| 9aaba0d6 |
1 | *$ CREATE DT_INIT.FOR |
| 2 | *COPY DT_INIT |
| 3 | * |
| 4 | * +-------------------------------------------------------------+ |
| 5 | * | | |
| 6 | * | | |
| 7 | * | DPMJET 3.0 | |
| 8 | * | | |
| 9 | * | | |
| 10 | * | S. Roesler+), R. Engel#), J. Ranft*) | |
| 11 | * | | |
| 12 | * | +) CERN, SC-RP | |
| 13 | * | CH-1211 Geneva 23, Switzerland | |
| 14 | * | Email: Stefan.Roesler@cern.ch | |
| 15 | * | | |
| 16 | * | #) Institut fuer Kernphysik | |
| 17 | * | Forschungszentrum Karlsruhe | |
| 18 | * | D-76021 Karlsruhe, Germany | |
| 19 | * | | |
| 20 | * | *) University of Siegen, Dept. of Physics | |
| 21 | * | D-57068 Siegen, Germany | |
| 22 | * | | |
| 23 | * | | |
| 24 | * | http://home.cern.ch/sroesler/dpmjet3.html | |
| 25 | * | | |
| 26 | * | | |
| 27 | * | Monte Carlo models used for event generation: | |
| 28 | * | PHOJET 1.12, JETSET 7.4 and LEPTO 6.5.1 | |
| 29 | * | | |
| 30 | * +-------------------------------------------------------------+ |
| 31 | * |
| 32 | * |
| 33 | *===init===============================================================* |
| 34 | * |
| 35 | SUBROUTINE DT_INIT(NCASES,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR, |
| 36 | & IDP,IGLAU) |
| 37 | |
| 38 | ************************************************************************ |
| 39 | * Initialization of event generation * |
| 40 | * This version dated 7.4.98 is written by S. Roesler. * |
| 41 | * * |
| 42 | * Last change 27.12.2006 by S. Roesler. * |
| 43 | ************************************************************************ |
| 44 | |
| 45 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 46 | SAVE |
| 47 | |
| 48 | PARAMETER ( LINP = 10 , |
| 49 | & LOUT = 6 , |
| 50 | & LDAT = 9 ) |
| 51 | PARAMETER (ZERO=0.0D0,ONE=1.0D0) |
| 52 | |
| 53 | * particle properties (BAMJET index convention) |
| 54 | CHARACTER*8 ANAME |
| 55 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 56 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 57 | * names of hadrons used in input-cards |
| 58 | CHARACTER*8 BTYPE |
| 59 | COMMON /DTPAIN/ BTYPE(30) |
| 60 | * (original name: PAREVT) |
| 61 | LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX, |
| 62 | & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF |
| 63 | PARAMETER ( NALLWP = 39 ) |
| 64 | COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, |
| 65 | & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY, |
| 66 | & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV, |
| 67 | & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF |
| 68 | * (original name: INPFLG) |
| 69 | COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK |
| 70 | * (original name: FRBKCM) |
| 71 | PARAMETER ( MXFFBK = 6 ) |
| 72 | PARAMETER ( MXZFBK = 9 ) |
| 73 | PARAMETER ( MXNFBK = 10 ) |
| 74 | PARAMETER ( MXAFBK = 16 ) |
| 75 | PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 ) |
| 76 | PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 ) |
| 77 | PARAMETER ( NXAFBK = MXAFBK + 1 ) |
| 78 | PARAMETER ( MXPSST = 300 ) |
| 79 | PARAMETER ( MXPSFB = 41000 ) |
| 80 | LOGICAL LFRMBK, LNCMSS |
| 81 | COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST), |
| 82 | & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB), |
| 83 | & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK, |
| 84 | & IFRBKN (MXPSST), IFRBKZ (MXPSST), |
| 85 | & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST), |
| 86 | & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK), |
| 87 | & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK), |
| 88 | & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF, |
| 89 | & IFBFRB, NBUFBK, LFRMBK, LNCMSS |
| 90 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 91 | * emulsion treatment |
| 92 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), |
| 93 | & NCOMPO,IEMUL |
| 94 | * Glauber formalism: parameters |
| 95 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), |
| 96 | & BMAX(NCOMPX),BSTEP(NCOMPX), |
| 97 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), |
| 98 | & NSITEB,NSTATB |
| 99 | * Glauber formalism: cross sections |
| 100 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, |
| 101 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), |
| 102 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), |
| 103 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), |
| 104 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), |
| 105 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), |
| 106 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), |
| 107 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), |
| 108 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), |
| 109 | & BSLOPE,NEBINI,NQBINI |
| 110 | * interface HADRIN-DPM |
| 111 | COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA |
| 112 | * central particle production, impact parameter biasing |
| 113 | COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR |
| 114 | * parameter for intranuclear cascade |
| 115 | LOGICAL LPAULI |
| 116 | COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI |
| 117 | * various options for treatment of partons (DTUNUC 1.x) |
| 118 | * (chain recombination, Cronin,..) |
| 119 | LOGICAL LCO2CR,LINTPT |
| 120 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, |
| 121 | & LCO2CR,LINTPT |
| 122 | * threshold values for x-sampling (DTUNUC 1.x) |
| 123 | COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA, |
| 124 | & SSMIMQ,VVMTHR |
| 125 | * flags for input different options |
| 126 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 127 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 128 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 129 | * nuclear potential |
| 130 | LOGICAL LFERMI |
| 131 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, |
| 132 | & EBINDP(2),EBINDN(2),EPOT(2,210), |
| 133 | & ETACOU(2),ICOUL,LFERMI |
| 134 | * n-n cross section fluctuations |
| 135 | PARAMETER (NBINS = 1000) |
| 136 | COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT |
| 137 | * flags for particle decays |
| 138 | COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20), |
| 139 | & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20), |
| 140 | & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0 |
| 141 | * diquark-breaking mechanism |
| 142 | COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3 |
| 143 | * nucleon-nucleon event-generator |
| 144 | CHARACTER*8 CMODEL |
| 145 | LOGICAL LPHOIN |
| 146 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN |
| 147 | * properties of interacting particles |
| 148 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG |
| 149 | * properties of photon/lepton projectiles |
| 150 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC |
| 151 | * flags for diffractive interactions (DTUNUC 1.x) |
| 152 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF |
| 153 | * parameters for hA-diffraction |
| 154 | COMMON /DTDIHA/ DIBETA,DIALPH |
| 155 | * Lorentz-parameters of the current interaction |
| 156 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, |
| 157 | & UMO,PPCM,EPROJ,PPROJ |
| 158 | * kinematical cuts for lepton-nucleus interactions |
| 159 | COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX, |
| 160 | & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI |
| 161 | * VDM parameter for photon-nucleus interactions |
| 162 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) |
| 163 | * Glauber formalism: flags and parameters for statistics |
| 164 | LOGICAL LPROD |
| 165 | CHARACTER*8 CGLB |
| 166 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD |
| 167 | * cuts for variable energy runs |
| 168 | COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI |
| 169 | * flags for activated histograms |
| 170 | COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL |
| 171 | COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) |
| bd378884 |
172 | COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) |
| 9aaba0d6 |
173 | * LEPTO |
| 174 | **LUND single / double precision |
| 175 | REAL CUT,PARL,TMPX,TMPY,TMPW2,TMPQ2,TMPU |
| 176 | COMMON /LEPTOU/ CUT(14),LST(40),PARL(30), |
| 177 | & TMPX,TMPY,TMPW2,TMPQ2,TMPU |
| 178 | * LEPTO |
| 179 | REAL RPPN |
| 180 | COMMON /LEPTOI/ RPPN,LEPIN,INTER |
| 181 | * steering flags for qel neutrino scattering modules |
| 182 | COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC |
| 183 | * event flag |
| 184 | COMMON /DTEVNO/ NEVENT,ICASCA |
| 185 | |
| 186 | INTEGER PYCOMP |
| 187 | |
| 188 | C DIMENSION XPARA(5) |
| 189 | DIMENSION XDUMB(40),IPRANG(5) |
| 190 | |
| 191 | PARAMETER (MXCARD=58) |
| 192 | CHARACTER*78 CLINE,CTITLE |
| 193 | CHARACTER*60 CWHAT |
| 194 | CHARACTER*8 BLANK,SDUM |
| 195 | CHARACTER*10 CODE,CODEWD |
| 196 | CHARACTER*72 HEADER |
| 197 | LOGICAL LSTART,LEINP,LXSTAB |
| 198 | DIMENSION WHAT(6),CODE(MXCARD) |
| 199 | DATA CODE/ |
| 200 | & 'TITLE ','PROJPAR ','TARPAR ','ENERGY ', |
| 201 | & 'MOMENTUM ','CMENERGY ','EMULSION ','FERMI ', |
| 202 | & 'TAUFOR ','PAULI ','COULOMB ','HADRIN ', |
| 203 | & 'EVAP ','EMCCHECK ','MODEL ','PHOINPUT ', |
| 204 | & 'GLAUBERI ','FLUCTUAT ','CENTRAL ','RECOMBIN ', |
| 205 | & 'COMBIJET ','XCUTS ','INTPT ','CRONINPT ', |
| 206 | & 'SEADISTR ','SEASU3 ','DIQUARKS ','RESONANC ', |
| 207 | & 'DIFFRACT ','SINGLECH ','NOFRAGME ','HADRONIZE ', |
| 208 | & 'POPCORN ','PARDECAY ','BEAM ','LUND-MSTU ', |
| 209 | & 'LUND-MSTJ ','LUND-MDCY ','LUND-PARJ ','LUND-PARU ', |
| 210 | & 'OUTLEVEL ','FRAME ','L-TAG ','L-ETAG ', |
| 211 | & 'ECMS-CUT ','VDM-PAR1 ','HISTOGRAM ','XS-TABLE ', |
| 212 | & 'GLAUB-PAR ','GLAUB-INI ','VDM-PAR2 ','XS-QELPRO ', |
| 213 | & 'RNDMINIT ','LEPTO-CUT ','LEPTO-LST ','LEPTO-PARL', |
| 214 | & 'START ','STOP '/ |
| 215 | DATA BLANK /' '/ |
| 216 | |
| 217 | DATA LSTART,LXSTAB,IFIRST /.TRUE.,.FALSE.,1/ |
| 218 | DATA CMEOLD /0.0D0/ |
| 219 | |
| 220 | *--------------------------------------------------------------------- |
| 221 | * at the first call of INIT: initialize event generation |
| 222 | EPNSAV = EPN |
| 223 | IF (LSTART) THEN |
| 224 | CALL DT_TITLE |
| 225 | * initialization and test of the random number generator |
| 226 | IF (ITRSPT.NE.1) THEN |
| 227 | CALL DT_RNDMST(22,54,76,92) |
| 228 | CALL DT_RNDMTE(1) |
| 229 | ENDIF |
| 230 | * initialization of BAMJET, DECAY and HADRIN |
| 231 | CALL DT_DDATAR |
| 232 | CALL DT_DHADDE |
| 233 | CALL DT_DCHANT |
| 234 | CALL DT_DCHANH |
| 235 | * set default values for input variables |
| 236 | CALL DT_DEFAUL(EPN,PPN) |
| 237 | IGLAU = 0 |
| 238 | IXSQEL = 0 |
| 239 | * flag for collision energy input |
| 240 | LEINP = .FALSE. |
| 241 | LSTART = .FALSE. |
| 242 | ENDIF |
| 243 | |
| 244 | *--------------------------------------------------------------------- |
| 245 | 10 CONTINUE |
| 246 | |
| 247 | * bypass reading input cards (e.g. for use with Fluka) |
| 248 | * in this case Epn is expected to carry the beam momentum |
| 249 | IF (NCASES.EQ.-1) THEN |
| 250 | IP = NPMASS |
| 251 | IPZ = NPCHAR |
| 252 | PPN = EPNSAV |
| 253 | EPN = ZERO |
| 254 | CMENER = ZERO |
| 255 | LEINP = .TRUE. |
| 256 | MKCRON = 0 |
| 257 | WHAT(1) = 1 |
| 258 | WHAT(2) = 0 |
| 259 | CODEWD = 'START ' |
| 260 | GOTO 900 |
| 261 | ENDIF |
| 262 | |
| 263 | * read control card from input-unit LINP |
| 264 | READ(LINP,'(A78)',END=9999) CLINE |
| 265 | IF (CLINE(1:1).EQ.'*') THEN |
| 266 | * comment-line |
| 267 | WRITE(LOUT,'(A78)') CLINE |
| 268 | GOTO 10 |
| 269 | ENDIF |
| 270 | C READ(CLINE,1000,END=9999) CODEWD,(WHAT(I),I=1,6),SDUM |
| 271 | C1000 FORMAT(A10,6E10.0,A8) |
| 272 | DO 1008 I=1,6 |
| 273 | WHAT(I) = ZERO |
| 274 | 1008 CONTINUE |
| 275 | READ(CLINE,1006,END=9999) CODEWD,CWHAT,SDUM |
| 276 | 1006 FORMAT(A10,A60,A8) |
| 277 | READ(CWHAT,*,END=1007) (WHAT(I),I=1,6) |
| 278 | 1007 CONTINUE |
| 279 | WRITE(LOUT,1001) CODEWD,(WHAT(I),I=1,6),SDUM |
| 280 | 1001 FORMAT(A10,6G10.3,A8) |
| 281 | |
| 282 | 900 CONTINUE |
| 283 | |
| 284 | * check for valid control card and get card index |
| 285 | ICW = 0 |
| 286 | DO 11 I=1,MXCARD |
| 287 | IF (CODEWD.EQ.CODE(I)) ICW = I |
| 288 | 11 CONTINUE |
| 289 | IF (ICW.EQ.0) THEN |
| 290 | WRITE(LOUT,1002) CODEWD |
| 291 | 1002 FORMAT(/,1X,'---> ',A10,': invalid control-card !',/) |
| 292 | GOTO 10 |
| 293 | ENDIF |
| 294 | |
| 295 | GOTO( |
| 296 | *------------------------------------------------------------ |
| 297 | * TITLE , PROJPAR , TARPAR , ENERGY , MOMENTUM, |
| 298 | & 100 , 110 , 120 , 130 , 140 , |
| 299 | * |
| 300 | *------------------------------------------------------------ |
| 301 | * CMENERGY, EMULSION, FERMI , TAUFOR , PAULI , |
| 302 | & 150 , 160 , 170 , 180 , 190 , |
| 303 | * |
| 304 | *------------------------------------------------------------ |
| 305 | * COULOMB , HADRIN , EVAP , EMCCHECK, MODEL , |
| 306 | & 200 , 210 , 220 , 230 , 240 , |
| 307 | * |
| 308 | *------------------------------------------------------------ |
| 309 | * PHOINPUT, GLAUBERI, FLUCTUAT, CENTRAL , RECOMBIN, |
| 310 | & 250 , 260 , 270 , 280 , 290 , |
| 311 | * |
| 312 | *------------------------------------------------------------ |
| 313 | * COMBIJET, XCUTS , INTPT , CRONINPT, SEADISTR, |
| 314 | & 300 , 310 , 320 , 330 , 340 , |
| 315 | * |
| 316 | *------------------------------------------------------------ |
| 317 | * SEASU3 , DIQUARKS, RESONANC, DIFFRACT, SINGLECH, |
| 318 | & 350 , 360 , 370 , 380 , 390 , |
| 319 | * |
| 320 | *------------------------------------------------------------ |
| 321 | * NOFRAGME, HADRONIZE, POPCORN , PARDECAY, BEAM , |
| 322 | & 400 , 410 , 420 , 430 , 440 , |
| 323 | * |
| 324 | *------------------------------------------------------------ |
| 325 | * LUND-MSTU, LUND-MSTJ, LUND-MDCY, LUND-PARJ, LUND-PARU, |
| 326 | & 450 , 451 , 452 , 460 , 470 , |
| 327 | * |
| 328 | *------------------------------------------------------------ |
| 329 | * OUTLEVEL, FRAME , L-TAG , L-ETAG , ECMS-CUT, |
| 330 | & 480 , 490 , 500 , 510 , 520 , |
| 331 | * |
| 332 | *------------------------------------------------------------ |
| 333 | * VDM-PAR1, HISTOGRAM, XS-TABLE , GLAUB-PAR, GLAUB-INI, |
| 334 | & 530 , 540 , 550 , 560 , 565 , |
| 335 | * |
| 336 | *------------------------------------------------------------ |
| 337 | * , , VDM-PAR2, XS-QELPRO, RNDMINIT , |
| 338 | & 570 , 580 , 590 , |
| 339 | * |
| 340 | *------------------------------------------------------------ |
| 341 | * LEPTO-CUT, LEPTO-LST,LEPTO-PARL, START , STOP ) |
| 342 | & 600 , 610 , 620 , 630 , 640 ) , ICW |
| 343 | * |
| 344 | *------------------------------------------------------------ |
| 345 | |
| 346 | GOTO 10 |
| 347 | |
| 348 | ********************************************************************* |
| 349 | * * |
| 350 | * control card: codewd = TITLE * |
| 351 | * * |
| 352 | * what (1..6), sdum no meaning * |
| 353 | * * |
| 354 | * Note: The control-card following this must consist of * |
| 355 | * a string of characters usually giving the title of * |
| 356 | * the run. * |
| 357 | * * |
| 358 | ********************************************************************* |
| 359 | |
| 360 | 100 CONTINUE |
| 361 | READ(LINP,'(A78)') CTITLE |
| 362 | WRITE(LOUT,'(//,5X,A78,//)') CTITLE |
| 363 | GOTO 10 |
| 364 | |
| 365 | ********************************************************************* |
| 366 | * * |
| 367 | * control card: codewd = PROJPAR * |
| 368 | * * |
| 369 | * what (1) = mass number of projectile nucleus default: 1 * |
| 370 | * what (2) = charge of projectile nucleus default: 1 * |
| 371 | * what (3..6) no meaning * |
| 372 | * sdum projectile particle code word * |
| 373 | * * |
| 374 | * Note: If sdum is defined what (1..2) have no meaning. * |
| 375 | * * |
| 376 | ********************************************************************* |
| 377 | |
| 378 | 110 CONTINUE |
| 379 | IF (SDUM.EQ.BLANK) THEN |
| 380 | IP = INT(WHAT(1)) |
| 381 | IPZ = INT(WHAT(2)) |
| 382 | IJPROJ = 1 |
| 383 | IBPROJ = 1 |
| 384 | ELSE |
| 385 | IJPROJ = 0 |
| 386 | DO 111 II=1,30 |
| 387 | IF (SDUM.EQ.BTYPE(II)) THEN |
| 388 | IP = 1 |
| 389 | IPZ = 1 |
| 390 | IF (II.EQ.26) THEN |
| 391 | IJPROJ = 135 |
| 392 | ELSEIF (II.EQ.27) THEN |
| 393 | IJPROJ = 136 |
| 394 | ELSEIF (II.EQ.28) THEN |
| 395 | IJPROJ = 133 |
| 396 | ELSEIF (II.EQ.29) THEN |
| 397 | IJPROJ = 134 |
| 398 | ELSE |
| 399 | IJPROJ = II |
| 400 | ENDIF |
| 401 | IBPROJ = IIBAR(IJPROJ) |
| 402 | * photon |
| 403 | IF ((IJPROJ.EQ.7).AND.(WHAT(1).GT.ZERO)) VIRT = WHAT(1) |
| 404 | * lepton |
| 405 | IF (((IJPROJ.EQ. 3).OR.(IJPROJ.EQ. 4).OR. |
| 406 | & (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11)).AND. |
| 407 | & (WHAT(1).GT.ZERO)) Q2HI = WHAT(1) |
| 408 | ENDIF |
| 409 | 111 CONTINUE |
| 410 | IF (IJPROJ.EQ.0) THEN |
| 411 | WRITE(LOUT,1110) |
| 412 | 1110 FORMAT(/,1X,'invalid PROJPAR card !',/) |
| 413 | GOTO 9999 |
| 414 | ENDIF |
| 415 | ENDIF |
| 416 | GOTO 10 |
| 417 | |
| 418 | ********************************************************************* |
| 419 | * * |
| 420 | * control card: codewd = TARPAR * |
| 421 | * * |
| 422 | * what (1) = mass number of target nucleus default: 1 * |
| 423 | * what (2) = charge of target nucleus default: 1 * |
| 424 | * what (3..6) no meaning * |
| 425 | * sdum target particle code word * |
| 426 | * * |
| 427 | * Note: If sdum is defined what (1..2) have no meaning. * |
| 428 | * * |
| 429 | ********************************************************************* |
| 430 | |
| 431 | 120 CONTINUE |
| 432 | IF (SDUM.EQ.BLANK) THEN |
| 433 | IT = INT(WHAT(1)) |
| 434 | ITZ = INT(WHAT(2)) |
| 435 | IJTARG = 1 |
| 436 | IBTARG = 1 |
| 437 | ELSE |
| 438 | IJTARG = 0 |
| 439 | DO 121 II=1,30 |
| 440 | IF (SDUM.EQ.BTYPE(II)) THEN |
| 441 | IT = 1 |
| 442 | ITZ = 1 |
| 443 | IJTARG = II |
| 444 | IBTARG = IIBAR(IJTARG) |
| 445 | ENDIF |
| 446 | 121 CONTINUE |
| 447 | IF (IJTARG.EQ.0) THEN |
| 448 | WRITE(LOUT,1120) |
| 449 | 1120 FORMAT(/,1X,'invalid TARPAR card !',/) |
| 450 | GOTO 9999 |
| 451 | ENDIF |
| 452 | ENDIF |
| 453 | GOTO 10 |
| 454 | |
| 455 | ********************************************************************* |
| 456 | * * |
| 457 | * control card: codewd = ENERGY * |
| 458 | * * |
| 459 | * what (1) = energy (GeV) of projectile in Lab. * |
| 460 | * if what(1) < 0: |what(1)| = kinetic energy * |
| 461 | * default: 200 GeV * |
| 462 | * if |what(2)| > 0: min. energy for variable * |
| 463 | * energy runs * |
| 464 | * what (2) = max. energy for variable energy runs * |
| 465 | * if what(2) < 0: |what(2)| = kinetic energy * |
| 466 | * * |
| 467 | ********************************************************************* |
| 468 | |
| 469 | 130 CONTINUE |
| 470 | EPN = WHAT(1) |
| 471 | PPN = ZERO |
| 472 | CMENER = ZERO |
| 473 | IF ((ABS(WHAT(2)).GT.ZERO).AND. |
| 474 | & (ABS(WHAT(2)).GT.ABS(WHAT(1)))) THEN |
| 475 | VARELO = WHAT(1) |
| 476 | VAREHI = WHAT(2) |
| 477 | EPN = VAREHI |
| 478 | ENDIF |
| 479 | LEINP = .TRUE. |
| 480 | GOTO 10 |
| 481 | |
| 482 | ********************************************************************* |
| 483 | * * |
| 484 | * control card: codewd = MOMENTUM * |
| 485 | * * |
| 486 | * what (1) = momentum (GeV/c) of projectile in Lab. * |
| 487 | * default: 200 GeV/c * |
| 488 | * what (2..6), sdum no meaning * |
| 489 | * * |
| 490 | ********************************************************************* |
| 491 | |
| 492 | 140 CONTINUE |
| 493 | EPN = ZERO |
| 494 | PPN = WHAT(1) |
| 495 | CMENER = ZERO |
| 496 | LEINP = .TRUE. |
| 497 | GOTO 10 |
| 498 | |
| 499 | ********************************************************************* |
| 500 | * * |
| 501 | * control card: codewd = CMENERGY * |
| 502 | * * |
| 503 | * what (1) = energy in nucleon-nucleon cms. * |
| 504 | * default: none * |
| 505 | * what (2..6), sdum no meaning * |
| 506 | * * |
| 507 | ********************************************************************* |
| 508 | |
| 509 | 150 CONTINUE |
| 510 | EPN = ZERO |
| 511 | PPN = ZERO |
| 512 | CMENER = WHAT(1) |
| 513 | LEINP = .TRUE. |
| 514 | GOTO 10 |
| 515 | |
| 516 | ********************************************************************* |
| 517 | * * |
| 518 | * control card: codewd = EMULSION * |
| 519 | * * |
| 520 | * definition of nuclear emulsions * |
| 521 | * * |
| 522 | * what(1) mass number of emulsion component * |
| 523 | * what(2) charge of emulsion component * |
| 524 | * what(3) fraction of events in which a scattering on a * |
| 525 | * nucleus of this properties is performed * |
| 526 | * what(4,5,6) as what(1,2,3) but for another component * |
| 527 | * default: no emulsion * |
| 528 | * sdum no meaning * |
| 529 | * * |
| 530 | * Note: If this input-card is once used with valid parameters * |
| 531 | * TARPAR is obsolete. * |
| 532 | * Not the absolute values of the fractions are important * |
| 533 | * but only the ratios of fractions of different comp. * |
| 534 | * This control card can be repeatedly used to define * |
| 535 | * emulsions consisting of up to 10 elements. * |
| 536 | * * |
| 537 | ********************************************************************* |
| 538 | |
| 539 | 160 CONTINUE |
| 540 | IF ((WHAT(1).GT.ZERO).AND.(WHAT(2).GT.ZERO) |
| 541 | & .AND.(ABS(WHAT(3)).GT.ZERO)) THEN |
| 542 | NCOMPO = NCOMPO+1 |
| 543 | IF (NCOMPO.GT.NCOMPX) THEN |
| 544 | WRITE(LOUT,1600) |
| 545 | STOP |
| 546 | ENDIF |
| 547 | IEMUMA(NCOMPO) = INT(WHAT(1)) |
| 548 | IEMUCH(NCOMPO) = INT(WHAT(2)) |
| 549 | EMUFRA(NCOMPO) = WHAT(3) |
| 550 | IEMUL = 1 |
| 551 | C CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO)) |
| 552 | ENDIF |
| 553 | IF ((WHAT(4).GT.ZERO).AND.(WHAT(5).GT.ZERO) |
| 554 | & .AND.(ABS(WHAT(6)).GT.ZERO)) THEN |
| 555 | NCOMPO = NCOMPO+1 |
| 556 | IF (NCOMPO.GT.NCOMPX) THEN |
| 557 | WRITE(LOUT,1001) |
| 558 | STOP |
| 559 | ENDIF |
| 560 | IEMUMA(NCOMPO) = INT(WHAT(4)) |
| 561 | IEMUCH(NCOMPO) = INT(WHAT(5)) |
| 562 | EMUFRA(NCOMPO) = WHAT(6) |
| 563 | C CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO)) |
| 564 | ENDIF |
| 565 | 1600 FORMAT(1X,'too many emulsion components - program stopped') |
| 566 | GOTO 10 |
| 567 | |
| 568 | ********************************************************************* |
| 569 | * * |
| 570 | * control card: codewd = FERMI * |
| 571 | * * |
| 572 | * what (1) = -1 Fermi-motion of nucleons not treated * |
| 573 | * default: 1 * |
| 574 | * what (2) = scale factor for Fermi-momentum * |
| 575 | * default: 0.75 * |
| 576 | * what (3..6), sdum no meaning * |
| 577 | * * |
| 578 | ********************************************************************* |
| 579 | |
| 580 | 170 CONTINUE |
| 581 | IF (WHAT(1).EQ.-1.0D0) THEN |
| 582 | LFERMI = .FALSE. |
| 583 | ELSE |
| 584 | LFERMI = .TRUE. |
| 585 | ENDIF |
| 586 | XMOD = WHAT(2) |
| 587 | IF (XMOD.GE.ZERO) FERMOD = XMOD |
| 588 | GOTO 10 |
| 589 | |
| 590 | ********************************************************************* |
| 591 | * * |
| 592 | * control card: codewd = TAUFOR * |
| 593 | * * |
| 594 | * formation time supressed intranuclear cascade * |
| 595 | * * |
| 596 | * what (1) formation time (in fm/c) * |
| 597 | * note: what(1)=10. corresponds roughly to an * |
| 598 | * average formation time of 1 fm/c * |
| 599 | * default: 5. fm/c * |
| 600 | * what (2) number of generations followed * |
| 601 | * default: 25 * |
| 602 | * what (3) = 1. p_t-dependent formation zone * |
| 603 | * = 2. constant formation zone * |
| 604 | * default: 1 * |
| 605 | * what (4) modus of selection of nucleus where the * |
| 606 | * cascade if followed first * |
| 607 | * = 1. proj./target-nucleus with probab. 1/2 * |
| 608 | * = 2. nucleus with highest mass * |
| 609 | * = 3. proj. nucleus if particle is moving in pos. z * |
| 610 | * targ. nucleus if particle is moving in neg. z * |
| 611 | * default: 1 * |
| 612 | * what (5..6), sdum no meaning * |
| 613 | * * |
| 614 | ********************************************************************* |
| 615 | |
| 616 | 180 CONTINUE |
| 617 | TAUFOR = WHAT(1) |
| 618 | KTAUGE = INT(WHAT(2)) |
| 619 | INCMOD = 1 |
| 620 | IF ((WHAT(3).GE.1.0D0).AND.(WHAT(3).LE.2.0D0)) |
| 621 | & ITAUVE = INT(WHAT(3)) |
| 622 | IF ((WHAT(4).GE.1.0D0).AND.(WHAT(4).LE.3.0D0)) |
| 623 | & INCMOD = INT(WHAT(4)) |
| 624 | GOTO 10 |
| 625 | |
| 626 | ********************************************************************* |
| 627 | * * |
| 628 | * control card: codewd = PAULI * |
| 629 | * * |
| 630 | * what (1) = -1 Pauli's principle for secondary * |
| 631 | * interactions not treated * |
| 632 | * default: 1 * |
| 633 | * what (2..6), sdum no meaning * |
| 634 | * * |
| 635 | ********************************************************************* |
| 636 | |
| 637 | 190 CONTINUE |
| 638 | IF (WHAT(1).EQ.-1.0D0) THEN |
| 639 | LPAULI = .FALSE. |
| 640 | ELSE |
| 641 | LPAULI = .TRUE. |
| 642 | ENDIF |
| 643 | GOTO 10 |
| 644 | |
| 645 | ********************************************************************* |
| 646 | * * |
| 647 | * control card: codewd = COULOMB * |
| 648 | * * |
| 649 | * what (1) = -1. Coulomb-energy treatment switched off * |
| 650 | * default: 1 * |
| 651 | * what (2..6), sdum no meaning * |
| 652 | * * |
| 653 | ********************************************************************* |
| 654 | |
| 655 | 200 CONTINUE |
| 656 | ICOUL = 1 |
| 657 | IF (WHAT(1).EQ.-1.0D0) THEN |
| 658 | ICOUL = 0 |
| 659 | ELSE |
| 660 | ICOUL = 1 |
| 661 | ENDIF |
| 662 | GOTO 10 |
| 663 | |
| 664 | ********************************************************************* |
| 665 | * * |
| 666 | * control card: codewd = HADRIN * |
| 667 | * * |
| 668 | * HADRIN module * |
| 669 | * * |
| 670 | * what (1) = 0. elastic/inelastic interactions with probab. * |
| 671 | * as defined by cross-sections * |
| 672 | * = 1. inelastic interactions forced * |
| 673 | * = 2. elastic interactions forced * |
| 674 | * default: 1 * |
| 675 | * what (2) upper threshold in total energy (GeV) below * |
| 676 | * which interactions are sampled by HADRIN * |
| 677 | * default: 5. GeV * |
| 678 | * what (3..6), sdum no meaning * |
| 679 | * * |
| 680 | ********************************************************************* |
| 681 | |
| 682 | 210 CONTINUE |
| 683 | IWHAT = INT(WHAT(1)) |
| 684 | IF ((IWHAT.GE.0).AND.(IWHAT.LE.2)) INTHAD = IWHAT |
| 685 | IF ((WHAT(2).GT.ZERO).AND.(WHAT(2).LT.15.0D0)) EHADTH = WHAT(2) |
| 686 | GOTO 10 |
| 687 | |
| 688 | ********************************************************************* |
| 689 | * * |
| 690 | * control card: codewd = EVAP * |
| 691 | * * |
| 692 | * evaporation module * |
| 693 | * * |
| 694 | * what (1) =< -1 ==> evaporation is switched off * |
| 695 | * >= 1 ==> evaporation is performed * |
| 696 | * * |
| 697 | * what (1) = i1 + i2*10 + i3*100 + i4*10000 * |
| 698 | * (i1, i2, i3, i4 >= 0 ) * |
| 699 | * * |
| 700 | * i1 is the flag for selecting the T=0 level density option used * |
| 701 | * = 1: standard EVAP level densities with Cook pairing * |
| 702 | * energies * |
| 703 | * = 2: Z,N-dependent Gilbert & Cameron level densities * |
| 704 | * (default) * |
| 705 | * = 3: Julich A-dependent level densities * |
| 706 | * = 4: Z,N-dependent Brancazio & Cameron level densities * |
| 707 | * * |
| 708 | * i2 >= 1: high energy fission activated * |
| 709 | * (default high energy fission activated) * |
| 710 | * * |
| 711 | * i3 = 0: No energy dependence for level densities * |
| 712 | * = 1: Standard Ignyatuk (1975, 1st) energy dependence * |
| 713 | * for level densities (default) * |
| 714 | * = 2: Standard Ignyatuk (1975, 1st) energy dependence * |
| 715 | * for level densities with NOT used set of parameters * |
| 716 | * = 3: Standard Ignyatuk (1975, 1st) energy dependence * |
| 717 | * for level densities with NOT used set of parameters * |
| 718 | * = 4: Second Ignyatuk (1975, 2nd) energy dependence * |
| 719 | * for level densities * |
| 720 | * = 5: Second Ignyatuk (1975, 2nd) energy dependence * |
| 721 | * for level densities with fit 1 Iljinov & Mebel set of * |
| 722 | * parameters * |
| 723 | * = 6: Second Ignyatuk (1975, 2nd) energy dependence * |
| 724 | * for level densities with fit 2 Iljinov & Mebel set of * |
| 725 | * parameters * |
| 726 | * = 7: Second Ignyatuk (1975, 2nd) energy dependence * |
| 727 | * for level densities with fit 3 Iljinov & Mebel set of * |
| 728 | * parameters * |
| 729 | * = 8: Second Ignyatuk (1975, 2nd) energy dependence * |
| 730 | * for level densities with fit 4 Iljinov & Mebel set of * |
| 731 | * parameters * |
| 732 | * * |
| 733 | * i4 >= 1: Original Gilbert and Cameron pairing energies used * |
| 734 | * (default Cook's modified pairing energies) * |
| 735 | * * |
| 736 | * what (2) = ig + 10 * if (ig and if must have the same sign) * |
| 737 | * * |
| 738 | * ig =< -1 ==> deexcitation gammas are not produced * |
| 739 | * (if the evaporation step is not performed * |
| 740 | * they are never produced) * |
| 741 | * if =< -1 ==> Fermi Break Up is not invoked * |
| 742 | * (if the evaporation step is not performed * |
| 743 | * it is never invoked) * |
| 744 | * The default is: deexcitation gamma produced and Fermi break up * |
| 745 | * activated for the new preequilibrium, not * |
| 746 | * activated otherwise. * |
| 747 | * what (3..6), sdum no meaning * |
| 748 | * * |
| 749 | ********************************************************************* |
| 750 | |
| 751 | 220 CONTINUE |
| 752 | WRITE(LOUT,1009) |
| 753 | 1009 FORMAT(1X,/,'Warning! Evaporation request rejected since', |
| 754 | & ' evaporation modules not available with this version.') |
| 755 | LEVPRT = .FALSE. |
| 756 | LDEEXG = .FALSE. |
| 757 | LHEAVY = .FALSE. |
| 758 | LFRMBK = .FALSE. |
| 759 | IFISS = 0 |
| 760 | IEVFSS = 0 |
| 761 | |
| 762 | GOTO 10 |
| 763 | |
| 764 | ********************************************************************* |
| 765 | * * |
| 766 | * control card: codewd = EMCCHECK * |
| 767 | * * |
| 768 | * extended energy-momentum / quantum-number conservation check * |
| 769 | * * |
| 770 | * what (1) = -1 extended check not performed * |
| 771 | * default: 1. * |
| 772 | * what (2..6), sdum no meaning * |
| 773 | * * |
| 774 | ********************************************************************* |
| 775 | |
| 776 | 230 CONTINUE |
| 777 | IF (WHAT(1).EQ.-1) THEN |
| 778 | LEMCCK = .FALSE. |
| 779 | ELSE |
| 780 | LEMCCK = .TRUE. |
| 781 | ENDIF |
| 782 | GOTO 10 |
| 783 | |
| 784 | ********************************************************************* |
| 785 | * * |
| 786 | * control card: codewd = MODEL * |
| 787 | * * |
| 788 | * Model to be used to treat nucleon-nucleon interactions * |
| 789 | * * |
| 790 | * sdum = DTUNUC two-chain model * |
| 791 | * = PHOJET multiple chains including minijets * |
| 792 | * = LEPTO DIS * |
| 793 | * = QNEUTRIN quasi-elastic neutrino scattering * |
| 794 | * default: PHOJET * |
| 795 | * * |
| 796 | * if sdum = LEPTO: * |
| 797 | * what (1) (variable INTER) * |
| 798 | * = 1 gamma exchange * |
| 799 | * = 2 W+- exchange * |
| 800 | * = 3 Z0 exchange * |
| 801 | * = 4 gamma/Z0 exchange * |
| 802 | * * |
| 803 | * if sdum = QNEUTRIN: * |
| 804 | * what (1) = 0 elastic scattering on nucleon and * |
| 805 | * tau does not decay (default) * |
| 806 | * = 1 decay of tau into mu.. * |
| 807 | * = 2 decay of tau into e.. * |
| 808 | * = 10 CC events on p and n * |
| 809 | * = 11 NC events on p and n * |
| 810 | * * |
| 811 | * what (2..6) no meaning * |
| 812 | * * |
| 813 | ********************************************************************* |
| 814 | |
| 815 | 240 CONTINUE |
| 816 | IF (SDUM.EQ.CMODEL(1)) THEN |
| 817 | MCGENE = 1 |
| 818 | ELSEIF (SDUM.EQ.CMODEL(2)) THEN |
| 819 | MCGENE = 2 |
| 820 | ELSEIF (SDUM.EQ.CMODEL(3)) THEN |
| 821 | MCGENE = 3 |
| 822 | IF ((WHAT(1).GE.1.0D0).AND.(WHAT(1).LE.4.0D0)) |
| 823 | & INTER = INT(WHAT(1)) |
| 824 | ELSEIF (SDUM.EQ.CMODEL(4)) THEN |
| 825 | MCGENE = 4 |
| 826 | IWHAT = INT(WHAT(1)) |
| 827 | IF ((IWHAT.EQ.1 ).OR.(IWHAT.EQ.2 ).OR. |
| 828 | & (IWHAT.EQ.10).OR.(IWHAT.EQ.11)) |
| 829 | & NEUDEC = IWHAT |
| 830 | ELSE |
| 831 | STOP ' Unknown model !' |
| 832 | ENDIF |
| 833 | GOTO 10 |
| 834 | |
| 835 | ********************************************************************* |
| 836 | * * |
| 837 | * control card: codewd = PHOINPUT * |
| 838 | * * |
| 839 | * Start of input-section for PHOJET-specific input-cards * |
| 840 | * Note: This section will not be finished before giving * |
| 841 | * ENDINPUT-card * |
| 842 | * what (1..6), sdum no meaning * |
| 843 | * * |
| 844 | ********************************************************************* |
| 845 | |
| 846 | 250 CONTINUE |
| 847 | IF (LPHOIN) THEN |
| 848 | CALL PHO_INIT(LINP,LOUT,IREJ1) |
| 849 | IF (IREJ1.NE.0) THEN |
| 850 | WRITE(LOUT,'(1X,A)')'INIT: reading PHOJET-input failed' |
| 851 | STOP |
| 852 | ENDIF |
| 853 | LPHOIN = .FALSE. |
| 854 | ENDIF |
| 855 | GOTO 10 |
| 856 | |
| 857 | ********************************************************************* |
| 858 | * * |
| 859 | * control card: codewd = GLAUBERI * |
| 860 | * * |
| 861 | * Pre-initialization of impact parameter selection * |
| 862 | * * |
| 863 | * what (1..6), sdum no meaning * |
| 864 | * * |
| 865 | ********************************************************************* |
| 866 | |
| 867 | 260 CONTINUE |
| 868 | IF (IFIRST.NE.99) THEN |
| 869 | CALL DT_RNDMST(12,34,56,78) |
| 870 | CALL DT_RNDMTE(1) |
| 871 | OPEN(40,FILE='outdata0/shm.out',STATUS='UNKNOWN') |
| 872 | C OPEN(11,FILE='outdata0/shm.dbg',STATUS='UNKNOWN') |
| 873 | IFIRST = 99 |
| 874 | ENDIF |
| 875 | |
| 876 | IPPN = 8 |
| 877 | PLOW = 10.0D0 |
| 878 | C IPPN = 1 |
| 879 | C PLOW = 100.0D0 |
| 880 | PHI = 1.0D5 |
| 881 | APLOW = LOG10(PLOW) |
| 882 | APHI = LOG10(PHI) |
| 883 | ADP = (APHI-APLOW)/DBLE(IPPN) |
| 884 | |
| 885 | IPLOW = 1 |
| 886 | IDIP = 1 |
| 887 | IIP = 5 |
| 888 | C IPLOW = 1 |
| 889 | C IDIP = 1 |
| 890 | C IIP = 1 |
| 891 | IPRANG(1) = 1 |
| 892 | IPRANG(2) = 2 |
| 893 | IPRANG(3) = 5 |
| 894 | IPRANG(4) = 10 |
| 895 | IPRANG(5) = 20 |
| 896 | |
| 897 | ITLOW = 30 |
| 898 | IDIT = 3 |
| 899 | IIT = 60 |
| 900 | C IDIT = 10 |
| 901 | C IIT = 21 |
| 902 | |
| 903 | DO 473 NCIT=1,IIT |
| 904 | IT = ITLOW+(NCIT-1)*IDIT |
| 905 | C IPHI = IT |
| 906 | C IDIP = 10 |
| 907 | C IIP = (IPHI-IPLOW)/IDIP |
| 908 | C IF (IIP.EQ.0) IIP = 1 |
| 909 | C IF (IT.EQ.IPLOW) IIP = 0 |
| 910 | |
| 911 | DO 472 NCIP=1,IIP |
| 912 | IP = IPRANG(NCIP) |
| 913 | CC IF (NCIP.LE.IIP) THEN |
| 914 | C IP = IPLOW+(NCIP-1)*IDIP |
| 915 | CC ELSE |
| 916 | CC IP = IT |
| 917 | CC ENDIF |
| 918 | IF (IP.GT.IT) GOTO 472 |
| 919 | |
| 920 | DO 471 NCP=1,IPPN+1 |
| 921 | APPN = APLOW+DBLE(NCP-1)*ADP |
| 922 | PPN = 10**APPN |
| 923 | |
| 924 | OPEN(12,FILE='outdata0/shm.sta',STATUS='UNKNOWN') |
| 925 | WRITE(12,'(1X,2I5,E15.3)') IP,IT,PPN |
| 926 | CLOSE(12) |
| 927 | |
| 928 | XLIM1 = 0.0D0 |
| 929 | XLIM2 = 50.0D0 |
| 930 | XLIM3 = ZERO |
| 931 | IBIN = 50 |
| 932 | CALL DT_NEWHGR(XDUM,XDUM,XDUM,XDUMB,-1,IHDUM) |
| 933 | CALL DT_NEWHGR(XLIM1,XLIM2,XLIM3,XDUMB,IBIN,IHSHMA) |
| 934 | |
| 935 | NEVFIT = 5 |
| 936 | C IF ((IP.GT.10).OR.(IT.GT.10)) THEN |
| 937 | C NEVFIT = 5 |
| 938 | C ELSE |
| 939 | C NEVFIT = 10 |
| 940 | C ENDIF |
| 941 | SIGAV = 0.0D0 |
| 942 | |
| 943 | DO 478 I=1,NEVFIT |
| 944 | CALL DT_SHMAKI(IP,IDUM1,IT,IDUM1,IJPROJ,PPN,99) |
| 945 | SIGAV = SIGAV+XSPRO(1,1,1) |
| 946 | DO 479 J=1,50 |
| 947 | XC = DBLE(J) |
| 948 | CALL DT_FILHGR(XC,BSITE(1,1,1,J),IHSHMA,I) |
| 949 | 479 CONTINUE |
| 950 | 478 CONTINUE |
| 951 | |
| 952 | CALL DT_EVTHIS(IDUM) |
| 953 | HEADER = ' BSITE' |
| 954 | C CALL OUTGEN(IHSHMA,0,0,0,0,0,HEADER,0,NEVFIT,ONE,0,1,-1) |
| 955 | |
| 956 | C CALL GENFIT(XPARA) |
| 957 | C WRITE(40,'(2I4,E11.3,F6.0,5E11.3)') |
| 958 | C & IP,IT,PPN,SIGAV/DBLE(NEVFIT),XPARA |
| 959 | |
| 960 | 471 CONTINUE |
| 961 | |
| 962 | 472 CONTINUE |
| 963 | |
| 964 | 473 CONTINUE |
| 965 | |
| 966 | STOP |
| 967 | |
| 968 | ********************************************************************* |
| 969 | * * |
| 970 | * control card: codewd = FLUCTUAT * |
| 971 | * * |
| 972 | * Treatment of cross section fluctuations * |
| 973 | * * |
| 974 | * what (1) = 1 treat cross section fluctuations * |
| 975 | * default: 0. * |
| 976 | * what (1..6), sdum no meaning * |
| 977 | * * |
| 978 | ********************************************************************* |
| 979 | |
| 980 | 270 CONTINUE |
| 981 | IFLUCT = 0 |
| 982 | IF (WHAT(1).EQ.ONE) THEN |
| 983 | IFLUCT = 1 |
| 984 | CALL DT_FLUINI |
| 985 | ENDIF |
| 986 | GOTO 10 |
| 987 | |
| 988 | ********************************************************************* |
| 989 | * * |
| 990 | * control card: codewd = CENTRAL * |
| 991 | * * |
| 992 | * what (1) = 1. central production forced default: 0 * |
| 993 | * if what (1) < 0 and > -100 * |
| 994 | * what (2) = min. impact parameter default: 0 * |
| 995 | * what (3) = max. impact parameter default: b_max * |
| 996 | * if what (1) < -99 * |
| 997 | * what (2) = fraction of cross section default: 1 * |
| 998 | * if what (1) = -1 : evaporation/fzc suppressed * |
| 999 | * if what (1) < -1 : evaporation/fzc allowed * |
| 1000 | * * |
| 1001 | * what (4..6), sdum no meaning * |
| 1002 | * * |
| 1003 | ********************************************************************* |
| 1004 | |
| 1005 | 280 CONTINUE |
| 1006 | ICENTR = INT(WHAT(1)) |
| 1007 | IF (ICENTR.LT.0) THEN |
| 1008 | IF (ICENTR.GT.-100) THEN |
| 1009 | BIMIN = WHAT(2) |
| 1010 | BIMAX = WHAT(3) |
| 1011 | ELSE |
| 1012 | XSFRAC = WHAT(2) |
| 1013 | ENDIF |
| 1014 | ENDIF |
| 1015 | GOTO 10 |
| 1016 | |
| 1017 | ********************************************************************* |
| 1018 | * * |
| 1019 | * control card: codewd = RECOMBIN * |
| 1020 | * * |
| 1021 | * Chain recombination * |
| 1022 | * (recombine S-S and V-V chains to V-S chains) * |
| 1023 | * * |
| 1024 | * what (1) = -1. recombination switched off default: 1 * |
| 1025 | * what (2..6), sdum no meaning * |
| 1026 | * * |
| 1027 | ********************************************************************* |
| 1028 | |
| 1029 | 290 CONTINUE |
| 1030 | IRECOM = 1 |
| 1031 | IF (WHAT(1).EQ.-1.0D0) IRECOM = 0 |
| 1032 | GOTO 10 |
| 1033 | |
| 1034 | ********************************************************************* |
| 1035 | * * |
| 1036 | * control card: codewd = COMBIJET * |
| 1037 | * * |
| 1038 | * chain fusion (2 q-aq --> qq-aqaq) * |
| 1039 | * * |
| 1040 | * what (1) = 1 fusion treated * |
| 1041 | * default: 0. * |
| 1042 | * what (2) minimum number of uncombined chains from * |
| 1043 | * single projectile or target nucleons * |
| 1044 | * default: 0. * |
| 1045 | * what (3..6), sdum no meaning * |
| 1046 | * * |
| 1047 | ********************************************************************* |
| 1048 | |
| 1049 | 300 CONTINUE |
| 1050 | LCO2CR = .FALSE. |
| 1051 | IF (INT(WHAT(1)).EQ.1) LCO2CR = .TRUE. |
| 1052 | IF (WHAT(2).GE.ZERO) CUTOF = WHAT(2) |
| 1053 | GOTO 10 |
| 1054 | |
| 1055 | ********************************************************************* |
| 1056 | * * |
| 1057 | * control card: codewd = XCUTS * |
| 1058 | * * |
| 1059 | * thresholds for x-sampling * |
| 1060 | * * |
| 1061 | * what (1) defines lower threshold for val.-q x-value (CVQ) * |
| 1062 | * default: 1. * |
| 1063 | * what (2) defines lower threshold for val.-qq x-value (CDQ) * |
| 1064 | * default: 2. * |
| 1065 | * what (3) defines lower threshold for sea-q x-value (CSEA) * |
| 1066 | * default: 0.2 * |
| 1067 | * what (4) sea-q x-values in S-S chains (SSMIMA) * |
| 1068 | * default: 0.14 * |
| 1069 | * what (5) not used * |
| 1070 | * default: 2. * |
| 1071 | * what (6), sdum no meaning * |
| 1072 | * * |
| 1073 | * Note: Lower thresholds (what(1..3)) are def. as x_thr=CXXX/ECM * |
| 1074 | * * |
| 1075 | ********************************************************************* |
| 1076 | |
| 1077 | 310 CONTINUE |
| 1078 | IF (WHAT(1).GE.0.5D0) CVQ = WHAT(1) |
| 1079 | IF (WHAT(2).GE.ONE) CDQ = WHAT(2) |
| 1080 | IF (WHAT(3).GE.0.1D0) CSEA = WHAT(3) |
| 1081 | IF (WHAT(4).GE.ZERO) THEN |
| 1082 | SSMIMA = WHAT(4) |
| 1083 | SSMIMQ = SSMIMA**2 |
| 1084 | ENDIF |
| 1085 | IF (WHAT(5).GT.2.0D0) VVMTHR = WHAT(5) |
| 1086 | GOTO 10 |
| 1087 | |
| 1088 | ********************************************************************* |
| 1089 | * * |
| 1090 | * control card: codewd = INTPT * |
| 1091 | * * |
| 1092 | * what (1) = -1 intrinsic transverse momenta of partons * |
| 1093 | * not treated default: 1 * |
| 1094 | * what (2..6), sdum no meaning * |
| 1095 | * * |
| 1096 | ********************************************************************* |
| 1097 | |
| 1098 | 320 CONTINUE |
| 1099 | IF (WHAT(1).EQ.-1.0D0) THEN |
| 1100 | LINTPT = .FALSE. |
| 1101 | ELSE |
| 1102 | LINTPT = .TRUE. |
| 1103 | ENDIF |
| 1104 | GOTO 10 |
| 1105 | |
| 1106 | ********************************************************************* |
| 1107 | * * |
| 1108 | * control card: codewd = CRONINPT * |
| 1109 | * * |
| 1110 | * Cronin effect (multiple scattering of partons at chain ends) * |
| 1111 | * * |
| 1112 | * what (1) = -1 Cronin effect not treated default: 1 * |
| 1113 | * what (2) = 0 scattering parameter default: 0.64 * |
| 1114 | * what (3..6), sdum no meaning * |
| 1115 | * * |
| 1116 | ********************************************************************* |
| 1117 | |
| 1118 | 330 CONTINUE |
| 1119 | IF (WHAT(1).EQ.-1.0D0) THEN |
| 1120 | MKCRON = 0 |
| 1121 | ELSE |
| 1122 | MKCRON = 1 |
| 1123 | ENDIF |
| 1124 | CRONCO = WHAT(2) |
| 1125 | GOTO 10 |
| 1126 | |
| 1127 | ********************************************************************* |
| 1128 | * * |
| 1129 | * control card: codewd = SEADISTR * |
| 1130 | * * |
| 1131 | * what (1) (XSEACO) sea(x) prop. 1/x**what (1) default: 1. * |
| 1132 | * what (2) (UNON) default: 2. * |
| 1133 | * what (3) (UNOM) default: 1.5 * |
| 1134 | * what (4) (UNOSEA) default: 5. * |
| 1135 | * qdis(x) prop. (1-x)**what (1) etc. * |
| 1136 | * what (5..6), sdum no meaning * |
| 1137 | * * |
| 1138 | ********************************************************************* |
| 1139 | |
| 1140 | 340 CONTINUE |
| 1141 | XSEACO = WHAT(1) |
| 1142 | XSEACU = 1.05D0-XSEACO |
| 1143 | UNON = WHAT(2) |
| 1144 | IF (UNON.LT.0.1D0) UNON = 2.0D0 |
| 1145 | UNOM = WHAT(3) |
| 1146 | IF (UNOM.LT.0.1D0) UNOM = 1.5D0 |
| 1147 | UNOSEA = WHAT(4) |
| 1148 | IF (UNOSEA.LT.0.1D0) UNOSEA = 5.0D0 |
| 1149 | GOTO 10 |
| 1150 | |
| 1151 | ********************************************************************* |
| 1152 | * * |
| 1153 | * control card: codewd = SEASU3 * |
| 1154 | * * |
| 1155 | * Treatment of strange-quarks at chain ends * |
| 1156 | * * |
| 1157 | * what (1) (SEASQ) strange-quark supression factor * |
| 1158 | * iflav = 1.+rndm*(2.+SEASQ) * |
| 1159 | * default: 1. * |
| 1160 | * what (2..6), sdum no meaning * |
| 1161 | * * |
| 1162 | ********************************************************************* |
| 1163 | |
| 1164 | 350 CONTINUE |
| 1165 | SEASQ = WHAT(1) |
| 1166 | GOTO 10 |
| 1167 | |
| 1168 | ********************************************************************* |
| 1169 | * * |
| 1170 | * control card: codewd = DIQUARKS * |
| 1171 | * * |
| 1172 | * what (1) = -1. sea-diquark/antidiquark-pairs not treated * |
| 1173 | * default: 1. * |
| 1174 | * what (2..6), sdum no meaning * |
| 1175 | * * |
| 1176 | ********************************************************************* |
| 1177 | |
| 1178 | 360 CONTINUE |
| 1179 | IF (WHAT(1).EQ.-1.0D0) THEN |
| 1180 | LSEADI = .FALSE. |
| 1181 | ELSE |
| 1182 | LSEADI = .TRUE. |
| 1183 | ENDIF |
| 1184 | GOTO 10 |
| 1185 | |
| 1186 | ********************************************************************* |
| 1187 | * * |
| 1188 | * control card: codewd = RESONANC * |
| 1189 | * * |
| 1190 | * treatment of low mass chains * |
| 1191 | * * |
| 1192 | * what (1) = -1 low chain masses are not corrected for resonance * |
| 1193 | * masses (obsolete for BAMJET-fragmentation) * |
| 1194 | * default: 1. * |
| 1195 | * what (2) = -1 massless partons default: 1. (massive) * |
| 1196 | * default: 1. (massive) * |
| 1197 | * what (3) = -1 chain-system containing chain of too small * |
| 1198 | * mass is rejected (note: this does not fully * |
| 1199 | * apply to S-S chains) default: 0. * |
| 1200 | * what (4..6), sdum no meaning * |
| 1201 | * * |
| 1202 | ********************************************************************* |
| 1203 | |
| 1204 | 370 CONTINUE |
| 1205 | IRESCO = 1 |
| 1206 | IMSHL = 1 |
| 1207 | IRESRJ = 0 |
| 1208 | IF (WHAT(1).EQ.-ONE) IRESCO = 0 |
| 1209 | IF (WHAT(2).EQ.-ONE) IMSHL = 0 |
| 1210 | IF (WHAT(3).EQ.-ONE) IRESRJ = 1 |
| 1211 | GOTO 10 |
| 1212 | |
| 1213 | ********************************************************************* |
| 1214 | * * |
| 1215 | * control card: codewd = DIFFRACT * |
| 1216 | * * |
| 1217 | * Treatment of diffractive events * |
| 1218 | * * |
| 1219 | * what (1) = (ISINGD) 0 no single diffraction * |
| 1220 | * 1 single diffraction included * |
| 1221 | * +-2 single diffractive events only * |
| 1222 | * +-3 projectile single diffraction only * |
| 1223 | * +-4 target single diffraction only * |
| 1224 | * -5 double pomeron exchange only * |
| 1225 | * (neg. sign applies to PHOJET events) * |
| 1226 | * default: 0. * |
| 1227 | * * |
| 1228 | * what (2) = (IDOUBD) 0 no double diffraction * |
| 1229 | * 1 double diffraction included * |
| 1230 | * 2 double diffractive events only * |
| 1231 | * default: 0. * |
| 1232 | * what (3) = 1 projectile diffraction treated (2-channel form.) * |
| 1233 | * default: 0. * |
| 1234 | * what (4) = alpha-parameter in projectile diffraction * |
| 1235 | * default: 0. * |
| 1236 | * what (5..6), sdum no meaning * |
| 1237 | * * |
| 1238 | ********************************************************************* |
| 1239 | |
| 1240 | 380 CONTINUE |
| 1241 | IF (ABS(WHAT(1)).GT.ZERO) ISINGD = INT(WHAT(1)) |
| 1242 | IF (ABS(WHAT(2)).GT.ZERO) IDOUBD = INT(WHAT(2)) |
| 1243 | IF ((ISINGD.GT.1).AND.(IDOUBD.GT.1)) THEN |
| 1244 | WRITE(LOUT,1380) |
| 1245 | 1380 FORMAT(1X,'INIT: inconsistent DIFFRACT - input !',/, |
| 1246 | & 11X,'IDOUBD is reset to zero') |
| 1247 | IDOUBD = 0 |
| 1248 | ENDIF |
| 1249 | IF (WHAT(3).GT.ZERO) DIBETA = WHAT(3) |
| 1250 | IF (WHAT(4).GT.ZERO) DIALPH = WHAT(4) |
| 1251 | GOTO 10 |
| 1252 | |
| 1253 | ********************************************************************* |
| 1254 | * * |
| 1255 | * control card: codewd = SINGLECH * |
| 1256 | * * |
| 1257 | * what (1) = 1. Regge contribution (one chain) included * |
| 1258 | * default: 0. * |
| 1259 | * what (2..6), sdum no meaning * |
| 1260 | * * |
| 1261 | ********************************************************************* |
| 1262 | |
| 1263 | 390 CONTINUE |
| 1264 | ISICHA = 0 |
| 1265 | IF (WHAT(1).EQ.ONE) ISICHA = 1 |
| 1266 | GOTO 10 |
| 1267 | |
| 1268 | ********************************************************************* |
| 1269 | * * |
| 1270 | * control card: codewd = NOFRAGME * |
| 1271 | * * |
| 1272 | * biased chain hadronization * |
| 1273 | * * |
| 1274 | * what (1..6) = -1 no of hadronizsation of S-S chains * |
| 1275 | * = -2 no of hadronizsation of D-S chains * |
| 1276 | * = -3 no of hadronizsation of S-D chains * |
| 1277 | * = -4 no of hadronizsation of S-V chains * |
| 1278 | * = -5 no of hadronizsation of D-V chains * |
| 1279 | * = -6 no of hadronizsation of V-S chains * |
| 1280 | * = -7 no of hadronizsation of V-D chains * |
| 1281 | * = -8 no of hadronizsation of V-V chains * |
| 1282 | * = -9 no of hadronizsation of comb. chains * |
| 1283 | * default: complete hadronization * |
| 1284 | * sdum no meaning * |
| 1285 | * * |
| 1286 | ********************************************************************* |
| 1287 | |
| 1288 | 400 CONTINUE |
| 1289 | DO 401 I=1,6 |
| 1290 | ICHAIN = INT(WHAT(I)) |
| 1291 | IF ((ICHAIN.LE.-1).AND.(ICHAIN.GE.-9)) |
| 1292 | & LHADRO(ABS(ICHAIN)) = .FALSE. |
| 1293 | 401 CONTINUE |
| 1294 | GOTO 10 |
| 1295 | |
| 1296 | ********************************************************************* |
| 1297 | * * |
| 1298 | * control card: codewd = HADRONIZE * |
| 1299 | * * |
| 1300 | * hadronization model and parameter switch * |
| 1301 | * * |
| 1302 | * what (1) = 1 hadronization via BAMJET * |
| 1303 | * = 2 hadronization via JETSET * |
| 1304 | * default: 2 * |
| 1305 | * what (2) = 1..3 parameter set to be used * |
| 1306 | * JETSET: 3 sets available * |
| 1307 | * ( = 3 default JETSET-parameters) * |
| 1308 | * BAMJET: 1 set available * |
| 1309 | * default: 1 * |
| 1310 | * what (3..6), sdum no meaning * |
| 1311 | * * |
| 1312 | ********************************************************************* |
| 1313 | |
| 1314 | 410 CONTINUE |
| 1315 | IWHAT1 = INT(WHAT(1)) |
| 1316 | IWHAT2 = INT(WHAT(2)) |
| 1317 | IF ((IWHAT1.EQ.1).OR.(IWHAT1.EQ.2)) IFRAG(1) = IWHAT1 |
| 1318 | IF ((IWHAT1.EQ.2).AND.(IWHAT2.GE.1).AND.(IWHAT2.LE.3)) |
| 1319 | & IFRAG(2) = IWHAT2 |
| 1320 | GOTO 10 |
| 1321 | |
| 1322 | ********************************************************************* |
| 1323 | * * |
| 1324 | * control card: codewd = POPCORN * |
| 1325 | * * |
| 1326 | * "Popcorn-effect" in fragmentation and diquark breaking diagrams * |
| 1327 | * * |
| 1328 | * what (1) = (PDB) frac. of diquark fragmenting directly into * |
| 1329 | * baryons (PYTHIA/JETSET fragmentation) * |
| 1330 | * (JETSET: = 0. Popcorn mechanism switched off) * |
| 1331 | * default: 0.5 * |
| 1332 | * what (2) = probability for accepting a diquark breaking * |
| 1333 | * diagram involving the generation of a u/d quark- * |
| 1334 | * antiquark pair default: 0.0 * |
| 1335 | * what (3) = same a what (2), here for s quark-antiquark pair * |
| 1336 | * default: 0.0 * |
| 1337 | * what (4..6), sdum no meaning * |
| 1338 | * * |
| 1339 | ********************************************************************* |
| 1340 | |
| 1341 | 420 CONTINUE |
| 1342 | IF (WHAT(1).GE.0.0D0) PDB = WHAT(1) |
| 1343 | IF (WHAT(2).GE.0.0D0) THEN |
| 1344 | PDBSEA(1) = WHAT(2) |
| 1345 | PDBSEA(2) = WHAT(2) |
| 1346 | ENDIF |
| 1347 | IF (WHAT(3).GE.0.0D0) PDBSEA(3) = WHAT(3) |
| 1348 | DO 421 I=1,8 |
| 1349 | DBRKA(1,I) = DBRKR(1,I)*PDBSEA(1)/(1.D0-PDBSEA(1)) |
| 1350 | DBRKA(2,I) = DBRKR(2,I)*PDBSEA(2)/(1.D0-PDBSEA(2)) |
| 1351 | DBRKA(3,I) = DBRKR(3,I)*PDBSEA(3)/(1.D0-PDBSEA(3)) |
| 1352 | 421 CONTINUE |
| 1353 | GOTO 10 |
| 1354 | |
| 1355 | ********************************************************************* |
| 1356 | * * |
| 1357 | * control card: codewd = PARDECAY * |
| 1358 | * * |
| 1359 | * what (1) = 1. Sigma0/Asigma0 are decaying within JETSET * |
| 1360 | * = 2. pion^0 decay after intranucl. cascade * |
| 1361 | * default: no decay * |
| 1362 | * what (2..6), sdum no meaning * |
| 1363 | * * |
| 1364 | ********************************************************************* |
| 1365 | |
| 1366 | 430 CONTINUE |
| 1367 | IF (WHAT(1).EQ.ONE) ISIG0 = 1 |
| 1368 | IF (WHAT(1).EQ.2.0D0) IPI0 = 1 |
| 1369 | GOTO 10 |
| 1370 | |
| 1371 | ********************************************************************* |
| 1372 | * * |
| 1373 | * control card: codewd = BEAM * |
| 1374 | * * |
| 1375 | * definition of beam parameters * |
| 1376 | * * |
| 1377 | * what (1/2) > 0 : energy of beam 1/2 (GeV) * |
| 1378 | * < 0 : abs(what(1/2)) energy per charge of * |
| 1379 | * beam 1/2 (GeV) * |
| 1380 | * (beam 1 is directed into positive z-direction) * |
| 1381 | * what (3) beam crossing angle, defined as 2x angle between * |
| 1382 | * one beam and the z-axis (micro rad) * |
| 1383 | * what (4) angle with x-axis defining the collision plane * |
| 1384 | * what (5..6), sdum no meaning * |
| 1385 | * * |
| 1386 | * Note: this card requires previously defined projectile and * |
| 1387 | * target identities (PROJPAR, TARPAR) * |
| 1388 | * * |
| 1389 | ********************************************************************* |
| 1390 | |
| 1391 | 440 CONTINUE |
| 1392 | CALL DT_BEAMPR(WHAT,PPN,1) |
| 1393 | EPN = ZERO |
| 1394 | CMENER = ZERO |
| 1395 | LEINP = .TRUE. |
| 1396 | GOTO 10 |
| 1397 | |
| 1398 | ********************************************************************* |
| 1399 | * * |
| 1400 | * control card: codewd = LUND-MSTU * |
| 1401 | * * |
| 1402 | * set parameter MSTU in JETSET-common /LUDAT1/ * |
| 1403 | * * |
| 1404 | * what (1) = index according to LUND-common block * |
| 1405 | * what (2) = new value of MSTU( int(what(1)) ) * |
| 1406 | * what (3), what(4) and what (5), what(6) further * |
| 1407 | * parameter in the same way as what (1) and * |
| 1408 | * what (2) * |
| 1409 | * default: default-Lund or corresponding to * |
| 1410 | * the set given in HADRONIZE * |
| 1411 | * * |
| 1412 | ********************************************************************* |
| 1413 | |
| 1414 | 450 CONTINUE |
| 1415 | IF (WHAT(1).GT.ZERO) THEN |
| 1416 | NMSTU = NMSTU+1 |
| 1417 | IMSTU(NMSTU) = INT(WHAT(1)) |
| 1418 | MSTUX(NMSTU) = INT(WHAT(2)) |
| 1419 | ENDIF |
| 1420 | IF (WHAT(3).GT.ZERO) THEN |
| 1421 | NMSTU = NMSTU+1 |
| 1422 | IMSTU(NMSTU) = INT(WHAT(3)) |
| 1423 | MSTUX(NMSTU) = INT(WHAT(4)) |
| 1424 | ENDIF |
| 1425 | IF (WHAT(5).GT.ZERO) THEN |
| 1426 | NMSTU = NMSTU+1 |
| 1427 | IMSTU(NMSTU) = INT(WHAT(5)) |
| 1428 | MSTUX(NMSTU) = INT(WHAT(6)) |
| 1429 | ENDIF |
| 1430 | GOTO 10 |
| 1431 | |
| 1432 | ********************************************************************* |
| 1433 | * * |
| 1434 | * control card: codewd = LUND-MSTJ * |
| 1435 | * * |
| 1436 | * set parameter MSTJ in JETSET-common /LUDAT1/ * |
| 1437 | * * |
| 1438 | * what (1) = index according to LUND-common block * |
| 1439 | * what (2) = new value of MSTJ( int(what(1)) ) * |
| 1440 | * what (3), what(4) and what (5), what(6) further * |
| 1441 | * parameter in the same way as what (1) and * |
| 1442 | * what (2) * |
| 1443 | * default: default-Lund or corresponding to * |
| 1444 | * the set given in HADRONIZE * |
| 1445 | * * |
| 1446 | ********************************************************************* |
| 1447 | |
| 1448 | 451 CONTINUE |
| 1449 | IF (WHAT(1).GT.ZERO) THEN |
| 1450 | NMSTJ = NMSTJ+1 |
| 1451 | IMSTJ(NMSTJ) = INT(WHAT(1)) |
| 1452 | MSTJX(NMSTJ) = INT(WHAT(2)) |
| 1453 | ENDIF |
| 1454 | IF (WHAT(3).GT.ZERO) THEN |
| 1455 | NMSTJ = NMSTJ+1 |
| 1456 | IMSTJ(NMSTJ) = INT(WHAT(3)) |
| 1457 | MSTJX(NMSTJ) = INT(WHAT(4)) |
| 1458 | ENDIF |
| 1459 | IF (WHAT(5).GT.ZERO) THEN |
| 1460 | NMSTJ = NMSTJ+1 |
| 1461 | IMSTJ(NMSTJ) = INT(WHAT(5)) |
| 1462 | MSTJX(NMSTJ) = INT(WHAT(6)) |
| 1463 | ENDIF |
| 1464 | GOTO 10 |
| 1465 | |
| 1466 | ********************************************************************* |
| 1467 | * * |
| 1468 | * control card: codewd = LUND-MDCY * |
| 1469 | * * |
| 1470 | * set parameter MDCY(I,1) for particle decays in JETSET-common * |
| 1471 | * /LUDAT3/ * |
| 1472 | * * |
| 1473 | * what (1-6) = PDG particle index of particle which should * |
| 1474 | * not decay * |
| 1475 | * default: default-Lund or forced in * |
| 1476 | * DT_INITJS * |
| 1477 | * * |
| 1478 | ********************************************************************* |
| 1479 | |
| 1480 | 452 CONTINUE |
| 1481 | DO 4521 I=1,6 |
| 1482 | IF (WHAT(I).NE.ZERO) THEN |
| 1483 | KC = PYCOMP(INT(WHAT(I))) |
| 1484 | MDCY(KC,1) = 0 |
| 1485 | ENDIF |
| 1486 | 4521 CONTINUE |
| 1487 | GOTO 10 |
| 1488 | |
| 1489 | ********************************************************************* |
| 1490 | * * |
| 1491 | * control card: codewd = LUND-PARJ * |
| 1492 | * * |
| 1493 | * set parameter PARJ in JETSET-common /LUDAT1/ * |
| 1494 | * * |
| 1495 | * what (1) = index according to LUND-common block * |
| 1496 | * what (2) = new value of PARJ( int(what(1)) ) * |
| 1497 | * what (3), what(4) and what (5), what(6) further * |
| 1498 | * parameter in the same way as what (1) and * |
| 1499 | * what (2) * |
| 1500 | * default: default-Lund or corresponding to * |
| 1501 | * the set given in HADRONIZE * |
| 1502 | * * |
| 1503 | ********************************************************************* |
| 1504 | |
| 1505 | 460 CONTINUE |
| 1506 | IF (WHAT(1).NE.ZERO) THEN |
| 1507 | NPARJ = NPARJ+1 |
| 1508 | IPARJ(NPARJ) = INT(WHAT(1)) |
| 1509 | PARJX(NPARJ) = WHAT(2) |
| 1510 | ENDIF |
| 1511 | IF (WHAT(3).NE.ZERO) THEN |
| 1512 | NPARJ = NPARJ+1 |
| 1513 | IPARJ(NPARJ) = INT(WHAT(3)) |
| 1514 | PARJX(NPARJ) = WHAT(4) |
| 1515 | ENDIF |
| 1516 | IF (WHAT(5).NE.ZERO) THEN |
| 1517 | NPARJ = NPARJ+1 |
| 1518 | IPARJ(NPARJ) = INT(WHAT(5)) |
| 1519 | PARJX(NPARJ) = WHAT(6) |
| 1520 | ENDIF |
| 1521 | GOTO 10 |
| 1522 | |
| 1523 | ********************************************************************* |
| 1524 | * * |
| 1525 | * control card: codewd = LUND-PARU * |
| 1526 | * * |
| 1527 | * set parameter PARJ in JETSET-common /LUDAT1/ * |
| 1528 | * * |
| 1529 | * what (1) = index according to LUND-common block * |
| 1530 | * what (2) = new value of PARU( int(what(1)) ) * |
| 1531 | * what (3), what(4) and what (5), what(6) further * |
| 1532 | * parameter in the same way as what (1) and * |
| 1533 | * what (2) * |
| 1534 | * default: default-Lund or corresponding to * |
| 1535 | * the set given in HADRONIZE * |
| 1536 | * * |
| 1537 | ********************************************************************* |
| 1538 | |
| 1539 | 470 CONTINUE |
| 1540 | IF (WHAT(1).GT.ZERO) THEN |
| 1541 | NPARU = NPARU+1 |
| 1542 | IPARU(NPARU) = INT(WHAT(1)) |
| 1543 | PARUX(NPARU) = WHAT(2) |
| 1544 | ENDIF |
| 1545 | IF (WHAT(3).GT.ZERO) THEN |
| 1546 | NPARU = NPARU+1 |
| 1547 | IPARU(NPARU) = INT(WHAT(3)) |
| 1548 | PARUX(NPARU) = WHAT(4) |
| 1549 | ENDIF |
| 1550 | IF (WHAT(5).GT.ZERO) THEN |
| 1551 | NPARU = NPARU+1 |
| 1552 | IPARU(NPARU) = INT(WHAT(5)) |
| 1553 | PARUX(NPARU) = WHAT(6) |
| 1554 | ENDIF |
| 1555 | GOTO 10 |
| 1556 | |
| 1557 | ********************************************************************* |
| 1558 | * * |
| 1559 | * control card: codewd = OUTLEVEL * |
| 1560 | * * |
| 1561 | * output control switches * |
| 1562 | * * |
| 1563 | * what (1) = internal rejection informations default: 0 * |
| 1564 | * what (2) = energy-momentum conservation check output * |
| 1565 | * default: 0 * |
| 1566 | * what (3) = internal warning messages default: 0 * |
| 1567 | * what (4..6), sdum not yet used * |
| 1568 | * * |
| 1569 | ********************************************************************* |
| 1570 | |
| 1571 | 480 CONTINUE |
| 1572 | DO 481 K=1,6 |
| 1573 | IOULEV(K) = INT(WHAT(K)) |
| 1574 | 481 CONTINUE |
| 1575 | GOTO 10 |
| 1576 | |
| 1577 | ********************************************************************* |
| 1578 | * * |
| 1579 | * control card: codewd = FRAME * |
| 1580 | * * |
| 1581 | * frame in which final state is given in DTEVT1 * |
| 1582 | * * |
| 1583 | * what (1) = 1 target rest frame (laboratory) * |
| 1584 | * = 2 nucleon-nucleon cms * |
| 1585 | * default: 1 * |
| 1586 | * * |
| 1587 | ********************************************************************* |
| 1588 | |
| 1589 | 490 CONTINUE |
| 1590 | KFRAME = INT(WHAT(1)) |
| 1591 | IF ((KFRAME.GE.1).AND.(KFRAME.LE.2)) IFRAME = KFRAME |
| 1592 | GOTO 10 |
| 1593 | |
| 1594 | ********************************************************************* |
| 1595 | * * |
| 1596 | * control card: codewd = L-TAG * |
| 1597 | * * |
| 1598 | * lepton tagger: * |
| 1599 | * definition of kinematical cuts for radiated photon and * |
| 1600 | * outgoing lepton detection in lepton-nucleus interactions * |
| 1601 | * * |
| 1602 | * what (1) = y_min * |
| 1603 | * what (2) = y_max * |
| 1604 | * what (3) = Q^2_min * |
| 1605 | * what (4) = Q^2_max * |
| 1606 | * what (5) = theta_min (Lab) * |
| 1607 | * what (6) = theta_max (Lab) * |
| 1608 | * default: no cuts * |
| 1609 | * sdum no meaning * |
| 1610 | * * |
| 1611 | ********************************************************************* |
| 1612 | |
| 1613 | 500 CONTINUE |
| 1614 | YMIN = WHAT(1) |
| 1615 | YMAX = WHAT(2) |
| 1616 | Q2MIN = WHAT(3) |
| 1617 | Q2MAX = WHAT(4) |
| 1618 | THMIN = WHAT(5) |
| 1619 | THMAX = WHAT(6) |
| 1620 | GOTO 10 |
| 1621 | |
| 1622 | ********************************************************************* |
| 1623 | * * |
| 1624 | * control card: codewd = L-ETAG * |
| 1625 | * * |
| 1626 | * lepton tagger: * |
| 1627 | * what (1) = min. outgoing lepton energy (in Lab) * |
| 1628 | * what (2) = min. photon energy (in Lab) * |
| 1629 | * what (3) = max. photon energy (in Lab) * |
| 1630 | * default: no cuts * |
| 1631 | * what (2..6), sdum no meaning * |
| 1632 | * * |
| 1633 | ********************************************************************* |
| 1634 | |
| 1635 | 510 CONTINUE |
| 1636 | ELMIN = MAX(WHAT(1),ZERO) |
| 1637 | EGMIN = MAX(WHAT(2),ZERO) |
| 1638 | EGMAX = MAX(WHAT(3),ZERO) |
| 1639 | GOTO 10 |
| 1640 | |
| 1641 | ********************************************************************* |
| 1642 | * * |
| 1643 | * control card: codewd = ECMS-CUT * |
| 1644 | * * |
| 1645 | * what (1) = min. c.m. energy to be sampled * |
| 1646 | * what (2) = max. c.m. energy to be sampled * |
| 1647 | * what (3) = min x_Bj to be sampled * |
| 1648 | * default: no cuts * |
| 1649 | * what (3..6), sdum no meaning * |
| 1650 | * * |
| 1651 | ********************************************************************* |
| 1652 | |
| 1653 | 520 CONTINUE |
| 1654 | ECMIN = WHAT(1) |
| 1655 | ECMAX = WHAT(2) |
| 1656 | IF (ECMIN.GT.ECMAX) ECMIN = ECMAX |
| 1657 | XBJMIN = MAX(WHAT(3),ZERO) |
| 1658 | GOTO 10 |
| 1659 | |
| 1660 | ********************************************************************* |
| 1661 | * * |
| 1662 | * control card: codewd = VDM-PAR1 * |
| 1663 | * * |
| 1664 | * parameters in gamma-nucleus cross section calculation * |
| 1665 | * * |
| 1666 | * what (1) = Lambda^2 default: 2. * |
| 1667 | * what (2) lower limit in M^2 integration * |
| 1668 | * = 1 (3m_pi)^2 * |
| 1669 | * = 2 (m_rho0)^2 * |
| 1670 | * = 3 (m_phi)^2 default: 1 * |
| 1671 | * what (3) upper limit in M^2 integration * |
| 1672 | * = 1 s/2 * |
| 1673 | * = 2 s/4 * |
| 1674 | * = 3 s default: 3 * |
| 1675 | * what (4) CKMT F_2 structure function * |
| 1676 | * = 2212 proton * |
| 1677 | * = 100 deuteron default: 2212 * |
| 1678 | * what (5) calculation of gamma-nucleon xsections * |
| 1679 | * = 1 according to CKMT-parametrization of F_2 * |
| 1680 | * = 2 integrating SIGVP over M^2 * |
| 1681 | * = 3 using SIGGA * |
| 1682 | * = 4 PHOJET cross sections default: 4 * |
| 1683 | * * |
| 1684 | * what (6), sdum no meaning * |
| 1685 | * * |
| 1686 | ********************************************************************* |
| 1687 | |
| 1688 | 530 CONTINUE |
| 1689 | IF (WHAT(1).GE.ZERO) RL2 = WHAT(1) |
| 1690 | IF ((WHAT(2).GE.1).AND.(WHAT(2).LE.3)) INTRGE(1) = INT(WHAT(2)) |
| 1691 | IF ((WHAT(3).GE.1).AND.(WHAT(3).LE.3)) INTRGE(2) = INT(WHAT(3)) |
| 1692 | IF ((WHAT(4).EQ.2212).OR.(WHAT(4).EQ.100)) IDPDF = INT(WHAT(4)) |
| 1693 | IF ((WHAT(5).GE.1).AND.(WHAT(5).LE.4)) MODEGA = INT(WHAT(5)) |
| 1694 | GOTO 10 |
| 1695 | |
| 1696 | ********************************************************************* |
| 1697 | * * |
| 1698 | * control card: codewd = HISTOGRAM * |
| 1699 | * * |
| 1700 | * activate different classes of histograms * |
| 1701 | * * |
| 1702 | * default: no histograms * |
| 1703 | * * |
| 1704 | ********************************************************************* |
| 1705 | |
| 1706 | 540 CONTINUE |
| 1707 | DO 541 J=1,6 |
| 1708 | IF ((WHAT(J).GE.100).AND.(WHAT(J).LE.150)) THEN |
| 1709 | IHISPP(INT(WHAT(J))-100) = 1 |
| 1710 | ELSEIF ((ABS(WHAT(J)).GE.200).AND.(ABS(WHAT(J)).LE.250)) THEN |
| 1711 | IHISXS(INT(ABS(WHAT(J)))-200) = 1 |
| 1712 | IF (WHAT(J).LT.ZERO) IXSTBL = 1 |
| 1713 | ENDIF |
| 1714 | 541 CONTINUE |
| 1715 | GOTO 10 |
| 1716 | |
| 1717 | ********************************************************************* |
| 1718 | * * |
| 1719 | * control card: codewd = XS-TABLE * |
| 1720 | * * |
| 1721 | * output of cross section table for requested interaction * |
| 1722 | * - particle production deactivated ! - * |
| 1723 | * * |
| 1724 | * what (1) lower energy limit for tabulation * |
| 1725 | * > 0 Lab. frame * |
| 1726 | * < 0 nucleon-nucleon cms * |
| 1727 | * what (2) upper energy limit for tabulation * |
| 1728 | * > 0 Lab. frame * |
| 1729 | * < 0 nucleon-nucleon cms * |
| 1730 | * what (3) > 0 # of equidistant lin. bins in E * |
| 1731 | * < 0 # of equidistant log. bins in E * |
| 1732 | * what (4) lower limit of particle virtuality (photons) * |
| 1733 | * what (5) upper limit of particle virtuality (photons) * |
| 1734 | * what (6) > 0 # of equidistant lin. bins in Q^2 * |
| 1735 | * < 0 # of equidistant log. bins in Q^2 * |
| 1736 | * * |
| 1737 | ********************************************************************* |
| 1738 | |
| 1739 | 550 CONTINUE |
| 1740 | IF (WHAT(1).EQ.99999.0D0) THEN |
| 1741 | IRATIO = INT(WHAT(2)) |
| 1742 | GOTO 10 |
| 1743 | ENDIF |
| 1744 | CMENER = ABS(WHAT(2)) |
| 1745 | IF (.NOT.LXSTAB) THEN |
| 1746 | CALL DT_BERTTP |
| 1747 | CALL DT_INCINI |
| 1748 | ENDIF |
| 1749 | IF ((.NOT.LXSTAB).OR.(CMENER.NE.CMEOLD)) THEN |
| 1750 | CMEOLD = CMENER |
| 1751 | IF (WHAT(2).GT.ZERO) |
| 1752 | & CMENER = SQRT(2.0D0*AAM(1)**2+2.0D0*WHAT(2)*AAM(1)) |
| 1753 | EPN = ZERO |
| 1754 | PPN = ZERO |
| 1755 | C WRITE(LOUT,*) 'CMENER = ',CMENER |
| 1756 | CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,CMENER,1) |
| 1757 | CALL DT_PHOINI |
| 1758 | ENDIF |
| 1759 | CALL DT_XSTABL(WHAT,IXSQEL,IRATIO) |
| 1760 | IXSQEL = 0 |
| 1761 | LXSTAB = .TRUE. |
| 1762 | GOTO 10 |
| 1763 | |
| 1764 | ********************************************************************* |
| 1765 | * * |
| 1766 | * control card: codewd = GLAUB-PAR * |
| 1767 | * * |
| 1768 | * parameters in Glauber-formalism * |
| 1769 | * * |
| 1770 | * what (1) # of nucleon configurations sampled in integration * |
| 1771 | * over nuclear desity default: 1000 * |
| 1772 | * what (2) # of bins for integration over impact-parameter and * |
| 1773 | * for profile-function calculation default: 49 * |
| 1774 | * what (3) = 1 calculation of tot., el. and qel. cross sections * |
| 1775 | * default: 0 * |
| 1776 | * what (4) = 1 read pre-calculated impact-parameter distrib. * |
| 1777 | * from "sdum".glb * |
| 1778 | * =-1 dump pre-calculated impact-parameter distrib. * |
| 1779 | * into "sdum".glb * |
| 1780 | * = 100 read pre-calculated impact-parameter distrib. * |
| 1781 | * for variable projectile/target/energy runs * |
| 1782 | * from "sdum".glb * |
| 1783 | * default: 0 * |
| 1784 | * what (5..6) no meaning * |
| 1785 | * sdum if |what (4)| = 1 name of in/output-file (sdum.glb) * |
| 1786 | * * |
| 1787 | ********************************************************************* |
| 1788 | |
| 1789 | 560 CONTINUE |
| 1790 | IF (WHAT(1).GT.ZERO) JSTATB = INT(WHAT(1)) |
| 1791 | IF (WHAT(2).GT.ZERO) JBINSB = INT(WHAT(2)) |
| 1792 | IF (WHAT(3).EQ.ONE) LPROD = .FALSE. |
| 1793 | IF ((ABS(WHAT(4)).EQ.ONE).OR.(WHAT(4).EQ.100)) THEN |
| 1794 | IOGLB = INT(WHAT(4)) |
| 1795 | CGLB = SDUM |
| 1796 | ENDIF |
| 1797 | GOTO 10 |
| 1798 | |
| 1799 | ********************************************************************* |
| 1800 | * * |
| 1801 | * control card: codewd = GLAUB-INI * |
| 1802 | * * |
| 1803 | * pre-initialization of profile function * |
| 1804 | * * |
| 1805 | * what (1) lower energy limit for initialization * |
| 1806 | * > 0 Lab. frame * |
| 1807 | * < 0 nucleon-nucleon cms * |
| 1808 | * what (2) upper energy limit for initialization * |
| 1809 | * > 0 Lab. frame * |
| 1810 | * < 0 nucleon-nucleon cms * |
| 1811 | * what (3) > 0 # of equidistant lin. bins in E * |
| 1812 | * < 0 # of equidistant log. bins in E * |
| 1813 | * what (4) maximum projectile mass number for which the * |
| 1814 | * Glauber data are initialized for each * |
| 1815 | * projectile mass number * |
| 1816 | * (if <= mass given with the PROJPAR-card) * |
| 1817 | * default: 18 * |
| 1818 | * what (5) steps in mass number starting from what (4) * |
| 1819 | * up to mass number defined with PROJPAR-card * |
| 1820 | * for which Glauber data are initialized * |
| 1821 | * default: 5 * |
| 1822 | * what (6) no meaning * |
| 1823 | * sdum no meaning * |
| 1824 | * * |
| 1825 | ********************************************************************* |
| 1826 | |
| 1827 | 565 CONTINUE |
| 1828 | IOGLB = -100 |
| 1829 | CALL DT_GLBINI(WHAT) |
| 1830 | GOTO 10 |
| 1831 | |
| 1832 | ********************************************************************* |
| 1833 | * * |
| 1834 | * control card: codewd = VDM-PAR2 * |
| 1835 | * * |
| 1836 | * parameters in gamma-nucleus cross section calculation * |
| 1837 | * * |
| 1838 | * what (1) = 0 no suppression of shadowing by direct photon * |
| 1839 | * processes * |
| 1840 | * = 1 suppression .. default: 1 * |
| 1841 | * what (2) = 0 no suppression of shadowing by anomalous * |
| 1842 | * component if photon-F_2 * |
| 1843 | * = 1 suppression .. default: 1 * |
| 1844 | * what (3) = 0 no suppression of shadowing by coherence * |
| 1845 | * length of the photon * |
| 1846 | * = 1 suppression .. default: 1 * |
| 1847 | * what (4) = 1 longitudinal polarized photons are taken into * |
| 1848 | * account * |
| 1849 | * eps*R*Q^2/M^2 = what(4)*Q^2/M^2 default: 0 * |
| 1850 | * what (5..6), sdum no meaning * |
| 1851 | * * |
| 1852 | ********************************************************************* |
| 1853 | |
| 1854 | 570 CONTINUE |
| 1855 | IF ((WHAT(1).EQ.ZERO).OR.(WHAT(1).EQ.ONE)) ISHAD(1) = INT(WHAT(1)) |
| 1856 | IF ((WHAT(2).EQ.ZERO).OR.(WHAT(2).EQ.ONE)) ISHAD(2) = INT(WHAT(2)) |
| 1857 | IF ((WHAT(3).EQ.ZERO).OR.(WHAT(3).EQ.ONE)) ISHAD(3) = INT(WHAT(3)) |
| 1858 | EPSPOL = WHAT(4) |
| 1859 | GOTO 10 |
| 1860 | |
| 1861 | ********************************************************************* |
| 1862 | * * |
| 1863 | * control card: XS-QELPRO * |
| 1864 | * * |
| 1865 | * what (1..6), sdum no meaning * |
| 1866 | * * |
| 1867 | ********************************************************************* |
| 1868 | |
| 1869 | 580 CONTINUE |
| 1870 | IXSQEL = ABS(WHAT(1)) |
| 1871 | GOTO 10 |
| 1872 | |
| 1873 | ********************************************************************* |
| 1874 | * * |
| 1875 | * control card: RNDMINIT * |
| 1876 | * * |
| 1877 | * initialization of random number generator * |
| 1878 | * * |
| 1879 | * what (1..4) values for initialization (= 1..168) * |
| 1880 | * what (5..6), sdum no meaning * |
| 1881 | * * |
| 1882 | ********************************************************************* |
| 1883 | |
| 1884 | 590 CONTINUE |
| 1885 | IF ((WHAT(1).LT.1.0D0).OR.(WHAT(1).GT.168.0D0)) THEN |
| 1886 | NA1 = 22 |
| 1887 | ELSE |
| 1888 | NA1 = WHAT(1) |
| 1889 | ENDIF |
| 1890 | IF ((WHAT(2).LT.1.0D0).OR.(WHAT(2).GT.168.0D0)) THEN |
| 1891 | NA2 = 54 |
| 1892 | ELSE |
| 1893 | NA2 = WHAT(2) |
| 1894 | ENDIF |
| 1895 | IF ((WHAT(3).LT.1.0D0).OR.(WHAT(3).GT.168.0D0)) THEN |
| 1896 | NA3 = 76 |
| 1897 | ELSE |
| 1898 | NA3 = WHAT(3) |
| 1899 | ENDIF |
| 1900 | IF ((WHAT(4).LT.1.0D0).OR.(WHAT(4).GT.168.0D0)) THEN |
| 1901 | NA4 = 92 |
| 1902 | ELSE |
| 1903 | NA4 = WHAT(4) |
| 1904 | ENDIF |
| 1905 | CALL DT_RNDMST(NA1,NA2,NA3,NA4) |
| 1906 | GOTO 10 |
| 1907 | |
| 1908 | ********************************************************************* |
| 1909 | * * |
| 1910 | * control card: codewd = LEPTO-CUT * |
| 1911 | * * |
| 1912 | * set parameter CUT in LEPTO-common /LEPTOU/ * |
| 1913 | * * |
| 1914 | * what (1) = index in CUT-array * |
| 1915 | * what (2) = new value of CUT( int(what(1)) ) * |
| 1916 | * what (3), what(4) and what (5), what(6) further * |
| 1917 | * parameter in the same way as what (1) and * |
| 1918 | * what (2) * |
| 1919 | * default: default-LEPTO parameters * |
| 1920 | * * |
| 1921 | ********************************************************************* |
| 1922 | |
| 1923 | 600 CONTINUE |
| 1924 | IF (WHAT(1).GT.ZERO) CUT(INT(WHAT(1))) = WHAT(2) |
| 1925 | IF (WHAT(3).GT.ZERO) CUT(INT(WHAT(3))) = WHAT(4) |
| 1926 | IF (WHAT(5).GT.ZERO) CUT(INT(WHAT(5))) = WHAT(6) |
| 1927 | GOTO 10 |
| 1928 | |
| 1929 | ********************************************************************* |
| 1930 | * * |
| 1931 | * control card: codewd = LEPTO-LST * |
| 1932 | * * |
| 1933 | * set parameter LST in LEPTO-common /LEPTOU/ * |
| 1934 | * * |
| 1935 | * what (1) = index in LST-array * |
| 1936 | * what (2) = new value of LST( int(what(1)) ) * |
| 1937 | * what (3), what(4) and what (5), what(6) further * |
| 1938 | * parameter in the same way as what (1) and * |
| 1939 | * what (2) * |
| 1940 | * default: default-LEPTO parameters * |
| 1941 | * * |
| 1942 | ********************************************************************* |
| 1943 | |
| 1944 | 610 CONTINUE |
| 1945 | IF (WHAT(1).GT.ZERO) LST(INT(WHAT(1))) = INT(WHAT(2)) |
| 1946 | IF (WHAT(3).GT.ZERO) LST(INT(WHAT(3))) = INT(WHAT(4)) |
| 1947 | IF (WHAT(5).GT.ZERO) LST(INT(WHAT(5))) = INT(WHAT(6)) |
| 1948 | GOTO 10 |
| 1949 | |
| 1950 | ********************************************************************* |
| 1951 | * * |
| 1952 | * control card: codewd = LEPTO-PARL * |
| 1953 | * * |
| 1954 | * set parameter PARL in LEPTO-common /LEPTOU/ * |
| 1955 | * * |
| 1956 | * what (1) = index in PARL-array * |
| 1957 | * what (2) = new value of PARL( int(what(1)) ) * |
| 1958 | * what (3), what(4) and what (5), what(6) further * |
| 1959 | * parameter in the same way as what (1) and * |
| 1960 | * what (2) * |
| 1961 | * default: default-LEPTO parameters * |
| 1962 | * * |
| 1963 | ********************************************************************* |
| 1964 | |
| 1965 | 620 CONTINUE |
| 1966 | IF (WHAT(1).GT.ZERO) PARL(INT(WHAT(1))) = WHAT(2) |
| 1967 | IF (WHAT(3).GT.ZERO) PARL(INT(WHAT(3))) = WHAT(4) |
| 1968 | IF (WHAT(5).GT.ZERO) PARL(INT(WHAT(5))) = WHAT(6) |
| 1969 | GOTO 10 |
| 1970 | |
| 1971 | ********************************************************************* |
| 1972 | * * |
| 1973 | * control card: codewd = START * |
| 1974 | * * |
| 1975 | * what (1) = number of events default: 100. * |
| 1976 | * what (2) = 0 Glauber initialization follows * |
| 1977 | * = 1 Glauber initialization supressed, fitted * |
| 1978 | * results are used instead * |
| 1979 | * (this does not apply if emulsion-treatment * |
| 1980 | * is requested) * |
| 1981 | * = 2 Glauber initialization is written to * |
| 1982 | * output-file shmakov.out * |
| 1983 | * = 3 Glauber initialization is read from input-file * |
| 1984 | * shmakov.out default: 0 * |
| 1985 | * what (3..6) no meaning * |
| 1986 | * what (3..6) no meaning * |
| 1987 | * * |
| 1988 | ********************************************************************* |
| 1989 | |
| 1990 | 630 CONTINUE |
| 1991 | |
| 1992 | * check for cross-section table output only |
| 1993 | IF (LXSTAB) STOP |
| 1994 | |
| 1995 | NCASES = INT(WHAT(1)) |
| 1996 | IF (NCASES.LE.0) NCASES = 100 |
| 1997 | IGLAU = INT(WHAT(2)) |
| 1998 | IF ((IGLAU.NE.1).AND.(IGLAU.NE.2).AND.(IGLAU.NE.3)) |
| 1999 | & IGLAU = 0 |
| 2000 | |
| 2001 | NPMASS = IP |
| 2002 | NPCHAR = IPZ |
| 2003 | NTMASS = IT |
| 2004 | NTCHAR = ITZ |
| 2005 | IDP = IJPROJ |
| 2006 | IDT = IJTARG |
| 2007 | IF (IDP.LE.0) IDP = 1 |
| 2008 | * muon neutrinos: temporary (missing index) |
| 2009 | * (new patch in projpar: therefore the following this is probably not |
| 2010 | * necessary anymore..) |
| 2011 | C IF (IDP.EQ.26) IDP = 5 |
| 2012 | C IF (IDP.EQ.27) IDP = 6 |
| 2013 | |
| 2014 | * redefine collision energy |
| 2015 | IF (LEINP) THEN |
| 2016 | IF (ABS(VAREHI).GT.ZERO) THEN |
| 2017 | PDUM = ZERO |
| 2018 | IF (VARELO.LT.EHADLO) VARELO = EHADLO |
| 2019 | CALL DT_LTINI(IDP,IDT,VARELO,PDUM,VARCLO,1) |
| 2020 | PDUM = ZERO |
| 2021 | CALL DT_LTINI(IDP,IDT,VAREHI,PDUM,VARCHI,1) |
| 2022 | ENDIF |
| 2023 | CALL DT_LTINI(IDP,IDT,EPN,PPN,CMENER,1) |
| 2024 | ELSE |
| 2025 | WRITE(LOUT,1003) |
| 2026 | 1003 FORMAT(1X,'INIT: collision energy not defined!',/, |
| 2027 | & 1X,' -program stopped- ') |
| 2028 | STOP |
| 2029 | ENDIF |
| 2030 | |
| 2031 | * switch off evaporation (even if requested) if central coll. requ. |
| 2032 | IF ((ICENTR.EQ.-1).OR.(ICENTR.GT.0).OR.(XSFRAC.LT.0.5D0)) THEN |
| 2033 | IF (LEVPRT) THEN |
| 2034 | WRITE(LOUT,1004) |
| 2035 | 1004 FORMAT(1X,/,'Warning! Evaporation request rejected since', |
| 2036 | & ' central collisions forced.') |
| 2037 | LEVPRT = .FALSE. |
| 2038 | LDEEXG = .FALSE. |
| 2039 | LHEAVY = .FALSE. |
| 2040 | ENDIF |
| 2041 | ENDIF |
| 2042 | |
| 2043 | * initialization of evaporation-module |
| 2044 | |
| 2045 | WRITE(LOUT,1010) |
| 2046 | 1010 FORMAT(1X,/,'Warning! No evaporation performed since', |
| 2047 | & ' evaporation modules not available with this version.') |
| 2048 | LEVPRT = .FALSE. |
| 2049 | LDEEXG = .FALSE. |
| 2050 | LHEAVY = .FALSE. |
| 2051 | LFRMBK = .FALSE. |
| 2052 | IFISS = 0 |
| 2053 | IEVFSS = 0 |
| 2054 | CALL DT_BERTTP |
| 2055 | CALL DT_INCINI |
| 2056 | |
| 2057 | * save the default JETSET-parameter |
| 2058 | CALL DT_JSPARA(0) |
| 2059 | |
| 2060 | * force use of phojet for g-A |
| 2061 | IF ((IDP.EQ.7).AND.(MCGENE.NE.3)) MCGENE = 2 |
| 2062 | * initialization of nucleon-nucleon event generator |
| 2063 | IF (MCGENE.EQ.2) CALL DT_PHOINI |
| 2064 | * initialization of LEPTO event generator |
| 2065 | IF (MCGENE.EQ.3) THEN |
| 2066 | |
| 2067 | STOP ' This version does not contain LEPTO !' |
| 2068 | |
| 2069 | ENDIF |
| 2070 | |
| 2071 | * initialization of quasi-elastic neutrino scattering |
| 2072 | IF (MCGENE.EQ.4) THEN |
| 2073 | IF (IJPROJ.EQ.5) THEN |
| 2074 | NEUTYP = 1 |
| 2075 | ELSEIF (IJPROJ.EQ.6) THEN |
| 2076 | NEUTYP = 2 |
| 2077 | ELSEIF (IJPROJ.EQ.135) THEN |
| 2078 | NEUTYP = 3 |
| 2079 | ELSEIF (IJPROJ.EQ.136) THEN |
| 2080 | NEUTYP = 4 |
| 2081 | ELSEIF (IJPROJ.EQ.133) THEN |
| 2082 | NEUTYP = 5 |
| 2083 | ELSEIF (IJPROJ.EQ.134) THEN |
| 2084 | NEUTYP = 6 |
| 2085 | ENDIF |
| 2086 | ENDIF |
| 2087 | |
| 2088 | * normalize fractions of emulsion components |
| 2089 | IF (NCOMPO.GT.0) THEN |
| 2090 | SUMFRA = ZERO |
| 2091 | DO 491 I=1,NCOMPO |
| 2092 | SUMFRA = SUMFRA+EMUFRA(I) |
| 2093 | 491 CONTINUE |
| 2094 | IF (SUMFRA.GT.ZERO) THEN |
| 2095 | DO 492 I=1,NCOMPO |
| 2096 | EMUFRA(I) = EMUFRA(I)/SUMFRA |
| 2097 | 492 CONTINUE |
| 2098 | ENDIF |
| 2099 | ENDIF |
| 2100 | |
| 2101 | * disallow Cronin's multiple scattering for nucleus-nucleus interactions |
| 6cf1df4c |
2102 | IF ((IP.GT.1).AND. (IT.GT.1) .AND. (MKCRON.GT.0)) THEN |
| 9aaba0d6 |
2103 | WRITE(LOUT,1005) |
| 2104 | 1005 FORMAT(/,1X,'INIT: multiple scattering disallowed',/) |
| 2105 | MKCRON = 0 |
| 2106 | ENDIF |
| 2107 | |
| 2108 | * initialization of Glauber-formalism (moved to xAEVT, sr 26.3.96) |
| 2109 | C IF (NCOMPO.LE.0) THEN |
| 2110 | C CALL DT_SHMAKI(IP,IPZ,IT,ITZ,IDP,PPN,IGLAU) |
| 2111 | C ELSE |
| 2112 | C DO 493 I=1,NCOMPO |
| 2113 | C CALL DT_SHMAKI(IP,IPZ,IEMUMA(I),IEMUCH(I),IDP,PPN,0) |
| 2114 | C 493 CONTINUE |
| 2115 | C ENDIF |
| 2116 | |
| 2117 | * pre-tabulation of elastic cross-sections |
| 2118 | CALL DT_SIGTBL(JDUM,JDUM,DUM,DUM,-1) |
| 2119 | |
| 2120 | CALL DT_XTIME |
| 2121 | |
| 2122 | RETURN |
| 2123 | |
| 2124 | ********************************************************************* |
| 2125 | * * |
| 2126 | * control card: codewd = STOP * |
| 2127 | * * |
| 2128 | * stop of the event generation * |
| 2129 | * * |
| 2130 | * what (1..6) no meaning * |
| 2131 | * * |
| 2132 | ********************************************************************* |
| 2133 | |
| 2134 | 9999 CONTINUE |
| 2135 | WRITE(LOUT,9000) |
| 2136 | 9000 FORMAT(1X,'---> unexpected end of input !') |
| 2137 | |
| 2138 | 640 CONTINUE |
| 2139 | STOP |
| 2140 | |
| 2141 | END |
| 2142 | |
| 2143 | *$ CREATE DT_KKINC.FOR |
| 2144 | *COPY DT_KKINC |
| 2145 | * |
| 2146 | *===kkinc==============================================================* |
| 2147 | * |
| 2148 | SUBROUTINE DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT, |
| 2149 | & IREJ) |
| 2150 | |
| 2151 | ************************************************************************ |
| 2152 | * Treatment of complete nucleus-nucleus or hadron-nucleus scattering * |
| 2153 | * This subroutine is an update of the previous version written * |
| 2154 | * by J. Ranft/ H.-J. Moehring. * |
| 2155 | * This version dated 19.11.95 is written by S. Roesler * |
| 2156 | ************************************************************************ |
| 2157 | |
| 2158 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 2159 | SAVE |
| 2160 | PARAMETER ( LINP = 10 , |
| 2161 | & LOUT = 6 , |
| 2162 | & LDAT = 9 ) |
| 2163 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY5=1.0D-5, |
| 2164 | & TINY2=1.0D-2,TINY3=1.0D-3) |
| 2165 | |
| 2166 | LOGICAL LFZC |
| 2167 | |
| 2168 | * event history |
| 09b429a4 |
2169 | |
| 2170 | PARAMETER (NMXHEP=4000) |
| 2171 | COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP), |
| 2172 | & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP), |
| 2173 | & VHEP(4,NMXHEP), NSD1, NSD2, NDD |
| 2174 | |
| 9aaba0d6 |
2175 | PARAMETER (NMXHKK=200000) |
| 2176 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 2177 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 2178 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 2179 | * extended event history |
| 2180 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 2181 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 2182 | & IHIST(2,NMXHKK) |
| 2183 | * particle properties (BAMJET index convention) |
| 2184 | CHARACTER*8 ANAME |
| 2185 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 2186 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 2187 | * properties of interacting particles |
| 2188 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG |
| 2189 | * Lorentz-parameters of the current interaction |
| 2190 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, |
| 2191 | & UMO,PPCM,EPROJ,PPROJ |
| 2192 | * flags for input different options |
| 2193 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 2194 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 2195 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 2196 | * flags for particle decays |
| 2197 | COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20), |
| 2198 | & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20), |
| 2199 | & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0 |
| 2200 | * cuts for variable energy runs |
| 2201 | COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI |
| 2202 | * Glauber formalism: flags and parameters for statistics |
| 2203 | LOGICAL LPROD |
| 2204 | CHARACTER*8 CGLB |
| 2205 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD |
| 2206 | |
| 2207 | DIMENSION WHAT(6) |
| 2208 | |
| 2209 | IREJ = 0 |
| 2210 | ILOOP = 0 |
| 09b429a4 |
2211 | NSD1 = 0 |
| 2212 | NSD2 = 0 |
| 2213 | NDD = 0 |
| 9aaba0d6 |
2214 | 100 CONTINUE |
| 2215 | IF (ILOOP.EQ.4) THEN |
| 2216 | WRITE(LOUT,1000) NEVHKK |
| 2217 | 1000 FORMAT(1X,'KKINC: event ',I8,' rejected!') |
| 2218 | GOTO 9999 |
| 2219 | ENDIF |
| 2220 | ILOOP = ILOOP+1 |
| 2221 | |
| 2222 | * variable energy-runs, recalculate parameters for LT's |
| 2223 | IF ((ABS(VAREHI).GT.ZERO).OR.(IOGLB.EQ.100)) THEN |
| 2224 | PDUM = ZERO |
| 2225 | CDUM = ZERO |
| 2226 | CALL DT_LTINI(IDP,1,EPN,PDUM,CDUM,1) |
| 2227 | ENDIF |
| 2228 | IF (EPN.GT.EPROJ) THEN |
| 2229 | WRITE(LOUT,'(A,E9.3,2A,E9.3,A)') |
| 2230 | & ' Requested energy (',EPN,'GeV) exceeds', |
| 2231 | & ' initialization energy (',EPROJ,'GeV) !' |
| 2232 | STOP |
| 2233 | ENDIF |
| 2234 | |
| 2235 | * re-initialize /DTPRTA/ |
| 2236 | IP = NPMASS |
| 2237 | IPZ = NPCHAR |
| 2238 | IT = NTMASS |
| 2239 | ITZ = NTCHAR |
| 2240 | IJPROJ = IDP |
| 2241 | IBPROJ = IIBAR(IJPROJ) |
| 2242 | |
| 2243 | * calculate nuclear potentials (common /DTNPOT/) |
| 2244 | CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0) |
| 2245 | |
| 2246 | * initialize treatment for residual nuclei |
| 2247 | CALL DT_RESNCL(EPN,NLOOP,1) |
| 2248 | |
| 2249 | * sample hadron/nucleus-nucleus interaction |
| 2250 | CALL DT_KKEVNT(KKMAT,IREJ1) |
| 2251 | IF (IREJ1.GT.0) THEN |
| 2252 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKINC' |
| 2253 | GOTO 9999 |
| 2254 | ENDIF |
| 2255 | |
| 2256 | IF ((NPMASS.GT.1).OR.(NTMASS.GT.1)) THEN |
| 2257 | |
| 2258 | * intranuclear cascade of final state particles for KTAUGE generations |
| 2259 | * of secondaries |
| 2260 | CALL DT_FOZOCA(LFZC,IREJ1) |
| 2261 | IF (IREJ1.GT.0) THEN |
| 2262 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKINC' |
| 2263 | GOTO 9999 |
| 2264 | ENDIF |
| 2265 | |
| 2266 | * baryons unable to escape the nuclear potential are treated as |
| 2267 | * excited nucleons (ISTHKK=15,16) |
| 2268 | CALL DT_SCN4BA |
| 2269 | |
| 2270 | * decay of resonances produced in intranuclear cascade processes |
| 2271 | **sr 15-11-95 should be obsolete |
| 2272 | C IF (LFZC) CALL DT_DECAY1 |
| 2273 | |
| 2274 | 101 CONTINUE |
| 2275 | * treatment of residual nuclei |
| 2276 | CALL DT_RESNCL(EPN,NLOOP,2) |
| 2277 | |
| 2278 | * evaporation / fission / fragmentation |
| 2279 | * (if intranuclear cascade was sampled only) |
| 2280 | IF (LFZC) THEN |
| 2281 | CALL DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ1) |
| 2282 | IF (IREJ1.GT.1) GOTO 101 |
| 2283 | IF (IREJ1.EQ.1) GOTO 100 |
| 2284 | ENDIF |
| 2285 | |
| 2286 | ENDIF |
| 2287 | |
| 2288 | * rejection of unphysical configurations |
| 2289 | CALL DT_REJUCO(1,IREJ1) |
| 2290 | IF (IREJ1.GT.0) THEN |
| 2291 | IF (IOULEV(1).GT.0) |
| 2292 | & WRITE(LOUT,*) 'rejected 3 in KKINC: too large x' |
| 2293 | GOTO 100 |
| 2294 | ENDIF |
| 2295 | |
| 2296 | * transform finale state into Lab. |
| 2297 | IFLAG = 2 |
| 2298 | CALL DT_BEAMPR(WHAT,DUM,IFLAG) |
| 2299 | IF ((IFRAME.EQ.1).AND.(IFLAG.EQ.-1)) CALL DT_LT2LAB |
| 2300 | |
| 2301 | IF (IPI0.EQ.1) CALL DT_DECPI0 |
| 2302 | |
| 2303 | C IF (NEVHKK.EQ.5) CALL DT_EVTOUT(4) |
| 9aaba0d6 |
2304 | RETURN |
| 2305 | 9999 CONTINUE |
| 2306 | IREJ = 1 |
| 09b429a4 |
2307 | |
| 9aaba0d6 |
2308 | RETURN |
| 2309 | END |
| 2310 | |
| 2311 | *$ CREATE DT_DEFAUL.FOR |
| 2312 | *COPY DT_DEFAUL |
| 2313 | * |
| 2314 | *===defaul=============================================================* |
| 2315 | * |
| 2316 | SUBROUTINE DT_DEFAUL(EPN,PPN) |
| 2317 | |
| 2318 | ************************************************************************ |
| 2319 | * Variables are set to default values. * |
| 2320 | * This version dated 8.5.95 is written by S. Roesler. * |
| 2321 | ************************************************************************ |
| 2322 | |
| 2323 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 2324 | SAVE |
| 2325 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10) |
| 2326 | PARAMETER (TWOPI = 6.283185307179586454D+00) |
| 2327 | |
| 2328 | * particle properties (BAMJET index convention) |
| 2329 | CHARACTER*8 ANAME |
| 2330 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 2331 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 2332 | * nuclear potential |
| 2333 | LOGICAL LFERMI |
| 2334 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, |
| 2335 | & EBINDP(2),EBINDN(2),EPOT(2,210), |
| 2336 | & ETACOU(2),ICOUL,LFERMI |
| 2337 | * interface HADRIN-DPM |
| 2338 | COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA |
| 2339 | * central particle production, impact parameter biasing |
| 2340 | COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR |
| 2341 | * properties of interacting particles |
| 2342 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG |
| 2343 | * properties of photon/lepton projectiles |
| 2344 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC |
| 2345 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 2346 | * emulsion treatment |
| 2347 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), |
| 2348 | & NCOMPO,IEMUL |
| 2349 | * parameter for intranuclear cascade |
| 2350 | LOGICAL LPAULI |
| 2351 | COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI |
| 2352 | * various options for treatment of partons (DTUNUC 1.x) |
| 2353 | * (chain recombination, Cronin,..) |
| 2354 | LOGICAL LCO2CR,LINTPT |
| 2355 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, |
| 2356 | & LCO2CR,LINTPT |
| 2357 | * threshold values for x-sampling (DTUNUC 1.x) |
| 2358 | COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA, |
| 2359 | & SSMIMQ,VVMTHR |
| 2360 | * flags for input different options |
| 2361 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 2362 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 2363 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 2364 | * n-n cross section fluctuations |
| 2365 | PARAMETER (NBINS = 1000) |
| 2366 | COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT |
| 2367 | * flags for particle decays |
| 2368 | COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20), |
| 2369 | & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20), |
| 2370 | & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0 |
| 2371 | * diquark-breaking mechanism |
| 2372 | COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3 |
| 2373 | * nucleon-nucleon event-generator |
| 2374 | CHARACTER*8 CMODEL |
| 2375 | LOGICAL LPHOIN |
| 2376 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN |
| 2377 | * flags for diffractive interactions (DTUNUC 1.x) |
| 2378 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF |
| 2379 | * VDM parameter for photon-nucleus interactions |
| 2380 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) |
| 2381 | * Glauber formalism: flags and parameters for statistics |
| 2382 | LOGICAL LPROD |
| 2383 | CHARACTER*8 CGLB |
| 2384 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD |
| 2385 | * kinematical cuts for lepton-nucleus interactions |
| 2386 | COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX, |
| 2387 | & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI |
| 2388 | * flags for activated histograms |
| 2389 | COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL |
| 2390 | * cuts for variable energy runs |
| 2391 | COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI |
| 2392 | * parameters for hA-diffraction |
| 2393 | COMMON /DTDIHA/ DIBETA,DIALPH |
| 2394 | * LEPTO |
| 2395 | REAL RPPN |
| 2396 | COMMON /LEPTOI/ RPPN,LEPIN,INTER |
| 2397 | * steering flags for qel neutrino scattering modules |
| 2398 | COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC |
| 2399 | * event flag |
| 2400 | COMMON /DTEVNO/ NEVENT,ICASCA |
| 2401 | |
| 2402 | DATA POTMES /0.002D0/ |
| 2403 | |
| 2404 | * common /DTNPOT/ |
| 2405 | DO 10 I=1,2 |
| 2406 | PFERMP(I) = ZERO |
| 2407 | PFERMN(I) = ZERO |
| 2408 | EBINDP(I) = ZERO |
| 2409 | EBINDN(I) = ZERO |
| 2410 | DO 11 J=1,210 |
| 2411 | EPOT(I,J) = ZERO |
| 2412 | 11 CONTINUE |
| 2413 | * nucleus independent meson potential |
| 2414 | EPOT(I,13) = POTMES |
| 2415 | EPOT(I,14) = POTMES |
| 2416 | EPOT(I,15) = POTMES |
| 2417 | EPOT(I,16) = POTMES |
| 2418 | EPOT(I,23) = POTMES |
| 2419 | EPOT(I,24) = POTMES |
| 2420 | EPOT(I,25) = POTMES |
| 2421 | 10 CONTINUE |
| 2422 | FERMOD = 0.55D0 |
| 2423 | ETACOU(1) = ZERO |
| 2424 | ETACOU(2) = ZERO |
| 2425 | ICOUL = 1 |
| 2426 | LFERMI = .TRUE. |
| 2427 | |
| 2428 | * common /HNTHRE/ |
| 2429 | EHADTH = -99.0D0 |
| 2430 | EHADLO = 4.06D0 |
| 2431 | EHADHI = 6.0D0 |
| 2432 | INTHAD = 1 |
| 2433 | IDXTA = 2 |
| 2434 | |
| 2435 | * common /DTIMPA/ |
| 2436 | ICENTR = 0 |
| 2437 | BIMIN = ZERO |
| 2438 | BIMAX = 1.0D10 |
| 2439 | XSFRAC = 1.0D0 |
| 2440 | |
| 2441 | * common /DTPRTA/ |
| 2442 | IP = 1 |
| 2443 | IPZ = 1 |
| 2444 | IT = 1 |
| 2445 | ITZ = 1 |
| 2446 | IJPROJ = 1 |
| 2447 | IBPROJ = 1 |
| 2448 | IJTARG = 1 |
| 2449 | IBTARG = 1 |
| 2450 | * common /DTGPRO/ |
| 2451 | VIRT = ZERO |
| 2452 | DO 14 I=1,4 |
| 2453 | PGAMM(I) = ZERO |
| 2454 | PLEPT0(I) = ZERO |
| 2455 | PLEPT1(I) = ZERO |
| 2456 | PNUCL(I) = ZERO |
| 2457 | 14 CONTINUE |
| 2458 | IDIREC = 0 |
| 2459 | |
| 2460 | * common /DTFOTI/ |
| 2461 | **sr 7.4.98: changed after corrected B-sampling |
| 2462 | C TAUFOR = 4.4D0 |
| 2463 | TAUFOR = 3.5D0 |
| 2464 | KTAUGE = 25 |
| 2465 | ITAUVE = 1 |
| 2466 | INCMOD = 1 |
| 2467 | LPAULI = .TRUE. |
| 2468 | |
| 2469 | * common /DTCHAI/ |
| 2470 | SEASQ = ONE |
| 2471 | MKCRON = 1 |
| 2472 | CRONCO = 0.64D0 |
| 2473 | ISICHA = 0 |
| 2474 | CUTOF = 100.0D0 |
| 2475 | LCO2CR = .FALSE. |
| 2476 | IRECOM = 1 |
| 2477 | LINTPT = .TRUE. |
| 2478 | |
| 2479 | * common /DTXCUT/ |
| 2480 | * definition of soft quark distributions |
| 2481 | XSEACU = 0.05D0 |
| 2482 | UNON = 2.0D0 |
| 2483 | UNOM = 1.5D0 |
| 2484 | UNOSEA = 5.0D0 |
| 2485 | * cutoff parameters for x-sampling |
| 2486 | CVQ = 1.0D0 |
| 2487 | CDQ = 2.0D0 |
| 2488 | C CSEA = 0.3D0 |
| 2489 | CSEA = 0.1D0 |
| 2490 | SSMIMA = 1.2D0 |
| 2491 | SSMIMQ = SSMIMA**2 |
| 2492 | VVMTHR = 2.0D0 |
| 2493 | |
| 2494 | * common /DTXSFL/ |
| 2495 | IFLUCT = 0 |
| 2496 | |
| 2497 | * common /DTFRPA/ |
| 2498 | PDB = 0.15D0 |
| 2499 | PDBSEA(1) = 0.0D0 |
| 2500 | PDBSEA(2) = 0.0D0 |
| 2501 | PDBSEA(3) = 0.0D0 |
| 2502 | ISIG0 = 0 |
| 2503 | IPI0 = 0 |
| 2504 | NMSTU = 0 |
| 2505 | NPARU = 0 |
| 2506 | NMSTJ = 0 |
| 2507 | NPARJ = 0 |
| 2508 | |
| 2509 | * common /DTDIQB/ |
| 2510 | DO 15 I=1,8 |
| 2511 | DBRKR(1,I) = 5.0D0 |
| 2512 | DBRKR(2,I) = 5.0D0 |
| 2513 | DBRKR(3,I) = 10.0D0 |
| 2514 | DBRKA(1,I) = ZERO |
| 2515 | DBRKA(2,I) = ZERO |
| 2516 | DBRKA(3,I) = ZERO |
| 2517 | 15 CONTINUE |
| 2518 | CHAM1 = 0.2D0 |
| 2519 | CHAM3 = 0.5D0 |
| 2520 | CHAB1 = 0.7D0 |
| 2521 | CHAB3 = 1.0D0 |
| 2522 | |
| 2523 | * common /DTFLG3/ |
| 2524 | ISINGD = 0 |
| 2525 | IDOUBD = 0 |
| 2526 | IFLAGD = 0 |
| 2527 | IDIFF = 0 |
| 2528 | |
| 2529 | * common /DTMODL/ |
| 2530 | MCGENE = 2 |
| 2531 | CMODEL(1) = 'DTUNUC ' |
| 2532 | CMODEL(2) = 'PHOJET ' |
| 2533 | CMODEL(3) = 'LEPTO ' |
| 2534 | CMODEL(4) = 'QNEUTRIN' |
| 2535 | LPHOIN = .TRUE. |
| 2536 | ELOJET = 5.0D0 |
| 2537 | |
| 2538 | * common /DTLCUT/ |
| 2539 | ECMIN = 3.5D0 |
| 2540 | ECMAX = 1.0D10 |
| 2541 | XBJMIN = ZERO |
| 2542 | ELMIN = ZERO |
| 2543 | EGMIN = ZERO |
| 2544 | EGMAX = 1.0D10 |
| 2545 | YMIN = TINY10 |
| 2546 | YMAX = 0.999D0 |
| 2547 | Q2MIN = TINY10 |
| 2548 | Q2MAX = 10.0D0 |
| 2549 | THMIN = ZERO |
| 2550 | THMAX = TWOPI |
| 2551 | Q2LI = ZERO |
| 2552 | Q2HI = 1.0D10 |
| 2553 | ECMLI = ZERO |
| 2554 | ECMHI = 1.0D10 |
| 2555 | |
| 2556 | * common /DTVDMP/ |
| 2557 | RL2 = 2.0D0 |
| 2558 | INTRGE(1) = 1 |
| 2559 | INTRGE(2) = 3 |
| 2560 | IDPDF = 2212 |
| 2561 | MODEGA = 4 |
| 2562 | ISHAD(1) = 1 |
| 2563 | ISHAD(2) = 1 |
| 2564 | ISHAD(3) = 1 |
| 2565 | EPSPOL = ZERO |
| 2566 | |
| 2567 | * common /DTGLGP/ |
| 2568 | JSTATB = 1000 |
| 2569 | JBINSB = 49 |
| 2570 | CGLB = ' ' |
| 2571 | IF (ITRSPT.EQ.1) THEN |
| 2572 | IOGLB = 100 |
| 2573 | ELSE |
| 2574 | IOGLB = 0 |
| 2575 | ENDIF |
| 2576 | LPROD = .TRUE. |
| 2577 | |
| 2578 | * common /DTHIS3/ |
| 2579 | DO 16 I=1,50 |
| 2580 | IHISPP(I) = 0 |
| 2581 | IHISXS(I) = 0 |
| 2582 | 16 CONTINUE |
| 2583 | IXSTBL = 0 |
| 2584 | |
| 2585 | * common /DTVARE/ |
| 2586 | VARELO = ZERO |
| 2587 | VAREHI = ZERO |
| 2588 | VARCLO = ZERO |
| 2589 | VARCHI = ZERO |
| 2590 | |
| 2591 | * common /DTDIHA/ |
| 2592 | DIBETA = -1.0D0 |
| 2593 | DIALPH = ZERO |
| 2594 | |
| 2595 | * common /LEPTOI/ |
| 2596 | RPPN = 0.0 |
| 2597 | LEPIN = 0 |
| 2598 | INTER = 0 |
| 2599 | |
| 2600 | * common /QNEUTO/ |
| 2601 | NEUTYP = 1 |
| 2602 | NEUDEC = 0 |
| 2603 | |
| 2604 | * common /DTEVNO/ |
| 2605 | NEVENT = 1 |
| 2606 | IF (ITRSPT.EQ.1) THEN |
| 2607 | ICASCA = 1 |
| 2608 | ELSE |
| 2609 | ICASCA = 0 |
| 2610 | ENDIF |
| 2611 | |
| 2612 | * default Lab.-energy |
| 2613 | EPN = 200.0D0 |
| 2614 | PPN = SQRT((EPN-AAM(IJPROJ))*(EPN+AAM(IJPROJ))) |
| 2615 | |
| 2616 | RETURN |
| 2617 | END |
| 2618 | |
| 2619 | *$ CREATE DT_AAEVT.FOR |
| 2620 | *COPY DT_AAEVT |
| 2621 | * |
| 2622 | *===aaevt==============================================================* |
| 2623 | * |
| 2624 | SUBROUTINE DT_AAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR, |
| 2625 | & IDP,IGLAU) |
| 2626 | |
| 2627 | ************************************************************************ |
| 2628 | * This version dated 22.03.96 is written by S. Roesler. * |
| 2629 | ************************************************************************ |
| 2630 | |
| 2631 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 2632 | SAVE |
| 2633 | PARAMETER ( LINP = 10 , |
| 2634 | & LOUT = 6 , |
| 2635 | & LDAT = 9 ) |
| 2636 | |
| 2637 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 2638 | * emulsion treatment |
| 2639 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), |
| 2640 | & NCOMPO,IEMUL |
| 2641 | * event flag |
| 2642 | COMMON /DTEVNO/ NEVENT,ICASCA |
| 9aaba0d6 |
2643 | CHARACTER*8 DATE,HHMMSS |
| 2644 | DIMENSION IDMNYR(3) |
| 09b429a4 |
2645 | NSD1 = 0 |
| 2646 | NSD2 = 0 |
| 2647 | NDD = 0 |
| 9aaba0d6 |
2648 | KKMAT = 1 |
| 2649 | NMSG = MAX(NEVTS/100,1) |
| 2650 | |
| 2651 | * initialization of run-statistics and histograms |
| 2652 | CALL DT_STATIS(1) |
| 2653 | CALL PHO_PHIST(1000,DUM) |
| 2654 | |
| 2655 | * initialization of Glauber-formalism |
| 2656 | IF (NCOMPO.LE.0) THEN |
| 2657 | CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU) |
| 2658 | ELSE |
| 2659 | DO 1 I=1,NCOMPO |
| 2660 | CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0) |
| 2661 | 1 CONTINUE |
| 2662 | ENDIF |
| 2663 | CALL DT_SIGEMU |
| 2664 | |
| 2665 | CALL IDATE(IDMNYR) |
| 2666 | WRITE(DATE,'(I2,''/'',I2,''/'',I2)') |
| 2667 | & IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100) |
| 2668 | CALL ITIME(IDMNYR) |
| 2669 | WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)') |
| 2670 | & IDMNYR(1),IDMNYR(2),IDMNYR(3) |
| 2671 | WRITE(LOUT,1001) DATE,HHMMSS |
| 2672 | 1001 FORMAT(/,' DT_AAEVT: Initialisation finished. ( Date: ',A8, |
| 2673 | & ' Time: ',A8,' )') |
| 2674 | |
| 2675 | * generate NEVTS events |
| 2676 | DO 2 IEVT=1,NEVTS |
| 2677 | |
| 2678 | * print run-status message |
| 2679 | IF (MOD(IEVT,NMSG).EQ.0) THEN |
| 2680 | CALL IDATE(IDMNYR) |
| 2681 | WRITE(DATE,'(I2,''/'',I2,''/'',I2)') |
| 2682 | & IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100) |
| 2683 | CALL ITIME(IDMNYR) |
| 2684 | WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)') |
| 2685 | & IDMNYR(1),IDMNYR(2),IDMNYR(3) |
| 2686 | WRITE(LOUT,1000) IEVT-1,NEVTS,DATE,HHMMSS |
| 2687 | 1000 FORMAT(/,1X,I8,' out of ',I8,' events sampled ( Date: ',A, |
| 2688 | & ' Time: ',A,' )',/) |
| 2689 | C WRITE(LOUT,1000) IEVT-1 |
| 2690 | C1000 FORMAT(1X,I8,' events sampled') |
| 2691 | ENDIF |
| 2692 | NEVENT = IEVT |
| 2693 | * treat nuclear emulsions |
| 2694 | IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0) |
| 2695 | * composite targets only |
| 2696 | KKMAT = -KKMAT |
| 2697 | * sample this event |
| 2698 | CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,IREJ) |
| 2699 | |
| 2700 | CALL PHO_PHIST(2000,DUM) |
| 09b429a4 |
2701 | |
| 2702 | write(6,*) "Diffractive collisions", NSD1, NSD2, NDD |
| 9aaba0d6 |
2703 | |
| 2704 | 2 CONTINUE |
| 2705 | |
| 2706 | * print run-statistics and histograms to output-unit 6 |
| 2707 | CALL PHO_PHIST(3000,DUM) |
| 2708 | CALL DT_STATIS(2) |
| 9aaba0d6 |
2709 | RETURN |
| 2710 | END |
| 2711 | |
| 2712 | *$ CREATE DT_LAEVT.FOR |
| 2713 | *COPY DT_LAEVT |
| 2714 | * |
| 2715 | *===laevt==============================================================* |
| 2716 | * |
| 2717 | SUBROUTINE DT_LAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR, |
| 2718 | & IDP,IGLAU) |
| 2719 | |
| 2720 | ************************************************************************ |
| 2721 | * Interface to run DPMJET for lepton-nucleus interactions. * |
| 2722 | * Kinematics is sampled using the equivalent photon approximation * |
| 2723 | * Based on GPHERA-routine by R. Engel. * |
| 2724 | * This version dated 23.03.96 is written by S. Roesler. * |
| 2725 | ************************************************************************ |
| 2726 | |
| 2727 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 2728 | SAVE |
| 2729 | PARAMETER ( LINP = 10 , |
| 2730 | & LOUT = 6 , |
| 2731 | & LDAT = 9 ) |
| 2732 | PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4, |
| 2733 | & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0) |
| 2734 | PARAMETER (TWOPI = 6.283185307179586454D+00, |
| 2735 | & PI = TWOPI/TWO, |
| 2736 | & ALPHEM = ONE/137.0D0) |
| 2737 | |
| 2738 | C CHARACTER*72 HEADER |
| 2739 | |
| 2740 | * particle properties (BAMJET index convention) |
| 2741 | CHARACTER*8 ANAME |
| 2742 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 2743 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 2744 | * event history |
| 2745 | PARAMETER (NMXHKK=200000) |
| 2746 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 2747 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 2748 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 2749 | * extended event history |
| 2750 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 2751 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 2752 | & IHIST(2,NMXHKK) |
| 2753 | * kinematical cuts for lepton-nucleus interactions |
| 2754 | COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX, |
| 2755 | & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI |
| 2756 | * properties of interacting particles |
| 2757 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG |
| 2758 | * properties of photon/lepton projectiles |
| 2759 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC |
| 2760 | * kinematics at lepton-gamma vertex |
| 2761 | COMMON /DTLGVX/ PPL0(4),PPL1(4),PPG(4),PPA(4) |
| 2762 | * flags for activated histograms |
| 2763 | COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL |
| 2764 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 2765 | * emulsion treatment |
| 2766 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), |
| 2767 | & NCOMPO,IEMUL |
| 2768 | * Glauber formalism: cross sections |
| 2769 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, |
| 2770 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), |
| 2771 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), |
| 2772 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), |
| 2773 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), |
| 2774 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), |
| 2775 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), |
| 2776 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), |
| 2777 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), |
| 2778 | & BSLOPE,NEBINI,NQBINI |
| 2779 | * nucleon-nucleon event-generator |
| 2780 | CHARACTER*8 CMODEL |
| 2781 | LOGICAL LPHOIN |
| 2782 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN |
| 2783 | * flags for input different options |
| 2784 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 2785 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 2786 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 2787 | * event flag |
| 2788 | COMMON /DTEVNO/ NEVENT,ICASCA |
| 2789 | |
| 2790 | DIMENSION XDUMB(40),BGTA(4) |
| 2791 | |
| 2792 | * LEPTO |
| 2793 | IF (MCGENE.EQ.3) THEN |
| 2794 | STOP ' This version does not contain LEPTO !' |
| 2795 | ENDIF |
| 2796 | |
| 2797 | KKMAT = 1 |
| 2798 | NMSG = MAX(NEVTS/10,1) |
| 2799 | |
| 2800 | * mass of incident lepton |
| 2801 | AMLPT = AAM(IDP) |
| 2802 | AMLPT2 = AMLPT**2 |
| 2803 | IDPPDG = IDT_IPDGHA(IDP) |
| 2804 | |
| 2805 | * consistency of kinematical limits |
| 2806 | Q2MIN = MAX(Q2MIN,TINY10) |
| 2807 | Q2MAX = MAX(Q2MAX,TINY10) |
| 2808 | YMIN = MIN(MAX(YMIN,TINY10),0.999D0) |
| 2809 | YMAX = MIN(MAX(YMAX,TINY10),0.999D0) |
| 2810 | |
| 2811 | * total energy of the lepton-nucleon system |
| 2812 | PTOTLN = SQRT( (PLEPT0(1)+PNUCL(1))**2+(PLEPT0(2)+PNUCL(2))**2 |
| 2813 | & +(PLEPT0(3)+PNUCL(3))**2 ) |
| 2814 | ETOTLN = PLEPT0(4)+PNUCL(4) |
| 2815 | ECMLN = SQRT((ETOTLN-PTOTLN)*(ETOTLN+PTOTLN)) |
| 2816 | ECMAX = MIN(ECMAX,ECMLN) |
| 2817 | WRITE(LOUT,1003) ECMIN,ECMAX,YMIN,YMAX,Q2MIN,Q2MAX,EGMIN, |
| 2818 | & THMIN,THMAX,ELMIN |
| 2819 | 1003 FORMAT(1X,'LAEVT:',16X,'kinematical cuts',/,22X, |
| 2820 | & '------------------',/,9X,'W (min) =', |
| 2821 | & F7.1,' GeV (max) =',F7.1,' GeV',/,9X,'y (min) =', |
| 2822 | & F7.3,8X,'(max) =',F7.3,/,9X,'Q^2 (min) =',F7.1, |
| 2823 | & ' GeV^2 (max) =',F7.1,' GeV^2',/,' (Lab) E_g (min) =' |
| 2824 | & ,F7.1,' GeV',/,' (Lab) theta (min) =',F7.4,8X,'(max) =', |
| 2825 | & F7.4,' for E_lpt >',F7.1,' GeV',/) |
| 2826 | |
| 2827 | * Lorentz-parameter for transf. into Lab |
| 2828 | BGTA(1) = PNUCL(1)/AAM(1) |
| 2829 | BGTA(2) = PNUCL(2)/AAM(1) |
| 2830 | BGTA(3) = PNUCL(3)/AAM(1) |
| 2831 | BGTA(4) = PNUCL(4)/AAM(1) |
| 2832 | * LT of incident lepton into Lab and dump it in DTEVT1 |
| 2833 | CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3), |
| 2834 | & PLEPT0(1),PLEPT0(2),PLEPT0(3),PLEPT0(4), |
| 2835 | & PLTOT,PPL0(1),PPL0(2),PPL0(3),PPL0(4)) |
| 2836 | CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3), |
| 2837 | & PNUCL(1),PNUCL(2),PNUCL(3),PNUCL(4), |
| 2838 | & PLTOT,PPA(1),PPA(2),PPA(3),PPA(4)) |
| 2839 | * maximum energy of photon nucleon system |
| 2840 | PTOTGN = SQRT((YMAX*PPL0(1)+PPA(1))**2+(YMAX*PPL0(2)+PPA(2))**2 |
| 2841 | & +(YMAX*PPL0(3)+PPA(3))**2) |
| 2842 | ETOTGN = YMAX*PPL0(4)+PPA(4) |
| 2843 | EGNMAX = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN)) |
| 2844 | EGNMAX = MIN(EGNMAX,ECMAX) |
| 2845 | * minimum energy of photon nucleon system |
| 2846 | PTOTGN = SQRT((YMIN*PPL0(1)+PPA(1))**2+(YMIN*PPL0(2)+PPA(2))**2 |
| 2847 | & +(YMIN*PPL0(3)+PPA(3))**2) |
| 2848 | ETOTGN = YMIN*PPL0(4)+PPA(4) |
| 2849 | EGNMIN = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN)) |
| 2850 | EGNMIN = MAX(EGNMIN,ECMIN) |
| 2851 | |
| 2852 | * limits for Glauber-initialization |
| 2853 | Q2LI = Q2MIN |
| 2854 | Q2HI = MAX(Q2LI,MIN(Q2HI,Q2MAX)) |
| 2855 | ECMLI = MAX(EGNMIN,THREE) |
| 2856 | ECMHI = EGNMAX |
| 2857 | WRITE(LOUT,1004) EGNMIN,EGNMAX,ECMLI,ECMHI,Q2LI,Q2HI |
| 2858 | 1004 FORMAT(1X,'resulting limits:',/,9X,'W (min) =',F7.1, |
| 2859 | & ' GeV (max) =',F7.1,' GeV',/,/,' limits for ', |
| 2860 | & 'Glauber-initialization:',/,9X,'W (min) =',F7.1, |
| 2861 | & ' GeV (max) =',F7.1,' GeV',/,9X,'Q^2 (min) =',F7.1, |
| 2862 | & ' GeV^2 (max) =',F7.1,' GeV^2',/) |
| 2863 | * initialization of Glauber-formalism |
| 2864 | IF (NCOMPO.LE.0) THEN |
| 2865 | CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU) |
| 2866 | ELSE |
| 2867 | DO 9 I=1,NCOMPO |
| 2868 | CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0) |
| 2869 | 9 CONTINUE |
| 2870 | ENDIF |
| 2871 | CALL DT_SIGEMU |
| 2872 | |
| 2873 | * initialization of run-statistics and histograms |
| 2874 | CALL DT_STATIS(1) |
| 2875 | CALL PHO_PHIST(1000,DUM) |
| 2876 | |
| 2877 | * maximum photon-nucleus cross section |
| 2878 | I1 = 1 |
| 2879 | I2 = 1 |
| 2880 | RAT = ONE |
| 2881 | IF (EGNMAX.GE.ECMNN(NEBINI)) THEN |
| 2882 | I1 = NEBINI |
| 2883 | I2 = NEBINI |
| 2884 | RAT = ONE |
| 2885 | ELSEIF (EGNMAX.GT.ECMNN(1)) THEN |
| 2886 | DO 5 I=2,NEBINI |
| 2887 | IF (EGNMAX.LT.ECMNN(I)) THEN |
| 2888 | I1 = I-1 |
| 2889 | I2 = I |
| 2890 | RAT = (EGNMAX-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1)) |
| 2891 | GOTO 6 |
| 2892 | ENDIF |
| 2893 | 5 CONTINUE |
| 2894 | 6 CONTINUE |
| 2895 | ENDIF |
| 2896 | SIGMAX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1)) |
| 2897 | EGNXX = EGNMAX |
| 2898 | I1 = 1 |
| 2899 | I2 = 1 |
| 2900 | RAT = ONE |
| 2901 | IF (EGNMIN.GE.ECMNN(NEBINI)) THEN |
| 2902 | I1 = NEBINI |
| 2903 | I2 = NEBINI |
| 2904 | RAT = ONE |
| 2905 | ELSEIF (EGNMIN.GT.ECMNN(1)) THEN |
| 2906 | DO 7 I=2,NEBINI |
| 2907 | IF (EGNMIN.LT.ECMNN(I)) THEN |
| 2908 | I1 = I-1 |
| 2909 | I2 = I |
| 2910 | RAT = (EGNMIN-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1)) |
| 2911 | GOTO 8 |
| 2912 | ENDIF |
| 2913 | 7 CONTINUE |
| 2914 | 8 CONTINUE |
| 2915 | ENDIF |
| 2916 | SIGXX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1)) |
| 2917 | IF (SIGXX.GT.SIGMAX) EGNXX = EGNMIN |
| 2918 | SIGMAX = MAX(SIGMAX,SIGXX) |
| 2919 | WRITE(LOUT,'(9X,A,F8.3,A)') 'Sigma_tot (max) =',SIGMAX,' mb' |
| 2920 | |
| 2921 | * plot photon flux table |
| 2922 | AYMIN = LOG(YMIN) |
| 2923 | AYMAX = LOG(YMAX) |
| 2924 | AYRGE = AYMAX-AYMIN |
| 2925 | MAXTAB = 50 |
| 2926 | ADY = LOG(YMAX/YMIN)/DBLE(MAXTAB-1) |
| 2927 | C WRITE(LOUT,'(/,1X,A)') 'LAEVT: photon flux ' |
| 2928 | DO 1 I=1,MAXTAB |
| 2929 | Y = EXP(AYMIN+ADY*DBLE(I-1)) |
| 2930 | Q2LOW = MAX(Q2MIN,AMLPT2*Y**2/(ONE-Y)) |
| 2931 | FF1 = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW) |
| 2932 | & -TWO*AMLPT2*Y*(ONE/Q2LOW-ONE/Q2MAX)) |
| 2933 | FF2 = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW) |
| 2934 | & -TWO*(ONE-Y)/Y*(ONE-Q2LOW/Q2MAX)) |
| 2935 | C WRITE(LOUT,'(5X,3E15.4)') Y,FF1,FF2 |
| 2936 | 1 CONTINUE |
| 2937 | |
| 2938 | * maximum residual weight for flux sampling (dy/y) |
| 2939 | YY = YMIN |
| 2940 | Q2LOW = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY)) |
| 2941 | WGHMAX = (ONE+(ONE-YY)**2)*LOG(Q2MAX/Q2LOW) |
| 2942 | & -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY |
| 2943 | |
| 2944 | CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY0) |
| 2945 | CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY1) |
| 2946 | CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY2) |
| 2947 | CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ0) |
| 2948 | CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ1) |
| 2949 | CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ2) |
| 2950 | CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE0) |
| 2951 | CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE1) |
| 2952 | CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE2) |
| 2953 | CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU0) |
| 2954 | CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU1) |
| 2955 | CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU2) |
| 2956 | XBLOW = 0.001D0 |
| 2957 | CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX0) |
| 2958 | CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX1) |
| 2959 | CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX2) |
| 2960 | |
| 2961 | ITRY = 0 |
| 2962 | ITRW = 0 |
| 2963 | NC0 = 0 |
| 2964 | NC1 = 0 |
| 2965 | |
| 2966 | * generate events |
| 2967 | DO 2 IEVT=1,NEVTS |
| 2968 | IF (MOD(IEVT,NMSG).EQ.0) THEN |
| 2969 | C OPEN(LDAT,FILE='/scrtch3/hr/sroesler/statusd5.out', |
| 2970 | C & STATUS='UNKNOWN') |
| 2971 | WRITE(LOUT,'(1X,I8,A)') IEVT-1,' events sampled' |
| 2972 | C CLOSE(LDAT) |
| 2973 | ENDIF |
| 2974 | NEVENT = IEVT |
| 2975 | |
| 2976 | 100 CONTINUE |
| 2977 | ITRY = ITRY+1 |
| 2978 | |
| 2979 | * sample y |
| 2980 | 101 CONTINUE |
| 2981 | ITRW = ITRW+1 |
| 2982 | YY = EXP(AYRGE*DT_RNDM(RAT)+AYMIN) |
| 2983 | Q2LOW = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY)) |
| 2984 | Q2LOG = LOG(Q2MAX/Q2LOW) |
| 2985 | WGH = (ONE+(ONE-YY)**2)*Q2LOG |
| 2986 | & -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY |
| 2987 | IF (WGHMAX.LT.WGH) WRITE(LOUT,1000) YY,WGHMAX,WGH |
| 2988 | 1000 FORMAT(1X,'LAEVT: weight error!',3E12.5) |
| 2989 | IF (DT_RNDM(YY)*WGHMAX.GT.WGH) GOTO 101 |
| 2990 | |
| 2991 | * sample Q2 |
| 2992 | YEFF = ONE+(ONE-YY)**2 |
| 2993 | 102 CONTINUE |
| 2994 | Q2 = Q2LOW*EXP(Q2LOG*DT_RNDM(YY)) |
| 2995 | WGH = (YEFF-TWO*(ONE-YY)*Q2LOW/Q2)/YEFF |
| 2996 | IF (WGH.LT.DT_RNDM(Q2)) GOTO 102 |
| 2997 | |
| 2998 | c NC0 = NC0+1 |
| 2999 | c CALL DT_FILHGR(YY,ONE,IHFLY0,NC0) |
| 3000 | c CALL DT_FILHGR(Q2,ONE,IHFLQ0,NC0) |
| 3001 | |
| 3002 | * kinematics at lepton-photon vertex |
| 3003 | * scattered electron |
| 3004 | YQ2 = SQRT((ONE-YY)*Q2) |
| 3005 | Q2E = Q2/(4.0D0*PLEPT0(4)) |
| 3006 | E1Y = (ONE-YY)*PLEPT0(4) |
| 3007 | CALL DT_DSFECF(SIF,COF) |
| 3008 | PLEPT1(1) = YQ2*COF |
| 3009 | PLEPT1(2) = YQ2*SIF |
| 3010 | PLEPT1(3) = E1Y-Q2E |
| 3011 | PLEPT1(4) = E1Y+Q2E |
| 3012 | C THETA = ACOS( (E1Y-Q2E)/(E1Y+Q2E) ) |
| 3013 | * radiated photon |
| 3014 | PGAMM(1) = -PLEPT1(1) |
| 3015 | PGAMM(2) = -PLEPT1(2) |
| 3016 | PGAMM(3) = PLEPT0(3)-PLEPT1(3) |
| 3017 | PGAMM(4) = PLEPT0(4)-PLEPT1(4) |
| 3018 | * E_cm cut |
| 3019 | PTOTGN = SQRT( (PGAMM(1)+PNUCL(1))**2+(PGAMM(2)+PNUCL(2))**2 |
| 3020 | & +(PGAMM(3)+PNUCL(3))**2 ) |
| 3021 | ETOTGN = PGAMM(4)+PNUCL(4) |
| 3022 | ECMGN = (ETOTGN-PTOTGN)*(ETOTGN+PTOTGN) |
| 3023 | IF (ECMGN.LT.0.1D0) GOTO 101 |
| 3024 | ECMGN = SQRT(ECMGN) |
| 3025 | IF ((ECMGN.LT.ECMIN).OR.(ECMGN.GT.ECMAX)) GOTO 101 |
| 3026 | |
| 3027 | * Lorentz-transformation into nucleon-rest system |
| 3028 | CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3), |
| 3029 | & PGAMM(1),PGAMM(2),PGAMM(3),PGAMM(4), |
| 3030 | & PGTOT,PPG(1),PPG(2),PPG(3),PPG(4)) |
| 3031 | CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3), |
| 3032 | & PLEPT1(1),PLEPT1(2),PLEPT1(3),PLEPT1(4), |
| 3033 | & PLTOT,PPL1(1),PPL1(2),PPL1(3),PPL1(4)) |
| 3034 | * temporary checks.. |
| 3035 | Q2TMP = ABS(PPG(4)**2-PGTOT**2) |
| 3036 | IF (ABS(Q2-Q2TMP).GT.0.01D0) WRITE(LOUT,1001) Q2,Q2TMP |
| 3037 | 1001 FORMAT(1X,'LAEVT: inconsistent kinematics (Q2,Q2TMP) ', |
| 3038 | & 2F10.4) |
| 3039 | ECMTMP = SQRT((PPG(4)+AAM(1)-PGTOT)*(PPG(4)+AAM(1)+PGTOT)) |
| 3040 | IF (ABS(ECMGN-ECMTMP).GT.TINY10) WRITE(LOUT,1002) ECMGN,ECMTMP |
| 3041 | 1002 FORMAT(1X,'LAEVT: inconsistent kinematics (ECMGN,ECMTMP) ', |
| 3042 | & 2F10.2) |
| 3043 | YYTMP = PPG(4)/PPL0(4) |
| 3044 | IF (ABS(YY-YYTMP).GT.0.01D0) WRITE(LOUT,1005) YY,YYTMP |
| 3045 | 1005 FORMAT(1X,'LAEVT: inconsistent kinematics (YY,YYTMP) ', |
| 3046 | & 2F10.4) |
| 3047 | |
| 3048 | * lepton tagger (Lab) |
| 3049 | THETA = ACOS( PPL1(3)/PLTOT ) |
| 3050 | IF (PPL1(4).GT.ELMIN) THEN |
| 3051 | IF ((THETA.LT.THMIN).OR.(THETA.GT.THMAX)) GOTO 101 |
| 3052 | ENDIF |
| 3053 | * photon energy-cut (Lab) |
| 3054 | IF (PPG(4).LT.EGMIN) GOTO 101 |
| 3055 | IF (PPG(4).GT.EGMAX) GOTO 101 |
| 3056 | * x_Bj cut |
| 3057 | XBJ = ABS(Q2/(1.876D0*PPG(4))) |
| 3058 | IF (XBJ.LT.XBJMIN) GOTO 101 |
| 3059 | |
| 3060 | NC0 = NC0+1 |
| 3061 | CALL DT_FILHGR( Q2,ONE,IHFLQ0,NC0) |
| 3062 | CALL DT_FILHGR( YY,ONE,IHFLY0,NC0) |
| 3063 | CALL DT_FILHGR( XBJ,ONE,IHFLX0,NC0) |
| 3064 | CALL DT_FILHGR(PPG(4),ONE,IHFLU0,NC0) |
| 3065 | CALL DT_FILHGR( ECMGN,ONE,IHFLE0,NC0) |
| 3066 | |
| 3067 | * rotation angles against z-axis |
| 3068 | COD = PPG(3)/PGTOT |
| 3069 | C SID = SQRT((ONE-COD)*(ONE+COD)) |
| 3070 | PPT = SQRT(PPG(1)**2+PPG(2)**2) |
| 3071 | SID = PPT/PGTOT |
| 3072 | COF = ONE |
| 3073 | SIF = ZERO |
| 3074 | IF (PGTOT*SID.GT.TINY10) THEN |
| 3075 | COF = PPG(1)/(SID*PGTOT) |
| 3076 | SIF = PPG(2)/(SID*PGTOT) |
| 3077 | ANORF = SQRT(COF*COF+SIF*SIF) |
| 3078 | COF = COF/ANORF |
| 3079 | SIF = SIF/ANORF |
| 3080 | ENDIF |
| 3081 | |
| 3082 | IF (IXSTBL.EQ.0) THEN |
| 3083 | * change to photon projectile |
| 3084 | IJPROJ = 7 |
| 3085 | * set virtuality |
| 3086 | VIRT = Q2 |
| 3087 | * re-initialize LTs with new kinematics |
| 3088 | * !!PGAMM ist set in cms (ECMGN) along z |
| 3089 | EPN = ZERO |
| 3090 | PPN = ZERO |
| 3091 | CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,ECMGN,0) |
| 3092 | * force Lab-system |
| 3093 | IFRAME = 1 |
| 3094 | * get emulsion component if requested |
| 3095 | IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0) |
| 3096 | * convolute with cross section |
| 3097 | CALL DT_SIGGAT(Q2LOW,EGNXX,STOTX,KKMAT) |
| 3098 | CALL DT_SIGGAT(Q2,ECMGN,STOT,KKMAT) |
| 3099 | IF (STOTX.LT.STOT) WRITE(LOUT,'(1X,A,/,6E12.3)') |
| 3100 | & 'LAEVT: warning STOTX<STOT ! ',Q2LOW,EGNMAX,STOTX, |
| 3101 | & Q2,ECMGN,STOT |
| 3102 | IF (DT_RNDM(Q2)*STOTX.GT.STOT) GOTO 100 |
| 3103 | NC1 = NC1+1 |
| 3104 | CALL DT_FILHGR( Q2,ONE,IHFLQ1,NC1) |
| 3105 | CALL DT_FILHGR( YY,ONE,IHFLY1,NC1) |
| 3106 | CALL DT_FILHGR( XBJ,ONE,IHFLX1,NC1) |
| 3107 | CALL DT_FILHGR(PPG(4),ONE,IHFLU1,NC1) |
| 3108 | CALL DT_FILHGR( ECMGN,ONE,IHFLE1,NC1) |
| 3109 | * composite targets only |
| 3110 | KKMAT = -KKMAT |
| 3111 | * sample this event |
| 3112 | CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IJPROJ,EPN,KKMAT, |
| 3113 | & IREJ) |
| 3114 | * rotate momenta of final state particles back in photon-nucleon syst. |
| 3115 | DO 4 I=NPOINT(4),NHKK |
| 3116 | IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR. |
| 3117 | & (ISTHKK(I).EQ.1001)) THEN |
| 3118 | PX = PHKK(1,I) |
| 3119 | PY = PHKK(2,I) |
| 3120 | PZ = PHKK(3,I) |
| 3121 | CALL DT_MYTRAN(1,PX,PY,PZ,COD,SID,COF,SIF, |
| 3122 | & PHKK(1,I),PHKK(2,I),PHKK(3,I)) |
| 3123 | ENDIF |
| 3124 | 4 CONTINUE |
| 3125 | ENDIF |
| 3126 | |
| 3127 | CALL DT_FILHGR( Q2,ONE,IHFLQ2,NC1) |
| 3128 | CALL DT_FILHGR( YY,ONE,IHFLY2,NC1) |
| 3129 | CALL DT_FILHGR( XBJ,ONE,IHFLX2,NC1) |
| 3130 | CALL DT_FILHGR(PPG(4),ONE,IHFLU2,NC1) |
| 3131 | CALL DT_FILHGR( ECMGN,ONE,IHFLE2,NC1) |
| 3132 | |
| 3133 | * dump this event to histograms |
| 3134 | CALL PHO_PHIST(2000,DUM) |
| 3135 | |
| 3136 | 2 CONTINUE |
| 3137 | |
| 3138 | WGY = ALPHEM/TWOPI*WGHMAX*DBLE(ITRY)/DBLE(ITRW) |
| 3139 | WGY = WGY*LOG(YMAX/YMIN) |
| 3140 | WEIGHT = WGY*SIGMAX*DBLE(NEVTS)/DBLE(ITRY) |
| 3141 | |
| 3142 | C HEADER = ' LAEVT: Q^2 distribution 0' |
| 3143 | C CALL DT_OUTHGR(IHFLQ0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) |
| 3144 | C HEADER = ' LAEVT: Q^2 distribution 1' |
| 3145 | C CALL DT_OUTHGR(IHFLQ1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) |
| 3146 | C HEADER = ' LAEVT: Q^2 distribution 2' |
| 3147 | C CALL DT_OUTHGR(IHFLQ2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) |
| 3148 | C HEADER = ' LAEVT: y distribution 0' |
| 3149 | C CALL DT_OUTHGR(IHFLY0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) |
| 3150 | C HEADER = ' LAEVT: y distribution 1' |
| 3151 | C CALL DT_OUTHGR(IHFLY1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) |
| 3152 | C HEADER = ' LAEVT: y distribution 2' |
| 3153 | C CALL DT_OUTHGR(IHFLY2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) |
| 3154 | C HEADER = ' LAEVT: x distribution 0' |
| 3155 | C CALL DT_OUTHGR(IHFLX0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) |
| 3156 | C HEADER = ' LAEVT: x distribution 1' |
| 3157 | C CALL DT_OUTHGR(IHFLX1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) |
| 3158 | C HEADER = ' LAEVT: x distribution 2' |
| 3159 | C CALL DT_OUTHGR(IHFLX2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) |
| 3160 | C HEADER = ' LAEVT: E_g distribution 0' |
| 3161 | C CALL DT_OUTHGR(IHFLU0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) |
| 3162 | C HEADER = ' LAEVT: E_g distribution 1' |
| 3163 | C CALL DT_OUTHGR(IHFLU1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) |
| 3164 | C HEADER = ' LAEVT: E_g distribution 2' |
| 3165 | C CALL DT_OUTHGR(IHFLU2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) |
| 3166 | C HEADER = ' LAEVT: E_c distribution 0' |
| 3167 | C CALL DT_OUTHGR(IHFLE0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) |
| 3168 | C HEADER = ' LAEVT: E_c distribution 1' |
| 3169 | C CALL DT_OUTHGR(IHFLE1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) |
| 3170 | C HEADER = ' LAEVT: E_c distribution 2' |
| 3171 | C CALL DT_OUTHGR(IHFLE2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) |
| 3172 | |
| 3173 | * print run-statistics and histograms to output-unit 6 |
| 3174 | CALL PHO_PHIST(3000,DUM) |
| 3175 | IF (IXSTBL.EQ.0) CALL DT_STATIS(2) |
| 3176 | |
| 3177 | RETURN |
| 3178 | END |
| 3179 | |
| 3180 | *$ CREATE DT_DTUINI.FOR |
| 3181 | *COPY DT_DTUINI |
| 3182 | * |
| 3183 | *===dtuini=============================================================* |
| 3184 | * |
| 3185 | SUBROUTINE DT_DTUINI(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR, |
| 3186 | & IDP,IEMU) |
| 3187 | |
| 3188 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 3189 | SAVE |
| 3190 | |
| 3191 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 3192 | * emulsion treatment |
| 3193 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), |
| 3194 | & NCOMPO,IEMUL |
| 3195 | * Glauber formalism: flags and parameters for statistics |
| 3196 | LOGICAL LPROD |
| 3197 | CHARACTER*8 CGLB |
| 3198 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD |
| 3199 | |
| 3200 | CALL DT_INIT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,IGLAU) |
| 3201 | CALL DT_STATIS(1) |
| 3202 | CALL PHO_PHIST(1000,DUM) |
| 3203 | IF (NCOMPO.LE.0) THEN |
| 3204 | CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU) |
| 3205 | ELSE |
| 3206 | DO 1 I=1,NCOMPO |
| 3207 | CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0) |
| 3208 | 1 CONTINUE |
| 3209 | ENDIF |
| 3210 | IF (IOGLB.NE.100) CALL DT_SIGEMU |
| 3211 | IEMU = IEMUL |
| 3212 | |
| 3213 | RETURN |
| 3214 | END |
| 3215 | |
| 3216 | *$ CREATE DT_DTUOUT.FOR |
| 3217 | *COPY DT_DTUOUT |
| 3218 | * |
| 3219 | *===dtuout=============================================================* |
| 3220 | * |
| 3221 | SUBROUTINE DT_DTUOUT |
| 3222 | |
| 3223 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 3224 | SAVE |
| 3225 | |
| 3226 | CALL PHO_PHIST(3000,DUM) |
| 3227 | CALL DT_STATIS(2) |
| 3228 | |
| 3229 | RETURN |
| 3230 | END |
| 3231 | |
| 3232 | *$ CREATE DT_BEAMPR.FOR |
| 3233 | *COPY DT_BEAMPR |
| 3234 | * |
| 3235 | *===beampr=============================================================* |
| 3236 | * |
| 3237 | SUBROUTINE DT_BEAMPR(WHAT,PLAB,MODE) |
| 3238 | |
| 3239 | ************************************************************************ |
| 3240 | * Initialization of event generation * |
| 3241 | * This version dated 7.4.98 is written by S. Roesler. * |
| 3242 | ************************************************************************ |
| 3243 | |
| 3244 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 3245 | SAVE |
| 3246 | |
| 3247 | PARAMETER ( LINP = 10 , |
| 3248 | & LOUT = 6 , |
| 3249 | & LDAT = 9 ) |
| 3250 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10) |
| 3251 | PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0) |
| 3252 | |
| 3253 | LOGICAL LBEAM |
| 3254 | |
| 3255 | * event history |
| 3256 | PARAMETER (NMXHKK=200000) |
| 3257 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 3258 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 3259 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 3260 | * extended event history |
| 3261 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 3262 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 3263 | & IHIST(2,NMXHKK) |
| 3264 | * properties of interacting particles |
| 3265 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG |
| 3266 | * particle properties (BAMJET index convention) |
| 3267 | CHARACTER*8 ANAME |
| 3268 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 3269 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 3270 | * beam momenta |
| 3271 | COMMON /DTBEAM/ P1(4),P2(4) |
| 3272 | |
| 3273 | C DIMENSION WHAT(6),P1(4),P2(4),P1CMS(4),P2CMS(4) |
| 3274 | DIMENSION WHAT(6),P1CMS(4),P2CMS(4) |
| 3275 | |
| 3276 | DATA LBEAM /.FALSE./ |
| 3277 | |
| 3278 | GOTO (1,2) MODE |
| 3279 | |
| 3280 | 1 CONTINUE |
| 3281 | |
| 3282 | E1 = WHAT(1) |
| 3283 | IF (E1.LT.ZERO) E1 = DBLE(IPZ)/DBLE(IP)*ABS(WHAT(1)) |
| 3284 | E2 = WHAT(2) |
| 3285 | IF (E2.LT.ZERO) E2 = DBLE(ITZ)/DBLE(IT)*ABS(WHAT(2)) |
| 3286 | PP1 = SQRT( (E1+AAM(IJPROJ))*(E1-AAM(IJPROJ)) ) |
| 3287 | PP2 = SQRT( (E2+AAM(IJTARG))*(E2-AAM(IJTARG)) ) |
| 3288 | TH = 1.D-6*WHAT(3)/2.D0 |
| 3289 | PH = WHAT(4)*BOG |
| 3290 | P1(1) = PP1*SIN(TH)*COS(PH) |
| 3291 | P1(2) = PP1*SIN(TH)*SIN(PH) |
| 3292 | P1(3) = PP1*COS(TH) |
| 3293 | P1(4) = E1 |
| 3294 | P2(1) = PP2*SIN(TH)*COS(PH) |
| 3295 | P2(2) = PP2*SIN(TH)*SIN(PH) |
| 3296 | P2(3) = -PP2*COS(TH) |
| 3297 | P2(4) = E2 |
| 3298 | ECM = SQRT( (P1(4)+P2(4))**2-(P1(1)+P2(1))**2-(P1(2)+P2(2))**2 |
| 3299 | & -(P1(3)+P2(3))**2 ) |
| 3300 | ELAB = (ECM**2-AAM(IJPROJ)**2-AAM(IJTARG)**2)/(2.0D0*AAM(IJTARG)) |
| 3301 | PLAB = SQRT( (ELAB+AAM(IJPROJ))*(ELAB-AAM(IJPROJ)) ) |
| 3302 | BGX = (P1(1)+P2(1))/ECM |
| 3303 | BGY = (P1(2)+P2(2))/ECM |
| 3304 | BGZ = (P1(3)+P2(3))/ECM |
| 3305 | BGE = (P1(4)+P2(4))/ECM |
| 3306 | CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P1(1),P1(2),P1(3),P1(4), |
| 3307 | & P1TOT,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4)) |
| 3308 | CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P2(1),P2(2),P2(3),P2(4), |
| 3309 | & P2TOT,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4)) |
| 3310 | COD = P1CMS(3)/P1TOT |
| 3311 | C SID = SQRT((ONE-COD)*(ONE+COD)) |
| 3312 | PPT = SQRT(P1CMS(1)**2+P1CMS(2)**2) |
| 3313 | SID = PPT/P1TOT |
| 3314 | COF = ONE |
| 3315 | SIF = ZERO |
| 3316 | IF (P1TOT*SID.GT.TINY10) THEN |
| 3317 | COF = P1CMS(1)/(SID*P1TOT) |
| 3318 | SIF = P1CMS(2)/(SID*P1TOT) |
| 3319 | ANORF = SQRT(COF*COF+SIF*SIF) |
| 3320 | COF = COF/ANORF |
| 3321 | SIF = SIF/ANORF |
| 3322 | ENDIF |
| 3323 | **check |
| 3324 | C WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4) |
| 3325 | C WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4) |
| 3326 | C WRITE(LOUT,'(5E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),P1TOT |
| 3327 | C WRITE(LOUT,'(5E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),P2TOT |
| 3328 | C PAX = ZERO |
| 3329 | C PAY = ZERO |
| 3330 | C PAZ = P1TOT |
| 3331 | C PAE = SQRT(AAM(IJPROJ)**2+PAZ**2) |
| 3332 | C PBX = ZERO |
| 3333 | C PBY = ZERO |
| 3334 | C PBZ = -P2TOT |
| 3335 | C PBE = SQRT(AAM(IJTARG)**2+PBZ**2) |
| 3336 | C WRITE(LOUT,'(4E15.4)') PAX,PAY,PAZ,PAE |
| 3337 | C WRITE(LOUT,'(4E15.4)') PBX,PBY,PBZ,PBE |
| 3338 | C CALL DT_MYTRAN(1,PAX,PAY,PAZ,COD,SID,COF,SIF, |
| 3339 | C & P1CMS(1),P1CMS(2),P1CMS(3)) |
| 3340 | C CALL DT_MYTRAN(1,PBX,PBY,PBZ,COD,SID,COF,SIF, |
| 3341 | C & P2CMS(1),P2CMS(2),P2CMS(3)) |
| 3342 | C WRITE(LOUT,'(4E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4) |
| 3343 | C WRITE(LOUT,'(4E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4) |
| 3344 | C CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4), |
| 3345 | C & P1TOT,P1(1),P1(2),P1(3),P1(4)) |
| 3346 | C CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4), |
| 3347 | C & P2TOT,P2(1),P2(2),P2(3),P2(4)) |
| 3348 | C WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4) |
| 3349 | C WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4) |
| 3350 | C STOP |
| 3351 | ** |
| 3352 | |
| 3353 | LBEAM = .TRUE. |
| 3354 | |
| 3355 | RETURN |
| 3356 | |
| 3357 | 2 CONTINUE |
| 3358 | |
| 3359 | IF (LBEAM) THEN |
| 3360 | IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN |
| 3361 | DO 20 I=NPOINT(4),NHKK |
| 3362 | IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR. |
| 3363 | & (ISTHKK(I).EQ.1001)) THEN |
| 3364 | CALL DT_MYTRAN(1,PHKK(1,I),PHKK(2,I),PHKK(3,I), |
| 3365 | & COD,SID,COF,SIF,PXCMS,PYCMS,PZCMS) |
| 3366 | PECMS = PHKK(4,I) |
| 3367 | CALL DT_DALTRA(BGE,BGX,BGY,BGZ,PXCMS,PYCMS,PZCMS,PECMS, |
| 3368 | & PTOT,PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I)) |
| 3369 | ENDIF |
| 3370 | 20 CONTINUE |
| 3371 | ELSE |
| 3372 | MODE = -1 |
| 3373 | ENDIF |
| 3374 | |
| 3375 | RETURN |
| 3376 | END |
| 3377 | |
| 3378 | *$ CREATE DT_REJUCO.FOR |
| 3379 | *COPY DT_REJUCO |
| 3380 | * |
| 3381 | *===rejuco=============================================================* |
| 3382 | * |
| 3383 | SUBROUTINE DT_REJUCO(MODE,IREJ) |
| 3384 | |
| 3385 | ************************************************************************ |
| 3386 | * REJection of Unphysical COnfigurations * |
| 3387 | * MODE = 1 rejection of particles with unphysically large energy * |
| 3388 | * * |
| 3389 | * This version dated 27.12.2006 is written by S. Roesler. * |
| 3390 | ************************************************************************ |
| 3391 | |
| 3392 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 3393 | SAVE |
| 3394 | |
| 3395 | PARAMETER ( LINP = 10 , |
| 3396 | & LOUT = 6 , |
| 3397 | & LDAT = 9 ) |
| 3398 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10) |
| 3399 | PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0) |
| 3400 | |
| 3401 | * maximum x_cms of final state particle |
| 3402 | PARAMETER (XCMSMX = 1.4D0) |
| 3403 | |
| 3404 | * event history |
| 3405 | PARAMETER (NMXHKK=200000) |
| 3406 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 3407 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 3408 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 3409 | * extended event history |
| 3410 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 3411 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 3412 | & IHIST(2,NMXHKK) |
| 3413 | * Lorentz-parameters of the current interaction |
| 3414 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, |
| 3415 | & UMO,PPCM,EPROJ,PPROJ |
| 3416 | |
| 3417 | IREJ = 0 |
| 3418 | |
| 3419 | IF (MODE.EQ.1) THEN |
| 3420 | IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN |
| 3421 | ECMHLF = UMO/2.0D0 |
| 3422 | DO 10 I=NPOINT(4),NHKK |
| 3423 | IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDHKK(I).NE.80000)) THEN |
| 3424 | XCMS = ABS(PHKK(4,I))/ECMHLF |
| 3425 | IF (XCMS.GT.XCMSMX) GOTO 9999 |
| 3426 | ENDIF |
| 3427 | 10 CONTINUE |
| 3428 | ENDIF |
| 3429 | |
| 3430 | RETURN |
| 3431 | 9999 CONTINUE |
| 3432 | IREJ = 1 |
| 3433 | RETURN |
| 3434 | END |
| 3435 | |
| 3436 | *$ CREATE DT_EVENTB.FOR |
| 3437 | *COPY DT_EVENTB |
| 3438 | * |
| 3439 | *===eventb=============================================================* |
| 3440 | * |
| 3441 | SUBROUTINE DT_EVENTB(NCSY,IREJ) |
| 3442 | |
| 3443 | ************************************************************************ |
| 3444 | * Treatment of nucleon-nucleon interactions with full two-component * |
| 3445 | * Dual Parton Model. * |
| 3446 | * NCSY number of nucleon-nucleon interactions * |
| 3447 | * IREJ rejection flag * |
| 3448 | * This version dated 14.01.2000 is written by S. Roesler * |
| 3449 | ************************************************************************ |
| 3450 | |
| 3451 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 3452 | SAVE |
| 3453 | PARAMETER ( LINP = 10 , |
| 3454 | & LOUT = 6 , |
| 3455 | & LDAT = 9 ) |
| 3456 | PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0) |
| 3457 | |
| 3458 | * event history |
| 3459 | PARAMETER (NMXHKK=200000) |
| 3460 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 3461 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 3462 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 3463 | * extended event history |
| 3464 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 3465 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 3466 | & IHIST(2,NMXHKK) |
| 3467 | *! uncomment this line for internal phojet-fragmentation |
| 3468 | C #include "dtu_dtevtp.inc" |
| 3469 | * particle properties (BAMJET index convention) |
| 3470 | CHARACTER*8 ANAME |
| 3471 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 3472 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 3473 | * flags for input different options |
| 3474 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 3475 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 3476 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 3477 | * rejection counter |
| 3478 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, |
| 3479 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, |
| 3480 | & IREXCI(3),IRDIFF(2),IRINC |
| 3481 | * properties of interacting particles |
| 3482 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG |
| 3483 | * properties of photon/lepton projectiles |
| 3484 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC |
| 3485 | * various options for treatment of partons (DTUNUC 1.x) |
| 3486 | * (chain recombination, Cronin,..) |
| 3487 | LOGICAL LCO2CR,LINTPT |
| 3488 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, |
| 3489 | & LCO2CR,LINTPT |
| 3490 | * statistics |
| 3491 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, |
| 3492 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), |
| 3493 | & ICEVTG(8,0:30) |
| 3494 | * DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem |
| 3495 | COMMON /DTLTSU/ BGX,BGY,BGZ,GAM |
| 3496 | * Glauber formalism: collision properties |
| 3497 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, |
| 3498 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC |
| 3499 | * flags for diffractive interactions (DTUNUC 1.x) |
| 3500 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF |
| 3501 | * statistics: double-Pomeron exchange |
| 3502 | COMMON /DTFLG2/ INTFLG,IPOPO |
| 3503 | * flags for particle decays |
| 3504 | COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20), |
| 3505 | & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20), |
| 3506 | & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0 |
| 3507 | * nucleon-nucleon event-generator |
| 3508 | CHARACTER*8 CMODEL |
| 3509 | LOGICAL LPHOIN |
| 3510 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN |
| 3511 | C nucleon-nucleus / nucleus-nucleus interface to DPMJET |
| 3512 | INTEGER IDEQP,IDEQB,IHFLD,IHFLS |
| 3513 | DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB |
| 3514 | COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB, |
| 3515 | & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2) |
| 3516 | C model switches and parameters |
| 3517 | CHARACTER*8 MDLNA |
| 3518 | INTEGER ISWMDL,IPAMDL |
| 3519 | DOUBLE PRECISION PARMDL |
| 3520 | COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400) |
| 3521 | C initial state parton radiation (internal part) |
| 3522 | INTEGER MXISR3,MXISR4 |
| 3523 | PARAMETER ( MXISR3 = 50, MXISR4 = 100 ) |
| 3524 | INTEGER IFL1,IFL2,IBRA,IFANO,ISH,NACC |
| 3525 | DOUBLE PRECISION Q2SH,PT2SH,XPSH,ZPSH,THSH,SHAT |
| 3526 | COMMON /POINT6/ Q2SH(2,MXISR3),PT2SH(2,MXISR3),XPSH(2,MXISR3), |
| 3527 | & ZPSH(2,MXISR3),THSH(2,MXISR3),SHAT(MXISR3), |
| 3528 | & IFL1(2,MXISR3),IFL2(2,MXISR3), |
| 3529 | & IBRA(2,MXISR4),IFANO(2),ISH(2),NACC |
| 3530 | C event debugging information |
| 3531 | INTEGER NMAXD |
| 3532 | PARAMETER (NMAXD=100) |
| 3533 | INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO, |
| 3534 | & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD |
| 3535 | COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG, |
| 3536 | & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD |
| 3537 | C general process information |
| 3538 | INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON |
| 3539 | COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4) |
| 3540 | |
| 3541 | DIMENSION PP(4),PT(4),PTOT(4),PP1(4),PP2(4),PT1(4),PT2(4), |
| 3542 | & PPNN(4),PTNN(4),PTOTNN(4),PPSUB(4),PTSUB(4), |
| 3543 | & PPTCMS(4),PTTCMS(4),PPTMP(4),PTTMP(4), |
| 3544 | & KPRON(15),ISINGL(2000) |
| 3545 | |
| 3546 | * initial values for max. number of phojet scatterings and dtunuc chains |
| 3547 | * to be fragmented with one pyexec call |
| 3548 | DATA MXPHFR,MXDTFR /10,100/ |
| 3549 | |
| 3550 | IREJ = 0 |
| 3551 | * pointer to first parton of the first chain in dtevt common |
| 3552 | NPOINT(3) = NHKK+1 |
| 3553 | * special flag for double-Pomeron statistics |
| 3554 | IPOPO = 1 |
| 3555 | * counter for low-mass (DTUNUC) interactions |
| 3556 | NDTUSC = 0 |
| 3557 | * counter for interactions treated by PHOJET |
| 3558 | NPHOSC = 0 |
| 3559 | |
| 3560 | * scan interactions for single nucleon-nucleon interactions |
| 3561 | * (this has to be checked here because Cronin modifies parton momenta) |
| 3562 | NC = NPOINT(2) |
| 3563 | IF (NCSY.GT.2000) STOP ' DT_EVENTB: NCSY > 2000 ! ' |
| 3564 | DO 8 I=1,NCSY |
| 3565 | ISINGL(I) = 0 |
| 3566 | MOP = JMOHKK(1,NC) |
| 3567 | MOT = JMOHKK(1,NC+1) |
| 3568 | DIFF1 = ABS(PHKK(4,MOP)-PHKK(4, NC)-PHKK(4,NC+2)) |
| 3569 | DIFF2 = ABS(PHKK(4,MOT)-PHKK(4,NC+1)-PHKK(4,NC+3)) |
| 3570 | IF ((DIFF1.LT.TINY10).AND.(DIFF2.LT.TINY10)) ISINGL(I) = 1 |
| 3571 | NC = NC+4 |
| 3572 | 8 CONTINUE |
| 3573 | |
| 3574 | * multiple scattering of chain ends |
| 3575 | IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1) |
| 3576 | IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2) |
| 3577 | |
| 3578 | * switch to PHOJET-settings for JETSET parameter |
| 3579 | CALL DT_INITJS(1) |
| 3580 | |
| 3581 | * loop over nucleon-nucleon interaction |
| 3582 | NC = NPOINT(2) |
| 3583 | DO 2 I=1,NCSY |
| 3584 | * |
| 3585 | * pick up one nucleon-nucleon interaction from DTEVT1 |
| 3586 | * ppnn / ptnn - momenta of the interacting nucleons (cms) |
| 3587 | * ptotnn - total momentum of the interacting nucleons (cms) |
| 3588 | * pp1,2 / pt1,2 - momenta of the four partons |
| 3589 | * pp / pt - total momenta of the proj / targ partons |
| 3590 | * ptot - total momentum of the four partons |
| 3591 | MOP = JMOHKK(1,NC) |
| 3592 | MOT = JMOHKK(1,NC+1) |
| 3593 | DO 3 K=1,4 |
| 3594 | PPNN(K) = PHKK(K,MOP) |
| 3595 | PTNN(K) = PHKK(K,MOT) |
| 3596 | PTOTNN(K) = PPNN(K)+PTNN(K) |
| 3597 | PP1(K) = PHKK(K,NC) |
| 3598 | PT1(K) = PHKK(K,NC+1) |
| 3599 | PP2(K) = PHKK(K,NC+2) |
| 3600 | PT2(K) = PHKK(K,NC+3) |
| 3601 | PP(K) = PP1(K)+PP2(K) |
| 3602 | PT(K) = PT1(K)+PT2(K) |
| 3603 | PTOT(K) = PP(K)+PT(K) |
| 3604 | 3 CONTINUE |
| 3605 | * |
| 3606 | *----------------------------------------------------------------------- |
| 3607 | * this is a complete nucleon-nucleon interaction |
| 3608 | * |
| 3609 | IF (ISINGL(I).EQ.1) THEN |
| 3610 | * |
| 3611 | * initialize PHOJET-variables for remnant/valence-partons |
| 3612 | IHFLD(1,1) = 0 |
| 3613 | IHFLD(1,2) = 0 |
| 3614 | IHFLD(2,1) = 0 |
| 3615 | IHFLD(2,2) = 0 |
| 3616 | IHFLS(1) = 1 |
| 3617 | IHFLS(2) = 1 |
| 3618 | * save current settings of PHOJET process and min. bias flags |
| 3619 | DO 9 K=1,11 |
| 3620 | KPRON(K) = IPRON(K,1) |
| 3621 | 9 CONTINUE |
| 3622 | ISWSAV = ISWMDL(2) |
| 3623 | * |
| 3624 | * check if forced sampling of diffractive interaction requested |
| 3625 | IF (ISINGD.LT.-1) THEN |
| 3626 | DO 90 K=1,11 |
| 3627 | IPRON(K,1) = 0 |
| 3628 | 90 CONTINUE |
| 3629 | IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-3)) IPRON(5,1) = 1 |
| 3630 | IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-4)) IPRON(6,1) = 1 |
| 3631 | IF (ISINGD.EQ.-5) IPRON(4,1) = 1 |
| 3632 | ENDIF |
| 3633 | * |
| 3634 | * for photons: a direct/anomalous interaction is not sampled |
| 3635 | * in PHOJET but already in Glauber-formalism. Here we check if such |
| 3636 | * an interaction is requested |
| 3637 | IF (IJPROJ.EQ.7) THEN |
| 3638 | * first switch off direct interactions |
| 3639 | IPRON(8,1) = 0 |
| 3640 | * this is a direct interactions |
| 3641 | IF (IDIREC.EQ.1) THEN |
| 3642 | DO 12 K=1,11 |
| 3643 | IPRON(K,1) = 0 |
| 3644 | 12 CONTINUE |
| 3645 | IPRON(8,1) = 1 |
| 3646 | * this is an anomalous interactions |
| 3647 | * (iswmdl(2) = 0 only hard int. generated ( = 1 min. bias) ) |
| 3648 | ELSEIF (IDIREC.EQ.2) THEN |
| 3649 | ISWMDL(2) = 0 |
| 3650 | ENDIF |
| 3651 | ELSE |
| 3652 | IF (IDIREC.NE.0) STOP ' DT_EVENTB: IDIREC > 0 ! ' |
| 3653 | ENDIF |
| 3654 | * |
| 3655 | * make sure that total momenta of partons, pp and pt, are on mass |
| 3656 | * shell (Cronin may have srewed this up..) |
| 3657 | CALL DT_MASHEL(PP,PT,PHKK(5,MOP),PHKK(5,MOT),PPNN,PTNN,IR1) |
| 3658 | IF (IR1.NE.0) THEN |
| 3659 | IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A)') |
| 3660 | & 'EVENTB: mass shell correction rejected' |
| 3661 | GOTO 9999 |
| 3662 | ENDIF |
| 3663 | * |
| 3664 | * initialize the incoming particles in PHOJET |
| 3665 | IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN |
| 3666 | CALL PHO_SETPAR(1,22,0,VIRT) |
| 3667 | ELSE |
| 3668 | CALL PHO_SETPAR(1,IDHKK(MOP),0,ZERO) |
| 3669 | ENDIF |
| 3670 | CALL PHO_SETPAR(2,IDHKK(MOT),0,ZERO) |
| 3671 | * |
| 3672 | * initialize rejection loop counter for anomalous processes |
| 3673 | IRJANO = 0 |
| 3674 | 800 CONTINUE |
| 3675 | IRJANO = IRJANO+1 |
| 3676 | * |
| 3677 | * temporary fix for ifano problem |
| 3678 | IFANO(1) = 0 |
| 3679 | IFANO(2) = 0 |
| 3680 | * |
| 3681 | * generate complete hadron/nucleon/photon-nucleon event with PHOJET |
| 3682 | CALL PHO_EVENT(2,PPNN,PTNN,DUM,IREJ1) |
| 3683 | * |
| 3684 | * for photons: special consistency check for anomalous interactions |
| 3685 | IF (IJPROJ.EQ.7) THEN |
| 3686 | IF (IRJANO.LT.30) THEN |
| 3687 | IF (IFANO(1).NE.0) THEN |
| 3688 | * here, an anomalous interaction was generated. Check if it |
| 3689 | * was also requested. Otherwise reject this event. |
| 3690 | IF (IDIREC.EQ.0) GOTO 800 |
| 3691 | ELSE |
| 3692 | * here, an anomalous interaction was not generated. Check if it |
| 3693 | * was requested in which case we need to reject this event. |
| 3694 | IF (IDIREC.EQ.2) GOTO 800 |
| 3695 | ENDIF |
| 3696 | ELSE |
| 3697 | WRITE(LOUT,*) ' DT_EVENTB: Warning! IRJANO > 30 ', |
| 3698 | & IRJANO,IDIREC,NEVHKK |
| 3699 | ENDIF |
| 3700 | ENDIF |
| 3701 | * |
| 3702 | * copy back original settings of PHOJET process and min. bias flags |
| 3703 | DO 10 K=1,11 |
| 3704 | IPRON(K,1) = KPRON(K) |
| 3705 | 10 CONTINUE |
| 3706 | ISWMDL(2) = ISWSAV |
| 3707 | * |
| 3708 | * check if PHOJET has rejected this event |
| 3709 | IF (IREJ1.NE.0) THEN |
| 3710 | C IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)') |
| 3711 | WRITE(LOUT,'(1X,A,I4)') |
| 3712 | & 'EVENTB: chain system rejected',IDIREC |
| 3713 | CALL PHO_PREVNT(0) |
| 3714 | GOTO 9999 |
| 3715 | ENDIF |
| 3716 | * |
| 3717 | * copy partons and strings from PHOJET common back into DTEVT for |
| 3718 | * external fragmentation |
| 3719 | MO1 = NC |
| 3720 | MO2 = NC+3 |
| 3721 | *! uncomment this line for internal phojet-fragmentation |
| 3722 | C CALL DT_GETFSP(MO1,MO2,PPNN,PTNN,-1) |
| 3723 | NPHOSC = NPHOSC+1 |
| 3724 | CALL DT_GETPJE(MO1,MO2,PPNN,PTNN,-1,NPHOSC,IREJ1) |
| 3725 | IF (IREJ1.NE.0) THEN |
| 3726 | IF (IOULEV(1).GT.0) |
| 3727 | & WRITE(LOUT,'(1X,A,I4)') 'EVENTB: chain system rejected 1' |
| 3728 | GOTO 9999 |
| 3729 | ENDIF |
| 3730 | * |
| 3731 | * update statistics counter |
| 3732 | ICEVTG(IDCH(NC),29) = ICEVTG(IDCH(NC),29)+1 |
| 3733 | * |
| 3734 | *----------------------------------------------------------------------- |
| 3735 | * this interaction involves "remnants" |
| 3736 | * |
| 3737 | ELSE |
| 3738 | * |
| 3739 | * total mass of this system |
| 3740 | PPTOT = SQRT(PTOT(1)**2+PTOT(2)**2+PTOT(3)**2) |
| 3741 | AMTOT2 = (PTOT(4)-PPTOT)*(PTOT(4)+PPTOT) |
| 3742 | IF (AMTOT2.LT.ZERO) THEN |
| 3743 | AMTOT = ZERO |
| 3744 | ELSE |
| 3745 | AMTOT = SQRT(AMTOT2) |
| 3746 | ENDIF |
| 3747 | * |
| 3748 | * systems with masses larger than elojet are treated with PHOJET |
| 3749 | IF (AMTOT.GT.ELOJET) THEN |
| 3750 | * |
| 3751 | * initialize PHOJET-variables for remnant/valence-partons |
| 3752 | * projectile parton flavors and valence flag |
| 3753 | IHFLD(1,1) = IDHKK(NC) |
| 3754 | IHFLD(1,2) = IDHKK(NC+2) |
| 3755 | IHFLS(1) = 0 |
| 3756 | IF ((IDCH(NC).EQ.6).OR.(IDCH(NC).EQ.7) |
| 3757 | & .OR.(IDCH(NC).EQ.8)) IHFLS(1) = 1 |
| 3758 | * target parton flavors and valence flag |
| 3759 | IHFLD(2,1) = IDHKK(NC+1) |
| 3760 | IHFLD(2,2) = IDHKK(NC+3) |
| 3761 | IHFLS(2) = 0 |
| 3762 | IF ((IDCH(NC).EQ.4).OR.(IDCH(NC).EQ.5) |
| 3763 | & .OR.(IDCH(NC).EQ.8)) IHFLS(2) = 1 |
| 3764 | * flag signalizing PHOJET how to treat the remnant: |
| 3765 | * iremn = -1 sea-quark remnant: PHOJET takes flavors from ihfld |
| 3766 | * iremn > -1 valence remnant: PHOJET assumes flavors according |
| 3767 | * to mother particle |
| 3768 | IREMN1 = IHFLS(1)-1 |
| 3769 | IREMN2 = IHFLS(2)-1 |
| 3770 | * |
| 3771 | * initialize the incoming particles in PHOJET |
| 3772 | IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN |
| 3773 | CALL PHO_SETPAR(1,22,IREMN1,VIRT) |
| 3774 | ELSE |
| 3775 | CALL PHO_SETPAR(1,IDHKK(MOP),IREMN1,ZERO) |
| 3776 | ENDIF |
| 3777 | CALL PHO_SETPAR(2,IDHKK(MOT),IREMN2,ZERO) |
| 3778 | * |
| 3779 | * calculate Lorentz parameter of the nucleon-nucleon cm-system |
| 3780 | PPTOTN = SQRT(PTOTNN(1)**2+PTOTNN(2)**2+PTOTNN(3)**2) |
| 3781 | AMNN = SQRT( (PTOTNN(4)-PPTOTN)*(PTOTNN(4)+PPTOTN) ) |
| 3782 | BGX = PTOTNN(1)/AMNN |
| 3783 | BGY = PTOTNN(2)/AMNN |
| 3784 | BGZ = PTOTNN(3)/AMNN |
| 3785 | GAM = PTOTNN(4)/AMNN |
| 3786 | * transform interacting nucleons into nucleon-nucleon cm-system |
| 3787 | CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ, |
| 3788 | & PPNN(1),PPNN(2),PPNN(3),PPNN(4),PPCMS, |
| 3789 | & PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4)) |
| 3790 | CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ, |
| 3791 | & PTNN(1),PTNN(2),PTNN(3),PTNN(4),PTCMS, |
| 3792 | & PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4)) |
| 3793 | * transform (total) momenta of the proj and targ partons into |
| 3794 | * nucleon-nucleon cm-system |
| 3795 | CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ, |
| 3796 | & PP(1),PP(2),PP(3),PP(4), |
| 3797 | & PPTSUB,PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4)) |
| 3798 | CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ, |
| 3799 | & PT(1),PT(2),PT(3),PT(4), |
| 3800 | & PTTSUB,PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4)) |
| 3801 | * energy fractions of the proj and targ partons |
| 3802 | XPSUB = MIN(PPSUB(4)/PPTCMS(4),ONE) |
| 3803 | XTSUB = MIN(PTSUB(4)/PTTCMS(4),ONE) |
| 3804 | *** |
| 3805 | * testprint |
| 3806 | c PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 + |
| 3807 | c & (PPTCMS(2)+PTTCMS(2))**2 + |
| 3808 | c & (PPTCMS(3)+PTTCMS(3))**2 ) |
| 3809 | c EOLDCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) * |
| 3810 | c & (PPTCMS(4)+PTTCMS(4)+PTOTCM) ) |
| 3811 | c PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 + |
| 3812 | c & (PPSUB(2)+PTSUB(2))**2 + |
| 3813 | c & (PPSUB(3)+PTSUB(3))**2 ) |
| 3814 | c EOLDSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) * |
| 3815 | c & (PPSUB(4)+PTSUB(4)+PTOTSU) ) |
| 3816 | *** |
| 3817 | * |
| 3818 | * save current settings of PHOJET process and min. bias flags |
| 3819 | DO 7 K=1,11 |
| 3820 | KPRON(K) = IPRON(K,1) |
| 3821 | 7 CONTINUE |
| 3822 | * disallow direct photon int. (does not make sense here anyway) |
| 3823 | IPRON(8,1) = 0 |
| 3824 | * disallow double pomeron processes (due to technical problems |
| 3825 | * in PHOJET, needs to be solved sometime) |
| 3826 | IPRON(4,1) = 0 |
| 3827 | * disallow diffraction for sea-diquarks |
| 3828 | IF ((IABS(IHFLD(1,1)).GT.1100).AND. |
| 3829 | & (IABS(IHFLD(1,2)).GT.1100)) THEN |
| 3830 | IPRON(3,1) = 0 |
| 3831 | IPRON(6,1) = 0 |
| 3832 | ENDIF |
| 3833 | IF ((IABS(IHFLD(2,1)).GT.1100).AND. |
| 3834 | & (IABS(IHFLD(2,2)).GT.1100)) THEN |
| 3835 | IPRON(3,1) = 0 |
| 3836 | IPRON(5,1) = 0 |
| 3837 | ENDIF |
| 3838 | * |
| 3839 | * we need massless partons: transform them on mass shell |
| 3840 | XMP = ZERO |
| 3841 | XMT = ZERO |
| 3842 | DO 6 K=1,4 |
| 3843 | PPTMP(K) = PPSUB(K) |
| 3844 | PTTMP(K) = PTSUB(K) |
| 3845 | 6 CONTINUE |
| 3846 | CALL DT_MASHEL(PPTMP,PTTMP,XMP,XMT,PPSUB,PTSUB,IREJ1) |
| 3847 | PPSUTO = SQRT(PPSUB(1)**2+PPSUB(2)**2+PPSUB(3)**2) |
| 3848 | PTSUTO = SQRT(PTSUB(1)**2+PTSUB(2)**2+PTSUB(3)**2) |
| 3849 | PSUTOT = SQRT((PPSUB(1)+PTSUB(1))**2+ |
| 3850 | & (PPSUB(2)+PTSUB(2))**2+(PPSUB(3)+PTSUB(3))**2) |
| 3851 | * total energy of the subsysten after mass transformation |
| 3852 | * (should be the same as before..) |
| 3853 | SECM = SQRT( (PPSUB(4)+PTSUB(4)-PSUTOT)* |
| 3854 | & (PPSUB(4)+PTSUB(4)+PSUTOT) ) |
| 3855 | * |
| 3856 | * after mass shell transformation the x_sub - relation has to be |
| 3857 | * corrected. We therefore create "pseudo-momenta" of mother-nucleons. |
| 3858 | * |
| 3859 | * The old version was to scale based on the original x_sub and the |
| 3860 | * 4-momenta of the subsystem. At very high energy this could lead to |
| 3861 | * "pseudo-cm energies" of the parent system considerably exceeding |
| 3862 | * the true cm energy. Now we keep the true cm energy and calculate |
| 3863 | * new x_sub instead. |
| 3864 | C old version PPTCMS(4) = PPSUB(4)/XPSUB |
| 3865 | PPTCMS(4) = MAX(PPTCMS(4),PPSUB(4)) |
| 3866 | XPSUB = PPSUB(4)/PPTCMS(4) |
| 3867 | IF (IJPROJ.EQ.7) THEN |
| 3868 | AMP2 = PHKK(5,MOT)**2 |
| 3869 | PTOT1 = SQRT(PPTCMS(4)**2-AMP2) |
| 3870 | ELSE |
| 3871 | *??????? |
| 3872 | PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOP)) |
| 3873 | & *(PPTCMS(4)+PHKK(5,MOP))) |
| 3874 | C PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOT)) |
| 3875 | C & *(PPTCMS(4)+PHKK(5,MOT))) |
| 3876 | ENDIF |
| 3877 | C old version PTTCMS(4) = PTSUB(4)/XTSUB |
| 3878 | PTTCMS(4) = MAX(PTTCMS(4),PTSUB(4)) |
| 3879 | XTSUB = PTSUB(4)/PTTCMS(4) |
| 3880 | PTOT2 = SQRT((PTTCMS(4)-PHKK(5,MOT)) |
| 3881 | & *(PTTCMS(4)+PHKK(5,MOT))) |
| 3882 | DO 4 K=1,3 |
| 3883 | PPTCMS(K) = PTOT1*PPSUB(K)/PPSUTO |
| 3884 | PTTCMS(K) = PTOT2*PTSUB(K)/PTSUTO |
| 3885 | 4 CONTINUE |
| 3886 | *** |
| 3887 | * testprint |
| 3888 | * |
| 3889 | * ppnn / ptnn - momenta of the int. nucleons (cms, negl. Fermi) |
| 3890 | * ptotnn - total momentum of the int. nucleons (cms, negl. Fermi) |
| 3891 | * pptcms/ pttcms - momenta of the interacting nucleons (cms) |
| 3892 | * pp1,2 / pt1,2 - momenta of the four partons |
| 3893 | * |
| 3894 | * pp / pt - total momenta of the pr/ta partons (cms, negl. Fermi) |
| 3895 | * ptot - total momentum of the four partons (cms, negl. Fermi) |
| 3896 | * ppsub / ptsub - total momenta of the proj / targ partons (cms) |
| 3897 | * |
| 3898 | c PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 + |
| 3899 | c & (PPTCMS(2)+PTTCMS(2))**2 + |
| 3900 | c & (PPTCMS(3)+PTTCMS(3))**2 ) |
| 3901 | c ENEWCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) * |
| 3902 | c & (PPTCMS(4)+PTTCMS(4)+PTOTCM) ) |
| 3903 | c PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 + |
| 3904 | c & (PPSUB(2)+PTSUB(2))**2 + |
| 3905 | c & (PPSUB(3)+PTSUB(3))**2 ) |
| 3906 | c ENEWSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) * |
| 3907 | c & (PPSUB(4)+PTSUB(4)+PTOTSU) ) |
| 3908 | c IF (ENEWCM/EOLDCM.GT.1.1D0) THEN |
| 3909 | c WRITE(*,*) ' EOLDCM, ENEWCM : ',EOLDCM,ENEWCM |
| 3910 | c WRITE(*,*) ' EOLDSU, ENEWSU : ',EOLDSU,ENEWSU |
| 3911 | c WRITE(*,*) ' XPSUB, XTSUB : ',XPSUB,XTSUB |
| 3912 | c ENDIF |
| 3913 | c BBGX = (PPTCMS(1)+PTTCMS(1))/ENEWCM |
| 3914 | c BBGY = (PPTCMS(2)+PTTCMS(2))/ENEWCM |
| 3915 | c BBGZ = (PPTCMS(3)+PTTCMS(3))/ENEWCM |
| 3916 | c BGAM = (PPTCMS(4)+PTTCMS(4))/ENEWCM |
| 3917 | * transform interacting nucleons into nucleon-nucleon cm-system |
| 3918 | c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ, |
| 3919 | c & PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4),PPTOT, |
| 3920 | c & PPNEW1,PPNEW2,PPNEW3,PPNEW4) |
| 3921 | c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ, |
| 3922 | c & PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4),PTTOT, |
| 3923 | c & PTNEW1,PTNEW2,PTNEW3,PTNEW4) |
| 3924 | c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ, |
| 3925 | c & PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4),PPTOT, |
| 3926 | c & PPSUB1,PPSUB2,PPSUB3,PPSUB4) |
| 3927 | c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ, |
| 3928 | c & PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4),PTTOT, |
| 3929 | c & PTSUB1,PTSUB2,PTSUB3,PTSUB4) |
| 3930 | c PTSTCM = SQRT( (PPNEW1+PTNEW1)**2 + |
| 3931 | c & (PPNEW2+PTNEW2)**2 + |
| 3932 | c & (PPNEW3+PTNEW3)**2 ) |
| 3933 | c ETSTCM = SQRT( (PPNEW4+PTNEW4-PTSTCM) * |
| 3934 | c & (PPNEW4+PTNEW4+PTSTCM) ) |
| 3935 | c PTSTSU = SQRT( (PPSUB1+PTSUB1)**2 + |
| 3936 | c & (PPSUB2+PTSUB2)**2 + |
| 3937 | c & (PPSUB3+PTSUB3)**2 ) |
| 3938 | c ETSTSU = SQRT( (PPSUB4+PTSUB4-PTSTSU) * |
| 3939 | c & (PPSUB4+PTSUB4+PTSTSU) ) |
| 3940 | C WRITE(*,*) ' mother cmE :' |
| 3941 | C WRITE(*,*) ETSTCM,ENEWCM |
| 3942 | C WRITE(*,*) ' subsystem cmE :' |
| 3943 | C WRITE(*,*) ETSTSU,ENEWSU |
| 3944 | C WRITE(*,*) ' projectile mother :' |
| 3945 | C WRITE(*,*) PPNEW1,PPNEW2,PPNEW3,PPNEW4 |
| 3946 | C WRITE(*,*) ' target mother :' |
| 3947 | C WRITE(*,*) PTNEW1,PTNEW2,PTNEW3,PTNEW4 |
| 3948 | C WRITE(*,*) ' projectile subsystem:' |
| 3949 | C WRITE(*,*) PPSUB1,PPSUB2,PPSUB3,PPSUB4 |
| 3950 | C WRITE(*,*) ' target subsystem:' |
| 3951 | C WRITE(*,*) PTSUB1,PTSUB2,PTSUB3,PTSUB4 |
| 3952 | C WRITE(*,*) ' projectile subsystem should be:' |
| 3953 | C WRITE(*,*) ZERO,ZERO,XPSUB*ETSTCM/2.0D0, |
| 3954 | C & XPSUB*ETSTCM/2.0D0 |
| 3955 | C WRITE(*,*) ' target subsystem should be:' |
| 3956 | C WRITE(*,*) ZERO,ZERO,-XTSUB*ETSTCM/2.0D0, |
| 3957 | C & XTSUB*ETSTCM/2.0D0 |
| 3958 | C WRITE(*,*) ' subsystem cmE should be: ' |
| 3959 | C WRITE(*,*) SQRT(XPSUB*XTSUB)*ETSTCM,XPSUB,XTSUB |
| 3960 | *** |
| 3961 | * |
| 3962 | * generate complete remnant - nucleon/remnant event with PHOJET |
| 3963 | CALL PHO_EVENT(3,PPTCMS,PTTCMS,DUM,IREJ1) |
| 3964 | * |
| 3965 | * copy back original settings of PHOJET process flags |
| 3966 | DO 11 K=1,11 |
| 3967 | IPRON(K,1) = KPRON(K) |
| 3968 | 11 CONTINUE |
| 3969 | * |
| 3970 | * check if PHOJET has rejected this event |
| 3971 | IF (IREJ1.NE.0) THEN |
| 3972 | IF (IOULEV(1).GT.0) |
| 3973 | & WRITE(LOUT,'(1X,A)') 'EVENTB: chain system rejected' |
| 3974 | WRITE(LOUT,*) |
| 3975 | & 'XPSUB,XTSUB,SECM ',XPSUB,XTSUB,SECM,AMTOT |
| 3976 | CALL PHO_PREVNT(0) |
| 3977 | GOTO 9999 |
| 3978 | ENDIF |
| 3979 | * |
| 3980 | * copy partons and strings from PHOJET common back into DTEVT for |
| 3981 | * external fragmentation |
| 3982 | MO1 = NC |
| 3983 | MO2 = NC+3 |
| 3984 | *! uncomment this line for internal phojet-fragmentation |
| 3985 | C CALL DT_GETFSP(MO1,MO2,PP,PT,1) |
| 3986 | NPHOSC = NPHOSC+1 |
| 3987 | CALL DT_GETPJE(MO1,MO2,PP,PT,1,NPHOSC,IREJ1) |
| 3988 | IF (IREJ1.NE.0) THEN |
| 3989 | IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)') |
| 3990 | & 'EVENTB: chain system rejected 2' |
| 3991 | GOTO 9999 |
| 3992 | ENDIF |
| 3993 | * |
| 3994 | * update statistics counter |
| 3995 | ICEVTG(IDCH(NC),2) = ICEVTG(IDCH(NC),2)+1 |
| 3996 | * |
| 3997 | *----------------------------------------------------------------------- |
| 3998 | * two-chain approx. for smaller systems |
| 3999 | * |
| 4000 | ELSE |
| 4001 | * |
| 4002 | NDTUSC = NDTUSC+1 |
| 4003 | * special flag for double-Pomeron statistics |
| 4004 | IPOPO = 0 |
| 4005 | * |
| 4006 | * pick up flavors at the ends of the two chains |
| 4007 | IFP1 = IDHKK(NC) |
| 4008 | IFT1 = IDHKK(NC+1) |
| 4009 | IFP2 = IDHKK(NC+2) |
| 4010 | IFT2 = IDHKK(NC+3) |
| 4011 | * ..and the indices of the mothers |
| 4012 | MOP1 = NC |
| 4013 | MOT1 = NC+1 |
| 4014 | MOP2 = NC+2 |
| 4015 | MOT2 = NC+3 |
| 4016 | CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2, |
| 4017 | & IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1) |
| 4018 | * |
| 4019 | * check if this chain system was rejected |
| 4020 | IF (IREJ1.GT.0) THEN |
| 4021 | IF (IOULEV(1).GT.0) THEN |
| 4022 | WRITE(LOUT,*) 'rejected 1 in EVENTB' |
| 4023 | WRITE(LOUT,'(1X,4(I6,4E12.3,/),E12.3)') |
| 4024 | & IFP1,PP1,IFT1,PT1,IFP2,PP2,IFT2,PT2,AMTOT |
| 4025 | ENDIF |
| 4026 | IRHHA = IRHHA+1 |
| 4027 | GOTO 9999 |
| 4028 | ENDIF |
| 4029 | * the following lines are for sea-sea chains rejected in GETCSY |
| 4030 | IF (IREJ1.EQ.-1) NDTUSC = NDTUSC-1 |
| 4031 | ICEVTG(IDCH(NC),1) = ICEVTG(IDCH(NC),1)+1 |
| 4032 | ENDIF |
| 4033 | * |
| 4034 | ENDIF |
| 4035 | * |
| 4036 | * update statistics counter |
| 4037 | ICEVTG(IDCH(NC),0) = ICEVTG(IDCH(NC),0)+1 |
| 4038 | * |
| 4039 | NC = NC+4 |
| 4040 | * |
| 4041 | 2 CONTINUE |
| 4042 | * |
| 4043 | *----------------------------------------------------------------------- |
| 4044 | * treatment of low-mass chains (if there are any) |
| 4045 | * |
| 4046 | IF (NDTUSC.GT.0) THEN |
| 4047 | * |
| 4048 | * correct chains of very low masses for possible resonances |
| 4049 | IF (IRESCO.EQ.1) THEN |
| 4050 | CALL DT_EVTRES(IREJ1) |
| 4051 | IF (IREJ1.GT.0) THEN |
| 4052 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2a in EVENTB' |
| 4053 | IRRES(1) = IRRES(1)+1 |
| 4054 | GOTO 9999 |
| 4055 | ENDIF |
| 4056 | ENDIF |
| 4057 | * fragmentation of low-mass chains |
| 4058 | *! uncomment this line for internal phojet-fragmentation |
| 4059 | * (of course it will still be fragmented by DPMJET-routines but it |
| 4060 | * has to be done here instead of further below) |
| 4061 | C CALL DT_EVTFRA(IREJ1) |
| 4062 | C IF (IREJ1.GT.0) THEN |
| 4063 | C IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2b in EVENTB' |
| 4064 | C IRFRAG = IRFRAG+1 |
| 4065 | C GOTO 9999 |
| 4066 | C ENDIF |
| 4067 | ELSE |
| 4068 | *! uncomment this line for internal phojet-fragmentation |
| 4069 | C NPOINT(4) = NHKK+1 |
| 4070 | IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1 |
| 4071 | ENDIF |
| 4072 | * |
| 4073 | *----------------------------------------------------------------------- |
| 4074 | * new di-quark breaking mechanisms |
| 4075 | * |
| 4076 | MXLEFT = 2 |
| 4077 | CALL DT_CHASTA(0) |
| 4078 | IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0) |
| 4079 | & .OR.(PDBSEA(3).GT.0.0D0)) THEN |
| 4080 | CALL DT_DIQBRK |
| 4081 | MXLEFT = 4 |
| 4082 | ENDIF |
| 4083 | * |
| 4084 | *----------------------------------------------------------------------- |
| 4085 | * hadronize this event |
| 4086 | * |
| 4087 | * hadronize PHOJET chain systems |
| 4088 | NPYMAX = 0 |
| 4089 | NPJE = NPHOSC/MXPHFR |
| 4090 | IF (MXPHFR.LT.MXLEFT) MXLEFT = 2 |
| 4091 | IF (NPJE.GT.1) THEN |
| 4092 | NLEFT = NPHOSC-NPJE*MXPHFR |
| 4093 | DO 20 JFRG=1,NPJE |
| 4094 | NFRG = JFRG*MXPHFR |
| 4095 | IF ((JFRG.EQ.NPJE).AND.(NLEFT.LE.MXLEFT)) THEN |
| 4096 | CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1) |
| 4097 | IF (IREJ1.GT.0) GOTO 22 |
| 4098 | NLEFT = 0 |
| 4099 | ELSE |
| 4100 | CALL DT_EVTFRG(1,NFRG,NPYMEM,IREJ1) |
| 4101 | IF (IREJ1.GT.0) GOTO 22 |
| 4102 | ENDIF |
| 4103 | IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM |
| 4104 | 20 CONTINUE |
| 4105 | IF (NLEFT.GT.0) THEN |
| 4106 | CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1) |
| 4107 | IF (IREJ1.GT.0) GOTO 22 |
| 4108 | IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM |
| 4109 | ENDIF |
| 4110 | ELSE |
| 4111 | CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1) |
| 4112 | IF (IREJ1.GT.0) GOTO 22 |
| 4113 | IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM |
| 4114 | ENDIF |
| 4115 | * |
| 4116 | * check max. filling level of jetset common and |
| 4117 | * reduce mxphfr if necessary |
| 4118 | IF (NPYMAX.GT.3000) THEN |
| 4119 | IF (NPYMAX.GT.3500) THEN |
| 4120 | MXPHFR = MAX(1,MXPHFR-2) |
| 4121 | ELSE |
| 4122 | MXPHFR = MAX(1,MXPHFR-1) |
| 4123 | ENDIF |
| 4124 | C WRITE(LOUT,*) ' EVENTB: Mxphfr reduced to ',MXPHFR |
| 4125 | ENDIF |
| 4126 | * |
| 4127 | * hadronize DTUNUC chain systems |
| 4128 | 23 CONTINUE |
| 4129 | IBACK = MXDTFR |
| 4130 | CALL DT_EVTFRG(2,IBACK,NPYMEM,IREJ2) |
| 4131 | IF (IREJ2.GT.0) GOTO 22 |
| 4132 | * |
| 4133 | * check max. filling level of jetset common and |
| 4134 | * reduce mxdtfr if necessary |
| 4135 | IF (NPYMEM.GT.3000) THEN |
| 4136 | IF (NPYMEM.GT.3500) THEN |
| 4137 | MXDTFR = MAX(1,MXDTFR-20) |
| 4138 | ELSE |
| 4139 | MXDTFR = MAX(1,MXDTFR-10) |
| 4140 | ENDIF |
| 4141 | C WRITE(LOUT,*) ' EVENTB: Mxdtfr reduced to ',MXDTFR |
| 4142 | ENDIF |
| 4143 | * |
| 4144 | IF (IBACK.EQ.-1) GOTO 23 |
| 4145 | * |
| 4146 | 22 CONTINUE |
| 4147 | C CALL DT_EVTFRG(1,IREJ1) |
| 4148 | C CALL DT_EVTFRG(2,IREJ2) |
| 4149 | IF ((IREJ1.GT.0).OR.(IREJ2.GT.0)) THEN |
| 4150 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTB' |
| 4151 | IRFRAG = IRFRAG+1 |
| 4152 | GOTO 9999 |
| 4153 | ENDIF |
| 4154 | * |
| 4155 | * get final state particles from /DTEVTP/ |
| 4156 | *! uncomment this line for internal phojet-fragmentation |
| 4157 | C CALL DT_GETFSP(IDUM,IDUM,PP,PT,2) |
| 4158 | |
| 4159 | IF (IJPROJ.NE.7) |
| 4160 | & CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,88,IREJ3) |
| 4161 | C IF (IREJ3.NE.0) GOTO 9999 |
| 4162 | |
| 4163 | RETURN |
| 4164 | |
| 4165 | 9999 CONTINUE |
| 4166 | IREVT = IREVT+1 |
| 4167 | IREJ = 1 |
| 4168 | RETURN |
| 4169 | END |
| 4170 | |
| 4171 | *$ CREATE DT_GETPJE.FOR |
| 4172 | *COPY DT_GETPJE |
| 4173 | * |
| 4174 | *===getpje=============================================================* |
| 4175 | * |
| 4176 | SUBROUTINE DT_GETPJE(MO1,MO2,PP,PT,MODE,IPJE,IREJ) |
| 4177 | |
| 4178 | ************************************************************************ |
| 4179 | * This subroutine copies PHOJET partons and strings from POEVT1 into * |
| 4180 | * DTEVT1. * |
| 4181 | * MO1,MO2 indices of first and last mother-parton in DTEVT1 * |
| 4182 | * PP,PT 4-momenta of projectile/target being handled by * |
| 4183 | * PHOJET * |
| 4184 | * This version dated 11.12.99 is written by S. Roesler * |
| 4185 | ************************************************************************ |
| 4186 | |
| 4187 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 4188 | SAVE |
| 4189 | PARAMETER ( LINP = 10 , |
| 4190 | & LOUT = 6 , |
| 4191 | & LDAT = 9 ) |
| 4192 | PARAMETER (TINY10=1.0D-10,TINY1=1.0D-1, |
| 4193 | & ZERO=0.0D0,ONE=1.0D0,OHALF=0.5D0) |
| 4194 | |
| 4195 | LOGICAL LFLIP |
| 4196 | |
| 4197 | * event history |
| 4198 | PARAMETER (NMXHKK=200000) |
| 4199 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 4200 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 4201 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 4202 | * extended event history |
| 4203 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 4204 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 4205 | & IHIST(2,NMXHKK) |
| 4206 | * Lorentz-parameters of the current interaction |
| 4207 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, |
| 4208 | & UMO,PPCM,EPROJ,PPROJ |
| 4209 | * DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem |
| 4210 | COMMON /DTLTSU/ BGX,BGY,BGZ,GAM |
| 4211 | * flags for input different options |
| 4212 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 4213 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 4214 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 4215 | * statistics: double-Pomeron exchange |
| 4216 | COMMON /DTFLG2/ INTFLG,IPOPO |
| 4217 | * statistics |
| 4218 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, |
| 4219 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), |
| 4220 | & ICEVTG(8,0:30) |
| 4221 | * rejection counter |
| 4222 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, |
| 4223 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, |
| 4224 | & IREXCI(3),IRDIFF(2),IRINC |
| 4225 | C standard particle data interface |
| 4226 | INTEGER NMXHEP |
| 4227 | PARAMETER (NMXHEP=4000) |
| 4228 | INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP |
| 4229 | DOUBLE PRECISION PHEP,VHEP |
| 4230 | COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP), |
| 4231 | & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP), |
| 09b429a4 |
4232 | & VHEP(4,NMXHEP), NSD1, NSD2, NDD |
| 9aaba0d6 |
4233 | C extension to standard particle data interface (PHOJET specific) |
| 4234 | INTEGER IMPART,IPHIST,ICOLOR |
| 4235 | COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP) |
| 4236 | C color string configurations including collapsed strings and hadrons |
| 4237 | INTEGER MSTR |
| 4238 | PARAMETER (MSTR=500) |
| 4239 | INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD |
| 4240 | COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR), |
| 4241 | & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR), |
| 4242 | & NNCH(MSTR),IBHAD(MSTR),ISTR |
| 4243 | C general process information |
| 4244 | INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON |
| 4245 | COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4) |
| 4246 | C model switches and parameters |
| 4247 | CHARACTER*8 MDLNA |
| 4248 | INTEGER ISWMDL,IPAMDL |
| 4249 | DOUBLE PRECISION PARMDL |
| 4250 | COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400) |
| 4251 | C event debugging information |
| 4252 | INTEGER NMAXD |
| 4253 | PARAMETER (NMAXD=100) |
| 4254 | INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO, |
| 4255 | & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD |
| 4256 | COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG, |
| 4257 | & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD |
| 4258 | |
| 4259 | DIMENSION PP(4),PT(4) |
| 4260 | DATA MAXLOP /10000/ |
| 4261 | |
| 4262 | INHKK = NHKK |
| 4263 | LFLIP = .TRUE. |
| 4264 | 1 CONTINUE |
| 4265 | NPVAL = 0 |
| 4266 | NTVAL = 0 |
| 4267 | IREJ = 0 |
| 4268 | |
| 4269 | * store initial momenta for energy-momentum conservation check |
| 4270 | IF (LEMCCK) THEN |
| 4271 | CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM1,IDUM2) |
| 4272 | CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM1,IDUM2) |
| 4273 | ENDIF |
| 4274 | * copy partons and strings from POEVT1 into DTEVT1 |
| 4275 | DO 11 I=1,ISTR |
| 4276 | C IF ((NCODE(I).EQ.-99).AND.(IPAMDL(17).EQ.0)) THEN |
| 4277 | IF (NCODE(I).EQ.-99) THEN |
| 4278 | IDXSTG = NPOS(1,I) |
| 4279 | IDSTG = IDHEP(IDXSTG) |
| 4280 | PX = PHEP(1,IDXSTG) |
| 4281 | PY = PHEP(2,IDXSTG) |
| 4282 | PZ = PHEP(3,IDXSTG) |
| 4283 | PE = PHEP(4,IDXSTG) |
| 4284 | IF (MODE.LT.0) THEN |
| 4285 | ISTAT = 70000+IPJE |
| 4286 | CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PX,PY,PZ,PE, |
| 4287 | & 11,IDSTG,0) |
| 4288 | IF (LEMCCK) THEN |
| 4289 | PX = -PX |
| 4290 | PY = -PY |
| 4291 | PZ = -PZ |
| 4292 | PE = -PE |
| 4293 | CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2) |
| 4294 | ENDIF |
| 4295 | ELSE |
| 4296 | CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP, |
| 4297 | & PPX,PPY,PPZ,PPE) |
| 4298 | ISTAT = 70000+IPJE |
| 4299 | CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PPX,PPY,PPZ,PPE, |
| 4300 | & 11,IDSTG,0) |
| 4301 | IF (LEMCCK) THEN |
| 4302 | PX = -PPX |
| 4303 | PY = -PPY |
| 4304 | PZ = -PPZ |
| 4305 | PE = -PPE |
| 4306 | CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2) |
| 4307 | ENDIF |
| 4308 | ENDIF |
| 4309 | NOBAM(NHKK) = 0 |
| 4310 | IHIST(1,NHKK) = IPHIST(1,IDXSTG) |
| 4311 | IHIST(2,NHKK) = 0 |
| 4312 | ELSEIF (NCODE(I).GE.0) THEN |
| 4313 | * indices of partons and string in POEVT1 |
| 4314 | IDX1 = ABS(JMOHEP(1,NPOS(1,I))) |
| 4315 | IDX2 = ABS(JMOHEP(2,NPOS(1,I))) |
| 4316 | IF ((IDX1.GT.IDX2).OR.(JMOHEP(2,NPOS(1,I)).GT.0)) THEN |
| 4317 | WRITE(LOUT,*) ' GETPJE: IDX1.GT.IDX2 ',IDX1,IDX2, |
| 4318 | & ' or JMOHEP(2,NPOS(1,I)).GT.0 ',JMOHEP(2,NPOS(1,I)),' ! ' |
| 4319 | STOP ' GETPJE 1' |
| 4320 | ENDIF |
| 4321 | IDXSTG = NPOS(1,I) |
| 4322 | * find "mother" string of the string |
| 4323 | IDXMS1 = ABS(JMOHEP(1,IDX1)) |
| 4324 | IDXMS2 = ABS(JMOHEP(1,IDX2)) |
| 4325 | IF (IDXMS1.NE.IDXMS2) THEN |
| 4326 | IDXMS1 = IDXSTG |
| 4327 | IDXMS2 = IDXSTG |
| 4328 | C STOP ' GETPJE: IDXMS1.NE.IDXMS2 !' |
| 4329 | ENDIF |
| 4330 | * search POEVT1 for the original hadron of the parton |
| 4331 | ILOOP = 0 |
| 4332 | IPOM1 = 0 |
| 4333 | 14 CONTINUE |
| 4334 | ILOOP = ILOOP+1 |
| 4335 | IF (IDHEP(IDXMS1).EQ.990) IPOM1 = 1 |
| 4336 | IDXMS1 = ABS(JMOHEP(1,IDXMS1)) |
| 4337 | IF ((IDXMS1.NE.1).AND.(IDXMS1.NE.2).AND. |
| 4338 | & (ILOOP.LT.MAXLOP)) GOTO 14 |
| 4339 | IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 1 ! ' |
| 4340 | IPOM2 = 0 |
| 4341 | ILOOP = 0 |
| 4342 | 15 CONTINUE |
| 4343 | ILOOP = ILOOP+1 |
| 4344 | IF (IDHEP(IDXMS2).EQ.990) IPOM2 = 1 |
| 4345 | IF ((ILOOP.EQ.1).OR.(IDHEP(IDXMS2).GE.7777)) THEN |
| 4346 | IDXMS2 = ABS(JMOHEP(2,IDXMS2)) |
| 4347 | ELSE |
| 4348 | IDXMS2 = ABS(JMOHEP(1,IDXMS2)) |
| 4349 | ENDIF |
| 4350 | IF ((IDXMS2.NE.1).AND.(IDXMS2.NE.2).AND. |
| 4351 | & (ILOOP.LT.MAXLOP)) GOTO 15 |
| 4352 | IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 5 ! ' |
| 4353 | * parton 1 |
| 4354 | IF (IDXMS1.EQ.1) THEN |
| 4355 | ISPTN1 = ISTHKK(MO1) |
| 4356 | M1PTN1 = MO1 |
| 4357 | M2PTN1 = MO1+2 |
| 4358 | ELSE |
| 4359 | ISPTN1 = ISTHKK(MO2) |
| 4360 | M1PTN1 = MO2-2 |
| 4361 | M2PTN1 = MO2 |
| 4362 | ENDIF |
| 4363 | * parton 2 |
| 4364 | IF (IDXMS2.EQ.1) THEN |
| 4365 | ISPTN2 = ISTHKK(MO1) |
| 4366 | M1PTN2 = MO1 |
| 4367 | M2PTN2 = MO1+2 |
| 4368 | ELSE |
| 4369 | ISPTN2 = ISTHKK(MO2) |
| 4370 | M1PTN2 = MO2-2 |
| 4371 | M2PTN2 = MO2 |
| 4372 | ENDIF |
| 4373 | * check for mis-identified mothers and switch mother indices if necessary |
| 4374 | IF ((IDXMS1.EQ.IDXMS2).AND.(IPROCE.NE.5).AND.(IPROCE.NE.6) |
| 4375 | & .AND.((IDHEP(IDX1).NE.21).OR.(IDHEP(IDX2).NE.21)).AND. |
| 4376 | & (LFLIP)) THEN |
| 4377 | IF (PHEP(3,IDX1).GT.PHEP(3,IDX2)) THEN |
| 4378 | ISPTN1 = ISTHKK(MO1) |
| 4379 | M1PTN1 = MO1 |
| 4380 | M2PTN1 = MO1+2 |
| 4381 | ISPTN2 = ISTHKK(MO2) |
| 4382 | M1PTN2 = MO2-2 |
| 4383 | M2PTN2 = MO2 |
| 4384 | ELSE |
| 4385 | ISPTN1 = ISTHKK(MO2) |
| 4386 | M1PTN1 = MO2-2 |
| 4387 | M2PTN1 = MO2 |
| 4388 | ISPTN2 = ISTHKK(MO1) |
| 4389 | M1PTN2 = MO1 |
| 4390 | M2PTN2 = MO1+2 |
| 4391 | ENDIF |
| 4392 | ENDIF |
| 4393 | * register partons in temporary common |
| 4394 | * parton at chain end |
| 4395 | PX = PHEP(1,IDX1) |
| 4396 | PY = PHEP(2,IDX1) |
| 4397 | PZ = PHEP(3,IDX1) |
| 4398 | PE = PHEP(4,IDX1) |
| 4399 | * flag only partons coming from Pomeron with 41/42 |
| 4400 | C IF ((IPOM1.NE.0).OR.(NPOS(4,I).GE.4)) THEN |
| 4401 | IF (IPOM1.NE.0) THEN |
| 4402 | ISTX = ABS(ISPTN1)/10 |
| 4403 | IMO = ABS(ISPTN1)-10*ISTX |
| 4404 | ISPTN1 = -(40+IMO) |
| 4405 | ELSE |
| 4406 | IF ((ICOLOR(2,IDX1).EQ.0).OR.(IDHEP(IDX1).EQ.21)) THEN |
| 4407 | ISTX = ABS(ISPTN1)/10 |
| 4408 | IMO = ABS(ISPTN1)-10*ISTX |
| 4409 | IF ((IDHEP(IDX1).EQ.21).OR. |
| 4410 | & (ABS(IPHIST(1,IDX1)).GE.100)) THEN |
| 4411 | ISPTN1 = -(60+IMO) |
| 4412 | ELSE |
| 4413 | ISPTN1 = -(50+IMO) |
| 4414 | ENDIF |
| 4415 | ENDIF |
| 4416 | ENDIF |
| 4417 | IF (ISPTN1.EQ.-21) NPVAL = NPVAL+1 |
| 4418 | IF (ISPTN1.EQ.-22) NTVAL = NTVAL+1 |
| 4419 | IF (MODE.LT.0) THEN |
| 4420 | CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PX,PY, |
| 4421 | & PZ,PE,0,0,0) |
| 4422 | ELSE |
| 4423 | CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP, |
| 4424 | & PPX,PPY,PPZ,PPE) |
| 4425 | CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PPX,PPY, |
| 4426 | & PPZ,PPE,0,0,0) |
| 4427 | ENDIF |
| 4428 | IHIST(1,NHKK) = IPHIST(1,IDX1) |
| 4429 | IHIST(2,NHKK) = 0 |
| 4430 | DO 19 KK=1,4 |
| 4431 | VHKK(KK,NHKK) = VHKK(KK,M2PTN1) |
| 4432 | WHKK(KK,NHKK) = WHKK(KK,M1PTN1) |
| 4433 | 19 CONTINUE |
| 4434 | VHKK(4,NHKK) = VHKK(3,M2PTN1)/BLAB-VHKK(3,M1PTN1)/BGLAB |
| 4435 | WHKK(4,NHKK) = -WHKK(3,M1PTN1)/BLAB+WHKK(3,M2PTN1)/BGLAB |
| 4436 | M1STRG = NHKK |
| 4437 | * gluon kinks |
| 4438 | NGLUON = IDX2-IDX1-1 |
| 4439 | IF (NGLUON.GT.0) THEN |
| 4440 | DO 17 IGLUON=1,NGLUON |
| 4441 | IDX = IDX1+IGLUON |
| 4442 | IDXMS = ABS(JMOHEP(1,IDX)) |
| 4443 | IF ((IDXMS.NE.1).AND.(IDXMS.NE.2)) THEN |
| 4444 | ILOOP = 0 |
| 4445 | 16 CONTINUE |
| 4446 | ILOOP = ILOOP+1 |
| 4447 | IDXMS = ABS(JMOHEP(1,IDXMS)) |
| 4448 | IF ((IDXMS.NE.1).AND.(IDXMS.NE.2).AND. |
| 4449 | & (ILOOP.LT.MAXLOP)) GOTO 16 |
| 4450 | IF (ILOOP.EQ.MAXLOP) |
| 4451 | & WRITE(LOUT,*) ' GETPJE: MAXLOP in 3 ! ' |
| 4452 | ENDIF |
| 4453 | IF (IDXMS.EQ.1) THEN |
| 4454 | ISPTN = ISTHKK(MO1) |
| 4455 | M1PTN = MO1 |
| 4456 | M2PTN = MO1+2 |
| 4457 | ELSE |
| 4458 | ISPTN = ISTHKK(MO2) |
| 4459 | M1PTN = MO2-2 |
| 4460 | M2PTN = MO2 |
| 4461 | ENDIF |
| 4462 | PX = PHEP(1,IDX) |
| 4463 | PY = PHEP(2,IDX) |
| 4464 | PZ = PHEP(3,IDX) |
| 4465 | PE = PHEP(4,IDX) |
| 4466 | IF ((ICOLOR(2,IDX).EQ.0).OR.(IDHEP(IDX).EQ.21)) THEN |
| 4467 | ISTX = ABS(ISPTN)/10 |
| 4468 | IMO = ABS(ISPTN)-10*ISTX |
| 4469 | IF ((IDHEP(IDX).EQ.21).OR. |
| 4470 | & (ABS(IPHIST(1,IDX)).GE.100)) THEN |
| 4471 | ISPTN = -(60+IMO) |
| 4472 | ELSE |
| 4473 | ISPTN = -(50+IMO) |
| 4474 | ENDIF |
| 4475 | ENDIF |
| 4476 | IF (ISPTN.EQ.-21) NPVAL = NPVAL+1 |
| 4477 | IF (ISPTN.EQ.-22) NTVAL = NTVAL+1 |
| 4478 | IF (MODE.LT.0) THEN |
| 4479 | CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN, |
| 4480 | & PX,PY,PZ,PE,0,0,0) |
| 4481 | ELSE |
| 4482 | CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP, |
| 4483 | & PPX,PPY,PPZ,PPE) |
| 4484 | CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN, |
| 4485 | & PPX,PPY,PPZ,PPE,0,0,0) |
| 4486 | ENDIF |
| 4487 | IHIST(1,NHKK) = IPHIST(1,IDX) |
| 4488 | IHIST(2,NHKK) = 0 |
| 4489 | DO 20 KK=1,4 |
| 4490 | VHKK(KK,NHKK) = VHKK(KK,M2PTN) |
| 4491 | WHKK(KK,NHKK) = WHKK(KK,M1PTN) |
| 4492 | 20 CONTINUE |
| 4493 | VHKK(4,NHKK)= VHKK(3,M2PTN)/BLAB-VHKK(3,M1PTN)/BGLAB |
| 4494 | WHKK(4,NHKK)= -WHKK(3,M1PTN)/BLAB+WHKK(3,M2PTN)/BGLAB |
| 4495 | 17 CONTINUE |
| 4496 | ENDIF |
| 4497 | * parton at chain end |
| 4498 | PX = PHEP(1,IDX2) |
| 4499 | PY = PHEP(2,IDX2) |
| 4500 | PZ = PHEP(3,IDX2) |
| 4501 | PE = PHEP(4,IDX2) |
| 4502 | * flag only partons coming from Pomeron with 41/42 |
| 4503 | C IF ((IPOM2.NE.0).OR.(NPOS(4,I).GE.4)) THEN |
| 4504 | IF (IPOM2.NE.0) THEN |
| 4505 | ISTX = ABS(ISPTN2)/10 |
| 4506 | IMO = ABS(ISPTN2)-10*ISTX |
| 4507 | ISPTN2 = -(40+IMO) |
| 4508 | ELSE |
| 4509 | IF ((ICOLOR(2,IDX2).EQ.0).OR.(IDHEP(IDX2).EQ.21)) THEN |
| 4510 | ISTX = ABS(ISPTN2)/10 |
| 4511 | IMO = ABS(ISPTN2)-10*ISTX |
| 4512 | IF ((IDHEP(IDX2).EQ.21).OR. |
| 4513 | & (ABS(IPHIST(1,IDX2)).GE.100)) THEN |
| 4514 | ISPTN2 = -(60+IMO) |
| 4515 | ELSE |
| 4516 | ISPTN2 = -(50+IMO) |
| 4517 | ENDIF |
| 4518 | ENDIF |
| 4519 | ENDIF |
| 4520 | IF (ISPTN2.EQ.-21) NPVAL = NPVAL+1 |
| 4521 | IF (ISPTN2.EQ.-22) NTVAL = NTVAL+1 |
| 4522 | IF (MODE.LT.0) THEN |
| 4523 | CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2, |
| 4524 | & PX,PY,PZ,PE,0,0,0) |
| 4525 | ELSE |
| 4526 | CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP, |
| 4527 | & PPX,PPY,PPZ,PPE) |
| 4528 | CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2, |
| 4529 | & PPX,PPY,PPZ,PPE,0,0,0) |
| 4530 | ENDIF |
| 4531 | IHIST(1,NHKK) = IPHIST(1,IDX2) |
| 4532 | IHIST(2,NHKK) = 0 |
| 4533 | DO 21 KK=1,4 |
| 4534 | VHKK(KK,NHKK) = VHKK(KK,M2PTN2) |
| 4535 | WHKK(KK,NHKK) = WHKK(KK,M1PTN2) |
| 4536 | 21 CONTINUE |
| 4537 | VHKK(4,NHKK) = VHKK(3,M2PTN2)/BLAB-VHKK(3,M1PTN2)/BGLAB |
| 4538 | WHKK(4,NHKK) = -WHKK(3,M1PTN2)/BLAB+WHKK(3,M2PTN2)/BGLAB |
| 4539 | M2STRG = NHKK |
| 4540 | * register string |
| 4541 | JSTRG = 100*IPROCE+NCODE(I) |
| 4542 | PX = PHEP(1,IDXSTG) |
| 4543 | PY = PHEP(2,IDXSTG) |
| 4544 | PZ = PHEP(3,IDXSTG) |
| 4545 | PE = PHEP(4,IDXSTG) |
| 4546 | IF (MODE.LT.0) THEN |
| 4547 | ISTAT = 70000+IPJE |
| 4548 | CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG, |
| 4549 | & PX,PY,PZ,PE,0,0,0) |
| 4550 | IF (LEMCCK) THEN |
| 4551 | PX = -PX |
| 4552 | PY = -PY |
| 4553 | PZ = -PZ |
| 4554 | PE = -PE |
| 4555 | CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2) |
| 4556 | ENDIF |
| 4557 | ELSE |
| 4558 | CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP, |
| 4559 | & PPX,PPY,PPZ,PPE) |
| 4560 | ISTAT = 70000+IPJE |
| 4561 | CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG, |
| 4562 | & PPX,PPY,PPZ,PPE,0,0,0) |
| 4563 | IF (LEMCCK) THEN |
| 4564 | PX = -PPX |
| 4565 | PY = -PPY |
| 4566 | PZ = -PPZ |
| 4567 | PE = -PPE |
| 4568 | CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2) |
| 4569 | ENDIF |
| 4570 | ENDIF |
| 4571 | NOBAM(NHKK) = 0 |
| 4572 | IHIST(1,NHKK) = 0 |
| 4573 | IHIST(2,NHKK) = 0 |
| 4574 | DO 18 KK=1,4 |
| 4575 | VHKK(KK,NHKK) = VHKK(KK,MO2) |
| 4576 | WHKK(KK,NHKK) = WHKK(KK,MO1) |
| 4577 | 18 CONTINUE |
| 4578 | VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB |
| 4579 | WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB |
| 4580 | ENDIF |
| 4581 | 11 CONTINUE |
| 4582 | |
| 4583 | IF ( ((NPVAL.GT.2).OR.(NTVAL.GT.2)).AND.(LFLIP) ) THEN |
| 4584 | NHKK = INHKK |
| 4585 | LFLIP = .FALSE. |
| 4586 | GOTO 1 |
| 4587 | ENDIF |
| 4588 | |
| 4589 | IF (LEMCCK) THEN |
| 4590 | IF (UMO.GT.1.0D5) THEN |
| 4591 | CHKLEV = 1.0D0 |
| 4592 | ELSE |
| 4593 | CHKLEV = TINY1 |
| 4594 | ENDIF |
| 4595 | CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,1000,IREJ2) |
| 4596 | IF (IREJ2.GT.ZERO) CALL PHO_PREVNT(0) |
| 4597 | ENDIF |
| 4598 | |
| 4599 | * internal statistics |
| 4600 | * dble-Po statistics. |
| 4601 | IF (IPROCE.NE.4) IPOPO = 0 |
| 4602 | |
| 4603 | INTFLG = IPROCE |
| 4604 | IDCHSY = IDCH(MO1) |
| 4605 | IF ((IPROCE.GE.1).AND.(IPROCE.LE.8)) THEN |
| 4606 | ICEVTG(IDCHSY,IPROCE+2) = ICEVTG(IDCHSY,IPROCE+2)+1 |
| 4607 | ELSE |
| 4608 | WRITE(LOUT,1000) IPROCE,NEVHKK,MO1 |
| 4609 | 1000 FORMAT(1X,'GETFSP: warning! incons. process id. (',I2, |
| 4610 | & ') at evt(chain) ',I6,'(',I2,')') |
| 4611 | ENDIF |
| 4612 | IF (IPROCE.EQ.5) THEN |
| 4613 | IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3)) THEN |
| 4614 | ICEVTG(IDCHSY,18+IDIFR1) = ICEVTG(IDCHSY,18+IDIFR1)+1 |
| 4615 | ELSE |
| 4616 | C WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2 |
| 4617 | 1001 FORMAT(1X,'GETFSP: warning! incons. diffrac. id. ', |
| 4618 | & '(IPROCE,IDIFR1,IDIFR2=',3I3,')') |
| 4619 | ENDIF |
| 4620 | ELSEIF (IPROCE.EQ.6) THEN |
| 4621 | IF ((IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN |
| 4622 | ICEVTG(IDCHSY,21+IDIFR2) = ICEVTG(IDCHSY,21+IDIFR2)+1 |
| 4623 | ELSE |
| 4624 | C WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2 |
| 4625 | ENDIF |
| 4626 | ELSEIF (IPROCE.EQ.7) THEN |
| 4627 | IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3).AND. |
| 4628 | & (IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN |
| 4629 | IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.1)) |
| 4630 | & ICEVTG(IDCHSY,25) = ICEVTG(IDCHSY,25)+1 |
| 4631 | IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.2)) |
| 4632 | & ICEVTG(IDCHSY,26) = ICEVTG(IDCHSY,26)+1 |
| 4633 | IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.2)) |
| 4634 | & ICEVTG(IDCHSY,27) = ICEVTG(IDCHSY,27)+1 |
| 4635 | IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.1)) |
| 4636 | & ICEVTG(IDCHSY,28) = ICEVTG(IDCHSY,28)+1 |
| 4637 | ELSE |
| 4638 | WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2 |
| 4639 | ENDIF |
| 4640 | ENDIF |
| 4641 | IF ((IDIFR1+IDIFR2.EQ.0).AND.(KHDIR.GE.1).AND.(KHDIR.LE.3)) |
| 4642 | & THEN |
| 4643 | ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1 |
| 4644 | ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1 |
| 4645 | ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1 |
| 4646 | ENDIF |
| 4647 | ICEVTG(IDCHSY,14) = ICEVTG(IDCHSY,14)+KSPOM |
| 4648 | ICEVTG(IDCHSY,15) = ICEVTG(IDCHSY,15)+KHPOM |
| 4649 | ICEVTG(IDCHSY,16) = ICEVTG(IDCHSY,16)+KSREG |
| 4650 | ICEVTG(IDCHSY,17) = ICEVTG(IDCHSY,17)+(KSTRG+KHTRG) |
| 4651 | ICEVTG(IDCHSY,18) = ICEVTG(IDCHSY,18)+(KSLOO+KHLOO) |
| 4652 | |
| 4653 | RETURN |
| 4654 | |
| 4655 | 9999 CONTINUE |
| 4656 | IREJ = 1 |
| 4657 | RETURN |
| 4658 | END |
| 4659 | |
| 4660 | *$ CREATE DT_PHOINI.FOR |
| 4661 | *COPY DT_PHOINI |
| 4662 | * |
| 4663 | *===phoini=============================================================* |
| 4664 | * |
| 4665 | SUBROUTINE DT_PHOINI |
| 4666 | |
| 4667 | ************************************************************************ |
| 4668 | * Initialization PHOJET-event generator for nucleon-nucleon interact. * |
| 4669 | * This version dated 16.11.95 is written by S. Roesler * |
| 4670 | * * |
| 4671 | * Last change 27.12.2006 by S. Roesler. * |
| 4672 | ************************************************************************ |
| 4673 | |
| 4674 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 4675 | SAVE |
| 4676 | PARAMETER ( LINP = 10 , |
| 4677 | & LOUT = 6 , |
| 4678 | & LDAT = 9 ) |
| 4679 | PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0) |
| 4680 | |
| 4681 | * nucleon-nucleon event-generator |
| 4682 | CHARACTER*8 CMODEL |
| 4683 | LOGICAL LPHOIN |
| 4684 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN |
| 4685 | * particle properties (BAMJET index convention) |
| 4686 | CHARACTER*8 ANAME |
| 4687 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 4688 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 4689 | * Lorentz-parameters of the current interaction |
| 4690 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, |
| 4691 | & UMO,PPCM,EPROJ,PPROJ |
| 4692 | * properties of interacting particles |
| 4693 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG |
| 4694 | * properties of photon/lepton projectiles |
| 4695 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC |
| 4696 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 4697 | * emulsion treatment |
| 4698 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), |
| 4699 | & NCOMPO,IEMUL |
| 4700 | * VDM parameter for photon-nucleus interactions |
| 4701 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) |
| 4702 | * nuclear potential |
| 4703 | LOGICAL LFERMI |
| 4704 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, |
| 4705 | & EBINDP(2),EBINDN(2),EPOT(2,210), |
| 4706 | & ETACOU(2),ICOUL,LFERMI |
| 4707 | * Glauber formalism: flags and parameters for statistics |
| 4708 | LOGICAL LPROD |
| 4709 | CHARACTER*8 CGLB |
| 4710 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD |
| 4711 | * |
| 4712 | * parameters for cascade calculations: |
| 4713 | * maximum mumber of PDF's which can be defined in phojet (limited |
| 4714 | * by the dimension of ipdfs in pho_setpdf) |
| 4715 | PARAMETER (MAXPDF = 20) |
| 4716 | * PDF parametrization and number of set for the first 30 hadrons in |
| 4717 | * the bamjet-code list |
| 4718 | * negative numbers mean that the PDF is set in phojet, |
| 4719 | * zero stands for "not a hadron" |
| 4720 | DIMENSION IPARPD(30),ISETPD(30) |
| 4721 | * PDF parametrization |
| 4722 | DATA IPARPD / |
| 4723 | & -5,-5, 0, 0, 0, 0,-5,-5,-5, 0, 0, 5,-5,-5, 5, 5, 5, 5, 5, 5, |
| 4724 | & 5, 5,-5, 5, 5, 0, 0, 0, 0, 0/ |
| 4725 | * number of set |
| 4726 | DATA ISETPD / |
| 4727 | & -6,-6, 0, 0, 0, 0,-3,-6,-6, 0, 0, 2,-2,-2, 2, 2, 6, 6, 2, 6, |
| 4728 | & 6, 6,-2, 2, 2, 0, 0, 0, 0, 0/ |
| 4729 | |
| 4730 | **PHOJET105a |
| 4731 | C COMMON /GLOCMS/ XECM,XPCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2) |
| 4732 | C PARAMETER ( MAXPRO = 16 ) |
| 4733 | C PARAMETER ( MAXTAB = 20 ) |
| 4734 | C COMMON /HAXSEC/ XSECTA(4,-1:MAXPRO,4,MAXTAB),XSECT(6,-1:MAXPRO), |
| 4735 | C & MXSECT(0:4,-1:MAXPRO,4),ECMSH(4,MAXTAB),ISTTAB |
| 4736 | C CHARACTER*8 MDLNA |
| 4737 | C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100) |
| 4738 | C COMMON /PROCES/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15) |
| 4739 | **PHOJET110 |
| 4740 | C global event kinematics and particle IDs |
| 4741 | INTEGER IFPAP,IFPAB |
| 4742 | DOUBLE PRECISION ECM,PCM,PMASS,PVIRT |
| 4743 | COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2) |
| 4744 | C hard cross sections and MC selection weights |
| 4745 | INTEGER Max_pro_2 |
| 4746 | PARAMETER ( Max_pro_2 = 16 ) |
| 4747 | INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried, |
| 4748 | & MH_acc_1,MH_acc_2 |
| 4749 | DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last |
| 4750 | COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2), |
| 4751 | & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2), |
| 4752 | & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last, |
| 4753 | & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4), |
| 4754 | & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4) |
| 4755 | C model switches and parameters |
| 4756 | CHARACTER*8 MDLNA |
| 4757 | INTEGER ISWMDL,IPAMDL |
| 4758 | DOUBLE PRECISION PARMDL |
| 4759 | COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400) |
| 4760 | C general process information |
| 4761 | INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON |
| 4762 | COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4) |
| 4763 | ** |
| 4764 | DIMENSION PP(4),PT(4) |
| 4765 | |
| 4766 | LOGICAL LSTART |
| 4767 | DATA LSTART /.TRUE./ |
| 4768 | |
| 4769 | IJP = IJPROJ |
| 4770 | IJT = IJTARG |
| 4771 | Q2 = VIRT |
| 4772 | * lepton-projectiles: initialize real photon instead |
| 4773 | IF ((IJP.EQ.3).OR.(IJP.EQ.4).OR.(IJP.EQ.10).OR.(IJP.EQ.11)) THEN |
| 4774 | IJP = 7 |
| 4775 | Q2 = ZERO |
| 4776 | ENDIF |
| 4777 | IF (LPHOIN) CALL PHO_INIT(-1,LOUT,IDUM) |
| 4778 | * switch Reggeon off |
| 4779 | C IPAMDL(3)= 0 |
| 4780 | IF (IP.EQ.1) THEN |
| 4781 | IFPAP(1) = IDT_IPDGHA(IJP) |
| 4782 | IFPAB(1) = IJP |
| 4783 | ELSE |
| 4784 | IFPAP(1) = 2212 |
| 4785 | IFPAB(1) = IDT_ICIHAD(IFPAP(1)) |
| 4786 | ENDIF |
| 4787 | PMASS(1) = AAM(IFPAB(1))-SQRT(Q2) |
| 4788 | PVIRT(1) = PMASS(1)**2 |
| 4789 | IF (IT.EQ.1) THEN |
| 4790 | IFPAP(2) = IDT_IPDGHA(IJT) |
| 4791 | IFPAB(2) = IJT |
| 4792 | ELSE |
| 4793 | IFPAP(2) = 2212 |
| 4794 | IFPAB(2) = IDT_ICIHAD(IFPAP(2)) |
| 4795 | ENDIF |
| 4796 | PMASS(2) = AAM(IFPAB(2)) |
| 4797 | PVIRT(2) = ZERO |
| 4798 | DO 1 K=1,4 |
| 4799 | PP(K) = ZERO |
| 4800 | PT(K) = ZERO |
| 4801 | 1 CONTINUE |
| 4802 | * get max. possible momenta of incoming particles to be used for PHOJET ini. |
| 4803 | PPF = ZERO |
| 4804 | PTF = ZERO |
| 4805 | SCPF= 1.5D0 |
| 4806 | IF (UMO.GE.1.E5) THEN |
| 4807 | SCPF= 5.0D0 |
| 4808 | ENDIF |
| 4809 | IF (NCOMPO.GT.0) THEN |
| 4810 | DO 2 I=1,NCOMPO |
| 4811 | IF (IT.GT.1) THEN |
| 4812 | CALL DT_NCLPOT(IEMUCH(I),IEMUMA(I),ITZ,IT,ZERO,ZERO,0) |
| 4813 | ELSE |
| 4814 | CALL DT_NCLPOT(IPZ,IP,IEMUCH(I),IEMUMA(I),ZERO,ZERO,0) |
| 4815 | ENDIF |
| 4816 | PPFTMP = MAX(PFERMP(1),PFERMN(1)) |
| 4817 | PTFTMP = MAX(PFERMP(2),PFERMN(2)) |
| 4818 | IF (PPFTMP.GT.PPF) PPF = PPFTMP |
| 4819 | IF (PTFTMP.GT.PTF) PTF = PTFTMP |
| 4820 | 2 CONTINUE |
| 4821 | ELSE |
| 4822 | CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0) |
| 4823 | PPF = MAX(PFERMP(1),PFERMN(1)) |
| 4824 | PTF = MAX(PFERMP(2),PFERMN(2)) |
| 4825 | ENDIF |
| 4826 | PTF = -PTF |
| 4827 | PPF = SCPF*PPF |
| 4828 | PTF = SCPF*PTF |
| 4829 | IF (IJP.EQ.7) THEN |
| 4830 | AMP2 = SIGN(PMASS(1)**2,PMASS(1)) |
| 4831 | PP(3) = PPCM |
| 4832 | PP(4) = SQRT(AMP2+PP(3)**2) |
| 4833 | ELSE |
| 4834 | EPF = SQRT(PPF**2+PMASS(1)**2) |
| 4835 | CALL DT_LTNUC(PPF,EPF,PP(3),PP(4),2) |
| 4836 | ENDIF |
| 4837 | ETF = SQRT(PTF**2+PMASS(2)**2) |
| 4838 | CALL DT_LTNUC(PTF,ETF,PT(3),PT(4),3) |
| 4839 | ECMINI = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2- |
| 4840 | & (PP(2)+PT(2))**2-(PP(3)+PT(3))**2) |
| 4841 | IF (LSTART) THEN |
| 4842 | WRITE(LOUT,1001) IP,IPZ,SCPF,PPF,PP |
| 4843 | 1001 FORMAT( |
| 4844 | & ' DT_PHOINI: PHOJET initialized for projectile A,Z = ', |
| 4845 | & I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3) |
| 4846 | IF (NCOMPO.GT.0) THEN |
| 4847 | WRITE(LOUT,1002) SCPF,PTF,PT |
| 4848 | ELSE |
| 4849 | WRITE(LOUT,1003) IT,ITZ,SCPF,PTF,PT |
| 4850 | ENDIF |
| 4851 | 1002 FORMAT( |
| 4852 | & ' DT_PHOINI: PHOJET initialized for target emulsion ', |
| 4853 | & /,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3) |
| 4854 | 1003 FORMAT( |
| 4855 | & ' DT_PHOINI: PHOJET initialized for target A,Z = ', |
| 4856 | & I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3) |
| 4857 | WRITE(LOUT,1004) ECMINI |
| 4858 | 1004 FORMAT(' E_cm = ',E10.3) |
| 4859 | IF (IJP.EQ.8) WRITE(LOUT,1005) |
| 4860 | 1005 FORMAT( |
| 4861 | & ' DT_PHOINI: warning! proton parameters used for neutron', |
| 4862 | & ' projectile') |
| 4863 | LSTART = .FALSE. |
| 4864 | ENDIF |
| 4865 | * switch off new diffractive cross sections at low energies for nuclei |
| 4866 | * (temporary solution) |
| 4867 | IF ((ISWMDL(30).NE.0).AND.((IP.GT.1).OR.(IT.GT.1))) THEN |
| 4868 | WRITE(LOUT,'(1X,A)') |
| 4869 | & ' DT_PHOINI: model-switch 30 for nuclei re-set !' |
| 4870 | CALL PHO_SETMDL(30,0,1) |
| 4871 | ENDIF |
| 4872 | * |
| 4873 | C IF (IJP.EQ.7) THEN |
| 4874 | C AMP2 = SIGN(PMASS(1)**2,PMASS(1)) |
| 4875 | C PP(3) = PPCM |
| 4876 | C PP(4) = SQRT(AMP2+PP(3)**2) |
| 4877 | C ELSE |
| 4878 | C PFERMX = ZERO |
| 4879 | C IF (IP.GT.1) PFERMX = 0.5D0 |
| 4880 | C EFERMX = SQRT(PFERMX**2+PMASS(1)**2) |
| 4881 | C CALL DT_LTNUC(PFERMX,EFERMX,PP(3),PP(4),2) |
| 4882 | C ENDIF |
| 4883 | C PFERMX = ZERO |
| 4884 | C IF ((IT.GT.1).OR.(NCOMPO.GT.0)) PFERMX = -0.5D0 |
| 4885 | C EFERMX = SQRT(PFERMX**2+PMASS(2)**2) |
| 4886 | C CALL DT_LTNUC(PFERMX,EFERMX,PT(3),PT(4),3) |
| 4887 | **sr 26.10.96 |
| 4888 | ISAV = IPAMDL(13) |
| 4889 | IF ((ISHAD(2).EQ.1).AND. |
| 4890 | & ((IJPROJ.EQ. 7).OR.(IJPROJ.EQ.3).OR.(IJPROJ.EQ.4).OR. |
| 4891 | & (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11))) IPAMDL(13) = 1 |
| 4892 | ** |
| 4893 | CALL PHO_EVENT(-1,PP,PT,SIGMAX,IREJ1) |
| 4894 | **sr 26.10.96 |
| 4895 | IPAMDL(13) = ISAV |
| 4896 | ** |
| 4897 | * |
| 4898 | * patch for cascade calculations: |
| 4899 | * define parton distribution functions for other hadrons, i.e. other |
| 4900 | * then defined already in phojet |
| 4901 | IF (IOGLB.EQ.100) THEN |
| 4902 | WRITE(LOUT,1006) |
| 4903 | 1006 FORMAT(/,1X,'PHOINI: additional parton distribution functions', |
| 4904 | & ' assiged (ID,IPAR,ISET)',/) |
| 4905 | NPDF = 0 |
| 4906 | DO 3 I=1,30 |
| 4907 | IF (IPARPD(I).NE.0) THEN |
| 4908 | NPDF = NPDF+1 |
| 4909 | IF (NPDF.GT.MAXPDF) STOP ' PHOINI: npdf > maxpdf !' |
| 4910 | IF ((IPARPD(I).GT.0).AND.(ISETPD(I).GT.0)) THEN |
| 4911 | IDPDG = IDT_IPDGHA(I) |
| 4912 | IPAR = IPARPD(I) |
| 4913 | ISET = ISETPD(I) |
| 4914 | WRITE(LOUT,'(13X,A8,3I6)') ANAME(I),IDPDG,IPAR,ISET |
| 4915 | CALL PHO_SETPDF(IDPDG,IDUM,IPAR,ISET,0,0,-1) |
| 4916 | ENDIF |
| 4917 | ENDIF |
| 4918 | 3 CONTINUE |
| 4919 | ENDIF |
| 4920 | |
| 4921 | C CALL PHO_PHIST(-1,SIGMAX) |
| 4922 | IF (IREJ1.NE.0) THEN |
| 4923 | WRITE(LOUT,1000) |
| 4924 | 1000 FORMAT(1X,'PHOINI: PHOJET event-initialization failed!') |
| 4925 | STOP |
| 4926 | ENDIF |
| 4927 | |
| 4928 | RETURN |
| 4929 | END |
| 4930 | |
| 4931 | *$ CREATE DT_EVENTD.FOR |
| 4932 | *COPY DT_EVENTD |
| 4933 | * |
| 4934 | *===eventd=============================================================* |
| 4935 | * |
| 4936 | SUBROUTINE DT_EVENTD(IREJ) |
| 4937 | |
| 4938 | ************************************************************************ |
| 4939 | * Quasi-elastic neutrino nucleus scattering. * |
| 4940 | * This version dated 29.04.00 is written by S. Roesler. * |
| 4941 | ************************************************************************ |
| 4942 | |
| 4943 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 4944 | SAVE |
| 4945 | PARAMETER ( LINP = 10 , |
| 4946 | & LOUT = 6 , |
| 4947 | & LDAT = 9 ) |
| 4948 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY5=1.0D-5) |
| 4949 | PARAMETER (SQTINF=1.0D+15) |
| 4950 | |
| 4951 | LOGICAL LFIRST |
| 4952 | |
| 4953 | * event history |
| 4954 | PARAMETER (NMXHKK=200000) |
| 4955 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 4956 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 4957 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 4958 | * extended event history |
| 4959 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 4960 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 4961 | & IHIST(2,NMXHKK) |
| 4962 | * flags for input different options |
| 4963 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 4964 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 4965 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 4966 | PARAMETER (MAXLND=4000) |
| 4967 | COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5) |
| 4968 | * properties of interacting particles |
| 4969 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG |
| 4970 | * Lorentz-parameters of the current interaction |
| 4971 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, |
| 4972 | & UMO,PPCM,EPROJ,PPROJ |
| 4973 | * nuclear potential |
| 4974 | LOGICAL LFERMI |
| 4975 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, |
| 4976 | & EBINDP(2),EBINDN(2),EPOT(2,210), |
| 4977 | & ETACOU(2),ICOUL,LFERMI |
| 4978 | * steering flags for qel neutrino scattering modules |
| 4979 | COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC |
| 4980 | COMMON /QNPOL/ POLARX(4),PMODUL |
| 4981 | INTEGER PYK |
| 4982 | |
| 4983 | DATA LFIRST /.TRUE./ |
| 4984 | |
| 4985 | IREJ = 0 |
| 4986 | |
| 4987 | IF (LFIRST) THEN |
| 4988 | LFIRST = .FALSE. |
| 4989 | CALL DT_MASS_INI |
| 4990 | ENDIF |
| 4991 | |
| 4992 | * JETSET parameter |
| 4993 | CALL DT_INITJS(0) |
| 4994 | |
| 4995 | * interacting target nucleon |
| 4996 | LTYP = NEUTYP |
| 4997 | IF (NEUDEC.LE.9) THEN |
| 4998 | IF ((LTYP.EQ.1).OR.(LTYP.EQ.3).OR.(LTYP.EQ.5)) THEN |
| 4999 | NUCTYP = 2112 |
| 5000 | NUCTOP = 2 |
| 5001 | ELSE |
| 5002 | NUCTYP = 2212 |
| 5003 | NUCTOP = 1 |
| 5004 | ENDIF |
| 5005 | ELSE |
| 5006 | RTYP = DT_RNDM(RTYP) |
| 5007 | ZFRAC = DBLE(ITZ)/DBLE(IT) |
| 5008 | IF (RTYP.LE.ZFRAC) THEN |
| 5009 | NUCTYP = 2212 |
| 5010 | NUCTOP = 1 |
| 5011 | ELSE |
| 5012 | NUCTYP = 2112 |
| 5013 | NUCTOP = 2 |
| 5014 | ENDIF |
| 5015 | ENDIF |
| 5016 | |
| 5017 | * select first nucleon in list with matching id and reset all other |
| 5018 | * nucleons which have been marked as "wounded" by ININUC |
| 5019 | IFOUND = 0 |
| 5020 | DO 1 I=1,NHKK |
| 5021 | IF ((IDHKK(I).EQ.NUCTYP).AND.(IFOUND.EQ.0)) THEN |
| 5022 | ISTHKK(I) = 12 |
| 5023 | IFOUND = 1 |
| 5024 | IDX = I |
| 5025 | ELSE |
| 5026 | IF (ISTHKK(I).EQ.12) ISTHKK(I) = 14 |
| 5027 | ENDIF |
| 5028 | 1 CONTINUE |
| 5029 | IF (IFOUND.EQ.0) |
| 5030 | & STOP ' EVENTD: interacting target nucleon not found! ' |
| 5031 | |
| 5032 | * correct position of proj. lepton: assume position of target nucleon |
| 5033 | DO 3 I=1,4 |
| 5034 | VHKK(I,1) = VHKK(I,IDX) |
| 5035 | WHKK(I,1) = WHKK(I,IDX) |
| 5036 | 3 CONTINUE |
| 5037 | |
| 5038 | * load initial momenta for conservation check |
| 5039 | IF (LEMCCK) THEN |
| 5040 | CALL DT_EVTEMC(ZERO,ZERO,PPROJ,EPROJ,1,IDUM,IDUM) |
| 5041 | CALL DT_EVTEMC(PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),PHKK(4,IDX), |
| 5042 | & 2,IDUM,IDUM) |
| 5043 | ENDIF |
| 5044 | |
| 5045 | * quasi-elastic scattering |
| 5046 | IF (NEUDEC.LT.9) THEN |
| 5047 | CALL DT_QEL_POL(EPROJ,LTYP,PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX), |
| 5048 | & PHKK(4,IDX),PHKK(5,IDX)) |
| 5049 | * CC event on p or n |
| 5050 | ELSEIF (NEUDEC.EQ.10) THEN |
| 5051 | CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,1,PHKK(1,IDX),PHKK(2,IDX), |
| 5052 | & PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX)) |
| 5053 | * NC event on p or n |
| 5054 | ELSEIF (NEUDEC.EQ.11) THEN |
| 5055 | CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,2,PHKK(1,IDX),PHKK(2,IDX), |
| 5056 | & PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX)) |
| 5057 | ENDIF |
| 5058 | |
| 5059 | * get final state particles from Lund-common and write them into HKKEVT |
| 5060 | NPOINT(1) = NHKK+1 |
| 5061 | NPOINT(4) = NHKK+1 |
| 5062 | NLINES = PYK(0,1) |
| 5063 | NHKK0 = NHKK+1 |
| 5064 | DO 4 I=4,NLINES |
| 5065 | IF (K(I,1).EQ.1) THEN |
| 5066 | ID = K(I,2) |
| 5067 | PX = P(I,1) |
| 5068 | PY = P(I,2) |
| 5069 | PZ = P(I,3) |
| 5070 | PE = P(I,4) |
| 5071 | CALL DT_EVTPUT(1,ID,1,IDX,PX,PY,PZ,PE,0,0,0) |
| 5072 | IDBJ = IDT_ICIHAD(ID) |
| 5073 | EKIN = PHKK(4,NHKK)-PHKK(5,NHKK) |
| 5074 | IF ((IDBJ.EQ.1).OR.(IDBJ.EQ.8)) THEN |
| 5075 | IF (EKIN.LE.EPOT(2,IDBJ)) ISTHKK(NHKK) = 16 |
| 5076 | ENDIF |
| 5077 | VHKK(1,NHKK) = VHKK(1,IDX) |
| 5078 | VHKK(2,NHKK) = VHKK(2,IDX) |
| 5079 | VHKK(3,NHKK) = VHKK(3,IDX) |
| 5080 | VHKK(4,NHKK) = VHKK(4,IDX) |
| 5081 | C IF (I.EQ.4) THEN |
| 5082 | C WHKK(1,NHKK) = POLARX(1) |
| 5083 | C WHKK(2,NHKK) = POLARX(2) |
| 5084 | C WHKK(3,NHKK) = POLARX(3) |
| 5085 | C WHKK(4,NHKK) = POLARX(4) |
| 5086 | C ELSE |
| 5087 | WHKK(1,NHKK) = WHKK(1,IDX) |
| 5088 | WHKK(2,NHKK) = WHKK(2,IDX) |
| 5089 | WHKK(3,NHKK) = WHKK(3,IDX) |
| 5090 | WHKK(4,NHKK) = WHKK(4,IDX) |
| 5091 | C ENDIF |
| 5092 | IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM) |
| 5093 | ENDIF |
| 5094 | 4 CONTINUE |
| 5095 | |
| 5096 | IF (LEMCCK) THEN |
| 5097 | CHKLEV = TINY5 |
| 5098 | CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,778,IREJ1) |
| 5099 | IF (IREJ1.NE.0) CALL DT_EVTOUT(4) |
| 5100 | ENDIF |
| 5101 | |
| 5102 | * transform momenta into cms (as required for inc etc.) |
| 5103 | DO 5 I=NHKK0,NHKK |
| 5104 | IF (ISTHKK(I).EQ.1) THEN |
| 5105 | CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,3) |
| 5106 | PHKK(3,I) = PZ |
| 5107 | PHKK(4,I) = PE |
| 5108 | ENDIF |
| 5109 | 5 CONTINUE |
| 5110 | |
| 5111 | RETURN |
| 5112 | END |
| 5113 | |
| 5114 | *$ CREATE DT_KKEVNT.FOR |
| 5115 | *COPY DT_KKEVNT |
| 5116 | * |
| 5117 | *===kkevnt=============================================================* |
| 5118 | * |
| 5119 | SUBROUTINE DT_KKEVNT(KKMAT,IREJ) |
| 5120 | |
| 5121 | ************************************************************************ |
| 5122 | * Treatment of complete nucleus-nucleus or hadron-nucleus scattering * |
| 5123 | * without nuclear effects (one event). * |
| 5124 | * This subroutine is an update of the previous version (KKEVT) written * |
| 5125 | * by J. Ranft/ H.-J. Moehring. * |
| 5126 | * This version dated 20.04.95 is written by S. Roesler * |
| 5127 | ************************************************************************ |
| 5128 | |
| 5129 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 5130 | SAVE |
| 5131 | PARAMETER ( LINP = 10 , |
| 5132 | & LOUT = 6 , |
| 5133 | & LDAT = 9 ) |
| 5134 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10) |
| 5135 | |
| 5136 | PARAMETER ( MAXNCL = 260, |
| 5137 | & MAXVQU = MAXNCL, |
| 5138 | & MAXSQU = 20*MAXVQU, |
| 5139 | & MAXINT = MAXVQU+MAXSQU) |
| 5140 | * event history |
| 5141 | PARAMETER (NMXHKK=200000) |
| 5142 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 5143 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 5144 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 5145 | * extended event history |
| 5146 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 5147 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 5148 | & IHIST(2,NMXHKK) |
| 5149 | * flags for input different options |
| 5150 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 5151 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 5152 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 5153 | * rejection counter |
| 5154 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, |
| 5155 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, |
| 5156 | & IREXCI(3),IRDIFF(2),IRINC |
| 5157 | * statistics |
| 5158 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, |
| 5159 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), |
| 5160 | & ICEVTG(8,0:30) |
| 5161 | * properties of interacting particles |
| 5162 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG |
| 5163 | * Lorentz-parameters of the current interaction |
| 5164 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, |
| 5165 | & UMO,PPCM,EPROJ,PPROJ |
| 5166 | * flags for diffractive interactions (DTUNUC 1.x) |
| 5167 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF |
| 5168 | * interface HADRIN-DPM |
| 5169 | COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA |
| 5170 | * nucleon-nucleon event-generator |
| 5171 | CHARACTER*8 CMODEL |
| 5172 | LOGICAL LPHOIN |
| 5173 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN |
| 5174 | * coordinates of nucleons |
| 5175 | COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL) |
| 5176 | * interface between Glauber formalism and DPM |
| 5177 | COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL), |
| 5178 | & INTER1(MAXINT),INTER2(MAXINT) |
| 5179 | * Glauber formalism: collision properties |
| 5180 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, |
| 7cbda79e |
5181 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC, |
| 5182 | & NCP,NCT |
| 9aaba0d6 |
5183 | * central particle production, impact parameter biasing |
| 5184 | COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR |
| 5185 | **temporary |
| 5186 | * statistics: Glauber-formalism |
| 5187 | COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB |
| 5188 | ** |
| 5189 | |
| 5190 | DATA NEVOLD,IPOLD,ITOLD,JJPOLD,EPROLD /4*0,0.0D0/ |
| 5191 | |
| 5192 | IREJ = 0 |
| 5193 | ICREQU = ICREQU+1 |
| 5194 | NC = 0 |
| 7cbda79e |
5195 | NCP = 0 |
| 5196 | NCT = 0 |
| 9aaba0d6 |
5197 | |
| 5198 | 1 CONTINUE |
| 5199 | ICSAMP = ICSAMP+1 |
| 5200 | NC = NC+1 |
| 5201 | IF (MOD(NC,10).EQ.0) THEN |
| 5202 | WRITE(LOUT,1000) NEVHKK |
| 5203 | 1000 FORMAT(1X,'KKEVNT: event ',I8,' rejected!') |
| 5204 | GOTO 9999 |
| 5205 | ENDIF |
| 5206 | |
| 5207 | * initialize DTEVT1/DTEVT2 |
| 5208 | CALL DT_EVTINI |
| 5209 | |
| 5210 | * We need the following only in order to sample nucleon coordinates. |
| 5211 | * However we don't have parameters (cross sections, slope etc.) |
| 5212 | * for neutrinos available. Therefore switch projectile to proton |
| 5213 | * in this case. |
| 5214 | IF (MCGENE.EQ.4) THEN |
| 5215 | JJPROJ = 1 |
| 5216 | ELSE |
| 5217 | JJPROJ = IJPROJ |
| 5218 | ENDIF |
| 5219 | |
| 5220 | 10 CONTINUE |
| 5221 | IF ( (NEVHKK.NE.NEVOLD).OR.(ICENTR.GT.0).OR. |
| 5222 | * make sure that Glauber-formalism is called each time the interaction |
| 5223 | * configuration changed |
| 5224 | & (IP.NE.IPOLD).OR.(IT.NE.ITOLD).OR.(JJPROJ.NE.JJPOLD).OR. |
| 5225 | & (ABS(EPROJ-EPROLD).GT.TINY10) ) THEN |
| 5226 | * sample number of nucleon-nucleon coll. according to Glauber-form. |
| 5227 | CALL DT_GLAUBE(IP,IT,JJPROJ,BIMPAC,NN,NP,NT,JSSH,JTSH,KKMAT) |
| 5228 | NWTSAM = NN |
| 5229 | NWASAM = NP |
| 5230 | NWBSAM = NT |
| 5231 | NEVOLD = NEVHKK |
| 5232 | IPOLD = IP |
| 5233 | ITOLD = IT |
| 5234 | JJPOLD = JJPROJ |
| 5235 | EPROLD = EPROJ |
| 7cbda79e |
5236 | DO 8 I=1, IP |
| 5237 | NCP = NCP+JSSH(I) |
| 5238 | * WRITE(6,*)' PROJ.NUCL. ',I,' NCOLL = ',NCP |
| 5239 | 8 CONTINUE |
| 5240 | DO 9 I=1, IT |
| 5241 | NCT = NCT+JTSH(I) |
| 5242 | * WRITE(6,*)' TAR.NUCL. ',I,' NCOLL = ',NCT |
| 5243 | 9 CONTINUE |
| 9aaba0d6 |
5244 | ENDIF |
| 5245 | |
| 5246 | * force diffractive particle production in h-K interactions |
| 5247 | IF (((ABS(ISINGD).GT.1).OR.(ABS(IDOUBD).GT.1)).AND. |
| 5248 | & (IP.EQ.1).AND.(NN.NE.1)) THEN |
| 5249 | NEVOLD = 0 |
| 5250 | GOTO 10 |
| 5251 | ENDIF |
| 5252 | |
| 5253 | * check number of involved proj. nucl. (NP) if central prod.is requested |
| 5254 | IF (ICENTR.GT.0) THEN |
| 5255 | CALL DT_CHKCEN(IP,IT,NP,NT,IBACK) |
| 5256 | IF (IBACK.GT.0) GOTO 10 |
| 5257 | ENDIF |
| 5258 | |
| 5259 | * get initial nucleon-configuration in projectile and target |
| 5260 | * rest-system (including Fermi-momenta if requested) |
| 5261 | CALL DT_ININUC(IJPROJ,IP,IPZ,PKOO,JSSH,1) |
| 5262 | MODE = 2 |
| 5263 | IF (EPROJ.LE.EHADTH) MODE = 3 |
| 5264 | CALL DT_ININUC(IJTARG,IT,ITZ,TKOO,JTSH,MODE) |
| 5265 | |
| 5266 | IF ((MCGENE.NE.3).AND.(MCGENE.NE.4)) THEN |
| 5267 | |
| 5268 | * activate HADRIN at low energies (implemented for h-N scattering only) |
| 5269 | IF (EPROJ.LE.EHADHI) THEN |
| 5270 | IF (EHADTH.LT.ZERO) THEN |
| 5271 | * smooth transition btwn. DPM and HADRIN |
| 5272 | FRAC = (EPROJ-EHADLO)/(EHADHI-EHADLO) |
| 5273 | RR = DT_RNDM(FRAC) |
| 5274 | IF (RR.GT.FRAC) THEN |
| 5275 | IF (IP.EQ.1) THEN |
| 5276 | CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1) |
| 5277 | IF (IREJ1.GT.0) GOTO 1 |
| 5278 | RETURN |
| 5279 | ELSE |
| 5280 | WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH |
| 5281 | ENDIF |
| 5282 | ENDIF |
| 5283 | ELSE |
| 5284 | * fixed threshold for onset of production via HADRIN |
| 5285 | IF (EPROJ.LE.EHADTH) THEN |
| 5286 | IF (IP.EQ.1) THEN |
| 5287 | CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1) |
| 5288 | IF (IREJ1.GT.0) GOTO 1 |
| 5289 | RETURN |
| 5290 | ELSE |
| 5291 | WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH |
| 5292 | ENDIF |
| 5293 | ENDIF |
| 5294 | ENDIF |
| 5295 | ENDIF |
| 5296 | 1001 FORMAT(1X,'KKEVNT: warning! interaction of proj. (m=', |
| 5297 | & I3,') with target (m=',I3,')',/,11X, |
| 5298 | & 'at E_lab=',F5.1,'GeV (threshold-energy: ',F3.1, |
| 5299 | & 'GeV) cannot be handled') |
| 5300 | |
| 5301 | * sampling of momentum-x fractions & flavors of chain ends |
| 5302 | CALL DT_SPLPTN(NN) |
| 5303 | |
| 5304 | * Lorentz-transformation of wounded nucleons into nucl.-nucl. cms |
| 5305 | CALL DT_NUC2CM |
| 5306 | |
| 5307 | * collect momenta of chain ends and put them into DTEVT1 |
| 5308 | CALL DT_GETPTN(IP,NN,NCSY,IREJ1) |
| 5309 | IF (IREJ1.NE.0) GOTO 1 |
| 5310 | |
| 5311 | ENDIF |
| 5312 | |
| 5313 | * handle chains including fragmentation (two-chain approximation) |
| 5314 | IF (MCGENE.EQ.1) THEN |
| 5315 | * two-chain approximation |
| 5316 | CALL DT_EVENTA(IJPROJ,IP,IT,NCSY,IREJ1) |
| 5317 | IF (IREJ1.NE.0) THEN |
| 5318 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKEVNT' |
| 5319 | GOTO 1 |
| 5320 | ENDIF |
| 5321 | ELSEIF (MCGENE.EQ.2) THEN |
| 5322 | * multiple-Po exchange including minijets |
| 5323 | CALL DT_EVENTB(NCSY,IREJ1) |
| 5324 | IF (IREJ1.NE.0) THEN |
| 5325 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKEVNT' |
| 5326 | GOTO 1 |
| 5327 | ENDIF |
| 5328 | ELSEIF (MCGENE.EQ.3) THEN |
| 5329 | STOP ' This version does not contain LEPTO !' |
| 5330 | ELSEIF (MCGENE.EQ.4) THEN |
| 5331 | * quasi-elastic neutrino scattering |
| 5332 | CALL DT_EVENTD(IREJ1) |
| 5333 | IF (IREJ1.NE.0) THEN |
| 5334 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 4 in KKEVNT' |
| 5335 | GOTO 1 |
| 5336 | ENDIF |
| 5337 | ELSE |
| 5338 | WRITE(LOUT,1002) MCGENE |
| 5339 | 1002 FORMAT(1X,'KKEVNT: warning! event-generator',I4, |
| 5340 | & ' not available - program stopped') |
| 5341 | STOP |
| 5342 | ENDIF |
| 5343 | |
| 5344 | RETURN |
| 5345 | |
| 5346 | 9999 CONTINUE |
| 5347 | IREJ = 1 |
| 5348 | RETURN |
| 5349 | END |
| 5350 | |
| 5351 | *$ CREATE DT_CHKCEN.FOR |
| 5352 | *COPY DT_CHKCEN |
| 5353 | * |
| 5354 | *===chkcen=============================================================* |
| 5355 | * |
| 5356 | SUBROUTINE DT_CHKCEN(IP,IT,NP,NT,IBACK) |
| 5357 | |
| 5358 | ************************************************************************ |
| 5359 | * Check of number of involved projectile nucleons if central production* |
| 5360 | * is requested. * |
| 5361 | * Adopted from a part of the old KKEVT routine which was written by * |
| 5362 | * J. Ranft/H.-J.Moehring. * |
| 5363 | * This version dated 13.01.95 is written by S. Roesler * |
| 5364 | ************************************************************************ |
| 5365 | |
| 5366 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 5367 | SAVE |
| 5368 | PARAMETER ( LINP = 10 , |
| 5369 | & LOUT = 6 , |
| 5370 | & LDAT = 9 ) |
| 5371 | |
| 5372 | * statistics |
| 5373 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, |
| 5374 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), |
| 5375 | & ICEVTG(8,0:30) |
| 5376 | * central particle production, impact parameter biasing |
| 5377 | COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR |
| 5378 | |
| 5379 | IBACK = 0 |
| 5380 | |
| 5381 | * old version |
| 5382 | IF (ICENTR.EQ.2) THEN |
| 5383 | IF (IP.LT.IT) THEN |
| 5384 | IF (IP.LE.8) THEN |
| 5385 | IF (NP.LT.IP-1) IBACK = 1 |
| 5386 | ELSEIF (IP.LE.16) THEN |
| 5387 | IF (NP.LT.IP-2) IBACK = 1 |
| 5388 | ELSEIF (IP.LE.32) THEN |
| 5389 | IF (NP.LT.IP-3) IBACK = 1 |
| 5390 | ELSEIF (IP.GE.33) THEN |
| 5391 | IF (NP.LT.IP-5) IBACK = 1 |
| 5392 | ENDIF |
| 5393 | ELSEIF (IP.EQ.IT) THEN |
| 5394 | IF (IP.EQ.32) THEN |
| 5395 | IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1 |
| 5396 | ELSE |
| 5397 | IF (NP.LT.IP-IP/8) IBACK = 1 |
| 5398 | ENDIF |
| 5399 | ELSEIF (ABS(IP-IT).LT.3) THEN |
| 5400 | IF (NP.LT.IP-IP/8) IBACK = 1 |
| 5401 | ENDIF |
| 5402 | ELSE |
| 5403 | * new version (DPMJET, 5.6.99) |
| 5404 | IF (IP.LT.IT) THEN |
| 5405 | IF (IP.LE.8) THEN |
| 5406 | IF (NP.LT.IP-1) IBACK = 1 |
| 5407 | ELSEIF (IP.LE.16) THEN |
| 5408 | IF (NP.LT.IP-2) IBACK = 1 |
| 5409 | ELSEIF (IP.LT.32) THEN |
| 5410 | IF (NP.LT.IP-3) IBACK = 1 |
| 5411 | ELSEIF (IP.GE.32) THEN |
| 5412 | IF (IT.LE.150) THEN |
| 5413 | * Example: S-Ag |
| 5414 | IF (NP.LT.IP-1) IBACK = 1 |
| 5415 | ELSE |
| 5416 | * Example: S-Au |
| 5417 | IF (NP.LT.IP) IBACK = 1 |
| 5418 | ENDIF |
| 5419 | ENDIF |
| 5420 | ELSEIF (IP.EQ.IT) THEN |
| 5421 | * Example: S-S |
| 5422 | IF (IP.EQ.32) THEN |
| 5423 | IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1 |
| 5424 | * Example: Pb-Pb |
| 5425 | ELSE |
| 5426 | IF (NP.LT.IP-IP/4) IBACK = 1 |
| 5427 | ENDIF |
| 5428 | ELSEIF (ABS(IP-IT).LT.3) THEN |
| 5429 | IF (NP.LT.IP-IP/8) IBACK = 1 |
| 5430 | ENDIF |
| 5431 | ENDIF |
| 5432 | |
| 5433 | ICCPRO = ICCPRO+1 |
| 5434 | |
| 5435 | RETURN |
| 5436 | END |
| 5437 | |
| 5438 | *$ CREATE DT_ININUC.FOR |
| 5439 | *COPY DT_ININUC |
| 5440 | * |
| 5441 | *===ininuc=============================================================* |
| 5442 | * |
| 5443 | SUBROUTINE DT_ININUC(ID,NMASS,NCH,COORD,JS,IMODE) |
| 5444 | |
| 5445 | ************************************************************************ |
| 5446 | * Samples initial configuration of nucleons in nucleus with mass NMASS * |
| 5447 | * including Fermi-momenta (if reqested). * |
| 5448 | * ID BAMJET-code for hadrons (instead of nuclei) * |
| 5449 | * NMASS mass number of nucleus (number of nucleons) * |
| 5450 | * NCH charge of nucleus * |
| 5451 | * COORD(3,NMASS) coordinates of nucleons inside nucleus in fm * |
| 5452 | * JS(NMASS) > 0 nucleon undergoes nucleon-nucleon interact. * |
| 5453 | * IMODE = 1 projectile nucleus * |
| 5454 | * = 2 target nucleus * |
| 5455 | * = 3 target nucleus (E_lab<E_thr for HADRIN) * |
| 5456 | * Adopted from a part of the old KKEVT routine which was written by * |
| 5457 | * J. Ranft/H.-J.Moehring. * |
| 5458 | * This version dated 13.01.95 is written by S. Roesler * |
| 5459 | ************************************************************************ |
| 5460 | |
| 5461 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 5462 | SAVE |
| 5463 | PARAMETER ( LINP = 10 , |
| 5464 | & LOUT = 6 , |
| 5465 | & LDAT = 9 ) |
| 5466 | PARAMETER (FM2MM=1.0D-12) |
| 5467 | |
| 5468 | PARAMETER ( MAXNCL = 260, |
| 5469 | & MAXVQU = MAXNCL, |
| 5470 | & MAXSQU = 20*MAXVQU, |
| 5471 | & MAXINT = MAXVQU+MAXSQU) |
| 5472 | * event history |
| 5473 | PARAMETER (NMXHKK=200000) |
| 5474 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 5475 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 5476 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 5477 | * extended event history |
| 5478 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 5479 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 5480 | & IHIST(2,NMXHKK) |
| 5481 | * flags for input different options |
| 5482 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 5483 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 5484 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 5485 | * auxiliary common for chain system storage (DTUNUC 1.x) |
| 5486 | COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL) |
| 5487 | * nuclear potential |
| 5488 | LOGICAL LFERMI |
| 5489 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, |
| 5490 | & EBINDP(2),EBINDN(2),EPOT(2,210), |
| 5491 | & ETACOU(2),ICOUL,LFERMI |
| 5492 | * properties of photon/lepton projectiles |
| 5493 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC |
| 5494 | * particle properties (BAMJET index convention) |
| 5495 | CHARACTER*8 ANAME |
| 5496 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 5497 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 5498 | * Glauber formalism: collision properties |
| 5499 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, |
| 5500 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC |
| 5501 | * flavors of partons (DTUNUC 1.x) |
| 5502 | COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU), |
| 5503 | & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU), |
| 5504 | & IPSQ(MAXSQU),IPSQ2(MAXSQU), |
| 5505 | & IPSAQ(MAXSQU),IPSAQ2(MAXSQU), |
| 5506 | & ITSQ(MAXSQU),ITSQ2(MAXSQU), |
| 5507 | & ITSAQ(MAXSQU),ITSAQ2(MAXSQU), |
| 5508 | & KKPROJ(MAXVQU),KKTARG(MAXVQU) |
| 5509 | * interface HADRIN-DPM |
| 5510 | COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA |
| 5511 | |
| 5512 | DIMENSION PF(4),PFTOT(4),COORD(3,MAXNCL),JS(MAXNCL) |
| 5513 | |
| 5514 | * number of neutrons |
| 5515 | NNEU = NMASS-NCH |
| 5516 | * initializations |
| 5517 | NP = 0 |
| 5518 | NN = 0 |
| 5519 | DO 1 K=1,4 |
| 5520 | PFTOT(K) = 0.0D0 |
| 5521 | 1 CONTINUE |
| 5522 | MODE = IMODE |
| 5523 | IF (IMODE.GT.2) MODE = 2 |
| 5524 | **sr 29.5. new NPOINT(1)-definition |
| 5525 | C IF (IMODE.GE.2) NPOINT(1) = NHKK+1 |
| 5526 | ** |
| 5527 | NHADRI = 0 |
| 5528 | NC = NHKK |
| 5529 | |
| 5530 | * get initial configuration |
| 5531 | DO 2 I=1,NMASS |
| 5532 | NHKK = NHKK+1 |
| 5533 | IF (JS(I).GT.0) THEN |
| 5534 | ISTHKK(NHKK) = 10+MODE |
| 5535 | IF (IMODE.EQ.3) THEN |
| 5536 | * additional treatment if HADRIN-generator is requested |
| 5537 | NHADRI = NHADRI+1 |
| 5538 | IF (NHADRI.EQ.1) IDXTA = NHKK |
| 5539 | IF (NHADRI.GT.1) ISTHKK(NHKK) = 14 |
| 5540 | ENDIF |
| 5541 | ELSE |
| 5542 | ISTHKK(NHKK) = 12+MODE |
| 5543 | ENDIF |
| 5544 | IF (NMASS.GE.2) THEN |
| 5545 | * treatment for nuclei |
| 5546 | FRAC = 1.0D0-DBLE(NCH)/DBLE(NMASS) |
| 5547 | RR = DT_RNDM(FRAC) |
| 5548 | IF ((RR.LT.FRAC).AND.(NN.LT.NNEU)) THEN |
| 5549 | IDX = 8 |
| 5550 | NN = NN+1 |
| 5551 | ELSEIF ((RR.GE.FRAC).AND.(NP.LT.NCH)) THEN |
| 5552 | IDX = 1 |
| 5553 | NP = NP+1 |
| 5554 | ELSEIF (NN.LT.NNEU) THEN |
| 5555 | IDX = 8 |
| 5556 | NN = NN+1 |
| 5557 | ELSEIF (NP.LT.NCH) THEN |
| 5558 | IDX = 1 |
| 5559 | NP = NP+1 |
| 5560 | ENDIF |
| 5561 | IDHKK(NHKK) = IDT_IPDGHA(IDX) |
| 5562 | IDBAM(NHKK) = IDX |
| 5563 | IF (MODE.EQ.1) THEN |
| 5564 | IPOSP(I) = NHKK |
| 5565 | KKPROJ(I) = IDX |
| 5566 | ELSE |
| 5567 | IPOST(I) = NHKK |
| 5568 | KKTARG(I) = IDX |
| 5569 | ENDIF |
| 5570 | IF (IDX.EQ.1) THEN |
| 5571 | PFER = PFERMP(MODE) |
| 5572 | PBIN = SQRT(2.0D0*EBINDP(MODE)*AAM(1)) |
| 5573 | ELSE |
| 5574 | PFER = PFERMN(MODE) |
| 5575 | PBIN = SQRT(2.0D0*EBINDN(MODE)*AAM(8)) |
| 5576 | ENDIF |
| 5577 | CALL DT_FER4M(PFER,PBIN,PF(1),PF(2),PF(3),PF(4),IDX) |
| 5578 | DO 3 K=1,4 |
| 5579 | PFTOT(K) = PFTOT(K)+PF(K) |
| 5580 | PHKK(K,NHKK) = PF(K) |
| 5581 | 3 CONTINUE |
| 5582 | PHKK(5,NHKK) = AAM(IDX) |
| 5583 | ELSE |
| 5584 | * treatment for hadrons |
| 5585 | IDHKK(NHKK) = IDT_IPDGHA(ID) |
| 5586 | IDBAM(NHKK) = ID |
| 5587 | PHKK(4,NHKK) = AAM(ID) |
| 5588 | PHKK(5,NHKK) = AAM(ID) |
| 5589 | C* VDM assumption |
| 5590 | C IF (IDHKK(NHKK).EQ.22) THEN |
| 5591 | C PHKK(4,NHKK) = AAM(33) |
| 5592 | C PHKK(5,NHKK) = AAM(33) |
| 5593 | C ENDIF |
| 5594 | IF (MODE.EQ.1) THEN |
| 5595 | IPOSP(I) = NHKK |
| 5596 | KKPROJ(I) = ID |
| 5597 | PHKK(5,NHKK) = PHKK(5,NHKK)-SQRT(VIRT) |
| 5598 | ELSE |
| 5599 | IPOST(I) = NHKK |
| 5600 | KKTARG(I) = ID |
| 5601 | ENDIF |
| 5602 | ENDIF |
| 5603 | DO 4 K=1,3 |
| 5604 | VHKK(K,NHKK) = COORD(K,I)*FM2MM |
| 5605 | WHKK(K,NHKK) = COORD(K,I)*FM2MM |
| 5606 | 4 CONTINUE |
| 5607 | IF (MODE.EQ.2) VHKK(1,NHKK) = VHKK(1,NHKK)+BIMPAC*FM2MM |
| 5608 | IF (MODE.EQ.2) WHKK(1,NHKK) = WHKK(1,NHKK)+BIMPAC*FM2MM |
| 5609 | VHKK(4,NHKK) = 0.0D0 |
| 5610 | WHKK(4,NHKK) = 0.0D0 |
| 5611 | 2 CONTINUE |
| 5612 | |
| 5613 | * balance Fermi-momenta |
| 5614 | IF (NMASS.GE.2) THEN |
| 5615 | DO 5 I=1,NMASS |
| 5616 | NC = NC+1 |
| 5617 | DO 6 K=1,3 |
| 5618 | PHKK(K,NC) = PHKK(K,NC)-PFTOT(K)/DBLE(NMASS) |
| 5619 | 6 CONTINUE |
| 5620 | PHKK(4,NC) = SQRT(PHKK(5,NC)**2+PHKK(1,NC)**2+ |
| 5621 | & PHKK(2,NC)**2+PHKK(3,NC)**2) |
| 5622 | 5 CONTINUE |
| 5623 | ENDIF |
| 5624 | |
| 5625 | RETURN |
| 5626 | END |
| 5627 | |
| 5628 | *$ CREATE DT_FER4M.FOR |
| 5629 | *COPY DT_FER4M |
| 5630 | * |
| 5631 | *===fer4m==============================================================* |
| 5632 | * |
| 5633 | SUBROUTINE DT_FER4M(PFERM,PBIND,PXT,PYT,PZT,ET,KT) |
| 5634 | |
| 5635 | ************************************************************************ |
| 5636 | * Sampling of nucleon Fermi-momenta from distributions at T=0. * |
| 5637 | * processed by S. Roesler, 17.10.95 * |
| 5638 | ************************************************************************ |
| 5639 | |
| 5640 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 5641 | SAVE |
| 5642 | PARAMETER ( LINP = 10 , |
| 5643 | & LOUT = 6 , |
| 5644 | & LDAT = 9 ) |
| 5645 | |
| 5646 | LOGICAL LSTART |
| 5647 | |
| 5648 | * particle properties (BAMJET index convention) |
| 5649 | CHARACTER*8 ANAME |
| 5650 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 5651 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 5652 | * nuclear potential |
| 5653 | LOGICAL LFERMI |
| 5654 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, |
| 5655 | & EBINDP(2),EBINDN(2),EPOT(2,210), |
| 5656 | & ETACOU(2),ICOUL,LFERMI |
| 5657 | |
| 5658 | DATA LSTART /.TRUE./ |
| 5659 | |
| 5660 | ILOOP = 0 |
| 5661 | IF (LFERMI) THEN |
| 5662 | IF (LSTART) THEN |
| 5663 | WRITE(LOUT,1000) |
| 5664 | 1000 FORMAT(/,1X,'FER4M: sampling of Fermi-momenta activated') |
| 5665 | LSTART = .FALSE. |
| 5666 | ENDIF |
| 5667 | 1 CONTINUE |
| 5668 | CALL DT_DFERMI(PABS) |
| 5669 | PABS = PFERM*PABS |
| 5670 | C IF (PABS.GE.PBIND) THEN |
| 5671 | C ILOOP = ILOOP+1 |
| 5672 | C IF (MOD(ILOOP,500).EQ.0) THEN |
| 5673 | C WRITE(LOUT,1001) PABS,PBIND,ILOOP |
| 5674 | C1001 FORMAT(1X,'FER4M: Fermi-mom. corr. for binding', |
| 5675 | C & ' energy ',2E12.3,I6) |
| 5676 | C ENDIF |
| 5677 | C GOTO 1 |
| 5678 | C ENDIF |
| 5679 | CALL DT_DPOLI(POLC,POLS) |
| 5680 | CALL DT_DSFECF(SFE,CFE) |
| 5681 | CXTA = POLS*CFE |
| 5682 | CYTA = POLS*SFE |
| 5683 | CZTA = POLC |
| 5684 | ET = SQRT(PABS*PABS+AAM(KT)**2) |
| 5685 | PXT = CXTA*PABS |
| 5686 | PYT = CYTA*PABS |
| 5687 | PZT = CZTA*PABS |
| 5688 | ELSE |
| 5689 | ET = AAM(KT) |
| 5690 | PXT = 0.0D0 |
| 5691 | PYT = 0.0D0 |
| 5692 | PZT = 0.0D0 |
| 5693 | ENDIF |
| 5694 | |
| 5695 | RETURN |
| 5696 | END |
| 5697 | |
| 5698 | *$ CREATE DT_NUC2CM.FOR |
| 5699 | *COPY DT_NUC2CM |
| 5700 | * |
| 5701 | *===nuc2cm=============================================================* |
| 5702 | * |
| 5703 | SUBROUTINE DT_NUC2CM |
| 5704 | |
| 5705 | ************************************************************************ |
| 5706 | * Lorentz-transformation of all wounded nucleons from Lab. to nucl.- * |
| 5707 | * nucl. cms. (This subroutine replaces NUCMOM.) * |
| 5708 | * This version dated 15.01.95 is written by S. Roesler * |
| 5709 | ************************************************************************ |
| 5710 | |
| 5711 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 5712 | SAVE |
| 5713 | PARAMETER ( LINP = 10 , |
| 5714 | & LOUT = 6 , |
| 5715 | & LDAT = 9 ) |
| 5716 | PARAMETER (ZERO=0.0D0,TINY3=1.0D-3) |
| 5717 | |
| 5718 | * event history |
| 5719 | PARAMETER (NMXHKK=200000) |
| 5720 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 5721 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 5722 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 5723 | * extended event history |
| 5724 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 5725 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 5726 | & IHIST(2,NMXHKK) |
| 5727 | * statistics |
| 5728 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, |
| 5729 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), |
| 5730 | & ICEVTG(8,0:30) |
| 5731 | * properties of photon/lepton projectiles |
| 5732 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC |
| 5733 | * particle properties (BAMJET index convention) |
| 5734 | CHARACTER*8 ANAME |
| 5735 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 5736 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 5737 | * Glauber formalism: collision properties |
| 5738 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, |
| 5739 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC |
| 5740 | **temporary |
| 5741 | * statistics: Glauber-formalism |
| 5742 | COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB |
| 5743 | ** |
| 5744 | |
| 5745 | ICWP = 0 |
| 5746 | ICWT = 0 |
| 5747 | NWTACC = 0 |
| 5748 | NWAACC = 0 |
| 5749 | NWBACC = 0 |
| 5750 | |
| 5751 | NPOINT(1) = NHKK+1 |
| 5752 | NEND = NHKK |
| 5753 | DO 1 I=1,NEND |
| 5754 | IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.12)) THEN |
| 5755 | IF (ISTHKK(I).EQ.11) NWAACC = NWAACC+1 |
| 5756 | IF (ISTHKK(I).EQ.12) NWBACC = NWBACC+1 |
| 5757 | MODE = ISTHKK(I)-9 |
| 5758 | C IF (IDHKK(I).EQ.22) THEN |
| 5759 | C* VDM assumption |
| 5760 | C PEIN = AAM(33) |
| 5761 | C IDB = 33 |
| 5762 | C ELSE |
| 5763 | C PEIN = PHKK(4,I) |
| 5764 | C IDB = IDBAM(I) |
| 5765 | C ENDIF |
| 5766 | C CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PEIN, |
| 5767 | C & PX,PY,PZ,PE,IDB,MODE) |
| 5768 | IF (PHKK(5,I).GT.ZERO) THEN |
| 5769 | CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I), |
| 5770 | & PX,PY,PZ,PE,IDBAM(I),MODE) |
| 5771 | ELSE |
| 5772 | PX = PGAMM(1) |
| 5773 | PY = PGAMM(2) |
| 5774 | PZ = PGAMM(3) |
| 5775 | PE = PGAMM(4) |
| 5776 | ENDIF |
| 5777 | IST = ISTHKK(I)-2 |
| 5778 | ID = IDHKK(I) |
| 5779 | C* VDM assumption |
| 5780 | C IF (ID.EQ.22) ID = 113 |
| 5781 | CALL DT_EVTPUT(IST,ID,I,0,PX,PY,PZ,PE,0,0,0) |
| 5782 | IF (ISTHKK(I).EQ.11) ICWP = ICWP+1 |
| 5783 | IF (ISTHKK(I).EQ.12) ICWT = ICWT+1 |
| 5784 | ENDIF |
| 5785 | 1 CONTINUE |
| 5786 | |
| 5787 | NWTACC = MAX(NWAACC,NWBACC) |
| 5788 | ICDPR = ICDPR+ICWP |
| 5789 | ICDTA = ICDTA+ICWT |
| 5790 | **temporary |
| 5791 | IF ((ICWP.EQ.0).OR.(ICWT.EQ.0)) THEN |
| 5792 | CALL DT_EVTOUT(4) |
| 5793 | STOP |
| 5794 | ENDIF |
| 5795 | |
| 5796 | RETURN |
| 5797 | END |
| 5798 | |
| 5799 | *$ CREATE DT_SPLPTN.FOR |
| 5800 | *COPY DT_SPLPTN |
| 5801 | * |
| 5802 | *===splptn=============================================================* |
| 5803 | * |
| 5804 | SUBROUTINE DT_SPLPTN(NN) |
| 5805 | |
| 5806 | ************************************************************************ |
| 5807 | * SamPLing of ParToN momenta and flavors. * |
| 5808 | * This version dated 15.01.95 is written by S. Roesler * |
| 5809 | ************************************************************************ |
| 5810 | |
| 5811 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 5812 | SAVE |
| 5813 | PARAMETER ( LINP = 10 , |
| 5814 | & LOUT = 6 , |
| 5815 | & LDAT = 9 ) |
| 5816 | |
| 5817 | * Lorentz-parameters of the current interaction |
| 5818 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, |
| 5819 | & UMO,PPCM,EPROJ,PPROJ |
| 5820 | |
| 5821 | * sample flavors of sea-quarks |
| 5822 | CALL DT_SPLFLA(NN,1) |
| 5823 | |
| 5824 | * sample x-values of partons at chain ends |
| 5825 | ECM = UMO |
| 5826 | CALL DT_XKSAMP(NN,ECM) |
| 5827 | |
| 5828 | * samle flavors |
| 5829 | CALL DT_SPLFLA(NN,2) |
| 5830 | |
| 5831 | RETURN |
| 5832 | END |
| 5833 | |
| 5834 | *$ CREATE DT_SPLFLA.FOR |
| 5835 | *COPY DT_SPLFLA |
| 5836 | * |
| 5837 | *===splfla=============================================================* |
| 5838 | * |
| 5839 | SUBROUTINE DT_SPLFLA(NN,MODE) |
| 5840 | |
| 5841 | ************************************************************************ |
| 5842 | * SamPLing of FLAvors of partons at chain ends. * |
| 5843 | * This subroutine replaces FLKSAA/FLKSAM. * |
| 5844 | * NN number of nucleon-nucleon interactions * |
| 5845 | * MODE = 1 sea-flavors * |
| 5846 | * = 2 valence-flavors * |
| 5847 | * Based on the original version written by J. Ranft/H.-J. Moehring. * |
| 5848 | * This version dated 16.01.95 is written by S. Roesler * |
| 5849 | ************************************************************************ |
| 5850 | |
| 5851 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 5852 | SAVE |
| 5853 | PARAMETER ( LINP = 10 , |
| 5854 | & LOUT = 6 , |
| 5855 | & LDAT = 9 ) |
| 5856 | |
| 5857 | PARAMETER ( MAXNCL = 260, |
| 5858 | & MAXVQU = MAXNCL, |
| 5859 | & MAXSQU = 20*MAXVQU, |
| 5860 | & MAXINT = MAXVQU+MAXSQU) |
| 5861 | * flavors of partons (DTUNUC 1.x) |
| 5862 | COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU), |
| 5863 | & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU), |
| 5864 | & IPSQ(MAXSQU),IPSQ2(MAXSQU), |
| 5865 | & IPSAQ(MAXSQU),IPSAQ2(MAXSQU), |
| 5866 | & ITSQ(MAXSQU),ITSQ2(MAXSQU), |
| 5867 | & ITSAQ(MAXSQU),ITSAQ2(MAXSQU), |
| 5868 | & KKPROJ(MAXVQU),KKTARG(MAXVQU) |
| 5869 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) |
| 5870 | COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD, |
| 5871 | & IXPV,IXPS,IXTV,IXTS, |
| 5872 | & INTVV1(MAXVQU),INTVV2(MAXVQU), |
| 5873 | & INTSV1(MAXVQU),INTSV2(MAXVQU), |
| 5874 | & INTVS1(MAXVQU),INTVS2(MAXVQU), |
| 5875 | & INTSS1(MAXSQU),INTSS2(MAXSQU), |
| 5876 | & INTDV1(MAXVQU),INTDV2(MAXVQU), |
| 5877 | & INTVD1(MAXVQU),INTVD2(MAXVQU), |
| 5878 | & INTDS1(MAXSQU),INTDS2(MAXSQU), |
| 5879 | & INTSD1(MAXSQU),INTSD2(MAXSQU) |
| 5880 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) |
| 5881 | COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU), |
| 5882 | & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU) |
| 5883 | * particle properties (BAMJET index convention) |
| 5884 | CHARACTER*8 ANAME |
| 5885 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 5886 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 5887 | * various options for treatment of partons (DTUNUC 1.x) |
| 5888 | * (chain recombination, Cronin,..) |
| 5889 | LOGICAL LCO2CR,LINTPT |
| 5890 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, |
| 5891 | & LCO2CR,LINTPT |
| 5892 | |
| 5893 | IF (MODE.EQ.1) THEN |
| 5894 | * sea-flavors |
| 5895 | DO 1 I=1,NN |
| 5896 | IPSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ)) |
| 5897 | IPSAQ(I) = -IPSQ(I) |
| 5898 | 1 CONTINUE |
| 5899 | DO 2 I=1,NN |
| 5900 | ITSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ)) |
| 5901 | ITSAQ(I)= -ITSQ(I) |
| 5902 | 2 CONTINUE |
| 5903 | ELSEIF (MODE.EQ.2) THEN |
| 5904 | * valence flavors |
| 5905 | DO 3 I=1,IXPV |
| 5906 | CALL DT_FLAHAD(KKPROJ(IFROVP(I)),IPVQ(I),IPPV1(I),IPPV2(I)) |
| 5907 | 3 CONTINUE |
| 5908 | DO 4 I=1,IXTV |
| 5909 | CALL DT_FLAHAD(KKTARG(IFROVT(I)),ITVQ(I),ITTV1(I),ITTV2(I)) |
| 5910 | 4 CONTINUE |
| 5911 | ENDIF |
| 5912 | |
| 5913 | RETURN |
| 5914 | END |
| 5915 | |
| 5916 | *$ CREATE DT_GETPTN.FOR |
| 5917 | *COPY DT_GETPTN |
| 5918 | * |
| 5919 | *===getptn=============================================================* |
| 5920 | * |
| 5921 | SUBROUTINE DT_GETPTN(IP,NN,NCSY,IREJ) |
| 5922 | |
| 5923 | ************************************************************************ |
| 5924 | * This subroutine collects partons at chain ends from temporary * |
| 5925 | * commons and puts them into DTEVT1. * |
| 5926 | * This version dated 15.01.95 is written by S. Roesler * |
| 5927 | ************************************************************************ |
| 5928 | |
| 5929 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 5930 | SAVE |
| 5931 | PARAMETER ( LINP = 10 , |
| 5932 | & LOUT = 6 , |
| 5933 | & LDAT = 9 ) |
| 5934 | PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0) |
| 5935 | |
| 5936 | LOGICAL LCHK |
| 5937 | |
| 5938 | PARAMETER ( MAXNCL = 260, |
| 5939 | & MAXVQU = MAXNCL, |
| 5940 | & MAXSQU = 20*MAXVQU, |
| 5941 | & MAXINT = MAXVQU+MAXSQU) |
| 5942 | * event history |
| 5943 | PARAMETER (NMXHKK=200000) |
| 5944 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 5945 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 5946 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 5947 | * extended event history |
| 5948 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 5949 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 5950 | & IHIST(2,NMXHKK) |
| 5951 | * flags for input different options |
| 5952 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 5953 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 5954 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 5955 | * auxiliary common for chain system storage (DTUNUC 1.x) |
| 5956 | COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL) |
| 5957 | * statistics |
| 5958 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, |
| 5959 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), |
| 5960 | & ICEVTG(8,0:30) |
| 5961 | * flags for diffractive interactions (DTUNUC 1.x) |
| 5962 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF |
| 5963 | * x-values of partons (DTUNUC 1.x) |
| 5964 | COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU), |
| 5965 | & XTVQ(MAXVQU),XTVD(MAXVQU), |
| 5966 | & XPSQ(MAXSQU),XPSAQ(MAXSQU), |
| 5967 | & XTSQ(MAXSQU),XTSAQ(MAXSQU) |
| 5968 | * flavors of partons (DTUNUC 1.x) |
| 5969 | COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU), |
| 5970 | & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU), |
| 5971 | & IPSQ(MAXSQU),IPSQ2(MAXSQU), |
| 5972 | & IPSAQ(MAXSQU),IPSAQ2(MAXSQU), |
| 5973 | & ITSQ(MAXSQU),ITSQ2(MAXSQU), |
| 5974 | & ITSAQ(MAXSQU),ITSAQ2(MAXSQU), |
| 5975 | & KKPROJ(MAXVQU),KKTARG(MAXVQU) |
| 5976 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) |
| 5977 | COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD, |
| 5978 | & IXPV,IXPS,IXTV,IXTS, |
| 5979 | & INTVV1(MAXVQU),INTVV2(MAXVQU), |
| 5980 | & INTSV1(MAXVQU),INTSV2(MAXVQU), |
| 5981 | & INTVS1(MAXVQU),INTVS2(MAXVQU), |
| 5982 | & INTSS1(MAXSQU),INTSS2(MAXSQU), |
| 5983 | & INTDV1(MAXVQU),INTDV2(MAXVQU), |
| 5984 | & INTVD1(MAXVQU),INTVD2(MAXVQU), |
| 5985 | & INTDS1(MAXSQU),INTDS2(MAXSQU), |
| 5986 | & INTSD1(MAXSQU),INTSD2(MAXSQU) |
| 5987 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) |
| 5988 | COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU), |
| 5989 | & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU) |
| 5990 | |
| 5991 | DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PP(4),PT(4) |
| 5992 | |
| 5993 | DATA AMSS,AMVS,AMDS,AMVD,AMVV/0.4D0,2.0D0,2.0D0,2.5D0,2.0D0/ |
| 5994 | |
| 5995 | IREJ = 0 |
| 5996 | NCSY = 0 |
| 5997 | NPOINT(2) = NHKK+1 |
| 5998 | |
| 5999 | * sea-sea chains |
| 6000 | DO 10 I=1,NSS |
| 6001 | IF (ISKPCH(1,I).EQ.99) GOTO 10 |
| 6002 | ICCHAI(1,1) = ICCHAI(1,1)+2 |
| 6003 | IDXP = INTSS1(I) |
| 6004 | IDXT = INTSS2(I) |
| 6005 | MOP = JDAHKK(1,IPOSP(IFROSP(IDXP))) |
| 6006 | MOT = JDAHKK(1,IPOST(IFROST(IDXT))) |
| 6007 | DO 11 K=1,4 |
| 6008 | PP1(K) = XPSQ(IDXP) *PHKK(K,MOP) |
| 6009 | PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP) |
| 6010 | PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT) |
| 6011 | PT2(K) = XTSQ(IDXT) *PHKK(K,MOT) |
| 6012 | 11 CONTINUE |
| 6013 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 |
| 6014 | & +(PP1(3)+PT1(3))**2) |
| 6015 | ECH = PP1(4)+PT1(4) |
| 6016 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) |
| 6017 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 |
| 6018 | & +(PP2(3)+PT2(3))**2) |
| 6019 | ECH = PP2(4)+PT2(4) |
| 6020 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) |
| 6021 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN |
| 6022 | AM1 = SQRT(AM1) |
| 6023 | AM2 = SQRT(AM2) |
| 6024 | IF ((AM1.LT.AMSS).OR.(AM2.LT.AMSS)) THEN |
| 6025 | C WRITE(LOUT,5000) NEVHKK,I,AM1,AM2 |
| 6026 | 5000 FORMAT(1X,'incon. chain mass SS: ',2I5,2E10.3) |
| 6027 | ENDIF |
| 6028 | ELSE |
| 6029 | WRITE(LOUT,5000) NEVHKK,I,AM1,AM2 |
| 6030 | ENDIF |
| 6031 | IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2) |
| 6032 | IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2) |
| 6033 | IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2) |
| 6034 | IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2) |
| 6035 | CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), |
| 6036 | & 0,0,1) |
| 6037 | CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), |
| 6038 | & 0,0,1) |
| 6039 | CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), |
| 6040 | & 0,0,1) |
| 6041 | CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), |
| 6042 | & 0,0,1) |
| 6043 | NCSY = NCSY+1 |
| 6044 | 10 CONTINUE |
| 6045 | |
| 6046 | * disea-sea chains |
| 6047 | DO 20 I=1,NDS |
| 6048 | IF (ISKPCH(2,I).EQ.99) GOTO 20 |
| 6049 | ICCHAI(1,2) = ICCHAI(1,2)+2 |
| 6050 | IDXP = INTDS1(I) |
| 6051 | IDXT = INTDS2(I) |
| 6052 | MOP = JDAHKK(1,IPOSP(IFROSP(IDXP))) |
| 6053 | MOT = JDAHKK(1,IPOST(IFROST(IDXT))) |
| 6054 | DO 21 K=1,4 |
| 6055 | PP1(K) = XPSQ(IDXP) *PHKK(K,MOP) |
| 6056 | PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP) |
| 6057 | PT1(K) = XTSQ(IDXT) *PHKK(K,MOT) |
| 6058 | PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT) |
| 6059 | 21 CONTINUE |
| 6060 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 |
| 6061 | & +(PP1(3)+PT1(3))**2) |
| 6062 | ECH = PP1(4)+PT1(4) |
| 6063 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) |
| 6064 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 |
| 6065 | & +(PP2(3)+PT2(3))**2) |
| 6066 | ECH = PP2(4)+PT2(4) |
| 6067 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) |
| 6068 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN |
| 6069 | AM1 = SQRT(AM1) |
| 6070 | AM2 = SQRT(AM2) |
| 6071 | IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN |
| 6072 | C WRITE(LOUT,5001) NEVHKK,I,AM1,AM2 |
| 6073 | 5001 FORMAT(1X,'incon. chain mass DS: ',2I5,2E10.3) |
| 6074 | ENDIF |
| 6075 | ELSE |
| 6076 | WRITE(LOUT,5001) NEVHKK,I,AM1,AM2 |
| 6077 | ENDIF |
| 6078 | IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2) |
| 6079 | IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2) |
| 6080 | IFT1 = IDT_IB2PDG(ITSQ(IDXT),0,2) |
| 6081 | IFT2 = IDT_IB2PDG(ITSAQ(IDXT),0,2) |
| 6082 | CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), |
| 6083 | & 0,0,2) |
| 6084 | CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), |
| 6085 | & 0,0,2) |
| 6086 | CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), |
| 6087 | & 0,0,2) |
| 6088 | CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), |
| 6089 | & 0,0,2) |
| 6090 | NCSY = NCSY+1 |
| 6091 | 20 CONTINUE |
| 6092 | |
| 6093 | * sea-disea chains |
| 6094 | DO 30 I=1,NSD |
| 6095 | IF (ISKPCH(3,I).EQ.99) GOTO 30 |
| 6096 | ICCHAI(1,3) = ICCHAI(1,3)+2 |
| 6097 | IDXP = INTSD1(I) |
| 6098 | IDXT = INTSD2(I) |
| 6099 | MOP = JDAHKK(1,IPOSP(IFROSP(IDXP))) |
| 6100 | MOT = JDAHKK(1,IPOST(IFROST(IDXT))) |
| 6101 | DO 31 K=1,4 |
| 6102 | PP1(K) = XPSQ(IDXP) *PHKK(K,MOP) |
| 6103 | PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP) |
| 6104 | PT1(K) = XTSQ(IDXT) *PHKK(K,MOT) |
| 6105 | PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT) |
| 6106 | 31 CONTINUE |
| 6107 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 |
| 6108 | & +(PP1(3)+PT1(3))**2) |
| 6109 | ECH = PP1(4)+PT1(4) |
| 6110 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) |
| 6111 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 |
| 6112 | & +(PP2(3)+PT2(3))**2) |
| 6113 | ECH = PP2(4)+PT2(4) |
| 6114 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) |
| 6115 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN |
| 6116 | AM1 = SQRT(AM1) |
| 6117 | AM2 = SQRT(AM2) |
| 6118 | IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN |
| 6119 | C WRITE(LOUT,5002) NEVHKK,I,AM1,AM2 |
| 6120 | 5002 FORMAT(1X,'incon. chain mass SD: ',2I5,2E10.3) |
| 6121 | ENDIF |
| 6122 | ELSE |
| 6123 | WRITE(LOUT,5002) NEVHKK,I,AM1,AM2 |
| 6124 | ENDIF |
| 6125 | IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2) |
| 6126 | IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2) |
| 6127 | IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2) |
| 6128 | IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2) |
| 6129 | CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), |
| 6130 | & 0,0,3) |
| 6131 | CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), |
| 6132 | & 0,0,3) |
| 6133 | CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), |
| 6134 | & 0,0,3) |
| 6135 | CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), |
| 6136 | & 0,0,3) |
| 6137 | NCSY = NCSY+1 |
| 6138 | 30 CONTINUE |
| 6139 | |
| 6140 | * disea-valence chains |
| 6141 | DO 50 I=1,NDV |
| 6142 | IF (ISKPCH(5,I).EQ.99) GOTO 50 |
| 6143 | ICCHAI(1,5) = ICCHAI(1,5)+2 |
| 6144 | IDXP = INTDV1(I) |
| 6145 | IDXT = INTDV2(I) |
| 6146 | MOP = JDAHKK(1,IPOSP(IFROSP(IDXP))) |
| 6147 | MOT = JDAHKK(1,IPOST(IFROVT(IDXT))) |
| 6148 | DO 51 K=1,4 |
| 6149 | PP1(K) = XPSQ(IDXP) *PHKK(K,MOP) |
| 6150 | PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP) |
| 6151 | PT1(K) = XTVQ(IDXT) *PHKK(K,MOT) |
| 6152 | PT2(K) = XTVD(IDXT) *PHKK(K,MOT) |
| 6153 | 51 CONTINUE |
| 6154 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 |
| 6155 | & +(PP1(3)+PT1(3))**2) |
| 6156 | ECH = PP1(4)+PT1(4) |
| 6157 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) |
| 6158 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 |
| 6159 | & +(PP2(3)+PT2(3))**2) |
| 6160 | ECH = PP2(4)+PT2(4) |
| 6161 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) |
| 6162 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN |
| 6163 | AM1 = SQRT(AM1) |
| 6164 | AM2 = SQRT(AM2) |
| 6165 | IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN |
| 6166 | C WRITE(LOUT,5003) NEVHKK,I,AM1,AM2 |
| 6167 | 5003 FORMAT(1X,'incon. chain mass DV: ',2I5,2E10.3) |
| 6168 | ENDIF |
| 6169 | ELSE |
| 6170 | WRITE(LOUT,5003) NEVHKK,I,AM1,AM2 |
| 6171 | ENDIF |
| 6172 | IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2) |
| 6173 | IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2) |
| 6174 | IFT1 = IDT_IB2PDG(ITVQ(IDXT),0,2) |
| 6175 | IFT2 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2) |
| 6176 | CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), |
| 6177 | & 0,0,5) |
| 6178 | CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), |
| 6179 | & 0,0,5) |
| 6180 | CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), |
| 6181 | & 0,0,5) |
| 6182 | CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), |
| 6183 | & 0,0,5) |
| 6184 | NCSY = NCSY+1 |
| 6185 | 50 CONTINUE |
| 6186 | |
| 6187 | * valence-sea chains |
| 6188 | DO 60 I=1,NVS |
| 6189 | IF (ISKPCH(6,I).EQ.99) GOTO 60 |
| 6190 | ICCHAI(1,6) = ICCHAI(1,6)+2 |
| 6191 | IDXP = INTVS1(I) |
| 6192 | IDXT = INTVS2(I) |
| 6193 | MOP = JDAHKK(1,IPOSP(IFROVP(IDXP))) |
| 6194 | MOT = JDAHKK(1,IPOST(IFROST(IDXT))) |
| 6195 | DO 61 K=1,4 |
| 6196 | PP1(K) = XPVQ(IDXP) *PHKK(K,MOP) |
| 6197 | PP2(K) = XPVD(IDXP) *PHKK(K,MOP) |
| 6198 | PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT) |
| 6199 | PT2(K) = XTSQ(IDXT) *PHKK(K,MOT) |
| 6200 | 61 CONTINUE |
| 6201 | IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2) |
| 6202 | IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2) |
| 6203 | IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2) |
| 6204 | IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2) |
| 6205 | CALL DT_CHKCSY(IFP1,IFT1,LCHK) |
| 6206 | IF (LCHK) THEN |
| 6207 | CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), |
| 6208 | & 0,0,6) |
| 6209 | CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), |
| 6210 | & 0,0,6) |
| 6211 | CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), |
| 6212 | & 0,0,6) |
| 6213 | CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), |
| 6214 | & 0,0,6) |
| 6215 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 |
| 6216 | & +(PP1(3)+PT1(3))**2) |
| 6217 | ECH = PP1(4)+PT1(4) |
| 6218 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) |
| 6219 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 |
| 6220 | & +(PP2(3)+PT2(3))**2) |
| 6221 | ECH = PP2(4)+PT2(4) |
| 6222 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) |
| 6223 | ELSE |
| 6224 | CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), |
| 6225 | & 0,0,6) |
| 6226 | CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), |
| 6227 | & 0,0,6) |
| 6228 | CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), |
| 6229 | & 0,0,6) |
| 6230 | CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), |
| 6231 | & 0,0,6) |
| 6232 | PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2 |
| 6233 | & +(PP1(3)+PT2(3))**2) |
| 6234 | ECH = PP1(4)+PT2(4) |
| 6235 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) |
| 6236 | PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2 |
| 6237 | & +(PP2(3)+PT1(3))**2) |
| 6238 | ECH = PP2(4)+PT1(4) |
| 6239 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) |
| 6240 | ENDIF |
| 6241 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN |
| 6242 | AM1 = SQRT(AM1) |
| 6243 | AM2 = SQRT(AM2) |
| 6244 | IF ((AM1.LT.AMSS).OR.(AM2.LT.AMVS)) THEN |
| 6245 | C WRITE(LOUT,5004) NEVHKK,I,AM1,AM2 |
| 6246 | 5004 FORMAT(1X,'incon. chain mass VS: ',2I5,2E10.3) |
| 6247 | ENDIF |
| 6248 | ELSE |
| 6249 | WRITE(LOUT,5004) NEVHKK,I,AM1,AM2 |
| 6250 | ENDIF |
| 6251 | NCSY = NCSY+1 |
| 6252 | 60 CONTINUE |
| 6253 | |
| 6254 | * sea-valence chains |
| 6255 | DO 40 I=1,NSV |
| 6256 | IF (ISKPCH(4,I).EQ.99) GOTO 40 |
| 6257 | ICCHAI(1,4) = ICCHAI(1,4)+2 |
| 6258 | IDXP = INTSV1(I) |
| 6259 | IDXT = INTSV2(I) |
| 6260 | MOP = JDAHKK(1,IPOSP(IFROSP(IDXP))) |
| 6261 | MOT = JDAHKK(1,IPOST(IFROVT(IDXT))) |
| 6262 | DO 41 K=1,4 |
| 6263 | PP1(K) = XPSQ(IDXP) *PHKK(K,MOP) |
| 6264 | PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP) |
| 6265 | PT1(K) = XTVD(IDXT) *PHKK(K,MOT) |
| 6266 | PT2(K) = XTVQ(IDXT) *PHKK(K,MOT) |
| 6267 | 41 CONTINUE |
| 6268 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 |
| 6269 | & +(PP1(3)+PT1(3))**2) |
| 6270 | ECH = PP1(4)+PT1(4) |
| 6271 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) |
| 6272 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 |
| 6273 | & +(PP2(3)+PT2(3))**2) |
| 6274 | ECH = PP2(4)+PT2(4) |
| 6275 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) |
| 6276 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN |
| 6277 | AM1 = SQRT(AM1) |
| 6278 | AM2 = SQRT(AM2) |
| 6279 | IF ((AM1.LT.AMVS).OR.(AM2.LT.AMSS)) THEN |
| 6280 | C WRITE(LOUT,5005) NEVHKK,I,AM1,AM2 |
| 6281 | 5005 FORMAT(1X,'incon. chain mass SV: ',2I5,2E10.3) |
| 6282 | ENDIF |
| 6283 | ELSE |
| 6284 | WRITE(LOUT,5005) NEVHKK,I,AM1,AM2 |
| 6285 | ENDIF |
| 6286 | IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2) |
| 6287 | IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2) |
| 6288 | IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2) |
| 6289 | IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2) |
| 6290 | CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), |
| 6291 | & 0,0,4) |
| 6292 | CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), |
| 6293 | & 0,0,4) |
| 6294 | CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), |
| 6295 | & 0,0,4) |
| 6296 | CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), |
| 6297 | & 0,0,4) |
| 6298 | NCSY = NCSY+1 |
| 6299 | 40 CONTINUE |
| 6300 | |
| 6301 | * valence-disea chains |
| 6302 | DO 70 I=1,NVD |
| 6303 | IF (ISKPCH(7,I).EQ.99) GOTO 70 |
| 6304 | ICCHAI(1,7) = ICCHAI(1,7)+2 |
| 6305 | IDXP = INTVD1(I) |
| 6306 | IDXT = INTVD2(I) |
| 6307 | MOP = JDAHKK(1,IPOSP(IFROVP(IDXP))) |
| 6308 | MOT = JDAHKK(1,IPOST(IFROST(IDXT))) |
| 6309 | DO 71 K=1,4 |
| 6310 | PP1(K) = XPVQ(IDXP) *PHKK(K,MOP) |
| 6311 | PP2(K) = XPVD(IDXP) *PHKK(K,MOP) |
| 6312 | PT1(K) = XTSQ(IDXT) *PHKK(K,MOT) |
| 6313 | PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT) |
| 6314 | 71 CONTINUE |
| 6315 | IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2) |
| 6316 | IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2) |
| 6317 | IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2) |
| 6318 | IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2) |
| 6319 | CALL DT_CHKCSY(IFP1,IFT1,LCHK) |
| 6320 | IF (LCHK) THEN |
| 6321 | CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), |
| 6322 | & 0,0,7) |
| 6323 | CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), |
| 6324 | & 0,0,7) |
| 6325 | CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), |
| 6326 | & 0,0,7) |
| 6327 | CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), |
| 6328 | & 0,0,7) |
| 6329 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 |
| 6330 | & +(PP1(3)+PT1(3))**2) |
| 6331 | ECH = PP1(4)+PT1(4) |
| 6332 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) |
| 6333 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 |
| 6334 | & +(PP2(3)+PT2(3))**2) |
| 6335 | ECH = PP2(4)+PT2(4) |
| 6336 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) |
| 6337 | ELSE |
| 6338 | CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), |
| 6339 | & 0,0,7) |
| 6340 | CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), |
| 6341 | & 0,0,7) |
| 6342 | CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), |
| 6343 | & 0,0,7) |
| 6344 | CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), |
| 6345 | & 0,0,7) |
| 6346 | PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2 |
| 6347 | & +(PP1(3)+PT2(3))**2) |
| 6348 | ECH = PP1(4)+PT2(4) |
| 6349 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) |
| 6350 | PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2 |
| 6351 | & +(PP2(3)+PT1(3))**2) |
| 6352 | ECH = PP2(4)+PT1(4) |
| 6353 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) |
| 6354 | ENDIF |
| 6355 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN |
| 6356 | AM1 = SQRT(AM1) |
| 6357 | AM2 = SQRT(AM2) |
| 6358 | IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN |
| 6359 | C WRITE(LOUT,5006) NEVHKK,I,AM1,AM2 |
| 6360 | 5006 FORMAT(1X,'incon. chain mass VD: ',2I5,2E10.3) |
| 6361 | ENDIF |
| 6362 | ELSE |
| 6363 | WRITE(LOUT,5006) NEVHKK,I,AM1,AM2 |
| 6364 | ENDIF |
| 6365 | NCSY = NCSY+1 |
| 6366 | 70 CONTINUE |
| 6367 | |
| 6368 | * valence-valence chains |
| 6369 | DO 80 I=1,NVV |
| 6370 | IF (ISKPCH(8,I).EQ.99) GOTO 80 |
| 6371 | ICCHAI(1,8) = ICCHAI(1,8)+2 |
| 6372 | IDXP = INTVV1(I) |
| 6373 | IDXT = INTVV2(I) |
| 6374 | MOP = JDAHKK(1,IPOSP(IFROVP(IDXP))) |
| 6375 | MOT = JDAHKK(1,IPOST(IFROVT(IDXT))) |
| 6376 | DO 81 K=1,4 |
| 6377 | PP1(K) = XPVQ(IDXP)*PHKK(K,MOP) |
| 6378 | PP2(K) = XPVD(IDXP)*PHKK(K,MOP) |
| 6379 | PT1(K) = XTVD(IDXT)*PHKK(K,MOT) |
| 6380 | PT2(K) = XTVQ(IDXT)*PHKK(K,MOT) |
| 6381 | 81 CONTINUE |
| 6382 | IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2) |
| 6383 | IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2) |
| 6384 | IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2) |
| 6385 | IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2) |
| 6386 | |
| 6387 | * check for diffractive event |
| 6388 | IDIFF = 0 |
| 6389 | IF (((ISINGD.GT.0).OR.(IDOUBD.GT.0)).AND. |
| 6390 | & (IP.EQ.1).AND.(NN.EQ.1)) THEN |
| 6391 | DO 800 K=1,4 |
| 6392 | PP(K) = PP1(K)+PP2(K) |
| 6393 | PT(K) = PT1(K)+PT2(K) |
| 6394 | 800 CONTINUE |
| 6395 | ISTCK = NHKK |
| 6396 | CALL DT_DIFEVT(IFP1,IFP2,PP,MOP, |
| 6397 | & IFT1,IFT2,PT,MOT,IDIFF,NCSY,IREJ1) |
| 6398 | C IF (IREJ1.NE.0) GOTO 9999 |
| 6399 | IF (IREJ1.NE.0) THEN |
| 6400 | IDIFF = 0 |
| 6401 | NHKK = ISTCK |
| 6402 | ENDIF |
| 6403 | ELSE |
| 6404 | IDIFF = 0 |
| 6405 | ENDIF |
| 6406 | |
| 6407 | IF (IDIFF.EQ.0) THEN |
| 6408 | * valence-valence chain system |
| 6409 | CALL DT_CHKCSY(IFP1,IFT1,LCHK) |
| 6410 | IF (LCHK) THEN |
| 6411 | * baryon-baryon |
| 6412 | CALL DT_EVTPUT(-21,IFP1,MOP,0, |
| 6413 | & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8) |
| 6414 | CALL DT_EVTPUT(-22,IFT1,MOT,0, |
| 6415 | & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8) |
| 6416 | CALL DT_EVTPUT(-21,IFP2,MOP,0, |
| 6417 | & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8) |
| 6418 | CALL DT_EVTPUT(-22,IFT2,MOT,0, |
| 6419 | & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8) |
| 6420 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 |
| 6421 | & +(PP1(3)+PT1(3))**2) |
| 6422 | ECH = PP1(4)+PT1(4) |
| 6423 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) |
| 6424 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 |
| 6425 | & +(PP2(3)+PT2(3))**2) |
| 6426 | ECH = PP2(4)+PT2(4) |
| 6427 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) |
| 6428 | ELSE |
| 6429 | * antibaryon-baryon |
| 6430 | CALL DT_EVTPUT(-21,IFP1,MOP,0, |
| 6431 | & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8) |
| 6432 | CALL DT_EVTPUT(-22,IFT2,MOT,0, |
| 6433 | & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8) |
| 6434 | CALL DT_EVTPUT(-21,IFP2,MOP,0, |
| 6435 | & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8) |
| 6436 | CALL DT_EVTPUT(-22,IFT1,MOT,0, |
| 6437 | & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8) |
| 6438 | PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2 |
| 6439 | & +(PP1(3)+PT2(3))**2) |
| 6440 | ECH = PP1(4)+PT2(4) |
| 6441 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) |
| 6442 | PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2 |
| 6443 | & +(PP2(3)+PT1(3))**2) |
| 6444 | ECH = PP2(4)+PT1(4) |
| 6445 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) |
| 6446 | ENDIF |
| 6447 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN |
| 6448 | AM1 = SQRT(AM1) |
| 6449 | AM2 = SQRT(AM2) |
| 6450 | IF ((AM1.LT.AMVV).OR.(AM2.LT.AMVV)) THEN |
| 6451 | C WRITE(LOUT,5007) NEVHKK,I,AM1,AM2 |
| 6452 | 5007 FORMAT(1X,'incon. chain mass VV: ',2I5,2E10.3) |
| 6453 | ENDIF |
| 6454 | ELSE |
| 6455 | WRITE(LOUT,5007) NEVHKK,I,AM1,AM2 |
| 6456 | ENDIF |
| 6457 | NCSY = NCSY+1 |
| 6458 | ENDIF |
| 6459 | 80 CONTINUE |
| 6460 | IF (ISTHKK(NPOINT(2)).EQ.1) NPOINT(2) = NPOINT(2)+1 |
| 6461 | |
| 6462 | * energy-momentum & flavor conservation check |
| 6463 | IF (ABS(IDIFF).NE.1) THEN |
| 6464 | IF (IDIFF.NE.0) THEN |
| 6465 | IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-41,1,0, |
| 6466 | & 1,3,10,IREJ) |
| 6467 | ELSE |
| 6468 | IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-31,-32,0, |
| 6469 | & 1,3,10,IREJ) |
| 6470 | ENDIF |
| 6471 | IF (IREJ.NE.0) THEN |
| 6472 | CALL DT_EVTOUT(4) |
| 6473 | STOP |
| 6474 | ENDIF |
| 6475 | ENDIF |
| 6476 | |
| 6477 | RETURN |
| 6478 | |
| 6479 | 9999 CONTINUE |
| 6480 | IREJ = 1 |
| 6481 | RETURN |
| 6482 | END |
| 6483 | |
| 6484 | *$ CREATE DT_CHKCSY.FOR |
| 6485 | *COPY DT_CHKCSY |
| 6486 | * |
| 6487 | *===chkcsy=============================================================* |
| 6488 | * |
| 6489 | SUBROUTINE DT_CHKCSY(ID1,ID2,LCHK) |
| 6490 | |
| 6491 | ************************************************************************ |
| 6492 | * CHeCk Chain SYstem for consistency of partons at chain ends. * |
| 6493 | * ID1,ID2 PDG-numbers of partons at chain ends * |
| 6494 | * LCHK = .true. consistent chain * |
| 6495 | * = .false. inconsistent chain * |
| 6496 | * This version dated 18.01.95 is written by S. Roesler * |
| 6497 | ************************************************************************ |
| 6498 | |
| 6499 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 6500 | SAVE |
| 6501 | PARAMETER ( LINP = 10 , |
| 6502 | & LOUT = 6 , |
| 6503 | & LDAT = 9 ) |
| 6504 | |
| 6505 | LOGICAL LCHK |
| 6506 | |
| 6507 | LCHK = .TRUE. |
| 6508 | |
| 6509 | * q-aq chain |
| 6510 | IF ((ABS(ID1).LE.6).AND.(ABS(ID2).LE.6)) THEN |
| 6511 | IF (ID1*ID2.GT.0) LCHK = .FALSE. |
| 6512 | * q-qq, aq-aqaq chain |
| 6513 | ELSEIF (((ABS(ID1).LE.6).AND.(ABS(ID2).GT.6)).OR. |
| 6514 | & ((ABS(ID1).GT.6).AND.(ABS(ID2).LE.6))) THEN |
| 6515 | IF (ID1*ID2.LT.0) LCHK = .FALSE. |
| 6516 | * qq-aqaq chain |
| 6517 | ELSEIF ((ABS(ID1).GT.6).AND.(ABS(ID2).GT.6)) THEN |
| 6518 | IF (ID1*ID2.GT.0) LCHK = .FALSE. |
| 6519 | ENDIF |
| 6520 | |
| 6521 | RETURN |
| 6522 | END |
| 6523 | |
| 6524 | *$ CREATE DT_EVENTA.FOR |
| 6525 | *COPY DT_EVENTA |
| 6526 | * |
| 6527 | *===eventa=============================================================* |
| 6528 | * |
| 6529 | SUBROUTINE DT_EVENTA(ID,IP,IT,NCSY,IREJ) |
| 6530 | |
| 6531 | ************************************************************************ |
| 6532 | * Treatment of nucleon-nucleon interactions in a two-chain * |
| 6533 | * approximation. * |
| 6534 | * (input) ID BAMJET-index of projectile hadron (in case of * |
| 6535 | * h-K scattering) * |
| 6536 | * IP/IT mass number of projectile/target nucleus * |
| 6537 | * NCSY number of two chain systems * |
| 6538 | * IREJ rejection flag * |
| 6539 | * This version dated 15.01.95 is written by S. Roesler * |
| 6540 | ************************************************************************ |
| 6541 | |
| 6542 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 6543 | SAVE |
| 6544 | PARAMETER ( LINP = 10 , |
| 6545 | & LOUT = 6 , |
| 6546 | & LDAT = 9 ) |
| 6547 | PARAMETER (TINY10=1.0D-10) |
| 6548 | |
| 6549 | * event history |
| 6550 | PARAMETER (NMXHKK=200000) |
| 6551 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 6552 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 6553 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 6554 | * extended event history |
| 6555 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 6556 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 6557 | & IHIST(2,NMXHKK) |
| 6558 | * rejection counter |
| 6559 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, |
| 6560 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, |
| 6561 | & IREXCI(3),IRDIFF(2),IRINC |
| 6562 | * flags for diffractive interactions (DTUNUC 1.x) |
| 6563 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF |
| 6564 | * particle properties (BAMJET index convention) |
| 6565 | CHARACTER*8 ANAME |
| 6566 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 6567 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 6568 | * flags for input different options |
| 6569 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 6570 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 6571 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 6572 | * various options for treatment of partons (DTUNUC 1.x) |
| 6573 | * (chain recombination, Cronin,..) |
| 6574 | LOGICAL LCO2CR,LINTPT |
| 6575 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, |
| 6576 | & LCO2CR,LINTPT |
| 6577 | |
| 6578 | DIMENSION PP1(4),PP2(4),PT1(4),PT2(4) |
| 6579 | |
| 6580 | IREJ = 0 |
| 6581 | NPOINT(3) = NHKK+1 |
| 6582 | |
| 6583 | * skip following treatment for low-mass diffraction |
| 6584 | IF (ABS(IFLAGD).EQ.1) THEN |
| 6585 | NPOINT(3) = NPOINT(2) |
| 6586 | GOTO 5 |
| 6587 | ENDIF |
| 6588 | |
| 6589 | * multiple scattering of chain ends |
| 6590 | IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1) |
| 6591 | IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2) |
| 6592 | |
| 6593 | NC = NPOINT(2) |
| 6594 | * get a two-chain system from DTEVT1 |
| 6595 | DO 3 I=1,NCSY |
| 6596 | IFP1 = IDHKK(NC) |
| 6597 | IFT1 = IDHKK(NC+1) |
| 6598 | IFP2 = IDHKK(NC+2) |
| 6599 | IFT2 = IDHKK(NC+3) |
| 6600 | DO 4 K=1,4 |
| 6601 | PP1(K) = PHKK(K,NC) |
| 6602 | PT1(K) = PHKK(K,NC+1) |
| 6603 | PP2(K) = PHKK(K,NC+2) |
| 6604 | PT2(K) = PHKK(K,NC+3) |
| 6605 | 4 CONTINUE |
| 6606 | MOP1 = NC |
| 6607 | MOT1 = NC+1 |
| 6608 | MOP2 = NC+2 |
| 6609 | MOT2 = NC+3 |
| 6610 | CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2, |
| 6611 | & IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1) |
| 6612 | IF (IREJ1.GT.0) THEN |
| 6613 | IRHHA = IRHHA+1 |
| 6614 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTA' |
| 6615 | GOTO 9999 |
| 6616 | ENDIF |
| 6617 | NC = NC+4 |
| 6618 | 3 CONTINUE |
| 6619 | |
| 6620 | * meson/antibaryon projectile: |
| 6621 | * sample single-chain valence-valence systems (Reggeon contrib.) |
| 6622 | IF ((IP.EQ.1).AND.(ISICHA.EQ.1)) THEN |
| 6623 | IF (IIBAR(ID).LE.0) CALL DT_VV2SCH |
| 6624 | ENDIF |
| 6625 | |
| 6626 | IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN |
| 6627 | * check DTEVT1 for remaining resonance mass corrections |
| 6628 | CALL DT_EVTRES(IREJ1) |
| 6629 | IF (IREJ1.GT.0) THEN |
| 6630 | IRRES(1) = IRRES(1)+1 |
| 6631 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in EVENTA' |
| 6632 | GOTO 9999 |
| 6633 | ENDIF |
| 6634 | ENDIF |
| 6635 | |
| 6636 | * assign p_t to two-"chain" systems consisting of two resonances only |
| 6637 | * since only entries for chains will be affected, this is obsolete |
| 6638 | * in case of JETSET-fragmetation |
| 6639 | CALL DT_RESPT |
| 6640 | |
| 6641 | * combine q-aq chains to color ropes (qq-aqaq) (chain fusion) |
| 6642 | IF (LCO2CR) CALL DT_COM2CR |
| 6643 | |
| 6644 | 5 CONTINUE |
| 6645 | |
| 6646 | * fragmentation of the complete event |
| 6647 | **uncomment for internal phojet-fragmentation |
| 6648 | C CALL DT_EVTFRA(IREJ1) |
| 6649 | CALL DT_EVTFRG(2,IDUM,NPYMEM,IREJ1) |
| 6650 | IF (IREJ1.GT.0) THEN |
| 6651 | IRFRAG = IRFRAG+1 |
| 6652 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 3 in EVENTA' |
| 6653 | GOTO 9999 |
| 6654 | ENDIF |
| 6655 | |
| 6656 | * decay of possible resonances (should be obsolete) |
| 6657 | CALL DT_DECAY1 |
| 6658 | |
| 6659 | RETURN |
| 6660 | |
| 6661 | 9999 CONTINUE |
| 6662 | IREVT = IREVT+1 |
| 6663 | IREJ = 1 |
| 6664 | RETURN |
| 6665 | END |
| 6666 | |
| 6667 | *$ CREATE DT_GETCSY.FOR |
| 6668 | *COPY DT_GETCSY |
| 6669 | * |
| 6670 | *===getcsy=============================================================* |
| 6671 | * |
| 6672 | SUBROUTINE DT_GETCSY(IFPR1,PP1,MOP1,IFPR2,PP2,MOP2, |
| 6673 | & IFTA1,PT1,MOT1,IFTA2,PT2,MOT2,IREJ) |
| 6674 | |
| 6675 | ************************************************************************ |
| 6676 | * This version dated 15.01.95 is written by S. Roesler * |
| 6677 | ************************************************************************ |
| 6678 | |
| 6679 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 6680 | SAVE |
| 6681 | PARAMETER ( LINP = 10 , |
| 6682 | & LOUT = 6 , |
| 6683 | & LDAT = 9 ) |
| 6684 | PARAMETER (TINY10=1.0D-10) |
| 6685 | |
| 6686 | * event history |
| 6687 | PARAMETER (NMXHKK=200000) |
| 6688 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 6689 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 6690 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 6691 | * extended event history |
| 6692 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 6693 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 6694 | & IHIST(2,NMXHKK) |
| 6695 | * rejection counter |
| 6696 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, |
| 6697 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, |
| 6698 | & IREXCI(3),IRDIFF(2),IRINC |
| 6699 | * flags for input different options |
| 6700 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 6701 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 6702 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 6703 | * flags for diffractive interactions (DTUNUC 1.x) |
| 6704 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF |
| 6705 | |
| 6706 | DIMENSION PP1(4),PP2(4),PT1(4),PT2(4), |
| 6707 | & IFP1(2),IFP2(2),IFT1(2),IFT2(2),PCH1(4),PCH2(4) |
| 6708 | |
| 6709 | IREJ = 0 |
| 6710 | |
| 6711 | * get quark content of partons |
| 6712 | DO 1 I=1,2 |
| 6713 | IFP1(I) = 0 |
| 6714 | IFP2(I) = 0 |
| 6715 | IFT1(I) = 0 |
| 6716 | IFT2(I) = 0 |
| 6717 | 1 CONTINUE |
| 6718 | IFP1(1) = IDT_IPDG2B(IFPR1,1,2) |
| 6719 | IF (ABS(IFPR1).GE.1000) IFP1(2) = IDT_IPDG2B(IFPR1,2,2) |
| 6720 | IFP2(1) = IDT_IPDG2B(IFPR2,1,2) |
| 6721 | IF (ABS(IFPR2).GE.1000) IFP2(2) = IDT_IPDG2B(IFPR2,2,2) |
| 6722 | IFT1(1) = IDT_IPDG2B(IFTA1,1,2) |
| 6723 | IF (ABS(IFTA1).GE.1000) IFT1(2) = IDT_IPDG2B(IFTA1,2,2) |
| 6724 | IFT2(1) = IDT_IPDG2B(IFTA2,1,2) |
| 6725 | IF (ABS(IFTA2).GE.1000) IFT2(2) = IDT_IPDG2B(IFTA2,2,2) |
| 6726 | |
| 6727 | * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq, 3 - qq-aqaq) |
| 6728 | IDCH1 = 2 |
| 6729 | IF ((IFP1(2).EQ.0).AND.(IFT1(2).EQ.0)) IDCH1 = 1 |
| 6730 | IF ((IFP1(2).NE.0).AND.(IFT1(2).NE.0)) IDCH1 = 3 |
| 6731 | IDCH2 = 2 |
| 6732 | IF ((IFP2(2).EQ.0).AND.(IFT2(2).EQ.0)) IDCH2 = 1 |
| 6733 | IF ((IFP2(2).NE.0).AND.(IFT2(2).NE.0)) IDCH2 = 3 |
| 6734 | |
| 6735 | * store initial configuration for energy-momentum cons. check |
| 6736 | IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IDUM) |
| 6737 | |
| 6738 | * sample intrinsic p_t at chain-ends |
| 6739 | CALL DT_GETSPT(PP1,IFPR1,IFP1,PP2,IFPR2,IFP2, |
| 6740 | & PT1,IFTA1,IFT1,PT2,IFTA2,IFT2, |
| 6741 | & AMCH1,IDCH1,AMCH2,IDCH2,IDCH(MOP1),IREJ1) |
| 6742 | IF (IREJ1.NE.0) THEN |
| 6743 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in GETCSY' |
| 6744 | IRPT = IRPT+1 |
| 6745 | GOTO 9999 |
| 6746 | ENDIF |
| 6747 | |
| 6748 | C IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN |
| 6749 | C IF ((IDCH1.EQ.3).OR.((IDCH1.GT.1).AND.(IDCH2.EQ.1))) THEN |
| 6750 | C* check second chain for resonance |
| 6751 | C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2, |
| 6752 | C & AMCH2,AMCH2N,IDCH2,IREJ1) |
| 6753 | C IF (IREJ1.NE.0) GOTO 9999 |
| 6754 | C IF (IDR2.NE.0) THEN |
| 6755 | C CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1, |
| 6756 | C & AMCH2,AMCH2N,AMCH1,IREJ1) |
| 6757 | C IF (IREJ1.NE.0) GOTO 9999 |
| 6758 | C ENDIF |
| 6759 | C* check first chain for resonance |
| 6760 | C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1, |
| 6761 | C & AMCH1,AMCH1N,IDCH1,IREJ1) |
| 6762 | C IF (IREJ1.NE.0) GOTO 9999 |
| 6763 | C IF (IDR1.NE.0) IDR1 = 100*IDR1 |
| 6764 | C ELSE |
| 6765 | C* check first chain for resonance |
| 6766 | C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1, |
| 6767 | C & AMCH1,AMCH1N,IDCH1,IREJ1) |
| 6768 | C IF (IREJ1.NE.0) GOTO 9999 |
| 6769 | C IF (IDR1.NE.0) THEN |
| 6770 | C CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2, |
| 6771 | C & AMCH1,AMCH1N,AMCH2,IREJ1) |
| 6772 | C IF (IREJ1.NE.0) GOTO 9999 |
| 6773 | C ENDIF |
| 6774 | C* check second chain for resonance |
| 6775 | C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2, |
| 6776 | C & AMCH2,AMCH2N,IDCH2,IREJ1) |
| 6777 | C IF (IREJ1.NE.0) GOTO 9999 |
| 6778 | C IF (IDR2.NE.0) IDR2 = 100*IDR2 |
| 6779 | C ENDIF |
| 6780 | C ENDIF |
| 6781 | |
| 6782 | IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN |
| 6783 | * check chains for resonances |
| 6784 | CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1, |
| 6785 | & AMCH1,AMCH1N,IDCH1,IREJ1) |
| 6786 | IF (IREJ1.NE.0) GOTO 9999 |
| 6787 | CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2, |
| 6788 | & AMCH2,AMCH2N,IDCH2,IREJ1) |
| 6789 | IF (IREJ1.NE.0) GOTO 9999 |
| 6790 | * change kinematics corresponding to resonance-masses |
| 6791 | IF ( (IDR1.NE.0).AND.(IDR2.EQ.0) ) THEN |
| 6792 | CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2, |
| 6793 | & AMCH1,AMCH1N,AMCH2,IREJ1) |
| 6794 | IF (IREJ1.GT.0) GOTO 9999 |
| 6795 | IF (IREJ1.EQ.-1) IDR1 = 100*IDR1 |
| 6796 | CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2, |
| 6797 | & AMCH2,AMCH2N,IDCH2,IREJ1) |
| 6798 | IF (IREJ1.NE.0) GOTO 9999 |
| 6799 | IF (IDR2.NE.0) IDR2 = 100*IDR2 |
| 6800 | ELSEIF ( (IDR1.EQ.0).AND.(IDR2.NE.0) ) THEN |
| 6801 | CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1, |
| 6802 | & AMCH2,AMCH2N,AMCH1,IREJ1) |
| 6803 | IF (IREJ1.GT.0) GOTO 9999 |
| 6804 | IF (IREJ1.EQ.-1) IDR2 = 100*IDR2 |
| 6805 | CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1, |
| 6806 | & AMCH1,AMCH1N,IDCH1,IREJ1) |
| 6807 | IF (IREJ1.NE.0) GOTO 9999 |
| 6808 | IF (IDR1.NE.0) IDR1 = 100*IDR1 |
| 6809 | ELSEIF ( (IDR1.NE.0).AND.(IDR2.NE.0) ) THEN |
| 6810 | AMDIF1 = ABS(AMCH1-AMCH1N) |
| 6811 | AMDIF2 = ABS(AMCH2-AMCH2N) |
| 6812 | IF (AMDIF2.LT.AMDIF1) THEN |
| 6813 | CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1, |
| 6814 | & AMCH2,AMCH2N,AMCH1,IREJ1) |
| 6815 | IF (IREJ1.GT.0) GOTO 9999 |
| 6816 | IF (IREJ1.EQ.-1) IDR2 = 100*IDR2 |
| 6817 | CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2), |
| 6818 | & IDR1,IDXR1,AMCH1,AMCH1N,IDCH1,IREJ1) |
| 6819 | IF (IREJ1.NE.0) GOTO 9999 |
| 6820 | IF (IDR1.NE.0) IDR1 = 100*IDR1 |
| 6821 | ELSE |
| 6822 | CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2, |
| 6823 | & AMCH1,AMCH1N,AMCH2,IREJ1) |
| 6824 | IF (IREJ1.GT.0) GOTO 9999 |
| 6825 | IF (IREJ1.EQ.-1) IDR1 = 100*IDR1 |
| 6826 | CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2), |
| 6827 | & IDR2,IDXR2,AMCH2,AMCH2N,IDCH2,IREJ1) |
| 6828 | IF (IREJ1.NE.0) GOTO 9999 |
| 6829 | IF (IDR2.NE.0) IDR2 = 100*IDR2 |
| 6830 | ENDIF |
| 6831 | ENDIF |
| 6832 | ENDIF |
| 6833 | |
| 6834 | * store final configuration for energy-momentum cons. check |
| 6835 | IF (LEMCCK) THEN |
| 6836 | CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IDUM) |
| 6837 | CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1) |
| 6838 | IF (IREJ1.NE.0) GOTO 9999 |
| 6839 | ENDIF |
| 6840 | |
| 6841 | * put partons and chains into DTEVT1 |
| 6842 | DO 10 I=1,4 |
| 6843 | PCH1(I) = PP1(I)+PT1(I) |
| 6844 | PCH2(I) = PP2(I)+PT2(I) |
| 6845 | 10 CONTINUE |
| 6846 | CALL DT_EVTPUT(-ISTHKK(MOP1),IFPR1,MOP1,0,PP1(1),PP1(2), |
| 6847 | & PP1(3),PP1(4),0,0,0) |
| 6848 | CALL DT_EVTPUT(-ISTHKK(MOT1),IFTA1,MOT1,0,PT1(1),PT1(2), |
| 6849 | & PT1(3),PT1(4),0,0,0) |
| 6850 | KCH = 100+IDCH(MOP1)*10+1 |
| 6851 | CALL DT_EVTPUT(KCH,88888,-2,-1, |
| 6852 | & PCH1(1),PCH1(2),PCH1(3),PCH1(4),IDR1,IDXR1,IDCH(MOP1)) |
| 6853 | CALL DT_EVTPUT(-ISTHKK(MOP2),IFPR2,MOP2,0,PP2(1),PP2(2), |
| 6854 | & PP2(3),PP2(4),0,0,0) |
| 6855 | CALL DT_EVTPUT(-ISTHKK(MOT2),IFTA2,MOT2,0,PT2(1),PT2(2), |
| 6856 | & PT2(3),PT2(4),0,0,0) |
| 6857 | KCH = KCH+1 |
| 6858 | CALL DT_EVTPUT(KCH,88888,-2,-1, |
| 6859 | & PCH2(1),PCH2(2),PCH2(3),PCH2(4),IDR2,IDXR2,IDCH(MOP2)) |
| 6860 | |
| 6861 | RETURN |
| 6862 | |
| 6863 | 9999 CONTINUE |
| 6864 | IF ((IDCH(MOP1).LE.3).AND.(IDCH(MOP2).LE.3)) THEN |
| 6865 | * "cancel" sea-sea chains |
| 6866 | CALL DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ1) |
| 6867 | IF (IREJ1.NE.0) GOTO 9998 |
| 6868 | **sr 16.5. flag for EVENTB |
| 6869 | IREJ = -1 |
| 6870 | RETURN |
| 6871 | ENDIF |
| 6872 | 9998 CONTINUE |
| 6873 | IREJ = 1 |
| 6874 | RETURN |
| 6875 | END |
| 6876 | |
| 6877 | *$ CREATE DT_CHKINE.FOR |
| 6878 | *COPY DT_CHKINE |
| 6879 | * |
| 6880 | *===chkine=============================================================* |
| 6881 | * |
| 6882 | SUBROUTINE DT_CHKINE(PP1I,IFP1,PP2I,IFP2,PT1I,IFT1,PT2I,IFT2, |
| 6883 | & AMCH1,AMCH1N,AMCH2,IREJ) |
| 6884 | |
| 6885 | ************************************************************************ |
| 6886 | * This subroutine replaces CORMOM. * |
| 6887 | * This version dated 05.01.95 is written by S. Roesler * |
| 6888 | ************************************************************************ |
| 6889 | |
| 6890 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 6891 | SAVE |
| 6892 | PARAMETER ( LINP = 10 , |
| 6893 | & LOUT = 6 , |
| 6894 | & LDAT = 9 ) |
| 6895 | PARAMETER (TINY10=1.0D-10) |
| 6896 | |
| 6897 | * flags for input different options |
| 6898 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 6899 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 6900 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 6901 | * rejection counter |
| 6902 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, |
| 6903 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, |
| 6904 | & IREXCI(3),IRDIFF(2),IRINC |
| 6905 | |
| 6906 | DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),P1(4),P2(4), |
| 6907 | & PP1I(4),PP2I(4),PT1I(4),PT2I(4) |
| 6908 | |
| 6909 | IREJ = 0 |
| 6910 | JMSHL = IMSHL |
| 6911 | |
| 6912 | SCALE = AMCH1N/MAX(AMCH1,TINY10) |
| 6913 | DO 10 I=1,4 |
| 6914 | PP1(I) = PP1I(I) |
| 6915 | PP2(I) = PP2I(I) |
| 6916 | PT1(I) = PT1I(I) |
| 6917 | PT2(I) = PT2I(I) |
| 6918 | PP2(I) = PP2(I)+(1.0D0-SCALE)*PP1(I) |
| 6919 | PT2(I) = PT2(I)+(1.0D0-SCALE)*PT1(I) |
| 6920 | PP1(I) = SCALE*PP1(I) |
| 6921 | PT1(I) = SCALE*PT1(I) |
| 6922 | 10 CONTINUE |
| 6923 | IF ((PP1(4).LT.0.0D0).OR.(PP2(4).LT.0.0D0).OR. |
| 6924 | & (PT1(4).LT.0.0D0).OR.(PT2(4).LT.0.0D0)) GOTO 9997 |
| 6925 | |
| 6926 | ECH = PP2(4)+PT2(4) |
| 6927 | PCH = SQRT( (PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2+ |
| 6928 | & (PP2(3)+PT2(3))**2 ) |
| 6929 | AMCH22 = (ECH-PCH)*(ECH+PCH) |
| 6930 | IF (AMCH22.LT.0.0D0) THEN |
| 6931 | IF (IOULEV(1).GT.0) |
| 6932 | & WRITE(LOUT,'(1X,A)') 'CHKINE: inconsistent treatment!' |
| 6933 | GOTO 9997 |
| 6934 | ENDIF |
| 6935 | |
| 6936 | AMCH1 = AMCH1N |
| 6937 | AMCH2 = SQRT(AMCH22) |
| 6938 | |
| 6939 | * put partons again on mass shell |
| 6940 | 13 CONTINUE |
| 6941 | XM1 = 0.0D0 |
| 6942 | XM2 = 0.0D0 |
| 6943 | IF (JMSHL.EQ.1) THEN |
| 6944 | XM1 = PYMASS(IFP1) |
| 6945 | XM2 = PYMASS(IFT1) |
| 6946 | ENDIF |
| 6947 | CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1) |
| 6948 | IF (IREJ1.NE.0) THEN |
| 6949 | IF (JMSHL.EQ.0) GOTO 9998 |
| 6950 | JMSHL = 0 |
| 6951 | GOTO 13 |
| 6952 | ENDIF |
| 6953 | JMSHL = IMSHL |
| 6954 | DO 11 I=1,4 |
| 6955 | PP1(I) = P1(I) |
| 6956 | PT1(I) = P2(I) |
| 6957 | 11 CONTINUE |
| 6958 | 14 CONTINUE |
| 6959 | XM1 = 0.0D0 |
| 6960 | XM2 = 0.0D0 |
| 6961 | IF (JMSHL.EQ.1) THEN |
| 6962 | XM1 = PYMASS(IFP2) |
| 6963 | XM2 = PYMASS(IFT2) |
| 6964 | ENDIF |
| 6965 | CALL DT_MASHEL(PP2,PT2,XM1,XM2,P1,P2,IREJ1) |
| 6966 | IF (IREJ1.NE.0) THEN |
| 6967 | IF (JMSHL.EQ.0) GOTO 9998 |
| 6968 | JMSHL = 0 |
| 6969 | GOTO 14 |
| 6970 | ENDIF |
| 6971 | DO 12 I=1,4 |
| 6972 | PP2(I) = P1(I) |
| 6973 | PT2(I) = P2(I) |
| 6974 | 12 CONTINUE |
| 6975 | DO 15 I=1,4 |
| 6976 | PP1I(I) = PP1(I) |
| 6977 | PP2I(I) = PP2(I) |
| 6978 | PT1I(I) = PT1(I) |
| 6979 | PT2I(I) = PT2(I) |
| 6980 | 15 CONTINUE |
| 6981 | RETURN |
| 6982 | |
| 6983 | 9997 IRCHKI(1) = IRCHKI(1)+1 |
| 6984 | **sr |
| 6985 | C GOTO 9999 |
| 6986 | IREJ = -1 |
| 6987 | RETURN |
| 6988 | ** |
| 6989 | 9998 IRCHKI(2) = IRCHKI(2)+1 |
| 6990 | |
| 6991 | 9999 CONTINUE |
| 6992 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in CHKINE' |
| 6993 | IREJ = 1 |
| 6994 | RETURN |
| 6995 | END |
| 6996 | |
| 6997 | *$ CREATE DT_CH2RES.FOR |
| 6998 | *COPY DT_CH2RES |
| 6999 | * |
| 7000 | *===ch2res=============================================================* |
| 7001 | * |
| 7002 | SUBROUTINE DT_CH2RES(IF1,IF2,IF3,IF4,IDR,IDXR, |
| 7003 | & AM,AMN,IMODE,IREJ) |
| 7004 | |
| 7005 | ************************************************************************ |
| 7006 | * Check chains for resonance production. * |
| 7007 | * This subroutine replaces COMCMA/COBCMA/COMCM2 * |
| 7008 | * input: * |
| 7009 | * IF1,2,3,4 input flavors (q,aq in any order) * |
| 7010 | * AM chain mass * |
| 7011 | * MODE = 1 check q-aq chain for meson-resonance * |
| 7012 | * = 2 check q-qq, aq-aqaq chain for baryon-resonance * |
| 7013 | * = 3 check qq-aqaq chain for lower mass cut * |
| 7014 | * output: * |
| 7015 | * IDR = 0 no resonances found * |
| 7016 | * = -1 pseudoscalar meson/octet baryon * |
| 7017 | * = 1 vector-meson/decuplet baryon * |
| 7018 | * IDXR BAMJET-index of corresponding resonance * |
| 7019 | * AMN mass of corresponding resonance * |
| 7020 | * * |
| 7021 | * IREJ rejection flag * |
| 7022 | * This version dated 06.01.95 is written by S. Roesler * |
| 7023 | ************************************************************************ |
| 7024 | |
| 7025 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 7026 | SAVE |
| 7027 | PARAMETER ( LINP = 10 , |
| 7028 | & LOUT = 6 , |
| 7029 | & LDAT = 9 ) |
| 7030 | |
| 7031 | * particle properties (BAMJET index convention) |
| 7032 | CHARACTER*8 ANAME |
| 7033 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 7034 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 7035 | * quark-content to particle index conversion (DTUNUC 1.x) |
| 7036 | COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21), |
| 7037 | & IA08(6,21),IA10(6,21) |
| 7038 | * rejection counter |
| 7039 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, |
| 7040 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, |
| 7041 | & IREXCI(3),IRDIFF(2),IRINC |
| 7042 | * flags for input different options |
| 7043 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 7044 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 7045 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 7046 | |
| 7047 | DIMENSION IF(4),JF(4) |
| 7048 | |
| 7049 | **sr 4.7. test |
| 7050 | C DATA AMLOM,AMLOB /0.08D0,0.2D0/ |
| 7051 | DATA AMLOM,AMLOB /0.1D0,0.7D0/ |
| 7052 | ** |
| 7053 | C DATA AMLOM,AMLOB /0.001D0,0.001D0/ |
| 7054 | |
| 7055 | MODE = ABS(IMODE) |
| 7056 | |
| 7057 | IF ((MODE.LT.1).OR.(MODE.GT.3)) THEN |
| 7058 | WRITE(LOUT,1000) MODE |
| 7059 | 1000 FORMAT(1X,'CH2RES: MODE ',I4,' not supported!',/, |
| 7060 | & 1X,' program stopped') |
| 7061 | STOP |
| 7062 | ENDIF |
| 7063 | |
| 7064 | AMX = AM |
| 7065 | IREJ = 0 |
| 7066 | IDR = 0 |
| 7067 | IDXR = 0 |
| 7068 | AMN = AMX |
| 7069 | IF ((AM.LE.0.0D0).AND.(MODE.EQ.1)) AMX = AMLOM |
| 7070 | IF ((AM.LE.0.0D0).AND.(MODE.EQ.2)) AMX = AMLOB |
| 7071 | |
| 7072 | IF(1) = IF1 |
| 7073 | IF(2) = IF2 |
| 7074 | IF(3) = IF3 |
| 7075 | IF(4) = IF4 |
| 7076 | NF = 0 |
| 7077 | DO 100 I=1,4 |
| 7078 | IF (IF(I).NE.0) THEN |
| 7079 | NF = NF+1 |
| 7080 | JF(NF) = IF(I) |
| 7081 | ENDIF |
| 7082 | 100 CONTINUE |
| 7083 | IF (NF.LE.MODE) THEN |
| 7084 | WRITE(LOUT,1001) MODE,IF |
| 7085 | 1001 FORMAT(1X,'CH2RES: inconsistent input flavors in MODE ', |
| 7086 | & I4,' IF1 = ',I4,' IF2 = ',I4,' IF3 = ',I4,' IF4 = ',I4) |
| 7087 | GOTO 9999 |
| 7088 | ENDIF |
| 7089 | |
| 7090 | GOTO (1,2,3) MODE |
| 7091 | |
| 7092 | * check for meson resonance |
| 7093 | 1 CONTINUE |
| 7094 | IFQ = JF(1) |
| 7095 | IFAQ = ABS(JF(2)) |
| 7096 | IF (JF(2).GT.0) THEN |
| 7097 | IFQ = JF(2) |
| 7098 | IFAQ = ABS(JF(1)) |
| 7099 | ENDIF |
| 7100 | IFPS = IMPS(IFAQ,IFQ) |
| 7101 | IFV = IMVE(IFAQ,IFQ) |
| 7102 | AMPS = AAM(IFPS) |
| 7103 | AMV = AAM(IFV) |
| 7104 | AMHI = AMV+0.3D0 |
| 7105 | IF (AMX.LT.AMV) THEN |
| 7106 | IF (AMX.LT.AMPS) THEN |
| 7107 | IF (IMODE.GT.0) THEN |
| 7108 | IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOM)) GOTO 9999 |
| 7109 | ELSE |
| 7110 | IF (AMX.LT.0.8D0*AMPS) GOTO 9999 |
| 7111 | ENDIF |
| 7112 | LOMRES = LOMRES+1 |
| 7113 | ENDIF |
| 7114 | * replace chain by pseudoscalar meson |
| 7115 | IDR = -1 |
| 7116 | IDXR = IFPS |
| 7117 | AMN = AMPS |
| 7118 | ELSEIF (AMX.LT.AMHI) THEN |
| 7119 | * replace chain by vector-meson |
| 7120 | IDR = 1 |
| 7121 | IDXR = IFV |
| 7122 | AMN = AMV |
| 7123 | ENDIF |
| 7124 | RETURN |
| 7125 | |
| 7126 | * check for baryon resonance |
| 7127 | 2 CONTINUE |
| 7128 | CALL DT_DBKLAS(JF(1),JF(2),JF(3),JB8,JB10) |
| 7129 | AM8 = AAM(JB8) |
| 7130 | AM10 = AAM(JB10) |
| 7131 | AMHI = AM10+0.3D0 |
| 7132 | IF (AMX.LT.AM10) THEN |
| 7133 | IF (AMX.LT.AM8) THEN |
| 7134 | IF (IMODE.GT.0) THEN |
| 7135 | IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOB)) GOTO 9999 |
| 7136 | ELSE |
| 7137 | IF (AMX.LT.0.8D0*AM8) GOTO 9999 |
| 7138 | ENDIF |
| 7139 | LOBRES = LOBRES+1 |
| 7140 | ENDIF |
| 7141 | * replace chain by oktet baryon |
| 7142 | IDR = -1 |
| 7143 | IDXR = JB8 |
| 7144 | AMN = AM8 |
| 7145 | ELSEIF (AMX.LT.AMHI) THEN |
| 7146 | IDR = 1 |
| 7147 | IDXR = JB10 |
| 7148 | AMN = AM10 |
| 7149 | ENDIF |
| 7150 | RETURN |
| 7151 | |
| 7152 | * check qq-aqaq for lower mass cut |
| 7153 | 3 CONTINUE |
| 7154 | * empirical definition of AMHI to allow for (b-antib)-pair prod. |
| 7155 | AMHI = 2.5D0 |
| 7156 | IF (AMX.LT.AMHI) GOTO 9999 |
| 7157 | RETURN |
| 7158 | |
| 7159 | 9999 CONTINUE |
| 7160 | IF ((IOULEV(1).GT.0).AND.(IMODE.GT.0)) |
| 7161 | & WRITE(LOUT,*) 'rejected 1 in CH2RES',IMODE |
| 7162 | IREJ = 1 |
| 7163 | IRRES(2) = IRRES(2)+1 |
| 7164 | RETURN |
| 7165 | END |
| 7166 | |
| 7167 | *$ CREATE DT_RJSEAC.FOR |
| 7168 | *COPY DT_RJSEAC |
| 7169 | * |
| 7170 | *===rjseac=============================================================* |
| 7171 | * |
| 7172 | SUBROUTINE DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ) |
| 7173 | |
| 7174 | ************************************************************************ |
| 7175 | * ReJection of SEA-sea Chains. * |
| 7176 | * MOP1/2 entries of projectile sea-partons in DTEVT1 * |
| 7177 | * MOT1/2 entries of projectile sea-partons in DTEVT1 * |
| 7178 | * This version dated 16.01.95 is written by S. Roesler * |
| 7179 | ************************************************************************ |
| 7180 | |
| 7181 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 7182 | SAVE |
| 7183 | PARAMETER ( LINP = 10 , |
| 7184 | & LOUT = 6 , |
| 7185 | & LDAT = 9 ) |
| 7186 | PARAMETER (TINY10=1.0D-10,ZERO=0.0D0) |
| 7187 | |
| 7188 | * event history |
| 7189 | PARAMETER (NMXHKK=200000) |
| 7190 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 7191 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 7192 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 7193 | * extended event history |
| 7194 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 7195 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 7196 | & IHIST(2,NMXHKK) |
| 7197 | * statistics |
| 7198 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, |
| 7199 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), |
| 7200 | & ICEVTG(8,0:30) |
| 7201 | |
| 7202 | DIMENSION IDXSEA(2,2),IDXNUC(2),ISTVAL(2) |
| 7203 | |
| 7204 | IREJ = 0 |
| 7205 | |
| 7206 | * projectile sea q-aq-pair |
| 7207 | * indices of sea-pair |
| 7208 | IDXSEA(1,1) = MOP1 |
| 7209 | IDXSEA(1,2) = MOP2 |
| 7210 | * index of mother-nucleon |
| 7211 | IDXNUC(1) = JMOHKK(1,MOP1) |
| 7212 | * status of valence quarks to be corrected |
| 7213 | ISTVAL(1) = -21 |
| 7214 | |
| 7215 | * target sea q-aq-pair |
| 7216 | * indices of sea-pair |
| 7217 | IDXSEA(2,1) = MOT1 |
| 7218 | IDXSEA(2,2) = MOT2 |
| 7219 | * index of mother-nucleon |
| 7220 | IDXNUC(2) = JMOHKK(1,MOT1) |
| 7221 | * status of valence quarks to be corrected |
| 7222 | ISTVAL(2) = -22 |
| 7223 | |
| 7224 | DO 1 N=1,2 |
| 7225 | IDONE = 0 |
| 7226 | DO 2 I=NPOINT(2),NHKK |
| 7227 | IF ((ISTHKK(I).EQ.ISTVAL(N)).AND. |
| 7228 | & (JMOHKK(1,I).EQ.IDXNUC(N))) THEN |
| 7229 | * valence parton found |
| 7230 | * inrease 4-momentum by sea 4-momentum |
| 7231 | DO 3 K=1,4 |
| 7232 | PHKK(K,I) = PHKK(K,I)+PHKK(K,IDXSEA(N,1))+ |
| 7233 | & PHKK(K,IDXSEA(N,2)) |
| 7234 | 3 CONTINUE |
| 7235 | PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2- |
| 7236 | & PHKK(2,I)**2-PHKK(3,I)**2)) |
| 7237 | * "cancel" sea-pair |
| 7238 | DO 4 J=1,2 |
| 7239 | ISTHKK(IDXSEA(N,J)) = 100 |
| 7240 | IDHKK(IDXSEA(N,J)) = 0 |
| 7241 | JMOHKK(1,IDXSEA(N,J)) = 0 |
| 7242 | JMOHKK(2,IDXSEA(N,J)) = 0 |
| 7243 | JDAHKK(1,IDXSEA(N,J)) = 0 |
| 7244 | JDAHKK(2,IDXSEA(N,J)) = 0 |
| 7245 | DO 5 K=1,4 |
| 7246 | PHKK(K,IDXSEA(N,J)) = ZERO |
| 7247 | VHKK(K,IDXSEA(N,J)) = ZERO |
| 7248 | WHKK(K,IDXSEA(N,J)) = ZERO |
| 7249 | 5 CONTINUE |
| 7250 | PHKK(5,IDXSEA(N,J)) = ZERO |
| 7251 | 4 CONTINUE |
| 7252 | IDONE = 1 |
| 7253 | ENDIF |
| 7254 | 2 CONTINUE |
| 7255 | IF (IDONE.NE.1) THEN |
| 7256 | WRITE(LOUT,1000) NEVHKK,MOP1,MOP2,MOT1,MOT2 |
| 7257 | 1000 FORMAT(1X,'RJSEAC: event ',I8,': inconsistent event', |
| 7258 | & '-record!',/,1X,' sea-quark pairs ', |
| 7259 | & 2I5,4X,2I5,' could not be canceled!') |
| 7260 | GOTO 9999 |
| 7261 | ENDIF |
| 7262 | 1 CONTINUE |
| 7263 | ICRJSS = ICRJSS+1 |
| 7264 | RETURN |
| 7265 | |
| 7266 | 9999 CONTINUE |
| 7267 | IREJ = 1 |
| 7268 | RETURN |
| 7269 | END |
| 7270 | |
| 7271 | *$ CREATE DT_VV2SCH.FOR |
| 7272 | *COPY DT_VV2SCH |
| 7273 | * |
| 7274 | *===vv2sch=============================================================* |
| 7275 | * |
| 7276 | SUBROUTINE DT_VV2SCH |
| 7277 | |
| 7278 | ************************************************************************ |
| 7279 | * Change Valence-Valence chain systems to Single CHain systems for * |
| 7280 | * hadron-nucleus collisions with meson or antibaryon projectile. * |
| 7281 | * (Reggeon contribution) * |
| 7282 | * The single chain system is approximately treated as one chain and a * |
| 7283 | * meson at rest. * |
| 7284 | * This version dated 18.01.95 is written by S. Roesler * |
| 7285 | ************************************************************************ |
| 7286 | |
| 7287 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 7288 | SAVE |
| 7289 | PARAMETER ( LINP = 10 , |
| 7290 | & LOUT = 6 , |
| 7291 | & LDAT = 9 ) |
| 7292 | PARAMETER (ZERO=0.0D0,TINY7=1.0D-7,TINY3=1.0D-3) |
| 7293 | |
| 7294 | LOGICAL LSTART |
| 7295 | |
| 7296 | * event history |
| 7297 | PARAMETER (NMXHKK=200000) |
| 7298 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 7299 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 7300 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 7301 | * extended event history |
| 7302 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 7303 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 7304 | & IHIST(2,NMXHKK) |
| 7305 | * flags for input different options |
| 7306 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 7307 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 7308 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 7309 | * statistics |
| 7310 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, |
| 7311 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), |
| 7312 | & ICEVTG(8,0:30) |
| 7313 | |
| 7314 | DIMENSION IF(4,2),MO(4),PP1(4),PP2(4),PT1(4),PT2(4),PCH1(4), |
| 7315 | & PCH2(4) |
| 7316 | |
| 7317 | DATA LSTART /.TRUE./ |
| 7318 | |
| 7319 | IFSC = 0 |
| 7320 | IF (LSTART) THEN |
| 7321 | WRITE(LOUT,1000) |
| 7322 | 1000 FORMAT(/,1X,'VV2SCH: Reggeon contribution to valance-', |
| 7323 | & 'valence chains treated') |
| 7324 | LSTART = .FALSE. |
| 7325 | ENDIF |
| 7326 | |
| 7327 | NSTOP = NHKK |
| 7328 | |
| 7329 | * get index of first chain |
| 7330 | DO 1 I=NPOINT(3),NHKK |
| 7331 | IF (IDHKK(I).EQ.88888) THEN |
| 7332 | NC = I |
| 7333 | GOTO 2 |
| 7334 | ENDIF |
| 7335 | 1 CONTINUE |
| 7336 | |
| 7337 | 2 CONTINUE |
| 7338 | IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888) |
| 7339 | & .AND.(NC.LT.NSTOP)) THEN |
| 7340 | * get valence-valence chains |
| 7341 | IF ((IDCH(NC).EQ.8).AND.(IDCH(NC+3).EQ.8)) THEN |
| 7342 | * get "mother"-hadron indices |
| 7343 | MO1 = JMOHKK(1,JMOHKK(1,JMOHKK(1,NC))) |
| 7344 | MO2 = JMOHKK(1,JMOHKK(1,JMOHKK(2,NC))) |
| 7345 | KPROJ = IDT_ICIHAD(IDHKK(MO1)) |
| 7346 | KTARG = IDT_ICIHAD(IDHKK(MO2)) |
| 7347 | * Lab momentum of projectile hadron |
| 7348 | CALL DT_LTNUC(PHKK(3,MO1),PHKK(4,MO1),PPZ,PPE,-3) |
| 7349 | PTOT = SQRT(PHKK(1,MO1)**2+PHKK(2,MO1)**2+ |
| 7350 | & PHKK(3,MO1)**2) |
| 7351 | |
| 7352 | SICHAP = DT_PHNSCH(KPROJ,KTARG,PTOT) |
| 7353 | IF (DT_RNDM(PTOT).LE.SICHAP) THEN |
| 7354 | ICVV2S = ICVV2S+1 |
| 7355 | * single chain requested |
| 7356 | * get flavors of chain-end partons |
| 7357 | MO(1) = JMOHKK(1,NC) |
| 7358 | MO(2) = JMOHKK(2,NC) |
| 7359 | MO(3) = JMOHKK(1,NC+3) |
| 7360 | MO(4) = JMOHKK(2,NC+3) |
| 7361 | DO 3 I=1,4 |
| 7362 | IF(I,1) = IDT_IPDG2B(IDHKK(MO(I)),1,2) |
| 7363 | IF(I,2) = 0 |
| 7364 | IF (ABS(IDHKK(MO(I))).GE.1000) |
| 7365 | & IF(I,2) = IDT_IPDG2B(IDHKK(MO(I)),2,2) |
| 7366 | 3 CONTINUE |
| 7367 | * which one is the q-aq chain? |
| 7368 | * N1,N1+1 - DTEVT1-entries for q-aq system |
| 7369 | * N2,N2+1 - DTEVT1-entries for the other chain |
| 7370 | IF ((IF(1,2).EQ.0).AND.(IF(2,2).EQ.0)) THEN |
| 7371 | K1 = 1 |
| 7372 | K2 = 3 |
| 7373 | N1 = NC-2 |
| 7374 | N2 = NC+1 |
| 7375 | ELSEIF ((IF(3,2).EQ.0).AND.(IF(4,2).EQ.0)) THEN |
| 7376 | K1 = 3 |
| 7377 | K2 = 1 |
| 7378 | N1 = NC+1 |
| 7379 | N2 = NC-2 |
| 7380 | ELSE |
| 7381 | GOTO 10 |
| 7382 | ENDIF |
| 7383 | DO 4 K=1,4 |
| 7384 | PP1(K) = PHKK(K,N1) |
| 7385 | PT1(K) = PHKK(K,N1+1) |
| 7386 | PP2(K) = PHKK(K,N2) |
| 7387 | PT2(K) = PHKK(K,N2+1) |
| 7388 | 4 CONTINUE |
| 7389 | AMCH1 = PHKK(5,N1+2) |
| 7390 | AMCH2 = PHKK(5,N2+2) |
| 7391 | * get meson-identity corresponding to flavors of q-aq chain |
| 7392 | ITMP = IRESRJ |
| 7393 | IRESRJ = 0 |
| 7394 | CALL DT_CH2RES(IF(K1,1),IF(K1+1,1),0,0,IDR1,IDXR1, |
| 7395 | & ZERO,AMCH1N,1,IDUM) |
| 7396 | IRESRJ = ITMP |
| 7397 | * change kinematics of chains |
| 7398 | CALL DT_CHKINE(PP1,IDHKK(N1), PP2,IDHKK(N2), |
| 7399 | & PT1,IDHKK(N1+1),PT2,IDHKK(N2+1), |
| 7400 | & AMCH1,AMCH1N,AMCH2,IREJ1) |
| 7401 | IF (IREJ1.NE.0) GOTO 10 |
| 7402 | * check second chain for resonance |
| 7403 | IDCHAI = 2 |
| 7404 | IF ((IF(K2,2).NE.0).AND.(IF(K2+1,2).NE.0)) IDCHAI = 3 |
| 7405 | CALL DT_CH2RES(IF(K2,1),IF(K2,2),IF(K2+1,1),IF(K2+1,2), |
| 7406 | & IDR2,IDXR2,AMCH2,AMCH2N,IDCHAI,IREJ1) |
| 7407 | IF (IREJ1.NE.0) GOTO 10 |
| 7408 | IF (IDR2.NE.0) IDR2 = 100*IDR2 |
| 7409 | * add partons and chains to DTEVT1 |
| 7410 | DO 5 K=1,4 |
| 7411 | PCH1(K) = PP1(K)+PT1(K) |
| 7412 | PCH2(K) = PP2(K)+PT2(K) |
| 7413 | 5 CONTINUE |
| 7414 | CALL DT_EVTPUT(ISTHKK(N1),IDHKK(N1),N1,0,PP1(1),PP1(2), |
| 7415 | & PP1(3),PP1(4),0,0,0) |
| 7416 | CALL DT_EVTPUT(ISTHKK(N1+1),IDHKK(N1+1),N1+1,0,PT1(1), |
| 7417 | & PT1(2),PT1(3),PT1(4),0,0,0) |
| 7418 | KCH = ISTHKK(N1+2)+100 |
| 7419 | CALL DT_EVTPUT(KCH,88888,-2,-1,PCH1(1),PCH1(2),PCH1(3), |
| 7420 | & PCH1(4),IDR1,IDXR1,IDCH(N1+2)) |
| 7421 | IDHKK(N1+2) = 22222 |
| 7422 | CALL DT_EVTPUT(ISTHKK(N2),IDHKK(N2),N2,0,PP2(1),PP2(2), |
| 7423 | & PP2(3),PP2(4),0,0,0) |
| 7424 | CALL DT_EVTPUT(ISTHKK(N2+1),IDHKK(N2+1),N2+1,0,PT2(1), |
| 7425 | & PT2(2),PT2(3),PT2(4),0,0,0) |
| 7426 | KCH = ISTHKK(N2+2)+100 |
| 7427 | CALL DT_EVTPUT(KCH,88888,-2,-1,PCH2(1),PCH2(2),PCH2(3), |
| 7428 | & PCH2(4),IDR2,IDXR2,IDCH(N2+2)) |
| 7429 | IDHKK(N2+2) = 22222 |
| 7430 | ENDIF |
| 7431 | ENDIF |
| 7432 | ELSE |
| 7433 | GOTO 11 |
| 7434 | ENDIF |
| 7435 | 10 CONTINUE |
| 7436 | NC = NC+6 |
| 7437 | GOTO 2 |
| 7438 | |
| 7439 | 11 CONTINUE |
| 7440 | |
| 7441 | RETURN |
| 7442 | END |
| 7443 | |
| 7444 | *$ CREATE DT_PHNSCH.FOR |
| 7445 | *COPY DT_PHNSCH |
| 7446 | * |
| 7447 | *=== phnsch ===========================================================* |
| 7448 | * |
| 7449 | DOUBLE PRECISION FUNCTION DT_PHNSCH( KP, KTARG, PLAB ) |
| 7450 | |
| 7451 | *----------------------------------------------------------------------* |
| 7452 | * * |
| 7453 | * Probability for Hadron Nucleon Single CHain interactions: * |
| 7454 | * * |
| 7455 | * Created on 30 december 1993 by Alfredo Ferrari & Paola Sala * |
| 7456 | * Infn - Milan * |
| 7457 | * * |
| 7458 | * Last change on 04-jan-94 by Alfredo Ferrari * |
| 7459 | * * |
| 7460 | * modified by J.R.for use in DTUNUC 6.1.94 * |
| 7461 | * * |
| 7462 | * Input variables: * |
| 7463 | * Kp = hadron projectile index (Part numbering * |
| 7464 | * scheme) * |
| 7465 | * Ktarg = target nucleon index (1=proton, 8=neutron) * |
| 7466 | * Plab = projectile laboratory momentum (GeV/c) * |
| 7467 | * Output variable: * |
| 7468 | * Phnsch = probability per single chain (particle * |
| 7469 | * exchange) interactions * |
| 7470 | * * |
| 7471 | *----------------------------------------------------------------------* |
| 7472 | |
| 7473 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 7474 | SAVE |
| 7475 | |
| 7476 | PARAMETER ( LUNOUT = 6 ) |
| 7477 | PARAMETER ( LUNERR = 6 ) |
| 7478 | PARAMETER ( ONEPLS = 1.000000000000001 D+00 ) |
| 7479 | PARAMETER ( ZERZER = 0.D+00 ) |
| 7480 | PARAMETER ( ONEONE = 1.D+00 ) |
| 7481 | PARAMETER ( TWOTWO = 2.D+00 ) |
| 7482 | PARAMETER ( FIVFIV = 5.D+00 ) |
| 7483 | PARAMETER ( HLFHLF = 0.5D+00 ) |
| 7484 | |
| 7485 | PARAMETER ( NALLWP = 39 ) |
| 7486 | PARAMETER ( IDMAXP = 210 ) |
| 7487 | |
| 7488 | DIMENSION ICHRGE(39),AM(39) |
| 7489 | |
| 7490 | * particle properties (BAMJET index convention) |
| 7491 | CHARACTER*8 ANAME |
| 7492 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 7493 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 7494 | |
| 7495 | DIMENSION KPTOIP(210) |
| 7496 | * auxiliary common for reggeon exchange (DTUNUC 1.x) |
| 7497 | COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6), |
| 7498 | & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6), |
| 7499 | & IQTCHR(-6:6),MQUARK(3,39) |
| 7500 | |
| 7501 | DIMENSION SGTCOE (5,33), IHLP (NALLWP) |
| 7502 | DIMENSION SGTCO1(5,10),SGTCO2(5,8),SGTCO3(5,15) |
| 454792a9 |
7503 | CPH SAVE SGTCOE, IHLP |
| 7504 | CPH SAVE IQFSC1, IQFSC2, IQBSC1, IQBSC2 |
| 9aaba0d6 |
7505 | EQUIVALENCE (SGTCO1(1,1),SGTCOE(1,1)) |
| 7506 | EQUIVALENCE (SGTCO2(1,1),SGTCOE(1,11)) |
| 7507 | EQUIVALENCE (SGTCO3(1,1),SGTCOE(1,19)) |
| 7508 | |
| 7509 | * Conversion from part to paprop numbering |
| 7510 | DATA KPTOIP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, |
| 7511 | & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 66*0, |
| 7512 | & 34, 36, 31, 32, 33, 35, 37, 5*0, 38, 5*0, 39, 19*0, 27, 28, 74*0/ |
| 7513 | |
| 7514 | * 1=baryon, 2=pion, 3=kaon, 4=antibaryon: |
| 7515 | DATA IHLP/1,4,5*0,1,4,2*0,3,2*2,2*3,1,4,3,3*1,2, |
| 7516 | & 2*3, 2, 4*0, 3*4, 1, 4, 1, 4, 1, 4 / |
| 7517 | C DATA ( ( SGTCOE (J,I), J=1,5 ), I=1,10 ) / |
| 7518 | DATA SGTCO1 / |
| 7519 | * 1st reaction: gamma p total |
| 7520 | &0.147 D+00, ZERZER , ZERZER , 0.0022D+00, -0.0170D+00, |
| 7521 | * 2nd reaction: gamma d total |
| 7522 | &0.300 D+00, ZERZER , ZERZER , 0.0095D+00, -0.057 D+00, |
| 7523 | * 3rd reaction: pi+ p total |
| 7524 | &16.4 D+00, 19.3D+00, -0.42D+00, 0.19 D+00, ZERZER , |
| 7525 | * 4th reaction: pi- p total |
| 7526 | &33.0 D+00, 14.0D+00, -1.36D+00, 0.456 D+00, -4.03 D+00, |
| 7527 | * 5th reaction: pi+/- d total |
| 7528 | &56.8 D+00, 42.2D+00, -1.45D+00, 0.65 D+00, -5.39 D+00, |
| 7529 | * 6th reaction: K+ p total |
| 7530 | &18.1 D+00, ZERZER , ZERZER , 0.26 D+00, -1.0 D+00, |
| 7531 | * 7th reaction: K+ n total |
| 7532 | &18.7 D+00, ZERZER , ZERZER , 0.21 D+00, -0.89 D+00, |
| 7533 | * 8th reaction: K+ d total |
| 7534 | &34.2 D+00, 7.9 D+00, -2.1 D+00, 0.346 D+00, -0.99 D+00, |
| 7535 | * 9th reaction: K- p total |
| 7536 | &32.1 D+00, ZERZER , ZERZER , 0.66 D+00, -5.6 D+00, |
| 7537 | * 10th reaction: K- n total |
| 7538 | &25.2 D+00, ZERZER , ZERZER , 0.38 D+00, -2.9 D+00/ |
| 7539 | C DATA ( ( SGTCOE (J,I), J=1,5 ), I=11,18 ) / |
| 7540 | DATA SGTCO2 / |
| 7541 | * 11th reaction: K- d total |
| 7542 | &57.6 D+00, ZERZER , ZERZER , 1.17 D+00, -9.5 D+00, |
| 7543 | * 12th reaction: p p total |
| 7544 | &48.0 D+00, ZERZER , ZERZER , 0.522 D+00, -4.51 D+00, |
| 7545 | * 13th reaction: p n total |
| 7546 | &47.30 D+00, ZERZER , ZERZER , 0.513 D+00, -4.27 D+00, |
| 7547 | * 14th reaction: p d total |
| 7548 | &91.3 D+00, ZERZER , ZERZER , 1.05 D+00, -8.8 D+00, |
| 7549 | * 15th reaction: pbar p total |
| 7550 | &38.4 D+00, 77.6D+00, -0.64D+00, 0.26 D+00, -1.2 D+00, |
| 7551 | * 16th reaction: pbar n total |
| 7552 | &ZERZER ,133.6D+00, -0.70D+00, -1.22 D+00, 13.7 D+00, |
| 7553 | * 17th reaction: pbar d total |
| 7554 | &112. D+00, 125.D+00, -1.08D+00, 1.14 D+00, -12.4 D+00, |
| 7555 | * 18th reaction: Lamda p total |
| 7556 | &30.4 D+00, ZERZER , ZERZER , ZERZER , 1.6 D+00/ |
| 7557 | C DATA ( ( SGTCOE (J,I), J=1,5 ), I=19,33 ) / |
| 7558 | DATA SGTCO3 / |
| 7559 | * 19th reaction: pi+ p elastic |
| 7560 | &ZERZER , 11.4D+00, -0.4 D+00, 0.079 D+00, ZERZER , |
| 7561 | * 20th reaction: pi- p elastic |
| 7562 | &1.76 D+00, 11.2D+00, -0.64D+00, 0.043 D+00, ZERZER , |
| 7563 | * 21st reaction: K+ p elastic |
| 7564 | &5.0 D+00, 8.1 D+00, -1.8 D+00, 0.16 D+00, -1.3 D+00, |
| 7565 | * 22nd reaction: K- p elastic |
| 7566 | &7.3 D+00, ZERZER , ZERZER , 0.29 D+00, -2.40 D+00, |
| 7567 | * 23rd reaction: p p elastic |
| 7568 | &11.9 D+00, 26.9D+00, -1.21D+00, 0.169 D+00, -1.85 D+00, |
| 7569 | * 24th reaction: p d elastic |
| 7570 | &16.1 D+00, ZERZER , ZERZER , 0.32 D+00, -3.4 D+00, |
| 7571 | * 25th reaction: pbar p elastic |
| 7572 | &10.2 D+00, 52.7D+00, -1.16D+00, 0.125 D+00, -1.28 D+00, |
| 7573 | * 26th reaction: pbar p elastic bis |
| 7574 | &10.6 D+00, 53.1D+00, -1.19D+00, 0.136 D+00, -1.41 D+00, |
| 7575 | * 27th reaction: pbar n elastic |
| 7576 | &36.5 D+00, ZERZER , ZERZER , ZERZER , -11.9 D+00, |
| 7577 | * 28th reaction: Lamda p elastic |
| 7578 | &12.3 D+00, ZERZER , ZERZER , ZERZER , -2.4 D+00, |
| 7579 | * 29th reaction: K- p ela bis |
| 7580 | &7.24 D+00, 46.0D+00, -4.71D+00, 0.279 D+00, -2.35 D+00, |
| 7581 | * 30th reaction: pi- p cx |
| 7582 | &ZERZER ,0.912D+00, -1.22D+00, ZERZER , ZERZER , |
| 7583 | * 31st reaction: K- p cx |
| 7584 | &ZERZER , 3.39D+00, -1.75D+00, ZERZER , ZERZER , |
| 7585 | * 32nd reaction: K+ n cx |
| 7586 | &ZERZER , 7.18D+00, -2.01D+00, ZERZER , ZERZER , |
| 7587 | * 33rd reaction: pbar p cx |
| 7588 | &ZERZER , 18.8D+00, -2.01D+00, ZERZER , ZERZER / |
| 7589 | * |
| 7590 | * +-------------------------------------------------------------------* |
| 7591 | ICHRGE(KTARG)=IICH(KTARG) |
| 7592 | AM (KTARG)=AAM (KTARG) |
| 7593 | * | Check for pi0 (d-dbar) |
| 7594 | IF ( KP .NE. 26 ) THEN |
| 7595 | IP = KPTOIP (KP) |
| 7596 | IF(IP.EQ.0)IP=1 |
| 7597 | ICHRGE(IP)=IICH(KP) |
| 7598 | AM (IP)=AAM (KP) |
| 7599 | * | |
| 7600 | * +-------------------------------------------------------------------* |
| 7601 | * | |
| 7602 | ELSE |
| 7603 | IP = 23 |
| 7604 | ICHRGE(IP)=0 |
| 7605 | END IF |
| 7606 | * | |
| 7607 | * +-------------------------------------------------------------------* |
| 7608 | * +-------------------------------------------------------------------* |
| 7609 | * | No such interactions for baryon-baryon |
| 7610 | IF ( IIBAR (KP) .GT. 0 ) THEN |
| 7611 | DT_PHNSCH = ZERZER |
| 7612 | RETURN |
| 7613 | * | |
| 7614 | * +-------------------------------------------------------------------* |
| 7615 | * | No "annihilation" diagram possible for K+ p/n |
| 7616 | ELSE IF ( IP .EQ. 15 ) THEN |
| 7617 | DT_PHNSCH = ZERZER |
| 7618 | RETURN |
| 7619 | * | |
| 7620 | * +-------------------------------------------------------------------* |
| 7621 | * | No "annihilation" diagram possible for K0 p/n |
| 7622 | ELSE IF ( IP .EQ. 24 ) THEN |
| 7623 | DT_PHNSCH = ZERZER |
| 7624 | RETURN |
| 7625 | * | |
| 7626 | * +-------------------------------------------------------------------* |
| 7627 | * | No "annihilation" diagram possible for Omebar p/n |
| 7628 | ELSE IF ( IP .GE. 38 ) THEN |
| 7629 | DT_PHNSCH = ZERZER |
| 7630 | RETURN |
| 7631 | END IF |
| 7632 | * | |
| 7633 | * +-------------------------------------------------------------------* |
| 7634 | * +-------------------------------------------------------------------* |
| 7635 | * | If the momentum is larger than 50 GeV/c, compute the single |
| 7636 | * | chain probability at 50 GeV/c and extrapolate to the present |
| 7637 | * | momentum according to 1/sqrt(s) |
| 7638 | * | sigma = sigma_sch (50) * sqrt (s(50)/s) + sigma_dch |
| 7639 | * | P_sch (50) = sigma_sch (50) / ( sigma_dch + sigma_sch (50) ) |
| 7640 | * | sigma_dch / sigma_sch (50) = 1 / P_sch (50) - 1 |
| 7641 | * | sigma_dch / sigma_sch = 1 / P_sch - 1 = ( 1 / P_sch (50) - 1 ) |
| 7642 | * | x sqrt(s/s(50)) |
| 7643 | * | P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ] |
| 7644 | IF ( PLAB .GT. 50.D+00 ) THEN |
| 7645 | PLA = 50.D+00 |
| 7646 | AMPSQ = AM (IP)**2 |
| 7647 | AMTSQ = AM (KTARG)**2 |
| 7648 | EPROJ = SQRT ( PLAB**2 + AMPSQ ) |
| 7649 | UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ |
| 7650 | EPROJ = SQRT ( PLA**2 + AMPSQ ) |
| 7651 | UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ |
| 7652 | UMORAT = SQRT ( UMOSQ / UMO50 ) |
| 7653 | * | |
| 7654 | * +-------------------------------------------------------------------* |
| 7655 | * | P < 3 GeV/c |
| 7656 | ELSE IF ( PLAB .LT. 3.D+00 ) THEN |
| 7657 | PLA = 3.D+00 |
| 7658 | AMPSQ = AM (IP)**2 |
| 7659 | AMTSQ = AM (KTARG)**2 |
| 7660 | EPROJ = SQRT ( PLAB**2 + AMPSQ ) |
| 7661 | UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ |
| 7662 | EPROJ = SQRT ( PLA**2 + AMPSQ ) |
| 7663 | UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ |
| 7664 | UMORAT = SQRT ( UMOSQ / UMO50 ) |
| 7665 | * | |
| 7666 | * +-------------------------------------------------------------------* |
| 7667 | * | P < 50 GeV/c |
| 7668 | ELSE |
| 7669 | PLA = PLAB |
| 7670 | UMORAT = ONEONE |
| 7671 | END IF |
| 7672 | * | |
| 7673 | * +-------------------------------------------------------------------* |
| 7674 | ALGPLA = LOG (PLA) |
| 7675 | * +-------------------------------------------------------------------* |
| 7676 | * | Pions: |
| 7677 | IF ( IHLP (IP) .EQ. 2 ) THEN |
| 7678 | ACOF = SGTCOE (1,3) |
| 7679 | BCOF = SGTCOE (2,3) |
| 7680 | ENNE = SGTCOE (3,3) |
| 7681 | CCOF = SGTCOE (4,3) |
| 7682 | DCOF = SGTCOE (5,3) |
| 7683 | * | Compute the pi+ p total cross section: |
| 7684 | SPPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 |
| 7685 | & + DCOF * ALGPLA |
| 7686 | ACOF = SGTCOE (1,19) |
| 7687 | BCOF = SGTCOE (2,19) |
| 7688 | ENNE = SGTCOE (3,19) |
| 7689 | CCOF = SGTCOE (4,19) |
| 7690 | DCOF = SGTCOE (5,19) |
| 7691 | * | Compute the pi+ p elastic cross section: |
| 7692 | SPPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 |
| 7693 | & + DCOF * ALGPLA |
| 7694 | * | Compute the pi+ p inelastic cross section: |
| 7695 | SPPPIN = SPPPTT - SPPPEL |
| 7696 | ACOF = SGTCOE (1,4) |
| 7697 | BCOF = SGTCOE (2,4) |
| 7698 | ENNE = SGTCOE (3,4) |
| 7699 | CCOF = SGTCOE (4,4) |
| 7700 | DCOF = SGTCOE (5,4) |
| 7701 | * | Compute the pi- p total cross section: |
| 7702 | SPMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 |
| 7703 | & + DCOF * ALGPLA |
| 7704 | ACOF = SGTCOE (1,20) |
| 7705 | BCOF = SGTCOE (2,20) |
| 7706 | ENNE = SGTCOE (3,20) |
| 7707 | CCOF = SGTCOE (4,20) |
| 7708 | DCOF = SGTCOE (5,20) |
| 7709 | * | Compute the pi- p elastic cross section: |
| 7710 | SPMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 |
| 7711 | & + DCOF * ALGPLA |
| 7712 | * | Compute the pi- p inelastic cross section: |
| 7713 | SPMPIN = SPMPTT - SPMPEL |
| 7714 | SIGDIA = SPMPIN - SPPPIN |
| 7715 | * | +----------------------------------------------------------------* |
| 7716 | * | | Charged pions: besides isospin consideration it is supposed |
| 7717 | * | | that (pi+ n)el is almost equal to (pi- p)el |
| 7718 | * | | and (pi+ p)el " " " " (pi- n)el |
| 7719 | * | | and all are almost equal among each others |
| 7720 | * | | (reasonable above 5 GeV/c) |
| 7721 | IF ( ICHRGE (IP) .NE. 0 ) THEN |
| 7722 | KHELP = KTARG / 8 |
| 7723 | JREAC = 3 + IP - 13 + ICHRGE (IP) * KHELP |
| 7724 | ACOF = SGTCOE (1,JREAC) |
| 7725 | BCOF = SGTCOE (2,JREAC) |
| 7726 | ENNE = SGTCOE (3,JREAC) |
| 7727 | CCOF = SGTCOE (4,JREAC) |
| 7728 | DCOF = SGTCOE (5,JREAC) |
| 7729 | * | | Compute the total cross section: |
| 7730 | SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 |
| 7731 | & + DCOF * ALGPLA |
| 7732 | JREAC = 19 + IP - 13 + ICHRGE (IP) * KHELP |
| 7733 | ACOF = SGTCOE (1,JREAC) |
| 7734 | BCOF = SGTCOE (2,JREAC) |
| 7735 | ENNE = SGTCOE (3,JREAC) |
| 7736 | CCOF = SGTCOE (4,JREAC) |
| 7737 | DCOF = SGTCOE (5,JREAC) |
| 7738 | * | | Compute the elastic cross section: |
| 7739 | SHNCEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 |
| 7740 | & + DCOF * ALGPLA |
| 7741 | * | | Compute the inelastic cross section: |
| 7742 | SHNCIN = SHNCTT - SHNCEL |
| 7743 | * | | Number of diagrams: |
| 7744 | NDIAGR = 1 + IP - 13 + ICHRGE (IP) * KHELP |
| 7745 | * | | Now compute the chain end (anti)quark-(anti)diquark |
| 7746 | IQFSC1 = 1 + IP - 13 |
| 7747 | IQFSC2 = 0 |
| 7748 | IQBSC1 = 1 + KHELP |
| 7749 | IQBSC2 = 1 + IP - 13 |
| 7750 | * | | |
| 7751 | * | +----------------------------------------------------------------* |
| 7752 | * | | pi0: besides isospin consideration it is supposed that the |
| 7753 | * | | elastic cross section is not very different from |
| 7754 | * | | pi+ p and/or pi- p (reasonable above 5 GeV/c) |
| 7755 | ELSE |
| 7756 | KHELP = KTARG / 8 |
| 7757 | K2HLP = ( KP - 23 ) / 3 |
| 7758 | * | | Number of diagrams: |
| 7759 | * | | For u ubar (k2hlp=0): |
| 7760 | * NDIAGR = 2 - KHELP |
| 7761 | * | | For d dbar (k2hlp=1): |
| 7762 | * NDIAGR = 2 + KHELP - K2HLP |
| 7763 | NDIAGR = 2 + KHELP * ( 2 * K2HLP - 1 ) - K2HLP |
| 7764 | SHNCIN = HLFHLF * ( SPPPIN + SPMPIN ) |
| 7765 | * | | Now compute the chain end (anti)quark-(anti)diquark |
| 7766 | IQFSC1 = 1 + K2HLP |
| 7767 | IQFSC2 = 0 |
| 7768 | IQBSC1 = 1 + KHELP |
| 7769 | IQBSC2 = 2 - K2HLP |
| 7770 | END IF |
| 7771 | * | | |
| 7772 | * | +----------------------------------------------------------------* |
| 7773 | * | end pi's |
| 7774 | * +-------------------------------------------------------------------* |
| 7775 | * | Kaons: |
| 7776 | ELSE IF ( IHLP (IP) .EQ. 3 ) THEN |
| 7777 | ACOF = SGTCOE (1,6) |
| 7778 | BCOF = SGTCOE (2,6) |
| 7779 | ENNE = SGTCOE (3,6) |
| 7780 | CCOF = SGTCOE (4,6) |
| 7781 | DCOF = SGTCOE (5,6) |
| 7782 | * | Compute the K+ p total cross section: |
| 7783 | SKPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 |
| 7784 | & + DCOF * ALGPLA |
| 7785 | ACOF = SGTCOE (1,21) |
| 7786 | BCOF = SGTCOE (2,21) |
| 7787 | ENNE = SGTCOE (3,21) |
| 7788 | CCOF = SGTCOE (4,21) |
| 7789 | DCOF = SGTCOE (5,21) |
| 7790 | * | Compute the K+ p elastic cross section: |
| 7791 | SKPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 |
| 7792 | & + DCOF * ALGPLA |
| 7793 | * | Compute the K+ p inelastic cross section: |
| 7794 | SKPPIN = SKPPTT - SKPPEL |
| 7795 | ACOF = SGTCOE (1,9) |
| 7796 | BCOF = SGTCOE (2,9) |
| 7797 | ENNE = SGTCOE (3,9) |
| 7798 | CCOF = SGTCOE (4,9) |
| 7799 | DCOF = SGTCOE (5,9) |
| 7800 | * | Compute the K- p total cross section: |
| 7801 | SKMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 |
| 7802 | & + DCOF * ALGPLA |
| 7803 | ACOF = SGTCOE (1,22) |
| 7804 | BCOF = SGTCOE (2,22) |
| 7805 | ENNE = SGTCOE (3,22) |
| 7806 | CCOF = SGTCOE (4,22) |
| 7807 | DCOF = SGTCOE (5,22) |
| 7808 | * | Compute the K- p elastic cross section: |
| 7809 | SKMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 |
| 7810 | & + DCOF * ALGPLA |
| 7811 | * | Compute the K- p inelastic cross section: |
| 7812 | SKMPIN = SKMPTT - SKMPEL |
| 7813 | SIGDIA = HLFHLF * ( SKMPIN - SKPPIN ) |
| 7814 | * | +----------------------------------------------------------------* |
| 7815 | * | | Charged Kaons: actually only K- |
| 7816 | IF ( ICHRGE (IP) .NE. 0 ) THEN |
| 7817 | KHELP = KTARG / 8 |
| 7818 | * | | +-------------------------------------------------------------* |
| 7819 | * | | | Proton target: |
| 7820 | IF ( KHELP .EQ. 0 ) THEN |
| 7821 | SHNCIN = SKMPIN |
| 7822 | * | | | Number of diagrams: |
| 7823 | NDIAGR = 2 |
| 7824 | * | | | |
| 7825 | * | | +-------------------------------------------------------------* |
| 7826 | * | | | Neutron target: besides isospin consideration it is supposed |
| 7827 | * | | | that (K- n)el is almost equal to (K- p)el |
| 7828 | * | | | (reasonable above 5 GeV/c) |
| 7829 | ELSE |
| 7830 | ACOF = SGTCOE (1,10) |
| 7831 | BCOF = SGTCOE (2,10) |
| 7832 | ENNE = SGTCOE (3,10) |
| 7833 | CCOF = SGTCOE (4,10) |
| 7834 | DCOF = SGTCOE (5,10) |
| 7835 | * | | | Compute the total cross section: |
| 7836 | SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 |
| 7837 | & + DCOF * ALGPLA |
| 7838 | * | | | Compute the elastic cross section: |
| 7839 | SHNCEL = SKMPEL |
| 7840 | * | | | Compute the inelastic cross section: |
| 7841 | SHNCIN = SHNCTT - SHNCEL |
| 7842 | * | | | Number of diagrams: |
| 7843 | NDIAGR = 1 |
| 7844 | END IF |
| 7845 | * | | | |
| 7846 | * | | +-------------------------------------------------------------* |
| 7847 | * | | Now compute the chain end (anti)quark-(anti)diquark |
| 7848 | IQFSC1 = 3 |
| 7849 | IQFSC2 = 0 |
| 7850 | IQBSC1 = 1 + KHELP |
| 7851 | IQBSC2 = 2 |
| 7852 | * | | |
| 7853 | * | +----------------------------------------------------------------* |
| 7854 | * | | K0's: (actually only K0bar) |
| 7855 | ELSE |
| 7856 | KHELP = KTARG / 8 |
| 7857 | * | | +-------------------------------------------------------------* |
| 7858 | * | | | Proton target: (K0bar p)in supposed to be given by |
| 7859 | * | | | (K- p)in - Sig_diagr |
| 7860 | IF ( KHELP .EQ. 0 ) THEN |
| 7861 | SHNCIN = SKMPIN - SIGDIA |
| 7862 | * | | | Number of diagrams: |
| 7863 | NDIAGR = 1 |
| 7864 | * | | | |
| 7865 | * | | +-------------------------------------------------------------* |
| 7866 | * | | | Neutron target: (K0bar n)in supposed to be given by |
| 7867 | * | | | (K- n)in + Sig_diagr |
| 7868 | * | | | besides isospin consideration it is supposed |
| 7869 | * | | | that (K- n)el is almost equal to (K- p)el |
| 7870 | * | | | (reasonable above 5 GeV/c) |
| 7871 | ELSE |
| 7872 | ACOF = SGTCOE (1,10) |
| 7873 | BCOF = SGTCOE (2,10) |
| 7874 | ENNE = SGTCOE (3,10) |
| 7875 | CCOF = SGTCOE (4,10) |
| 7876 | DCOF = SGTCOE (5,10) |
| 7877 | * | | | Compute the total cross section: |
| 7878 | SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 |
| 7879 | & + DCOF * ALGPLA |
| 7880 | * | | | Compute the elastic cross section: |
| 7881 | SHNCEL = SKMPEL |
| 7882 | * | | | Compute the inelastic cross section: |
| 7883 | SHNCIN = SHNCTT - SHNCEL + SIGDIA |
| 7884 | * | | | Number of diagrams: |
| 7885 | NDIAGR = 2 |
| 7886 | END IF |
| 7887 | * | | | |
| 7888 | * | | +-------------------------------------------------------------* |
| 7889 | * | | Now compute the chain end (anti)quark-(anti)diquark |
| 7890 | IQFSC1 = 3 |
| 7891 | IQFSC2 = 0 |
| 7892 | IQBSC1 = 1 |
| 7893 | IQBSC2 = 1 + KHELP |
| 7894 | END IF |
| 7895 | * | | |
| 7896 | * | +----------------------------------------------------------------* |
| 7897 | * | end Kaon's |
| 7898 | * +-------------------------------------------------------------------* |
| 7899 | * | Antinucleons: |
| 7900 | ELSE IF ( IHLP (IP) .EQ. 4 .AND. IP .LE. 9 ) THEN |
| 7901 | * | For momenta between 3 and 5 GeV/c the use of tabulated data |
| 7902 | * | should be implemented! |
| 7903 | ACOF = SGTCOE (1,15) |
| 7904 | BCOF = SGTCOE (2,15) |
| 7905 | ENNE = SGTCOE (3,15) |
| 7906 | CCOF = SGTCOE (4,15) |
| 7907 | DCOF = SGTCOE (5,15) |
| 7908 | * | Compute the pbar p total cross section: |
| 7909 | SAPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 |
| 7910 | & + DCOF * ALGPLA |
| 7911 | IF ( PLA .LT. FIVFIV ) THEN |
| 7912 | JREAC = 26 |
| 7913 | ELSE |
| 7914 | JREAC = 25 |
| 7915 | END IF |
| 7916 | ACOF = SGTCOE (1,JREAC) |
| 7917 | BCOF = SGTCOE (2,JREAC) |
| 7918 | ENNE = SGTCOE (3,JREAC) |
| 7919 | CCOF = SGTCOE (4,JREAC) |
| 7920 | DCOF = SGTCOE (5,JREAC) |
| 7921 | * | Compute the pbar p elastic cross section: |
| 7922 | SAPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 |
| 7923 | & + DCOF * ALGPLA |
| 7924 | * | Compute the pbar p inelastic cross section: |
| 7925 | SAPPIN = SAPPTT - SAPPEL |
| 7926 | ACOF = SGTCOE (1,12) |
| 7927 | BCOF = SGTCOE (2,12) |
| 7928 | ENNE = SGTCOE (3,12) |
| 7929 | CCOF = SGTCOE (4,12) |
| 7930 | DCOF = SGTCOE (5,12) |
| 7931 | * | Compute the p p total cross section: |
| 7932 | SPPTOT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 |
| 7933 | & + DCOF * ALGPLA |
| 7934 | ACOF = SGTCOE (1,23) |
| 7935 | BCOF = SGTCOE (2,23) |
| 7936 | ENNE = SGTCOE (3,23) |
| 7937 | CCOF = SGTCOE (4,23) |
| 7938 | DCOF = SGTCOE (5,23) |
| 7939 | * | Compute the p p elastic cross section: |
| 7940 | SPPELA = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 |
| 7941 | & + DCOF * ALGPLA |
| 7942 | * | Compute the K- p inelastic cross section: |
| 7943 | SPPINE = SPPTOT - SPPELA |
| 7944 | SIGDIA = ( SAPPIN - SPPINE ) / FIVFIV |
| 7945 | KHELP = KTARG / 8 |
| 7946 | * | +----------------------------------------------------------------* |
| 7947 | * | | Pbar: |
| 7948 | IF ( ICHRGE (IP) .NE. 0 ) THEN |
| 7949 | NDIAGR = 5 - KHELP |
| 7950 | * | | +-------------------------------------------------------------* |
| 7951 | * | | | Proton target: |
| 7952 | IF ( KHELP .EQ. 0 ) THEN |
| 7953 | * | | | Number of diagrams: |
| 7954 | SHNCIN = SAPPIN |
| 7955 | PUUBAR = 0.8D+00 |
| 7956 | * | | | |
| 7957 | * | | +-------------------------------------------------------------* |
| 7958 | * | | | Neutron target: it is supposed that (ap n)el is almost equal |
| 7959 | * | | | to (ap p)el (reasonable above 5 GeV/c) |
| 7960 | ELSE |
| 7961 | ACOF = SGTCOE (1,16) |
| 7962 | BCOF = SGTCOE (2,16) |
| 7963 | ENNE = SGTCOE (3,16) |
| 7964 | CCOF = SGTCOE (4,16) |
| 7965 | DCOF = SGTCOE (5,16) |
| 7966 | * | | | Compute the total cross section: |
| 7967 | SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 |
| 7968 | & + DCOF * ALGPLA |
| 7969 | * | | | Compute the elastic cross section: |
| 7970 | SHNCEL = SAPPEL |
| 7971 | * | | | Compute the inelastic cross section: |
| 7972 | SHNCIN = SHNCTT - SHNCEL |
| 7973 | PUUBAR = HLFHLF |
| 7974 | END IF |
| 7975 | * | | | |
| 7976 | * | | +-------------------------------------------------------------* |
| 7977 | * | | Now compute the chain end (anti)quark-(anti)diquark |
| 7978 | * | | there are different possibilities, make a random choiche: |
| 7979 | IQFSC1 = -1 |
| 7980 | RNCHEN = DT_RNDM(PUUBAR) |
| 7981 | IF ( RNCHEN .LT. PUUBAR ) THEN |
| 7982 | IQFSC2 = -2 |
| 7983 | ELSE |
| 7984 | IQFSC2 = -1 |
| 7985 | END IF |
| 7986 | IQBSC1 = -IQFSC1 + KHELP |
| 7987 | IQBSC2 = -IQFSC2 |
| 7988 | * | | |
| 7989 | * | +----------------------------------------------------------------* |
| 7990 | * | | nbar: |
| 7991 | ELSE |
| 7992 | NDIAGR = 4 + KHELP |
| 7993 | * | | +-------------------------------------------------------------* |
| 7994 | * | | | Proton target: (nbar p)in supposed to be given by |
| 7995 | * | | | (pbar p)in - Sig_diagr |
| 7996 | IF ( KHELP .EQ. 0 ) THEN |
| 7997 | SHNCIN = SAPPIN - SIGDIA |
| 7998 | PDDBAR = HLFHLF |
| 7999 | * | | | |
| 8000 | * | | +-------------------------------------------------------------* |
| 8001 | * | | | Neutron target: (nbar n)el is supposed to be equal to |
| 8002 | * | | | (pbar p)el (reasonable above 5 GeV/c) |
| 8003 | ELSE |
| 8004 | * | | | Compute the total cross section: |
| 8005 | SHNCTT = SAPPTT |
| 8006 | * | | | Compute the elastic cross section: |
| 8007 | SHNCEL = SAPPEL |
| 8008 | * | | | Compute the inelastic cross section: |
| 8009 | SHNCIN = SHNCTT - SHNCEL |
| 8010 | PDDBAR = 0.8D+00 |
| 8011 | END IF |
| 8012 | * | | | |
| 8013 | * | | +-------------------------------------------------------------* |
| 8014 | * | | Now compute the chain end (anti)quark-(anti)diquark |
| 8015 | * | | there are different possibilities, make a random choiche: |
| 8016 | IQFSC1 = -2 |
| 8017 | RNCHEN = DT_RNDM(RNCHEN) |
| 8018 | IF ( RNCHEN .LT. PDDBAR ) THEN |
| 8019 | IQFSC2 = -1 |
| 8020 | ELSE |
| 8021 | IQFSC2 = -2 |
| 8022 | END IF |
| 8023 | IQBSC1 = -IQFSC1 + KHELP - 1 |
| 8024 | IQBSC2 = -IQFSC2 |
| 8025 | END IF |
| 8026 | * | | |
| 8027 | * | +----------------------------------------------------------------* |
| 8028 | * | |
| 8029 | * +-------------------------------------------------------------------* |
| 8030 | * | Others: not yet implemented |
| 8031 | ELSE |
| 8032 | SIGDIA = ZERZER |
| 8033 | SHNCIN = ONEONE |
| 8034 | NDIAGR = 0 |
| 8035 | DT_PHNSCH = ZERZER |
| 8036 | RETURN |
| 8037 | END IF |
| 8038 | * | end others |
| 8039 | * +-------------------------------------------------------------------* |
| 8040 | DT_PHNSCH = NDIAGR * SIGDIA / SHNCIN |
| 8041 | IQECHC = IQECHR (IQFSC1) + IQECHR (IQFSC2) + IQECHR (IQBSC1) |
| 8042 | & + IQECHR (IQBSC2) |
| 8043 | IQBCHC = IQBCHR (IQFSC1) + IQBCHR (IQFSC2) + IQBCHR (IQBSC1) |
| 8044 | & + IQBCHR (IQBSC2) |
| 8045 | IQECHC = IQECHC / 3 |
| 8046 | IQBCHC = IQBCHC / 3 |
| 8047 | IQSCHC = IQSCHR (IQFSC1) + IQSCHR (IQFSC2) + IQSCHR (IQBSC1) |
| 8048 | & + IQSCHR (IQBSC2) |
| 8049 | IQSPRO = IQSCHR (MQUARK(1,IP)) + IQSCHR (MQUARK(2,IP)) |
| 8050 | & + IQSCHR (MQUARK(3,IP)) |
| 8051 | * +-------------------------------------------------------------------* |
| 8052 | * | Consistency check: |
| 8053 | IF ( DT_PHNSCH .LE. ZERZER .OR. DT_PHNSCH .GT. ONEONE ) THEN |
| 8054 | WRITE (LUNOUT,*)' *** Phnsch,kp,ktarg,pla', |
| 8055 | & DT_PHNSCH,KP,KTARG,PLA,' ****' |
| 8056 | WRITE (LUNERR,*)' *** Phnsch,kp,ktarg,pla', |
| 8057 | & DT_PHNSCH,KP,KTARG,PLA,' ****' |
| 8058 | DT_PHNSCH = MAX ( DT_PHNSCH, ZERZER ) |
| 8059 | DT_PHNSCH = MIN ( DT_PHNSCH, ONEONE ) |
| 8060 | END IF |
| 8061 | * | |
| 8062 | * +-------------------------------------------------------------------* |
| 8063 | * +-------------------------------------------------------------------* |
| 8064 | * | Consistency check: |
| 8065 | IF ( IQSPRO .NE. IQSCHC .OR. ICHRGE (IP) + ICHRGE (KTARG) |
| 8066 | & .NE. IQECHC .OR. IIBAR (KP) + IIBAR (KTARG) .NE. IQBCHC) THEN |
| 8067 | WRITE (LUNOUT,*) |
| 8068 | &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg', |
| 8069 | & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG |
| 8070 | WRITE (LUNERR,*) |
| 8071 | &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg', |
| 8072 | & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG |
| 8073 | END IF |
| 8074 | * | |
| 8075 | * +-------------------------------------------------------------------* |
| 8076 | * P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ] |
| 8077 | IF ( UMORAT .GT. ONEPLS ) |
| 8078 | & DT_PHNSCH = ONEONE / ( ( ONEONE / DT_PHNSCH |
| 8079 | & - ONEONE ) * UMORAT + ONEONE ) |
| 8080 | RETURN |
| 8081 | * |
| 8082 | ENTRY DT_SCHQUA ( JQFSC1, JQFSC2, JQBSC1, JQBSC2 ) |
| 8083 | DT_SCHQUA = ONEONE |
| 8084 | JQFSC1 = IQFSC1 |
| 8085 | JQFSC2 = IQFSC2 |
| 8086 | JQBSC1 = IQBSC1 |
| 8087 | JQBSC2 = IQBSC2 |
| 8088 | *=== End of function Phnsch ===========================================* |
| 8089 | RETURN |
| 8090 | END |
| 8091 | |
| 8092 | *$ CREATE DT_RESPT.FOR |
| 8093 | *COPY DT_RESPT |
| 8094 | * |
| 8095 | *===respt==============================================================* |
| 8096 | * |
| 8097 | SUBROUTINE DT_RESPT |
| 8098 | |
| 8099 | ************************************************************************ |
| 8100 | * Check DTEVT1 for two-resonance systems and sample intrinsic p_t. * |
| 8101 | * This version dated 18.01.95 is written by S. Roesler * |
| 8102 | ************************************************************************ |
| 8103 | |
| 8104 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 8105 | SAVE |
| 8106 | PARAMETER ( LINP = 10 , |
| 8107 | & LOUT = 6 , |
| 8108 | & LDAT = 9 ) |
| 8109 | PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3) |
| 8110 | |
| 8111 | * event history |
| 8112 | PARAMETER (NMXHKK=200000) |
| 8113 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 8114 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 8115 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 8116 | * extended event history |
| 8117 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 8118 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 8119 | & IHIST(2,NMXHKK) |
| 8120 | |
| 8121 | * get index of first chain |
| 8122 | DO 1 I=NPOINT(3),NHKK |
| 8123 | IF (IDHKK(I).EQ.88888) THEN |
| 8124 | NC = I |
| 8125 | GOTO 2 |
| 8126 | ENDIF |
| 8127 | 1 CONTINUE |
| 8128 | |
| 8129 | 2 CONTINUE |
| 8130 | IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)) THEN |
| 8131 | C WRITE(LOUT,*)NC,NC+3,IDRES(NC),IDRES(NC+3) |
| 8132 | * skip VV-,SS- systems |
| 8133 | IF ((IDCH(NC ).NE.1).AND.(IDCH(NC ).NE.8).AND. |
| 8134 | & (IDCH(NC+3).NE.1).AND.(IDCH(NC+3).NE.8)) THEN |
| 8135 | * check if both "chains" are resonances |
| 8136 | IF ((IDRES(NC).NE.0).AND.(IDRES(NC+3).NE.0)) THEN |
| 8137 | CALL DT_SAPTRE(NC,NC+3) |
| 8138 | ENDIF |
| 8139 | ENDIF |
| 8140 | ELSE |
| 8141 | GOTO 3 |
| 8142 | ENDIF |
| 8143 | NC = NC+6 |
| 8144 | GOTO 2 |
| 8145 | |
| 8146 | 3 CONTINUE |
| 8147 | |
| 8148 | RETURN |
| 8149 | END |
| 8150 | |
| 8151 | *$ CREATE DT_EVTRES.FOR |
| 8152 | *COPY DT_EVTRES |
| 8153 | * |
| 8154 | *===evtres=============================================================* |
| 8155 | * |
| 8156 | SUBROUTINE DT_EVTRES(IREJ) |
| 8157 | |
| 8158 | ************************************************************************ |
| 8159 | * This version dated 14.12.94 is written by S. Roesler * |
| 8160 | ************************************************************************ |
| 8161 | |
| 8162 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 8163 | SAVE |
| 8164 | PARAMETER ( LINP = 10 , |
| 8165 | & LOUT = 6 , |
| 8166 | & LDAT = 9 ) |
| 8167 | PARAMETER (TINY5=1.0D-5,TINY10=1.0D-10) |
| 8168 | |
| 8169 | * event history |
| 8170 | PARAMETER (NMXHKK=200000) |
| 8171 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 8172 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 8173 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 8174 | * extended event history |
| 8175 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 8176 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 8177 | & IHIST(2,NMXHKK) |
| 8178 | * flags for input different options |
| 8179 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 8180 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 8181 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 8182 | * particle properties (BAMJET index convention) |
| 8183 | CHARACTER*8 ANAME |
| 8184 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 8185 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 8186 | |
| 8187 | DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),IFP(2),IFT(2) |
| 8188 | |
| 8189 | IREJ = 0 |
| 8190 | |
| 8191 | DO 1 I=NPOINT(3),NHKK |
| 8192 | IF (ABS(IDRES(I)).GE.100) THEN |
| 8193 | AMMX = 0.0D0 |
| 8194 | DO 2 J=NPOINT(3),NHKK |
| 8195 | IF (IDHKK(J).EQ.88888) THEN |
| 8196 | IF (PHKK(5,J).GT.AMMX) THEN |
| 8197 | AMMX = PHKK(5,J) |
| 8198 | IMMX = J |
| 8199 | ENDIF |
| 8200 | ENDIF |
| 8201 | 2 CONTINUE |
| 8202 | IF (IDRES(IMMX).NE.0) THEN |
| 8203 | IF (IOULEV(3).GT.0) THEN |
| 8204 | WRITE(LOUT,'(1X,A)') |
| 8205 | & 'EVTRES: no chain for correc. found' |
| 8206 | C GOTO 6 |
| 8207 | GOTO 9999 |
| 8208 | ELSE |
| 8209 | GOTO 9999 |
| 8210 | ENDIF |
| 8211 | ENDIF |
| 8212 | IMO11 = JMOHKK(1,I) |
| 8213 | IMO12 = JMOHKK(2,I) |
| 8214 | IF (PHKK(3,IMO11).LT.0.0D0) THEN |
| 8215 | IMO11 = JMOHKK(2,I) |
| 8216 | IMO12 = JMOHKK(1,I) |
| 8217 | ENDIF |
| 8218 | IMO21 = JMOHKK(1,IMMX) |
| 8219 | IMO22 = JMOHKK(2,IMMX) |
| 8220 | IF (PHKK(3,IMO21).LT.0.0D0) THEN |
| 8221 | IMO21 = JMOHKK(2,IMMX) |
| 8222 | IMO22 = JMOHKK(1,IMMX) |
| 8223 | ENDIF |
| 8224 | AMCH1 = PHKK(5,I) |
| 8225 | AMCH1N = AAM(IDXRES(I)) |
| 8226 | |
| 8227 | IFPR1 = IDHKK(IMO11) |
| 8228 | IFPR2 = IDHKK(IMO21) |
| 8229 | IFTA1 = IDHKK(IMO12) |
| 8230 | IFTA2 = IDHKK(IMO22) |
| 8231 | DO 4 J=1,4 |
| 8232 | PP1(J) = PHKK(J,IMO11) |
| 8233 | PP2(J) = PHKK(J,IMO21) |
| 8234 | PT1(J) = PHKK(J,IMO12) |
| 8235 | PT2(J) = PHKK(J,IMO22) |
| 8236 | 4 CONTINUE |
| 8237 | * store initial configuration for energy-momentum cons. check |
| 8238 | IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IREJ1) |
| 8239 | * correct kinematics of second chain |
| 8240 | CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2, |
| 8241 | & AMCH1,AMCH1N,AMCH2,IREJ1) |
| 8242 | IF (IREJ1.NE.0) GOTO 9999 |
| 8243 | * check now this chain for resonance mass |
| 8244 | IFP(1) = IDT_IPDG2B(IFPR2,1,2) |
| 8245 | IFP(2) = 0 |
| 8246 | IF (ABS(IFPR2).GE.1000) IFP(2) = IDT_IPDG2B(IFPR2,2,2) |
| 8247 | IFT(1) = IDT_IPDG2B(IFTA2,1,2) |
| 8248 | IFT(2) = 0 |
| 8249 | IF (ABS(IFTA2).GE.1000) IFT(2) = IDT_IPDG2B(IFTA2,2,2) |
| 8250 | IDCH2 = 2 |
| 8251 | IF ((IFP(2).EQ.0).AND.(IFT(2).EQ.0)) IDCH2 = 1 |
| 8252 | IF ((IFP(2).NE.0).AND.(IFT(2).NE.0)) IDCH2 = 3 |
| 8253 | CALL DT_CH2RES(IFP(1),IFP(2),IFT(1),IFT(2),IDR2,IDXR2, |
| 8254 | & AMCH2,AMCH2N,IDCH2,IREJ1) |
| 8255 | IF ((IREJ1.NE.0).OR.(IDR2.NE.0)) THEN |
| 8256 | IF (IOULEV(1).GT.0) |
| 8257 | & WRITE(LOUT,*) ' correction for resonance not poss.' |
| 8258 | **sr test |
| 8259 | C GOTO 1 |
| 8260 | C GOTO 9999 |
| 8261 | ** |
| 8262 | ENDIF |
| 8263 | * store final configuration for energy-momentum cons. check |
| 8264 | IF (LEMCCK) THEN |
| 8265 | CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IREJ1) |
| 8266 | CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1) |
| 8267 | IF (IREJ1.NE.0) GOTO 9999 |
| 8268 | ENDIF |
| 8269 | DO 5 J=1,4 |
| 8270 | PHKK(J,IMO11) = PP1(J) |
| 8271 | PHKK(J,IMO21) = PP2(J) |
| 8272 | PHKK(J,IMO12) = PT1(J) |
| 8273 | PHKK(J,IMO22) = PT2(J) |
| 8274 | 5 CONTINUE |
| 8275 | * correct entries of chains |
| 8276 | DO 3 K=1,4 |
| 8277 | PHKK(K,I) = PHKK(K,IMO11)+PHKK(K,IMO12) |
| 8278 | PHKK(K,IMMX) = PHKK(K,IMO21)+PHKK(K,IMO22) |
| 8279 | 3 CONTINUE |
| 8280 | AM1 = PHKK(4,I)**2-PHKK(1,I)**2-PHKK(2,I)**2-PHKK(3,I)**2 |
| 8281 | AM2 = PHKK(4,IMMX)**2-PHKK(1,IMMX)**2-PHKK(2,IMMX)**2- |
| 8282 | & PHKK(3,IMMX)**2 |
| 8283 | * ?? the following should now be obsolete |
| 8284 | **sr test |
| 8285 | C IF ((AM1.LT.0.0D0).OR.(AM2.LT.1.0D0)) THEN |
| 8286 | IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN |
| 8287 | ** |
| 8288 | WRITE(LOUT,'(1X,A,4G10.3)') |
| 8289 | & 'EVTRES: inonsistent mass-corr.',AM1,AM2 |
| 8290 | C GOTO 9999 |
| 8291 | GOTO 1 |
| 8292 | ENDIF |
| 8293 | PHKK(5,I) = SQRT(AM1) |
| 8294 | PHKK(5,IMMX) = SQRT(AM2) |
| 8295 | IDRES(I) = IDRES(I)/100 |
| 8296 | IF ((ABS(PHKK(5,I)-AMCH1N).GT.TINY5).OR. |
| 8297 | & (ABS(PHKK(5,IMMX)-AMCH2).GT.TINY5)) THEN |
| 8298 | WRITE(LOUT,'(1X,A,4G10.3)') |
| 8299 | & 'EVTRES: inconsistent chain-masses', |
| 8300 | & PHKK(5,I),AMCH1N,PHKK(5,IMMX),AMCH2 |
| 8301 | GOTO 9999 |
| 8302 | ENDIF |
| 8303 | ENDIF |
| 8304 | 1 CONTINUE |
| 8305 | 6 CONTINUE |
| 8306 | RETURN |
| 8307 | |
| 8308 | 9999 CONTINUE |
| 8309 | IREJ = 1 |
| 8310 | RETURN |
| 8311 | END |
| 8312 | |
| 8313 | *$ CREATE DT_GETSPT.FOR |
| 8314 | *COPY DT_GETSPT |
| 8315 | * |
| 8316 | *===getspt=============================================================* |
| 8317 | * |
| 8318 | SUBROUTINE DT_GETSPT(PP1I,IFPR1,IFP1,PP2I,IFPR2,IFP2, |
| 8319 | & PT1I,IFTA1,IFT1,PT2I,IFTA2,IFT2, |
| 8320 | & AM1,IDCH1,AM2,IDCH2,IDCHAI,IREJ) |
| 8321 | |
| 8322 | ************************************************************************ |
| 8323 | * This version dated 12.12.94 is written by S. Roesler * |
| 8324 | ************************************************************************ |
| 8325 | |
| 8326 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 8327 | SAVE |
| 8328 | PARAMETER ( LINP = 10 , |
| 8329 | & LOUT = 6 , |
| 8330 | & LDAT = 9 ) |
| 8331 | PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,ZERO=0.0D0) |
| 8332 | |
| 8333 | * various options for treatment of partons (DTUNUC 1.x) |
| 8334 | * (chain recombination, Cronin,..) |
| 8335 | LOGICAL LCO2CR,LINTPT |
| 8336 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, |
| 8337 | & LCO2CR,LINTPT |
| 8338 | * flags for input different options |
| 8339 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 8340 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 8341 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 8342 | * flags for diffractive interactions (DTUNUC 1.x) |
| 8343 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF |
| 8344 | |
| 8345 | DIMENSION PP1(4),PP1I(4),PP2(4),PP2I(4),PT1(4),PT1I(4), |
| 8346 | & PT2(4),PT2I(4),P1(4),P2(4), |
| 8347 | & IFP1(2),IFP2(2),IFT1(2),IFT2(2), |
| 8348 | & PTOTI(4),PTOTF(4),DIFF(4) |
| 8349 | |
| 8350 | IC = 0 |
| 8351 | IREJ = 0 |
| 8352 | C B33P = 4.0D0 |
| 8353 | C B33T = 4.0D0 |
| 8354 | C IF ((IDCHAI.EQ.6).OR.(IDCHAI.EQ.7).OR.(IDCHAI.EQ.8)) B33P = 2.0D0 |
| 8355 | C IF ((IDCHAI.EQ.4).OR.(IDCHAI.EQ.5).OR.(IDCHAI.EQ.8)) B33T = 2.0D0 |
| 8356 | REDU = 1.0D0 |
| 8357 | C B33P = 3.5D0 |
| 8358 | C B33T = 3.5D0 |
| 8359 | B33P = 4.0D0 |
| 8360 | B33T = 4.0D0 |
| 8361 | IF (IDIFF.NE.0) THEN |
| 8362 | B33P = 16.0D0 |
| 8363 | B33T = 16.0D0 |
| 8364 | ENDIF |
| 8365 | |
| 8366 | DO 1 I=1,4 |
| 8367 | PTOTI(I) = PP1I(I)+PP2I(I)+PT1I(I)+PT2I(I) |
| 8368 | PP1(I) = PP1I(I) |
| 8369 | PP2(I) = PP2I(I) |
| 8370 | PT1(I) = PT1I(I) |
| 8371 | PT2(I) = PT2I(I) |
| 8372 | 1 CONTINUE |
| 8373 | * get initial chain masses |
| 8374 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 |
| 8375 | & +(PP1(3)+PT1(3))**2) |
| 8376 | ECH = PP1(4)+PT1(4) |
| 8377 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) |
| 8378 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 |
| 8379 | & +(PP2(3)+PT2(3))**2) |
| 8380 | ECH = PP2(4)+PT2(4) |
| 8381 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) |
| 8382 | IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN |
| 8383 | IF (IOULEV(1).GT.0) |
| 8384 | & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 1', |
| 8385 | & AM1,AM2 |
| 8386 | GOTO 9999 |
| 8387 | ENDIF |
| 8388 | AM1 = SQRT(AM1) |
| 8389 | AM2 = SQRT(AM2) |
| 8390 | AM1N = ZERO |
| 8391 | AM2N = ZERO |
| 8392 | |
| 8393 | MODE = 0 |
| 8394 | C IF ((AM1.GE.3.0D0).AND.(AM2.GE.3.0D0)) THEN |
| 8395 | C MODE = 0 |
| 8396 | C ELSE |
| 8397 | C MODE = 1 |
| 8398 | C IF (AM1.LT.0.6) THEN |
| 8399 | C B33P = 10.0D0 |
| 8400 | C ELSEIF ((AM1.GE.1.2).AND.(AM1.LT.3.0D0)) THEN |
| 8401 | CC B33P = 4.0D0 |
| 8402 | C ENDIF |
| 8403 | C IF (AM2.LT.0.6) THEN |
| 8404 | C B33T = 10.0D0 |
| 8405 | C ELSEIF ((AM2.GE.1.2).AND.(AM2.LT.3.0D0)) THEN |
| 8406 | CC B33T = 4.0D0 |
| 8407 | C ENDIF |
| 8408 | C ENDIF |
| 8409 | |
| 8410 | * check chain masses for very low mass chains |
| 8411 | C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM, |
| 8412 | C & AM1,DUM,-IDCH1,IREJ1) |
| 8413 | C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM, |
| 8414 | C & AM2,DUM,-IDCH2,IREJ2) |
| 8415 | C IF ((IREJ1.NE.0).OR.(IREJ2.NE.0)) THEN |
| 8416 | C B33P = 20.0D0 |
| 8417 | C B33T = 20.0D0 |
| 8418 | C ENDIF |
| 8419 | |
| 8420 | JMSHL = IMSHL |
| 8421 | |
| 8422 | 2 CONTINUE |
| 8423 | IC = IC+1 |
| 8424 | IF (MOD(IC,15).EQ.0) B33P = 2.0D0*B33P |
| 8425 | IF (MOD(IC,15).EQ.0) B33T = 2.0D0*B33T |
| 8426 | IF (MOD(IC,18).EQ.0) REDU = 0.0D0 |
| 8427 | C IF (MOD(IC,19).EQ.0) JMSHL = 0 |
| 8428 | IF (MOD(IC,20).EQ.0) GOTO 7 |
| 8429 | C WRITE(LOUT,'(1X,A)') 'GETSPT: rejection ' |
| 8430 | C RETURN |
| 8431 | C GOTO 9999 |
| 8432 | C ENDIF |
| 8433 | |
| 8434 | * get transverse momentum |
| 8435 | IF (LINTPT) THEN |
| 8436 | ES = -2.0D0/(B33P**2) |
| 8437 | & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10) |
| 8438 | HPSP = SQRT(ES*ES+2.0D0*ES*0.94D0) |
| 8439 | HPSP = HPSP*REDU |
| 8440 | ES = -2.0D0/(B33T**2) |
| 8441 | & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10) |
| 8442 | HPST = SQRT(ES*ES+2.0D0*ES*0.94D0) |
| 8443 | HPST = HPST*REDU |
| 8444 | ELSE |
| 8445 | HPSP = ZERO |
| 8446 | HPST = ZERO |
| 8447 | ENDIF |
| 8448 | CALL DT_DSFECF(SFE1,CFE1) |
| 8449 | CALL DT_DSFECF(SFE2,CFE2) |
| 8450 | IF (MODE.EQ.0) THEN |
| 8451 | PP1(1) = PP1I(1)+HPSP*CFE1 |
| 8452 | PP1(2) = PP1I(2)+HPSP*SFE1 |
| 8453 | PP2(1) = PP2I(1)-HPSP*CFE1 |
| 8454 | PP2(2) = PP2I(2)-HPSP*SFE1 |
| 8455 | PT1(1) = PT1I(1)+HPST*CFE2 |
| 8456 | PT1(2) = PT1I(2)+HPST*SFE2 |
| 8457 | PT2(1) = PT2I(1)-HPST*CFE2 |
| 8458 | PT2(2) = PT2I(2)-HPST*SFE2 |
| 8459 | ELSE |
| 8460 | PP1(1) = PP1I(1)+HPSP*CFE1 |
| 8461 | PP1(2) = PP1I(2)+HPSP*SFE1 |
| 8462 | PT1(1) = PT1I(1)-HPSP*CFE1 |
| 8463 | PT1(2) = PT1I(2)-HPSP*SFE1 |
| 8464 | PP2(1) = PP2I(1)+HPST*CFE2 |
| 8465 | PP2(2) = PP2I(2)+HPST*SFE2 |
| 8466 | PT2(1) = PT2I(1)-HPST*CFE2 |
| 8467 | PT2(2) = PT2I(2)-HPST*SFE2 |
| 8468 | ENDIF |
| 8469 | |
| 8470 | * put partons on mass shell |
| 8471 | XMP1 = 0.0D0 |
| 8472 | XMT1 = 0.0D0 |
| 8473 | IF (JMSHL.EQ.1) THEN |
| 8474 | XMP1 = PYMASS(IFPR1) |
| 8475 | XMT1 = PYMASS(IFTA1) |
| 8476 | ENDIF |
| 8477 | CALL DT_MASHEL(PP1,PT1,XMP1,XMT1,P1,P2,IREJ1) |
| 8478 | IF (IREJ1.NE.0) GOTO 2 |
| 8479 | DO 3 I=1,4 |
| 8480 | PTOTF(I) = P1(I)+P2(I) |
| 8481 | PP1(I) = P1(I) |
| 8482 | PT1(I) = P2(I) |
| 8483 | 3 CONTINUE |
| 8484 | XMP2 = 0.0D0 |
| 8485 | XMT2 = 0.0D0 |
| 8486 | IF (JMSHL.EQ.1) THEN |
| 8487 | XMP2 = PYMASS(IFPR2) |
| 8488 | XMT2 = PYMASS(IFTA2) |
| 8489 | ENDIF |
| 8490 | CALL DT_MASHEL(PP2,PT2,XMP2,XMT2,P1,P2,IREJ1) |
| 8491 | IF (IREJ1.NE.0) GOTO 2 |
| 8492 | DO 4 I=1,4 |
| 8493 | PTOTF(I) = PTOTF(I)+P1(I)+P2(I) |
| 8494 | PP2(I) = P1(I) |
| 8495 | PT2(I) = P2(I) |
| 8496 | 4 CONTINUE |
| 8497 | |
| 8498 | * check consistency |
| 8499 | DO 5 I=1,4 |
| 8500 | DIFF(I) = PTOTI(I)-PTOTF(I) |
| 8501 | 5 CONTINUE |
| 8502 | IF ((ABS(DIFF(1)).GT.TINY5).OR.(ABS(DIFF(2)).GT.TINY5).OR. |
| 8503 | & (ABS(DIFF(3)).GT.TINY5).OR.(ABS(DIFF(4)).GT.TINY5)) THEN |
| 8504 | WRITE(LOUT,'(1X,A,4G10.3)') 'GETSPT: inconsistencies ',DIFF |
| 8505 | GOTO 9999 |
| 8506 | ENDIF |
| 8507 | PTOTP1 = SQRT(PP1(1)**2+PP1(2)**2+PP1(3)**2) |
| 8508 | AMP1 = SQRT(ABS( (PP1(4)-PTOTP1)*(PP1(4)+PTOTP1) )) |
| 8509 | PTOTP2 = SQRT(PP2(1)**2+PP2(2)**2+PP2(3)**2) |
| 8510 | AMP2 = SQRT(ABS( (PP2(4)-PTOTP2)*(PP2(4)+PTOTP2) )) |
| 8511 | PTOTT1 = SQRT(PT1(1)**2+PT1(2)**2+PT1(3)**2) |
| 8512 | AMT1 = SQRT(ABS( (PT1(4)-PTOTT1)*(PT1(4)+PTOTT1) )) |
| 8513 | PTOTT2 = SQRT(PT2(1)**2+PT2(2)**2+PT2(3)**2) |
| 8514 | AMT2 = SQRT(ABS( (PT2(4)-PTOTT2)*(PT2(4)+PTOTT2) )) |
| 8515 | IF ((ABS(AMP1-XMP1).GT.TINY3).OR.(ABS(AMP2-XMP2).GT.TINY3).OR. |
| 8516 | & (ABS(AMT1-XMT1).GT.TINY3).OR.(ABS(AMT2-XMT2).GT.TINY3)) |
| 8517 | & THEN |
| 8518 | WRITE(LOUT,'(1X,A,2(4G10.3,/))') |
| 8519 | & 'GETSPT: inconsistent masses', |
| 8520 | & AMP1,XMP1,AMP2,XMP2,AMT1,XMT1,AMT2,XMT2 |
| 8521 | * sr 22.11.00: commented. It should only have inconsistent masses for |
| 8522 | * ultrahigh energies due to rounding problems |
| 8523 | C GOTO 9999 |
| 8524 | ENDIF |
| 8525 | |
| 8526 | * get chain masses |
| 8527 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 |
| 8528 | & +(PP1(3)+PT1(3))**2) |
| 8529 | ECH = PP1(4)+PT1(4) |
| 8530 | AM1N = (ECH+PTOCH)*(ECH-PTOCH) |
| 8531 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 |
| 8532 | & +(PP2(3)+PT2(3))**2) |
| 8533 | ECH = PP2(4)+PT2(4) |
| 8534 | AM2N = (ECH+PTOCH)*(ECH-PTOCH) |
| 8535 | IF ((AM1N.LT.0.0D0).OR.(AM2N.LT.0.0D0)) THEN |
| 8536 | IF (IOULEV(1).GT.0) |
| 8537 | & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 2', |
| 8538 | & AM1N,AM2N |
| 8539 | GOTO 2 |
| 8540 | ENDIF |
| 8541 | AM1N = SQRT(AM1N) |
| 8542 | AM2N = SQRT(AM2N) |
| 8543 | |
| 8544 | * check chain masses for very low mass chains |
| 8545 | CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM, |
| 8546 | & AM1N,DUM,-IDCH1,IREJ1) |
| 8547 | IF (IREJ1.NE.0) GOTO 2 |
| 8548 | CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM, |
| 8549 | & AM2N,DUM,-IDCH2,IREJ2) |
| 8550 | IF (IREJ2.NE.0) GOTO 2 |
| 8551 | |
| 8552 | 7 CONTINUE |
| 8553 | IF (AM1N.GT.ZERO) THEN |
| 8554 | AM1 = AM1N |
| 8555 | AM2 = AM2N |
| 8556 | ENDIF |
| 8557 | DO 6 I=1,4 |
| 8558 | PP1I(I) = PP1(I) |
| 8559 | PP2I(I) = PP2(I) |
| 8560 | PT1I(I) = PT1(I) |
| 8561 | PT2I(I) = PT2(I) |
| 8562 | 6 CONTINUE |
| 8563 | |
| 8564 | RETURN |
| 8565 | |
| 8566 | 9999 CONTINUE |
| 8567 | IREJ = 1 |
| 8568 | RETURN |
| 8569 | END |
| 8570 | |
| 8571 | *$ CREATE DT_SAPTRE.FOR |
| 8572 | *COPY DT_SAPTRE |
| 8573 | * |
| 8574 | *===saptre=============================================================* |
| 8575 | * |
| 8576 | SUBROUTINE DT_SAPTRE(IDX1,IDX2) |
| 8577 | |
| 8578 | ************************************************************************ |
| 8579 | * p-t sampling for two-resonance systems. ("BAMJET-like" method) * |
| 8580 | * IDX1,IDX2 indices of resonances ("chains") in DTEVT1 * |
| 8581 | * Adopted from the original SAPTRE written by J. Ranft. * |
| 8582 | * This version dated 18.01.95 is written by S. Roesler * |
| 8583 | ************************************************************************ |
| 8584 | |
| 8585 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 8586 | SAVE |
| 8587 | PARAMETER ( LINP = 10 , |
| 8588 | & LOUT = 6 , |
| 8589 | & LDAT = 9 ) |
| 8590 | PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3) |
| 8591 | |
| 8592 | * event history |
| 8593 | PARAMETER (NMXHKK=200000) |
| 8594 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 8595 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 8596 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 8597 | * extended event history |
| 8598 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 8599 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 8600 | & IHIST(2,NMXHKK) |
| 8601 | * flags for input different options |
| 8602 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 8603 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 8604 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 8605 | |
| 8606 | DIMENSION PA1(4),PA2(4),P1(4),P2(4) |
| 8607 | |
| 8608 | DATA B3 /4.0D0/ |
| 8609 | |
| 8610 | ESMAX1 = PHKK(4,IDX1)-PHKK(5,IDX1) |
| 8611 | ESMAX2 = PHKK(4,IDX2)-PHKK(5,IDX2) |
| 8612 | ESMAX = MIN(ESMAX1,ESMAX2) |
| 8613 | IF (ESMAX.LE.0.05D0) RETURN |
| 8614 | |
| 8615 | HMA = PHKK(5,IDX1) |
| 8616 | DO 1 K=1,4 |
| 8617 | PA1(K) = PHKK(K,IDX1) |
| 8618 | PA2(K) = PHKK(K,IDX2) |
| 8619 | 1 CONTINUE |
| 8620 | |
| 8621 | IF (LEMCCK) THEN |
| 8622 | CALL DT_EVTEMC(PA1(1),PA1(2),PA1(3),PA1(4),1,IDUM,IDUM) |
| 8623 | CALL DT_EVTEMC(PA2(1),PA2(2),PA2(3),PA2(4),2,IDUM,IDUM) |
| 8624 | ENDIF |
| 8625 | |
| 8626 | EXEB = 0.0D0 |
| 8627 | IF (B3*ESMAX.LE.60.0D0) EXEB = EXP(-B3*ESMAX) |
| 8628 | BEXP = HMA*(1.0D0-EXEB)/B3 |
| 8629 | AXEXP = (1.0D0-(B3*ESMAX-1.0D0)*EXEB)/B3**2 |
| 8630 | WA = AXEXP/(BEXP+AXEXP) |
| 8631 | XAB = DT_RNDM(WA) |
| 8632 | 10 CONTINUE |
| 8633 | * ES is the transverse kinetic energy |
| 8634 | IF (XAB.LT.WA)THEN |
| 8635 | X = DT_RNDM(WA) |
| 8636 | Y = DT_RNDM(WA) |
| 8637 | ES = -2.0D0/(B3**2)*LOG(X*Y+TINY7) |
| 8638 | ELSE |
| 8639 | X = DT_RNDM(Y) |
| 8640 | ES = ABS(-LOG(X+TINY7)/B3) |
| 8641 | ENDIF |
| 8642 | IF (ES.GT.ESMAX) GOTO 10 |
| 8643 | ES = ES+HMA |
| 8644 | * transverse momentum |
| 8645 | HPS = SQRT((ES-HMA)*(ES+HMA)) |
| 8646 | |
| 8647 | CALL DT_DSFECF(SFE,CFE) |
| 8648 | HPX = HPS*CFE |
| 8649 | HPY = HPS*SFE |
| 8650 | PZ1NSQ = PA1(3)**2-HPS**2-2.0D0*PA1(1)*HPX-2.0D0*PA1(2)*HPY |
| 8651 | PZ2NSQ = PA2(3)**2-HPS**2+2.0D0*PA2(1)*HPX+2.0D0*PA2(2)*HPY |
| 8652 | IF ((PZ1NSQ.LT.TINY3).OR.(PZ2NSQ.LT.TINY3)) RETURN |
| 8653 | |
| 8654 | C PA1(3) = SIGN(SQRT(PZ1NSQ),PA1(3)) |
| 8655 | C PA2(3) = SIGN(SQRT(PZ2NSQ),PA2(3)) |
| 8656 | PA1(1) = PA1(1)+HPX |
| 8657 | PA1(2) = PA1(2)+HPY |
| 8658 | PA2(1) = PA2(1)-HPX |
| 8659 | PA2(2) = PA2(2)-HPY |
| 8660 | |
| 8661 | * put resonances on mass-shell again |
| 8662 | XM1 = PHKK(5,IDX1) |
| 8663 | XM2 = PHKK(5,IDX2) |
| 8664 | CALL DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ1) |
| 8665 | IF (IREJ1.NE.0) RETURN |
| 8666 | |
| 8667 | IF (LEMCCK) THEN |
| 8668 | CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,IDUM,IDUM) |
| 8669 | CALL DT_EVTEMC(-P2(1),-P2(2),-P2(3),-P2(4),2,IDUM,IDUM) |
| 8670 | CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,12,IREJ1) |
| 8671 | IF (IREJ1.NE.0) RETURN |
| 8672 | ENDIF |
| 8673 | |
| 8674 | DO 2 K=1,4 |
| 8675 | PHKK(K,IDX1) = P1(K) |
| 8676 | PHKK(K,IDX2) = P2(K) |
| 8677 | 2 CONTINUE |
| 8678 | |
| 8679 | RETURN |
| 8680 | END |
| 8681 | |
| 8682 | *$ CREATE DT_CRONIN.FOR |
| 8683 | *COPY DT_CRONIN |
| 8684 | * |
| 8685 | *===cronin=============================================================* |
| 8686 | * |
| 8687 | SUBROUTINE DT_CRONIN(INCL) |
| 8688 | |
| 8689 | ************************************************************************ |
| 8690 | * Cronin-Effect. Multiple scattering of partons at chain ends. * |
| 8691 | * INCL = 1 multiple sc. in projectile * |
| 8692 | * = 2 multiple sc. in target * |
| 8693 | * This version dated 05.01.96 is written by S. Roesler. * |
| 8694 | ************************************************************************ |
| 8695 | |
| 8696 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 8697 | SAVE |
| 8698 | PARAMETER ( LINP = 10 , |
| 8699 | & LOUT = 6 , |
| 8700 | & LDAT = 9 ) |
| 8701 | PARAMETER (ZERO=0.0D0,TINY3=1.0D-3) |
| 8702 | |
| 8703 | * event history |
| 8704 | PARAMETER (NMXHKK=200000) |
| 8705 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 8706 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 8707 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 8708 | * extended event history |
| 8709 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 8710 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 8711 | & IHIST(2,NMXHKK) |
| 8712 | * rejection counter |
| 8713 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, |
| 8714 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, |
| 8715 | & IREXCI(3),IRDIFF(2),IRINC |
| 8716 | * Glauber formalism: collision properties |
| 8717 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, |
| 8718 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC |
| 8719 | |
| 8720 | DIMENSION R(3),PIN(4),POUT(4),DEV(4) |
| 8721 | |
| 8722 | DO 1 K=1,4 |
| 8723 | DEV(K) = ZERO |
| 8724 | 1 CONTINUE |
| 8725 | |
| 8726 | DO 2 I=NPOINT(2),NHKK |
| 8727 | IF (ISTHKK(I).LT.0) THEN |
| 8728 | * get z-position of the chain |
| 8729 | R(1) = VHKK(1,I)*1.0D12 |
| 8730 | IF (INCL.EQ.2) R(1) = VHKK(1,I)*1.0D12-BIMPAC |
| 8731 | R(2) = VHKK(2,I)*1.0D12 |
| 8732 | IDXNU = JMOHKK(1,I) |
| 8733 | IF ( (INCL.EQ.1).AND.(ISTHKK(IDXNU).EQ.10) ) |
| 8734 | & IDXNU = JMOHKK(1,I-1) |
| 8735 | IF ( (INCL.EQ.2).AND.(ISTHKK(IDXNU).EQ. 9) ) |
| 8736 | & IDXNU = JMOHKK(1,I+1) |
| 8737 | R(3) = VHKK(3,IDXNU)*1.0D12 |
| 8738 | * position of target parton the chain is connected to |
| 8739 | DO 3 K=1,4 |
| 8740 | PIN(K) = PHKK(K,I) |
| 8741 | 3 CONTINUE |
| 8742 | * multiple scattering of parton with DTEVT1-index I |
| 8743 | CALL DT_CROMSC(PIN,R,POUT,INCL) |
| 8744 | **testprint |
| 8745 | C IF (NEVHKK.EQ.5) THEN |
| 8746 | C AMIN = PIN(4)**2-PIN(1)**2-PIN(2)**2-PIN(3)**2 |
| 8747 | C AMOU = POUT(4)**2-POUT(1)**2-POUT(2)**2-POUT(3)**2 |
| 8748 | C AMIN = SIGN(SQRT(ABS(AMIN)),AMIN) |
| 8749 | C AMOU = SIGN(SQRT(ABS(AMOU)),AMOU) |
| 8750 | C WRITE(6,'(A,I4,2E15.5)')'I,AMIN,AMOU: ',I,AMIN,AMOU |
| 8751 | C WRITE(6,'(A,4E15.5)')'PIN: ',PIN |
| 8752 | C WRITE(6,'(A,4E15.5)')'POUT: ',POUT |
| 8753 | C ENDIF |
| 8754 | ** |
| 8755 | * increase accumulator by energy-momentum difference |
| 8756 | DO 4 K=1,4 |
| 8757 | DEV(K) = DEV(K)+POUT(K)-PIN(K) |
| 8758 | PHKK(K,I) = POUT(K) |
| 8759 | 4 CONTINUE |
| 8760 | PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2- |
| 8761 | & PHKK(2,I)**2-PHKK(3,I)**2)) |
| 8762 | ENDIF |
| 8763 | 2 CONTINUE |
| 8764 | |
| 8765 | * dump accumulator to momenta of valence partons |
| 8766 | NVAL = 0 |
| 8767 | ETOT = 0.0D0 |
| 8768 | DO 5 I=NPOINT(2),NHKK |
| 8769 | IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN |
| 8770 | NVAL = NVAL+1 |
| 8771 | ETOT = ETOT+PHKK(4,I) |
| 8772 | ENDIF |
| 8773 | 5 CONTINUE |
| 8774 | C WRITE(LOUT,1000) NVAL,(DEV(K)/DBLE(NVAL),K=1,4) |
| 8775 | 1000 FORMAT(1X,'CRONIN : number of val. partons ',I4,/, |
| 8776 | & 9X,4E12.4) |
| 8777 | DO 6 I=NPOINT(2),NHKK |
| 8778 | IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN |
| 8779 | E = PHKK(4,I) |
| 8780 | DO 7 K=1,4 |
| 8781 | C PHKK(K,I) = PHKK(K,I)-DEV(K)/DBLE(NVAL) |
| 8782 | PHKK(K,I) = PHKK(K,I)-DEV(K)*E/ETOT |
| 8783 | 7 CONTINUE |
| 8784 | PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2- |
| 8785 | & PHKK(2,I)**2-PHKK(3,I)**2)) |
| 8786 | ENDIF |
| 8787 | 6 CONTINUE |
| 8788 | |
| 8789 | RETURN |
| 8790 | END |
| 8791 | |
| 8792 | *$ CREATE DT_CROMSC.FOR |
| 8793 | *COPY DT_CROMSC |
| 8794 | * |
| 8795 | *===cromsc=============================================================* |
| 8796 | * |
| 8797 | SUBROUTINE DT_CROMSC(PIN,R,POUT,INCL) |
| 8798 | |
| 8799 | ************************************************************************ |
| 8800 | * Cronin-Effect. Multiple scattering of one parton passing through * |
| 8801 | * nuclear matter. * |
| 8802 | * PIN(4) input 4-momentum of parton * |
| 8803 | * POUT(4) 4-momentum of parton after mult. scatt. * |
| 8804 | * R(3) spatial position of parton in target nucleus * |
| 8805 | * INCL = 1 multiple sc. in projectile * |
| 8806 | * = 2 multiple sc. in target * |
| 8807 | * This is a revised version of the original version written by J. Ranft* |
| 8808 | * This version dated 17.01.95 is written by S. Roesler. * |
| 8809 | ************************************************************************ |
| 8810 | |
| 8811 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 8812 | SAVE |
| 8813 | PARAMETER ( LINP = 10 , |
| 8814 | & LOUT = 6 , |
| 8815 | & LDAT = 9 ) |
| 8816 | PARAMETER (ZERO=0.0D0,TINY3=1.0D-3) |
| 8817 | |
| 8818 | LOGICAL LSTART |
| 8819 | |
| 8820 | * rejection counter |
| 8821 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, |
| 8822 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, |
| 8823 | & IREXCI(3),IRDIFF(2),IRINC |
| 8824 | * Glauber formalism: collision properties |
| 8825 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, |
| 8826 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC |
| 8827 | * various options for treatment of partons (DTUNUC 1.x) |
| 8828 | * (chain recombination, Cronin,..) |
| 8829 | LOGICAL LCO2CR,LINTPT |
| 8830 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, |
| 8831 | & LCO2CR,LINTPT |
| 8832 | |
| 8833 | DIMENSION PIN(4),POUT(4),R(3) |
| 8834 | |
| 8835 | DATA LSTART /.TRUE./ |
| 8836 | |
| 8837 | IRCRON(1) = IRCRON(1)+1 |
| 8838 | |
| 8839 | IF (LSTART) THEN |
| 8840 | WRITE(LOUT,1000) CRONCO |
| 8841 | 1000 FORMAT(/,1X,'CROMSC: multiple scattering of chain ends', |
| 8842 | & ' treated',/,10X,'with parameter CRONCO = ',F5.2) |
| 8843 | LSTART = .FALSE. |
| 8844 | ENDIF |
| 8845 | |
| 8846 | NCBACK = 0 |
| 8847 | RNCL = RPROJ |
| 8848 | IF (INCL.EQ.2) RNCL = RTARG |
| 8849 | |
| 8850 | * Lorentz-transformation into Lab. |
| 8851 | MODE = -(INCL+1) |
| 8852 | CALL DT_LTNUC(PIN(3),PIN(4),PZ,PE,MODE) |
| 8853 | |
| 8854 | PTOT = SQRT(PIN(1)**2+PIN(2)**2+PZ**2) |
| 8855 | IF (PTOT.LE.8.0D0) GOTO 9997 |
| 8856 | |
| 8857 | * direction cosines of parton before mult. scattering |
| 8858 | COSX = PIN(1)/PTOT |
| 8859 | COSY = PIN(2)/PTOT |
| 8860 | COSZ = PZ/PTOT |
| 8861 | |
| 8862 | RTESQ = R(1)**2+R(2)**2+R(3)**2-RNCL**2 |
| 8863 | IF (RTESQ.GE.-TINY3) GOTO 9999 |
| 8864 | |
| 8865 | * calculate distance (DIST) from R to surface of nucleus (radius RNCL) |
| 8866 | * in the direction of particle motion |
| 8867 | |
| 8868 | A = COSX*R(1)+COSY*R(2)+COSZ*R(3) |
| 8869 | TMP = A**2-RTESQ |
| 8870 | IF (TMP.LT.ZERO) GOTO 9998 |
| 8871 | DIST = -A+SQRT(TMP) |
| 8872 | |
| 8873 | * multiple scattering angle |
| 8874 | THETO = CRONCO*SQRT(DIST)/PTOT |
| 8875 | IF (THETO.GT.0.1D0) THETO=0.1D0 |
| 8876 | |
| 8877 | 1 CONTINUE |
| 8878 | * Gaussian sampling of spatial angle |
| 8879 | CALL DT_RANNOR(R1,R2) |
| 8880 | THETA = ABS(R1*THETO) |
| 8881 | IF (THETA.GT.0.3D0) GOTO 9997 |
| 8882 | CALL DT_DSFECF(SFE,CFE) |
| 8883 | COSTH = COS(THETA) |
| 8884 | SINTH = SIN(THETA) |
| 8885 | |
| 8886 | * new direction cosines |
| 8887 | CALL DT_MYTRAN(1,COSX,COSY,COSZ,COSTH,SINTH,SFE,CFE, |
| 8888 | & COSXN,COSYN,COSZN) |
| 8889 | |
| 8890 | POUT(1) = COSXN*PTOT |
| 8891 | POUT(2) = COSYN*PTOT |
| 8892 | PZ = COSZN*PTOT |
| 8893 | * Lorentz-transformation into nucl.-nucl. cms |
| 8894 | MODE = INCL+1 |
| 8895 | CALL DT_LTNUC(PZ,PE,POUT(3),POUT(4),MODE) |
| 8896 | |
| 8897 | C IF (ABS(PIN(4)-POUT(4)).GT.0.2D0) THEN |
| 8898 | C IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.1D0 ) THEN |
| 8899 | IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.05D0 ) THEN |
| 8900 | THETO = THETO/2.0D0 |
| 8901 | NCBACK = NCBACK+1 |
| 8902 | IF (MOD(NCBACK,200).EQ.0) THEN |
| 8903 | WRITE(LOUT,1001) THETO,PIN,POUT |
| 8904 | 1001 FORMAT(1X,'CROMSC: inconsistent scattering angle ', |
| 8905 | & E12.4,/,1X,' PIN :',4E12.4,/, |
| 8906 | & 1X,' POUT:',4E12.4) |
| 8907 | GOTO 9997 |
| 8908 | ENDIF |
| 8909 | GOTO 1 |
| 8910 | ENDIF |
| 8911 | |
| 8912 | RETURN |
| 8913 | |
| 8914 | 9997 IRCRON(2) = IRCRON(2)+1 |
| 8915 | GOTO 9999 |
| 8916 | 9998 IRCRON(3) = IRCRON(3)+1 |
| 8917 | |
| 8918 | 9999 CONTINUE |
| 8919 | DO 100 K=1,4 |
| 8920 | POUT(K) = PIN(K) |
| 8921 | 100 CONTINUE |
| 8922 | RETURN |
| 8923 | END |
| 8924 | |
| 8925 | *$ CREATE DT_COM2CR.FOR |
| 8926 | *COPY DT_COM2CR |
| 8927 | * |
| 8928 | *===com2sr=============================================================* |
| 8929 | * |
| 8930 | SUBROUTINE DT_COM2CR |
| 8931 | |
| 8932 | ************************************************************************ |
| 8933 | * COMbine q-aq chains to Color Ropes (qq-aqaq). * |
| 8934 | * CUTOF parameter determining minimum number of not * |
| 8935 | * combined q-aq chains * |
| 8936 | * This subroutine replaces KKEVCC etc. * |
| 8937 | * This version dated 11.01.95 is written by S. Roesler. * |
| 8938 | ************************************************************************ |
| 8939 | |
| 8940 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 8941 | SAVE |
| 8942 | PARAMETER ( LINP = 10 , |
| 8943 | & LOUT = 6 , |
| 8944 | & LDAT = 9 ) |
| 8945 | |
| 8946 | * event history |
| 8947 | PARAMETER (NMXHKK=200000) |
| 8948 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 8949 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 8950 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 8951 | * extended event history |
| 8952 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 8953 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 8954 | & IHIST(2,NMXHKK) |
| 8955 | * statistics |
| 8956 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, |
| 8957 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), |
| 8958 | & ICEVTG(8,0:30) |
| 8959 | * various options for treatment of partons (DTUNUC 1.x) |
| 8960 | * (chain recombination, Cronin,..) |
| 8961 | LOGICAL LCO2CR,LINTPT |
| 8962 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, |
| 8963 | & LCO2CR,LINTPT |
| 8964 | |
| 8965 | DIMENSION IDXQA(248),IDXAQ(248) |
| 8966 | |
| 8967 | ICCHAI(1,9) = ICCHAI(1,9)+1 |
| 8968 | NQA = 0 |
| 8969 | NAQ = 0 |
| 8970 | * scan DTEVT1 for q-aq, aq-q chains |
| 8971 | DO 10 I=NPOINT(3),NHKK |
| 8972 | * skip "chains" which are resonances |
| 8973 | IF ((IDHKK(I).EQ.88888).AND.(IDRES(I).EQ.0)) THEN |
| 8974 | MO1 = JMOHKK(1,I) |
| 8975 | MO2 = JMOHKK(2,I) |
| 8976 | IF ((ABS(IDHKK(MO1)).LE.6).AND.(ABS(IDHKK(MO2)).LE.6)) THEN |
| 8977 | * q-aq, aq-q chain found, keep index |
| 8978 | IF (IDHKK(MO1).GT.0) THEN |
| 8979 | NQA = NQA+1 |
| 8980 | IDXQA(NQA) = I |
| 8981 | ELSE |
| 8982 | NAQ = NAQ+1 |
| 8983 | IDXAQ(NAQ) = I |
| 8984 | ENDIF |
| 8985 | ENDIF |
| 8986 | ENDIF |
| 8987 | 10 CONTINUE |
| 8988 | |
| 8989 | * minimum number of q-aq chains requested for the same projectile/ |
| 8990 | * target |
| 8991 | NCHMIN = IDT_NPOISS(CUTOF) |
| 8992 | |
| 8993 | * combine q-aq chains of the same projectile |
| 8994 | CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,1) |
| 8995 | * combine q-aq chains of the same target |
| 8996 | CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,2) |
| 8997 | * combine aq-q chains of the same projectile |
| 8998 | CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,1) |
| 8999 | * combine aq-q chains of the same target |
| 9000 | CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,2) |
| 9001 | |
| 9002 | RETURN |
| 9003 | END |
| 9004 | |
| 9005 | *$ CREATE DT_SCN4CR.FOR |
| 9006 | *COPY DT_SCN4CR |
| 9007 | * |
| 9008 | *===scn4cr=============================================================* |
| 9009 | * |
| 9010 | SUBROUTINE DT_SCN4CR(NCH,IDXCH,NCHMIN,MODE) |
| 9011 | |
| 9012 | ************************************************************************ |
| 9013 | * SCan q-aq chains for Color Ropes. * |
| 9014 | * This version dated 11.01.95 is written by S. Roesler. * |
| 9015 | ************************************************************************ |
| 9016 | |
| 9017 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 9018 | SAVE |
| 9019 | PARAMETER ( LINP = 10 , |
| 9020 | & LOUT = 6 , |
| 9021 | & LDAT = 9 ) |
| 9022 | |
| 9023 | * event history |
| 9024 | PARAMETER (NMXHKK=200000) |
| 9025 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 9026 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 9027 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 9028 | * extended event history |
| 9029 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 9030 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 9031 | & IHIST(2,NMXHKK) |
| 9032 | |
| 9033 | DIMENSION IDXCH(248),IDXJN(248) |
| 9034 | |
| 9035 | DO 1 I=1,NCH |
| 9036 | IF (IDXCH(I).GT.0) THEN |
| 9037 | NJOIN = 1 |
| 9038 | IDXMO = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(I)))) |
| 9039 | IDXJN(NJOIN) = I |
| 9040 | IF (I.LT.NCH) THEN |
| 9041 | DO 2 J=I+1,NCH |
| 9042 | IF (IDXCH(J).GT.0) THEN |
| 9043 | IDXMO1 = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(J)))) |
| 9044 | IF (IDXMO.EQ.IDXMO1) THEN |
| 9045 | NJOIN = NJOIN+1 |
| 9046 | IDXJN(NJOIN) = J |
| 9047 | ENDIF |
| 9048 | ENDIF |
| 9049 | 2 CONTINUE |
| 9050 | ENDIF |
| 9051 | IF (NJOIN.GE.NCHMIN+2) THEN |
| 9052 | NJ = INT(DBLE(NJOIN-NCHMIN)/2.0D0) |
| 9053 | DO 3 J=1,2*NJ,2 |
| 9054 | CALL DT_JOIN(IDXCH(IDXJN(J)),IDXCH(IDXJN(J+1)),IREJ1) |
| 9055 | IF (IREJ1.NE.0) GOTO 3 |
| 9056 | IDXCH(IDXJN(J)) = 0 |
| 9057 | IDXCH(IDXJN(J+1)) = 0 |
| 9058 | 3 CONTINUE |
| 9059 | ENDIF |
| 9060 | ENDIF |
| 9061 | 1 CONTINUE |
| 9062 | |
| 9063 | RETURN |
| 9064 | END |
| 9065 | |
| 9066 | *$ CREATE DT_JOIN.FOR |
| 9067 | *COPY DT_JOIN |
| 9068 | * |
| 9069 | *===join===============================================================* |
| 9070 | * |
| 9071 | SUBROUTINE DT_JOIN(IDX1,IDX2,IREJ) |
| 9072 | |
| 9073 | ************************************************************************ |
| 9074 | * This subroutine joins two q-aq chains to one qq-aqaq chain. * |
| 9075 | * IDX1, IDX2 DTEVT1 indices of chains to be joined * |
| 9076 | * This version dated 11.01.95 is written by S. Roesler. * |
| 9077 | ************************************************************************ |
| 9078 | |
| 9079 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 9080 | SAVE |
| 9081 | PARAMETER ( LINP = 10 , |
| 9082 | & LOUT = 6 , |
| 9083 | & LDAT = 9 ) |
| 9084 | |
| 9085 | * event history |
| 9086 | PARAMETER (NMXHKK=200000) |
| 9087 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 9088 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 9089 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 9090 | * extended event history |
| 9091 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 9092 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 9093 | & IHIST(2,NMXHKK) |
| 9094 | * flags for input different options |
| 9095 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 9096 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 9097 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 9098 | * statistics |
| 9099 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, |
| 9100 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), |
| 9101 | & ICEVTG(8,0:30) |
| 9102 | |
| 9103 | DIMENSION MO(2,2),ID(2,2),IDX(2),PCH(4),PP(4),PT(4),P1(4),P2(4) |
| 9104 | |
| 9105 | IREJ = 0 |
| 9106 | |
| 9107 | IDX(1) = IDX1 |
| 9108 | IDX(2) = IDX2 |
| 9109 | DO 1 I=1,2 |
| 9110 | DO 2 J=1,2 |
| 9111 | MO(I,J) = JMOHKK(J,IDX(I)) |
| 9112 | ID(I,J) = IDT_IPDG2B(IDHKK(MO(I,J)),1,2) |
| 9113 | 2 CONTINUE |
| 9114 | 1 CONTINUE |
| 9115 | |
| 9116 | * check consistency |
| 9117 | IF ((ABS(ID(1,1)).GT.6).OR.(ABS(ID(1,2)).GT.6).OR. |
| 9118 | & (ABS(ID(2,1)).GT.6).OR.(ABS(ID(2,2)).GT.6).OR. |
| 9119 | & ((ID(1,1)*ID(2,1)).LT.0).OR. |
| 9120 | & ((ID(1,2)*ID(2,2)).LT.0)) THEN |
| 9121 | WRITE(LOUT,1000) IDX(1),MO(1,1),MO(1,2),IDX(2),MO(2,1), |
| 9122 | & MO(2,2) |
| 9123 | 1000 FORMAT(1X,'JOIN: incons. chain system! chain ',I4,':', |
| 9124 | & 2I5,' chain ',I4,':',2I5) |
| 9125 | ENDIF |
| 9126 | |
| 9127 | * join chains |
| 9128 | DO 3 K=1,4 |
| 9129 | PP(K) = PHKK(K,MO(1,1))+PHKK(K,MO(2,1)) |
| 9130 | PT(K) = PHKK(K,MO(1,2))+PHKK(K,MO(2,2)) |
| 9131 | 3 CONTINUE |
| 9132 | IF1 = IDT_IB2PDG(ID(1,1),ID(2,1),2) |
| 9133 | IF2 = IDT_IB2PDG(ID(1,2),ID(2,2),2) |
| 9134 | IST1 = ISTHKK(MO(1,1)) |
| 9135 | IST2 = ISTHKK(MO(1,2)) |
| 9136 | |
| 9137 | * put partons again on mass shell |
| 9138 | XM1 = 0.0D0 |
| 9139 | XM2 = 0.0D0 |
| 9140 | IF (IMSHL.EQ.1) THEN |
| 9141 | XM1 = PYMASS(IF1) |
| 9142 | XM2 = PYMASS(IF2) |
| 9143 | ENDIF |
| 9144 | CALL DT_MASHEL(PP,PT,XM1,XM2,P1,P2,IREJ1) |
| 9145 | IF (IREJ1.NE.0) GOTO 9999 |
| 9146 | DO 4 I=1,4 |
| 9147 | PP(I) = P1(I) |
| 9148 | PT(I) = P2(I) |
| 9149 | 4 CONTINUE |
| 9150 | |
| 9151 | * store new partons in DTEVT1 |
| 9152 | CALL DT_EVTPUT(IST1,IF1,MO(1,1),MO(2,1),PP(1),PP(2),PP(3),PP(4), |
| 9153 | & 0,0,0) |
| 9154 | CALL DT_EVTPUT(IST2,IF2,MO(1,2),MO(2,2),PT(1),PT(2),PT(3),PT(4), |
| 9155 | & 0,0,0) |
| 9156 | DO 5 K=1,4 |
| 9157 | PCH(K) = PP(K)+PT(K) |
| 9158 | 5 CONTINUE |
| 9159 | |
| 9160 | * check new chain for lower mass limit |
| 9161 | IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN |
| 9162 | AMCH = SQRT(ABS(PCH(4)**2-PCH(1)**2-PCH(2)**2-PCH(3)**2)) |
| 9163 | CALL DT_CH2RES(ID(1,1),ID(2,1),ID(1,2),ID(2,2),IDUM,IDUM, |
| 9164 | & AMCH,AMCHN,3,IREJ1) |
| 9165 | IF (IREJ1.NE.0) THEN |
| 9166 | NHKK = NHKK-2 |
| 9167 | GOTO 9999 |
| 9168 | ENDIF |
| 9169 | ENDIF |
| 9170 | |
| 9171 | ICCHAI(2,9) = ICCHAI(2,9)+1 |
| 9172 | * store new chain in DTEVT1 |
| 9173 | KCH = 191 |
| 9174 | CALL DT_EVTPUT(KCH,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),0,0,9) |
| 9175 | IDHKK(IDX(1)) = 22222 |
| 9176 | IDHKK(IDX(2)) = 22222 |
| 9177 | * special treatment for space-time coordinates |
| 9178 | DO 6 K=1,4 |
| 9179 | VHKK(K,NHKK) = (VHKK(K,IDX(1))+VHKK(K,IDX(2)))/2.0D0 |
| 9180 | WHKK(K,NHKK) = (WHKK(K,IDX(1))+WHKK(K,IDX(2)))/2.0D0 |
| 9181 | 6 CONTINUE |
| 9182 | RETURN |
| 9183 | |
| 9184 | 9999 CONTINUE |
| 9185 | IREJ = 1 |
| 9186 | RETURN |
| 9187 | END |
| 9188 | |
| 9189 | *$ CREATE DT_XSGLAU.FOR |
| 9190 | *COPY DT_XSGLAU |
| 9191 | * |
| 9192 | *===xsglau=============================================================* |
| 9193 | * |
| 9194 | SUBROUTINE DT_XSGLAU(NA,NB,JJPROJ,XI,Q2I,ECMI,IE,IQ,NIDX) |
| 9195 | |
| 9196 | ************************************************************************ |
| 9197 | * Total, elastic, quasi-elastic, inelastic cross sections according to * |
| 9198 | * Glauber's approach. * |
| 9199 | * NA / NB mass numbers of proj./target nuclei * |
| 9200 | * JJPROJ bamjet-index of projectile (=1 in case of proj.nucleus) * |
| 9201 | * XI,Q2I,ECMI kinematical variables x, Q^2, E_cm * |
| 9202 | * IE,IQ indices of energy and virtuality (the latter for gamma * |
| 9203 | * projectiles only) * |
| 9204 | * NIDX index of projectile/target nucleus * |
| 9205 | * This version dated 17.3.98 is written by S. Roesler * |
| 9206 | ************************************************************************ |
| 9207 | |
| 9208 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 9209 | SAVE |
| 9210 | PARAMETER ( LINP = 10 , |
| 9211 | & LOUT = 6 , |
| 9212 | & LDAT = 9 ) |
| 9213 | |
| 9214 | COMPLEX*16 CZERO,CONE,CTWO |
| 9215 | CHARACTER*12 CFILE |
| 9216 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0, |
| 9217 | & ONETHI=ONE/THREE,TINY25=1.0D-25) |
| 9218 | PARAMETER (TWOPI = 6.283185307179586454D+00, |
| 9219 | & PI = TWOPI/TWO, |
| 9220 | & GEV2MB = 0.38938D0, |
| 9221 | & GEV2FM = 0.1972D0, |
| 9222 | & ALPHEM = ONE/137.0D0, |
| 9223 | * proton mass |
| 9224 | & AMP = 0.938D0, |
| 9225 | & AMP2 = AMP**2, |
| 9226 | * approx. nucleon radius |
| 9227 | & RNUCLE = 1.12D0) |
| 9228 | |
| 9229 | * particle properties (BAMJET index convention) |
| 9230 | CHARACTER*8 ANAME |
| 9231 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 9232 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 9233 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 9234 | PARAMETER ( MAXNCL = 260, |
| 9235 | & MAXVQU = MAXNCL, |
| 9236 | & MAXSQU = 20*MAXVQU, |
| 9237 | & MAXINT = MAXVQU+MAXSQU) |
| 9238 | * Glauber formalism: parameters |
| 9239 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), |
| 9240 | & BMAX(NCOMPX),BSTEP(NCOMPX), |
| 9241 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), |
| 9242 | & NSITEB,NSTATB |
| 9243 | * Glauber formalism: cross sections |
| 9244 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, |
| 9245 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), |
| 9246 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), |
| 9247 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), |
| 9248 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), |
| 9249 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), |
| 9250 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), |
| 9251 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), |
| 9252 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), |
| 9253 | & BSLOPE,NEBINI,NQBINI |
| 9254 | * Glauber formalism: flags and parameters for statistics |
| 9255 | LOGICAL LPROD |
| 9256 | CHARACTER*8 CGLB |
| 9257 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD |
| 9258 | * nucleon-nucleon event-generator |
| 9259 | CHARACTER*8 CMODEL |
| 9260 | LOGICAL LPHOIN |
| 9261 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN |
| 9262 | * VDM parameter for photon-nucleus interactions |
| 9263 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) |
| 9264 | * parameters for hA-diffraction |
| 9265 | COMMON /DTDIHA/ DIBETA,DIALPH |
| 9266 | |
| 9267 | COMPLEX*16 PP11(MAXNCL),PP12(MAXNCL),PP21(MAXNCL),PP22(MAXNCL), |
| 9268 | & OMPP11,OMPP12,OMPP21,OMPP22, |
| 9269 | & DIPP11,DIPP12,DIPP21,DIPP22,AVDIPP, |
| 9270 | & PPTMP1,PPTMP2 |
| 9271 | COMPLEX*16 C,CA,CI |
| 9272 | DIMENSION COOP1(3,MAXNCL),COOT1(3,MAXNCL), |
| 9273 | & COOP2(3,MAXNCL),COOT2(3,MAXNCL), |
| 9274 | & BPROD(KSITEB) |
| 9275 | |
| 9276 | PARAMETER (NPOINT=16) |
| 9277 | DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT) |
| 9278 | |
| 9279 | LOGICAL LFIRST,LOPEN |
| 9280 | DATA LFIRST,LOPEN /.TRUE.,.FALSE./ |
| 9281 | |
| 9282 | NTARG = ABS(NIDX) |
| 9283 | * for quasi-elastic neutrino scattering set projectile to proton |
| 9284 | * it should not have an effect since the whole Glauber-formalism is |
| 9285 | * not needed for these interactions.. |
| 9286 | IF (MCGENE.EQ.4) THEN |
| 9287 | IJPROJ = 1 |
| 9288 | ELSE |
| 9289 | IJPROJ = JJPROJ |
| 9290 | ENDIF |
| 9291 | |
| 9292 | IF ((ABS(IOGLB).EQ.1).AND.(.NOT.LOPEN)) THEN |
| 9293 | I = INDEX(CGLB,' ') |
| 9294 | IF (I.EQ.0) THEN |
| 9295 | CFILE = CGLB//'.glb' |
| 9296 | OPEN(LDAT,FILE=CGLB//'.glb',STATUS='UNKNOWN') |
| 9297 | ELSEIF (I.GT.1) THEN |
| 9298 | CFILE = CGLB(1:I-1)//'.glb' |
| 9299 | OPEN(LDAT,FILE=CGLB(1:I-1)//'.glb',STATUS='UNKNOWN') |
| 9300 | ELSE |
| 9301 | STOP 'XSGLAU 1' |
| 9302 | ENDIF |
| 9303 | LOPEN = .TRUE. |
| 9304 | ENDIF |
| 9305 | |
| 9306 | CZERO = DCMPLX(ZERO,ZERO) |
| 9307 | CONE = DCMPLX(ONE,ZERO) |
| 9308 | CTWO = DCMPLX(TWO,ZERO) |
| 9309 | NEBINI = IE |
| 9310 | NQBINI = IQ |
| 9311 | |
| 9312 | * re-define kinematics |
| 9313 | S = ECMI**2 |
| 9314 | Q2 = Q2I |
| 9315 | X = XI |
| 9316 | * g(Q2=0)-A, h-A, A-A scattering |
| 9317 | IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN |
| 9318 | Q2 = 0.0001D0 |
| 9319 | X = Q2/(S+Q2-AMP2) |
| 9320 | * g(Q2>0)-A scattering |
| 9321 | ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(S.GT.ZERO)) THEN |
| 9322 | X = Q2/(S+Q2-AMP2) |
| 9323 | ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN |
| 9324 | Q2 = (S-AMP2)*X/(ONE-X) |
| 9325 | ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN |
| 9326 | S = Q2*(ONE-X)/X+AMP2 |
| 9327 | ELSE |
| 9328 | WRITE(LOUT,*) 'XSGLAU: inconsistent input ',S,Q2,X |
| 9329 | STOP |
| 9330 | ENDIF |
| 9331 | ECMNN(IE) = SQRT(S) |
| 9332 | Q2G(IQ) = Q2 |
| 9333 | XNU = (S+Q2-AMP2)/(TWO*AMP) |
| 9334 | |
| 9335 | * parameters determining statistics in evaluating Glauber-xsection |
| 9336 | NSTATB = JSTATB |
| 9337 | NSITEB = JBINSB |
| 9338 | IF (NSITEB.GT.KSITEB) NSITEB = KSITEB |
| 9339 | |
| 9340 | * set up interaction geometry (common /DTGLAM/) |
| 9341 | * projectile/target radii |
| 9342 | RPRNCL = DT_RNCLUS(NA) |
| 9343 | RTANCL = DT_RNCLUS(NB) |
| 9344 | IF (IJPROJ.EQ.7) THEN |
| 9345 | RASH(1) = ZERO |
| 9346 | RBSH(NTARG) = RTANCL |
| 9347 | BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG)) |
| 9348 | ELSE |
| 9349 | IF (NIDX.LE.-1) THEN |
| 9350 | RASH(1) = RPRNCL |
| 9351 | RBSH(NTARG) = RTANCL |
| 9352 | BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG)) |
| 9353 | ELSE |
| 9354 | RASH(NTARG) = RPRNCL |
| 9355 | RBSH(1) = RTANCL |
| 9356 | BMAX(NTARG) = 2.0D0*(RASH(NTARG)+RBSH(1)) |
| 9357 | ENDIF |
| 9358 | ENDIF |
| 9359 | * maximum impact-parameter |
| 9360 | BSTEP(NTARG)= BMAX(NTARG)/DBLE(NSITEB-1) |
| 9361 | |
| 9362 | * slope, rho ( Re(f(0))/Im(f(0)) ) |
| 9363 | IF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN |
| 9364 | IF (MCGENE.EQ.2) THEN |
| 9365 | ZERO1 = ZERO |
| 9366 | CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,SDUM1,SDUM2,SDUM3, |
| 9367 | & BSLOPE,0) |
| 9368 | ELSE |
| 9369 | BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S)) |
| 9370 | ENDIF |
| 9371 | IF (ECMNN(IE).LE.3.0D0) THEN |
| 9372 | ROSH = -0.43D0 |
| 9373 | ELSEIF ((ECMNN(IE).GT.3.0D0).AND.(ECMNN(IE).LE.50.D0)) THEN |
| 9374 | ROSH = -0.63D0+0.175D0*LOG(ECMNN(IE)) |
| 9375 | ELSEIF (ECMNN(IE).GT.50.0D0) THEN |
| 9376 | ROSH = 0.1D0 |
| 9377 | ENDIF |
| 9378 | ELSEIF (IJPROJ.EQ.7) THEN |
| 9379 | ROSH = 0.1D0 |
| 9380 | ELSE |
| 9381 | BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S)) |
| 9382 | ROSH = 0.01D0 |
| 9383 | ENDIF |
| 9384 | |
| 9385 | * projectile-nucleon xsection (in fm) |
| 9386 | IF (IJPROJ.EQ.7) THEN |
| 9387 | SIGSH = DT_SIGVP(X,Q2)/10.0D0 |
| 9388 | ELSE |
| 9389 | ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP) |
| 9390 | PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) ) |
| 9391 | C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0 |
| 9392 | DUMZER = ZERO |
| 9393 | CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL) |
| 9394 | SIGSH = SIGSH/10.0D0 |
| 9395 | ENDIF |
| 9396 | |
| 9397 | * parameters for projectile diffraction (hA scattering only) |
| 9398 | IF ((MCGENE.EQ.2).AND.(NA.EQ.1).AND.(NB.GT.1).AND.(IJPROJ.NE.7) |
| 9399 | & .AND.(DIBETA.GE.ZERO)) THEN |
| 9400 | ZERO1 = ZERO |
| 9401 | CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,STOT,SDUM2,SDIF1,BDUM,0) |
| 9402 | C DIBETA = SDIF1/STOT |
| 9403 | DIBETA = 0.2D0 |
| 9404 | DIGAMM = SQRT(DIALPH**2+DIBETA**2) |
| 9405 | IF (DIBETA.LE.ZERO) THEN |
| 9406 | ALPGAM = ONE |
| 9407 | ELSE |
| 9408 | ALPGAM = DIALPH/DIGAMM |
| 9409 | ENDIF |
| 9410 | FACDI1 = ONE-ALPGAM |
| 9411 | FACDI2 = ONE+ALPGAM |
| 9412 | FACDI = SQRT(FACDI1*FACDI2) |
| 9413 | WRITE(LOUT,*)'DIBETA,DIALPH,DIGAMM: ',DIBETA,DIALPH,DIGAMM |
| 9414 | ELSE |
| 9415 | DIBETA = -1.0D0 |
| 9416 | DIALPH = ZERO |
| 9417 | DIGAMM = ZERO |
| 9418 | FACDI1 = ZERO |
| 9419 | FACDI2 = 2.0D0 |
| 9420 | FACDI = ZERO |
| 9421 | ENDIF |
| 9422 | |
| 9423 | * initializations |
| 9424 | DO 10 I=1,NSITEB |
| 9425 | BSITE( 0,IQ,NTARG,I) = ZERO |
| 9426 | BSITE(IE,IQ,NTARG,I) = ZERO |
| 9427 | BPROD(I) = ZERO |
| 9428 | 10 CONTINUE |
| 9429 | STOT = ZERO |
| 9430 | STOT2 = ZERO |
| 9431 | SELA = ZERO |
| 9432 | SELA2 = ZERO |
| 9433 | SQEP = ZERO |
| 9434 | SQEP2 = ZERO |
| 9435 | SQET = ZERO |
| 9436 | SQET2 = ZERO |
| 9437 | SQE2 = ZERO |
| 9438 | SQE22 = ZERO |
| 9439 | SPRO = ZERO |
| 9440 | SPRO2 = ZERO |
| 9441 | SDEL = ZERO |
| 9442 | SDEL2 = ZERO |
| 9443 | SDQE = ZERO |
| 9444 | SDQE2 = ZERO |
| 9445 | FACN = ONE/DBLE(NSTATB) |
| 9446 | |
| 9447 | IPNT = 0 |
| 9448 | RPNT = ZERO |
| 9449 | |
| 9450 | * initialize Gauss-integration for photon-proj. |
| 9451 | JPOINT = 1 |
| 9452 | IF (IJPROJ.EQ.7) THEN |
| 9453 | IF (INTRGE(1).EQ.1) THEN |
| 9454 | AMLO2 = (3.0D0*AAM(13))**2 |
| 9455 | ELSEIF (INTRGE(1).EQ.2) THEN |
| 9456 | AMLO2 = AAM(33)**2 |
| 9457 | ELSE |
| 9458 | AMLO2 = AAM(96)**2 |
| 9459 | ENDIF |
| 9460 | IF (INTRGE(2).EQ.1) THEN |
| 9461 | AMHI2 = S/TWO |
| 9462 | ELSEIF (INTRGE(2).EQ.2) THEN |
| 9463 | AMHI2 = S/4.0D0 |
| 9464 | ELSE |
| 9465 | AMHI2 = S |
| 9466 | ENDIF |
| 9467 | AMHI20 = (ECMNN(IE)-AMP)**2 |
| 9468 | IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20 |
| 9469 | XAMLO = LOG( AMLO2+Q2 ) |
| 9470 | XAMHI = LOG( AMHI2+Q2 ) |
| 9471 | **PHOJET105a |
| 9472 | C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT) |
| 9473 | **PHOJET112 |
| 9474 | CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT) |
| 9475 | ** |
| 9476 | JPOINT = NPOINT |
| 9477 | * ratio direct/total photon-nucleon xsection |
| 9478 | CALL DT_POILIK(NB,NTARG,ECMNN(IE),Q2,IPNT,RPNT,1) |
| 9479 | ENDIF |
| 9480 | |
| 9481 | * read pre-initialized profile-function from file |
| 9482 | IF (IOGLB.EQ.1) THEN |
| 9483 | READ(LDAT,'(5I10,E15.5)') KJPROJ,IA,IB,ISTATB,ISITEB,DUM |
| 9484 | IF ((IA.NE.NA).OR.(IB.NE.NB)) THEN |
| 9485 | WRITE(LOUT,1000) CFILE,IA,IB,ISTATB,ISITEB, |
| 9486 | & NA,NB,NSTATB,NSITEB |
| 9487 | 1000 FORMAT(' XSGLAU: inconsistent input data in file ',A12,/, |
| 9488 | & ' (IA,IB,ISTATB,ISITEB) ',4I10,/, |
| 9489 | & ' (NA,NB,NSTATB,NSITEB) ',4I10) |
| 9490 | STOP |
| 9491 | ENDIF |
| 9492 | IF (LFIRST) WRITE(LOUT,1001) CFILE |
| 9493 | 1001 FORMAT(/,' XSGLAU: impact parameter distribution read from ', |
| 9494 | & 'file ',A12,/) |
| 9495 | READ(LDAT,'(6E12.5)') XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG), |
| 9496 | & XSQEP(IE,IQ,NTARG),XSQET(IE,IQ,NTARG), |
| 9497 | & XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG) |
| 9498 | READ(LDAT,'(6E12.5)') XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG), |
| 9499 | & XEQEP(IE,IQ,NTARG),XEQET(IE,IQ,NTARG), |
| 9500 | & XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG) |
| 9501 | NLINES = INT(DBLE(NSITEB)/7.0D0) |
| 9502 | IF (NLINES.GT.0) THEN |
| 9503 | DO 21 I=1,NLINES |
| 9504 | ISTART = 7*I-6 |
| 9505 | READ(LDAT,'(7E11.4)') |
| 9506 | & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6) |
| 9507 | 21 CONTINUE |
| 9508 | ENDIF |
| 9509 | ISTART = 7*NLINES+1 |
| 9510 | IF (ISTART.LE.NSITEB) THEN |
| 9511 | READ(LDAT,'(7E11.4)') |
| 9512 | & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB) |
| 9513 | ENDIF |
| 9514 | LFIRST = .FALSE. |
| 9515 | GOTO 100 |
| 9516 | * variable projectile/target/energy runs: |
| 9517 | * read pre-initialized profile-functions from file |
| 9518 | ELSEIF (IOGLB.EQ.100) THEN |
| 9519 | CALL DT_GLBSET(IJPROJ,IINA,IINB,RRELAB,0) |
| 9520 | GOTO 100 |
| 9521 | ENDIF |
| 9522 | |
| 9523 | * cross sections averaged over NSTATB nucleon configurations |
| 9524 | DO 11 IS=1,NSTATB |
| 9525 | C IF ((NA.EQ.207).AND.(NB.EQ.207)) WRITE(LOUT,*) 'conf. ',IS |
| 9526 | STOTN = ZERO |
| 9527 | SELAN = ZERO |
| 9528 | SQEPN = ZERO |
| 9529 | SQETN = ZERO |
| 9530 | SQE2N = ZERO |
| 9531 | SPRON = ZERO |
| 9532 | SDELN = ZERO |
| 9533 | SDQEN = ZERO |
| 9534 | |
| 9535 | IF (NIDX.LE.-1) THEN |
| 9536 | CALL DT_CONUCL(COOP1,NA,RASH(1),0) |
| 9537 | CALL DT_CONUCL(COOT1,NB,RBSH(NTARG),1) |
| 9538 | IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN |
| 9539 | CALL DT_CONUCL(COOP2,NA,RASH(1),0) |
| 9540 | CALL DT_CONUCL(COOT2,NB,RBSH(NTARG),1) |
| 9541 | ENDIF |
| 9542 | ELSE |
| 9543 | CALL DT_CONUCL(COOP1,NA,RASH(NTARG),0) |
| 9544 | CALL DT_CONUCL(COOT1,NB,RBSH(1),1) |
| 9545 | IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN |
| 9546 | CALL DT_CONUCL(COOP2,NA,RASH(NTARG),0) |
| 9547 | CALL DT_CONUCL(COOT2,NB,RBSH(1),1) |
| 9548 | ENDIF |
| 9549 | ENDIF |
| 9550 | |
| 9551 | * integration over impact parameter B |
| 9552 | DO 12 IB=1,NSITEB-1 |
| 9553 | STOTB = ZERO |
| 9554 | SELAB = ZERO |
| 9555 | SQEPB = ZERO |
| 9556 | SQETB = ZERO |
| 9557 | SQE2B = ZERO |
| 9558 | SPROB = ZERO |
| 9559 | SDIR = ZERO |
| 9560 | SDELB = ZERO |
| 9561 | SDQEB = ZERO |
| 9562 | B = DBLE(IB)*BSTEP(NTARG) |
| 9563 | FACB = 10.0D0*TWOPI*B*BSTEP(NTARG) |
| 9564 | |
| 9565 | * integration over M_V^2 for photon-proj. |
| 9566 | DO 14 IM=1,JPOINT |
| 9567 | PP11(1) = CONE |
| 9568 | PP12(1) = CONE |
| 9569 | PP21(1) = CONE |
| 9570 | PP22(1) = CONE |
| 9571 | IF (IJPROJ.EQ.7) THEN |
| 9572 | DO 13 K=2,NB |
| 9573 | PP11(K) = CONE |
| 9574 | PP12(K) = CONE |
| 9575 | PP21(K) = CONE |
| 9576 | PP22(K) = CONE |
| 9577 | 13 CONTINUE |
| 9578 | ENDIF |
| 9579 | SHI = ZERO |
| 9580 | FACM = ONE |
| 9581 | DCOH = 1.0D10 |
| 9582 | |
| 9583 | IF (IJPROJ.EQ.7) THEN |
| 9584 | AMV2 = EXP(ABSZX(IM))-Q2 |
| 9585 | AMV = SQRT(AMV2) |
| 9586 | IF (AMV2.LT.16.0D0) THEN |
| 9587 | R = TWO |
| 9588 | ELSEIF ((AMV2.GE.16.0D0).AND.(AMV2.LT.121.0D0)) THEN |
| 9589 | R = 10.0D0/3.0D0 |
| 9590 | ELSE |
| 9591 | R = 11.0D0/3.0D0 |
| 9592 | ENDIF |
| 9593 | * define M_V dependent properties of nucleon scattering amplitude |
| 9594 | * V_M-nucleon xsection |
| 9595 | SIGMVD = RPNT*SIGSH/(AMV2+Q2+RL2)*10.0D0 |
| 9596 | SIGMV = (ONE-RPNT)*SIGSH/(AMV2+Q2+RL2) |
| 9597 | * slope-parametrisation a la Kaidalov |
| 9598 | BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2) |
| 9599 | & +0.25D0*LOG(S/(AMV2+Q2))) |
| 9600 | * coherence length |
| 9601 | IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+Q2)*GEV2FM |
| 9602 | * integration weight factor |
| 9603 | FACM = ALPHEM/(3.0D0*PI*(ONE-X))* |
| 9604 | & R*AMV2/(AMV2+Q2)*(ONE+EPSPOL*Q2/AMV2)*WEIGHT(IM) |
| 9605 | ENDIF |
| 9606 | GSH = 10.0D0/(TWO*BSLOPE*GEV2MB) |
| 9607 | GAM = GSH |
| 9608 | IF (IJPROJ.EQ.7) THEN |
| 9609 | RCA = GAM*SIGMV/TWOPI |
| 9610 | ELSE |
| 9611 | RCA = GAM*SIGSH/TWOPI |
| 9612 | ENDIF |
| 9613 | FCA = -ROSH*RCA |
| 9614 | CA = DCMPLX(RCA,FCA) |
| 9615 | CI = CONE |
| 9616 | |
| 9617 | DO 15 INA=1,NA |
| 9618 | KK1 = 1 |
| 9619 | INT1 = 1 |
| 9620 | KK2 = 1 |
| 9621 | INT2 = 1 |
| 9622 | DO 16 INB=1,NB |
| 9623 | * photon-projectile: check for supression by coherence length |
| 9624 | IF (IJPROJ.EQ.7) THEN |
| 9625 | IF (ABS(COOT1(3,INB)-COOT1(3,KK1)).GT.DCOH)THEN |
| 9626 | KK1 = INB |
| 9627 | INT1 = INT1+1 |
| 9628 | ENDIF |
| 9629 | IF (ABS(COOT2(3,INB)-COOT2(3,KK2)).GT.DCOH)THEN |
| 9630 | KK2 = INB |
| 9631 | INT2 = INT2+1 |
| 9632 | ENDIF |
| 9633 | ENDIF |
| 9634 | |
| 9635 | X11 = B+COOT1(1,INB)-COOP1(1,INA) |
| 9636 | Y11 = COOT1(2,INB)-COOP1(2,INA) |
| 9637 | XY11 = GAM*(X11*X11+Y11*Y11) |
| 9638 | IF (XY11.LE.15.0D0) THEN |
| 9639 | C = CONE-CA*EXP(-XY11) |
| 9640 | AR = DBLE(PP11(INT1)) |
| 9641 | AI = DIMAG(PP11(INT1)) |
| 9642 | IF (ABS(AR).LT.TINY25) AR = ZERO |
| 9643 | IF (ABS(AI).LT.TINY25) AI = ZERO |
| 9644 | PP11(INT1) = DCMPLX(AR,AI) |
| 9645 | PP11(INT1) = PP11(INT1)*C |
| 9646 | AR = DBLE(C) |
| 9647 | AI = DIMAG(C) |
| 9648 | SHI = SHI+LOG(AR*AR+AI*AI) |
| 9649 | ENDIF |
| 9650 | IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN |
| 9651 | X12 = B+COOT2(1,INB)-COOP1(1,INA) |
| 9652 | Y12 = COOT2(2,INB)-COOP1(2,INA) |
| 9653 | XY12 = GAM*(X12*X12+Y12*Y12) |
| 9654 | IF (XY12.LE.15.0D0) THEN |
| 9655 | C = CONE-CA*EXP(-XY12) |
| 9656 | AR = DBLE(PP12(INT2)) |
| 9657 | AI = DIMAG(PP12(INT2)) |
| 9658 | IF (ABS(AR).LT.TINY25) AR = ZERO |
| 9659 | IF (ABS(AI).LT.TINY25) AI = ZERO |
| 9660 | PP12(INT2) = DCMPLX(AR,AI) |
| 9661 | PP12(INT2) = PP12(INT2)*C |
| 9662 | ENDIF |
| 9663 | X21 = B+COOT1(1,INB)-COOP2(1,INA) |
| 9664 | Y21 = COOT1(2,INB)-COOP2(2,INA) |
| 9665 | XY21 = GAM*(X21*X21+Y21*Y21) |
| 9666 | IF (XY21.LE.15.0D0) THEN |
| 9667 | C = CONE-CA*EXP(-XY21) |
| 9668 | AR = DBLE(PP21(INT1)) |
| 9669 | AI = DIMAG(PP21(INT1)) |
| 9670 | IF (ABS(AR).LT.TINY25) AR = ZERO |
| 9671 | IF (ABS(AI).LT.TINY25) AI = ZERO |
| 9672 | PP21(INT1) = DCMPLX(AR,AI) |
| 9673 | PP21(INT1) = PP21(INT1)*C |
| 9674 | ENDIF |
| 9675 | X22 = B+COOT2(1,INB)-COOP2(1,INA) |
| 9676 | Y22 = COOT2(2,INB)-COOP2(2,INA) |
| 9677 | XY22 = GAM*(X22*X22+Y22*Y22) |
| 9678 | IF (XY22.LE.15.0D0) THEN |
| 9679 | C = CONE-CA*EXP(-XY22) |
| 9680 | AR = DBLE(PP22(INT2)) |
| 9681 | AI = DIMAG(PP22(INT2)) |
| 9682 | IF (ABS(AR).LT.TINY25) AR = ZERO |
| 9683 | IF (ABS(AI).LT.TINY25) AI = ZERO |
| 9684 | PP22(INT2) = DCMPLX(AR,AI) |
| 9685 | PP22(INT2) = PP22(INT2)*C |
| 9686 | ENDIF |
| 9687 | ENDIF |
| 9688 | 16 CONTINUE |
| 9689 | 15 CONTINUE |
| 9690 | |
| 9691 | OMPP11 = CZERO |
| 9692 | OMPP21 = CZERO |
| 9693 | DIPP11 = CZERO |
| 9694 | DIPP21 = CZERO |
| 9695 | DO 17 K=1,INT1 |
| 9696 | IF (PP11(K).EQ.CZERO) THEN |
| 9697 | PPTMP1 = CZERO |
| 9698 | PPTMP2 = CZERO |
| 9699 | ELSE |
| 9700 | PPTMP1 = PP11(K)**(ONE-DIALPH-DIGAMM) |
| 9701 | PPTMP2 = PP11(K)**(ONE-DIALPH+DIGAMM) |
| 9702 | ENDIF |
| 9703 | AVDIPP = 0.5D0* |
| 9704 | & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) ) |
| 9705 | OMPP11 = OMPP11+AVDIPP |
| 9706 | C OMPP11 = OMPP11+(CONE-PP11(K)) |
| 9707 | AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 ) |
| 9708 | DIPP11 = DIPP11+AVDIPP |
| 9709 | IF (PP21(K).EQ.CZERO) THEN |
| 9710 | PPTMP1 = CZERO |
| 9711 | PPTMP2 = CZERO |
| 9712 | ELSE |
| 9713 | PPTMP1 = PP21(K)**(ONE-DIALPH-DIGAMM) |
| 9714 | PPTMP2 = PP21(K)**(ONE-DIALPH+DIGAMM) |
| 9715 | ENDIF |
| 9716 | AVDIPP = 0.5D0* |
| 9717 | & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) ) |
| 9718 | OMPP21 = OMPP21+AVDIPP |
| 9719 | C OMPP21 = OMPP21+(CONE-PP21(K)) |
| 9720 | AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 ) |
| 9721 | DIPP21 = DIPP21+AVDIPP |
| 9722 | 17 CONTINUE |
| 9723 | OMPP12 = CZERO |
| 9724 | OMPP22 = CZERO |
| 9725 | DIPP12 = CZERO |
| 9726 | DIPP22 = CZERO |
| 9727 | DO 18 K=1,INT2 |
| 9728 | IF (PP12(K).EQ.CZERO) THEN |
| 9729 | PPTMP1 = CZERO |
| 9730 | PPTMP2 = CZERO |
| 9731 | ELSE |
| 9732 | PPTMP1 = PP12(K)**(ONE-DIALPH-DIGAMM) |
| 9733 | PPTMP2 = PP12(K)**(ONE-DIALPH+DIGAMM) |
| 9734 | ENDIF |
| 9735 | AVDIPP = 0.5D0* |
| 9736 | & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) ) |
| 9737 | OMPP12 = OMPP12+AVDIPP |
| 9738 | C OMPP12 = OMPP12+(CONE-PP12(K)) |
| 9739 | AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 ) |
| 9740 | DIPP12 = DIPP12+AVDIPP |
| 9741 | IF (PP22(K).EQ.CZERO) THEN |
| 9742 | PPTMP1 = CZERO |
| 9743 | PPTMP2 = CZERO |
| 9744 | ELSE |
| 9745 | PPTMP1 = PP22(K)**(ONE-DIALPH-DIGAMM) |
| 9746 | PPTMP2 = PP22(K)**(ONE-DIALPH+DIGAMM) |
| 9747 | ENDIF |
| 9748 | AVDIPP = 0.5D0* |
| 9749 | & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) ) |
| 9750 | OMPP22 = OMPP22+AVDIPP |
| 9751 | C OMPP22 = OMPP22+(CONE-PP22(K)) |
| 9752 | AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 ) |
| 9753 | DIPP22 = DIPP22+AVDIPP |
| 9754 | 18 CONTINUE |
| 9755 | |
| 9756 | SPROM = ONE-EXP(SHI) |
| 9757 | SPROB = SPROB+FACM*SPROM |
| 9758 | IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN |
| 9759 | STOTM = DBLE(OMPP11+OMPP22) |
| 9760 | SELAM = DBLE(OMPP11*DCONJG(OMPP22)) |
| 9761 | SQEPM = DBLE(OMPP11*DCONJG(OMPP21))-SELAM |
| 9762 | SQETM = DBLE(OMPP11*DCONJG(OMPP12))-SELAM |
| 9763 | SQE2M = DBLE(OMPP11*DCONJG(OMPP11))-SELAM-SQEPM-SQETM |
| 9764 | SDELM = DBLE(DIPP11*DCONJG(DIPP22)) |
| 9765 | SDQEM = DBLE(DIPP11*DCONJG(DIPP21))-SDELM |
| 9766 | STOTB = STOTB+FACM*STOTM |
| 9767 | SELAB = SELAB+FACM*SELAM |
| 9768 | SDELB = SDELB+FACM*SDELM |
| 9769 | IF (NB.GT.1) THEN |
| 9770 | SQEPB = SQEPB+FACM*SQEPM |
| 9771 | SDQEB = SDQEB+FACM*SDQEM |
| 9772 | ENDIF |
| 9773 | IF (NA.GT.1) SQETB = SQETB+FACM*SQETM |
| 9774 | IF ((NA.GT.1).AND.(NB.GT.1)) SQE2B = SQE2B+FACM*SQE2M |
| 9775 | IF (IJPROJ.EQ.7) SDIR = SDIR+FACM*SIGMVD |
| 9776 | ENDIF |
| 9777 | |
| 9778 | 14 CONTINUE |
| 9779 | |
| 9780 | STOTN = STOTN+FACB*STOTB |
| 9781 | SELAN = SELAN+FACB*SELAB |
| 9782 | SQEPN = SQEPN+FACB*SQEPB |
| 9783 | SQETN = SQETN+FACB*SQETB |
| 9784 | SQE2N = SQE2N+FACB*SQE2B |
| 9785 | SPRON = SPRON+FACB*SPROB |
| 9786 | SDELN = SDELN+FACB*SDELB |
| 9787 | SDQEN = SDQEN+FACB*SDQEB |
| 9788 | |
| 9789 | IF (IJPROJ.EQ.7) THEN |
| 9790 | BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*(STOTB-SELAB-SQEPB) |
| 9791 | ELSE |
| 9792 | IF (DIBETA.GT.ZERO) THEN |
| 9793 | BPROD(IB+1)= BPROD(IB+1) |
| 9794 | & +FACN*FACB*(STOTB-SELAB-SQEPB-SQETB-SQE2B) |
| 9795 | ELSE |
| 9796 | BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*SPROB |
| 9797 | ENDIF |
| 9798 | ENDIF |
| 9799 | |
| 9800 | 12 CONTINUE |
| 9801 | |
| 9802 | STOT = STOT +FACN*STOTN |
| 9803 | STOT2 = STOT2+FACN*STOTN**2 |
| 9804 | SELA = SELA +FACN*SELAN |
| 9805 | SELA2 = SELA2+FACN*SELAN**2 |
| 9806 | SQEP = SQEP +FACN*SQEPN |
| 9807 | SQEP2 = SQEP2+FACN*SQEPN**2 |
| 9808 | SQET = SQET +FACN*SQETN |
| 9809 | SQET2 = SQET2+FACN*SQETN**2 |
| 9810 | SQE2 = SQE2 +FACN*SQE2N |
| 9811 | SQE22 = SQE22+FACN*SQE2N**2 |
| 9812 | SPRO = SPRO +FACN*SPRON |
| 9813 | SPRO2 = SPRO2+FACN*SPRON**2 |
| 9814 | SDEL = SDEL +FACN*SDELN |
| 9815 | SDEL2 = SDEL2+FACN*SDELN**2 |
| 9816 | SDQE = SDQE +FACN*SDQEN |
| 9817 | SDQE2 = SDQE2+FACN*SDQEN**2 |
| 9818 | |
| 9819 | 11 CONTINUE |
| 9820 | |
| 9821 | * final cross sections |
| 9822 | * 1) total |
| 9823 | XSTOT(IE,IQ,NTARG) = STOT |
| 9824 | IF (IJPROJ.EQ.7) |
| 9825 | & XSTOT(IE,IQ,NTARG) = XSTOT(IE,IQ,NTARG)+DBLE(NB)*SDIR |
| 9826 | * 2) elastic |
| 9827 | XSELA(IE,IQ,NTARG) = SELA |
| 9828 | * 3) quasi-el.: A+B-->A+X (excluding 2) |
| 9829 | XSQEP(IE,IQ,NTARG) = SQEP |
| 9830 | * 4) quasi-el.: A+B-->X+B (excluding 2) |
| 9831 | XSQET(IE,IQ,NTARG) = SQET |
| 9832 | * 5) quasi-el.: A+B-->X (excluding 2-4) |
| 9833 | XSQE2(IE,IQ,NTARG) = SQE2 |
| 9834 | * 6) production (= STOT-SELA-SQEP-SQET-SQE2!) |
| 9835 | IF (SDEL.GT.ZERO) THEN |
| 9836 | XSPRO(IE,IQ,NTARG) = STOT-SELA-SQEP-SQET-SQE2 |
| 9837 | ELSE |
| 9838 | XSPRO(IE,IQ,NTARG) = SPRO |
| 9839 | ENDIF |
| 9840 | * 7) projectile diffraction (el. scatt. off target) |
| 9841 | XSDEL(IE,IQ,NTARG) = SDEL |
| 9842 | * 8) projectile diffraction (quasi-el. scatt. off target) |
| 9843 | XSDQE(IE,IQ,NTARG) = SDQE |
| 9844 | * stat. errors |
| 9845 | XETOT(IE,IQ,NTARG) = SQRT(ABS(STOT2-STOT**2)/DBLE(NSTATB-1)) |
| 9846 | XEELA(IE,IQ,NTARG) = SQRT(ABS(SELA2-SELA**2)/DBLE(NSTATB-1)) |
| 9847 | XEQEP(IE,IQ,NTARG) = SQRT(ABS(SQEP2-SQEP**2)/DBLE(NSTATB-1)) |
| 9848 | XEQET(IE,IQ,NTARG) = SQRT(ABS(SQET2-SQET**2)/DBLE(NSTATB-1)) |
| 9849 | XEQE2(IE,IQ,NTARG) = SQRT(ABS(SQE22-SQE2**2)/DBLE(NSTATB-1)) |
| 9850 | XEPRO(IE,IQ,NTARG) = SQRT(ABS(SPRO2-SPRO**2)/DBLE(NSTATB-1)) |
| 9851 | XEDEL(IE,IQ,NTARG) = SQRT(ABS(SDEL2-SDEL**2)/DBLE(NSTATB-1)) |
| 9852 | XEDQE(IE,IQ,NTARG) = SQRT(ABS(SDQE2-SDQE**2)/DBLE(NSTATB-1)) |
| 9853 | |
| 9854 | IF (IJPROJ.EQ.7) THEN |
| 9855 | BNORM = XSTOT(IE,IQ,NTARG)-XSELA(IE,IQ,NTARG) |
| 9856 | & -XSQEP(IE,IQ,NTARG) |
| 9857 | ELSE |
| 9858 | BNORM = XSPRO(IE,IQ,NTARG) |
| 9859 | ENDIF |
| 9860 | DO 19 I=2,NSITEB |
| 9861 | BSITE(IE,IQ,NTARG,I) = BPROD(I)/BNORM+BSITE(IE,IQ,NTARG,I-1) |
| 9862 | IF ((IE.EQ.1).AND.(IQ.EQ.1)) |
| 9863 | & BSITE(0,1,NTARG,I) = BPROD(I)/BNORM+BSITE(0,1,NTARG,I-1) |
| 9864 | 19 CONTINUE |
| 9865 | |
| 9866 | * write profile function data into file |
| 9867 | IF ((IOGLB.EQ.-1).OR.(IOGLB.EQ.-100)) THEN |
| 9868 | WRITE(LDAT,'(5I10,1P,E15.5)') |
| 9869 | & IJPROJ,NA,NB,NSTATB,NSITEB,ECMNN(IE) |
| 9870 | WRITE(LDAT,'(1P,6E12.5)') |
| 9871 | & XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),XSQEP(IE,IQ,NTARG), |
| 9872 | & XSQET(IE,IQ,NTARG),XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG) |
| 9873 | WRITE(LDAT,'(1P,6E12.5)') |
| 9874 | & XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),XEQEP(IE,IQ,NTARG), |
| 9875 | & XEQET(IE,IQ,NTARG),XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG) |
| 9876 | NLINES = INT(DBLE(NSITEB)/7.0D0) |
| 9877 | IF (NLINES.GT.0) THEN |
| 9878 | DO 20 I=1,NLINES |
| 9879 | ISTART = 7*I-6 |
| 9880 | WRITE(LDAT,'(1P,7E11.4)') |
| 9881 | & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6) |
| 9882 | 20 CONTINUE |
| 9883 | ENDIF |
| 9884 | ISTART = 7*NLINES+1 |
| 9885 | IF (ISTART.LE.NSITEB) THEN |
| 9886 | WRITE(LDAT,'(1P,7E11.4)') |
| 9887 | & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB) |
| 9888 | ENDIF |
| 9889 | ENDIF |
| 9890 | |
| 9891 | 100 CONTINUE |
| 9892 | |
| 9893 | C IF (ABS(IOGLB).EQ.1) CLOSE(LDAT) |
| 9894 | |
| 9895 | RETURN |
| 9896 | END |
| 9897 | |
| 9898 | *$ CREATE DT_GETBXS.FOR |
| 9899 | *COPY DT_GETBXS |
| 9900 | * |
| 9901 | *===getbxs=============================================================* |
| 9902 | * |
| 9903 | SUBROUTINE DT_GETBXS(XSFRAC,BLO,BHI,NIDX) |
| 9904 | |
| 9905 | ************************************************************************ |
| 9906 | * Biasing in impact parameter space. * |
| 9907 | * XSFRAC = 0 : BLO - minimum impact parameter (input) * |
| 9908 | * BHI - maximum impact parameter (input) * |
| 9909 | * XSFRAC - fraction of cross section corresponding * |
| 9910 | * to impact parameter range (BLO,BHI) * |
| 9911 | * (output) * |
| 9912 | * XSFRAC > 0 : XSFRAC - fraction of cross section (input) * |
| 9913 | * BHI - maximum impact parameter giving requested * |
| 9914 | * fraction of cross section in impact * |
| 9915 | * parameter range (0,BMAX) (output) * |
| 9916 | * This version dated 17.03.00 is written by S. Roesler * |
| 9917 | ************************************************************************ |
| 9918 | |
| 9919 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 9920 | SAVE |
| 9921 | PARAMETER ( LINP = 10 , |
| 9922 | & LOUT = 6 , |
| 9923 | & LDAT = 9 ) |
| 9924 | |
| 9925 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 9926 | * Glauber formalism: parameters |
| 9927 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), |
| 9928 | & BMAX(NCOMPX),BSTEP(NCOMPX), |
| 9929 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), |
| 9930 | & NSITEB,NSTATB |
| 9931 | |
| 9932 | NTARG = ABS(NIDX) |
| 9933 | IF (XSFRAC.LE.0.0D0) THEN |
| 9934 | ILO = MIN(NSITEB-1,INT(BLO/BSTEP(NTARG))) |
| 9935 | IHI = MIN(NSITEB-1,INT(BHI/BSTEP(NTARG))) |
| 9936 | IF (ILO.GE.IHI) THEN |
| 9937 | XSFRAC = 0.0D0 |
| 9938 | RETURN |
| 9939 | ENDIF |
| 9940 | IF (ILO.EQ.NSITEB-1) THEN |
| 9941 | FRCLO = BSITE(0,1,NTARG,NSITEB) |
| 9942 | ELSE |
| 9943 | FRCLO = BSITE(0,1,NTARG,ILO+1) |
| 9944 | & +(BLO-ILO*BSTEP(NTARG))/BSTEP(NTARG) |
| 9945 | & *(BSITE(0,1,NTARG,ILO+2)-BSITE(0,1,NTARG,ILO+1)) |
| 9946 | ENDIF |
| 9947 | IF (IHI.EQ.NSITEB-1) THEN |
| 9948 | FRCHI = BSITE(0,1,NTARG,NSITEB) |
| 9949 | ELSE |
| 9950 | FRCHI = BSITE(0,1,NTARG,IHI+1) |
| 9951 | & +(BHI-IHI*BSTEP(NTARG))/BSTEP(NTARG) |
| 9952 | & *(BSITE(0,1,NTARG,IHI+2)-BSITE(0,1,NTARG,IHI+1)) |
| 9953 | ENDIF |
| 9954 | XSFRAC = FRCHI-FRCLO |
| 9955 | ELSE |
| 9956 | BLO = 0.0D0 |
| 9957 | BHI = BMAX(NTARG) |
| 9958 | DO 1 I=1,NSITEB-1 |
| 9959 | IF (XSFRAC.LT.BSITE(0,1,NTARG,I+1)) THEN |
| 9960 | FAC = (XSFRAC -BSITE(0,1,NTARG,I))/ |
| 9961 | & (BSITE(0,1,NTARG,I+1)-BSITE(0,1,NTARG,I)) |
| 9962 | BHI = DBLE(I-1)*BSTEP(NTARG)+BSTEP(NTARG)*FAC |
| 9963 | GOTO 2 |
| 9964 | ENDIF |
| 9965 | 1 CONTINUE |
| 9966 | 2 CONTINUE |
| 9967 | ENDIF |
| 9968 | |
| 9969 | RETURN |
| 9970 | END |
| 9971 | |
| 9972 | *$ CREATE DT_CONUCL.FOR |
| 9973 | *COPY DT_CONUCL |
| 9974 | * |
| 9975 | *===conucl=============================================================* |
| 9976 | * |
| 9977 | SUBROUTINE DT_CONUCL(X,N,R,MODE) |
| 9978 | |
| 9979 | ************************************************************************ |
| 9980 | * Calculation of coordinates of nucleons within nuclei. * |
| 9981 | * X(3,N) spatial coordinates of nucleons (in fm) (output) * |
| 9982 | * N / R number of nucleons / radius of nucleus (input) * |
| 9983 | * MODE = 0 coordinates not sorted * |
| 9984 | * = 1 coordinates sorted with increasing X(3,i) * |
| 9985 | * = 2 coordinates sorted with decreasing X(3,i) * |
| 9986 | * This version dated 26.10.95 is revised by S. Roesler * |
| 9987 | ************************************************************************ |
| 9988 | |
| 9989 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 9990 | SAVE |
| 9991 | PARAMETER ( LINP = 10 , |
| 9992 | & LOUT = 6 , |
| 9993 | & LDAT = 9 ) |
| 9994 | |
| 9995 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0, |
| 9996 | & ONETHI=ONE/THREE,SQRTWO=1.414213562D0) |
| 9997 | |
| 9998 | PARAMETER (TWOPI = 6.283185307179586454D+00 ) |
| 9999 | |
| 10000 | PARAMETER (NSRT=10) |
| 10001 | DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT) |
| 10002 | DIMENSION X(3,N),XTMP(3,260) |
| 10003 | |
| 10004 | CALL DT_COORDI(XTMP,IDXSRT,ICSRT,N,R) |
| 10005 | |
| 10006 | IF ((MODE.NE.0).AND.(N.GT.4)) THEN |
| 10007 | K = 0 |
| 10008 | DO 1 I=1,NSRT |
| 10009 | IF (MODE.EQ.2) THEN |
| 10010 | ISRT = NSRT+1-I |
| 10011 | ELSE |
| 10012 | ISRT = I |
| 10013 | ENDIF |
| 10014 | K1 = K |
| 10015 | DO 2 J=1,ICSRT(ISRT) |
| 10016 | K = K+1 |
| 10017 | X(1,K) = XTMP(1,IDXSRT(ISRT,J)) |
| 10018 | X(2,K) = XTMP(2,IDXSRT(ISRT,J)) |
| 10019 | X(3,K) = XTMP(3,IDXSRT(ISRT,J)) |
| 10020 | 2 CONTINUE |
| 10021 | IF (ICSRT(ISRT).GT.1) THEN |
| 10022 | I0 = K1+1 |
| 10023 | I1 = K |
| 10024 | CALL DT_SORT(X,N,I0,I1,MODE) |
| 10025 | ENDIF |
| 10026 | 1 CONTINUE |
| 10027 | ELSEIF ((MODE.NE.0).AND.(N.GE.2).AND.(N.LE.4)) THEN |
| 10028 | DO 3 I=1,N |
| 10029 | X(1,I) = XTMP(1,I) |
| 10030 | X(2,I) = XTMP(2,I) |
| 10031 | X(3,I) = XTMP(3,I) |
| 10032 | 3 CONTINUE |
| 10033 | CALL DT_SORT(X,N,1,N,MODE) |
| 10034 | ELSE |
| 10035 | DO 4 I=1,N |
| 10036 | X(1,I) = XTMP(1,I) |
| 10037 | X(2,I) = XTMP(2,I) |
| 10038 | X(3,I) = XTMP(3,I) |
| 10039 | 4 CONTINUE |
| 10040 | ENDIF |
| 10041 | |
| 10042 | RETURN |
| 10043 | END |
| 10044 | |
| 10045 | *$ CREATE DT_COORDI.FOR |
| 10046 | *COPY DT_COORDI |
| 10047 | * |
| 10048 | *===coordi=============================================================* |
| 10049 | * |
| 10050 | SUBROUTINE DT_COORDI(X,IDXSRT,ICSRT,N,R) |
| 10051 | |
| 10052 | ************************************************************************ |
| 10053 | * Calculation of coordinates of nucleons within nuclei. * |
| 10054 | * X(3,N) spatial coordinates of nucleons (in fm) (output) * |
| 10055 | * N / R number of nucleons / radius of nucleus (input) * |
| 10056 | * Based on the original version by Shmakov et al. * |
| 10057 | * This version dated 26.10.95 is revised by S. Roesler * |
| 10058 | ************************************************************************ |
| 10059 | |
| 10060 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 10061 | SAVE |
| 10062 | PARAMETER ( LINP = 10 , |
| 10063 | & LOUT = 6 , |
| 10064 | & LDAT = 9 ) |
| 10065 | |
| 10066 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0, |
| 10067 | & ONETHI=ONE/THREE,SQRTWO=1.414213562D0) |
| 10068 | |
| 10069 | PARAMETER (TWOPI = 6.283185307179586454D+00 ) |
| 10070 | |
| 10071 | LOGICAL LSTART |
| 10072 | |
| 10073 | PARAMETER (NSRT=10) |
| 10074 | DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT) |
| 10075 | DIMENSION X(3,260),WD(4),RD(3) |
| 10076 | |
| 10077 | DATA PDIF/0.545D0/,R2MIN/0.16D0/ |
| 10078 | DATA WD / 0.0D0, 0.178D0, 0.465D0, 1.0D0/ |
| 10079 | DATA RD /2.09D0, 0.935D0, 0.697D0/ |
| 10080 | |
| 10081 | X1SUM = ZERO |
| 10082 | X2SUM = ZERO |
| 10083 | X3SUM = ZERO |
| 10084 | |
| 10085 | IF (N.EQ.1) THEN |
| 10086 | X(1,1) = ZERO |
| 10087 | X(2,1) = ZERO |
| 10088 | X(3,1) = ZERO |
| 10089 | ELSEIF (N.EQ.2) THEN |
| 10090 | EPS = DT_RNDM(RD(1)) |
| 10091 | DO 30 I=1,3 |
| 10092 | IF ((EPS.GE.WD(I)).AND.(EPS.LE.WD(I+1))) GOTO 40 |
| 10093 | 30 CONTINUE |
| 10094 | 40 CONTINUE |
| 10095 | DO 50 J=1,3 |
| 10096 | CALL DT_RANNOR(X1,X2) |
| 10097 | X(J,1) = RD(I)*X1 |
| 10098 | X(J,2) = -X(J,1) |
| 10099 | 50 CONTINUE |
| 10100 | ELSEIF ((N.EQ.3).OR.(N.EQ.4)) THEN |
| 10101 | SIGMA = R/SQRTWO |
| 10102 | LSTART = .TRUE. |
| 10103 | CALL DT_RANNOR(X3,X4) |
| 10104 | DO 100 I=1,N |
| 10105 | CALL DT_RANNOR(X1,X2) |
| 10106 | X(1,I) = SIGMA*X1 |
| 10107 | X(2,I) = SIGMA*X2 |
| 10108 | IF (LSTART) GOTO 80 |
| 10109 | X(3,I) = SIGMA*X4 |
| 10110 | CALL DT_RANNOR(X3,X4) |
| 10111 | GOTO 90 |
| 10112 | 80 CONTINUE |
| 10113 | X(3,I) = SIGMA*X3 |
| 10114 | 90 CONTINUE |
| 10115 | LSTART = .NOT.LSTART |
| 10116 | X1SUM = X1SUM+X(1,I) |
| 10117 | X2SUM = X2SUM+X(2,I) |
| 10118 | X3SUM = X3SUM+X(3,I) |
| 10119 | 100 CONTINUE |
| 10120 | X1SUM = X1SUM/DBLE(N) |
| 10121 | X2SUM = X2SUM/DBLE(N) |
| 10122 | X3SUM = X3SUM/DBLE(N) |
| 10123 | DO 101 I=1,N |
| 10124 | X(1,I) = X(1,I)-X1SUM |
| 10125 | X(2,I) = X(2,I)-X2SUM |
| 10126 | X(3,I) = X(3,I)-X3SUM |
| 10127 | 101 CONTINUE |
| 10128 | ELSE |
| 10129 | |
| 10130 | * maximum nuclear radius for coordinate sampling |
| 10131 | RMAX = R+4.605D0*PDIF |
| 10132 | |
| 10133 | * initialize pre-sorting |
| 10134 | DO 121 I=1,NSRT |
| 10135 | ICSRT(I) = 0 |
| 10136 | 121 CONTINUE |
| 10137 | DR = TWO*RMAX/DBLE(NSRT) |
| 10138 | |
| 10139 | * sample coordinates for N nucleons |
| 10140 | DO 140 I=1,N |
| 10141 | 120 CONTINUE |
| 10142 | RAD = RMAX*(DT_RNDM(DR))**ONETHI |
| 10143 | F = DT_DENSIT(N,RAD,R) |
| 10144 | IF (DT_RNDM(RAD).GT.F) GOTO 120 |
| 10145 | * theta, phi uniformly distributed |
| 10146 | CT = ONE-TWO*DT_RNDM(F) |
| 10147 | ST = SQRT((ONE-CT)*(ONE+CT)) |
| 10148 | CALL DT_DSFECF(SFE,CFE) |
| 10149 | X(1,I) = RAD*ST*CFE |
| 10150 | X(2,I) = RAD*ST*SFE |
| 10151 | X(3,I) = RAD*CT |
| 10152 | * ensure that distance between two nucleons is greater than R2MIN |
| 10153 | IF (I.LT.2) GOTO 122 |
| 10154 | I1 = I-1 |
| 10155 | DO 130 I2=1,I1 |
| 10156 | DIST2 = (X(1,I)-X(1,I2))**2+(X(2,I)-X(2,I2))**2+ |
| 10157 | & (X(3,I)-X(3,I2))**2 |
| 10158 | IF (DIST2.LE.R2MIN) GOTO 120 |
| 10159 | 130 CONTINUE |
| 10160 | 122 CONTINUE |
| 10161 | * save index according to z-bin |
| 10162 | IDXZ = INT( (X(3,I)+RMAX)/DR )+1 |
| 10163 | ICSRT(IDXZ) = ICSRT(IDXZ)+1 |
| 10164 | IDXSRT(IDXZ,ICSRT(IDXZ)) = I |
| 10165 | X1SUM = X1SUM+X(1,I) |
| 10166 | X2SUM = X2SUM+X(2,I) |
| 10167 | X3SUM = X3SUM+X(3,I) |
| 10168 | 140 CONTINUE |
| 10169 | X1SUM = X1SUM/DBLE(N) |
| 10170 | X2SUM = X2SUM/DBLE(N) |
| 10171 | X3SUM = X3SUM/DBLE(N) |
| 10172 | DO 141 I=1,N |
| 10173 | X(1,I) = X(1,I)-X1SUM |
| 10174 | X(2,I) = X(2,I)-X2SUM |
| 10175 | X(3,I) = X(3,I)-X3SUM |
| 10176 | 141 CONTINUE |
| 10177 | |
| 10178 | ENDIF |
| 10179 | |
| 10180 | RETURN |
| 10181 | END |
| 10182 | |
| 10183 | *$ CREATE DT_DENSIT.FOR |
| 10184 | *COPY DT_DENSIT |
| 10185 | * |
| 10186 | *===densit=============================================================* |
| 10187 | * |
| 10188 | DOUBLE PRECISION FUNCTION DT_DENSIT(NA,R,RA) |
| 10189 | |
| 10190 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 10191 | SAVE |
| 10192 | |
| 10193 | PARAMETER ( LINP = 10 , |
| 10194 | & LOUT = 6 , |
| 10195 | & LDAT = 9 ) |
| 10196 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) |
| 10197 | PARAMETER (TWOPI = 6.283185307179586476925286766559D+00, |
| 10198 | & PI = TWOPI/TWO) |
| 10199 | |
| 10200 | DIMENSION R0(18),FNORM(18) |
| 10201 | DATA R0 / ZERO, ZERO, ZERO, ZERO, 2.12D0, |
| 10202 | & 2.56D0, 2.41D0, 2.46D0, 2.52D0, 2.45D0, |
| 10203 | & 2.37D0, 2.46D0, 2.44D0, 2.54D0, 2.58D0, |
| 10204 | & 2.72D0, 2.66D0, 2.79D0/ |
| 10205 | DATA FNORM /.1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01, |
| 10206 | & .1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01, |
| 10207 | & .1012D+01,.1039D+01,.1075D+01,.1118D+01,.1164D+01, |
| 10208 | & .1214D+01,.1265D+01,.1318D+01/ |
| 10209 | DATA PDIF /0.545D0/ |
| 10210 | |
| 10211 | DT_DENSIT = ZERO |
| 10212 | * shell model |
| 10213 | IF (NA.LE.4) THEN |
| 10214 | STOP 'DT_DENSIT-0' |
| 10215 | ELSEIF ((NA.GT.4).AND.(NA.LE.18)) THEN |
| 10216 | R1 = R0(NA)/SQRT(2.5D0-4.0D0/DBLE(NA)) |
| 10217 | DT_DENSIT = (ONE+(DBLE(NA)-4.0D0)/6.0D0*(R/R1)**2) |
| 10218 | & *EXP(-(R/R1)**2)/FNORM(NA) |
| 10219 | * Woods-Saxon |
| 10220 | ELSEIF (NA.GT.18) THEN |
| 10221 | DT_DENSIT = ONE/(ONE+EXP((R-RA)/PDIF)) |
| 10222 | ENDIF |
| 10223 | |
| 10224 | RETURN |
| 10225 | END |
| 10226 | |
| 10227 | *$ CREATE DT_RNCLUS.FOR |
| 10228 | *COPY DT_RNCLUS |
| 10229 | * |
| 10230 | *===rnclus=============================================================* |
| 10231 | * |
| 10232 | DOUBLE PRECISION FUNCTION DT_RNCLUS(N) |
| 10233 | |
| 10234 | ************************************************************************ |
| 10235 | * Nuclear radius for nucleus with mass number N. * |
| 10236 | * This version dated 26.9.00 is written by S. Roesler * |
| 10237 | ************************************************************************ |
| 10238 | |
| 10239 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 10240 | SAVE |
| 10241 | |
| 10242 | PARAMETER (ONE=1.0D0,THREE=3.0D0,ONETHI=ONE/THREE) |
| 10243 | |
| 10244 | * nucleon radius |
| 10245 | PARAMETER (RNUCLE = 1.12D0) |
| 10246 | |
| 10247 | * nuclear radii for selected nuclei |
| 10248 | DIMENSION RADNUC(18) |
| 10249 | DATA RADNUC / 8*0.0D0,2.52D0,2.45D0,2.37D0,2.45D0,2.44D0,2.55D0, |
| 10250 | & 2.58D0,2.71D0,2.66D0,2.71D0/ |
| 10251 | |
| 10252 | IF (N.LE.18) THEN |
| 10253 | IF (RADNUC(N).GT.0.0D0) THEN |
| 10254 | DT_RNCLUS = RADNUC(N) |
| 10255 | ELSE |
| 10256 | DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI |
| 10257 | ENDIF |
| 10258 | ELSE |
| 10259 | DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI |
| 10260 | ENDIF |
| 10261 | |
| 10262 | RETURN |
| 10263 | END |
| 10264 | |
| 10265 | *$ CREATE DT_DENTST.FOR |
| 10266 | *COPY DT_DENTST |
| 10267 | * |
| 10268 | *===dentst=============================================================* |
| 10269 | * |
| 10270 | C PROGRAM DT_DENTST |
| 10271 | SUBROUTINE DT_DENTST |
| 10272 | |
| 10273 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 10274 | SAVE |
| 10275 | |
| 10276 | OPEN(40,FILE='dentst.out',STATUS='UNKNOWN') |
| 10277 | OPEN(41,FILE='denmax.out',STATUS='UNKNOWN') |
| 10278 | |
| 10279 | RMIN = 0.0D0 |
| 10280 | RMAX = 8.0D0 |
| 10281 | NBINS = 500.0D0 |
| 10282 | DR = (RMAX-RMIN)/DBLE(NBINS) |
| 10283 | DO 1 IA=5,18 |
| 10284 | FMAX = 0.0D0 |
| 10285 | DO 2 IR=1,NBINS+1 |
| 10286 | R = RMIN+DBLE(IR-1)*DR |
| 10287 | F = DT_DENSIT(IA,R,R) |
| 10288 | IF (F.GT.FMAX) FMAX = F |
| 10289 | WRITE(40,'(1X,I3,2E15.5)') IA,R,F |
| 10290 | 2 CONTINUE |
| 10291 | WRITE(41,'(1X,I3,E15.5)') IA,FMAX |
| 10292 | 1 CONTINUE |
| 10293 | |
| 10294 | CLOSE(40) |
| 10295 | CLOSE(41) |
| 10296 | |
| 10297 | END |
| 10298 | |
| 10299 | *$ CREATE DT_SHMAKI.FOR |
| 10300 | *COPY DT_SHMAKI |
| 10301 | * |
| 10302 | *===shmaki=============================================================* |
| 10303 | * |
| 10304 | SUBROUTINE DT_SHMAKI(NA,NCA,NB,NCB,IJP,PPN,MODE) |
| 10305 | |
| 10306 | ************************************************************************ |
| 10307 | * Initialisation of Glauber formalism. This subroutine has to be * |
| 10308 | * called once (in case of target emulsions as often as many different * |
| 10309 | * target nuclei are considered) before events are sampled. * |
| 10310 | * NA / NCA mass number/charge of projectile nucleus * |
| 10311 | * NB / NCB mass number/charge of target nucleus * |
| 10312 | * IJP identity of projectile (hadrons/leptons/photons) * |
| 10313 | * PPN projectile momentum (for projectile nuclei: * |
| 10314 | * momentum per nucleon) in target rest system * |
| 10315 | * MODE = 0 Glauber formalism invoked * |
| 10316 | * = 1 fitted results are loaded from data-file * |
| 10317 | * = 99 NTARG is forced to be 1 * |
| 10318 | * (used in connection with GLAUBERI-card only) * |
| 10319 | * This version dated 22.03.96 is based on the original SHMAKI-routine * |
| 10320 | * and revised by S. Roesler. * |
| 10321 | ************************************************************************ |
| 10322 | |
| 10323 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 10324 | SAVE |
| 10325 | PARAMETER ( LINP = 10 , |
| 10326 | & LOUT = 6 , |
| 10327 | & LDAT = 9 ) |
| 10328 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0, |
| 10329 | & THREE=3.0D0) |
| 10330 | |
| 10331 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 10332 | * Glauber formalism: parameters |
| 10333 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), |
| 10334 | & BMAX(NCOMPX),BSTEP(NCOMPX), |
| 10335 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), |
| 10336 | & NSITEB,NSTATB |
| 10337 | * Lorentz-parameters of the current interaction |
| 10338 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, |
| 10339 | & UMO,PPCM,EPROJ,PPROJ |
| 10340 | * properties of photon/lepton projectiles |
| 10341 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC |
| 10342 | * kinematical cuts for lepton-nucleus interactions |
| 10343 | COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX, |
| 10344 | & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI |
| 10345 | * Glauber formalism: cross sections |
| 10346 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, |
| 10347 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), |
| 10348 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), |
| 10349 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), |
| 10350 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), |
| 10351 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), |
| 10352 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), |
| 10353 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), |
| 10354 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), |
| 10355 | & BSLOPE,NEBINI,NQBINI |
| 10356 | * cuts for variable energy runs |
| 10357 | COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI |
| 10358 | * nucleon-nucleon event-generator |
| 10359 | CHARACTER*8 CMODEL |
| 10360 | LOGICAL LPHOIN |
| 10361 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN |
| 10362 | * Glauber formalism: flags and parameters for statistics |
| 10363 | LOGICAL LPROD |
| 10364 | CHARACTER*8 CGLB |
| 10365 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD |
| 10366 | |
| 10367 | DATA NTARG,ICOUT,IVEOUT /0,0,0/ |
| 10368 | |
| 10369 | C CALL DT_HISHAD |
| 10370 | C STOP |
| 10371 | |
| 10372 | NTARG = NTARG+1 |
| 10373 | IF (MODE.EQ.99) NTARG = 1 |
| 10374 | NIDX = -NTARG |
| 10375 | IF (MODE.EQ.-1) NIDX = NTARG |
| 10376 | |
| 10377 | IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) ICOUT = ICOUT+1 |
| 10378 | IF (ICOUT.EQ.1) WRITE(LOUT,1000) |
| 10379 | 1000 FORMAT(//,1X,'SHMAKI: Glauber formalism (Shmakov et. al) -', |
| 10380 | & ' initialization',/,12X,'--------------------------', |
| 10381 | & '-------------------------',/) |
| 10382 | |
| 10383 | IF (MODE.EQ.2) THEN |
| 10384 | CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX) |
| 10385 | CALL DT_SHFAST(MODE,PPN,IBACK) |
| 10386 | STOP ' Glauber pre-initialization done' |
| 10387 | ENDIF |
| 10388 | IF (MODE.EQ.1) THEN |
| 10389 | CALL DT_PROFBI(NA,NB,PPN,NTARG) |
| 10390 | ELSE |
| 10391 | IBACK = 1 |
| 10392 | IF (MODE.EQ.3) CALL DT_SHFAST(MODE,PPN,IBACK) |
| 10393 | IF (IBACK.EQ.1) THEN |
| 10394 | * lepton-nucleus (variable energy runs) |
| 10395 | IF ((IJP.EQ. 3).OR.(IJP.EQ. 4).OR. |
| 10396 | & (IJP.EQ.10).OR.(IJP.EQ.11)) THEN |
| 10397 | IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) |
| 10398 | & WRITE(LOUT,1002) NB,NCB |
| 10399 | 1002 FORMAT(1X,'variable energy run: projectile-id: 7', |
| 10400 | & ' target A/Z: ',I3,' /',I3,/,/,8X, |
| 10401 | & 'E_cm (GeV) Q^2 (GeV^2)', |
| 10402 | & ' Sigma_tot (mb) Sigma_in (mb)',/,7X, |
| 10403 | & '--------------------------------', |
| 10404 | & '------------------------------') |
| 10405 | AECMLO = LOG10(MIN(UMO,ECMLI)) |
| 10406 | AECMHI = LOG10(MIN(UMO,ECMHI)) |
| 10407 | IESTEP = NEB-1 |
| 10408 | DAECM = (AECMHI-AECMLO)/DBLE(IESTEP) |
| 10409 | IF (AECMLO.EQ.AECMHI) IESTEP = 0 |
| 10410 | DO 1 I=1,IESTEP+1 |
| 10411 | ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM) |
| 10412 | IF (Q2HI.GT.0.1D0) THEN |
| 10413 | IF (Q2LI.LT.0.01D0) THEN |
| 10414 | CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX) |
| 10415 | IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) |
| 10416 | & WRITE(LOUT,1003) |
| 10417 | & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG) |
| 10418 | Q2LI = 0.01D0 |
| 10419 | IBIN = 2 |
| 10420 | ELSE |
| 10421 | IBIN = 1 |
| 10422 | ENDIF |
| 10423 | IQSTEP = NQB-IBIN |
| 10424 | AQ2LO = LOG10(Q2LI) |
| 10425 | AQ2HI = LOG10(Q2HI) |
| 10426 | DAQ2 = (AQ2HI-AQ2LO)/MAX(DBLE(IQSTEP),ONE) |
| 10427 | DO 2 J=IBIN,IQSTEP+IBIN |
| 10428 | Q2 = 10.0D0**(AQ2LO+DBLE(J-IBIN)*DAQ2) |
| 10429 | CALL DT_XSGLAU(NA,NB,7,ZERO,Q2,ECM,I,J,NIDX) |
| 10430 | IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) |
| 10431 | & WRITE(LOUT,1003) ECMNN(I), |
| 10432 | & Q2G(J),XSTOT(I,J,NTARG),XSPRO(I,J,NTARG) |
| 10433 | 2 CONTINUE |
| 10434 | ELSE |
| 10435 | CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX) |
| 10436 | IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) |
| 10437 | & WRITE(LOUT,1003) |
| 10438 | & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG) |
| 10439 | ENDIF |
| 10440 | 1003 FORMAT(9X,F6.1,9X,F6.2,8X,F8.3,11X,F8.3) |
| 10441 | 1 CONTINUE |
| 10442 | IVEOUT = 1 |
| 10443 | ELSE |
| 10444 | * hadron/photon/nucleus-nucleus |
| 10445 | IF ((ABS(VAREHI).GT.ZERO).AND. |
| 10446 | & (ABS(VAREHI).GT.ABS(VARELO))) THEN |
| 10447 | IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) THEN |
| 10448 | WRITE(LOUT,1004) NA,NB,NCB |
| 10449 | 1004 FORMAT(1X,'variable energy run: projectile-id:', |
| 10450 | & I3,' target A/Z: ',I3,' /',I3,/) |
| 10451 | WRITE(LOUT,1005) |
| 10452 | 1005 FORMAT(' E_cm (GeV) E_Lab (GeV) sig_tot^pp (mb)' |
| 10453 | & ,' Sigma_tot (mb) Sigma_prod (mb)',/, |
| 10454 | & ' -------------------------------------', |
| 10455 | & '--------------------------------------') |
| 10456 | ENDIF |
| 10457 | AECMLO = LOG10(VARCLO) |
| 10458 | AECMHI = LOG10(VARCHI) |
| 10459 | IESTEP = NEB-1 |
| 10460 | DAECM = (AECMHI-AECMLO)/DBLE(IESTEP) |
| 10461 | IF (AECMLO.EQ.AECMHI) IESTEP = 0 |
| 10462 | DO 3 I=1,IESTEP+1 |
| 10463 | ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM) |
| 10464 | AMP = 0.938D0 |
| 10465 | AMT = 0.938D0 |
| 10466 | AMP2 = AMP**2 |
| 10467 | AMT2 = AMT**2 |
| 10468 | ELAB = (ECM**2-AMP2-AMT2)/(TWO*AMT) |
| 10469 | PLAB = SQRT((ELAB+AMP)*(ELAB-AMP)) |
| 10470 | CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,ECM,I,1,NIDX) |
| 10471 | IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) |
| 10472 | & WRITE(LOUT,1006) |
| 10473 | & ECM,PLAB,SIGSH,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG) |
| 10474 | 1006 FORMAT(1X,F9.1,1X,E11.3,1X,F12.2,8X,F10.3,8X,F8.3) |
| 10475 | 3 CONTINUE |
| 10476 | IVEOUT = 1 |
| 10477 | ELSE |
| 10478 | CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX) |
| 10479 | ENDIF |
| 10480 | ENDIF |
| 10481 | ENDIF |
| 10482 | ENDIF |
| 10483 | |
| 10484 | IF ((ICOUT.LT.15).AND.(IVEOUT.EQ.0).AND.(MCGENE.NE.4).AND. |
| 10485 | & (IOGLB.NE.100)) THEN |
| 10486 | WRITE(LOUT,1001) NA,NCA,NB,NCB,ECMNN(1),SIGSH*10.0D0,ROSH, |
| 10487 | & BSLOPE,NSITEB,NSTATB,XSPRO(1,1,NTARG) |
| 10488 | 1001 FORMAT(38X,'projectile', |
| 10489 | & ' target',/,1X,'Mass number / charge', |
| 10490 | & 17X,I3,' /',I3,6X,I3,' /',I3,/,/,1X, |
| 10491 | & 'Nucleon-nucleon c.m. energy',9X,F10.2,' GeV',/,/,1X, |
| 10492 | & 'Parameters of elastic scattering amplitude:',/,5X, |
| 10493 | & 'sigma =',F7.2,' mb',6X,'rho = ',F9.4,6X,'slope = ', |
| 10494 | & F4.1,' GeV^-2',/,/,1X,'Number of b-steps',4X,I3,8X, |
| 10495 | & 'statistics at each b-step',4X,I5,/,/,1X, |
| 10496 | & 'Prod. cross section ',5X,F10.4,' mb',/) |
| 10497 | ENDIF |
| 10498 | |
| 10499 | RETURN |
| 10500 | END |
| 10501 | |
| 10502 | *$ CREATE DT_PROFBI.FOR |
| 10503 | *COPY DT_PROFBI |
| 10504 | * |
| 10505 | *===profbi=============================================================* |
| 10506 | * |
| 10507 | SUBROUTINE DT_PROFBI(NA,NB,PPN,NTARG) |
| 10508 | |
| 10509 | ************************************************************************ |
| 10510 | * Integral over profile function (to be used for impact-parameter * |
| 10511 | * sampling during event generation). * |
| 10512 | * Fitted results are used. * |
| 10513 | * NA / NB mass numbers of proj./target nuclei * |
| 10514 | * PPN projectile momentum (for projectile nuclei: * |
| 10515 | * momentum per nucleon) in target rest system * |
| 10516 | * NTARG index of target material (i.e. kind of nucleus) * |
| 10517 | * This version dated 31.05.95 is revised by S. Roesler * |
| 10518 | ************************************************************************ |
| 10519 | |
| 10520 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 10521 | SAVE |
| 10522 | PARAMETER ( LINP = 10 , |
| 10523 | & LOUT = 6 , |
| 10524 | & LDAT = 9 ) |
| 454792a9 |
10525 | CPH SAVE |
| 9aaba0d6 |
10526 | |
| 10527 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0) |
| 10528 | |
| 10529 | LOGICAL LSTART |
| 10530 | CHARACTER CNAME*80 |
| 10531 | |
| 10532 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 10533 | * Glauber formalism: parameters |
| 10534 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), |
| 10535 | & BMAX(NCOMPX),BSTEP(NCOMPX), |
| 10536 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), |
| 10537 | & NSITEB,NSTATB |
| 10538 | * Glauber formalism: cross sections |
| 10539 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, |
| 10540 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), |
| 10541 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), |
| 10542 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), |
| 10543 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), |
| 10544 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), |
| 10545 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), |
| 10546 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), |
| 10547 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), |
| 10548 | & BSLOPE,NEBINI,NQBINI |
| 10549 | |
| 10550 | PARAMETER (NGLMAX=8000) |
| 10551 | DIMENSION NGLIT(NGLMAX),NGLIP(NGLMAX),GLAPPN(NGLMAX), |
| 10552 | & GLASIG(NGLMAX),GLAFIT(5,NGLMAX) |
| 10553 | |
| 10554 | DATA LSTART /.TRUE./ |
| 10555 | |
| 10556 | IF (LSTART) THEN |
| 10557 | * read fit-parameters from file |
| 10558 | OPEN(47,FILE='inpdata/glpara.dat',STATUS='UNKNOWN') |
| 10559 | I = 0 |
| 10560 | 1 CONTINUE |
| 10561 | READ(47,'(A80)') CNAME |
| 10562 | IF (CNAME.EQ.'STOP') GOTO 2 |
| 10563 | I = I+1 |
| 10564 | READ(CNAME,*) NGLIP(I),NGLIT(I),GLAPPN(I),GLASIG(I), |
| 10565 | & GLAFIT(1,I),GLAFIT(2,I),GLAFIT(3,I), |
| 10566 | & GLAFIT(4,I),GLAFIT(5,I) |
| 10567 | IF (I+1.GT.NGLMAX) THEN |
| 10568 | WRITE(LOUT,1000) |
| 10569 | 1000 FORMAT(1X,'PROFBI: warning! array size exceeded - ', |
| 10570 | & 'program stopped') |
| 10571 | STOP |
| 10572 | ENDIF |
| 10573 | GOTO 1 |
| 10574 | 2 CONTINUE |
| 10575 | NGLPAR = I |
| 10576 | LSTART = .FALSE. |
| 10577 | ENDIF |
| 10578 | |
| 10579 | NNA = NA |
| 10580 | NNB = NB |
| 10581 | IF (NA.GT.NB) THEN |
| 10582 | NNA = NB |
| 10583 | NNB = NA |
| 10584 | ENDIF |
| 10585 | IDXGLA = 0 |
| 10586 | DO 3 J=1,NGLPAR |
| 10587 | IF ((NNB.LT.NGLIT(J)).OR.(J.EQ.NGLPAR)) THEN |
| 10588 | IF (NNB.NE.NGLIT(J-1)) NNB = NGLIT(J-1) |
| 10589 | DO 4 K=1,J-1 |
| 10590 | IPOINT = J-K |
| 10591 | IF (J.EQ.NGLPAR) IPOINT = J+1-K |
| 10592 | IF ((NNA.GT.NGLIP(IPOINT)).OR. |
| 10593 | & (NNB.NE.NGLIT(IPOINT)).OR.(IPOINT.EQ.1)) THEN |
| 10594 | IF (IPOINT.EQ.1) IPOINT = 0 |
| 10595 | NATMP = NGLIP(IPOINT+1) |
| 10596 | IF (PPN.LT.GLAPPN(IPOINT+1)) THEN |
| 10597 | IDXGLA = IPOINT+1 |
| 10598 | GOTO 6 |
| 10599 | ELSE |
| 10600 | J1BEG = IPOINT+1 |
| 10601 | J1END = J |
| 10602 | C IF (J.EQ.NGLPAR) THEN |
| 10603 | C J1BEG = IPOINT |
| 10604 | C J1END = J |
| 10605 | C ENDIF |
| 10606 | DO 5 J1=J1BEG,J1END |
| 10607 | IF (NGLIP(J1).EQ.NATMP) THEN |
| 10608 | IF (PPN.LT.GLAPPN(J1)) THEN |
| 10609 | IDXGLA = J1 |
| 10610 | GOTO 6 |
| 10611 | ENDIF |
| 10612 | ELSE |
| 10613 | IDXGLA = J1-1 |
| 10614 | GOTO 6 |
| 10615 | ENDIF |
| 10616 | 5 CONTINUE |
| 10617 | IF ((J.EQ.NGLPAR).AND.(PPN.GT.GLAPPN(NGLPAR))) |
| 10618 | & IDXGLA = NGLPAR |
| 10619 | ENDIF |
| 10620 | ENDIF |
| 10621 | 4 CONTINUE |
| 10622 | ENDIF |
| 10623 | 3 CONTINUE |
| 10624 | |
| 10625 | 6 CONTINUE |
| 10626 | IF (IDXGLA.EQ.0) THEN |
| 10627 | WRITE(LOUT,1001) NNA,NNB,PPN |
| 10628 | 1001 FORMAT(1X,'PROFBI: configuration (NA,NB,PPN = ', |
| 10629 | & 2I4,F6.0,') not found ') |
| 10630 | STOP |
| 10631 | ENDIF |
| 10632 | |
| 10633 | * no interpolation yet available |
| 10634 | XSPRO(1,1,NTARG) = GLASIG(IDXGLA) |
| 10635 | |
| 10636 | BSITE(1,1,NTARG,1) = ZERO |
| 10637 | DO 10 I=2,NSITEB |
| 10638 | XX = DBLE(I) |
| 10639 | POLY = GLAFIT(1,IDXGLA)+GLAFIT(2,IDXGLA)*XX+ |
| 10640 | & GLAFIT(3,IDXGLA)*XX**2+GLAFIT(4,IDXGLA)*XX**3+ |
| 10641 | & GLAFIT(5,IDXGLA)*XX**4 |
| 10642 | IF (ABS(POLY).GT.35.0D0) POLY = SIGN(35.0D0,POLY) |
| 10643 | BSITE(1,1,NTARG,I) = (1.0D0-EXP(-POLY)) |
| 10644 | IF (BSITE(1,1,NTARG,I).LT.ZERO) BSITE(1,1,NTARG,I) = ZERO |
| 10645 | 10 CONTINUE |
| 10646 | |
| 10647 | RETURN |
| 10648 | END |
| 10649 | |
| 10650 | *$ CREATE DT_GLAUBE.FOR |
| 10651 | *COPY DT_GLAUBE |
| 10652 | * |
| 10653 | *===glaube=============================================================* |
| 10654 | * |
| 10655 | SUBROUTINE DT_GLAUBE(NA,NB,IJPROJ,B,INTT,INTA,INTB,JS,JT,NIDX) |
| 10656 | |
| 10657 | ************************************************************************ |
| 10658 | * Calculation of configuartion of interacting nucleons for one event. * |
| 10659 | * NB / NB mass numbers of proj./target nuclei (input) * |
| 10660 | * B impact parameter (output) * |
| 10661 | * INTT total number of wounded nucleons " * |
| 10662 | * INTA / INTB number of wounded nucleons in proj. / target " * |
| 10663 | * JS / JT(i) number of collisions proj. / target nucleon i is * |
| 10664 | * involved (output) * |
| 10665 | * NIDX index of projectile/target material (input) * |
| 10666 | * = -2 call within FLUKA transport calculation * |
| 10667 | * This is an update of the original routine SHMAKO by J.Ranft/HJM * |
| 10668 | * This version dated 22.03.96 is revised by S. Roesler * |
| 10669 | * * |
| 10670 | * Last change 27.12.2006 by S. Roesler. * |
| 10671 | ************************************************************************ |
| 10672 | |
| 10673 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 10674 | SAVE |
| 10675 | PARAMETER ( LINP = 10 , |
| 10676 | & LOUT = 6 , |
| 10677 | & LDAT = 9 ) |
| 10678 | PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14, |
| 10679 | & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0) |
| 10680 | |
| 10681 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 10682 | PARAMETER ( MAXNCL = 260, |
| 10683 | & MAXVQU = MAXNCL, |
| 10684 | & MAXSQU = 20*MAXVQU, |
| 10685 | & MAXINT = MAXVQU+MAXSQU) |
| 10686 | * Glauber formalism: parameters |
| 10687 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), |
| 10688 | & BMAX(NCOMPX),BSTEP(NCOMPX), |
| 10689 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), |
| 10690 | & NSITEB,NSTATB |
| 10691 | * Glauber formalism: cross sections |
| 10692 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, |
| 10693 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), |
| 10694 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), |
| 10695 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), |
| 10696 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), |
| 10697 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), |
| 10698 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), |
| 10699 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), |
| 10700 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), |
| 10701 | & BSLOPE,NEBINI,NQBINI |
| 10702 | * Lorentz-parameters of the current interaction |
| 10703 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, |
| 10704 | & UMO,PPCM,EPROJ,PPROJ |
| 10705 | * properties of photon/lepton projectiles |
| 10706 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC |
| 10707 | * Glauber formalism: collision properties |
| 10708 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, |
| 10709 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC |
| 10710 | * Glauber formalism: flags and parameters for statistics |
| 10711 | LOGICAL LPROD |
| 10712 | CHARACTER*8 CGLB |
| 10713 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD |
| 10714 | |
| 10715 | DIMENSION JS(MAXNCL),JT(MAXNCL) |
| 10716 | |
| 10717 | NTARG = ABS(NIDX) |
| 10718 | |
| 10719 | * get actual energy from /DTLTRA/ |
| 10720 | ECMNOW = UMO |
| 10721 | Q2 = VIRT |
| 10722 | * |
| 10723 | * new patch for pre-initialized variable projectile/target/energy runs, |
| 10724 | * bypassed for use within FLUKA (Nidx=-2) |
| 10725 | IF (IOGLB.EQ.100) THEN |
| 10726 | IF (NIDX.NE.-2) CALL DT_GLBSET(IJPROJ,NA,NB,EPROJ,1) |
| 10727 | * |
| 10728 | * variable energy run, interpolate profile function |
| 10729 | ELSE |
| 10730 | I1 = 1 |
| 10731 | I2 = 1 |
| 10732 | RATE = ONE |
| 10733 | IF (NEBINI.GT.1) THEN |
| 10734 | IF (ECMNOW.GE.ECMNN(NEBINI)) THEN |
| 10735 | I1 = NEBINI |
| 10736 | I2 = NEBINI |
| 10737 | RATE = ONE |
| 10738 | ELSEIF (ECMNOW.GT.ECMNN(1)) THEN |
| 10739 | DO 1 I=2,NEBINI |
| 10740 | IF (ECMNOW.LT.ECMNN(I)) THEN |
| 10741 | I1 = I-1 |
| 10742 | I2 = I |
| 10743 | RATE = (ECMNOW-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1)) |
| 10744 | GOTO 2 |
| 10745 | ENDIF |
| 10746 | 1 CONTINUE |
| 10747 | 2 CONTINUE |
| 10748 | ENDIF |
| 10749 | ENDIF |
| 10750 | J1 = 1 |
| 10751 | J2 = 1 |
| 10752 | RATQ = ONE |
| 10753 | IF (NQBINI.GT.1) THEN |
| 10754 | IF (Q2.GE.Q2G(NQBINI)) THEN |
| 10755 | J1 = NQBINI |
| 10756 | J2 = NQBINI |
| 10757 | RATQ = ONE |
| 10758 | ELSEIF (Q2.GT.Q2G(1)) THEN |
| 10759 | DO 3 I=2,NQBINI |
| 10760 | IF (Q2.LT.Q2G(I)) THEN |
| 10761 | J1 = I-1 |
| 10762 | J2 = I |
| 10763 | RATQ = LOG10( Q2/MAX(Q2G(J1),TINY14))/ |
| 10764 | & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14)) |
| 10765 | C RATQ = (Q2-Q2G(J1))/(Q2G(J2)-Q2G(J1)) |
| 10766 | GOTO 4 |
| 10767 | ENDIF |
| 10768 | 3 CONTINUE |
| 10769 | 4 CONTINUE |
| 10770 | ENDIF |
| 10771 | ENDIF |
| 10772 | |
| 10773 | DO 5 I=1,KSITEB |
| 10774 | BSITE(0,1,NTARG,I) = BSITE(I1,J1,NTARG,I)+ |
| 10775 | & RATE*(BSITE(I2,J1,NTARG,I)-BSITE(I1,J1,NTARG,I))+ |
| 10776 | & RATQ*(BSITE(I1,J2,NTARG,I)-BSITE(I1,J1,NTARG,I))+ |
| 10777 | & RATE*RATQ*(BSITE(I2,J2,NTARG,I)-BSITE(I1,J2,NTARG,I)+ |
| 10778 | & BSITE(I1,J1,NTARG,I)-BSITE(I2,J1,NTARG,I)) |
| 10779 | 5 CONTINUE |
| 10780 | ENDIF |
| 10781 | |
| 10782 | CALL DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,INTT,INTA,INTB,IDIREC,NIDX) |
| 10783 | IF (NIDX.LE.-1) THEN |
| 10784 | RPROJ = RASH(1) |
| 10785 | RTARG = RBSH(NTARG) |
| 10786 | ELSE |
| 10787 | RPROJ = RASH(NTARG) |
| 10788 | RTARG = RBSH(1) |
| 10789 | ENDIF |
| 10790 | |
| 10791 | RETURN |
| 10792 | END |
| 10793 | |
| 10794 | *$ CREATE DT_DIAGR.FOR |
| 10795 | *COPY DT_DIAGR |
| 10796 | * |
| 10797 | *===diagr==============================================================* |
| 10798 | * |
| 10799 | SUBROUTINE DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,JNT,INTA,INTB,IDIREC, |
| 10800 | & NIDX) |
| 10801 | |
| 10802 | ************************************************************************ |
| 10803 | * Based on the original version by Shmakov et al. * |
| 10804 | * This version dated 21.04.95 is revised by S. Roesler * |
| 10805 | ************************************************************************ |
| 10806 | |
| 10807 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 10808 | SAVE |
| 10809 | PARAMETER ( LINP = 10 , |
| 10810 | & LOUT = 6 , |
| 10811 | & LDAT = 9 ) |
| 10812 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) |
| 10813 | PARAMETER (TWOPI = 6.283185307179586454D+00, |
| 10814 | & PI = TWOPI/TWO, |
| 10815 | & GEV2MB = 0.38938D0, |
| 10816 | & GEV2FM = 0.1972D0, |
| 10817 | & ALPHEM = ONE/137.0D0, |
| 10818 | * proton mass |
| 10819 | & AMP = 0.938D0, |
| 10820 | & AMP2 = AMP**2, |
| 10821 | * rho0 mass |
| 10822 | & AMRHO0 = 0.77D0) |
| 10823 | |
| 10824 | COMPLEX*16 C,CA,CI |
| 10825 | PARAMETER ( MAXNCL = 260, |
| 10826 | & MAXVQU = MAXNCL, |
| 10827 | & MAXSQU = 20*MAXVQU, |
| 10828 | & MAXINT = MAXVQU+MAXSQU) |
| 10829 | * particle properties (BAMJET index convention) |
| 10830 | CHARACTER*8 ANAME |
| 10831 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 10832 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 10833 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 10834 | * emulsion treatment |
| 10835 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), |
| 10836 | & NCOMPO,IEMUL |
| 10837 | * Glauber formalism: parameters |
| 10838 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), |
| 10839 | & BMAX(NCOMPX),BSTEP(NCOMPX), |
| 10840 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), |
| 10841 | & NSITEB,NSTATB |
| 10842 | * Glauber formalism: cross sections |
| 10843 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, |
| 10844 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), |
| 10845 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), |
| 10846 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), |
| 10847 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), |
| 10848 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), |
| 10849 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), |
| 10850 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), |
| 10851 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), |
| 10852 | & BSLOPE,NEBINI,NQBINI |
| 10853 | * VDM parameter for photon-nucleus interactions |
| 10854 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) |
| 10855 | * nucleon-nucleon event-generator |
| 10856 | CHARACTER*8 CMODEL |
| 10857 | LOGICAL LPHOIN |
| 10858 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN |
| 10859 | **PHOJET105a |
| 10860 | C COMMON /CUTOFF/ PTCUT(4),CUTMU(4),FPS(4),FPH(4),PSOMIN,XSOMIN |
| 10861 | **PHOJET112 |
| 10862 | C obsolete cut-off information |
| 10863 | DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN |
| 10864 | COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN |
| 10865 | ** |
| 10866 | * coordinates of nucleons |
| 10867 | COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL) |
| 10868 | * interface between Glauber formalism and DPM |
| 10869 | COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL), |
| 10870 | & INTER1(MAXINT),INTER2(MAXINT) |
| 10871 | * statistics: Glauber-formalism |
| 10872 | COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB |
| 10873 | * n-n cross section fluctuations |
| 10874 | PARAMETER (NBINS = 1000) |
| 10875 | COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT |
| 10876 | |
| 10877 | DIMENSION JS(MAXNCL),JT(MAXNCL), |
| 10878 | & JS0(MAXNCL),JT0(MAXNCL,MAXNCL), |
| 10879 | & JI1(MAXNCL,MAXNCL),JI2(MAXNCL,MAXNCL),JNT0(MAXNCL) |
| 10880 | DIMENSION NWA(0:210),NWB(0:210) |
| 10881 | |
| 10882 | LOGICAL LFIRST |
| 10883 | DATA LFIRST /.TRUE./ |
| 10884 | |
| 10885 | DATA NTARGO,ICNT /0,0/ |
| 10886 | |
| 10887 | NTARG = ABS(NIDX) |
| 10888 | |
| 10889 | IF (LFIRST) THEN |
| 10890 | LFIRST = .FALSE. |
| 10891 | IF (NCOMPO.EQ.0) THEN |
| 10892 | NCALL = 0 |
| 10893 | NWAMAX = NA |
| 10894 | NWBMAX = NB |
| 10895 | DO 17 I=0,210 |
| 10896 | NWA(I) = 0 |
| 10897 | NWB(I) = 0 |
| 10898 | 17 CONTINUE |
| 10899 | ENDIF |
| 10900 | ENDIF |
| 10901 | IF (NTARG.EQ.-1) THEN |
| 10902 | IF (NCOMPO.EQ.0) THEN |
| 10903 | WRITE(LOUT,*) ' DIAGR: distribution of wounded nucleons' |
| 10904 | WRITE(LOUT,'(8X,A,3I7)') 'NCALL,NWAMAX,NWBMAX = ', |
| 10905 | & NCALL,NWAMAX,NWBMAX |
| 10906 | DO 18 I=1,MAX(NWAMAX,NWBMAX) |
| 10907 | WRITE(LOUT,'(8X,2I7,E12.4,I7,E12.4)') |
| 10908 | & I,NWA(I),DBLE(NWA(I))/DBLE(NCALL), |
| 10909 | & NWB(I),DBLE(NWB(I))/DBLE(NCALL) |
| 10910 | 18 CONTINUE |
| 10911 | ENDIF |
| 10912 | RETURN |
| 10913 | ENDIF |
| 10914 | |
| 10915 | DCOH = 1.0D10 |
| 10916 | IPNT = 0 |
| 10917 | |
| 10918 | SQ2 = Q2 |
| 10919 | IF (SQ2.LE.ZERO) SQ2 = 0.0001D0 |
| 10920 | S = ECMNOW**2 |
| 10921 | X = SQ2/(S+SQ2-AMP2) |
| 10922 | XNU = (S+SQ2-AMP2)/(TWO*AMP) |
| 10923 | * photon projectiles: recalculate photon-nucleon amplitude |
| 10924 | IF (IJPROJ.EQ.7) THEN |
| 10925 | 15 CONTINUE |
| 10926 | * VDM assumption: mass of V-meson |
| 10927 | AMV2 = DT_SAM2(SQ2,ECMNOW) |
| 10928 | AMV = SQRT(AMV2) |
| 10929 | IF (AMV.GT.2.0D0*PTCUT(1)) GOTO 15 |
| 10930 | * check for pointlike interaction |
| 10931 | CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,1) |
| 10932 | **sr 27.10. |
| 10933 | C SIGSH = DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0 |
| 10934 | SIGSH = (ONE-RPNT)*DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0 |
| 10935 | ** |
| 10936 | ROSH = 0.1D0 |
| 10937 | BSLOPE = 2.0D0*(2.0D0+AMRHO0**2/(AMV2+SQ2) |
| 10938 | & +0.25D0*LOG(S/(AMV2+SQ2))) |
| 10939 | * coherence length |
| 10940 | IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+SQ2)*GEV2FM |
| 10941 | ELSEIF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN |
| 10942 | IF (MCGENE.EQ.2) THEN |
| 10943 | ZERO1 = ZERO |
| 10944 | CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SDUM1,SDUM2,SDUM3, |
| 10945 | & BSLOPE,0) |
| 10946 | ELSE |
| 10947 | BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S)) |
| 10948 | ENDIF |
| 10949 | IF (ECMNOW.LE.3.0D0) THEN |
| 10950 | ROSH = -0.43D0 |
| 10951 | ELSEIF ((ECMNOW.GT.3.0D0).AND.(ECMNOW.LE.50.D0)) THEN |
| 10952 | ROSH = -0.63D0+0.175D0*LOG(ECMNOW) |
| 10953 | ELSEIF (ECMNOW.GT.50.0D0) THEN |
| 10954 | ROSH = 0.1D0 |
| 10955 | ENDIF |
| 10956 | ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP) |
| 10957 | PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) ) |
| 10958 | IF (MCGENE.EQ.2) THEN |
| 10959 | ZERO1 = ZERO |
| 10960 | CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SIGSH,SDUM2,SDUM3, |
| 10961 | & BDUM,0) |
| 10962 | SIGSH = SIGSH/10.0D0 |
| 10963 | ELSE |
| 10964 | C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0 |
| 10965 | DUMZER = ZERO |
| 10966 | CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL) |
| 10967 | SIGSH = SIGSH/10.0D0 |
| 10968 | ENDIF |
| 10969 | ELSE |
| 10970 | BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S)) |
| 10971 | ROSH = 0.01D0 |
| 10972 | ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP) |
| 10973 | PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) ) |
| 10974 | C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0 |
| 10975 | DUMZER = ZERO |
| 10976 | CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL) |
| 10977 | SIGSH = SIGSH/10.0D0 |
| 10978 | ENDIF |
| 10979 | GSH = 10.0D0/(TWO*BSLOPE*GEV2MB) |
| 10980 | GAM = GSH |
| 10981 | RCA = GAM*SIGSH/TWOPI |
| 10982 | FCA = -ROSH*RCA |
| 10983 | CA = DCMPLX(RCA,FCA) |
| 10984 | CI = DCMPLX(ONE,ZERO) |
| 10985 | |
| 10986 | 16 CONTINUE |
| 10987 | * impact parameter |
| 10988 | IF (MCGENE.NE.3) CALL DT_MODB(B,NIDX) |
| 10989 | |
| 10990 | NTRY = 0 |
| 10991 | 3 CONTINUE |
| 10992 | NTRY = NTRY+1 |
| 10993 | * initializations |
| 10994 | JNT = 0 |
| 10995 | DO 1 I=1,NA |
| 10996 | JS(I) = 0 |
| 10997 | 1 CONTINUE |
| 10998 | DO 2 I=1,NB |
| 10999 | JT(I) = 0 |
| 11000 | 2 CONTINUE |
| 11001 | IF (IJPROJ.EQ.7) THEN |
| 11002 | DO 8 I=1,MAXNCL |
| 11003 | JS0(I) = 0 |
| 11004 | JNT0(I)= 0 |
| 11005 | DO 9 J=1,NB |
| 11006 | JT0(I,J) = 0 |
| 11007 | 9 CONTINUE |
| 11008 | 8 CONTINUE |
| 11009 | ENDIF |
| 11010 | |
| 11011 | * nucleon configuration |
| 11012 | C IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,5).EQ.0)) THEN |
| 11013 | IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,1).EQ.0)) THEN |
| 11014 | C CALL DT_CONUCL(PKOO,NA,RASH,2) |
| 11015 | C CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),1) |
| 11016 | IF (NIDX.LE.-1) THEN |
| 11017 | CALL DT_CONUCL(PKOO,NA,RASH(1),0) |
| 11018 | CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),0) |
| 11019 | ELSE |
| 11020 | CALL DT_CONUCL(PKOO,NA,RASH(NTARG),0) |
| 11021 | CALL DT_CONUCL(TKOO,NB,RBSH(1),0) |
| 11022 | ENDIF |
| 11023 | NTARGO = NTARG |
| 11024 | ENDIF |
| 11025 | ICNT = ICNT+1 |
| 11026 | |
| 11027 | * LEPTO: pick out one struck nucleon |
| 11028 | IF (MCGENE.EQ.3) THEN |
| 11029 | JNT = 1 |
| 11030 | JS(1) = 1 |
| 11031 | IDX = INT(DT_RNDM(X)*NB)+1 |
| 11032 | JT(IDX) = 1 |
| 11033 | B = ZERO |
| 11034 | GOTO 19 |
| 11035 | ENDIF |
| 11036 | |
| 11037 | DO 4 INA=1,NA |
| 11038 | * cross section fluctuations |
| 11039 | AFLUC = ONE |
| 11040 | IF (IFLUCT.EQ.1) THEN |
| 11041 | IFLUK = INT((DT_RNDM(X)+0.001D0)*1000.0D0) |
| 11042 | AFLUC = FLUIXX(IFLUK) |
| 11043 | ENDIF |
| 11044 | KK1 = 1 |
| 11045 | KINT = 1 |
| 11046 | DO 5 INB=1,NB |
| 11047 | * photon-projectile: check for supression by coherence length |
| 11048 | IF (IJPROJ.EQ.7) THEN |
| 11049 | IF (ABS(TKOO(3,INB)-TKOO(3,KK1)).GT.DCOH) THEN |
| 11050 | KK1 = INB |
| 11051 | KINT = KINT+1 |
| 11052 | ENDIF |
| 11053 | ENDIF |
| 11054 | QQ1 = B+TKOO(1,INB)-PKOO(1,INA) |
| 11055 | QQ2 = TKOO(2,INB)-PKOO(2,INA) |
| 11056 | XY = GAM*(QQ1*QQ1+QQ2*QQ2) |
| 11057 | IF (XY.LE.15.0D0) THEN |
| 11058 | C = CI-CA*AFLUC*EXP(-XY) |
| 11059 | AR = DBLE(C) |
| 11060 | AI = DIMAG(C) |
| 11061 | P = AR*AR+AI*AI |
| 11062 | IF (DT_RNDM(XY).GE.P) THEN |
| 11063 | JNT = JNT+1 |
| 11064 | IF (IJPROJ.EQ.7) THEN |
| 11065 | JNT0(KINT) = JNT0(KINT)+1 |
| 11066 | IF (JNT0(KINT).GT.MAXNCL) THEN |
| 11067 | WRITE(LOUT,1001) MAXNCL |
| 11068 | 1001 FORMAT(1X, |
| 11069 | & 'DIAGR: no. of requested interactions', |
| 11070 | & ' exceeds array dimensions ',I4) |
| 11071 | STOP |
| 11072 | ENDIF |
| 11073 | JS0(KINT) = JS0(KINT)+1 |
| 11074 | JT0(KINT,INB) = JT0(KINT,INB)+1 |
| 11075 | JI1(KINT,JNT0(KINT)) = INA |
| 11076 | JI2(KINT,JNT0(KINT)) = INB |
| 11077 | ELSE |
| 11078 | IF (JNT.GT.MAXINT) THEN |
| 11079 | WRITE(LOUT,1000) JNT, MAXINT |
| 11080 | 1000 FORMAT(1X, |
| 11081 | & 'DIAGR: no. of requested interactions (' |
| 11082 | & ,I4,') exceeds array dimensions (',I4,')') |
| 11083 | STOP |
| 11084 | ENDIF |
| 11085 | JS(INA) = JS(INA)+1 |
| 11086 | JT(INB) = JT(INB)+1 |
| 11087 | INTER1(JNT) = INA |
| 11088 | INTER2(JNT) = INB |
| 11089 | ENDIF |
| 11090 | ENDIF |
| 11091 | ENDIF |
| 11092 | 5 CONTINUE |
| 11093 | 4 CONTINUE |
| 11094 | |
| 11095 | IF (JNT.EQ.0) THEN |
| 11096 | IF (NTRY.LT.500) THEN |
| 11097 | GOTO 3 |
| 11098 | ELSE |
| 11099 | C WRITE(6,*) ' new impact parameter required (old= ',B,')' |
| 11100 | GOTO 16 |
| 11101 | ENDIF |
| 11102 | ENDIF |
| 11103 | |
| 11104 | IDIREC = 0 |
| 11105 | IF (IJPROJ.EQ.7) THEN |
| 11106 | K = INT(ONE+DT_RNDM(X)*DBLE(KINT)) |
| 11107 | 10 CONTINUE |
| 11108 | IF (JNT0(K).EQ.0) THEN |
| 11109 | K = K+1 |
| 11110 | IF (K.GT.KINT) K = 1 |
| 11111 | GOTO 10 |
| 11112 | ENDIF |
| 11113 | * supress Glauber-cascade by direct photon processes |
| 11114 | CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,2) |
| 11115 | IF (IPNT.GT.0) THEN |
| 11116 | JNT = 1 |
| 11117 | JS(1) = 1 |
| 11118 | DO 11 INB=1,NB |
| 11119 | JT(INB) = JT0(K,INB) |
| 11120 | IF (JT(INB).GT.0) GOTO 12 |
| 11121 | 11 CONTINUE |
| 11122 | 12 CONTINUE |
| 11123 | INTER1(1) = 1 |
| 11124 | INTER2(1) = INB |
| 11125 | IDIREC = IPNT |
| 11126 | ELSE |
| 11127 | JNT = JNT0(K) |
| 11128 | JS(1) = JS0(K) |
| 11129 | DO 13 INB=1,NB |
| 11130 | JT(INB) = JT0(K,INB) |
| 11131 | 13 CONTINUE |
| 11132 | DO 14 I=1,JNT |
| 11133 | INTER1(I) = JI1(K,I) |
| 11134 | INTER2(I) = JI2(K,I) |
| 11135 | 14 CONTINUE |
| 11136 | ENDIF |
| 11137 | ENDIF |
| 11138 | |
| 11139 | 19 CONTINUE |
| 11140 | INTA = 0 |
| 11141 | INTB = 0 |
| 11142 | DO 6 I=1,NA |
| 11143 | IF (JS(I).NE.0) INTA=INTA+1 |
| 11144 | 6 CONTINUE |
| 11145 | DO 7 I=1,NB |
| 11146 | IF (JT(I).NE.0) INTB=INTB+1 |
| 11147 | 7 CONTINUE |
| 11148 | ICWPG = INTA |
| 11149 | ICWTG = INTB |
| 11150 | ICIG = JNT |
| 11151 | IPGLB = IPGLB+INTA |
| 11152 | ITGLB = ITGLB+INTB |
| 11153 | NGLB = NGLB+1 |
| 11154 | |
| 11155 | IF (NCOMPO.EQ.0) THEN |
| 11156 | NCALL = NCALL+1 |
| 11157 | NWA(INTA) = NWA(INTA)+1 |
| 11158 | NWB(INTB) = NWB(INTB)+1 |
| 11159 | ENDIF |
| 11160 | |
| 11161 | RETURN |
| 11162 | END |
| 11163 | |
| 11164 | *$ CREATE DT_MODB.FOR |
| 11165 | *COPY DT_MODB |
| 11166 | * |
| 11167 | *===modb===============================================================* |
| 11168 | * |
| 11169 | SUBROUTINE DT_MODB(B,NIDX) |
| 11170 | |
| 11171 | ************************************************************************ |
| 11172 | * Sampling of impact parameter of collision. * |
| 11173 | * B impact parameter (output) * |
| 11174 | * NIDX index of projectile/target material (input)* |
| 11175 | * Based on the original version by Shmakov et al. * |
| 11176 | * This version dated 21.04.95 is revised by S. Roesler * |
| 11177 | * * |
| 11178 | * Last change 27.12.2006 by S. Roesler. * |
| 11179 | ************************************************************************ |
| 11180 | |
| 11181 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 11182 | SAVE |
| 11183 | PARAMETER ( LINP = 10 , |
| 11184 | & LOUT = 6 , |
| 11185 | & LDAT = 9 ) |
| 11186 | PARAMETER (ZERO=0.0D0,TINY15=1.0D-15,ONE=1.0D0,TWO=2.0D0) |
| 11187 | |
| 11188 | LOGICAL LEFT,LFIRST |
| 11189 | |
| 11190 | * central particle production, impact parameter biasing |
| 11191 | COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR |
| 11192 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 11193 | * Glauber formalism: parameters |
| 11194 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), |
| 11195 | & BMAX(NCOMPX),BSTEP(NCOMPX), |
| 11196 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), |
| 11197 | & NSITEB,NSTATB |
| 11198 | * Glauber formalism: cross sections |
| 11199 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, |
| 11200 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), |
| 11201 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), |
| 11202 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), |
| 11203 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), |
| 11204 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), |
| 11205 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), |
| 11206 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), |
| 11207 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), |
| 11208 | & BSLOPE,NEBINI,NQBINI |
| 11209 | |
| 11210 | DATA LFIRST /.TRUE./ |
| 11211 | |
| 11212 | NTARG = ABS(NIDX) |
| 11213 | IF (NIDX.LE.-1) THEN |
| 11214 | RA = RASH(1) |
| 11215 | RB = RBSH(NTARG) |
| 11216 | ELSE |
| 11217 | RA = RASH(NTARG) |
| 11218 | RB = RBSH(1) |
| 11219 | ENDIF |
| 11220 | |
| 11221 | IF (ICENTR.EQ.2) THEN |
| 11222 | IF (RA.EQ.RB) THEN |
| 11223 | BB = DT_RNDM(B)*(0.3D0*RA)**2 |
| 11224 | B = SQRT(BB) |
| 11225 | ELSEIF(RA.LT.RB)THEN |
| 11226 | BB = DT_RNDM(B)*1.4D0*(RB-RA)**2 |
| 11227 | B = SQRT(BB) |
| 11228 | ELSEIF(RA.GT.RB)THEN |
| 11229 | BB = DT_RNDM(B)*1.4D0*(RA-RB)**2 |
| 11230 | B = SQRT(BB) |
| 11231 | ENDIF |
| 11232 | ELSE |
| 11233 | 9 CONTINUE |
| 11234 | Y = DT_RNDM(BB) |
| 11235 | I0 = 1 |
| 11236 | I2 = NSITEB |
| 11237 | 10 CONTINUE |
| 11238 | I1 = (I0+I2)/2 |
| 11239 | LEFT = ((BSITE(0,1,NTARG,I0)-Y) |
| 11240 | & *(BSITE(0,1,NTARG,I1)-Y)).LT.ZERO |
| 11241 | IF (LEFT) GOTO 20 |
| 11242 | I0 = I1 |
| 11243 | GOTO 30 |
| 11244 | 20 CONTINUE |
| 11245 | I2 = I1 |
| 11246 | 30 CONTINUE |
| 11247 | IF (I2-I0-2) 40,50,60 |
| 11248 | 40 CONTINUE |
| 11249 | I1 = I2+1 |
| 11250 | IF (I1.GT.NSITEB) I1 = I0-1 |
| 11251 | GOTO 70 |
| 11252 | 50 CONTINUE |
| 11253 | I1 = I0+1 |
| 11254 | GOTO 70 |
| 11255 | 60 CONTINUE |
| 11256 | GOTO 10 |
| 11257 | 70 CONTINUE |
| 11258 | X0 = DBLE(I0-1)*BSTEP(NTARG) |
| 11259 | X1 = DBLE(I1-1)*BSTEP(NTARG) |
| 11260 | X2 = DBLE(I2-1)*BSTEP(NTARG) |
| 11261 | Y0 = BSITE(0,1,NTARG,I0) |
| 11262 | Y1 = BSITE(0,1,NTARG,I1) |
| 11263 | Y2 = BSITE(0,1,NTARG,I2) |
| 11264 | 80 CONTINUE |
| 11265 | B = X0*(Y-Y1)*(Y-Y2)/((Y0-Y1)*(Y0-Y2)+TINY15)+ |
| 11266 | & X1*(Y-Y0)*(Y-Y2)/((Y1-Y0)*(Y1-Y2)+TINY15)+ |
| 11267 | & X2*(Y-Y0)*(Y-Y1)/((Y2-Y0)*(Y2-Y1)+TINY15) |
| 11268 | **sr 5.4.98: shift B by half the bin width to be in agreement with BPROD |
| 11269 | B = B+0.5D0*BSTEP(NTARG) |
| 11270 | IF (B.LT.ZERO) B = X1 |
| 11271 | IF (B.GT.BMAX(NTARG)) B = BMAX(NTARG) |
| 11272 | IF (ICENTR.LT.0) THEN |
| 11273 | IF (LFIRST) THEN |
| 11274 | LFIRST = .FALSE. |
| 11275 | IF (ICENTR.LE.-100) THEN |
| 11276 | BIMIN = 0.0D0 |
| 11277 | ELSE |
| 11278 | XSFRAC = 0.0D0 |
| 11279 | ENDIF |
| 11280 | CALL DT_GETBXS(XSFRAC,BIMIN,BIMAX,NTARG) |
| 11281 | WRITE(LOUT,1000) RASH(1),RBSH(NTARG),BMAX(NTARG), |
| 11282 | & BIMIN,BIMAX,XSFRAC*100.0D0, |
| 11283 | & XSFRAC*XSPRO(1,1,NTARG) |
| 11284 | 10000 FORMAT(/,1X,'DT_MODB: Biasing in impact parameter', |
| 11285 | & /,15X,'---------------------------'/,/,4X, |
| 11286 | & 'average radii of proj / targ :',F10.3,' fm /', |
| 11287 | & F7.3,' fm',/,4X,'corresp. b_max (4*(r_p+r_t)) :', |
| 11288 | & F10.3,' fm',/,/,21X,'b_lo / b_hi :', |
| 11289 | & F10.3,' fm /',F7.3,' fm',/,5X,'percentage of', |
| 11290 | & ' cross section :',F10.3,' %',/,5X, |
| 11291 | & 'corresponding cross section :',F10.3,' mb',/) |
| 11292 | ENDIF |
| 11293 | IF (ABS(BIMAX-BIMIN).LT.1.0D-3) THEN |
| 11294 | B = BIMIN |
| 11295 | ELSE |
| 11296 | IF ((B.LT.BIMIN).OR.(B.GT.BIMAX)) GOTO 9 |
| 11297 | ENDIF |
| 11298 | ENDIF |
| 11299 | ENDIF |
| 11300 | |
| 11301 | RETURN |
| 11302 | END |
| 11303 | |
| 11304 | *$ CREATE DT_SHFAST.FOR |
| 11305 | *COPY DT_SHFAST |
| 11306 | * |
| 11307 | *===shfast=============================================================* |
| 11308 | * |
| 11309 | SUBROUTINE DT_SHFAST(MODE,PPN,IBACK) |
| 11310 | |
| 11311 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 11312 | SAVE |
| 11313 | PARAMETER ( LINP = 10 , |
| 11314 | & LOUT = 6 , |
| 11315 | & LDAT = 9 ) |
| 11316 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY1=1.0D-1, |
| 11317 | & ONE=1.0D0,TWO=2.0D0) |
| 11318 | |
| 11319 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 11320 | * Glauber formalism: parameters |
| 11321 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), |
| 11322 | & BMAX(NCOMPX),BSTEP(NCOMPX), |
| 11323 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), |
| 11324 | & NSITEB,NSTATB |
| 11325 | * properties of interacting particles |
| 11326 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG |
| 11327 | * Glauber formalism: cross sections |
| 11328 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, |
| 11329 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), |
| 11330 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), |
| 11331 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), |
| 11332 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), |
| 11333 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), |
| 11334 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), |
| 11335 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), |
| 11336 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), |
| 11337 | & BSLOPE,NEBINI,NQBINI |
| 11338 | |
| 11339 | IBACK = 0 |
| 11340 | |
| 11341 | IF (MODE.EQ.2) THEN |
| 11342 | OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN') |
| 11343 | WRITE(47,1000) IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG,PPN |
| 11344 | 1000 FORMAT(1X,8I5,E15.5) |
| 11345 | WRITE(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1) |
| 11346 | 1001 FORMAT(1X,4E15.5) |
| 11347 | WRITE(47,1002) SIGSH,ROSH,GSH |
| 11348 | 1002 FORMAT(1X,3E15.5) |
| 11349 | DO 10 I=1,100 |
| 11350 | WRITE(47,'(1X,E15.5)') BSITE(1,1,1,I) |
| 11351 | 10 CONTINUE |
| 11352 | WRITE(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE |
| 11353 | 1003 FORMAT(1X,2I10,3E15.5) |
| 11354 | CLOSE(47) |
| 11355 | ELSE |
| 11356 | OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN') |
| 11357 | READ(47,1000) JT,JTZ,JP,JPZ,JJPROJ,JBPROJ,JJTARG,JBTARG,PP |
| 11358 | IF ((JT.EQ.IT).AND.(JTZ.EQ.ITZ).AND.(JP.EQ.IP).AND. |
| 11359 | & (JPZ.EQ.IPZ).AND.(JJPROJ.EQ.IJPROJ).AND.(JBPROJ.EQ.IBPROJ) |
| 11360 | & .AND.(JJTARG.EQ.IJTARG).AND.(JBTARG.EQ.IBTARG).AND. |
| 11361 | & (ABS(PP-PPN).LT.(PPN*0.01D0))) THEN |
| 11362 | READ(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1) |
| 11363 | READ(47,1002) SIGSH,ROSH,GSH |
| 11364 | DO 11 I=1,100 |
| 11365 | READ(47,'(1X,E15.5)') BSITE(1,1,1,I) |
| 11366 | 11 CONTINUE |
| 11367 | READ(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE |
| 11368 | ELSE |
| 11369 | IBACK = 1 |
| 11370 | ENDIF |
| 11371 | CLOSE(47) |
| 11372 | ENDIF |
| 11373 | |
| 11374 | RETURN |
| 11375 | END |
| 11376 | |
| 11377 | *$ CREATE DT_POILIK.FOR |
| 11378 | *COPY DT_POILIK |
| 11379 | * |
| 11380 | *===poilik=============================================================* |
| 11381 | * |
| 11382 | SUBROUTINE DT_POILIK(NB,NTARG,ECM,VIRT,IPNT,RPNT,MODE) |
| 11383 | |
| 11384 | IMPLICIT DOUBLE PRECISION(A-H,O-Z) |
| 11385 | SAVE |
| 11386 | |
| 11387 | PARAMETER ( LINP = 10 , |
| 11388 | & LOUT = 6 , |
| 11389 | & LDAT = 9 ) |
| 11390 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.0D0) |
| 11391 | PARAMETER (NE = 8) |
| 11392 | |
| 11393 | **PHOJET105a |
| 11394 | C CHARACTER*8 MDLNA |
| 11395 | C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100) |
| 11396 | C PARAMETER (IEETAB=10) |
| 11397 | C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX |
| 11398 | **PHOJET110 |
| 11399 | C model switches and parameters |
| 11400 | CHARACTER*8 MDLNA |
| 11401 | INTEGER ISWMDL,IPAMDL |
| 11402 | DOUBLE PRECISION PARMDL |
| 11403 | COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400) |
| 11404 | C energy-interpolation table |
| 11405 | INTEGER IEETA2 |
| 11406 | PARAMETER ( IEETA2 = 20 ) |
| 11407 | INTEGER ISIMAX |
| 11408 | DOUBLE PRECISION SIGTAB,SIGECM |
| 11409 | COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX |
| 11410 | ** |
| 11411 | * VDM parameter for photon-nucleus interactions |
| 11412 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) |
| 11413 | **sr 22.7.97 |
| 11414 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 11415 | * Glauber formalism: cross sections |
| 11416 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, |
| 11417 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), |
| 11418 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), |
| 11419 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), |
| 11420 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), |
| 11421 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), |
| 11422 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), |
| 11423 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), |
| 11424 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), |
| 11425 | & BSLOPE,NEBINI,NQBINI |
| 11426 | ** |
| 11427 | |
| 11428 | DATA ECMOLD,Q2OLD /-1.0D0,-1.0D0/ |
| 11429 | |
| 11430 | IF ((ECM.EQ.ECMOLD).AND.(VIRT.EQ.Q2OLD)) GOTO 3 |
| 11431 | |
| 11432 | * load cross sections from interpolation table |
| 11433 | IP = 1 |
| 11434 | IF(ECM.LE.SIGECM(IP,1)) THEN |
| 11435 | I1 = 1 |
| 11436 | I2 = 1 |
| 11437 | ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN |
| 11438 | DO 50 I=2,ISIMAX |
| 11439 | IF(ECM.LE.SIGECM(IP,I)) GOTO 200 |
| 11440 | 50 CONTINUE |
| 11441 | 200 CONTINUE |
| 11442 | I1 = I-1 |
| 11443 | I2 = I |
| 11444 | ELSE |
| 11445 | WRITE(LOUT,'(/1X,A,2E12.3)') |
| 11446 | & 'POILIK:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX) |
| 11447 | I1 = ISIMAX |
| 11448 | I2 = ISIMAX |
| 11449 | ENDIF |
| 11450 | FAC2 = ZERO |
| 11451 | IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1)) |
| 11452 | & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1)) |
| 11453 | FAC1 = ONE-FAC2 |
| 11454 | |
| 11455 | SIGANO = DT_SANO(ECM) |
| 11456 | |
| 11457 | * cross section dependence on photon virtuality |
| 11458 | FSUP1 = ZERO |
| 11459 | DO 150 I=1,3 |
| 11460 | FSUP1 = FSUP1+PARMDL(26+I)*(ONE+VIRT/(4.D0*PARMDL(30+I))) |
| 11461 | & /(ONE+VIRT/PARMDL(30+I))**2 |
| 11462 | 150 CONTINUE |
| 11463 | FSUP1 = FSUP1+PARMDL(30)/(ONE+VIRT/PARMDL(34)) |
| 11464 | FAC1 = FAC1*FSUP1 |
| 11465 | FAC2 = FAC2*FSUP1 |
| 11466 | FSUP2 = ONE |
| 11467 | |
| 11468 | ECMOLD = ECM |
| 11469 | Q2OLD = VIRT |
| 11470 | |
| 11471 | 3 CONTINUE |
| 11472 | |
| 11473 | C SIGTOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1) |
| 11474 | CALL DT_SIGGP(ZERO,VIRT,ECM,ZERO,SIGTOT,DUM1,DUM2) |
| 11475 | IF (ISHAD(1).EQ.1) THEN |
| 11476 | SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1) |
| 11477 | ELSE |
| 11478 | SIGDIR = ZERO |
| 11479 | ENDIF |
| 11480 | SIGANO = FSUP1*FSUP2*SIGANO |
| 11481 | SIGTOT = SIGTOT-SIGDIR-SIGANO |
| 11482 | SIGDIR = SIGDIR/(FSUP1*FSUP2) |
| 11483 | SIGANO = SIGANO/(FSUP1*FSUP2) |
| 11484 | SIGTOT = SIGTOT+SIGDIR+SIGANO |
| 11485 | |
| 11486 | RR = DT_RNDM(SIGTOT) |
| 11487 | IF (RR.LT.SIGDIR/SIGTOT) THEN |
| 11488 | IPNT = 1 |
| 11489 | ELSEIF ((RR.GE.SIGDIR/SIGTOT).AND. |
| 11490 | & (RR.LT.(SIGDIR+SIGANO)/SIGTOT)) THEN |
| 11491 | IPNT = 2 |
| 11492 | ELSE |
| 11493 | IPNT = 0 |
| 11494 | ENDIF |
| 11495 | RPNT = (SIGDIR+SIGANO)/SIGTOT |
| 11496 | C WRITE(LOUT,'(I3,2F15.5)') ISHAD(1),FAC1,FAC2 |
| 11497 | C WRITE(LOUT,'(I3,2F15.5)') MODE,SIGDIR,SIGANO |
| 11498 | C WRITE(LOUT,'(I3,4F15.5)') MODE,SIGDIR+SIGANO,SIGTOT,RPNT,ECM |
| 11499 | C WRITE(LOUT,'(1X,6E12.4)') ECM,VIRT,SIGTOT,SIGDIR,SIGANO,RPNT |
| 11500 | IF (MODE.EQ.1) RETURN |
| 11501 | |
| 11502 | **sr 22.7.97 |
| 11503 | K1 = 1 |
| 11504 | K2 = 1 |
| 11505 | RATE = ZERO |
| 11506 | IF (ECM.GE.ECMNN(NEBINI)) THEN |
| 11507 | K1 = NEBINI |
| 11508 | K2 = NEBINI |
| 11509 | RATE = ONE |
| 11510 | ELSEIF (ECM.GT.ECMNN(1)) THEN |
| 11511 | DO 10 I=2,NEBINI |
| 11512 | IF (ECM.LT.ECMNN(I)) THEN |
| 11513 | K1 = I-1 |
| 11514 | K2 = I |
| 11515 | RATE = (ECM-ECMNN(K1))/(ECMNN(K2)-ECMNN(K1)) |
| 11516 | GOTO 11 |
| 11517 | ENDIF |
| 11518 | 10 CONTINUE |
| 11519 | 11 CONTINUE |
| 11520 | ENDIF |
| 11521 | J1 = 1 |
| 11522 | J2 = 1 |
| 11523 | RATQ = ZERO |
| 11524 | IF (NQBINI.GT.1) THEN |
| 11525 | IF (VIRT.GE.Q2G(NQBINI)) THEN |
| 11526 | J1 = NQBINI |
| 11527 | J2 = NQBINI |
| 11528 | RATQ = ONE |
| 11529 | ELSEIF (VIRT.GT.Q2G(1)) THEN |
| 11530 | DO 12 I=2,NQBINI |
| 11531 | IF (VIRT.LT.Q2G(I)) THEN |
| 11532 | J1 = I-1 |
| 11533 | J2 = I |
| 11534 | RATQ = LOG10( VIRT/MAX(Q2G(J1),TINY14))/ |
| 11535 | & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14)) |
| 11536 | GOTO 13 |
| 11537 | ENDIF |
| 11538 | 12 CONTINUE |
| 11539 | 13 CONTINUE |
| 11540 | ENDIF |
| 11541 | ENDIF |
| 11542 | SGA = XSPRO(K1,J1,NTARG)+ |
| 11543 | & RATE*(XSPRO(K2,J1,NTARG)-XSPRO(K1,J1,NTARG))+ |
| 11544 | & RATQ*(XSPRO(K1,J2,NTARG)-XSPRO(K1,J1,NTARG))+ |
| 11545 | & RATE*RATQ*(XSPRO(K2,J2,NTARG)-XSPRO(K1,J2,NTARG)+ |
| 11546 | & XSPRO(K1,J1,NTARG)-XSPRO(K2,J1,NTARG)) |
| 11547 | SDI = DBLE(NB)*SIGDIR |
| 11548 | SAN = DBLE(NB)*SIGANO |
| 11549 | SPL = SDI+SAN |
| 11550 | RR = DT_RNDM(SPL) |
| 11551 | IF (RR.LT.SDI/SGA) THEN |
| 11552 | IPNT = 1 |
| 11553 | ELSEIF ((RR.GE.SDI/SGA).AND. |
| 11554 | & (RR.LT.SPL/SGA)) THEN |
| 11555 | IPNT = 2 |
| 11556 | ELSE |
| 11557 | IPNT = 0 |
| 11558 | ENDIF |
| 11559 | RPNT = SPL/SGA |
| 11560 | C WRITE(LOUT,'(I3,4F15.5)') MODE,SPL,SGA,RPNT,ECM |
| 11561 | ** |
| 11562 | |
| 11563 | RETURN |
| 11564 | END |
| 11565 | |
| 11566 | *$ CREATE DT_GLBINI.FOR |
| 11567 | *COPY DT_GLBINI |
| 11568 | * |
| 11569 | *===glbini=============================================================* |
| 11570 | * |
| 11571 | SUBROUTINE DT_GLBINI(WHAT) |
| 11572 | |
| 11573 | ************************************************************************ |
| 11574 | * Pre-initialization of profile function * |
| 11575 | * This version dated 28.11.00 is written by S. Roesler. * |
| 11576 | * * |
| 11577 | * Last change 27.12.2006 by S. Roesler. * |
| 11578 | ************************************************************************ |
| 11579 | |
| 11580 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 11581 | SAVE |
| 11582 | |
| 11583 | PARAMETER ( LINP = 10 , |
| 11584 | & LOUT = 6 , |
| 11585 | & LDAT = 9 ) |
| 11586 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.D-14) |
| 11587 | |
| 11588 | LOGICAL LCMS |
| 11589 | |
| 11590 | * particle properties (BAMJET index convention) |
| 11591 | CHARACTER*8 ANAME |
| 11592 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 11593 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 11594 | * properties of interacting particles |
| 11595 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG |
| 11596 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 11597 | * emulsion treatment |
| 11598 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), |
| 11599 | & NCOMPO,IEMUL |
| 11600 | * Glauber formalism: flags and parameters for statistics |
| 11601 | LOGICAL LPROD |
| 11602 | CHARACTER*8 CGLB |
| 11603 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD |
| 11604 | * number of data sets other than protons and nuclei |
| 11605 | * at the moment = 2 (pions and kaons) |
| 11606 | PARAMETER (MAXOFF=2) |
| 11607 | DIMENSION IJPINI(5),IOFFST(25) |
| 11608 | DATA IJPINI / 13, 15, 0, 0, 0/ |
| 11609 | * Glauber data-set to be used for hadron projectiles |
| 11610 | * (0=proton, 1=pion, 2=kaon) |
| 11611 | DATA (IOFFST(K),K=1,25) / |
| 11612 | & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0, |
| 11613 | & 0, 0, 1, 2, 2/ |
| 11614 | * Acceptance interval for target nucleus mass |
| 11615 | PARAMETER (KBACC = 6) |
| 11616 | * flags for input different options |
| 11617 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 11618 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 11619 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 11620 | |
| 11621 | PARAMETER (MAXMSS = 100) |
| 11622 | DIMENSION IASAV(MAXMSS),IBSAV(MAXMSS) |
| 11623 | DIMENSION WHAT(6) |
| 11624 | |
| 11625 | DATA JPEACH,JPSTEP / 18, 5 / |
| 11626 | |
| 11627 | * temporary patch until fix has been implemented in phojet: |
| 11628 | * maximum energy for pion projectile |
| 11629 | DATA ECMXPI / 100000.0D0 / |
| 11630 | * |
| 11631 | *-------------------------------------------------------------------------- |
| 11632 | * general initializations |
| 11633 | * |
| 11634 | * steps in projectile mass number for initialization |
| 11635 | IF (WHAT(4).GT.ZERO) JPEACH = INT(WHAT(4)) |
| 11636 | IF (WHAT(5).GT.ZERO) JPSTEP = INT(WHAT(5)) |
| 11637 | * |
| 11638 | * energy range and binning |
| 11639 | ELO = ABS(WHAT(1)) |
| 11640 | EHI = ABS(WHAT(2)) |
| 11641 | IF (ELO.GT.EHI) ELO = EHI |
| 11642 | NEBIN = MAX(INT(WHAT(3)),1) |
| 11643 | IF (ELO.EQ.EHI) NEBIN = 0 |
| 11644 | LCMS = (WHAT(1).LT.ZERO).OR.(WHAT(2).LT.ZERO) |
| 11645 | IF (LCMS) THEN |
| 11646 | ECMINI = EHI |
| 11647 | ELSE |
| 11648 | ECMINI = SQRT(AAM(IJPROJ)**2+AAM(IJTARG)**2 |
| 11649 | & +2.0D0*AAM(IJTARG)*EHI) |
| 11650 | ENDIF |
| 11651 | * |
| 11652 | * default arguments for Glauber-routine |
| 11653 | XI = ZERO |
| 11654 | Q2I = ZERO |
| 11655 | * |
| 11656 | * initialize nuclear parameters, etc. |
| 11657 | CALL DT_BERTTP |
| 11658 | CALL DT_INCINI |
| 11659 | * |
| 11660 | * open Glauber-data output file |
| 11661 | IDX = INDEX(CGLB,' ') |
| 11662 | K = 12 |
| 11663 | IF (IDX.GT.1) K = IDX-1 |
| 11664 | OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN') |
| 11665 | * |
| 11666 | *-------------------------------------------------------------------------- |
| 11667 | * Glauber-initialization for proton and nuclei projectiles |
| 11668 | * |
| 11669 | * initialize phojet for proton-proton interactions |
| 11670 | ELAB = ZERO |
| 11671 | PLAB = ZERO |
| 11672 | CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1) |
| 11673 | CALL DT_PHOINI |
| 11674 | * |
| 11675 | * record projectile masses |
| 11676 | NASAV = 0 |
| 11677 | NPROJ = MIN(IP,JPEACH) |
| 11678 | DO 10 KPROJ=1,NPROJ |
| 11679 | NASAV = NASAV+1 |
| 11680 | IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! ' |
| 11681 | IASAV(NASAV) = KPROJ |
| 11682 | 10 CONTINUE |
| 11683 | IF (IP.GT.JPEACH) THEN |
| 11684 | NPROJ = DBLE(IP-JPEACH)/DBLE(JPSTEP) |
| 11685 | IF (NPROJ.EQ.0) THEN |
| 11686 | NASAV = NASAV+1 |
| 11687 | IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! ' |
| 11688 | IASAV(NASAV) = IP |
| 11689 | ELSE |
| 11690 | DO 11 IPROJ=1,NPROJ |
| 11691 | KPROJ = JPEACH+IPROJ*JPSTEP |
| 11692 | NASAV = NASAV+1 |
| 11693 | IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! ' |
| 11694 | IASAV(NASAV) = KPROJ |
| 11695 | 11 CONTINUE |
| 11696 | IF (KPROJ.LT.IP) THEN |
| 11697 | NASAV = NASAV+1 |
| 11698 | IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! ' |
| 11699 | IASAV(NASAV) = IP |
| 11700 | ENDIF |
| 11701 | ENDIF |
| 11702 | ENDIF |
| 11703 | * |
| 11704 | * record target masses |
| 11705 | NBSAV = 0 |
| 11706 | NTARG = 1 |
| 11707 | IF (NCOMPO.GT.0) NTARG = NCOMPO |
| 11708 | DO 12 ITARG=1,NTARG |
| 11709 | NBSAV = NBSAV+1 |
| 11710 | IF (NBSAV.GT.MAXMSS) STOP ' GLBINI: NBSAV > MAXMSS ! ' |
| 11711 | IF (NCOMPO.GT.0) THEN |
| 11712 | IBSAV(NBSAV) = IEMUMA(ITARG) |
| 11713 | ELSE |
| 11714 | IBSAV(NBSAV) = IT |
| 11715 | ENDIF |
| 11716 | 12 CONTINUE |
| 11717 | * |
| 11718 | * print masses |
| 11719 | WRITE(LDAT,1000) NEBIN,': ',SIGN(ELO,WHAT(1)),SIGN(EHI,WHAT(2)) |
| 11720 | 1000 FORMAT(I4,A,1P,2E13.5) |
| 11721 | NLINES = DBLE(NASAV)/18.0D0 |
| 11722 | IF (NLINES.GT.0) THEN |
| 11723 | DO 13 I=1,NLINES |
| 11724 | IF (I.EQ.1) THEN |
| 11725 | WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=1,18) |
| 11726 | ELSE |
| 11727 | WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=18*I-17,18*I) |
| 11728 | ENDIF |
| 11729 | 13 CONTINUE |
| 11730 | ENDIF |
| 11731 | I0 = 18*NLINES+1 |
| 11732 | IF (I0.LE.NASAV) THEN |
| 11733 | IF (I0.EQ.1) THEN |
| 11734 | WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=I0,NASAV) |
| 11735 | ELSE |
| 11736 | WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=I0,NASAV) |
| 11737 | ENDIF |
| 11738 | ENDIF |
| 11739 | NLINES = DBLE(NBSAV)/18.0D0 |
| 11740 | IF (NLINES.GT.0) THEN |
| 11741 | DO 14 I=1,NLINES |
| 11742 | IF (I.EQ.1) THEN |
| 11743 | WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=1,18) |
| 11744 | ELSE |
| 11745 | WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=18*I-17,18*I) |
| 11746 | ENDIF |
| 11747 | 14 CONTINUE |
| 11748 | ENDIF |
| 11749 | I0 = 18*NLINES+1 |
| 11750 | IF (I0.LE.NBSAV) THEN |
| 11751 | IF (I0.EQ.1) THEN |
| 11752 | WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=I0,NBSAV) |
| 11753 | ELSE |
| 11754 | WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=I0,NBSAV) |
| 11755 | ENDIF |
| 11756 | ENDIF |
| 11757 | * |
| 11758 | * calculate Glauber-data for each energy and mass combination |
| 11759 | * |
| 11760 | * loop over energy bins |
| 11761 | ELO = LOG10(ELO) |
| 11762 | EHI = LOG10(EHI) |
| 11763 | DEBIN = (EHI-ELO)/MAX(DBLE(NEBIN),ONE) |
| 11764 | DO 1 IE=1,NEBIN+1 |
| 11765 | E = ELO+DBLE(IE-1)*DEBIN |
| 11766 | E = 10**E |
| 11767 | IF (LCMS) THEN |
| 11768 | E = MAX(2.0D0*AAM(IJPROJ)+0.1D0,E) |
| 11769 | ECM = E |
| 11770 | ELSE |
| 11771 | PLAB = ZERO |
| 11772 | ECM = ZERO |
| 11773 | E = MAX(AAM(IJPROJ)+0.1D0,E) |
| 11774 | CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0) |
| 11775 | ENDIF |
| 11776 | * |
| 11777 | * loop over projectile and target masses |
| 11778 | DO 2 ITARG=1,NBSAV |
| 11779 | DO 3 IPROJ=1,NASAV |
| 11780 | CALL DT_XSGLAU(IASAV(IPROJ),IBSAV(ITARG),IJPROJ, |
| 11781 | & XI,Q2I,ECM,1,1,-1) |
| 11782 | 3 CONTINUE |
| 11783 | 2 CONTINUE |
| 11784 | * |
| 11785 | 1 CONTINUE |
| 11786 | * |
| 11787 | *-------------------------------------------------------------------------- |
| 11788 | * Glauber-initialization for pion, kaon, ... projectiles |
| 11789 | * |
| 11790 | DO 6 IJ=1,MAXOFF |
| 11791 | * |
| 11792 | * initialize phojet for this interaction |
| 11793 | ELAB = ZERO |
| 11794 | PLAB = ZERO |
| 11795 | IJPROJ = IJPINI(IJ) |
| 11796 | IP = 1 |
| 11797 | IPZ = 1 |
| 11798 | * |
| 11799 | * temporary patch until fix has been implemented in phojet: |
| 11800 | IF (ECMINI.GT.ECMXPI) THEN |
| 11801 | CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMXPI,1) |
| 11802 | ELSE |
| 11803 | CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1) |
| 11804 | ENDIF |
| 11805 | CALL DT_PHOINI |
| 11806 | * |
| 11807 | * calculate Glauber-data for each energy and mass combination |
| 11808 | * |
| 11809 | * loop over energy bins |
| 11810 | DO 4 IE=1,NEBIN+1 |
| 11811 | E = ELO+DBLE(IE-1)*DEBIN |
| 11812 | E = 10**E |
| 11813 | IF (LCMS) THEN |
| 11814 | E = MAX(2.0D0*AAM(IJPROJ)+TINY14,E) |
| 11815 | ECM = E |
| 11816 | ELSE |
| 11817 | PLAB = ZERO |
| 11818 | ECM = ZERO |
| 11819 | E = MAX(AAM(IJPROJ)+TINY14,E) |
| 11820 | CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0) |
| 11821 | ENDIF |
| 11822 | * |
| 11823 | * loop over projectile and target masses |
| 11824 | DO 5 ITARG=1,NBSAV |
| 11825 | CALL DT_XSGLAU(1,IBSAV(ITARG),IJPROJ,XI,Q2I,ECM,1,1,-1) |
| 11826 | 5 CONTINUE |
| 11827 | * |
| 11828 | 4 CONTINUE |
| 11829 | * |
| 11830 | 6 CONTINUE |
| 11831 | |
| 11832 | *-------------------------------------------------------------------------- |
| 11833 | * close output unit(s), etc. |
| 11834 | * |
| 11835 | CLOSE(LDAT) |
| 11836 | |
| 11837 | RETURN |
| 11838 | END |
| 11839 | |
| 11840 | *$ CREATE DT_GLBSET.FOR |
| 11841 | *COPY DT_GLBSET |
| 11842 | * |
| 11843 | *===glbset=============================================================* |
| 11844 | * |
| 11845 | SUBROUTINE DT_GLBSET(IDPROJ,NA,NB,ELAB,MODE) |
| 11846 | ************************************************************************ |
| 11847 | * Interpolation of pre-initialized profile functions * |
| 11848 | * This version dated 28.11.00 is written by S. Roesler. * |
| 11849 | ************************************************************************ |
| 11850 | |
| 11851 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 11852 | SAVE |
| 11853 | |
| 11854 | PARAMETER ( LINP = 10 , |
| 11855 | & LOUT = 6 , |
| 11856 | & LDAT = 9 ) |
| 11857 | PARAMETER (ZERO=0.0D0,ONE=1.0D0) |
| 11858 | |
| 11859 | LOGICAL LCMS,LREAD,LFRST1,LFRST2 |
| 11860 | |
| 11861 | * particle properties (BAMJET index convention) |
| 11862 | CHARACTER*8 ANAME |
| 11863 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 11864 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 11865 | * Glauber formalism: flags and parameters for statistics |
| 11866 | LOGICAL LPROD |
| 11867 | CHARACTER*8 CGLB |
| 11868 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD |
| 11869 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 11870 | * Glauber formalism: parameters |
| 11871 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), |
| 11872 | & BMAX(NCOMPX),BSTEP(NCOMPX), |
| 11873 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), |
| 11874 | & NSITEB,NSTATB |
| 11875 | * Glauber formalism: cross sections |
| 11876 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, |
| 11877 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), |
| 11878 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), |
| 11879 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), |
| 11880 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), |
| 11881 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), |
| 11882 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), |
| 11883 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), |
| 11884 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), |
| 11885 | & BSLOPE,NEBINI,NQBINI |
| 11886 | * number of data sets other than protons and nuclei |
| 11887 | * at the moment = 2 (pions and kaons) |
| 11888 | PARAMETER (MAXOFF=2) |
| 11889 | DIMENSION IJPINI(5),IOFFST(25) |
| 11890 | DATA IJPINI / 13, 15, 0, 0, 0/ |
| 11891 | * Glauber data-set to be used for hadron projectiles |
| 11892 | * (0=proton, 1=pion, 2=kaon) |
| 11893 | DATA (IOFFST(K),K=1,25) / |
| 11894 | & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0, |
| 11895 | & 0, 0, 1, 2, 2/ |
| 11896 | * Acceptance interval for target nucleus mass |
| 11897 | PARAMETER (KBACC = 6) |
| 11898 | * emulsion treatment |
| 11899 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), |
| 11900 | & NCOMPO,IEMUL |
| 11901 | |
| 11902 | PARAMETER (MAXSET=5000, |
| 11903 | & MAXBIN=100) |
| 11904 | DIMENSION XSIG(MAXSET,6),XERR(MAXSET,6),BPROFL(MAXSET,KSITEB) |
| 11905 | DIMENSION IABIN(MAXBIN),IBBIN(MAXBIN),XS(6),XE(6), |
| 11906 | & BPRO0(KSITEB),BPRO1(KSITEB),BPRO(KSITEB), |
| 11907 | & IAIDX(10) |
| 11908 | |
| 11909 | DATA LREAD,LFRST1,LFRST2 /.FALSE.,.TRUE.,.TRUE./ |
| 11910 | * |
| 11911 | * read data from file |
| 11912 | * |
| 11913 | IF (MODE.EQ.0) THEN |
| 11914 | |
| 11915 | IF (LREAD) RETURN |
| 11916 | |
| 11917 | DO 1 I=1,MAXSET |
| 11918 | DO 2 J=1,6 |
| 11919 | XSIG(I,J) = ZERO |
| 11920 | XERR(I,J) = ZERO |
| 11921 | 2 CONTINUE |
| 11922 | DO 3 J=1,KSITEB |
| 11923 | BPROFL(I,J) = ZERO |
| 11924 | 3 CONTINUE |
| 11925 | 1 CONTINUE |
| 11926 | DO 4 I=1,MAXBIN |
| 11927 | IABIN(I) = 0 |
| 11928 | IBBIN(I) = 0 |
| 11929 | 4 CONTINUE |
| 11930 | DO 5 I=1,KSITEB |
| 11931 | BPRO0(I) = ZERO |
| 11932 | BPRO1(I) = ZERO |
| 11933 | BPRO(I) = ZERO |
| 11934 | 5 CONTINUE |
| 11935 | |
| 11936 | IDX = INDEX(CGLB,' ') |
| 11937 | K = 12 |
| 11938 | IF (IDX.GT.1) K = IDX-1 |
| 11939 | OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN') |
| 11940 | WRITE(LOUT,1000) CGLB(1:K)//'.glb' |
| 11941 | 1000 FORMAT(/,' GLBSET: impact parameter distributions read from ', |
| 11942 | & 'file ',A12,/) |
| 11943 | * |
| 11944 | * read binning information |
| 11945 | READ(LDAT,'(I4,2X,2E13.5)') NEBIN,ELO,EHI |
| 11946 | * return lower energy threshold to Fluka-interface |
| 11947 | ELAB = ELO |
| 11948 | LCMS = ELO.LT.ZERO |
| 11949 | WRITE(LOUT,'(1X,A)') ' equidistant logarithmic energy binning:' |
| 11950 | IF (LCMS) THEN |
| 11951 | WRITE(LOUT,1001) '(cms)',ABS(ELO),ABS(EHI),NEBIN |
| 11952 | ELSE |
| 11953 | WRITE(LOUT,1001) '(lab)',ABS(ELO),ABS(EHI),NEBIN |
| 11954 | ENDIF |
| 11955 | 1001 FORMAT(2X,A5,' E_lo = ',1P,E9.3,' E_hi = ',1P,E9.3,4X, |
| 11956 | & 'No. of bins:',I5,/) |
| 11957 | ELO = LOG10(ABS(ELO)) |
| 11958 | EHI = LOG10(ABS(EHI)) |
| 11959 | DEBIN = (EHI-ELO)/ABS(DBLE(NEBIN)) |
| 11960 | WRITE(LOUT,'(/,1X,A)') ' projectiles: (mass number)' |
| 11961 | READ(LDAT,'(I4,2X,18I4)') NABIN,(IABIN(J),J=1,18) |
| 11962 | IF (NABIN.LT.18) THEN |
| 11963 | WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,NABIN) |
| 11964 | ELSE |
| 11965 | WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,18) |
| 11966 | ENDIF |
| 11967 | IF (NABIN.GT.MAXBIN) STOP ' GLBSET: NABIN > MAXBIN !' |
| 11968 | IF (NABIN.GT.18) THEN |
| 11969 | NLINES = DBLE(NABIN-18)/18.0D0 |
| 11970 | IF (NLINES.GT.0) THEN |
| 11971 | DO 7 I=1,NLINES |
| 11972 | I0 = 18*(I+1)-17 |
| 11973 | READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,I0+17) |
| 11974 | WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,I0+17) |
| 11975 | 7 CONTINUE |
| 11976 | ENDIF |
| 11977 | I0 = 18*(NLINES+1)+1 |
| 11978 | IF (I0.LE.NABIN) THEN |
| 11979 | READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,NABIN) |
| 11980 | WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,NABIN) |
| 11981 | ENDIF |
| 11982 | ENDIF |
| 11983 | WRITE(LOUT,'(/,1X,A)') ' targets: (mass number)' |
| 11984 | READ(LDAT,'(I4,2X,18I4)') NBBIN,(IBBIN(J),J=1,18) |
| 11985 | IF (NBBIN.LT.18) THEN |
| 11986 | WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,NBBIN) |
| 11987 | ELSE |
| 11988 | WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,18) |
| 11989 | ENDIF |
| 11990 | IF (NBBIN.GT.MAXBIN) STOP ' GLBSET: NBBIN > MAXBIN !' |
| 11991 | IF (NBBIN.GT.18) THEN |
| 11992 | NLINES = DBLE(NBBIN-18)/18.0D0 |
| 11993 | IF (NLINES.GT.0) THEN |
| 11994 | DO 8 I=1,NLINES |
| 11995 | I0 = 18*(I+1)-17 |
| 11996 | READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17) |
| 11997 | WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17) |
| 11998 | 8 CONTINUE |
| 11999 | ENDIF |
| 12000 | I0 = 18*(NLINES+1)+1 |
| 12001 | IF (I0.LE.NBBIN) THEN |
| 12002 | READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN) |
| 12003 | WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN) |
| 12004 | ENDIF |
| 12005 | ENDIF |
| 12006 | * number of data sets to follow in the Glauber data file |
| 12007 | * this variable is used for checks of consistency of projectile |
| 12008 | * and target mass configurations given in header of Glauber data |
| 12009 | * file and the data-sets which follow in this file |
| 12010 | NSET0 = (NEBIN+1)*(NABIN+MAXOFF)*NBBIN |
| 12011 | * |
| 12012 | * read profile function data |
| 12013 | NSET = 0 |
| 12014 | NAIDX = 0 |
| 12015 | IPOLD = 0 |
| 12016 | 10 CONTINUE |
| 12017 | NSET = NSET+1 |
| 12018 | IF (NSET.GT.MAXSET) STOP ' GLBSET: NSET > MAXSET ! ' |
| 12019 | READ(LDAT,1002,END=100) IP,IA,IB,ISTATB,ISITEB,ECM |
| 12020 | 1002 FORMAT(5I10,E15.5) |
| 12021 | IF ((IP.NE.1).AND.(IP.NE.IPOLD)) THEN |
| 12022 | NAIDX = NAIDX+1 |
| 12023 | IF (NAIDX.GT.10) STOP ' GLBSET: NAIDX > 10 !' |
| 12024 | IAIDX(NAIDX) = IP |
| 12025 | IPOLD = IP |
| 12026 | ENDIF |
| 12027 | READ(LDAT,'(6E12.5)') (XSIG(NSET,I),I=1,6) |
| 12028 | READ(LDAT,'(6E12.5)') (XERR(NSET,I),I=1,6) |
| 12029 | NLINES = INT(DBLE(ISITEB)/7.0D0) |
| 12030 | IF (NLINES.GT.0) THEN |
| 12031 | DO 11 I=1,NLINES |
| 12032 | READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=7*I-6,7*I) |
| 12033 | 11 CONTINUE |
| 12034 | ENDIF |
| 12035 | I0 = 7*NLINES+1 |
| 12036 | IF (I0.LE.ISITEB) |
| 12037 | & READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=I0,ISITEB) |
| 12038 | GOTO 10 |
| 12039 | 100 CONTINUE |
| 12040 | NSET = NSET-1 |
| 12041 | IF (NSET.NE.NSET0) STOP ' GLBSET: NSET.NE.NSET0 !' |
| 12042 | WRITE(LOUT,'(/,1X,A)') |
| 12043 | & ' projectiles other than protons and nuclei: (particle index)' |
| 12044 | IF (NAIDX.GT.0) THEN |
| 12045 | WRITE(LOUT,'(6X,18I4)') (IAIDX(J),J=1,NAIDX) |
| 12046 | ELSE |
| 12047 | WRITE(LOUT,'(6X,A)') 'none' |
| 12048 | ENDIF |
| 12049 | * |
| 12050 | CLOSE(LDAT) |
| 12051 | WRITE(LOUT,*) |
| 12052 | LREAD = .TRUE. |
| 12053 | |
| 12054 | IF (NCOMPO.EQ.0) THEN |
| 12055 | DO 12 J=1,NBBIN |
| 12056 | NCOMPO = NCOMPO+1 |
| 12057 | IEMUMA(NCOMPO) = IBBIN(J) |
| 12058 | IEMUCH(NCOMPO) = IEMUMA(NCOMPO)/2 |
| 12059 | EMUFRA(NCOMPO) = 1.0D0 |
| 12060 | 12 CONTINUE |
| 12061 | IEMUL = 1 |
| 12062 | ENDIF |
| 12063 | * |
| 12064 | * calculate profile function for certain set of parameters |
| 12065 | * |
| 12066 | ELSE |
| 12067 | |
| 12068 | c write(*,*) 'glbset called for ',IDPROJ,NA,NB,ELAB,MODE |
| 12069 | * |
| 12070 | * check for type of projectile and set index-offset to entry in |
| 12071 | * Glauber data array correspondingly |
| 12072 | IF (IDPROJ.GT.25) STOP ' GLBSET: IDPROJ > 25 !' |
| 12073 | IF (IOFFST(IDPROJ).EQ.-1) THEN |
| 12074 | STOP ' GLBSET: no data for this projectile !' |
| 12075 | ELSEIF (IOFFST(IDPROJ).GT.0) THEN |
| 12076 | IDXOFF = (NEBIN+1)*(NABIN+IOFFST(IDPROJ)-1)*NBBIN |
| 12077 | ELSE |
| 12078 | IDXOFF = 0 |
| 12079 | ENDIF |
| 12080 | * |
| 12081 | * get energy bin and interpolation factor |
| 12082 | IF (LCMS) THEN |
| 12083 | E = SQRT(AAM(IDPROJ)**2+AAM(1)**2+2.0D0*AAM(1)*ELAB) |
| 12084 | ELSE |
| 12085 | E = ELAB |
| 12086 | ENDIF |
| 12087 | E = LOG10(E) |
| 12088 | IF (E.LT.ELO) THEN |
| 12089 | IF (LFRST1) THEN |
| 12090 | WRITE(LOUT,*) ' GLBSET: Too low energy! (E_lo,E) ',ELO,E |
| 12091 | LFRST1 = .FALSE. |
| 12092 | ENDIF |
| 12093 | E = ELO |
| 12094 | ENDIF |
| 12095 | IF (E.GT.EHI) THEN |
| 12096 | IF (LFRST2) THEN |
| 12097 | WRITE(LOUT,*) ' GLBSET: Too high energy! (E_hi,E) ',EHI,E |
| 12098 | LFRST2 = .FALSE. |
| 12099 | ENDIF |
| 12100 | E = EHI |
| 12101 | ENDIF |
| 12102 | IE0 = (E-ELO)/DEBIN+1 |
| 12103 | IE1 = IE0+1 |
| 12104 | FACE = (E-(ELO+DBLE(IE0-1)*DEBIN))/DEBIN |
| 12105 | * |
| 12106 | * get target nucleus index |
| 12107 | KB = 0 |
| 12108 | NBACC = KBACC |
| 12109 | DO 20 I=1,NBBIN |
| 12110 | NBDIFF = ABS(NB-IBBIN(I)) |
| 12111 | IF (NB.EQ.IBBIN(I)) THEN |
| 12112 | KB = I |
| 12113 | GOTO 21 |
| 12114 | ELSEIF (NBDIFF.LE.NBACC) THEN |
| 12115 | KB = I |
| 12116 | NBACC = NBDIFF |
| 12117 | ENDIF |
| 12118 | 20 CONTINUE |
| 12119 | IF (KB.NE.0) GOTO 21 |
| 12120 | WRITE(LOUT,*) ' GLBSET: data not found for target ',NB |
| 12121 | STOP |
| 12122 | 21 CONTINUE |
| 12123 | * |
| 12124 | * get projectile nucleus bin and interpolation factor |
| 12125 | KA0 = 0 |
| 12126 | KA1 = 0 |
| 12127 | FACNA = 0 |
| 12128 | IF (IDXOFF.GT.0) THEN |
| 12129 | KA0 = 1 |
| 12130 | KA1 = 1 |
| 12131 | KABIN = 1 |
| 12132 | ELSE |
| 12133 | IF (NA.GT.IABIN(NABIN)) STOP ' GLBSET: NA > IABIN(NABIN) !' |
| 12134 | DO 22 I=1,NABIN |
| 12135 | IF (NA.EQ.IABIN(I)) THEN |
| 12136 | KA0 = I |
| 12137 | KA1 = I |
| 12138 | GOTO 23 |
| 12139 | ELSEIF (NA.LT.IABIN(I)) THEN |
| 12140 | KA0 = I-1 |
| 12141 | KA1 = I |
| 12142 | GOTO 23 |
| 12143 | ENDIF |
| 12144 | 22 CONTINUE |
| 12145 | WRITE(LOUT,*) ' GLBSET: data not found for projectile ',NA |
| 12146 | STOP |
| 12147 | 23 CONTINUE |
| 12148 | IF (KA0.NE.KA1) |
| 12149 | & FACNA = DBLE(NA-IABIN(KA0))/DBLE(IABIN(KA1)-IABIN(KA0)) |
| 12150 | KABIN = NABIN |
| 12151 | ENDIF |
| 12152 | * |
| 12153 | * interpolate profile functions for interactions ka0-kb and ka1-kb |
| 12154 | * for energy E separately |
| 12155 | IDX0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1) |
| 12156 | IDX1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1) |
| 12157 | IDY0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1) |
| 12158 | IDY1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1) |
| 12159 | DO 30 I=1,ISITEB |
| 12160 | BPRO0(I) = BPROFL(IDX0,I) |
| 12161 | & +FACE*(BPROFL(IDX1,I)-BPROFL(IDX0,I)) |
| 12162 | BPRO1(I) = BPROFL(IDY0,I) |
| 12163 | & +FACE*(BPROFL(IDY1,I)-BPROFL(IDY0,I)) |
| 12164 | 30 CONTINUE |
| 12165 | RADB = DT_RNCLUS(NB) |
| 12166 | BSTP0 = 2.0D0*(DT_RNCLUS(IABIN(KA0))+RADB)/DBLE(ISITEB-1) |
| 12167 | BSTP1 = 2.0D0*(DT_RNCLUS(IABIN(KA1))+RADB)/DBLE(ISITEB-1) |
| 12168 | * |
| 12169 | * interpolate cross sections for energy E and projectile mass |
| 12170 | DO 31 I=1,6 |
| 12171 | XS0 = XSIG(IDX0,I)+FACE*(XSIG(IDX1,I)-XSIG(IDX0,I)) |
| 12172 | XS1 = XSIG(IDY0,I)+FACE*(XSIG(IDY1,I)-XSIG(IDY0,I)) |
| 12173 | XS(I) = XS0+FACNA*(XS1-XS0) |
| 12174 | XE0 = XERR(IDX0,I)+FACE*(XERR(IDX1,I)-XERR(IDX0,I)) |
| 12175 | XE1 = XERR(IDY0,I)+FACE*(XERR(IDY1,I)-XERR(IDY0,I)) |
| 12176 | XE(I) = XE0+FACNA*(XE1-XE0) |
| 12177 | 31 CONTINUE |
| 12178 | * |
| 12179 | * interpolate between ka0 and ka1 |
| 12180 | RADA = DT_RNCLUS(NA) |
| 12181 | BMX = 2.0D0*(RADA+RADB) |
| 12182 | BSTP = BMX/DBLE(ISITEB-1) |
| 12183 | BPRO(1) = ZERO |
| 12184 | DO 32 I=1,ISITEB-1 |
| 12185 | B = DBLE(I)*BSTP |
| 12186 | * |
| 12187 | * calculate values of profile functions at B |
| 12188 | IDX0 = B/BSTP0+1 |
| 12189 | IF (IDX0.GT.ISITEB) IDX0 = ISITEB |
| 12190 | IDX1 = MIN(IDX0+1,ISITEB) |
| 12191 | FACB = (B-DBLE(IDX0-1)*BSTP0)/BSTP0 |
| 12192 | BPR0 = BPRO0(IDX0)+FACB*(BPRO0(IDX1)-BPRO0(IDX0)) |
| 12193 | IDX0 = B/BSTP1+1 |
| 12194 | IF (IDX0.GT.ISITEB) IDX0 = ISITEB |
| 12195 | IDX1 = MIN(IDX0+1,ISITEB) |
| 12196 | FACB = (B-DBLE(IDX0-1)*BSTP1)/BSTP1 |
| 12197 | BPR1 = BPRO1(IDX0)+FACB*(BPRO1(IDX1)-BPRO1(IDX0)) |
| 12198 | * |
| 12199 | BPRO(I+1) = BPR0+FACNA*(BPR1-BPR0) |
| 12200 | 32 CONTINUE |
| 12201 | * |
| 12202 | * fill common dtglam |
| 12203 | NSITEB = ISITEB |
| 12204 | RASH(1) = RADA |
| 12205 | RBSH(1) = RADB |
| 12206 | BMAX(1) = BMX |
| 12207 | BSTEP(1) = BSTP |
| 12208 | DO 33 I=1,KSITEB |
| 12209 | BSITE(0,1,1,I) = BPRO(I) |
| 12210 | 33 CONTINUE |
| 12211 | * |
| 12212 | * fill common dtglxs |
| 12213 | XSTOT(1,1,1) = XS(1) |
| 12214 | XSELA(1,1,1) = XS(2) |
| 12215 | XSQEP(1,1,1) = XS(3) |
| 12216 | XSQET(1,1,1) = XS(4) |
| 12217 | XSQE2(1,1,1) = XS(5) |
| 12218 | XSPRO(1,1,1) = XS(6) |
| 12219 | XETOT(1,1,1) = XE(1) |
| 12220 | XEELA(1,1,1) = XE(2) |
| 12221 | XEQEP(1,1,1) = XE(3) |
| 12222 | XEQET(1,1,1) = XE(4) |
| 12223 | XEQE2(1,1,1) = XE(5) |
| 12224 | XEPRO(1,1,1) = XE(6) |
| 12225 | |
| 12226 | ENDIF |
| 12227 | |
| 12228 | RETURN |
| 12229 | END |
| 12230 | |
| 12231 | *$ CREATE DT_XKSAMP.FOR |
| 12232 | *COPY DT_XKSAMP |
| 12233 | * |
| 12234 | *===xksamp=============================================================* |
| 12235 | * |
| 12236 | SUBROUTINE DT_XKSAMP(NN,ECM) |
| 12237 | |
| 12238 | ************************************************************************ |
| 12239 | * Sampling of parton x-values and chain system for one interaction. * |
| 12240 | * processed by S. Roesler, 9.8.95 * |
| 12241 | ************************************************************************ |
| 12242 | |
| 12243 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 12244 | SAVE |
| 12245 | PARAMETER ( LINP = 10 , |
| 12246 | & LOUT = 6 , |
| 12247 | & LDAT = 9 ) |
| 12248 | PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0) |
| 454792a9 |
12249 | CPH SAVE |
| 9aaba0d6 |
12250 | |
| 12251 | PARAMETER ( |
| 12252 | * lower cuts for (valence-sea/sea-valence) chain masses |
| 12253 | * antiquark-quark (u/d-sea quark) (s-sea quark) |
| 12254 | & AMIU = 0.5D0, AMIS = 0.8D0, |
| 12255 | * quark-diquark (u/d-sea quark) (s-sea quark) |
| 12256 | & AMAU = 2.6D0, AMAS = 2.6D0, |
| 12257 | * maximum lower valence-x threshold |
| 12258 | & XVMAX = 0.98D0, |
| 12259 | * fraction of sea-diquarks sampled out of sea-partons |
| 12260 | **test |
| 12261 | C & FRCDIQ = 0.9D0, |
| 12262 | ** |
| 12263 | * |
| 12264 | & SQMA = 0.7D0, |
| 12265 | * |
| 12266 | * maximum number of trials to generate x's for the required number |
| 12267 | * of sea quark pairs for a given hadron |
| 12268 | & NSEATY = 12 |
| 12269 | C & NSEATY = 3 |
| 12270 | & ) |
| 12271 | |
| 12272 | LOGICAL ZUOVP,ZUOSP,ZUOVT,ZUOST,INTLO |
| 12273 | |
| 12274 | PARAMETER ( MAXNCL = 260, |
| 12275 | & MAXVQU = MAXNCL, |
| 12276 | & MAXSQU = 20*MAXVQU, |
| 12277 | & MAXINT = MAXVQU+MAXSQU) |
| 12278 | * event history |
| 12279 | PARAMETER (NMXHKK=200000) |
| 12280 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 12281 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 12282 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 12283 | * particle properties (BAMJET index convention) |
| 12284 | CHARACTER*8 ANAME |
| 12285 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 12286 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 12287 | * interface between Glauber formalism and DPM |
| 12288 | COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL), |
| 12289 | & INTER1(MAXINT),INTER2(MAXINT) |
| 12290 | * properties of interacting particles |
| 12291 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG |
| 12292 | * threshold values for x-sampling (DTUNUC 1.x) |
| 12293 | COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA, |
| 12294 | & SSMIMQ,VVMTHR |
| 12295 | * x-values of partons (DTUNUC 1.x) |
| 12296 | COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU), |
| 12297 | & XTVQ(MAXVQU),XTVD(MAXVQU), |
| 12298 | & XPSQ(MAXSQU),XPSAQ(MAXSQU), |
| 12299 | & XTSQ(MAXSQU),XTSAQ(MAXSQU) |
| 12300 | * flavors of partons (DTUNUC 1.x) |
| 12301 | COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU), |
| 12302 | & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU), |
| 12303 | & IPSQ(MAXSQU),IPSQ2(MAXSQU), |
| 12304 | & IPSAQ(MAXSQU),IPSAQ2(MAXSQU), |
| 12305 | & ITSQ(MAXSQU),ITSQ2(MAXSQU), |
| 12306 | & ITSAQ(MAXSQU),ITSAQ2(MAXSQU), |
| 12307 | & KKPROJ(MAXVQU),KKTARG(MAXVQU) |
| 12308 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) |
| 12309 | COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD, |
| 12310 | & IXPV,IXPS,IXTV,IXTS, |
| 12311 | & INTVV1(MAXVQU),INTVV2(MAXVQU), |
| 12312 | & INTSV1(MAXVQU),INTSV2(MAXVQU), |
| 12313 | & INTVS1(MAXVQU),INTVS2(MAXVQU), |
| 12314 | & INTSS1(MAXSQU),INTSS2(MAXSQU), |
| 12315 | & INTDV1(MAXVQU),INTDV2(MAXVQU), |
| 12316 | & INTVD1(MAXVQU),INTVD2(MAXVQU), |
| 12317 | & INTDS1(MAXSQU),INTDS2(MAXSQU), |
| 12318 | & INTSD1(MAXSQU),INTSD2(MAXSQU) |
| 12319 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) |
| 12320 | COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU), |
| 12321 | & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU) |
| 12322 | * auxiliary common for chain system storage (DTUNUC 1.x) |
| 12323 | COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL) |
| 12324 | * flags for input different options |
| 12325 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 12326 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 12327 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 12328 | * various options for treatment of partons (DTUNUC 1.x) |
| 12329 | * (chain recombination, Cronin,..) |
| 12330 | LOGICAL LCO2CR,LINTPT |
| 12331 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, |
| 12332 | & LCO2CR,LINTPT |
| 12333 | |
| 12334 | DIMENSION ZUOVP(MAXVQU),ZUOSP(MAXSQU),ZUOVT(MAXVQU),ZUOST(MAXSQU), |
| 12335 | & INTLO(MAXINT) |
| 12336 | |
| 12337 | * (1) initializations |
| 12338 | *----------------------------------------------------------------------- |
| 12339 | |
| 12340 | **test |
| 12341 | IF (ECM.LT.4.5D0) THEN |
| 12342 | C FRCDIQ = 0.6D0 |
| 12343 | FRCDIQ = 0.4D0 |
| 12344 | ELSEIF ((ECM.GE.4.5D0).AND.(ECM.LT.7.5)) THEN |
| 12345 | C FRCDIQ = 0.6D0+(ECM-4.5D0)/3.0D0*0.3D0 |
| 12346 | FRCDIQ = 0.4D0+(ECM-4.5D0)/3.0D0*0.3D0 |
| 12347 | ELSE |
| 12348 | C FRCDIQ = 0.9D0 |
| 12349 | FRCDIQ = 0.7D0 |
| 12350 | ENDIF |
| 12351 | ** |
| 12352 | DO 30 I=1,MAXSQU |
| 12353 | ZUOSP(I) = .FALSE. |
| 12354 | ZUOST(I) = .FALSE. |
| 12355 | IF (I.LE.MAXVQU) THEN |
| 12356 | ZUOVP(I) = .FALSE. |
| 12357 | ZUOVT(I) = .FALSE. |
| 12358 | ENDIF |
| 12359 | 30 CONTINUE |
| 12360 | |
| 12361 | * lower thresholds for x-selection |
| 12362 | * sea-quarks (default: CSEA=0.2) |
| 12363 | IF (ECM.LT.10.0D0) THEN |
| 12364 | **!!test |
| 12365 | XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM |
| 12366 | C XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM**2.0D0 |
| 12367 | NSEA = NSEATY |
| 12368 | C XSTHR = ONE/ECM**2 |
| 12369 | ELSE |
| 12370 | **sr 30.3.98 |
| 12371 | C XSTHR = CSEA/ECM |
| 12372 | XSTHR = CSEA/ECM**2 |
| 12373 | C XSTHR = ONE/ECM**2 |
| 12374 | ** |
| 12375 | IF ((IP.GE.150).AND.(IT.GE.150)) |
| 12376 | & XSTHR = 2.5D0/(ECM*SQRT(ECM)) |
| 12377 | NSEA = NSEATY |
| 12378 | ENDIF |
| 12379 | * (default: SSMIMA=0.14) used for sea-diquarks (?) |
| 12380 | XSSTHR = SSMIMA/ECM |
| 12381 | BSQMA = SQMA/ECM |
| 12382 | * valence-quarks (default: CVQ=1.0) |
| 12383 | XVTHR = CVQ/ECM |
| 12384 | * valence-diquarks (default: CDQ=2.0) |
| 12385 | XDTHR = CDQ/ECM |
| 12386 | |
| 12387 | * maximum-x for sea-quarks |
| 12388 | XVCUT = XVTHR+XDTHR |
| 12389 | IF (XVCUT.GT.XVMAX) THEN |
| 12390 | XVCUT = XVMAX |
| 12391 | XVTHR = XVCUT/3.0D0 |
| 12392 | XDTHR = XVCUT-XVTHR |
| 12393 | ENDIF |
| 12394 | XXSEAM = ONE-XVCUT |
| 12395 | **sr 18.4. test: DPMJET |
| 12396 | C XXSEAM=1.0 - XVTHR*(1.D0+0.3D0*DT_RNDM(V1)) |
| 12397 | C & - XDTHR*(1.D0+0.3D0*DT_RNDM(V2)) |
| 12398 | C & -0.01*(1.D0+1.5D0*DT_RNDM(V3)) |
| 12399 | ** |
| 12400 | * maximum number of sea-pairs allowed kinematically |
| 12401 | C NSMAX = INT(OHALF*XXSEAM/XSTHR) |
| 12402 | RNSMAX = OHALF*XXSEAM/XSTHR |
| 12403 | IF (RNSMAX.GT.10000.0D0) THEN |
| 12404 | NSMAX = 10000 |
| 12405 | ELSE |
| 12406 | NSMAX = INT(OHALF*XXSEAM/XSTHR) |
| 12407 | ENDIF |
| 12408 | * check kinematical limit for valence-x thresholds |
| 12409 | * (should be obsolete now) |
| 12410 | IF (XVCUT.GT.XVMAX) THEN |
| 12411 | WRITE(LOUT,1000) XVCUT,ECM |
| 12412 | 1000 FORMAT(' XKSAMP: kin. limit for valence-x', |
| 12413 | & ' thresholds not allowed (',2E9.3,')') |
| 12414 | C XVTHR = XVMAX-XDTHR |
| 12415 | C IF (XVTHR.LT.ZERO) STOP |
| 12416 | STOP |
| 12417 | ENDIF |
| 12418 | |
| 12419 | * set eta for valence-x sampling (BETREJ) |
| 12420 | * (UNON per default, UNOM used for projectile mesons only) |
| 12421 | IF ((IJPROJ.NE.0).AND.(IBPROJ.EQ.0)) THEN |
| 12422 | UNOPRV = UNOM |
| 12423 | ELSE |
| 12424 | UNOPRV = UNON |
| 12425 | ENDIF |
| 12426 | |
| 12427 | * (2) select parton x-values of interacting projectile nucleons |
| 12428 | *----------------------------------------------------------------------- |
| 12429 | |
| 12430 | IXPV = 0 |
| 12431 | IXPS = 0 |
| 12432 | |
| 12433 | DO 100 IPP=1,IP |
| 12434 | * get interacting projectile nucleon as sampled by Glauber |
| 12435 | IF (JSSH(IPP).NE.0) THEN |
| 12436 | IXSTMP = IXPS |
| 12437 | IXVTMP = IXPV |
| 12438 | 99 CONTINUE |
| 12439 | IXPS = IXSTMP |
| 12440 | IXPV = IXVTMP |
| 12441 | * JIPP is the actual number of sea-pairs sampled for this nucleon |
| 12442 | JIPP = MIN(JSSH(IPP)-1,NSMAX) |
| 12443 | 41 CONTINUE |
| 12444 | XXSEA = ZERO |
| 12445 | IF (JIPP.GT.0) THEN |
| 12446 | XSMAX = XXSEAM-2.0D0*DBLE(JIPP)*XSTHR |
| 12447 | *??? |
| 12448 | IF (XSTHR.GE.XSMAX) THEN |
| 12449 | JIPP = JIPP-1 |
| 12450 | GOTO 41 |
| 12451 | ENDIF |
| 12452 | |
| 12453 | *>>>get x-values of sea-quark pairs |
| 12454 | NSCOUN = 0 |
| 12455 | PLW = 0.5D0 |
| 12456 | 40 CONTINUE |
| 12457 | * accumulator for sea x-values |
| 12458 | XXSEA = ZERO |
| 12459 | NSCOUN = NSCOUN+1 |
| 12460 | IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0 |
| 12461 | IF (NSCOUN.GT.NSEA) THEN |
| 12462 | * decrease the number of interactions after NSEA trials |
| 12463 | JIPP = JIPP-1 |
| 12464 | NSCOUN = 0 |
| 12465 | ENDIF |
| 12466 | DO 70 ISQ=1,JIPP |
| 12467 | * sea-quarks |
| 12468 | IF (IPSQ(IXPS+1).LE.2) THEN |
| 12469 | **sr 8.4.98 (1/sqrt(x)) |
| 12470 | C XPSQI = DT_SAMPEX(XSTHR,XSMAX) |
| 12471 | C XPSQI = DT_SAMSQX(XSTHR,XSMAX) |
| 12472 | XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW) |
| 12473 | ** |
| 12474 | ELSE |
| 12475 | IF (XSMAX.GT.XSTHR+BSQMA) THEN |
| 12476 | XPSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA) |
| 12477 | ELSE |
| 12478 | **sr 8.4.98 (1/sqrt(x)) |
| 12479 | C XPSQI = DT_SAMPEX(XSTHR,XSMAX) |
| 12480 | C XPSQI = DT_SAMSQX(XSTHR,XSMAX) |
| 12481 | XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW) |
| 12482 | ** |
| 12483 | ENDIF |
| 12484 | ENDIF |
| 12485 | * sea-antiquarks |
| 12486 | IF (IPSAQ(IXPS+1).GE.-2) THEN |
| 12487 | **sr 8.4.98 (1/sqrt(x)) |
| 12488 | C XPSAQI = DT_SAMPEX(XSTHR,XSMAX) |
| 12489 | C XPSAQI = DT_SAMSQX(XSTHR,XSMAX) |
| 12490 | XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW) |
| 12491 | ** |
| 12492 | ELSE |
| 12493 | IF (XSMAX.GT.XSTHR+BSQMA) THEN |
| 12494 | XPSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA) |
| 12495 | ELSE |
| 12496 | **sr 8.4.98 (1/sqrt(x)) |
| 12497 | C XPSAQI = DT_SAMPEX(XSTHR,XSMAX) |
| 12498 | C XPSAQI = DT_SAMSQX(XSTHR,XSMAX) |
| 12499 | XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW) |
| 12500 | ** |
| 12501 | ENDIF |
| 12502 | ENDIF |
| 12503 | XXSEA = XXSEA+XPSQI+XPSAQI |
| 12504 | * check for maximum allowed sea x-value |
| 12505 | IF (XXSEA.GE.XXSEAM) THEN |
| 12506 | IXPS = IXPS-ISQ+1 |
| 12507 | GOTO 40 |
| 12508 | ENDIF |
| 12509 | * accept this sea-quark pair |
| 12510 | IXPS = IXPS+1 |
| 12511 | XPSQ(IXPS) = XPSQI |
| 12512 | XPSAQ(IXPS) = XPSAQI |
| 12513 | IFROSP(IXPS) = IPP |
| 12514 | ZUOSP(IXPS) = .TRUE. |
| 12515 | 70 CONTINUE |
| 12516 | ENDIF |
| 12517 | |
| 12518 | *>>>get x-values of valence partons |
| 12519 | * valence quark |
| 12520 | IF (XVTHR.GT.0.05D0) THEN |
| 12521 | XVHI = ONE-XXSEA-XDTHR |
| 12522 | XPVQI = DT_BETREJ(OHALF,UNOPRV,XVTHR,XVHI) |
| 12523 | ELSE |
| 12524 | 90 CONTINUE |
| 12525 | XPVQI = DT_DBETAR(OHALF,UNOPRV) |
| 12526 | IF ((XPVQI.LT.XVTHR).OR.(ONE-XPVQI-XXSEA.LT.XDTHR)) |
| 12527 | & GOTO 90 |
| 12528 | ENDIF |
| 12529 | * valence diquark |
| 12530 | XPVDI = ONE-XPVQI-XXSEA |
| 12531 | * reject according to x**1.5 |
| 12532 | XDTMP = XPVDI**1.5D0 |
| 12533 | IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 99 |
| 12534 | * accept these valence partons |
| 12535 | IXPV = IXPV+1 |
| 12536 | XPVQ(IXPV) = XPVQI |
| 12537 | XPVD(IXPV) = XPVDI |
| 12538 | IFROVP(IXPV) = IPP |
| 12539 | ITOVP(IPP) = IXPV |
| 12540 | ZUOVP(IXPV) = .TRUE. |
| 12541 | |
| 12542 | ENDIF |
| 12543 | 100 CONTINUE |
| 12544 | |
| 12545 | * (3) select parton x-values of interacting target nucleons |
| 12546 | *----------------------------------------------------------------------- |
| 12547 | |
| 12548 | IXTV = 0 |
| 12549 | IXTS = 0 |
| 12550 | |
| 12551 | DO 170 ITT=1,IT |
| 12552 | * get interacting target nucleon as sampled by Glauber |
| 12553 | IF (JTSH(ITT).NE.0) THEN |
| 12554 | IXSTMP = IXTS |
| 12555 | IXVTMP = IXTV |
| 12556 | 169 CONTINUE |
| 12557 | IXTS = IXSTMP |
| 12558 | IXTV = IXVTMP |
| 12559 | * JITT is the actual number of sea-pairs sampled for this nucleon |
| 12560 | JITT = MIN(JTSH(ITT)-1,NSMAX) |
| 12561 | 111 CONTINUE |
| 12562 | XXSEA = ZERO |
| 12563 | IF (JITT.GT.0) THEN |
| 12564 | XSMAX = XXSEAM-2.0D0*DBLE(JITT)*XSTHR |
| 12565 | *??? |
| 12566 | IF (XSTHR.GE.XSMAX) THEN |
| 12567 | JITT = JITT-1 |
| 12568 | GOTO 111 |
| 12569 | ENDIF |
| 12570 | |
| 12571 | *>>>get x-values of sea-quark pairs |
| 12572 | NSCOUN = 0 |
| 12573 | PLW = 0.5D0 |
| 12574 | 110 CONTINUE |
| 12575 | * accumulator for sea x-values |
| 12576 | XXSEA = ZERO |
| 12577 | NSCOUN = NSCOUN+1 |
| 12578 | IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0 |
| 12579 | IF (NSCOUN.GT.NSEA)THEN |
| 12580 | * decrease the number of interactions after NSEA trials |
| 12581 | JITT = JITT-1 |
| 12582 | NSCOUN = 0 |
| 12583 | ENDIF |
| 12584 | DO 140 ISQ=1,JITT |
| 12585 | * sea-quarks |
| 12586 | IF (ITSQ(IXTS+1).LE.2) THEN |
| 12587 | **sr 8.4.98 (1/sqrt(x)) |
| 12588 | C XTSQI = DT_SAMPEX(XSTHR,XSMAX) |
| 12589 | C XTSQI = DT_SAMSQX(XSTHR,XSMAX) |
| 12590 | XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW) |
| 12591 | ** |
| 12592 | ELSE |
| 12593 | IF (XSMAX.GT.XSTHR+BSQMA) THEN |
| 12594 | XTSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA) |
| 12595 | ELSE |
| 12596 | **sr 8.4.98 (1/sqrt(x)) |
| 12597 | C XTSQI = DT_SAMPEX(XSTHR,XSMAX) |
| 12598 | C XTSQI = DT_SAMSQX(XSTHR,XSMAX) |
| 12599 | XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW) |
| 12600 | ** |
| 12601 | ENDIF |
| 12602 | ENDIF |
| 12603 | * sea-antiquarks |
| 12604 | IF (ITSAQ(IXTS+1).GE.-2) THEN |
| 12605 | **sr 8.4.98 (1/sqrt(x)) |
| 12606 | C XTSAQI = DT_SAMPEX(XSTHR,XSMAX) |
| 12607 | C XTSAQI = DT_SAMSQX(XSTHR,XSMAX) |
| 12608 | XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW) |
| 12609 | ** |
| 12610 | ELSE |
| 12611 | IF (XSMAX.GT.XSTHR+BSQMA) THEN |
| 12612 | XTSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA) |
| 12613 | ELSE |
| 12614 | **sr 8.4.98 (1/sqrt(x)) |
| 12615 | C XTSAQI = DT_SAMPEX(XSTHR,XSMAX) |
| 12616 | C XTSAQI = DT_SAMSQX(XSTHR,XSMAX) |
| 12617 | XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW) |
| 12618 | ** |
| 12619 | ENDIF |
| 12620 | ENDIF |
| 12621 | XXSEA = XXSEA+XTSQI+XTSAQI |
| 12622 | * check for maximum allowed sea x-value |
| 12623 | IF (XXSEA.GE.XXSEAM) THEN |
| 12624 | IXTS = IXTS-ISQ+1 |
| 12625 | GOTO 110 |
| 12626 | ENDIF |
| 12627 | * accept this sea-quark pair |
| 12628 | IXTS = IXTS+1 |
| 12629 | XTSQ(IXTS) = XTSQI |
| 12630 | XTSAQ(IXTS) = XTSAQI |
| 12631 | IFROST(IXTS) = ITT |
| 12632 | ZUOST(IXTS) = .TRUE. |
| 12633 | 140 CONTINUE |
| 12634 | ENDIF |
| 12635 | |
| 12636 | *>>>get x-values of valence partons |
| 12637 | * valence quark |
| 12638 | IF (XVTHR.GT.0.05D0) THEN |
| 12639 | XVHI = ONE-XXSEA-XDTHR |
| 12640 | XTVQI = DT_BETREJ(OHALF,UNON,XVTHR,XVHI) |
| 12641 | ELSE |
| 12642 | 160 CONTINUE |
| 12643 | XTVQI = DT_DBETAR(OHALF,UNON) |
| 12644 | IF ((XTVQI.LT.XVTHR).OR.(ONE-XTVQI-XXSEA.LT.XDTHR)) |
| 12645 | & GOTO 160 |
| 12646 | ENDIF |
| 12647 | * valence diquark |
| 12648 | XTVDI = ONE-XTVQI-XXSEA |
| 12649 | * reject according to x**1.5 |
| 12650 | XDTMP = XTVDI**1.5D0 |
| 12651 | IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 169 |
| 12652 | * accept these valence partons |
| 12653 | IXTV = IXTV+1 |
| 12654 | XTVQ(IXTV) = XTVQI |
| 12655 | XTVD(IXTV) = XTVDI |
| 12656 | IFROVT(IXTV) = ITT |
| 12657 | ITOVT(ITT) = IXTV |
| 12658 | ZUOVT(IXTV) = .TRUE. |
| 12659 | |
| 12660 | ENDIF |
| 12661 | 170 CONTINUE |
| 12662 | |
| 12663 | * (4) get valence-valence chains |
| 12664 | *----------------------------------------------------------------------- |
| 12665 | |
| 12666 | NVV = 0 |
| 12667 | DO 240 I=1,NN |
| 12668 | INTLO(I) = .TRUE. |
| 12669 | IPVAL = ITOVP(INTER1(I)) |
| 12670 | ITVAL = ITOVT(INTER2(I)) |
| 12671 | IF (ZUOVP(IPVAL).AND.ZUOVT(ITVAL)) THEN |
| 12672 | INTLO(I) = .FALSE. |
| 12673 | ZUOVP(IPVAL) = .FALSE. |
| 12674 | ZUOVT(ITVAL) = .FALSE. |
| 12675 | NVV = NVV+1 |
| 12676 | ISKPCH(8,NVV) = 0 |
| 12677 | INTVV1(NVV) = IPVAL |
| 12678 | INTVV2(NVV) = ITVAL |
| 12679 | ENDIF |
| 12680 | 240 CONTINUE |
| 12681 | |
| 12682 | * (5) get sea-valence chains |
| 12683 | *----------------------------------------------------------------------- |
| 12684 | |
| 12685 | NSV = 0 |
| 12686 | NDV = 0 |
| 12687 | PLW = 0.5D0 |
| 12688 | DO 270 I=1,NN |
| 12689 | IF (INTLO(I)) THEN |
| 12690 | IPVAL = ITOVP(INTER1(I)) |
| 12691 | ITVAL = ITOVT(INTER2(I)) |
| 12692 | DO 250 J=1,IXPS |
| 12693 | IF (ZUOSP(J).AND.(IFROSP(J).EQ.INTER1(I)).AND. |
| 12694 | & ZUOVT(ITVAL)) THEN |
| 12695 | ZUOSP(J) = .FALSE. |
| 12696 | ZUOVT(ITVAL) = .FALSE. |
| 12697 | INTLO(I) = .FALSE. |
| 12698 | IF (LSEADI.AND.(DT_RNDM(PLW).GT.FRCDIQ)) THEN |
| 12699 | * sample sea-diquark pair |
| 12700 | CALL DT_SAMSDQ(ECM,ITVAL,J,2,IREJ1) |
| 12701 | IF (IREJ1.EQ.0) GOTO 260 |
| 12702 | ENDIF |
| 12703 | NSV = NSV+1 |
| 12704 | ISKPCH(4,NSV) = 0 |
| 12705 | INTSV1(NSV) = J |
| 12706 | INTSV2(NSV) = ITVAL |
| 12707 | |
| 12708 | *>>>correct chain kinematics according to minimum chain masses |
| 12709 | * the actual chain masses |
| 12710 | AMSVQ1 = XPSQ(J) *XTVD(ITVAL)*ECM**2 |
| 12711 | AMSVQ2 = XPSAQ(J)*XTVQ(ITVAL)*ECM**2 |
| 12712 | * get lower mass cuts |
| 12713 | IF (IPSQ(J).EQ.3) THEN |
| 12714 | * q being s-quark |
| 12715 | AMCHK1 = AMAS |
| 12716 | AMCHK2 = AMIS |
| 12717 | ELSE |
| 12718 | * q being u/d-quark |
| 12719 | AMCHK1 = AMAU |
| 12720 | AMCHK2 = AMIU |
| 12721 | ENDIF |
| 12722 | * q-qq chain |
| 12723 | * chain mass above minimum - resampling of sea-q x-value |
| 12724 | IF (AMSVQ1.GT.AMCHK1) THEN |
| 12725 | XPSQTH = AMCHK1/(XTVD(ITVAL)*ECM**2) |
| 12726 | **sr 8.4.98 (1/sqrt(x)) |
| 12727 | C XPSQXX = DT_SAMPEX(XPSQTH,XPSQ(J)) |
| 12728 | C XPSQXX = DT_SAMSQX(XPSQTH,XPSQ(J)) |
| 12729 | XPSQXX = DT_SAMPLW(XPSQTH,XPSQ(J),PLW) |
| 12730 | ** |
| 12731 | XPVD(IPVAL) = XPVD(IPVAL)+XPSQ(J)-XPSQXX |
| 12732 | XPSQ(J) = XPSQXX |
| 12733 | * chain mass below minimum - reset sea-q x-value and correct |
| 12734 | * diquark-x of the same nucleon |
| 12735 | ELSEIF (AMSVQ1.LT.AMCHK1) THEN |
| 12736 | XPSQW = AMCHK1/(XTVD(ITVAL)*ECM**2) |
| 12737 | DXPSQ = XPSQW-XPSQ(J) |
| 12738 | IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN |
| 12739 | XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ |
| 12740 | XPSQ(J) = XPSQW |
| 12741 | ENDIF |
| 12742 | ENDIF |
| 12743 | * aq-q chain |
| 12744 | * chain mass below minimum - reset sea-aq x-value and correct |
| 12745 | * diquark-x of the same nucleon |
| 12746 | IF (AMSVQ2.LT.AMCHK2) THEN |
| 12747 | XPSQW = AMCHK2/(XTVQ(ITVAL)*ECM**2) |
| 12748 | DXPSQ = XPSQW-XPSAQ(J) |
| 12749 | IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN |
| 12750 | XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ |
| 12751 | XPSAQ(J) = XPSQW |
| 12752 | ENDIF |
| 12753 | ENDIF |
| 12754 | *>>>end of chain mass correction |
| 12755 | |
| 12756 | GOTO 260 |
| 12757 | ENDIF |
| 12758 | 250 CONTINUE |
| 12759 | ENDIF |
| 12760 | 260 CONTINUE |
| 12761 | 270 CONTINUE |
| 12762 | |
| 12763 | * (6) get valence-sea chains |
| 12764 | *----------------------------------------------------------------------- |
| 12765 | |
| 12766 | NVS = 0 |
| 12767 | NVD = 0 |
| 12768 | DO 300 I=1,NN |
| 12769 | IF (INTLO(I)) THEN |
| 12770 | IPVAL = ITOVP(INTER1(I)) |
| 12771 | ITVAL = ITOVT(INTER2(I)) |
| 12772 | DO 280 J=1,IXTS |
| 12773 | IF (ZUOVP(IPVAL).AND.ZUOST(J).AND. |
| 12774 | & (IFROST(J).EQ.INTER2(I))) THEN |
| 12775 | ZUOST(J) = .FALSE. |
| 12776 | ZUOVP(IPVAL) = .FALSE. |
| 12777 | INTLO(I) = .FALSE. |
| 12778 | IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN |
| 12779 | * sample sea-diquark pair |
| 12780 | CALL DT_SAMSDQ(ECM,IPVAL,J,1,IREJ1) |
| 12781 | IF (IREJ1.EQ.0) GOTO 290 |
| 12782 | ENDIF |
| 12783 | NVS = NVS + 1 |
| 12784 | ISKPCH(6,NVS) = 0 |
| 12785 | INTVS1(NVS) = IPVAL |
| 12786 | INTVS2(NVS) = J |
| 12787 | |
| 12788 | *>>>correct chain kinematics according to minimum chain masses |
| 12789 | * the actual chain masses |
| 12790 | AMVSQ1 = XPVQ(IPVAL)*XTSAQ(J)*ECM**2 |
| 12791 | AMVSQ2 = XPVD(IPVAL)*XTSQ(J) *ECM**2 |
| 12792 | * get lower mass cuts |
| 12793 | IF (ITSQ(J).EQ.3) THEN |
| 12794 | * q being s-quark |
| 12795 | AMCHK1 = AMIS |
| 12796 | AMCHK2 = AMAS |
| 12797 | ELSE |
| 12798 | * q being u/d-quark |
| 12799 | AMCHK1 = AMIU |
| 12800 | AMCHK2 = AMAU |
| 12801 | ENDIF |
| 12802 | * q-aq chain |
| 12803 | * chain mass below minimum - reset sea-aq x-value and correct |
| 12804 | * diquark-x of the same nucleon |
| 12805 | IF (AMVSQ1.LT.AMCHK1) THEN |
| 12806 | XTSQW = AMCHK1/(XPVQ(IPVAL)*ECM**2) |
| 12807 | DXTSQ = XTSQW-XTSAQ(J) |
| 12808 | IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN |
| 12809 | XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ |
| 12810 | XTSAQ(J) = XTSQW |
| 12811 | ENDIF |
| 12812 | ENDIF |
| 12813 | * qq-q chain |
| 12814 | * chain mass above minimum - resampling of sea-q x-value |
| 12815 | IF (AMVSQ2.GT.AMCHK2) THEN |
| 12816 | XTSQTH = AMCHK2/(XPVD(IPVAL)*ECM**2) |
| 12817 | **sr 8.4.98 (1/sqrt(x)) |
| 12818 | C XTSQXX = DT_SAMPEX(XTSQTH,XTSQ(J)) |
| 12819 | C XTSQXX = DT_SAMSQX(XTSQTH,XTSQ(J)) |
| 12820 | XTSQXX = DT_SAMPLW(XTSQTH,XTSQ(J),PLW) |
| 12821 | ** |
| 12822 | XTVD(ITVAL) = XTVD(ITVAL)+XTSQ(J)-XTSQXX |
| 12823 | XTSQ(J) = XTSQXX |
| 12824 | * chain mass below minimum - reset sea-q x-value and correct |
| 12825 | * diquark-x of the same nucleon |
| 12826 | ELSEIF (AMVSQ2.LT.AMCHK2) THEN |
| 12827 | XTSQW = AMCHK2/(XPVD(IPVAL)*ECM**2) |
| 12828 | DXTSQ = XTSQW-XTSQ(J) |
| 12829 | IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN |
| 12830 | XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ |
| 12831 | XTSQ(J) = XTSQW |
| 12832 | ENDIF |
| 12833 | ENDIF |
| 12834 | *>>>end of chain mass correction |
| 12835 | |
| 12836 | GOTO 290 |
| 12837 | ENDIF |
| 12838 | 280 CONTINUE |
| 12839 | ENDIF |
| 12840 | 290 CONTINUE |
| 12841 | 300 CONTINUE |
| 12842 | |
| 12843 | * (7) get sea-sea chains |
| 12844 | *----------------------------------------------------------------------- |
| 12845 | |
| 12846 | NSS = 0 |
| 12847 | NDS = 0 |
| 12848 | NSD = 0 |
| 12849 | DO 420 I=1,NN |
| 12850 | IF (INTLO(I)) THEN |
| 12851 | IPVAL = ITOVP(INTER1(I)) |
| 12852 | ITVAL = ITOVT(INTER2(I)) |
| 12853 | * loop over target partons not yet matched |
| 12854 | DO 400 J=1,IXTS |
| 12855 | IF (ZUOST(J).AND.(IFROST(J).EQ.INTER2(I))) THEN |
| 12856 | * loop over projectile partons not yet matched |
| 12857 | DO 390 JJ=1,IXPS |
| 12858 | IF (ZUOSP(JJ).AND.(IFROSP(JJ).EQ.INTER1(I))) THEN |
| 12859 | ZUOSP(JJ) = .FALSE. |
| 12860 | ZUOST(J) = .FALSE. |
| 12861 | INTLO(I) = .FALSE. |
| 12862 | NSS = NSS+1 |
| 12863 | ISKPCH(1,NSS) = 0 |
| 12864 | INTSS1(NSS) = JJ |
| 12865 | INTSS2(NSS) = J |
| 12866 | |
| 12867 | *---->chain recombination option |
| 12868 | VALFRA = DBLE(NVV/(NVV+IXPS+IXTS)) |
| 12869 | IF (IRECOM.EQ.1.AND.(DT_RNDM(BSQMA).GT.VALFRA)) |
| 12870 | & THEN |
| 12871 | * sea-sea chains may recombine with valence-valence chains |
| 12872 | * only if they have the same projectile or target nucleon |
| 12873 | DO 4201 IVV=1,NVV |
| 12874 | IF (ISKPCH(8,IVV).NE.99) THEN |
| 12875 | IXVPR = INTVV1(IVV) |
| 12876 | IXVTA = INTVV2(IVV) |
| 12877 | IF ((INTER1(I).EQ.IFROVP(IXVPR)).OR. |
| 12878 | & (INTER2(I).EQ.IFROVT(IXVTA))) THEN |
| 12879 | * recombination possible, drop old v-v and s-s chains |
| 12880 | ISKPCH(1,NSS) = 99 |
| 12881 | ISKPCH(8,IVV) = 99 |
| 12882 | |
| 12883 | * (a) assign new s-v chains |
| 12884 | * ~~~~~~~~~~~~~~~~~~~~~~~~~ |
| 12885 | IF (LSEADI.AND. |
| 12886 | & (DT_RNDM(VALFRA).GT.FRCDIQ)) |
| 12887 | & THEN |
| 12888 | * sample sea-diquark pair |
| 12889 | CALL DT_SAMSDQ(ECM,IXVTA,JJ,2, |
| 12890 | & IREJ1) |
| 12891 | IF (IREJ1.EQ.0) GOTO 4202 |
| 12892 | ENDIF |
| 12893 | NSV = NSV+1 |
| 12894 | ISKPCH(4,NSV) = 0 |
| 12895 | INTSV1(NSV) = JJ |
| 12896 | INTSV2(NSV) = IXVTA |
| 12897 | *>>>>>>>>>>>correct chain kinematics according to minimum chain masses |
| 12898 | * the actual chain masses |
| 12899 | AMSVQ1 = XPSQ(JJ) *XTVD(IXVTA) |
| 12900 | & *ECM**2 |
| 12901 | AMSVQ2 = XPSAQ(JJ)*XTVQ(IXVTA) |
| 12902 | & *ECM**2 |
| 12903 | * get lower mass cuts |
| 12904 | IF (IPSQ(JJ).EQ.3) THEN |
| 12905 | * q being s-quark |
| 12906 | AMCHK1 = AMAS |
| 12907 | AMCHK2 = AMIS |
| 12908 | ELSE |
| 12909 | * q being u/d-quark |
| 12910 | AMCHK1 = AMAU |
| 12911 | AMCHK2 = AMIU |
| 12912 | ENDIF |
| 12913 | * q-qq chain |
| 12914 | * chain mass above minimum - resampling of sea-q x-value |
| 12915 | IF (AMSVQ1.GT.AMCHK1) THEN |
| 12916 | XPSQTH = |
| 12917 | & AMCHK1/(XTVD(IXVTA)*ECM**2) |
| 12918 | **sr 8.4.98 (1/sqrt(x)) |
| 12919 | XPSQXX = |
| 12920 | & DT_SAMPLW(XPSQTH,XPSQ(JJ),PLW) |
| 12921 | C & DT_SAMSQX(XPSQTH,XPSQ(JJ)) |
| 12922 | C & DT_SAMPEX(XPSQTH,XPSQ(JJ)) |
| 12923 | ** |
| 12924 | XPVD(IPVAL) = |
| 12925 | & XPVD(IPVAL)+XPSQ(JJ)-XPSQXX |
| 12926 | XPSQ(JJ) = XPSQXX |
| 12927 | * chain mass below minimum - reset sea-q x-value and correct |
| 12928 | * diquark-x of the same nucleon |
| 12929 | ELSEIF (AMSVQ1.LT.AMCHK1) THEN |
| 12930 | XPSQW = |
| 12931 | & AMCHK1/(XTVD(IXVTA)*ECM**2) |
| 12932 | DXPSQ = XPSQW-XPSQ(JJ) |
| 12933 | IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) |
| 12934 | & THEN |
| 12935 | XPVD(IPVAL) = |
| 12936 | & XPVD(IPVAL)-DXPSQ |
| 12937 | XPSQ(JJ) = XPSQW |
| 12938 | ENDIF |
| 12939 | ENDIF |
| 12940 | * aq-q chain |
| 12941 | * chain mass below minimum - reset sea-aq x-value and correct |
| 12942 | * diquark-x of the same nucleon |
| 12943 | IF (AMSVQ2.LT.AMCHK2) THEN |
| 12944 | XPSQW = |
| 12945 | & AMCHK2/(XTVQ(IXVTA)*ECM**2) |
| 12946 | DXPSQ = XPSQW-XPSAQ(JJ) |
| 12947 | IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) |
| 12948 | & THEN |
| 12949 | XPVD(IPVAL) = |
| 12950 | & XPVD(IPVAL)-DXPSQ |
| 12951 | XPSAQ(JJ) = XPSQW |
| 12952 | ENDIF |
| 12953 | ENDIF |
| 12954 | *>>>>>>>>>>>end of chain mass correction |
| 12955 | 4202 CONTINUE |
| 12956 | |
| 12957 | * (b) assign new v-s chains |
| 12958 | * ~~~~~~~~~~~~~~~~~~~~~~~~~ |
| 12959 | IF (LSEADI.AND.( |
| 12960 | & DT_RNDM(AMSVQ2).GT.FRCDIQ)) |
| 12961 | & THEN |
| 12962 | * sample sea-diquark pair |
| 12963 | CALL DT_SAMSDQ(ECM,IXVPR,J,1, |
| 12964 | & IREJ1) |
| 12965 | IF (IREJ1.EQ.0) GOTO 4203 |
| 12966 | ENDIF |
| 12967 | NVS = NVS+1 |
| 12968 | ISKPCH(6,NVS) = 0 |
| 12969 | INTVS1(NVS) = IXVPR |
| 12970 | INTVS2(NVS) = J |
| 12971 | *>>>>>>>>>>>correct chain kinematics according to minimum chain masses |
| 12972 | * the actual chain masses |
| 12973 | AMVSQ1 = XPVQ(IXVPR)*XTSAQ(J)*ECM**2 |
| 12974 | AMVSQ2 = XPVD(IXVPR)*XTSQ(J) *ECM**2 |
| 12975 | * get lower mass cuts |
| 12976 | IF (ITSQ(J).EQ.3) THEN |
| 12977 | * q being s-quark |
| 12978 | AMCHK1 = AMIS |
| 12979 | AMCHK2 = AMAS |
| 12980 | ELSE |
| 12981 | * q being u/d-quark |
| 12982 | AMCHK1 = AMIU |
| 12983 | AMCHK2 = AMAU |
| 12984 | ENDIF |
| 12985 | * q-aq chain |
| 12986 | * chain mass below minimum - reset sea-aq x-value and correct |
| 12987 | * diquark-x of the same nucleon |
| 12988 | IF (AMVSQ1.LT.AMCHK1) THEN |
| 12989 | XTSQW = |
| 12990 | & AMCHK1/(XPVQ(IXVPR)*ECM**2) |
| 12991 | DXTSQ = XTSQW-XTSAQ(J) |
| 12992 | IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) |
| 12993 | & THEN |
| 12994 | XTVD(ITVAL) = |
| 12995 | & XTVD(ITVAL)-DXTSQ |
| 12996 | XTSAQ(J) = XTSQW |
| 12997 | ENDIF |
| 12998 | ENDIF |
| 12999 | IF (AMVSQ2.GT.AMCHK2) THEN |
| 13000 | XTSQTH = |
| 13001 | & AMCHK2/(XPVD(IXVPR)*ECM**2) |
| 13002 | **sr 8.4.98 (1/sqrt(x)) |
| 13003 | XTSQXX = |
| 13004 | & DT_SAMPLW(XTSQTH,XTSQ(J),PLW) |
| 13005 | C & DT_SAMSQX(XTSQTH,XTSQ(J)) |
| 13006 | C & DT_SAMPEX(XTSQTH,XTSQ(J)) |
| 13007 | ** |
| 13008 | XTVD(ITVAL) = |
| 13009 | & XTVD(ITVAL)+XTSQ(J)-XTSQXX |
| 13010 | XTSQ(J) = XTSQXX |
| 13011 | ELSEIF (AMVSQ2.LT.AMCHK2) THEN |
| 13012 | XTSQW = |
| 13013 | & AMCHK2/(XPVD(IXVPR)*ECM**2) |
| 13014 | DXTSQ = XTSQW-XTSQ(J) |
| 13015 | IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) |
| 13016 | & THEN |
| 13017 | XTVD(ITVAL) = |
| 13018 | & XTVD(ITVAL)-DXTSQ |
| 13019 | XTSQ(J) = XTSQW |
| 13020 | ENDIF |
| 13021 | ENDIF |
| 13022 | *>>>>>>>>>end of chain mass correction |
| 13023 | 4203 CONTINUE |
| 13024 | * jump out of s-s chain loop |
| 13025 | GOTO 420 |
| 13026 | ENDIF |
| 13027 | ENDIF |
| 13028 | 4201 CONTINUE |
| 13029 | ENDIF |
| 13030 | *---->end of chain recombination option |
| 13031 | |
| 13032 | * sample sea-diquark pair (projectile) |
| 13033 | IF (LSEADI.AND.(DT_RNDM(BSQMA).GT.FRCDIQ)) THEN |
| 13034 | CALL DT_SAMSDQ(ECM,J,JJ,4,IREJ1) |
| 13035 | IF (IREJ1.EQ.0) THEN |
| 13036 | ISKPCH(1,NSS) = 99 |
| 13037 | GOTO 410 |
| 13038 | ENDIF |
| 13039 | ENDIF |
| 13040 | * sample sea-diquark pair (target) |
| 13041 | IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN |
| 13042 | CALL DT_SAMSDQ(ECM,JJ,J,3,IREJ1) |
| 13043 | IF (IREJ1.EQ.0) THEN |
| 13044 | ISKPCH(1,NSS) = 99 |
| 13045 | GOTO 410 |
| 13046 | ENDIF |
| 13047 | ENDIF |
| 13048 | *>>>>>correct chain kinematics according to minimum chain masses |
| 13049 | * the actual chain masses |
| 13050 | SSMA1Q = XPSQ(JJ) *XTSAQ(J)*ECM**2 |
| 13051 | SSMA2Q = XPSAQ(JJ)*XTSQ(J) *ECM**2 |
| 13052 | * check for lower mass cuts |
| 13053 | IF ((SSMA1Q.LT.SSMIMQ).OR. |
| 13054 | & (SSMA2Q.LT.SSMIMQ)) THEN |
| 13055 | IPVAL = ITOVP(INTER1(I)) |
| 13056 | ITVAL = ITOVT(INTER2(I)) |
| 13057 | IF ((XPVD(IPVAL).GT.XDTHR+3.5D0*XSSTHR).AND. |
| 13058 | & (XTVD(ITVAL).GT.XDTHR+3.5D0*XSSTHR))THEN |
| 13059 | * maximum allowed x values for sea quarks |
| 13060 | XSPMAX = ONE-XPVQ(IPVAL)-XDTHR- |
| 13061 | & 1.2D0*XSSTHR |
| 13062 | XSTMAX = ONE-XTVQ(ITVAL)-XDTHR- |
| 13063 | & 1.2D0*XSSTHR |
| 13064 | * resampling of x values not possible - skip sea-sea chains |
| 13065 | IF ((XSPMAX.LE.XSSTHR+0.05D0).OR. |
| 13066 | & (XSTMAX.LE.XSSTHR+0.05D0)) GOTO 380 |
| 13067 | * resampling of x for projectile sea quark pair |
| 13068 | ICOUS = 0 |
| 13069 | 310 CONTINUE |
| 13070 | ICOUS = ICOUS+1 |
| 13071 | IF (XSSTHR.GT.0.05D0) THEN |
| 13072 | XPSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR, |
| 13073 | & XSPMAX) |
| 13074 | XPSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR, |
| 13075 | & XSPMAX) |
| 13076 | ELSE |
| 13077 | 320 CONTINUE |
| 13078 | XPSQI = DT_DBETAR(XSEACU,UNOSEA) |
| 13079 | IF ((XPSQI.LT.XSSTHR).OR. |
| 13080 | & (XPSQI.GT.XSPMAX)) GOTO 320 |
| 13081 | 330 CONTINUE |
| 13082 | XPSAQI = DT_DBETAR(XSEACU,UNOSEA) |
| 13083 | IF ((XPSAQI.LT.XSSTHR).OR. |
| 13084 | & (XPSAQI.GT.XSPMAX)) GOTO 330 |
| 13085 | ENDIF |
| 13086 | * final test of remaining x for projectile diquark |
| 13087 | XPVDCO = XPVD(IPVAL)-XPSQI-XPSAQI |
| 13088 | & +XPSQ(JJ)+XPSAQ(JJ) |
| 13089 | IF (XPVDCO.LE.XDTHR) THEN |
| 13090 | *!!! |
| 13091 | C IF (ICOUS.LT.5) GOTO 310 |
| 13092 | IF (ICOUS.LT.0.5D0) GOTO 310 |
| 13093 | GOTO 380 |
| 13094 | ENDIF |
| 13095 | * resampling of x for target sea quark pair |
| 13096 | ICOUS = 0 |
| 13097 | 350 CONTINUE |
| 13098 | ICOUS = ICOUS+1 |
| 13099 | IF (XSSTHR.GT.0.05D0) THEN |
| 13100 | XTSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR, |
| 13101 | & XSTMAX) |
| 13102 | XTSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR, |
| 13103 | & XSTMAX) |
| 13104 | ELSE |
| 13105 | 360 CONTINUE |
| 13106 | XTSQI = DT_DBETAR(XSEACU,UNOSEA) |
| 13107 | IF ((XTSQI.LT.XSSTHR).OR. |
| 13108 | & (XTSQI.GT.XSTMAX)) GOTO 360 |
| 13109 | 370 CONTINUE |
| 13110 | XTSAQI = DT_DBETAR(XSEACU,UNOSEA) |
| 13111 | IF ((XTSAQI.LT.XSSTHR).OR. |
| 13112 | & (XTSAQI.GT.XSTMAX)) GOTO 370 |
| 13113 | ENDIF |
| 13114 | * final test of remaining x for target diquark |
| 13115 | XTVDCO = XTVD(ITVAL)-XTSQI-XTSAQI |
| 13116 | & +XTSQ(J)+XTSAQ(J) |
| 13117 | IF (XTVDCO.LT.XDTHR) THEN |
| 13118 | IF (ICOUS.LT.5) GOTO 350 |
| 13119 | GOTO 380 |
| 13120 | ENDIF |
| 13121 | XPVD(IPVAL) = XPVDCO |
| 13122 | XTVD(ITVAL) = XTVDCO |
| 13123 | XPSQ(JJ) = XPSQI |
| 13124 | XPSAQ(JJ) = XPSAQI |
| 13125 | XTSQ(J) = XTSQI |
| 13126 | XTSAQ(J) = XTSAQI |
| 13127 | *>>>>>end of chain mass correction |
| 13128 | GOTO 410 |
| 13129 | ENDIF |
| 13130 | * come here to discard s-s interaction |
| 13131 | * resampling of x values not allowed or unsuccessful |
| 13132 | 380 CONTINUE |
| 13133 | INTLO(I) = .FALSE. |
| 13134 | ZUOST(J) = .TRUE. |
| 13135 | ZUOSP(JJ) = .TRUE. |
| 13136 | NSS = NSS-1 |
| 13137 | ENDIF |
| 13138 | * consider next s-s interaction |
| 13139 | GOTO 410 |
| 13140 | ENDIF |
| 13141 | 390 CONTINUE |
| 13142 | ENDIF |
| 13143 | 400 CONTINUE |
| 13144 | ENDIF |
| 13145 | 410 CONTINUE |
| 13146 | 420 CONTINUE |
| 13147 | |
| 13148 | * correct x-values of valence quarks for non-matching sea quarks |
| 13149 | DO 430 I=1,IXPS |
| 13150 | IF (ZUOSP(I)) THEN |
| 13151 | IPVAL = ITOVP(IFROSP(I)) |
| 13152 | XPVQ(IPVAL) = XPVQ(IPVAL)+XPSQ(I)+XPSAQ(I) |
| 13153 | XPSQ(I) = ZERO |
| 13154 | XPSAQ(I) = ZERO |
| 13155 | ZUOSP(I) = .FALSE. |
| 13156 | ENDIF |
| 13157 | 430 CONTINUE |
| 13158 | DO 440 I=1,IXTS |
| 13159 | IF (ZUOST(I)) THEN |
| 13160 | ITVAL = ITOVT(IFROST(I)) |
| 13161 | XTVQ(ITVAL) = XTVQ(ITVAL)+XTSQ(I)+XTSAQ(I) |
| 13162 | XTSQ(I) = ZERO |
| 13163 | XTSAQ(I) = ZERO |
| 13164 | ZUOST(I) = .FALSE. |
| 13165 | ENDIF |
| 13166 | 440 CONTINUE |
| 13167 | DO 450 I=1,IXPV |
| 13168 | IF (ZUOVP(I)) ISTHKK(IFROVP(I)) = 13 |
| 13169 | 450 CONTINUE |
| 13170 | DO 460 I=1,IXTV |
| 13171 | IF (ZUOVT(I)) ISTHKK(IFROVT(I)+IP) = 14 |
| 13172 | 460 CONTINUE |
| 13173 | |
| 13174 | RETURN |
| 13175 | END |
| 13176 | |
| 13177 | *$ CREATE DT_SAMSDQ.FOR |
| 13178 | *COPY DT_SAMSDQ |
| 13179 | * |
| 13180 | *===samsdq=============================================================* |
| 13181 | * |
| 13182 | SUBROUTINE DT_SAMSDQ(ECM,IDX1,IDX2,MODE,IREJ) |
| 13183 | |
| 13184 | ************************************************************************ |
| 13185 | * SAMpling of Sea-DiQuarks * |
| 13186 | * ECM cm-energy of the nucleon-nucleon system * |
| 13187 | * IDX1,2 indices of x-values of the participating * |
| 13188 | * partons (IDX2 is always the sea-q-pair to be * |
| 13189 | * changed to sea-qq-pair) * |
| 13190 | * MODE = 1 valence-q - sea-diq * |
| 13191 | * = 2 sea-diq - valence-q * |
| 13192 | * = 3 sea-q - sea-diq * |
| 13193 | * = 4 sea-diq - sea-q * |
| 13194 | * Based on DIQVS, DIQSV, DIQSSD, DIQDSS. * |
| 13195 | * This version dated 17.10.95 is written by S. Roesler * |
| 13196 | ************************************************************************ |
| 13197 | |
| 13198 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 13199 | SAVE |
| 13200 | |
| 13201 | PARAMETER (ZERO=0.0D0) |
| 13202 | |
| 13203 | * threshold values for x-sampling (DTUNUC 1.x) |
| 13204 | COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA, |
| 13205 | & SSMIMQ,VVMTHR |
| 13206 | * various options for treatment of partons (DTUNUC 1.x) |
| 13207 | * (chain recombination, Cronin,..) |
| 13208 | LOGICAL LCO2CR,LINTPT |
| 13209 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, |
| 13210 | & LCO2CR,LINTPT |
| 13211 | PARAMETER ( MAXNCL = 260, |
| 13212 | & MAXVQU = MAXNCL, |
| 13213 | & MAXSQU = 20*MAXVQU, |
| 13214 | & MAXINT = MAXVQU+MAXSQU) |
| 13215 | * x-values of partons (DTUNUC 1.x) |
| 13216 | COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU), |
| 13217 | & XTVQ(MAXVQU),XTVD(MAXVQU), |
| 13218 | & XPSQ(MAXSQU),XPSAQ(MAXSQU), |
| 13219 | & XTSQ(MAXSQU),XTSAQ(MAXSQU) |
| 13220 | * flavors of partons (DTUNUC 1.x) |
| 13221 | COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU), |
| 13222 | & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU), |
| 13223 | & IPSQ(MAXSQU),IPSQ2(MAXSQU), |
| 13224 | & IPSAQ(MAXSQU),IPSAQ2(MAXSQU), |
| 13225 | & ITSQ(MAXSQU),ITSQ2(MAXSQU), |
| 13226 | & ITSAQ(MAXSQU),ITSAQ2(MAXSQU), |
| 13227 | & KKPROJ(MAXVQU),KKTARG(MAXVQU) |
| 13228 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) |
| 13229 | COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD, |
| 13230 | & IXPV,IXPS,IXTV,IXTS, |
| 13231 | & INTVV1(MAXVQU),INTVV2(MAXVQU), |
| 13232 | & INTSV1(MAXVQU),INTSV2(MAXVQU), |
| 13233 | & INTVS1(MAXVQU),INTVS2(MAXVQU), |
| 13234 | & INTSS1(MAXSQU),INTSS2(MAXSQU), |
| 13235 | & INTDV1(MAXVQU),INTDV2(MAXVQU), |
| 13236 | & INTVD1(MAXVQU),INTVD2(MAXVQU), |
| 13237 | & INTDS1(MAXSQU),INTDS2(MAXSQU), |
| 13238 | & INTSD1(MAXSQU),INTSD2(MAXSQU) |
| 13239 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) |
| 13240 | COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU), |
| 13241 | & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU) |
| 13242 | * auxiliary common for chain system storage (DTUNUC 1.x) |
| 13243 | COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL) |
| 13244 | |
| 13245 | IREJ = 0 |
| 13246 | * threshold-x for valence diquarks |
| 13247 | XDTHR = CDQ/ECM |
| 13248 | |
| 13249 | GOTO (1,2,3,4) MODE |
| 13250 | |
| 13251 | *--------------------------------------------------------------------- |
| 13252 | * proj. valence partons - targ. sea partons |
| 13253 | * get x-values and flavors for target sea-diquark pair |
| 13254 | |
| 13255 | 1 CONTINUE |
| 13256 | IDXVP = IDX1 |
| 13257 | IDXST = IDX2 |
| 13258 | |
| 13259 | * index of corr. val-diquark-x in target nucleon |
| 13260 | IDXVT = ITOVT(IFROST(IDXST)) |
| 13261 | * available x above diquark thresholds for valence- and sea-diquarks |
| 13262 | XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR |
| 13263 | |
| 13264 | IF (XXD.GE.ZERO) THEN |
| 13265 | * x-values for the three diquarks of the target nucleon |
| 13266 | RR1 = DT_RNDM(XXD) |
| 13267 | RR2 = DT_RNDM(RR1) |
| 13268 | RR3 = DT_RNDM(RR2) |
| 13269 | SR123 = RR1+RR2+RR3 |
| 13270 | XXTV = XDTHR+RR1*XXD/SR123 |
| 13271 | XXTSQ = XDTHR+RR2*XXD/SR123 |
| 13272 | XXTSAQ = XDTHR+RR3*XXD/SR123 |
| 13273 | ELSE |
| 13274 | XXTV = XTVD(IDXVT) |
| 13275 | XXTSQ = XTSQ(IDXST) |
| 13276 | XXTSAQ = XTSAQ(IDXST) |
| 13277 | ENDIF |
| 13278 | * flavor of the second quarks in the sea-diquark pair |
| 13279 | ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ)) |
| 13280 | ITSAQ2(IDXST) = -ITSQ2(IDXST) |
| 13281 | * check masses of the new val-q - sea-qq, val-qq - sea-aqaq chains |
| 13282 | AM1 = XXTSQ *XPVQ(IDXVP)*ECM**2 |
| 13283 | AM2 = XXTSAQ*XPVD(IDXVP)*ECM**2 |
| 13284 | IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND. |
| 13285 | * ss-asas pair |
| 13286 | & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN |
| 13287 | IREJ = 1 |
| 13288 | RETURN |
| 13289 | ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND. |
| 13290 | * at least one strange quark |
| 13291 | & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN |
| 13292 | IREJ = 1 |
| 13293 | RETURN |
| 13294 | ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN |
| 13295 | IREJ = 1 |
| 13296 | RETURN |
| 13297 | ENDIF |
| 13298 | * accept the new sea-diquark |
| 13299 | XTVD(IDXVT) = XXTV |
| 13300 | XTSQ(IDXST) = XXTSQ |
| 13301 | XTSAQ(IDXST) = XXTSAQ |
| 13302 | NVD = NVD+1 |
| 13303 | INTVD1(NVD) = IDXVP |
| 13304 | INTVD2(NVD) = IDXST |
| 13305 | ISKPCH(7,NVD) = 0 |
| 13306 | RETURN |
| 13307 | |
| 13308 | *--------------------------------------------------------------------- |
| 13309 | * proj. sea partons - targ. valence partons |
| 13310 | * get x-values and flavors for projectile sea-diquark pair |
| 13311 | |
| 13312 | 2 CONTINUE |
| 13313 | IDXSP = IDX2 |
| 13314 | IDXVT = IDX1 |
| 13315 | |
| 13316 | * index of corr. val-diquark-x in projectile nucleon |
| 13317 | IDXVP = ITOVP(IFROSP(IDXSP)) |
| 13318 | * available x above diquark thresholds for valence- and sea-diquarks |
| 13319 | XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR |
| 13320 | |
| 13321 | IF (XXD.GE.ZERO) THEN |
| 13322 | * x-values for the three diquarks of the projectile nucleon |
| 13323 | RR1 = DT_RNDM(XXD) |
| 13324 | RR2 = DT_RNDM(RR1) |
| 13325 | RR3 = DT_RNDM(RR2) |
| 13326 | SR123 = RR1+RR2+RR3 |
| 13327 | XXPV = XDTHR+RR1*XXD/SR123 |
| 13328 | XXPSQ = XDTHR+RR2*XXD/SR123 |
| 13329 | XXPSAQ = XDTHR+RR3*XXD/SR123 |
| 13330 | ELSE |
| 13331 | XXPV = XPVD(IDXVP) |
| 13332 | XXPSQ = XPSQ(IDXSP) |
| 13333 | XXPSAQ = XPSAQ(IDXSP) |
| 13334 | ENDIF |
| 13335 | * flavor of the second quarks in the sea-diquark pair |
| 13336 | IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ)) |
| 13337 | IPSAQ2(IDXSP) = -IPSQ2(IDXSP) |
| 13338 | * check masses of the new sea-qq - val-q, sea-aqaq - val-qq chains |
| 13339 | AM1 = XXPSQ *XTVQ(IDXVT)*ECM**2 |
| 13340 | AM2 = XXPSAQ*XTVD(IDXVT)*ECM**2 |
| 13341 | IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND. |
| 13342 | * ss-asas pair |
| 13343 | & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN |
| 13344 | IREJ = 1 |
| 13345 | RETURN |
| 13346 | ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND. |
| 13347 | * at least one strange quark |
| 13348 | & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN |
| 13349 | IREJ = 1 |
| 13350 | RETURN |
| 13351 | ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN |
| 13352 | IREJ = 1 |
| 13353 | RETURN |
| 13354 | ENDIF |
| 13355 | * accept the new sea-diquark |
| 13356 | XPVD(IDXVP) = XXPV |
| 13357 | XPSQ(IDXSP) = XXPSQ |
| 13358 | XPSAQ(IDXSP) = XXPSAQ |
| 13359 | NDV = NDV+1 |
| 13360 | INTDV1(NDV) = IDXSP |
| 13361 | INTDV2(NDV) = IDXVT |
| 13362 | ISKPCH(5,NDV) = 0 |
| 13363 | RETURN |
| 13364 | |
| 13365 | *--------------------------------------------------------------------- |
| 13366 | * proj. sea partons - targ. sea partons |
| 13367 | * get x-values and flavors for target sea-diquark pair |
| 13368 | |
| 13369 | 3 CONTINUE |
| 13370 | IDXSP = IDX1 |
| 13371 | IDXST = IDX2 |
| 13372 | |
| 13373 | * index of corr. val-diquark-x in target nucleon |
| 13374 | IDXVT = ITOVT(IFROST(IDXST)) |
| 13375 | * available x above diquark thresholds for valence- and sea-diquarks |
| 13376 | XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR |
| 13377 | |
| 13378 | IF (XXD.GE.ZERO) THEN |
| 13379 | * x-values for the three diquarks of the target nucleon |
| 13380 | RR1 = DT_RNDM(XXD) |
| 13381 | RR2 = DT_RNDM(RR1) |
| 13382 | RR3 = DT_RNDM(RR2) |
| 13383 | SR123 = RR1+RR2+RR3 |
| 13384 | XXTV = XDTHR+RR1*XXD/SR123 |
| 13385 | XXTSQ = XDTHR+RR2*XXD/SR123 |
| 13386 | XXTSAQ = XDTHR+RR3*XXD/SR123 |
| 13387 | ELSE |
| 13388 | XXTV = XTVD(IDXVT) |
| 13389 | XXTSQ = XTSQ(IDXST) |
| 13390 | XXTSAQ = XTSAQ(IDXST) |
| 13391 | ENDIF |
| 13392 | * flavor of the second quarks in the sea-diquark pair |
| 13393 | ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ)) |
| 13394 | ITSAQ2(IDXST) = -ITSQ2(IDXST) |
| 13395 | * check masses of the new sea-q - sea-qq, sea-aq - sea-aqaq chains |
| 13396 | AM1 = XXTSQ *XPSQ(IDXSP)*ECM**2 |
| 13397 | AM2 = XXTSAQ*XPSAQ(IDXSP)*ECM**2 |
| 13398 | IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND. |
| 13399 | * ss-asas pair |
| 13400 | & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN |
| 13401 | IREJ = 1 |
| 13402 | RETURN |
| 13403 | ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND. |
| 13404 | * at least one strange quark |
| 13405 | & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN |
| 13406 | IREJ = 1 |
| 13407 | RETURN |
| 13408 | ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN |
| 13409 | IREJ = 1 |
| 13410 | RETURN |
| 13411 | ENDIF |
| 13412 | * accept the new sea-diquark |
| 13413 | XTVD(IDXVT) = XXTV |
| 13414 | XTSQ(IDXST) = XXTSQ |
| 13415 | XTSAQ(IDXST) = XXTSAQ |
| 13416 | NSD = NSD+1 |
| 13417 | INTSD1(NSD) = IDXSP |
| 13418 | INTSD2(NSD) = IDXST |
| 13419 | ISKPCH(3,NSD) = 0 |
| 13420 | RETURN |
| 13421 | |
| 13422 | *--------------------------------------------------------------------- |
| 13423 | * proj. sea partons - targ. sea partons |
| 13424 | * get x-values and flavors for projectile sea-diquark pair |
| 13425 | |
| 13426 | 4 CONTINUE |
| 13427 | IDXSP = IDX2 |
| 13428 | IDXST = IDX1 |
| 13429 | |
| 13430 | * index of corr. val-diquark-x in projectile nucleon |
| 13431 | IDXVP = ITOVP(IFROSP(IDXSP)) |
| 13432 | * available x above diquark thresholds for valence- and sea-diquarks |
| 13433 | XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR |
| 13434 | |
| 13435 | IF (XXD.GE.ZERO) THEN |
| 13436 | * x-values for the three diquarks of the projectile nucleon |
| 13437 | RR1 = DT_RNDM(XXD) |
| 13438 | RR2 = DT_RNDM(RR1) |
| 13439 | RR3 = DT_RNDM(RR2) |
| 13440 | SR123 = RR1+RR2+RR3 |
| 13441 | XXPV = XDTHR+RR1*XXD/SR123 |
| 13442 | XXPSQ = XDTHR+RR2*XXD/SR123 |
| 13443 | XXPSAQ = XDTHR+RR3*XXD/SR123 |
| 13444 | ELSE |
| 13445 | XXPV = XPVD(IDXVP) |
| 13446 | XXPSQ = XPSQ(IDXSP) |
| 13447 | XXPSAQ = XPSAQ(IDXSP) |
| 13448 | ENDIF |
| 13449 | * flavor of the second quarks in the sea-diquark pair |
| 13450 | IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ)) |
| 13451 | IPSAQ2(IDXSP) = -IPSQ2(IDXSP) |
| 13452 | * check masses of the new sea-qq - sea-q, sea-aqaq - sea-qq chains |
| 13453 | AM1 = XXPSQ *XTSQ(IDXST)*ECM**2 |
| 13454 | AM2 = XXPSAQ*XTSAQ(IDXST)*ECM**2 |
| 13455 | IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND. |
| 13456 | * ss-asas pair |
| 13457 | & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN |
| 13458 | IREJ = 1 |
| 13459 | RETURN |
| 13460 | ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND. |
| 13461 | * at least one strange quark |
| 13462 | & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN |
| 13463 | IREJ = 1 |
| 13464 | RETURN |
| 13465 | ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN |
| 13466 | IREJ = 1 |
| 13467 | RETURN |
| 13468 | ENDIF |
| 13469 | * accept the new sea-diquark |
| 13470 | XPVD(IDXVP) = XXPV |
| 13471 | XPSQ(IDXSP) = XXPSQ |
| 13472 | XPSAQ(IDXSP) = XXPSAQ |
| 13473 | NDS = NDS+1 |
| 13474 | INTDS1(NDS) = IDXSP |
| 13475 | INTDS2(NDS) = IDXST |
| 13476 | ISKPCH(2,NDS) = 0 |
| 13477 | RETURN |
| 13478 | END |
| 13479 | |
| 13480 | *$ CREATE DT_DIFEVT.FOR |
| 13481 | *COPY DT_DIFEVT |
| 13482 | * |
| 13483 | *===difevt=============================================================* |
| 13484 | * |
| 13485 | SUBROUTINE DT_DIFEVT(IFP1,IFP2,PP,MOP, |
| 13486 | & IFT1,IFT2,PT,MOT,JDIFF,NCSY,IREJ) |
| 13487 | |
| 13488 | ************************************************************************ |
| 13489 | * Interface to treatment of diffractive interactions. * |
| 13490 | * (input) IFP1/2 PDG-indizes of projectile partons * |
| 13491 | * (baryon: IFP2 - adiquark) * |
| 13492 | * PP(4) projectile 4-momentum * |
| 13493 | * IFT1/2 PDG-indizes of target partons * |
| 13494 | * (baryon: IFT1 - adiquark) * |
| 13495 | * PT(4) target 4-momentum * |
| 13496 | * (output) JDIFF = 0 no diffraction * |
| 13497 | * = 1/-1 LMSD/LMDD * |
| 13498 | * = 2/-2 HMSD/HMDD * |
| 13499 | * NCSY counter for two-chain systems * |
| 13500 | * dumped to DTEVT1 * |
| 13501 | * This version dated 14.02.95 is written by S. Roesler * |
| 13502 | ************************************************************************ |
| 13503 | |
| 13504 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 13505 | SAVE |
| 13506 | PARAMETER ( LINP = 10 , |
| 13507 | & LOUT = 6 , |
| 13508 | & LDAT = 9 ) |
| 13509 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5, |
| 13510 | & OHALF=0.5D0) |
| 13511 | |
| 13512 | * event history |
| 13513 | PARAMETER (NMXHKK=200000) |
| 13514 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 13515 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 13516 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 13517 | * extended event history |
| 13518 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 13519 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 13520 | & IHIST(2,NMXHKK) |
| 13521 | * flags for diffractive interactions (DTUNUC 1.x) |
| 13522 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF |
| 13523 | |
| 13524 | DIMENSION PP(4),PT(4) |
| 13525 | |
| 13526 | LOGICAL LFIRST |
| 13527 | DATA LFIRST /.TRUE./ |
| 13528 | |
| 13529 | IREJ = 0 |
| 13530 | JDIFF = 0 |
| 13531 | IFLAGD = JDIFF |
| 13532 | |
| 13533 | * cm. energy |
| 13534 | XM = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2- |
| 13535 | & (PP(2)+PT(2))**2-(PP(3)+PT(3))**2) |
| 13536 | * identities of projectile hadron / target nucleon |
| 13537 | KPROJ = IDT_ICIHAD(IDHKK(MOP)) |
| 13538 | KTARG = IDT_ICIHAD(IDHKK(MOT)) |
| 13539 | |
| 13540 | * single diffractive xsections |
| 13541 | CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM) |
| 13542 | * double diffractive xsections |
| 13543 | **!! no double diff yet |
| 13544 | C CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM,DDTOT,DDHM) |
| 13545 | DDTOT = 0.0D0 |
| 13546 | DDHM = 0.0D0 |
| 13547 | **!! |
| 13548 | * total inelastic xsection |
| 13549 | C SIGIN = DT_SHNTOT(KPROJ,KTARG,XM,ZERO)-DT_SHNELA(KPROJ,KTARG,XM) |
| 13550 | DUMZER = ZERO |
| 13551 | CALL DT_XSHN(KPROJ,KTARG,DUMZER,XM,SIGTO,SIGEL) |
| 13552 | SIGIN = MAX(SIGTO-SIGEL,ZERO) |
| 13553 | |
| 13554 | * fraction of diffractive processes |
| 13555 | FRADIF = (SDTOT+DDTOT)/SIGIN |
| 13556 | |
| 13557 | IF (LFIRST) THEN |
| 13558 | WRITE(LOUT,1000) XM,SDTOT,SIGIN |
| 13559 | 1000 FORMAT(1X,'DIFEVT: single diffraction requested at E_cm = ', |
| 13560 | & F5.1,' GeV',/,9X,'sigma_sd = ',F4.1,' mb, sigma_in = ', |
| 13561 | & F5.1,' mb',/) |
| 13562 | LFIRST = .FALSE. |
| 13563 | ENDIF |
| 13564 | |
| 13565 | IF ((DT_RNDM(DDHM).LE.FRADIF).OR. |
| 13566 | & (ISINGD.GT.1).OR.(IDOUBD.GT.1)) THEN |
| 13567 | * diffractive interaction requested by x-section or by user |
| 13568 | FRASD = SDTOT/(SDTOT+DDTOT) |
| 13569 | FRASDH = SDHM/SDTOT |
| 13570 | **sr needs to be specified!! |
| 13571 | C FRADDH = DDHM/DDTOT |
| 13572 | FRADDH = 1.0D0 |
| 13573 | ** |
| 13574 | IF ((DT_RNDM(FRASD).LE.FRASD).OR.(ISINGD.GT.1)) THEN |
| 13575 | * single diffraction |
| 13576 | KDIFF = 1 |
| 13577 | IF (DT_RNDM(DDTOT).LE.FRASDH) THEN |
| 13578 | KP = 2 |
| 13579 | KT = 0 |
| 13580 | IF (((ISINGD.EQ.4).OR.(DT_RNDM(DDTOT).GE.OHALF)).AND. |
| 13581 | & ISINGD.NE.3) THEN |
| 13582 | KP = 0 |
| 13583 | KT = 2 |
| 13584 | ENDIF |
| 13585 | ELSE |
| 13586 | KP = 1 |
| 13587 | KT = 0 |
| 13588 | IF (((ISINGD.EQ.4).OR.(DT_RNDM(FRADDH).GE.OHALF)).AND. |
| 13589 | & ISINGD.NE.3) THEN |
| 13590 | KP = 0 |
| 13591 | KT = 1 |
| 13592 | ENDIF |
| 13593 | ENDIF |
| 13594 | ELSE |
| 13595 | * double diffraction |
| 13596 | KDIFF = -1 |
| 13597 | IF (DT_RNDM(FRADDH).LE.FRADDH) THEN |
| 13598 | KP = 2 |
| 13599 | KT = 2 |
| 13600 | ELSE |
| 13601 | KP = 1 |
| 13602 | KT = 1 |
| 13603 | ENDIF |
| 13604 | ENDIF |
| 13605 | CALL DT_DIFFKI(IFP1,IFP2,PP,MOP,KP, |
| 13606 | & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1) |
| 13607 | IF (IREJ1.EQ.0) THEN |
| 13608 | IFLAGD = 2*KDIFF |
| 13609 | IF ((KP.EQ.1).OR.(KT.EQ.1)) IFLAGD = KDIFF |
| 13610 | ELSE |
| 13611 | GOTO 9999 |
| 13612 | ENDIF |
| 13613 | ENDIF |
| 13614 | JDIFF = IFLAGD |
| 13615 | |
| 13616 | RETURN |
| 13617 | |
| 13618 | 9999 CONTINUE |
| 13619 | IREJ = 1 |
| 13620 | RETURN |
| 13621 | END |
| 13622 | |
| 13623 | *$ CREATE DT_DIFFKI.FOR |
| 13624 | *COPY DT_DIFFKI |
| 13625 | * |
| 13626 | *===difkin=============================================================* |
| 13627 | * |
| 13628 | SUBROUTINE DT_DIFFKI(IFP1,IFP2,PP,MOP,KP, |
| 13629 | & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ) |
| 13630 | |
| 13631 | ************************************************************************ |
| 13632 | * Kinematics of diffractive nucleon-nucleon interaction. * |
| 13633 | * IFP1/2 PDG-indizes of projectile partons * |
| 13634 | * (baryon: IFP2 - adiquark) * |
| 13635 | * PP(4) projectile 4-momentum * |
| 13636 | * IFT1/2 PDG-indizes of target partons * |
| 13637 | * (baryon: IFT1 - adiquark) * |
| 13638 | * PT(4) target 4-momentum * |
| 13639 | * KP = 0 projectile quasi-elastically scattered * |
| 13640 | * = 1 excited to low-mass diff. state * |
| 13641 | * = 2 excited to high-mass diff. state * |
| 13642 | * KT = 0 target quasi-elastically scattered * |
| 13643 | * = 1 excited to low-mass diff. state * |
| 13644 | * = 2 excited to high-mass diff. state * |
| 13645 | * This version dated 12.02.95 is written by S. Roesler * |
| 13646 | ************************************************************************ |
| 13647 | |
| 13648 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 13649 | SAVE |
| 13650 | PARAMETER ( LINP = 10 , |
| 13651 | & LOUT = 6 , |
| 13652 | & LDAT = 9 ) |
| 13653 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5) |
| 13654 | |
| 13655 | LOGICAL LSTART |
| 13656 | |
| 13657 | * particle properties (BAMJET index convention) |
| 13658 | CHARACTER*8 ANAME |
| 13659 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 13660 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 13661 | * flags for input different options |
| 13662 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 13663 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 13664 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 13665 | * rejection counter |
| 13666 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, |
| 13667 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, |
| 13668 | & IREXCI(3),IRDIFF(2),IRINC |
| 13669 | * kinematics of diffractive interactions (DTUNUC 1.x) |
| 13670 | COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4), |
| 13671 | & PPF(4),PTF(4), |
| 13672 | & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4), |
| 13673 | & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2) |
| 13674 | |
| 13675 | DIMENSION PITOT(4),BGTOT(4),PP1(4),PT1(4),PPBLOB(4),PTBLOB(4), |
| 13676 | & PP(4),PT(4),PPOM1(4),DEV1(4),DEV2(4) |
| 13677 | |
| 13678 | DATA LSTART /.TRUE./ |
| 13679 | |
| 13680 | IF (LSTART) THEN |
| 13681 | WRITE(LOUT,2000) |
| 13682 | 2000 FORMAT(/,1X,'DIFEVT: diffractive interactions treated ') |
| 13683 | LSTART = .FALSE. |
| 13684 | ENDIF |
| 13685 | |
| 13686 | IREJ = 0 |
| 13687 | |
| 13688 | * initialize common /DTDIKI/ |
| 13689 | CALL DT_DIFINI |
| 13690 | * store momenta of initial incoming particles for emc-check |
| 13691 | IF (LEMCCK) THEN |
| 13692 | CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM,IDUM) |
| 13693 | CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM,IDUM) |
| 13694 | ENDIF |
| 13695 | |
| 13696 | * masses of initial particles |
| 13697 | XMP2 = PP(4)**2-PP(1)**2-PP(2)**2-PP(3)**2 |
| 13698 | XMT2 = PT(4)**2-PT(1)**2-PT(2)**2-PT(3)**2 |
| 13699 | IF ((XMP2.LT.ZERO).OR.(XMT2.LT.ZERO)) GOTO 9999 |
| 13700 | XMP = SQRT(XMP2) |
| 13701 | XMT = SQRT(XMT2) |
| 13702 | * check quark-input (used to adjust coherence cond. for M-selection) |
| 13703 | IBP = 0 |
| 13704 | IF ((ABS(IFP1).GE.1000).OR.(ABS(IFP2).GE.1000)) IBP = 1 |
| 13705 | IBT = 0 |
| 13706 | IF ((ABS(IFT1).GE.1000).OR.(ABS(IFT2).GE.1000)) IBT = 1 |
| 13707 | |
| 13708 | * parameter for Lorentz-transformation into nucleon-nucleon cms |
| 13709 | DO 3 K=1,4 |
| 13710 | PITOT(K) = PP(K)+PT(K) |
| 13711 | 3 CONTINUE |
| 13712 | XMTOT2 = PITOT(4)**2-PITOT(1)**2-PITOT(2)**2-PITOT(3)**2 |
| 13713 | IF (XMTOT2.LE.ZERO) THEN |
| 13714 | WRITE(LOUT,1000) XMTOT2 |
| 13715 | 1000 FORMAT(1X,'DIFEVT: negative cm. energy! ', |
| 13716 | & 'XMTOT2 = ',E12.3) |
| 13717 | GOTO 9999 |
| 13718 | ENDIF |
| 13719 | XMTOT = SQRT(XMTOT2) |
| 13720 | DO 4 K=1,4 |
| 13721 | BGTOT(K) = PITOT(K)/XMTOT |
| 13722 | 4 CONTINUE |
| 13723 | * transformation of nucleons into cms |
| 13724 | CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PP(1),PP(2), |
| 13725 | & PP(3),PP(4),PPTOT,PP1(1),PP1(2),PP1(3),PP1(4)) |
| 13726 | CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PT(1),PT(2), |
| 13727 | & PT(3),PT(4),PTTOT,PT1(1),PT1(2),PT1(3),PT1(4)) |
| 13728 | * rotation angles |
| 13729 | COD = PP1(3)/PPTOT |
| 13730 | C SID = SQRT((ONE-COD)*(ONE+COD)) |
| 13731 | PPT = SQRT(PP1(1)**2+PP1(2)**2) |
| 13732 | SID = PPT/PPTOT |
| 13733 | COF = ONE |
| 13734 | SIF = ZERO |
| 13735 | IF(PPTOT*SID.GT.TINY10) THEN |
| 13736 | COF = PP1(1)/(SID*PPTOT) |
| 13737 | SIF = PP1(2)/(SID*PPTOT) |
| 13738 | ANORF = SQRT(COF*COF+SIF*SIF) |
| 13739 | COF = COF/ANORF |
| 13740 | SIF = SIF/ANORF |
| 13741 | ENDIF |
| 13742 | * check consistency |
| 13743 | DO 5 K=1,4 |
| 13744 | DEV1(K) = ABS(PP1(K)+PT1(K)) |
| 13745 | 5 CONTINUE |
| 13746 | DEV1(4) = ABS(DEV1(4)-XMTOT) |
| 13747 | IF ((DEV1(1).GT.TINY10).OR.(DEV1(2).GT.TINY10).OR. |
| 13748 | & (DEV1(3).GT.TINY10).OR.(DEV1(4).GT.TINY10)) THEN |
| 13749 | WRITE(LOUT,1001) DEV1 |
| 13750 | 1001 FORMAT(1X,'DIFEVT: inconsitent Lorentz-transformation! ', |
| 13751 | & /,8X,4E12.3) |
| 13752 | GOTO 9999 |
| 13753 | ENDIF |
| 13754 | |
| 13755 | * select x-fractions in high-mass diff. interactions |
| 13756 | IF ((KP.EQ.2).OR.(KT.EQ.2)) CALL DT_XVALHM(KP,KT) |
| 13757 | |
| 13758 | * select diffractive masses |
| 13759 | * - projectile |
| 13760 | IF (KP.EQ.1) THEN |
| 13761 | XMPF = DT_XMLMD(XMTOT) |
| 13762 | CALL DT_LM2RES(IFP1,IFP2,XMPF,IDPR,IDXPR,IREJ1) |
| 13763 | IF (IREJ1.GT.0) GOTO 9999 |
| 13764 | ELSEIF (KP.EQ.2) THEN |
| 13765 | XMPF = DT_XMHMD(XMTOT,IBP,1) |
| 13766 | ELSE |
| 13767 | XMPF = XMP |
| 13768 | ENDIF |
| 13769 | * - target |
| 13770 | IF (KT.EQ.1) THEN |
| 13771 | XMTF = DT_XMLMD(XMTOT) |
| 13772 | CALL DT_LM2RES(IFT1,IFT2,XMTF,IDTR,IDXTR,IREJ1) |
| 13773 | IF (IREJ1.GT.0) GOTO 9999 |
| 13774 | ELSEIF (KT.EQ.2) THEN |
| 13775 | XMTF = DT_XMHMD(XMTOT,IBT,2) |
| 13776 | ELSE |
| 13777 | XMTF = XMT |
| 13778 | ENDIF |
| 13779 | |
| 13780 | * kinematical treatment of "two-particle" system (masses - XMPF,XMTF) |
| 13781 | XMPF2 = XMPF**2 |
| 13782 | XMTF2 = XMTF**2 |
| 13783 | PPBLOB(3) = DT_YLAMB(XMTOT2,XMPF2,XMTF2)/(2.D0*XMTOT) |
| 13784 | PPBLOB(4) = SQRT(XMPF2+PPBLOB(3)**2) |
| 13785 | |
| 13786 | * select momentum transfer (all t-values used here are <0) |
| 13787 | * minimum absolute value to produce diffractive masses |
| 13788 | TMIN = XMP2+XMPF2-2.0D0*(PP1(4)*PPBLOB(4)-PPTOT*PPBLOB(3)) |
| 13789 | TT = DT_TDIFF(XMTOT,TMIN,XMPF,KP,XMTF,KT,IREJ1) |
| 13790 | IF (IREJ1.GT.0) GOTO 9999 |
| 13791 | |
| 13792 | * longitudinal momentum of excited/elastically scattered projectile |
| 13793 | PPBLOB(3) = (TT-XMP2-XMPF2+2.0D0*PP1(4)*PPBLOB(4))/(2.0D0*PPTOT) |
| 13794 | * total transverse momentum due to t-selection |
| 13795 | PPBLT2 = PPBLOB(4)**2-PPBLOB(3)**2-XMPF2 |
| 13796 | IF (PPBLT2.LT.ZERO) THEN |
| 13797 | WRITE(LOUT,1002) PPBLT2,KP,PP1,XMPF,KT,PT1,XMTF,TT |
| 13798 | 1002 FORMAT(1X,'DIFEVT: inconsistent transverse momentum! ', |
| 13799 | & E12.3,2(/,1X,I2,5E12.3),/,1X,E12.3) |
| 13800 | GOTO 9999 |
| 13801 | ENDIF |
| 13802 | CALL DT_DSFECF(SINPHI,COSPHI) |
| 13803 | PPBLT = SQRT(PPBLT2) |
| 13804 | PPBLOB(1) = COSPHI*PPBLT |
| 13805 | PPBLOB(2) = SINPHI*PPBLT |
| 13806 | |
| 13807 | * rotate excited/elastically scattered projectile into n-n cms. |
| 13808 | CALL DT_MYTRAN(1,PPBLOB(1),PPBLOB(2),PPBLOB(3),COD,SID,COF,SIF, |
| 13809 | & XX,YY,ZZ) |
| 13810 | PPBLOB(1) = XX |
| 13811 | PPBLOB(2) = YY |
| 13812 | PPBLOB(3) = ZZ |
| 13813 | |
| 13814 | * 4-momentum of excited/elastically scattered target and of exchanged |
| 13815 | * Pomeron |
| 13816 | DO 6 K=1,4 |
| 13817 | IF (K.LT.4) PTBLOB(K) = -PPBLOB(K) |
| 13818 | PPOM1(K) = PP1(K)-PPBLOB(K) |
| 13819 | 6 CONTINUE |
| 13820 | PTBLOB(4) = XMTOT-PPBLOB(4) |
| 13821 | |
| 13822 | * Lorentz-transformation back into system of initial diff. collision |
| 13823 | CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3), |
| 13824 | & PPBLOB(1),PPBLOB(2),PPBLOB(3),PPBLOB(4), |
| 13825 | & PPTOTF,PPF(1),PPF(2),PPF(3),PPF(4)) |
| 13826 | CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3), |
| 13827 | & PTBLOB(1),PTBLOB(2),PTBLOB(3),PTBLOB(4), |
| 13828 | & PTTOTF,PTF(1),PTF(2),PTF(3),PTF(4)) |
| 13829 | CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3), |
| 13830 | & PPOM1(1),PPOM1(2),PPOM1(3),PPOM1(4), |
| 13831 | & PPOMTO,PPOM(1),PPOM(2),PPOM(3),PPOM(4)) |
| 13832 | |
| 13833 | * store 4-momentum of elastically scattered particle (in single diff. |
| 13834 | * events) |
| 13835 | IF (KP.EQ.0) THEN |
| 13836 | DO 7 K=1,4 |
| 13837 | PSC(K) = PPF(K) |
| 13838 | 7 CONTINUE |
| 13839 | ELSEIF (KT.EQ.0) THEN |
| 13840 | DO 8 K=1,4 |
| 13841 | PSC(K) = PTF(K) |
| 13842 | 8 CONTINUE |
| 13843 | ENDIF |
| 13844 | |
| 13845 | * check consistency of kinematical treatment so far |
| 13846 | IF (LEMCCK) THEN |
| 13847 | CALL DT_EVTEMC(-PPF(1),-PPF(2),-PPF(3),-PPF(4),2,IDUM,IDUM) |
| 13848 | CALL DT_EVTEMC(-PTF(1),-PTF(2),-PTF(3),-PTF(4),2,IDUM,IDUM) |
| 13849 | CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,60,IREJ1) |
| 13850 | IF (IREJ1.NE.0) GOTO 9999 |
| 13851 | ENDIF |
| 13852 | DO 9 K=1,4 |
| 13853 | DEV1(K) = ABS(PP(K)-PPF(K)-PPOM(K)) |
| 13854 | DEV2(K) = ABS(PT(K)-PTF(K)+PPOM(K)) |
| 13855 | 9 CONTINUE |
| 13856 | IF ((DEV1(1).GT.TINY5).OR.(DEV1(2).GT.TINY5).OR. |
| 13857 | & (DEV1(3).GT.TINY5).OR.(DEV1(4).GT.TINY5).OR. |
| 13858 | & (DEV2(1).GT.TINY5).OR.(DEV2(2).GT.TINY5).OR. |
| 13859 | & (DEV2(3).GT.TINY5).OR.(DEV2(4).GT.TINY5)) THEN |
| 13860 | WRITE(LOUT,1003) DEV1,DEV2 |
| 13861 | 1003 FORMAT(1X,'DIFEVT: inconsitent kinematical treatment! ', |
| 13862 | & 2(/,8X,4E12.3)) |
| 13863 | GOTO 9999 |
| 13864 | ENDIF |
| 13865 | |
| 13866 | * kinematical treatment for low-mass diffraction |
| 13867 | CALL DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ1) |
| 13868 | IF (IREJ1.NE.0) GOTO 9999 |
| 13869 | |
| 13870 | * dump diffractive chains into DTEVT1 |
| 13871 | CALL DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1) |
| 13872 | IF (IREJ1.NE.0) GOTO 9999 |
| 13873 | |
| 13874 | RETURN |
| 13875 | |
| 13876 | 9999 CONTINUE |
| 13877 | IRDIFF(1) = IRDIFF(1)+1 |
| 13878 | IREJ = 1 |
| 13879 | RETURN |
| 13880 | END |
| 13881 | |
| 13882 | *$ CREATE DT_XMHMD.FOR |
| 13883 | *COPY DT_XMHMD |
| 13884 | * |
| 13885 | *===xmhmd==============================================================* |
| 13886 | * |
| 13887 | DOUBLE PRECISION FUNCTION DT_XMHMD(ECM,IB,MODE) |
| 13888 | |
| 13889 | ************************************************************************ |
| 13890 | * Diffractive mass in high mass single/double diffractive events. * |
| 13891 | * This version dated 11.02.95 is written by S. Roesler * |
| 13892 | ************************************************************************ |
| 13893 | |
| 13894 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 13895 | SAVE |
| 13896 | PARAMETER ( LINP = 10 , |
| 13897 | & LOUT = 6 , |
| 13898 | & LDAT = 9 ) |
| 13899 | PARAMETER (OHALF=0.5D0,ONE=1.0D0,ZERO=0.0D0) |
| 13900 | |
| 13901 | * kinematics of diffractive interactions (DTUNUC 1.x) |
| 13902 | COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4), |
| 13903 | & PPF(4),PTF(4), |
| 13904 | & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4), |
| 13905 | & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2) |
| 13906 | |
| 13907 | C DATA XCOLOW /0.05D0/ |
| 13908 | DATA XCOLOW /0.15D0/ |
| 13909 | |
| 13910 | DT_XMHMD = ZERO |
| 13911 | XH = XPH(2) |
| 13912 | IF (MODE.EQ.2) XH = XTH(2) |
| 13913 | |
| 13914 | * minimum Pomeron-x for high-mass diffraction |
| 13915 | * (adjusted to get a smooth transition between HM and LM component) |
| 13916 | R = DT_RNDM(XH) |
| 13917 | XDIMIN = (3.0D0+400.0D0*R**2)/(XH*ECM**2) |
| 13918 | IF (ECM.LE.300.0D0) THEN |
| 13919 | RR = (1.0D0-EXP(-((ECM/140.0D0)**4))) |
| 13920 | XDIMIN = (3.0D0+400.0D0*(R**2)*RR)/(XH*ECM**2) |
| 13921 | ENDIF |
| 13922 | * maximum Pomeron-x for high-mass diffraction |
| 13923 | * (coherence condition, adjusted to fit to experimental data) |
| 13924 | IF (IB.NE.0) THEN |
| 13925 | * baryon-diffraction |
| 13926 | XDIMAX = XCOLOW*(1.0D0+EXP(-((ECM/420.0D0)**2))) |
| 13927 | ELSE |
| 13928 | * meson-diffraction |
| 13929 | XDIMAX = XCOLOW*(1.0D0+4.0D0*EXP(-((ECM/420.0D0)**2))) |
| 13930 | ENDIF |
| 13931 | * check boundaries |
| 13932 | IF (XDIMIN.GE.XDIMAX) THEN |
| 13933 | XDIMIN = OHALF*XDIMAX |
| 13934 | ENDIF |
| 13935 | |
| 13936 | KLOOP = 0 |
| 13937 | 1 CONTINUE |
| 13938 | KLOOP = KLOOP+1 |
| 13939 | IF (KLOOP.GT.20) RETURN |
| 13940 | * sample Pomeron-x from 1/x-distribution (critical Pomeron) |
| 13941 | XDIFF = DT_SAMPEX(XDIMIN,XDIMAX) |
| 13942 | * corr. diffr. mass |
| 13943 | DT_XMHMD = ECM*SQRT(XDIFF) |
| 13944 | IF (DT_XMHMD.LT.2.5D0) GOTO 1 |
| 13945 | |
| 13946 | RETURN |
| 13947 | END |
| 13948 | |
| 13949 | *$ CREATE DT_XMLMD.FOR |
| 13950 | *COPY DT_XMLMD |
| 13951 | * |
| 13952 | *===xmlmd==============================================================* |
| 13953 | * |
| 13954 | DOUBLE PRECISION FUNCTION DT_XMLMD(ECM) |
| 13955 | |
| 13956 | ************************************************************************ |
| 13957 | * Diffractive mass in high mass single/double diffractive events. * |
| 13958 | * This version dated 11.02.95 is written by S. Roesler * |
| 13959 | ************************************************************************ |
| 13960 | |
| 13961 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 13962 | SAVE |
| 13963 | PARAMETER ( LINP = 10 , |
| 13964 | & LOUT = 6 , |
| 13965 | & LDAT = 9 ) |
| 13966 | |
| 13967 | * minimum Pomeron-x for low-mass diffraction |
| 13968 | C AMO = 1.5D0 |
| 13969 | AMO = 2.0D0 |
| 13970 | * maximum Pomeron-x for low-mass diffraction |
| 13971 | * (adjusted to get a smooth transition between HM and LM component) |
| 13972 | R = DT_RNDM(AMO) |
| 13973 | SAM = 1.0D0 |
| 13974 | IF (ECM.LE.300.0D0) SAM = 1.0D0-EXP(-((ECM/200.0D0)**4)) |
| 13975 | R = DT_RNDM(AMO)*SAM |
| 13976 | AMAX= (1.0D0-SAM)*SQRT(0.1D0*ECM**2)+SAM*SQRT(400.0D0) |
| 13977 | AMU = R*SQRT(100.0D0)+(1.0D0-R)*AMAX |
| 13978 | |
| 13979 | * selection of diffractive mass |
| 13980 | * (adjusted to get a smooth transition between HM and LM component) |
| 13981 | R = DT_RNDM(AMU) |
| 13982 | IF (ECM.LE.50.0D0) THEN |
| 13983 | DT_XMLMD = AMO*(AMU/AMO)**R |
| 13984 | ELSE |
| 13985 | A = 0.7D0 |
| 13986 | IF (ECM.LE.300.0D0) A = 0.7D0*(1.0D0-EXP(-((ECM/100.0D0)**2))) |
| 13987 | DT_XMLMD = 1.0D0/((R/(AMU**A)+(1.0D0-R)/(AMO**A))**(1.0D0/A)) |
| 13988 | ENDIF |
| 13989 | |
| 13990 | RETURN |
| 13991 | END |
| 13992 | |
| 13993 | *$ CREATE DT_TDIFF.FOR |
| 13994 | *COPY DT_TDIFF |
| 13995 | * |
| 13996 | *===tdiff==============================================================* |
| 13997 | * |
| 13998 | DOUBLE PRECISION FUNCTION DT_TDIFF(ECM,TMIN,XM1I,K1,XM2I,K2,IREJ) |
| 13999 | |
| 14000 | ************************************************************************ |
| 14001 | * t-selection for single/double diffractive interactions. * |
| 14002 | * ECM cm. energy * |
| 14003 | * TMIN minimum momentum transfer to produce diff. masses * |
| 14004 | * XM1/XM2 diffractively produced masses * |
| 14005 | * (for single diffraction XM2 is obsolete) * |
| 14006 | * K1/K2= 0 not excited * |
| 14007 | * = 1 low-mass excitation * |
| 14008 | * = 2 high-mass excitation * |
| 14009 | * This version dated 11.02.95 is written by S. Roesler * |
| 14010 | ************************************************************************ |
| 14011 | |
| 14012 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 14013 | SAVE |
| 14014 | PARAMETER ( LINP = 10 , |
| 14015 | & LOUT = 6 , |
| 14016 | & LDAT = 9 ) |
| 14017 | PARAMETER (ZERO=0.0D0) |
| 14018 | |
| 14019 | PARAMETER ( BTP0 = 3.7D0, |
| 14020 | & ALPHAP = 0.24D0 ) |
| 14021 | |
| 14022 | IREJ = 0 |
| 14023 | NCLOOP = 0 |
| 14024 | DT_TDIFF = ZERO |
| 14025 | |
| 14026 | IF (K1.GT.0) THEN |
| 14027 | XM1 = XM1I |
| 14028 | XM2 = XM2I |
| 14029 | ELSE |
| 14030 | XM1 = XM2I |
| 14031 | ENDIF |
| 14032 | XDI = (XM1/ECM)**2 |
| 14033 | IF ((K1.EQ.0).OR.(K2.EQ.0)) THEN |
| 14034 | * slope for single diffraction |
| 14035 | SLOPE = BTP0-2.0D0*ALPHAP*LOG(XDI) |
| 14036 | ELSE |
| 14037 | * slope for double diffraction |
| 14038 | SLOPE = -2.0D0*ALPHAP*LOG(XDI*XM2**2) |
| 14039 | ENDIF |
| 14040 | |
| 14041 | 1 CONTINUE |
| 14042 | NCLOOP = NCLOOP+1 |
| 14043 | IF (MOD(NCLOOP,1000).EQ.0) GOTO 9999 |
| 14044 | Y = DT_RNDM(XDI) |
| 14045 | T = -LOG(1.0D0-Y)/SLOPE |
| 14046 | IF (ABS(T).LE.ABS(TMIN)) GOTO 1 |
| 14047 | DT_TDIFF = -ABS(T) |
| 14048 | |
| 14049 | RETURN |
| 14050 | |
| 14051 | 9999 CONTINUE |
| 14052 | WRITE(LOUT,1000) ECM,TMIN,XM1I,XM2I,K1,K2 |
| 14053 | 1000 FORMAT(1X,'DT_TDIFF: t-selection rejected!',/, |
| 14054 | & 1X,'ECM = ',E12.3,' TMIN = ',E12.2,/,1X,'XM1I = ', |
| 14055 | & E12.3,' XM2I = ',E12.3,' K1 = ',I2,' K2 = ',I2) |
| 14056 | IREJ = 1 |
| 14057 | RETURN |
| 14058 | END |
| 14059 | |
| 14060 | *$ CREATE DT_XVALHM.FOR |
| 14061 | *COPY DT_XVALHM |
| 14062 | * |
| 14063 | *===xvalhm=============================================================* |
| 14064 | * |
| 14065 | SUBROUTINE DT_XVALHM(KP,KT) |
| 14066 | |
| 14067 | ************************************************************************ |
| 14068 | * Sampling of parton x-values in high-mass diffractive interactions. * |
| 14069 | * This version dated 12.02.95 is written by S. Roesler * |
| 14070 | ************************************************************************ |
| 14071 | |
| 14072 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 14073 | SAVE |
| 14074 | PARAMETER ( LINP = 10 , |
| 14075 | & LOUT = 6 , |
| 14076 | & LDAT = 9 ) |
| 14077 | PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0,TINY2=1.0D-2) |
| 14078 | |
| 14079 | * kinematics of diffractive interactions (DTUNUC 1.x) |
| 14080 | COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4), |
| 14081 | & PPF(4),PTF(4), |
| 14082 | & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4), |
| 14083 | & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2) |
| 14084 | * various options for treatment of partons (DTUNUC 1.x) |
| 14085 | * (chain recombination, Cronin,..) |
| 14086 | LOGICAL LCO2CR,LINTPT |
| 14087 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, |
| 14088 | & LCO2CR,LINTPT |
| 14089 | |
| 14090 | DATA UNON,XVQTHR /2.0D0,0.8D0/ |
| 14091 | |
| 14092 | IF (KP.EQ.2) THEN |
| 14093 | * x-fractions of projectile valence partons |
| 14094 | 1 CONTINUE |
| 14095 | XPH(1) = DT_DBETAR(OHALF,UNON) |
| 14096 | IF (XPH(1).GE.XVQTHR) GOTO 1 |
| 14097 | XPH(2) = ONE-XPH(1) |
| 14098 | * x-fractions of Pomeron q-aq-pair |
| 14099 | XPOLO = TINY2 |
| 14100 | XPOHI = ONE-TINY2 |
| 14101 | XPPO(1) = DT_SAMPEX(XPOLO,XPOHI) |
| 14102 | XPPO(2) = ONE-XPPO(1) |
| 14103 | * flavors of Pomeron q-aq-pair |
| 14104 | IFLAV = INT(ONE+DT_RNDM(UNON)*(2.0D0+SEASQ)) |
| 14105 | IFPPO(1) = IFLAV |
| 14106 | IFPPO(2) = -IFLAV |
| 14107 | IF (DT_RNDM(UNON).GT.OHALF) THEN |
| 14108 | IFPPO(1) = -IFLAV |
| 14109 | IFPPO(2) = IFLAV |
| 14110 | ENDIF |
| 14111 | ENDIF |
| 14112 | |
| 14113 | IF (KT.EQ.2) THEN |
| 14114 | * x-fractions of projectile target partons |
| 14115 | 2 CONTINUE |
| 14116 | XTH(1) = DT_DBETAR(OHALF,UNON) |
| 14117 | IF (XTH(1).GE.XVQTHR) GOTO 2 |
| 14118 | XTH(2) = ONE-XTH(1) |
| 14119 | * x-fractions of Pomeron q-aq-pair |
| 14120 | XPOLO = TINY2 |
| 14121 | XPOHI = ONE-TINY2 |
| 14122 | XTPO(1) = DT_SAMPEX(XPOLO,XPOHI) |
| 14123 | XTPO(2) = ONE-XTPO(1) |
| 14124 | * flavors of Pomeron q-aq-pair |
| 14125 | IFLAV = INT(ONE+DT_RNDM(XPOLO)*(2.0D0+SEASQ)) |
| 14126 | IFTPO(1) = IFLAV |
| 14127 | IFTPO(2) = -IFLAV |
| 14128 | IF (DT_RNDM(XPOLO).GT.OHALF) THEN |
| 14129 | IFTPO(1) = -IFLAV |
| 14130 | IFTPO(2) = IFLAV |
| 14131 | ENDIF |
| 14132 | ENDIF |
| 14133 | |
| 14134 | RETURN |
| 14135 | END |
| 14136 | |
| 14137 | *$ CREATE DT_LM2RES.FOR |
| 14138 | *COPY DT_LM2RES |
| 14139 | * |
| 14140 | *===lm2res=============================================================* |
| 14141 | * |
| 14142 | SUBROUTINE DT_LM2RES(IF1,IF2,XM,IDR,IDXR,IREJ) |
| 14143 | |
| 14144 | ************************************************************************ |
| 14145 | * Check low-mass diffractive excitation for resonance mass. * |
| 14146 | * (input) IF1/2 PDG-indizes of valence partons * |
| 14147 | * (in/out) XM diffractive mass requested/corrected * |
| 14148 | * (output) IDR/IDXR id./BAMJET-index of resonance * |
| 14149 | * This version dated 12.02.95 is written by S. Roesler * |
| 14150 | ************************************************************************ |
| 14151 | |
| 14152 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 14153 | SAVE |
| 14154 | PARAMETER ( LINP = 10 , |
| 14155 | & LOUT = 6 , |
| 14156 | & LDAT = 9 ) |
| 14157 | PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0) |
| 14158 | |
| 14159 | * kinematics of diffractive interactions (DTUNUC 1.x) |
| 14160 | COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4), |
| 14161 | & PPF(4),PTF(4), |
| 14162 | & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4), |
| 14163 | & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2) |
| 14164 | |
| 14165 | IREJ = 0 |
| 14166 | IF1B = 0 |
| 14167 | IF2B = 0 |
| 14168 | XMI = XM |
| 14169 | |
| 14170 | * BAMJET indices of partons |
| 14171 | IF1A = IDT_IPDG2B(IF1,1,2) |
| 14172 | IF (ABS(IF1).GE.1000) IF1B = IDT_IPDG2B(IF1,2,2) |
| 14173 | IF2A = IDT_IPDG2B(IF2,1,2) |
| 14174 | IF (ABS(IF2).GE.1000) IF2B = IDT_IPDG2B(IF2,2,2) |
| 14175 | |
| 14176 | * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq) |
| 14177 | IDCH = 2 |
| 14178 | IF ((IF1B.EQ.0).AND.(IF2B.EQ.0)) IDCH = 1 |
| 14179 | |
| 14180 | * check for resonance mass |
| 14181 | CALL DT_CH2RES(IF1A,IF1B,IF2A,IF2B,IDR,IDXR,XMI,XMN,IDCH,IREJ1) |
| 14182 | IF (IREJ1.NE.0) GOTO 9999 |
| 14183 | |
| 14184 | XM = XMN |
| 14185 | RETURN |
| 14186 | |
| 14187 | 9999 CONTINUE |
| 14188 | IREJ = 1 |
| 14189 | RETURN |
| 14190 | END |
| 14191 | |
| 14192 | *$ CREATE DT_LMKINE.FOR |
| 14193 | *COPY DT_LMKINE |
| 14194 | * |
| 14195 | *===lmkine=============================================================* |
| 14196 | * |
| 14197 | SUBROUTINE DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ) |
| 14198 | |
| 14199 | ************************************************************************ |
| 14200 | * Kinematical treatment of low-mass excitations. * |
| 14201 | * This version dated 12.02.95 is written by S. Roesler * |
| 14202 | ************************************************************************ |
| 14203 | |
| 14204 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 14205 | SAVE |
| 14206 | PARAMETER ( LINP = 10 , |
| 14207 | & LOUT = 6 , |
| 14208 | & LDAT = 9 ) |
| 14209 | PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0) |
| 14210 | |
| 14211 | * flags for input different options |
| 14212 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 14213 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 14214 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 14215 | * kinematics of diffractive interactions (DTUNUC 1.x) |
| 14216 | COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4), |
| 14217 | & PPF(4),PTF(4), |
| 14218 | & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4), |
| 14219 | & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2) |
| 14220 | |
| 14221 | DIMENSION P1(4),P2(4) |
| 14222 | |
| 14223 | IREJ = 0 |
| 14224 | |
| 14225 | IF (KP.EQ.1) THEN |
| 14226 | PABS = SQRT(PPF(1)**2+PPF(2)**2+PPF(3)**2) |
| 14227 | POE = PPF(4)/PABS |
| 14228 | FAC1 = OHALF*(POE+ONE) |
| 14229 | FAC2 = -OHALF*(POE-ONE) |
| 14230 | DO 1 K=1,3 |
| 14231 | PPLM1(K) = FAC1*PPF(K) |
| 14232 | PPLM2(K) = FAC2*PPF(K) |
| 14233 | 1 CONTINUE |
| 14234 | PPLM1(4) = FAC1*PABS |
| 14235 | PPLM2(4) = -FAC2*PABS |
| 14236 | IF (IMSHL.EQ.1) THEN |
| 14237 | XM1 = PYMASS(IFP1) |
| 14238 | XM2 = PYMASS(IFP2) |
| 14239 | CALL DT_MASHEL(PPLM1,PPLM2,XM1,XM2,P1,P2,IREJ1) |
| 14240 | IF (IREJ1.NE.0) GOTO 9999 |
| 14241 | DO 2 K=1,4 |
| 14242 | PPLM1(K) = P1(K) |
| 14243 | PPLM2(K) = P2(K) |
| 14244 | 2 CONTINUE |
| 14245 | ENDIF |
| 14246 | ENDIF |
| 14247 | |
| 14248 | IF (KT.EQ.1) THEN |
| 14249 | PABS = SQRT(PTF(1)**2+PTF(2)**2+PTF(3)**2) |
| 14250 | POE = PTF(4)/PABS |
| 14251 | FAC1 = OHALF*(POE+ONE) |
| 14252 | FAC2 = -OHALF*(POE-ONE) |
| 14253 | DO 3 K=1,3 |
| 14254 | PTLM2(K) = FAC1*PTF(K) |
| 14255 | PTLM1(K) = FAC2*PTF(K) |
| 14256 | 3 CONTINUE |
| 14257 | PTLM2(4) = FAC1*PABS |
| 14258 | PTLM1(4) = -FAC2*PABS |
| 14259 | IF (IMSHL.EQ.1) THEN |
| 14260 | XM1 = PYMASS(IFT1) |
| 14261 | XM2 = PYMASS(IFT2) |
| 14262 | CALL DT_MASHEL(PTLM1,PTLM2,XM1,XM2,P1,P2,IREJ1) |
| 14263 | IF (IREJ1.NE.0) GOTO 9999 |
| 14264 | DO 4 K=1,4 |
| 14265 | PTLM1(K) = P1(K) |
| 14266 | PTLM2(K) = P2(K) |
| 14267 | 4 CONTINUE |
| 14268 | ENDIF |
| 14269 | ENDIF |
| 14270 | |
| 14271 | RETURN |
| 14272 | |
| 14273 | 9999 CONTINUE |
| 14274 | WRITE(LOUT,'(A)') 'LMKINE: kinematical treatment rejected' |
| 14275 | IREJ = 1 |
| 14276 | RETURN |
| 14277 | END |
| 14278 | |
| 14279 | *$ CREATE DT_DIFINI.FOR |
| 14280 | *COPY DT_DIFINI |
| 14281 | * |
| 14282 | *===difini=============================================================* |
| 14283 | * |
| 14284 | SUBROUTINE DT_DIFINI |
| 14285 | |
| 14286 | ************************************************************************ |
| 14287 | * Initialization of common /DTDIKI/ * |
| 14288 | * This version dated 12.02.95 is written by S. Roesler * |
| 14289 | ************************************************************************ |
| 14290 | |
| 14291 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 14292 | SAVE |
| 14293 | PARAMETER ( LINP = 10 , |
| 14294 | & LOUT = 6 , |
| 14295 | & LDAT = 9 ) |
| 14296 | PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0) |
| 14297 | |
| 14298 | * kinematics of diffractive interactions (DTUNUC 1.x) |
| 14299 | COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4), |
| 14300 | & PPF(4),PTF(4), |
| 14301 | & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4), |
| 14302 | & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2) |
| 14303 | |
| 14304 | DO 1 K=1,4 |
| 14305 | PPOM(K) = ZERO |
| 14306 | PSC(K) = ZERO |
| 14307 | PPF(K) = ZERO |
| 14308 | PTF(K) = ZERO |
| 14309 | PPLM1(K) = ZERO |
| 14310 | PPLM2(K) = ZERO |
| 14311 | PTLM1(K) = ZERO |
| 14312 | PTLM2(K) = ZERO |
| 14313 | 1 CONTINUE |
| 14314 | DO 2 K=1,2 |
| 14315 | XPH(K) = ZERO |
| 14316 | XPPO(K) = ZERO |
| 14317 | XTH(K) = ZERO |
| 14318 | XTPO(K) = ZERO |
| 14319 | IFPPO(K) = 0 |
| 14320 | IFTPO(K) = 0 |
| 14321 | 2 CONTINUE |
| 14322 | IDPR = 0 |
| 14323 | IDXPR = 0 |
| 14324 | IDTR = 0 |
| 14325 | IDXTR = 0 |
| 14326 | |
| 14327 | RETURN |
| 14328 | END |
| 14329 | |
| 14330 | *$ CREATE DT_DIFPUT.FOR |
| 14331 | *COPY DT_DIFPUT |
| 14332 | * |
| 14333 | *===difput=============================================================* |
| 14334 | * |
| 14335 | SUBROUTINE DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY, |
| 14336 | & IREJ) |
| 14337 | |
| 14338 | ************************************************************************ |
| 14339 | * Dump diffractive chains into DTEVT1 * |
| 14340 | * This version dated 12.02.95 is written by S. Roesler * |
| 14341 | ************************************************************************ |
| 14342 | |
| 14343 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 14344 | SAVE |
| 14345 | PARAMETER ( LINP = 10 , |
| 14346 | & LOUT = 6 , |
| 14347 | & LDAT = 9 ) |
| 14348 | PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0) |
| 14349 | |
| 14350 | LOGICAL LCHK |
| 14351 | |
| 14352 | * kinematics of diffractive interactions (DTUNUC 1.x) |
| 14353 | COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4), |
| 14354 | & PPF(4),PTF(4), |
| 14355 | & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4), |
| 14356 | & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2) |
| 14357 | * event history |
| 14358 | PARAMETER (NMXHKK=200000) |
| 14359 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 14360 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 14361 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 14362 | * extended event history |
| 14363 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 14364 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 14365 | & IHIST(2,NMXHKK) |
| 14366 | * rejection counter |
| 14367 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, |
| 14368 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, |
| 14369 | & IREXCI(3),IRDIFF(2),IRINC |
| 14370 | |
| 14371 | DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PCH(4),PP(4),PT(4), |
| 14372 | & P1(4),P2(4),P3(4),P4(4) |
| 14373 | |
| 14374 | IREJ = 0 |
| 14375 | |
| 14376 | IF (KP.EQ.1) THEN |
| 14377 | DO 1 K=1,4 |
| 14378 | PCH(K) = PPLM1(K)+PPLM2(K) |
| 14379 | 1 CONTINUE |
| 14380 | ID1 = IFP1 |
| 14381 | ID2 = IFP2 |
| 14382 | IF (DT_RNDM(PT).GT.OHALF) THEN |
| 14383 | ID1 = IFP2 |
| 14384 | ID2 = IFP1 |
| 14385 | ENDIF |
| 14386 | CALL DT_EVTPUT(21,ID1,MOP,0,PPLM1(1),PPLM1(2),PPLM1(3), |
| 14387 | & PPLM1(4),0,0,0) |
| 14388 | CALL DT_EVTPUT(21,ID2,MOP,0,PPLM2(1),PPLM2(2),PPLM2(3), |
| 14389 | & PPLM2(4),0,0,0) |
| 14390 | CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4), |
| 14391 | & IDPR,IDXPR,8) |
| 14392 | ELSEIF (KP.EQ.2) THEN |
| 14393 | DO 2 K=1,4 |
| 14394 | PP1(K) = XPH(1)*PP(K) |
| 14395 | PP2(K) = XPH(2)*PP(K) |
| 14396 | PT1(K) = -XPPO(1)*PPOM(K) |
| 14397 | PT2(K) = -XPPO(2)*PPOM(K) |
| 14398 | 2 CONTINUE |
| 14399 | CALL DT_CHKCSY(IFP1,IFPPO(1),LCHK) |
| 14400 | XM1 = ZERO |
| 14401 | XM2 = ZERO |
| 14402 | IF (LCHK) THEN |
| 14403 | CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1) |
| 14404 | IF (IREJ1.NE.0) GOTO 9999 |
| 14405 | CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1) |
| 14406 | IF (IREJ1.NE.0) GOTO 9999 |
| 14407 | DO 3 K=1,4 |
| 14408 | PP1(K) = P1(K) |
| 14409 | PT1(K) = P2(K) |
| 14410 | PP2(K) = P3(K) |
| 14411 | PT2(K) = P4(K) |
| 14412 | 3 CONTINUE |
| 14413 | CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), |
| 14414 | & 0,0,8) |
| 14415 | CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3), |
| 14416 | & PT1(4),0,0,8) |
| 14417 | CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), |
| 14418 | & 0,0,8) |
| 14419 | CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3), |
| 14420 | & PT2(4),0,0,8) |
| 14421 | ELSE |
| 14422 | CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1) |
| 14423 | IF (IREJ1.NE.0) GOTO 9999 |
| 14424 | CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1) |
| 14425 | IF (IREJ1.NE.0) GOTO 9999 |
| 14426 | DO 4 K=1,4 |
| 14427 | PP1(K) = P1(K) |
| 14428 | PT2(K) = P2(K) |
| 14429 | PP2(K) = P3(K) |
| 14430 | PT1(K) = P4(K) |
| 14431 | 4 CONTINUE |
| 14432 | CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), |
| 14433 | & 0,0,8) |
| 14434 | CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3), |
| 14435 | & PT2(4),0,0,8) |
| 14436 | CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), |
| 14437 | & 0,0,8) |
| 14438 | CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3), |
| 14439 | & PT1(4),0,0,8) |
| 14440 | ENDIF |
| 14441 | NCSY = NCSY+1 |
| 14442 | ELSE |
| 14443 | CALL DT_EVTPUT(1,IDHKK(MOP),MOP,0,PSC(1),PSC(2),PSC(3),PSC(4), |
| 14444 | & 0,0,0) |
| 14445 | ENDIF |
| 14446 | |
| 14447 | IF (KT.EQ.1) THEN |
| 14448 | DO 5 K=1,4 |
| 14449 | PCH(K) = PTLM1(K)+PTLM2(K) |
| 14450 | 5 CONTINUE |
| 14451 | ID1 = IFT1 |
| 14452 | ID2 = IFT2 |
| 14453 | IF (DT_RNDM(PT).GT.OHALF) THEN |
| 14454 | ID1 = IFT2 |
| 14455 | ID2 = IFT1 |
| 14456 | ENDIF |
| 14457 | CALL DT_EVTPUT(22,ID1,MOT,0,PTLM1(1),PTLM1(2),PTLM1(3), |
| 14458 | & PTLM1(4),0,0,0) |
| 14459 | CALL DT_EVTPUT(22,ID2,MOT,0,PTLM2(1),PTLM2(2),PTLM2(3), |
| 14460 | & PTLM2(4),0,0,0) |
| 14461 | CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4), |
| 14462 | & IDTR,IDXTR,8) |
| 14463 | ELSEIF (KT.EQ.2) THEN |
| 14464 | DO 6 K=1,4 |
| 14465 | PP1(K) = XTPO(1)*PPOM(K) |
| 14466 | PP2(K) = XTPO(2)*PPOM(K) |
| 14467 | PT1(K) = XTH(2)*PT(K) |
| 14468 | PT2(K) = XTH(1)*PT(K) |
| 14469 | 6 CONTINUE |
| 14470 | CALL DT_CHKCSY(IFTPO(1),IFT1,LCHK) |
| 14471 | XM1 = ZERO |
| 14472 | XM2 = ZERO |
| 14473 | IF (LCHK) THEN |
| 14474 | CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1) |
| 14475 | IF (IREJ1.NE.0) GOTO 9999 |
| 14476 | CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1) |
| 14477 | IF (IREJ1.NE.0) GOTO 9999 |
| 14478 | DO 7 K=1,4 |
| 14479 | PP1(K) = P1(K) |
| 14480 | PT1(K) = P2(K) |
| 14481 | PP2(K) = P3(K) |
| 14482 | PT2(K) = P4(K) |
| 14483 | 7 CONTINUE |
| 14484 | CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3), |
| 14485 | & PP1(4),0,0,8) |
| 14486 | CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), |
| 14487 | & 0,0,8) |
| 14488 | CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3), |
| 14489 | & PP2(4),0,0,8) |
| 14490 | CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), |
| 14491 | & 0,0,8) |
| 14492 | ELSE |
| 14493 | CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1) |
| 14494 | IF (IREJ1.NE.0) GOTO 9999 |
| 14495 | CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1) |
| 14496 | IF (IREJ1.NE.0) GOTO 9999 |
| 14497 | DO 8 K=1,4 |
| 14498 | PP1(K) = P1(K) |
| 14499 | PT2(K) = P2(K) |
| 14500 | PP2(K) = P3(K) |
| 14501 | PT1(K) = P4(K) |
| 14502 | 8 CONTINUE |
| 14503 | CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3), |
| 14504 | & PP1(4),0,0,8) |
| 14505 | CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), |
| 14506 | & 0,0,8) |
| 14507 | CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3), |
| 14508 | & PP2(4),0,0,8) |
| 14509 | CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), |
| 14510 | & 0,0,8) |
| 14511 | ENDIF |
| 14512 | NCSY = NCSY+1 |
| 14513 | ELSE |
| 14514 | CALL DT_EVTPUT(1,IDHKK(MOT),MOT,0,PSC(1),PSC(2),PSC(3),PSC(4), |
| 14515 | & 0,0,0) |
| 14516 | ENDIF |
| 14517 | |
| 14518 | RETURN |
| 14519 | |
| 14520 | 9999 CONTINUE |
| 14521 | IRDIFF(2) = IRDIFF(2)+1 |
| 14522 | IREJ = 1 |
| 14523 | RETURN |
| 14524 | END |
| 14525 | |
| 14526 | *$ CREATE DT_EVTFRG.FOR |
| 14527 | *COPY DT_EVTFRG |
| 14528 | * |
| 14529 | *===evtfrg=============================================================* |
| 14530 | * |
| 14531 | SUBROUTINE DT_EVTFRG(KMODE,NFRG,NPYMEM,IREJ) |
| 14532 | |
| 14533 | ************************************************************************ |
| 14534 | * Hadronization of chains in DTEVT1. * |
| 14535 | * * |
| 14536 | * Input: * |
| 14537 | * KMODE = 1 hadronization of PHOJET-chains (id=77xxx) * |
| 14538 | * = 2 hadronization of DTUNUC-chains (id=88xxx) * |
| 14539 | * NFRG if KMODE = 1 : upper index of PHOJET-scatterings to be * |
| 14540 | * hadronized with one PYEXEC call * |
| 14541 | * if KMODE = 2 : max. number of DTUNUC-chains to be hadronized * |
| 14542 | * with one PYEXEC call * |
| 14543 | * Output: * |
| 14544 | * NPYMEM number of entries in JETSET-common after hadronization * |
| 14545 | * IREJ rejection flag * |
| 14546 | * * |
| 14547 | * This version dated 17.09.00 is written by S. Roesler * |
| 14548 | ************************************************************************ |
| 14549 | |
| 14550 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 14551 | SAVE |
| 14552 | PARAMETER ( LINP = 10 , |
| 14553 | & LOUT = 6 , |
| 14554 | & LDAT = 9 ) |
| 14555 | PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1) |
| 14556 | PARAMETER (ONE=1.0D0,ZERO=0.0D0) |
| 14557 | |
| 14558 | LOGICAL LACCEP |
| 14559 | |
| 14560 | PARAMETER (MXJOIN=200) |
| 14561 | |
| 14562 | * event history |
| 14563 | PARAMETER (NMXHKK=200000) |
| 14564 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 14565 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 14566 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 14567 | * extended event history |
| 14568 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 14569 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 14570 | & IHIST(2,NMXHKK) |
| 14571 | * flags for input different options |
| 14572 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 14573 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 14574 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 14575 | * statistics |
| 14576 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, |
| 14577 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), |
| 14578 | & ICEVTG(8,0:30) |
| 14579 | * flags for diffractive interactions (DTUNUC 1.x) |
| 14580 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF |
| 14581 | * nucleon-nucleon event-generator |
| 14582 | CHARACTER*8 CMODEL |
| 14583 | LOGICAL LPHOIN |
| 14584 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN |
| 14585 | * phojet |
| 14586 | C model switches and parameters |
| 14587 | CHARACTER*8 MDLNA |
| 14588 | INTEGER ISWMDL,IPAMDL |
| 14589 | DOUBLE PRECISION PARMDL |
| 14590 | COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400) |
| 14591 | * jetset |
| 14592 | COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) |
| 1ddc441c |
14593 | COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) |
| 9aaba0d6 |
14594 | PARAMETER (MAXLND=4000) |
| 14595 | COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5) |
| 14596 | INTEGER PYK |
| 14597 | DIMENSION IJOIN(MXJOIN),ISJOIN(MXJOIN),IHISMO(8000),IFLG(4000) |
| 1ddc441c |
14598 | INTEGER PYCOMP |
| 9aaba0d6 |
14599 | MODE = KMODE |
| 14600 | ISTSTG = 7 |
| 14601 | IF (MODE.NE.1) ISTSTG = 8 |
| 14602 | IREJ = 0 |
| 14603 | |
| 14604 | IP = 0 |
| 14605 | ISH = 0 |
| 14606 | INIEMC = 1 |
| 14607 | NEND = NHKK |
| 14608 | NACCEP = 0 |
| 14609 | IFRG = 0 |
| 14610 | IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1 |
| 14611 | DO 10 I=NPOINT(3),NEND |
| 14612 | * sr 14.02.00: seems to be not necessary anymore, commented |
| 14613 | C LACCEP = ((NOBAM(I).EQ.0).AND.(MODE.EQ.1)).OR. |
| 14614 | C & ((NOBAM(I).NE.0).AND.(MODE.EQ.2)) |
| 14615 | LACCEP = .TRUE. |
| 14616 | * pick up chains from dtevt1 |
| 14617 | IDCHK = IDHKK(I)/10000 |
| 14618 | IF ((IDCHK.EQ.ISTSTG).AND.LACCEP) THEN |
| 14619 | IF (IDCHK.EQ.7) THEN |
| 14620 | IPJE = IDHKK(I)-IDCHK*10000 |
| 14621 | IF (IPJE.NE.IFRG) THEN |
| 14622 | IFRG = IPJE |
| 14623 | IF (IFRG.GT.NFRG) GOTO 16 |
| 14624 | ENDIF |
| 14625 | ELSE |
| 14626 | IPJE = 1 |
| 14627 | IFRG = IFRG+1 |
| 14628 | IF (IFRG.GT.NFRG) THEN |
| 14629 | NFRG = -1 |
| 14630 | GOTO 16 |
| 14631 | ENDIF |
| 14632 | ENDIF |
| 14633 | * statistics counter |
| 14634 | c IF (IDCH(I).LE.8) |
| 14635 | c & ICCHAI(2,IDCH(I)) = ICCHAI(2,IDCH(I))+1 |
| 14636 | c IF (IDRES(I).NE.0) ICRES(IDCH(I)) = ICRES(IDCH(I))+1 |
| 14637 | * special treatment for small chains already corrected to hadrons |
| 14638 | IF (IDRES(I).NE.0) THEN |
| 14639 | IF (IDRES(I).EQ.11) THEN |
| 14640 | ID = IDXRES(I) |
| 14641 | ELSE |
| 14642 | ID = IDT_IPDGHA(IDXRES(I)) |
| 14643 | ENDIF |
| 14644 | IF (LEMCCK) THEN |
| 14645 | CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I), |
| 14646 | & PHKK(4,I),INIEMC,IDUM,IDUM) |
| 14647 | INIEMC = 2 |
| 14648 | ENDIF |
| 14649 | IP = IP+1 |
| 14650 | IF (IP.GT.MSTU(4)) STOP ' NEWFRA 1: IP.GT.MSTU(4) !' |
| 14651 | P(IP,1) = PHKK(1,I) |
| 14652 | P(IP,2) = PHKK(2,I) |
| 14653 | P(IP,3) = PHKK(3,I) |
| 14654 | P(IP,4) = PHKK(4,I) |
| 14655 | P(IP,5) = PHKK(5,I) |
| 14656 | K(IP,1) = 1 |
| 14657 | K(IP,2) = ID |
| 14658 | K(IP,3) = 0 |
| 14659 | K(IP,4) = 0 |
| 14660 | K(IP,5) = 0 |
| 14661 | IHIST(2,I) = 10000*IPJE+IP |
| 14662 | IF (IHIST(1,I).LE.-100) THEN |
| 14663 | ISH = ISH+1 |
| 14664 | IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !' |
| 14665 | ISJOIN(ISH) = I |
| 14666 | ENDIF |
| 14667 | N = IP |
| 14668 | IHISMO(IP) = I |
| 14669 | ELSE |
| 14670 | IJ = 0 |
| 14671 | DO 11 KK=JMOHKK(1,I),JMOHKK(2,I) |
| 14672 | IF (LEMCCK) THEN |
| 14673 | CALL DT_EVTEMC(PHKK(1,KK),PHKK(2,KK),PHKK(3,KK), |
| 14674 | & PHKK(4,KK),INIEMC,IDUM,IDUM) |
| 14675 | CALL DT_EVTFLC(IDHKK(KK),1,INIEMC,IDUM,IDUM) |
| 14676 | INIEMC = 2 |
| 14677 | ENDIF |
| 14678 | ID = IDHKK(KK) |
| 14679 | IF (ID.EQ.0) ID = 21 |
| 14680 | c PTOT = SQRT(PHKK(1,KK)**2+PHKK(2,KK)**2+PHKK(3,KK)**2) |
| 14681 | c AM0 = SQRT(ABS((PHKK(4,KK)-PTOT)*(PHKK(4,KK)+PTOT))) |
| 14682 | c AMRQ = PYMASS(ID) |
| 14683 | c AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ) |
| 14684 | c IF ((ABS(AMDIF2).GT.TINY3).AND.(PTOT.GT.ZERO).AND. |
| 14685 | c & (ABS(IDIFF).EQ.0)) THEN |
| 14686 | cC WRITE(LOUT,*)'here: ',NEVHKK,AM0,AMRQ |
| 14687 | c DELTA = -AMDIF2/(2.0D0*(PHKK(4,KK)+PTOT)) |
| 14688 | c PHKK(4,KK) = PHKK(4,KK)+DELTA |
| 14689 | c PTOT1 = PTOT-DELTA |
| 14690 | c PHKK(1,KK) = PHKK(1,KK)*PTOT1/PTOT |
| 14691 | c PHKK(2,KK) = PHKK(2,KK)*PTOT1/PTOT |
| 14692 | c PHKK(3,KK) = PHKK(3,KK)*PTOT1/PTOT |
| 14693 | c PHKK(5,KK) = AMRQ |
| 14694 | c ENDIF |
| 14695 | IP = IP+1 |
| 14696 | IF (IP.GT.MSTU(4)) STOP ' NEWFRA 2: IP.GT.MSTU(4) !' |
| 14697 | P(IP,1) = PHKK(1,KK) |
| 14698 | P(IP,2) = PHKK(2,KK) |
| 14699 | P(IP,3) = PHKK(3,KK) |
| 14700 | P(IP,4) = PHKK(4,KK) |
| 14701 | P(IP,5) = PHKK(5,KK) |
| 14702 | K(IP,1) = 1 |
| 14703 | K(IP,2) = ID |
| 14704 | K(IP,3) = 0 |
| 14705 | K(IP,4) = 0 |
| 14706 | K(IP,5) = 0 |
| 14707 | IHIST(2,KK) = 10000*IPJE+IP |
| 14708 | IF (IHIST(1,KK).LE.-100) THEN |
| 14709 | ISH = ISH+1 |
| 14710 | IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !' |
| 14711 | ISJOIN(ISH) = KK |
| 14712 | ENDIF |
| 14713 | IJ = IJ+1 |
| 14714 | IF (IJ.GT.MXJOIN) STOP 'IJ > MXJOIN !' |
| 14715 | IJOIN(IJ) = IP |
| 14716 | IHISMO(IP) = I |
| 14717 | 11 CONTINUE |
| 14718 | N = IP |
| 14719 | * join the two-parton system |
| 14720 | CALL PYJOIN(IJ,IJOIN) |
| 14721 | ENDIF |
| 14722 | IDHKK(I) = 99999 |
| 14723 | ENDIF |
| 14724 | 10 CONTINUE |
| 14725 | 16 CONTINUE |
| 14726 | N = IP |
| 14727 | |
| 14728 | IF (IP.GT.0) THEN |
| 14729 | |
| 14730 | * final state parton shower |
| 14731 | DO 136 NPJE=1,IPJE |
| 14732 | IF ((MCGENE.EQ.2).AND.(ISH.GE.2)) THEN |
| 14733 | IF ((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN |
| 14734 | DO 130 K1=1,ISH |
| 14735 | IF (ISJOIN(K1).EQ.0) GOTO 130 |
| 14736 | I = ISJOIN(K1) |
| 14737 | IF ((IPAMDL(102).EQ.1).AND.(IHIST(1,I).NE.-100)) |
| 14738 | & GOTO 130 |
| 14739 | IH1 = IHIST(2,I)/10000 |
| 14740 | IF (IH1.NE.NPJE) GOTO 130 |
| 14741 | IH1 = IHIST(2,I)-IH1*10000 |
| 14742 | DO 135 K2=K1+1,ISH |
| 14743 | IF (ISJOIN(K2).EQ.0) GOTO 135 |
| 14744 | II = ISJOIN(K2) |
| 14745 | IH2 = IHIST(2,II)/10000 |
| 14746 | IF (IH2.NE.NPJE) GOTO 135 |
| 14747 | IH2 = IHIST(2,II)-IH2*10000 |
| 14748 | IF (IHIST(1,I).EQ.IHIST(1,II)) THEN |
| 14749 | PT1 = SQRT(PHKK(1,II)**2+PHKK(2,II)**2) |
| 14750 | PT2 = SQRT(PHKK(1, I)**2+PHKK(2, I)**2) |
| 14751 | RQLUN = MIN(PT1,PT2) |
| 14752 | CALL PYSHOW(IH1,IH2,RQLUN) |
| 14753 | |
| 14754 | ISJOIN(K1) = 0 |
| 14755 | ISJOIN(K2) = 0 |
| 14756 | GOTO 130 |
| 14757 | ENDIF |
| 14758 | 135 CONTINUE |
| 14759 | 130 CONTINUE |
| 14760 | ENDIF |
| 14761 | ENDIF |
| 14762 | 136 CONTINUE |
| 14763 | |
| 14764 | CALL DT_INITJS(MODE) |
| 14765 | * hadronization |
| 14766 | |
| 14767 | CALL PYEXEC |
| 14768 | |
| 14769 | IF (MSTU(24).NE.0) THEN |
| 14770 | WRITE(LOUT,*) ' JETSET-reject at event', |
| 14771 | & NEVHKK,MSTU(24),KMODE |
| 14772 | C CALL DT_EVTOUT(4) |
| 14773 | |
| 14774 | C CALL PYLIST(2) |
| 14775 | |
| 14776 | GOTO 9999 |
| 14777 | ENDIF |
| 14778 | |
| 14779 | * number of entries in LUJETS |
| 14780 | |
| 14781 | NLINES = PYK(0,1) |
| 14782 | |
| 14783 | NPYMEM = NLINES |
| 14784 | |
| 14785 | DO 12 I=1,NLINES |
| 14786 | IFLG(I) = 0 |
| 14787 | 12 CONTINUE |
| 14788 | |
| 14789 | DO 13 II=1,NLINES |
| 14790 | |
| 14791 | IF ((PYK(II,7).EQ.1).AND.(IFLG(II).NE.1)) THEN |
| 14792 | |
| 14793 | * pick up mother resonance if possible and put it together with |
| 14794 | * their decay-products into the common |
| 14795 | IDXMOR = K(II,3) |
| 14796 | IF ((IDXMOR.GE.1).AND.(IDXMOR.LE.MAXLND)) THEN |
| 14797 | KFMOR = K(IDXMOR,2) |
| 14798 | ISMOR = K(IDXMOR,1) |
| 14799 | ELSE |
| 14800 | KFMOR = 91 |
| 14801 | ISMOR = 1 |
| 14802 | ENDIF |
| 14803 | IF ((KFMOR.NE.91).AND.(KFMOR.NE.92).AND. |
| 14804 | & (KFMOR.NE.94).AND.(ISMOR.EQ.11)) THEN |
| 14805 | ID = K(IDXMOR,2) |
| 14806 | MO = IHISMO(PYK(IDXMOR,15)) |
| 14807 | PX = PYP(IDXMOR,1) |
| 14808 | PY = PYP(IDXMOR,2) |
| 14809 | PZ = PYP(IDXMOR,3) |
| 14810 | PE = PYP(IDXMOR,4) |
| 14811 | CALL DT_EVTPUT(2,ID,MO,0,PX,PY,PZ,PE,0,0,0) |
| 14812 | IFLG(IDXMOR) = 1 |
| 14813 | MO = NHKK |
| 14814 | DO 15 JDAUG=K(IDXMOR,4),K(IDXMOR,5) |
| 14815 | IF (PYK(JDAUG,7).EQ.1) THEN |
| 14816 | ID = PYK(JDAUG,8) |
| 14817 | PX = PYP(JDAUG,1) |
| 14818 | PY = PYP(JDAUG,2) |
| 14819 | PZ = PYP(JDAUG,3) |
| 14820 | PE = PYP(JDAUG,4) |
| 14821 | CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0) |
| 14822 | IF (LEMCCK) THEN |
| 14823 | PX = -PYP(JDAUG,1) |
| 14824 | PY = -PYP(JDAUG,2) |
| 14825 | PZ = -PYP(JDAUG,3) |
| 14826 | PE = -PYP(JDAUG,4) |
| 14827 | CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM) |
| 14828 | ENDIF |
| 14829 | IFLG(JDAUG) = 1 |
| 14830 | ENDIF |
| 14831 | 15 CONTINUE |
| 14832 | ELSE |
| 14833 | * there was no mother resonance |
| 14834 | MO = IHISMO(PYK(II,15)) |
| 14835 | ID = PYK(II,8) |
| 14836 | PX = PYP(II,1) |
| 14837 | PY = PYP(II,2) |
| 14838 | PZ = PYP(II,3) |
| 14839 | PE = PYP(II,4) |
| 14840 | CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0) |
| 14841 | IF (LEMCCK) THEN |
| 14842 | PX = -PYP(II,1) |
| 14843 | PY = -PYP(II,2) |
| 14844 | PZ = -PYP(II,3) |
| 14845 | PE = -PYP(II,4) |
| 14846 | CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM) |
| 14847 | ENDIF |
| 14848 | ENDIF |
| 14849 | ENDIF |
| 14850 | 13 CONTINUE |
| 14851 | IF (LEMCCK) THEN |
| 14852 | CHKLEV = TINY1 |
| 14853 | CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,6,IREJ1) |
| 14854 | C IF (IREJ1.NE.0) CALL DT_EVTOUT(4) |
| 14855 | ENDIF |
| 14856 | |
| 14857 | * global energy-momentum & flavor conservation check |
| 14858 | **sr 16.5. this check is skipped in case of phojet-treatment |
| 14859 | IF (MCGENE.EQ.1) |
| 14860 | & CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,12,IREJ3) |
| 14861 | |
| 14862 | * update statistics-counter for diffraction |
| 14863 | c IF (IFLAGD.NE.0) THEN |
| 14864 | c ICDIFF(1) = ICDIFF(1)+1 |
| 14865 | c IF (IFLAGD.EQ. 1) ICDIFF(2) = ICDIFF(2)+1 |
| 14866 | c IF (IFLAGD.EQ. 2) ICDIFF(3) = ICDIFF(3)+1 |
| 14867 | c IF (IFLAGD.EQ.-1) ICDIFF(4) = ICDIFF(4)+1 |
| 14868 | c IF (IFLAGD.EQ.-2) ICDIFF(5) = ICDIFF(5)+1 |
| 14869 | c ENDIF |
| 14870 | |
| 14871 | ENDIF |
| 14872 | |
| 14873 | RETURN |
| 14874 | |
| 14875 | 9999 CONTINUE |
| 14876 | IREJ = 1 |
| 14877 | RETURN |
| 14878 | END |
| 14879 | |
| 14880 | *$ CREATE DT_DECAYS.FOR |
| 14881 | *COPY DT_DECAYS |
| 14882 | * |
| 14883 | *===decay==============================================================* |
| 14884 | * |
| 14885 | SUBROUTINE DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ) |
| 14886 | |
| 14887 | ************************************************************************ |
| 14888 | * Resonance-decay. * |
| 14889 | * This subroutine replaces DDECAY/DECHKK. * |
| 14890 | * PIN(4) 4-momentum of resonance (input) * |
| 14891 | * IDXIN BAMJET-index of resonance (input) * |
| 14892 | * POUT(20,4) 4-momenta of decay-products (output) * |
| 14893 | * IDXOUT(20) BAMJET-indices of decay-products (output) * |
| 14894 | * NSEC number of secondaries (output) * |
| 14895 | * Adopted from the original version DECHKK. * |
| 14896 | * This version dated 09.01.95 is written by S. Roesler * |
| 14897 | ************************************************************************ |
| 14898 | |
| 14899 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 14900 | SAVE |
| 14901 | PARAMETER ( LINP = 10 , |
| 14902 | & LOUT = 6 , |
| 14903 | & LDAT = 9 ) |
| 14904 | PARAMETER (TINY17=1.0D-17) |
| 14905 | |
| 14906 | * HADRIN: decay channel information |
| 14907 | PARAMETER (IDMAX9=602) |
| 14908 | CHARACTER*8 ZKNAME |
| 14909 | COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3) |
| 14910 | * particle properties (BAMJET index convention) |
| 14911 | CHARACTER*8 ANAME |
| 14912 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 14913 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 14914 | * flags for input different options |
| 14915 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 14916 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 14917 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 14918 | |
| 14919 | DIMENSION PIN(4),PI(20,4),POUT(20,4),IDXOUT(20), |
| 14920 | & EF(3),PF(3),PFF(3),IDXSTK(20),IDX(3), |
| 14921 | & CODF(3),COFF(3),SIFF(3),DCOS(3),DCOSF(3) |
| 14922 | |
| 14923 | * ISTAB = 1 strong and weak decays |
| 14924 | * = 2 strong decays only |
| 14925 | * = 3 strong decays, weak decays for charmed particles and tau |
| 14926 | * leptons only |
| 14927 | DATA ISTAB /2/ |
| 14928 | |
| 14929 | IREJ = 0 |
| 14930 | NSEC = 0 |
| 14931 | * put initial resonance to stack |
| 14932 | NSTK = 1 |
| 14933 | IDXSTK(NSTK) = IDXIN |
| 14934 | DO 5 I=1,4 |
| 14935 | PI(NSTK,I) = PIN(I) |
| 14936 | 5 CONTINUE |
| 14937 | |
| 14938 | * store initial configuration for energy-momentum cons. check |
| 14939 | IF (LEMCCK) CALL DT_EVTEMC(PI(NSTK,1),PI(NSTK,2),PI(NSTK,3), |
| 14940 | & PI(NSTK,4),1,IDUM,IDUM) |
| 14941 | |
| 14942 | 100 CONTINUE |
| 14943 | * get particle from stack |
| 14944 | IDXI = IDXSTK(NSTK) |
| 14945 | * skip stable particles |
| 14946 | IF (ISTAB.EQ.1) THEN |
| 14947 | IF ((IDXI.EQ.135).OR. (IDXI.EQ.136)) GOTO 10 |
| 14948 | IF ((IDXI.GE. 1).AND.(IDXI.LE. 7)) GOTO 10 |
| 14949 | ELSEIF (ISTAB.EQ.2) THEN |
| 14950 | IF ((IDXI.GE. 1).AND.(IDXI.LE. 30)) GOTO 10 |
| 14951 | IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10 |
| 14952 | IF ((IDXI.GE.115).AND.(IDXI.LE.122)) GOTO 10 |
| 14953 | IF ((IDXI.GE.131).AND.(IDXI.LE.136)) GOTO 10 |
| 14954 | IF ( IDXI.EQ.109) GOTO 10 |
| 14955 | IF ((IDXI.GE.137).AND.(IDXI.LE.160)) GOTO 10 |
| 14956 | ELSEIF (ISTAB.EQ.3) THEN |
| 14957 | IF ((IDXI.GE. 1).AND.(IDXI.LE. 23)) GOTO 10 |
| 14958 | IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10 |
| 14959 | IF ((IDXI.GE.109).AND.(IDXI.LE.115)) GOTO 10 |
| 14960 | IF ((IDXI.GE.133).AND.(IDXI.LE.136)) GOTO 10 |
| 14961 | ENDIF |
| 14962 | |
| 14963 | * calculate direction cosines and Lorentz-parameter of decaying part. |
| 14964 | PTOT = SQRT(PI(NSTK,1)**2+PI(NSTK,2)**2+PI(NSTK,3)**2) |
| 14965 | PTOT = MAX(PTOT,TINY17) |
| 14966 | DO 1 I=1,3 |
| 14967 | DCOS(I) = PI(NSTK,I)/PTOT |
| 14968 | 1 CONTINUE |
| 14969 | GAM = PI(NSTK,4)/AAM(IDXI) |
| 14970 | BGAM = PTOT/AAM(IDXI) |
| 14971 | |
| 14972 | * get decay-channel |
| 14973 | KCHAN = K1(IDXI)-1 |
| 14974 | 2 CONTINUE |
| 14975 | KCHAN = KCHAN+1 |
| 14976 | IF ((DT_RNDM(GAM)-TINY17).GT.WT(KCHAN)) GOTO 2 |
| 14977 | |
| 14978 | * identities of secondaries |
| 14979 | IDX(1) = NZK(KCHAN,1) |
| 14980 | IDX(2) = NZK(KCHAN,2) |
| 14981 | IF (IDX(2).LT.1) GOTO 9999 |
| 14982 | IDX(3) = NZK(KCHAN,3) |
| 14983 | |
| 14984 | * handle decay in rest system of decaying particle |
| 14985 | IF (IDX(3).EQ.0) THEN |
| 14986 | * two-particle decay |
| 14987 | NDEC = 2 |
| 14988 | CALL DT_DTWOPD(AAM(IDXI),EF(1),EF(2),PF(1),PF(2), |
| 14989 | & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2), |
| 14990 | & AAM(IDX(1)),AAM(IDX(2))) |
| 14991 | ELSE |
| 14992 | * three-particle decay |
| 14993 | NDEC = 3 |
| 14994 | CALL DT_DTHREP(AAM(IDXI),EF(1),EF(2),EF(3),PF(1),PF(2),PF(3), |
| 14995 | & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2), |
| 14996 | & CODF(3),COFF(3),SIFF(3), |
| 14997 | & AAM(IDX(1)),AAM(IDX(2)),AAM(IDX(3))) |
| 14998 | ENDIF |
| 14999 | NSTK = NSTK-1 |
| 15000 | |
| 15001 | * transform decay products back |
| 15002 | DO 3 I=1,NDEC |
| 15003 | NSTK = NSTK+1 |
| 15004 | CALL DT_DTRAFO(GAM,BGAM,DCOS(1),DCOS(2),DCOS(3), |
| 15005 | & CODF(I),COFF(I),SIFF(I),PF(I),EF(I), |
| 15006 | & PFF(I),DCOSF(1),DCOSF(2),DCOSF(3),PI(NSTK,4)) |
| 15007 | * add particle to stack |
| 15008 | IDXSTK(NSTK) = IDX(I) |
| 15009 | DO 4 J=1,3 |
| 15010 | PI(NSTK,J) = DCOSF(J)*PFF(I) |
| 15011 | 4 CONTINUE |
| 15012 | 3 CONTINUE |
| 15013 | GOTO 100 |
| 15014 | |
| 15015 | 10 CONTINUE |
| 15016 | * stable particle, put to output-arrays |
| 15017 | NSEC = NSEC+1 |
| 15018 | DO 6 I=1,4 |
| 15019 | POUT(NSEC,I) = PI(NSTK,I) |
| 15020 | 6 CONTINUE |
| 15021 | IDXOUT(NSEC) = IDXSTK(NSTK) |
| 15022 | * store secondaries for energy-momentum conservation check |
| 15023 | IF (LEMCCK) |
| 15024 | &CALL DT_EVTEMC(-POUT(NSEC,1),-POUT(NSEC,2),-POUT(NSEC,3), |
| 15025 | & -POUT(NSEC,4),2,IDUM,IDUM) |
| 15026 | NSTK = NSTK-1 |
| 15027 | IF (NSTK.GT.0) GOTO 100 |
| 15028 | |
| 15029 | * check energy-momentum conservation |
| 15030 | IF (LEMCCK) THEN |
| 15031 | CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,5,IREJ1) |
| 15032 | IF (IREJ1.NE.0) GOTO 9999 |
| 15033 | ENDIF |
| 15034 | |
| 15035 | RETURN |
| 15036 | |
| 15037 | 9999 CONTINUE |
| 15038 | IREJ = 1 |
| 15039 | RETURN |
| 15040 | END |
| 15041 | |
| 15042 | *$ CREATE DT_DECAY1.FOR |
| 15043 | *COPY DT_DECAY1 |
| 15044 | * |
| 15045 | *===decay1=============================================================* |
| 15046 | * |
| 15047 | SUBROUTINE DT_DECAY1 |
| 15048 | |
| 15049 | ************************************************************************ |
| 15050 | * Decay of resonances stored in DTEVT1. * |
| 15051 | * This version dated 20.01.95 is written by S. Roesler * |
| 15052 | ************************************************************************ |
| 15053 | |
| 15054 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 15055 | SAVE |
| 15056 | PARAMETER ( LINP = 10 , |
| 15057 | & LOUT = 6 , |
| 15058 | & LDAT = 9 ) |
| 15059 | |
| 15060 | * event history |
| 15061 | PARAMETER (NMXHKK=200000) |
| 15062 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 15063 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 15064 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 15065 | * extended event history |
| 15066 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 15067 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 15068 | & IHIST(2,NMXHKK) |
| 15069 | |
| 15070 | DIMENSION PIN(4),POUT(20,4),IDXOUT(20) |
| 15071 | |
| 15072 | NEND = NHKK |
| 15073 | C DO 1 I=NPOINT(5),NEND |
| 15074 | DO 1 I=NPOINT(4),NEND |
| 15075 | IF (ABS(ISTHKK(I)).EQ.1) THEN |
| 15076 | DO 2 K=1,4 |
| 15077 | PIN(K) = PHKK(K,I) |
| 15078 | 2 CONTINUE |
| 15079 | IDXIN = IDBAM(I) |
| 15080 | CALL DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ) |
| 15081 | IF (NSEC.GT.1) THEN |
| 15082 | DO 3 N=1,NSEC |
| 15083 | IDHAD = IDT_IPDGHA(IDXOUT(N)) |
| 15084 | CALL DT_EVTPUT(1,IDHAD,I,0,POUT(N,1),POUT(N,2), |
| 15085 | & POUT(N,3),POUT(N,4),0,0,0) |
| 15086 | 3 CONTINUE |
| 15087 | ENDIF |
| 15088 | ENDIF |
| 15089 | 1 CONTINUE |
| 15090 | |
| 15091 | RETURN |
| 15092 | END |
| 15093 | |
| 15094 | *$ CREATE DT_DECPI0.FOR |
| 15095 | *COPY DT_DECPI0 |
| 15096 | * |
| 15097 | *===decpi0=============================================================* |
| 15098 | * |
| 15099 | SUBROUTINE DT_DECPI0 |
| 15100 | |
| 15101 | ************************************************************************ |
| 15102 | * Decay of pi0 handled with JETSET. * |
| 15103 | * This version dated 18.02.96 is written by S. Roesler * |
| 15104 | ************************************************************************ |
| 15105 | |
| 15106 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 15107 | SAVE |
| 15108 | PARAMETER ( LINP = 10 , |
| 15109 | & LOUT = 6 , |
| 15110 | & LDAT = 9 ) |
| 15111 | PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0,ZERO=0.0D0) |
| 15112 | |
| 15113 | * event history |
| 15114 | PARAMETER (NMXHKK=200000) |
| 15115 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 15116 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 15117 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 15118 | * extended event history |
| 15119 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 15120 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 15121 | & IHIST(2,NMXHKK) |
| bd378884 |
15122 | COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) |
| 9aaba0d6 |
15123 | COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) |
| 15124 | PARAMETER (MAXLND=4000) |
| 15125 | COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5) |
| 15126 | * flags for input different options |
| 15127 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 15128 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 15129 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 15130 | |
| 15131 | INTEGER PYCOMP,PYK |
| 15132 | |
| 15133 | DIMENSION IHISMO(NMXHKK),P1(4) |
| 15134 | |
| 15135 | TWOPI = 2.0D0*ATAN2(0.0D0,-1.0D0) |
| 15136 | |
| 15137 | CALL DT_INITJS(2) |
| 15138 | * allow pi0 decay |
| 15139 | KC = PYCOMP(111) |
| 15140 | MDCY(KC,1) = 1 |
| 15141 | |
| 15142 | NN = 0 |
| 15143 | INI = 0 |
| 15144 | DO 1 I=1,NHKK |
| 15145 | IF ((ISTHKK(I).EQ.1).AND.(IDHKK(I).EQ.111)) THEN |
| 15146 | IF (INI.EQ.0) THEN |
| 15147 | INI = 1 |
| 15148 | ELSE |
| 15149 | INI = 2 |
| 15150 | ENDIF |
| 15151 | IF (LEMCCK) CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I), |
| 15152 | & PHKK(4,I),INI,IDUM,IDUM) |
| 15153 | PT = SQRT(PHKK(1,I)**2+PHKK(2,I)**2) |
| 15154 | PTOT = SQRT(PT**2+PHKK(3,I)**2) |
| 15155 | COSTH = PHKK(3,I)/(PTOT+TINY10) |
| 15156 | IF (COSTH.GT.ONE) THEN |
| 15157 | THETA = ZERO |
| 15158 | ELSEIF (COSTH.LT.-ONE) THEN |
| 15159 | THETA = TWOPI/2.0D0 |
| 15160 | ELSE |
| 15161 | THETA = ACOS(COSTH) |
| 15162 | ENDIF |
| 15163 | PHI = ASIN(PHKK(2,I)/(PT +TINY10)) |
| 15164 | IF (PHKK(1,I).LT.0.0D0) |
| 15165 | & PHI = SIGN(TWOPI/2.0D0-ABS(PHI),PHI) |
| 15166 | ENER = PHKK(4,I) |
| 15167 | NN = NN+1 |
| 15168 | KTEMP = MSTU(10) |
| 15169 | MSTU(10)= 1 |
| 15170 | P(NN,5) = PHKK(5,I) |
| 15171 | CALL PY1ENT(NN,111,ENER,THETA,PHI) |
| 15172 | MSTU(10) = KTEMP |
| 15173 | IHISMO(NN)= I |
| 15174 | ENDIF |
| 15175 | 1 CONTINUE |
| 15176 | IF (NN.GT.0) THEN |
| 15177 | CALL PYEXEC |
| 15178 | NLINES = PYK(0,1) |
| 15179 | DO 2 II=1,NLINES |
| 15180 | IF (PYK(II,7).EQ.1) THEN |
| 15181 | DO 3 KK=1,4 |
| 15182 | P1(KK) = PYP(II,KK) |
| 15183 | 3 CONTINUE |
| 15184 | ID = PYK(II,8) |
| 15185 | MO = IHISMO(PYK(II,15)) |
| 15186 | CALL DT_EVTPUT(1,ID,MO,0,P1(1),P1(2),P1(3),P1(4),0,0,0) |
| 15187 | IF (LEMCCK) |
| 15188 | & CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2, |
| 15189 | & IDUM,IDUM) |
| 15190 | *sr: flag with neg. sign (for HELIOS p/A-W jobs) |
| 15191 | ISTHKK(MO) = -2 |
| 15192 | ENDIF |
| 15193 | 2 CONTINUE |
| 15194 | IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,7000,IREJ1) |
| 15195 | ENDIF |
| 15196 | MDCY(KC,1) = 0 |
| 15197 | |
| 15198 | RETURN |
| 15199 | END |
| 15200 | |
| 15201 | *$ CREATE DT_DTWOPD.FOR |
| 15202 | *COPY DT_DTWOPD |
| 15203 | * |
| 15204 | *===dtwopd=============================================================* |
| 15205 | * |
| 15206 | SUBROUTINE DT_DTWOPD(UMO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,COD2, |
| 15207 | & COF2,SIF2,AM1,AM2) |
| 15208 | |
| 15209 | ************************************************************************ |
| 15210 | * Two-particle decay. * |
| 15211 | * UMO cm-energy of the decaying system (input) * |
| 15212 | * AM1/AM2 masses of the decay products (input) * |
| 15213 | * ECM1,ECM2/PCM1,PCM2 cm-energies/momenta of the decay prod. (output) * |
| 15214 | * COD,COF,SIF direction cosines of the decay prod. (output) * |
| 15215 | * Revised by S. Roesler, 20.11.95 * |
| 15216 | ************************************************************************ |
| 15217 | |
| 15218 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 15219 | SAVE |
| 15220 | PARAMETER ( LINP = 10 , |
| 15221 | & LOUT = 6 , |
| 15222 | & LDAT = 9 ) |
| 15223 | PARAMETER (TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,ZERO=0.0D0) |
| 15224 | |
| 15225 | IF (UMO.LT.(AM1+AM2)) THEN |
| 15226 | WRITE(LOUT,1000) UMO,AM1,AM2 |
| 15227 | 1000 FORMAT(1X,'DTWOPD: inconsistent kinematics - UMO,AM1,AM2 ', |
| 15228 | & 3E12.3) |
| 15229 | STOP |
| 15230 | ENDIF |
| 15231 | |
| 15232 | ECM1 = ((UMO-AM2)*(UMO+AM2)+AM1*AM1)/(TWO*UMO) |
| 15233 | ECM2 = UMO-ECM1 |
| 15234 | PCM1 = SQRT((ECM1-AM1)*(ECM1+AM1)) |
| 15235 | PCM2 = PCM1 |
| 15236 | CALL DT_DSFECF(SIF1,COF1) |
| 15237 | COD1 = TWO*DT_RNDM(PCM2)-ONE |
| 15238 | COD2 = -COD1 |
| 15239 | COF2 = -COF1 |
| 15240 | SIF2 = -SIF1 |
| 15241 | |
| 15242 | RETURN |
| 15243 | END |
| 15244 | |
| 15245 | *$ CREATE DT_DTHREP.FOR |
| 15246 | *COPY DT_DTHREP |
| 15247 | * |
| 15248 | *===dthrep=============================================================* |
| 15249 | * |
| 15250 | SUBROUTINE DT_DTHREP(UMO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1, |
| 15251 | & SIF1,COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3) |
| 15252 | |
| 15253 | ************************************************************************ |
| 15254 | * Three-particle decay. * |
| 15255 | * UMO cm-energy of the decaying system (input) * |
| 15256 | * AM1/2/3 masses of the decay products (input) * |
| 15257 | * ECM1/2/2,PCM1/2/3 cm-energies/momenta of the decay prod. (output) * |
| 15258 | * COD,COF,SIF direction cosines of the decay prod. (output) * |
| 15259 | * * |
| 15260 | * Threpd89: slight revision by A. Ferrari * |
| 15261 | * Last change on 11-oct-93 by Alfredo Ferrari, INFN - Milan * |
| 15262 | * Revised by S. Roesler, 20.11.95 * |
| 15263 | ************************************************************************ |
| 15264 | |
| 15265 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 15266 | SAVE |
| 15267 | PARAMETER ( LINP = 10 , |
| 15268 | & LOUT = 6 , |
| 15269 | & LDAT = 9 ) |
| 15270 | |
| 15271 | PARAMETER ( ANGLSQ = 2.5D-31 ) |
| 15272 | PARAMETER ( AZRZRZ = 1.0D-30 ) |
| 15273 | PARAMETER ( ONEMNS = 0.999999999999999 D+00 ) |
| 15274 | PARAMETER ( ONEPLS = 1.000000000000001 D+00 ) |
| 15275 | PARAMETER ( ONEONE = 1.D+00 ) |
| 15276 | PARAMETER ( TWOTWO = 2.D+00 ) |
| 15277 | PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 ) |
| 15278 | |
| 15279 | COMMON /HNGAMR/ REDU,AMO,AMM(15) |
| 15280 | * flags for input different options |
| 15281 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 15282 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 15283 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 15284 | |
| 15285 | DIMENSION F(5),XX(5) |
| 15286 | DATA EPS /AZRZRZ/ |
| 15287 | |
| 15288 | UMOO=UMO+UMO |
| 15289 | C***S1, S2, S3 ARE THE INVARIANT MASSES OF THE PARTICLES 1, 2, 3 |
| 15290 | C***J. VON NEUMANN - RANDOM - SELECTION OF S2 |
| 15291 | C***CALCULATION OF THE MAXIMUM OF THE S2 - DISTRIBUTION |
| 15292 | UUMO=UMO |
| 15293 | AAM1=AM1 |
| 15294 | AAM2=AM2 |
| 15295 | AAM3=AM3 |
| 15296 | GU=(AM2+AM3)**2 |
| 15297 | GO=(UMO-AM1)**2 |
| 15298 | * UFAK=1.0000000000001D0 |
| 15299 | * IF (GU.GT.GO) UFAK=0.9999999999999D0 |
| 15300 | IF (GU.GT.GO) THEN |
| 15301 | UFAK=ONEMNS |
| 15302 | ELSE |
| 15303 | UFAK=ONEPLS |
| 15304 | END IF |
| 15305 | OFAK=2.D0-UFAK |
| 15306 | GU=GU*UFAK |
| 15307 | GO=GO*OFAK |
| 15308 | DS2=(GO-GU)/99.D0 |
| 15309 | AM11=AM1*AM1 |
| 15310 | AM22=AM2*AM2 |
| 15311 | AM33=AM3*AM3 |
| 15312 | UMO2=UMO*UMO |
| 15313 | RHO2=0.D0 |
| 15314 | S22=GU |
| 15315 | DO 124 I=1,100 |
| 15316 | S21=S22 |
| 15317 | S22=GU+(I-1.D0)*DS2 |
| 15318 | RHO1=RHO2 |
| 15319 | RHO2=DT_YLAMB(S22,UMO2,AM11)*DT_YLAMB(S22,AM22,AM33)/ |
| 15320 | * (S22+EPS) |
| 15321 | IF(RHO2.LT.RHO1) GO TO 125 |
| 15322 | 124 CONTINUE |
| 15323 | 125 S2SUP=(S22-S21)*.5D0+S21 |
| 15324 | SUPRHO=DT_YLAMB(S2SUP,UMO2,AM11)*DT_YLAMB(S2SUP,AM22,AM33)/ |
| 15325 | * (S2SUP+EPS) |
| 15326 | SUPRHO=SUPRHO*1.05D0 |
| 15327 | XO=S21-DS2 |
| 15328 | IF (GU.LT.GO.AND.XO.LT.GU) XO=GU |
| 15329 | IF (GU.GT.GO.AND.XO.GT.GU) XO=GU |
| 15330 | XX(1)=XO |
| 15331 | XX(3)=S22 |
| 15332 | X1=(XO+S22)*0.5D0 |
| 15333 | XX(2)=X1 |
| 15334 | F(3)=RHO2 |
| 15335 | F(1)=DT_YLAMB(XO,UMO2,AM11)*DT_YLAMB(XO,AM22,AM33)/(XO+EPS) |
| 15336 | F(2)=DT_YLAMB(X1,UMO2,AM11)*DT_YLAMB(X1,AM22,AM33)/(X1+EPS) |
| 15337 | DO 126 I=1,16 |
| 15338 | X4=(XX(1)+XX(2))*0.5D0 |
| 15339 | X5=(XX(2)+XX(3))*0.5D0 |
| 15340 | F(4)=DT_YLAMB(X4,UMO2,AM11)*DT_YLAMB(X4,AM22,AM33)/ |
| 15341 | * (X4+EPS) |
| 15342 | F(5)=DT_YLAMB(X5,UMO2,AM11)*DT_YLAMB(X5,AM22,AM33)/ |
| 15343 | * (X5+EPS) |
| 15344 | XX(4)=X4 |
| 15345 | XX(5)=X5 |
| 15346 | DO 128 II=1,5 |
| 15347 | IA=II |
| 15348 | DO 128 III=IA,5 |
| 15349 | IF (F (II).GE.F (III)) GO TO 128 |
| 15350 | FH=F(II) |
| 15351 | F(II)=F(III) |
| 15352 | F(III)=FH |
| 15353 | FH=XX(II) |
| 15354 | XX(II)=XX(III) |
| 15355 | XX(III)=FH |
| 15356 | 128 CONTINUE |
| 15357 | SUPRHO=F(1) |
| 15358 | S2SUP=XX(1) |
| 15359 | DO 129 II=1,3 |
| 15360 | IA=II |
| 15361 | DO 129 III=IA,3 |
| 15362 | IF (XX(II).GE.XX(III)) GO TO 129 |
| 15363 | FH=F(II) |
| 15364 | F(II)=F(III) |
| 15365 | F(III)=FH |
| 15366 | FH=XX(II) |
| 15367 | XX(II)=XX(III) |
| 15368 | XX(III)=FH |
| 15369 | 129 CONTINUE |
| 15370 | 126 CONTINUE |
| 15371 | AM23=(AM2+AM3)**2 |
| 15372 | ITH=0 |
| 15373 | REDU=2.D0 |
| 15374 | 1 CONTINUE |
| 15375 | ITH=ITH+1 |
| 15376 | IF (ITH.GT.200) REDU=-9.D0 |
| 15377 | IF (ITH.GT.200) GO TO 400 |
| 15378 | C=DT_RNDM(REDU) |
| 15379 | * S2=AM23+C*((UMO-AM1)**2-AM23) |
| 15380 | S2=AM23+C*(UMO-AM1-AM2-AM3)*(UMO-AM1+AM2+AM3) |
| 15381 | Y=DT_RNDM(S2) |
| 15382 | Y=Y*SUPRHO |
| 15383 | RHO=DT_YLAMB(S2,UMO2,AM11)*DT_YLAMB(S2,AM22,AM33)/S2 |
| 15384 | IF(Y.GT.RHO) GO TO 1 |
| 15385 | C***RANDOM SELECTION OF S3 AND CALCULATION OF S1 |
| 15386 | S1=DT_RNDM(S2) |
| 15387 | S1=S1*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)/(2.D0*S2)- |
| 15388 | &RHO*.5D0 |
| 15389 | S3=UMO2+AM11+AM22+AM33-S1-S2 |
| 15390 | ECM1=(UMO2+AM11-S2)/UMOO |
| 15391 | ECM2=(UMO2+AM22-S3)/UMOO |
| 15392 | ECM3=(UMO2+AM33-S1)/UMOO |
| 15393 | PCM1=SQRT((ECM1+AM1)*(ECM1-AM1)) |
| 15394 | PCM2=SQRT((ECM2+AM2)*(ECM2-AM2)) |
| 15395 | PCM3=SQRT((ECM3+AM3)*(ECM3-AM3)) |
| 15396 | CALL DT_DSFECF(SFE,CFE) |
| 15397 | C***TH IS THE ANGLE BETWEEN PARTICLES 1 AND 2 |
| 15398 | C***TH1, TH2 ARE THE ANGLES BETWEEN PARTICLES 1, 2 AND THE DIRECTION OF |
| 15399 | PCM12 = PCM1 * PCM2 |
| 15400 | IF ( PCM12 .LT. ANGLSQ ) GO TO 200 |
| 15401 | COSTH=(ECM1*ECM2+0.5D+00*(AM11+AM22-S1))/PCM12 |
| 15402 | GO TO 300 |
| 15403 | 200 CONTINUE |
| 15404 | UW=DT_RNDM(S1) |
| 15405 | COSTH=(UW-0.5D+00)*2.D+00 |
| 15406 | 300 CONTINUE |
| 15407 | * IF(ABS(COSTH).GT.0.9999999999999999D0) |
| 15408 | * &COSTH=SIGN(0.9999999999999999D0,COSTH) |
| 15409 | IF(ABS(COSTH).GT.ONEONE) |
| 15410 | &COSTH=SIGN(ONEONE,COSTH) |
| 15411 | IF (REDU.LT.1.D+00) RETURN |
| 15412 | COSTH2=(PCM3*PCM3+PCM2*PCM2-PCM1*PCM1)/(2.D+00*PCM2*PCM3) |
| 15413 | * IF(ABS(COSTH2).GT.0.9999999999999999D0) |
| 15414 | * &COSTH2=SIGN(0.9999999999999999D0,COSTH2) |
| 15415 | IF(ABS(COSTH2).GT.ONEONE) |
| 15416 | &COSTH2=SIGN(ONEONE,COSTH2) |
| 15417 | SINTH2=SQRT((ONEONE-COSTH2)*(ONEONE+COSTH2)) |
| 15418 | SINTH =SQRT((ONEONE-COSTH)*(ONEONE+COSTH)) |
| 15419 | SINTH1=COSTH2*SINTH-COSTH*SINTH2 |
| 15420 | COSTH1=COSTH*COSTH2+SINTH2*SINTH |
| 15421 | C***RANDOM SELECTION OF THE SPHERICAL COORDINATES OF THE DIRECTION OF PA |
| 15422 | C***CFE, SFE ARE COS AND SIN OF THE ROTATION ANGLE OF THE SYSTEM 1, 2 AR |
| 15423 | C***THE DIRECTION OF PARTICLE 3 |
| 15424 | C***CALCULATION OF THE SPHERICAL COORDINATES OF PARTICLES 1, 2 |
| 15425 | CX11=-COSTH1 |
| 15426 | CY11=SINTH1*CFE |
| 15427 | CZ11=SINTH1*SFE |
| 15428 | CX22=-COSTH2 |
| 15429 | CY22=-SINTH2*CFE |
| 15430 | CZ22=-SINTH2*SFE |
| 15431 | CALL DT_DSFECF(SIF3,COF3) |
| 15432 | COD3=TWOTWO*DT_RNDM(CX11)-ONEONE |
| 15433 | SID3=SQRT((1.D+00-COD3)*(1.D+00+COD3)) |
| 15434 | 2 FORMAT(5F20.15) |
| 15435 | COD1=CX11*COD3+CZ11*SID3 |
| 15436 | CHLP=(ONEONE-COD1)*(ONEONE+COD1) |
| 15437 | IF(CHLP.LT.1.D-14)WRITE(LOUT,2)COD1,COF3,SID3, |
| 15438 | &CX11,CZ11 |
| 15439 | SID1=SQRT(CHLP) |
| 15440 | COF1=(CX11*SID3*COF3-CY11*SIF3-CZ11*COD3*COF3)/SID1 |
| 15441 | SIF1=(CX11*SID3*SIF3+CY11*COF3-CZ11*COD3*SIF3)/SID1 |
| 15442 | COD2=CX22*COD3+CZ22*SID3 |
| 15443 | SID2=SQRT((ONEONE-COD2)*(ONEONE+COD2)) |
| 15444 | COF2=(CX22*SID3*COF3-CY22*SIF3-CZ22*COD3*COF3)/SID2 |
| 15445 | SIF2=(CX22*SID3*SIF3+CY22*COF3-CZ22*COD3*SIF3)/SID2 |
| 15446 | 400 CONTINUE |
| 15447 | * === Energy conservation check: === * |
| 15448 | EOCHCK = UMO - ECM1 - ECM2 - ECM3 |
| 15449 | * SID1 = SQRT ( ( ONEONE - COD1 ) * ( ONEONE + COD1 ) ) |
| 15450 | * SID2 = SQRT ( ( ONEONE - COD2 ) * ( ONEONE + COD2 ) ) |
| 15451 | * SID3 = SQRT ( ( ONEONE - COD3 ) * ( ONEONE + COD3 ) ) |
| 15452 | PZCHCK = PCM1 * COD1 + PCM2 * COD2 + PCM3 * COD3 |
| 15453 | PXCHCK = PCM1 * COF1 * SID1 + PCM2 * COF2 * SID2 |
| 15454 | & + PCM3 * COF3 * SID3 |
| 15455 | PYCHCK = PCM1 * SIF1 * SID1 + PCM2 * SIF2 * SID2 |
| 15456 | & + PCM3 * SIF3 * SID3 |
| 15457 | EOCMPR = 1.D-12 * UMO |
| 15458 | IF ( ABS (EOCHCK) + ABS (PXCHCK) + ABS (PYCHCK) + ABS (PZCHCK) |
| 15459 | & .GT. EOCMPR ) THEN |
| 15460 | **sr 5.5.95 output-unit changed |
| 15461 | IF (IOULEV(1).GT.0) THEN |
| 15462 | WRITE(LOUT,*) |
| 15463 | & ' *** Threpd: energy/momentum conservation failure! ***', |
| 15464 | & EOCHCK,PXCHCK,PYCHCK,PZCHCK |
| 15465 | WRITE(LOUT,*)' *** SID1,SID2,SID3',SID1,SID2,SID3 |
| 15466 | ENDIF |
| 15467 | ** |
| 15468 | END IF |
| 15469 | RETURN |
| 15470 | END |
| 15471 | |
| 15472 | *$ CREATE DT_DBKLAS.FOR |
| 15473 | *COPY DT_DBKLAS |
| 15474 | * |
| 15475 | *===dbklas=============================================================* |
| 15476 | * |
| 15477 | SUBROUTINE DT_DBKLAS(I,J,K,I8,I10) |
| 15478 | |
| 15479 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 15480 | SAVE |
| 15481 | PARAMETER ( LINP = 10 , |
| 15482 | & LOUT = 6 , |
| 15483 | & LDAT = 9 ) |
| 15484 | |
| 15485 | * quark-content to particle index conversion (DTUNUC 1.x) |
| 15486 | COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21), |
| 15487 | & IA08(6,21),IA10(6,21) |
| 15488 | |
| 15489 | IF (I) 20,20,10 |
| 15490 | * baryons |
| 15491 | 10 CONTINUE |
| 15492 | CALL DT_INDEXD(J,K,IND) |
| 15493 | I8 = IB08(I,IND) |
| 15494 | I10 = IB10(I,IND) |
| 15495 | IF (I8.LE.0) I8 = I10 |
| 15496 | RETURN |
| 15497 | * antibaryons |
| 15498 | 20 CONTINUE |
| 15499 | II = IABS(I) |
| 15500 | JJ = IABS(J) |
| 15501 | KK = IABS(K) |
| 15502 | CALL DT_INDEXD(JJ,KK,IND) |
| 15503 | I8 = IA08(II,IND) |
| 15504 | I10 = IA10(II,IND) |
| 15505 | IF (I8.LE.0) I8 = I10 |
| 15506 | |
| 15507 | RETURN |
| 15508 | END |
| 15509 | |
| 15510 | *$ CREATE DT_INDEXD.FOR |
| 15511 | *COPY DT_INDEXD |
| 15512 | * |
| 15513 | *===indexd=============================================================* |
| 15514 | * |
| 15515 | SUBROUTINE DT_INDEXD(KA,KB,IND) |
| 15516 | |
| 15517 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 15518 | SAVE |
| 15519 | PARAMETER ( LINP = 10 , |
| 15520 | & LOUT = 6 , |
| 15521 | & LDAT = 9 ) |
| 15522 | |
| 15523 | KP = KA*KB |
| 15524 | KS = KA+KB |
| 15525 | IF (KP.EQ.1) IND=1 |
| 15526 | IF (KP.EQ.2) IND=2 |
| 15527 | IF (KP.EQ.3) IND=3 |
| 15528 | IF ((KP.EQ.4).AND.(KS.EQ.5)) IND=4 |
| 15529 | IF (KP.EQ.5) IND=5 |
| 15530 | IF ((KP.EQ.6).AND.(KS.EQ.7)) IND=6 |
| 15531 | IF ((KP.EQ.4).AND.(KS.EQ.4)) IND=7 |
| 15532 | IF ((KP.EQ.6).AND.(KS.EQ.5)) IND=8 |
| 15533 | IF (KP.EQ.8) IND=9 |
| 15534 | IF (KP.EQ.10) IND=10 |
| 15535 | IF ((KP.EQ.12).AND.(KS.EQ.8)) IND=11 |
| 15536 | IF (KP.EQ.9) IND=12 |
| 15537 | IF ((KP.EQ.12).AND.(KS.EQ.7)) IND=13 |
| 15538 | IF (KP.EQ.15) IND=14 |
| 15539 | IF (KP.EQ.18) IND=15 |
| 15540 | IF (KP.EQ.16) IND=16 |
| 15541 | IF (KP.EQ.20) IND=17 |
| 15542 | IF (KP.EQ.24) IND=18 |
| 15543 | IF (KP.EQ.25) IND=19 |
| 15544 | IF (KP.EQ.30) IND=20 |
| 15545 | IF (KP.EQ.36) IND=21 |
| 15546 | |
| 15547 | RETURN |
| 15548 | END |
| 15549 | |
| 15550 | *$ CREATE DT_DCHANT.FOR |
| 15551 | *COPY DT_DCHANT |
| 15552 | * |
| 15553 | *===dchant=============================================================* |
| 15554 | * |
| 15555 | SUBROUTINE DT_DCHANT |
| 15556 | |
| 15557 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 15558 | SAVE |
| 15559 | PARAMETER ( LINP = 10 , |
| 15560 | & LOUT = 6 , |
| 15561 | & LDAT = 9 ) |
| 15562 | PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0) |
| 15563 | |
| 15564 | * HADRIN: decay channel information |
| 15565 | PARAMETER (IDMAX9=602) |
| 15566 | CHARACTER*8 ZKNAME |
| 15567 | COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3) |
| 15568 | * particle properties (BAMJET index convention) |
| 15569 | CHARACTER*8 ANAME |
| 15570 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 15571 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 15572 | |
| 15573 | DIMENSION HWT(IDMAX9) |
| 15574 | |
| 15575 | * change of weights wt from absolut values into the sum of wt of a dec. |
| 15576 | DO 10 J=1,IDMAX9 |
| 15577 | HWT(J) = ZERO |
| 15578 | 10 CONTINUE |
| 15579 | C DO 999 KKK=1,210 |
| 15580 | C WRITE(LOUT,'(A8,F5.2,2E10.3,2I4,2I10)') |
| 15581 | C & ANAME(KKK),AAM(KKK),GA(KKK),TAU(KKK),IICH(KKK),IIBAR(KKK), |
| 15582 | C & K1(KKK),K2(KKK) |
| 15583 | C 999 CONTINUE |
| 15584 | C STOP |
| 15585 | DO 30 I=1,210 |
| 15586 | IK1 = K1(I) |
| 15587 | IK2 = K2(I) |
| 15588 | HV = ZERO |
| 15589 | DO 20 J=IK1,IK2 |
| 15590 | HV = HV+WT(J) |
| 15591 | HWT(J) = HV |
| 15592 | **sr 13.1.95 |
| 15593 | IF (HWT(J).GT.1.0001) WRITE(LOUT,1000) HWT(J),J,I,IK1 |
| 15594 | 1000 FORMAT(2X,15H ERROR IN HWT =,1F10.5,8H J,I,K1=,3I5) |
| 15595 | 20 CONTINUE |
| 15596 | 30 CONTINUE |
| 15597 | DO 40 J=1,IDMAX9 |
| 15598 | WT(J) = HWT(J) |
| 15599 | 40 CONTINUE |
| 15600 | |
| 15601 | RETURN |
| 15602 | END |
| 15603 | |
| 15604 | *$ CREATE DT_DDATAR.FOR |
| 15605 | *COPY DT_DDATAR |
| 15606 | * |
| 15607 | *===ddatar=============================================================* |
| 15608 | * |
| 15609 | SUBROUTINE DT_DDATAR |
| 15610 | |
| 15611 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 15612 | SAVE |
| 15613 | PARAMETER ( LINP = 10 , |
| 15614 | & LOUT = 6 , |
| 15615 | & LDAT = 9 ) |
| 15616 | PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0) |
| 15617 | |
| 15618 | * quark-content to particle index conversion (DTUNUC 1.x) |
| 15619 | COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21), |
| 15620 | & IA08(6,21),IA10(6,21) |
| 15621 | |
| 15622 | DIMENSION IV(36),IP(36),IB(126),IBB(126),IA(126),IAA(126) |
| 15623 | |
| 15624 | DATA IV/ 33, 34, 38,123, 0, 0, 32, 33, 39,124, |
| 15625 | & 0, 0, 36, 37, 96,127, 0, 0,126,125, |
| 15626 | & 128,129,14*0/ |
| 15627 | DATA IP/ 23, 14, 16,116, 0, 0, 13, 23, 25,117, |
| 15628 | & 0, 0, 15, 24, 31,120, 0, 0,119,118, |
| 15629 | & 121,122,14*0/ |
| 15630 | DATA IB/ 0, 1, 21,140, 0, 0, 8, 22,137, 0, |
| 15631 | & 0, 97,138, 0, 0,146, 0, 0, 0, 0, |
| 15632 | & 0, 1, 8, 22,137, 0, 0, 0, 20,142, |
| 15633 | & 0, 0, 98,139, 0, 0,147, 0, 0, 0, |
| 15634 | & 0, 0, 21, 22, 97,138, 0, 0, 20, 98, |
| 15635 | & 139, 0, 0, 0,145, 0, 0,148, 0, 0, |
| 15636 | & 0, 0, 0,140,137,138,146, 0, 0,142, |
| 15637 | & 139,147, 0, 0,145,148, 50*0/ |
| 15638 | DATA IBB/53, 54,104,161, 0, 0, 55,105,162, 0, |
| 15639 | & 0,107,164, 0, 0,167, 0, 0, 0, 0, |
| 15640 | & 0, 54, 55,105,162, 0, 0, 56,106,163, |
| 15641 | & 0, 0,108,165, 0, 0,168, 0, 0, 0, |
| 15642 | & 0, 0,104,105,107,164, 0, 0,106,108, |
| 15643 | & 165, 0, 0,109,166, 0, 0,169, 0, 0, |
| 15644 | & 0, 0, 0,161,162,164,167, 0, 0,163, |
| 15645 | & 165,168, 0, 0,166,169, 0, 0,170,47*0/ |
| 15646 | DATA IA/ 0, 2, 99,152, 0, 0, 9,100,149, 0, |
| 15647 | & 0,102,150, 0, 0,158, 0, 0, 0, 0, |
| 15648 | & 0, 2, 9,100,149, 0, 0, 0,101,154, |
| 15649 | & 0, 0,103,151, 0, 0,159, 0, 0, 0, |
| 15650 | & 0, 0, 99,100,102,150, 0, 0,101,103, |
| 15651 | & 151, 0, 0, 0,157, 0, 0,160, 0, 0, |
| 15652 | & 0, 0, 0,152,149,150,158, 0, 0,154, |
| 15653 | & 151,159, 0, 0,157,160, 50*0/ |
| 15654 | DATA IAA/67, 68,110,171, 0, 0, 69,111,172, 0, |
| 15655 | & 0,113,174, 0, 0,177, 0, 0, 0, 0, |
| 15656 | & 0, 68, 69,111,172, 0, 0, 70,112,173, |
| 15657 | & 0, 0,114,175, 0, 0,178, 0, 0, 0, |
| 15658 | & 0, 0,110,111,113,174, 0, 0,112,114, |
| 15659 | & 175, 0, 0,115,176, 0, 0,179, 0, 0, |
| 15660 | & 0, 0, 0,171,172,174,177, 0, 0,173, |
| 15661 | & 175,178, 0, 0,176,179, 0, 0,180,47*0/ |
| 15662 | |
| 15663 | L=0 |
| 15664 | DO 2 I=1,6 |
| 15665 | DO 1 J=1,6 |
| 15666 | L = L+1 |
| 15667 | IMPS(I,J) = IP(L) |
| 15668 | IMVE(I,J) = IV(L) |
| 15669 | 1 CONTINUE |
| 15670 | 2 CONTINUE |
| 15671 | L=0 |
| 15672 | DO 4 I=1,6 |
| 15673 | DO 3 J=1,21 |
| 15674 | L = L+1 |
| 15675 | IB08(I,J) = IB(L) |
| 15676 | IB10(I,J) = IBB(L) |
| 15677 | IA08(I,J) = IA(L) |
| 15678 | IA10(I,J) = IAA(L) |
| 15679 | 3 CONTINUE |
| 15680 | 4 CONTINUE |
| 15681 | C A1 = 0.88D0 |
| 15682 | C B1 = 3.0D0 |
| 15683 | C B2 = 3.0D0 |
| 15684 | C B3 = 8.0D0 |
| 15685 | C LT = 0 |
| 15686 | C LB = 0 |
| 15687 | C BET = 12.0D0 |
| 15688 | C AS = 0.25D0 |
| 15689 | C B8 = 0.33D0 |
| 15690 | C AME = 0.95D0 |
| 15691 | C DIQ = 0.375D0 |
| 15692 | C ISU = 4 |
| 15693 | |
| 15694 | RETURN |
| 15695 | END |
| 15696 | |
| 15697 | *$ CREATE DT_INITJS.FOR |
| 15698 | *COPY DT_INITJS |
| 15699 | * |
| 15700 | *===initjs=============================================================* |
| 15701 | * |
| 15702 | SUBROUTINE DT_INITJS(MODE) |
| 15703 | |
| 15704 | ************************************************************************ |
| 15705 | * Initialize JETSET paramters. * |
| 15706 | * MODE = 0 default settings * |
| 15707 | * = 1 PHOJET settings * |
| 15708 | * = 2 DTUNUC settings * |
| 15709 | * This version dated 16.02.96 is written by S. Roesler * |
| 15710 | * * |
| 15711 | * Last change 27.12.2006 by S. Roesler. * |
| 15712 | ************************************************************************ |
| 15713 | |
| 15714 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 15715 | SAVE |
| 15716 | PARAMETER ( LINP = 10 , |
| 15717 | & LOUT = 6 , |
| 15718 | & LDAT = 9 ) |
| 15719 | PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0) |
| 15720 | |
| 15721 | LOGICAL LFIRST,LFIRDT,LFIRPH |
| 15722 | |
| 15723 | COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) |
| 15724 | COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) |
| bd378884 |
15725 | COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) |
| 9aaba0d6 |
15726 | * flags for particle decays |
| 15727 | COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20), |
| 15728 | & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20), |
| 15729 | & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0 |
| 15730 | * flags for input different options |
| 15731 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 15732 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 15733 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 15734 | |
| 15735 | INTEGER PYCOMP |
| 15736 | |
| 15737 | DIMENSION IDXSTA(40) |
| 15738 | DATA IDXSTA |
| 15739 | * K0s pi0 lam alam sig+ asig+ sig- asig- tet0 atet0 |
| 15740 | & / 310, 111, 3122,-3122, 3222,-3222, 3112,-3112, 3322,-3322, |
| 15741 | * tet- atet- om- aom- D+ D- D0 aD0 Ds+ aDs+ |
| 15742 | & 3312,-3312, 3334,-3334, 411, -411, 421, -421, 431, -431, |
| 15743 | * etac lamc+alamc+sigc++ sigc+ sigc0asigc++asigc+asigc0 Ksic+ |
| 15744 | & 441, 4122,-4122, 4222, 4212, 4112,-4222,-4212,-4112, 4232, |
| 15745 | * Ksic0 aKsic+aKsic0 sig0 asig0 |
| 15746 | & 4132,-4232,-4132, 3212,-3212, 5*0/ |
| 15747 | |
| 15748 | DATA LFIRST,LFIRDT,LFIRPH /.TRUE.,.TRUE.,.TRUE./ |
| 15749 | |
| 15750 | IF (LFIRST) THEN |
| 15751 | * save default settings |
| 15752 | PDEF1 = PARJ(1) |
| 15753 | PDEF2 = PARJ(2) |
| 15754 | PDEF3 = PARJ(3) |
| 15755 | PDEF5 = PARJ(5) |
| 15756 | PDEF6 = PARJ(6) |
| 15757 | PDEF7 = PARJ(7) |
| 15758 | PDEF18 = PARJ(18) |
| 15759 | PDEF19 = PARJ(19) |
| 15760 | PDEF21 = PARJ(21) |
| 15761 | PDEF42 = PARJ(42) |
| 15762 | MDEF12 = MSTJ(12) |
| 15763 | * LUJETS / PYJETS array-dimensions |
| 15764 | MSTU(4) = 4000 |
| 15765 | * increase maximum number of JETSET-error prints |
| 15766 | MSTU(22) = 50000 |
| 15767 | * prevent particles decaying |
| 15768 | DO 1 I=1,35 |
| 15769 | IF (I.LT.34) THEN |
| 15770 | KC = PYCOMP(IDXSTA(I)) |
| 15771 | IF (KC.GT.0) THEN |
| 15772 | IF (I.EQ.2) THEN |
| 15773 | * pi0 decay |
| 15774 | C MDCY(KC,1) = 1 |
| 15775 | MDCY(KC,1) = 0 |
| 15776 | **cr mode |
| 15777 | C ELSEIF ((I.EQ.4).OR.(I.EQ. 6).OR. |
| 15778 | C & (I.EQ.8).OR.(I.EQ.10)) THEN |
| 15779 | C ELSEIF (I.EQ.4) THEN |
| 15780 | C MDCY(KC,1) = 1 |
| 15781 | ** |
| 15782 | ELSE |
| 1ddc441c |
15783 | C AM MDCY(KC,1) = 0 |
| 9aaba0d6 |
15784 | ENDIF |
| 15785 | ENDIF |
| 15786 | ELSEIF (((I.EQ.34).OR.(I.EQ.35)).AND.(ISIG0.EQ.0)) THEN |
| 15787 | KC = PYCOMP(IDXSTA(I)) |
| 15788 | IF (KC.GT.0) THEN |
| 1ddc441c |
15789 | C AM MDCY(KC,1) = 0 |
| 9aaba0d6 |
15790 | ENDIF |
| 15791 | ENDIF |
| 15792 | 1 CONTINUE |
| 15793 | * |
| 15794 | * |
| 15795 | * popcorn: |
| 15796 | IF (PDB.LE.ZERO) THEN |
| 15797 | * no popcorn-mechanism |
| 15798 | MSTJ(12) = 1 |
| 15799 | ELSE |
| 15800 | MSTJ(12) = 3 |
| 15801 | PARJ(5) = PDB |
| 15802 | ENDIF |
| 15803 | * set JETSET-parameter requested by input cards |
| 15804 | IF (NMSTU.GT.0) THEN |
| 15805 | DO 2 I=1,NMSTU |
| 15806 | MSTU(IMSTU(I)) = MSTUX(I) |
| 15807 | 2 CONTINUE |
| 15808 | ENDIF |
| 15809 | IF (NMSTJ.GT.0) THEN |
| 15810 | DO 3 I=1,NMSTJ |
| 15811 | MSTJ(IMSTJ(I)) = MSTJX(I) |
| 15812 | 3 CONTINUE |
| 15813 | ENDIF |
| 15814 | IF (NPARU.GT.0) THEN |
| 15815 | DO 4 I=1,NPARU |
| 15816 | PARU(IPARU(I)) = PARUX(I) |
| 15817 | 4 CONTINUE |
| 15818 | ENDIF |
| 15819 | LFIRST = .FALSE. |
| 15820 | ENDIF |
| 15821 | * |
| 15822 | * PARJ(1) suppression of qq-aqaq pair prod. compared to |
| 15823 | * q-aq pair prod. (default: 0.1) |
| 15824 | * PARJ(2) strangeness suppression (default: 0.3) |
| 15825 | * PARJ(3) extra suppression of strange diquarks (default: 0.4) |
| 15826 | * PARJ(6) extra suppression of sas-pair shared by B and |
| 15827 | * aB in BMaB (default: 0.5) |
| 15828 | * PARJ(7) extra suppression of strange meson M in BMaB |
| 15829 | * configuration (default: 0.5) |
| 15830 | * PARJ(18) spin 3/2 baryon suppression (default: 1.0) |
| 15831 | * PARJ(21) width sigma in Gaussian p_x, p_y transverse |
| 15832 | * momentum distrib. for prim. hadrons (default: 0.35) |
| 15833 | * PARJ(42) b-parameter for symmetric Lund-fragmentation |
| 15834 | * function (default: 0.9 GeV^-2) |
| 15835 | * |
| 15836 | * PHOJET settings |
| 15837 | IF (MODE.EQ.1) THEN |
| 15838 | * JETSET default |
| 15839 | C PARJ(1) = PDEF1 |
| 15840 | C PARJ(2) = PDEF2 |
| 15841 | C PARJ(3) = PDEF3 |
| 15842 | C PARJ(6) = PDEF6 |
| 15843 | C PARJ(7) = PDEF7 |
| 15844 | C PARJ(18) = PDEF18 |
| 15845 | C PARJ(21) = PDEF21 |
| 15846 | C PARJ(42) = PDEF42 |
| 15847 | **sr 18.11.98 parameter tuning |
| 15848 | C PARJ(1) = 0.092D0 |
| 15849 | C PARJ(2) = 0.25D0 |
| 15850 | C PARJ(3) = 0.45D0 |
| 15851 | C PARJ(19) = 0.3D0 |
| 15852 | C PARJ(21) = 0.45D0 |
| 15853 | C PARJ(42) = 1.0D0 |
| 15854 | **sr 28.04.99 parameter tuning (May 99 minor modifications) |
| 15855 | PARJ(1) = 0.085D0 |
| 15856 | PARJ(2) = 0.26D0 |
| 15857 | PARJ(3) = 0.8D0 |
| 15858 | PARJ(11) = 0.38D0 |
| 15859 | PARJ(18) = 0.3D0 |
| 15860 | PARJ(19) = 0.4D0 |
| 15861 | PARJ(21) = 0.36D0 |
| 15862 | PARJ(41) = 0.3D0 |
| 15863 | PARJ(42) = 0.86D0 |
| 15864 | IF (NPARJ.GT.0) THEN |
| 15865 | DO 10 I=1,NPARJ |
| 15866 | IF (IPARJ(I).GT.0) PARJ(IPARJ(I)) = PARJX(I) |
| 15867 | 10 CONTINUE |
| 15868 | ENDIF |
| 15869 | IF (LFIRPH) THEN |
| 15870 | WRITE(LOUT,'(1X,A)') |
| 15871 | & 'DT_INITJS: JETSET-parameter for PHOJET' |
| 15872 | CALL DT_JSPARA(0) |
| 15873 | LFIRPH = .FALSE. |
| 15874 | ENDIF |
| 15875 | * DTUNUC settings |
| 15876 | ELSEIF (MODE.EQ.2) THEN |
| 15877 | IF (IFRAG(2).EQ.1) THEN |
| 15878 | **sr parameters before 9.3.96 |
| 15879 | C PARJ(2) = 0.27D0 |
| 15880 | C PARJ(3) = 0.6D0 |
| 15881 | C PARJ(6) = 0.75D0 |
| 15882 | C PARJ(7) = 0.75D0 |
| 15883 | C PARJ(21) = 0.55D0 |
| 15884 | C PARJ(42) = 1.3D0 |
| 15885 | **sr 18.11.98 parameter tuning |
| 15886 | C PARJ(1) = 0.05D0 |
| 15887 | C PARJ(2) = 0.27D0 |
| 15888 | C PARJ(3) = 0.4D0 |
| 15889 | C PARJ(19) = 0.2D0 |
| 15890 | C PARJ(21) = 0.45D0 |
| 15891 | C PARJ(42) = 1.0D0 |
| 15892 | **sr 28.04.99 parameter tuning |
| 15893 | PARJ(1) = 0.11D0 |
| 15894 | PARJ(2) = 0.36D0 |
| 15895 | PARJ(3) = 0.8D0 |
| 15896 | PARJ(19) = 0.2D0 |
| 15897 | PARJ(21) = 0.3D0 |
| 15898 | PARJ(41) = 0.3D0 |
| 15899 | PARJ(42) = 0.58D0 |
| 15900 | IF (NPARJ.GT.0) THEN |
| 15901 | DO 20 I=1,NPARJ |
| 15902 | IF (IPARJ(I).LT.0) THEN |
| 15903 | IDX = ABS(IPARJ(I)) |
| 15904 | PARJ(IDX) = PARJX(I) |
| 15905 | ENDIF |
| 15906 | 20 CONTINUE |
| 15907 | ENDIF |
| 15908 | IF (LFIRDT) THEN |
| 15909 | WRITE(LOUT,'(1X,A)') |
| 15910 | & 'DT_INITJS: JETSET-parameter for DTUNUC' |
| 15911 | CALL DT_JSPARA(0) |
| 15912 | LFIRDT = .FALSE. |
| 15913 | ENDIF |
| 15914 | ELSEIF (IFRAG(2).EQ.2) THEN |
| 15915 | PARJ(1) = 0.11D0 |
| 15916 | PARJ(2) = 0.27D0 |
| 15917 | PARJ(3) = 0.3D0 |
| 15918 | PARJ(6) = 0.35D0 |
| 15919 | PARJ(7) = 0.45D0 |
| 15920 | PARJ(18) = 0.66D0 |
| 15921 | C PARJ(21) = 0.55D0 |
| 15922 | C PARJ(42) = 1.0D0 |
| 15923 | PARJ(21) = 0.60D0 |
| 15924 | PARJ(42) = 1.3D0 |
| 15925 | ELSE |
| 15926 | PARJ(1) = PDEF1 |
| 15927 | PARJ(2) = PDEF2 |
| 15928 | PARJ(3) = PDEF3 |
| 15929 | PARJ(6) = PDEF6 |
| 15930 | PARJ(7) = PDEF7 |
| 15931 | PARJ(18) = PDEF18 |
| 15932 | PARJ(21) = PDEF21 |
| 15933 | PARJ(42) = PDEF42 |
| 15934 | ENDIF |
| 15935 | ELSE |
| 15936 | PARJ(1) = PDEF1 |
| 15937 | PARJ(2) = PDEF2 |
| 15938 | PARJ(3) = PDEF3 |
| 15939 | PARJ(5) = PDEF5 |
| 15940 | PARJ(6) = PDEF6 |
| 15941 | PARJ(7) = PDEF7 |
| 15942 | PARJ(18) = PDEF18 |
| 15943 | PARJ(19) = PDEF19 |
| 15944 | PARJ(21) = PDEF21 |
| 15945 | PARJ(42) = PDEF42 |
| 15946 | MSTJ(12) = MDEF12 |
| 15947 | ENDIF |
| 15948 | |
| 15949 | RETURN |
| 15950 | END |
| 15951 | |
| 15952 | *$ CREATE DT_JSPARA.FOR |
| 15953 | *COPY DT_JSPARA |
| 15954 | * |
| 15955 | *===jspara=============================================================* |
| 15956 | * |
| 15957 | SUBROUTINE DT_JSPARA(MODE) |
| 15958 | |
| 15959 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 15960 | SAVE |
| 15961 | PARAMETER ( LINP = 10 , |
| 15962 | & LOUT = 6 , |
| 15963 | & LDAT = 9 ) |
| 15964 | PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1, |
| 15965 | & ONE=1.0D0,ZERO=0.0D0) |
| 15966 | |
| 15967 | LOGICAL LFIRST |
| 15968 | |
| 15969 | COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) |
| 15970 | |
| 15971 | DIMENSION ISTU(200),QARU(200),ISTJ(200),QARJ(200) |
| 15972 | |
| 15973 | DATA LFIRST /.TRUE./ |
| 15974 | |
| 15975 | * save the default JETSET-parameter on the first call |
| 15976 | IF (LFIRST) THEN |
| 15977 | DO 1 I=1,200 |
| 15978 | ISTU(I) = MSTU(I) |
| 15979 | QARU(I) = PARU(I) |
| 15980 | ISTJ(I) = MSTJ(I) |
| 15981 | QARJ(I) = PARJ(I) |
| 15982 | 1 CONTINUE |
| 15983 | LFIRST = .FALSE. |
| 15984 | ENDIF |
| 15985 | |
| 15986 | WRITE(LOUT,1000) |
| 15987 | 1000 FORMAT(1X,'DT_JSPARA: new value (default value)') |
| 15988 | |
| 15989 | * compare the default JETSET-parameter with the present values |
| 15990 | DO 2 I=1,200 |
| 15991 | IF ((MSTU(I).NE.ISTU(I)).AND.(I.NE.31)) THEN |
| 15992 | WRITE(LOUT,1002) 'MSTU(',I,MSTU(I),ISTU(I) |
| 15993 | C ISTU(I) = MSTU(I) |
| 15994 | ENDIF |
| 15995 | DIFF = ABS(PARU(I)-QARU(I)) |
| 15996 | IF ((DIFF.GE.1.0D-5).AND.(I.NE.21)) THEN |
| 15997 | WRITE(LOUT,1001) 'PARU(',I,PARU(I),QARU(I) |
| 15998 | C QARU(I) = PARU(I) |
| 15999 | ENDIF |
| 16000 | IF (MSTJ(I).NE.ISTJ(I)) THEN |
| 16001 | WRITE(LOUT,1002) 'MSTJ(',I,MSTJ(I),ISTJ(I) |
| 16002 | C ISTJ(I) = MSTJ(I) |
| 16003 | ENDIF |
| 16004 | DIFF = ABS(PARJ(I)-QARJ(I)) |
| 16005 | IF (DIFF.GE.1.0D-5) THEN |
| 16006 | WRITE(LOUT,1001) 'PARJ(',I,PARJ(I),QARJ(I) |
| 16007 | C QARJ(I) = PARJ(I) |
| 16008 | ENDIF |
| 16009 | 2 CONTINUE |
| 16010 | 1001 FORMAT(12X,A5,I3,'): ',F6.3,' (',F6.3,')') |
| 16011 | 1002 FORMAT(12X,A5,I3,'): ',I6,' (',I6,')') |
| 16012 | |
| 16013 | RETURN |
| 16014 | END |
| 16015 | |
| 16016 | *$ CREATE DT_FOZOCA.FOR |
| 16017 | *COPY DT_FOZOCA |
| 16018 | * |
| 16019 | *===fozoca=============================================================* |
| 16020 | * |
| 16021 | SUBROUTINE DT_FOZOCA(LFZC,IREJ) |
| 16022 | |
| 16023 | ************************************************************************ |
| 16024 | * This subroutine treats the complete FOrmation ZOne supressed intra- * |
| 16025 | * nuclear CAscade. * |
| 16026 | * LFZC = .true. cascade has been treated * |
| 16027 | * = .false. cascade skipped * |
| 16028 | * This is a completely revised version of the original FOZOKL. * |
| 16029 | * This version dated 18.11.95 is written by S. Roesler * |
| 16030 | ************************************************************************ |
| 16031 | |
| 16032 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 16033 | SAVE |
| 16034 | PARAMETER ( LINP = 10 , |
| 16035 | & LOUT = 6 , |
| 16036 | & LDAT = 9 ) |
| 16037 | PARAMETER (DLARGE=1.0D10,OHALF=0.5D0,ZERO=0.0D0) |
| 16038 | PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0) |
| 16039 | |
| 16040 | LOGICAL LSTART,LCAS,LFZC |
| 16041 | |
| 16042 | * event history |
| 16043 | PARAMETER (NMXHKK=200000) |
| 16044 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 16045 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 16046 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 16047 | * extended event history |
| 16048 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 16049 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 16050 | & IHIST(2,NMXHKK) |
| 16051 | * rejection counter |
| 16052 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, |
| 16053 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, |
| 16054 | & IREXCI(3),IRDIFF(2),IRINC |
| 16055 | * properties of interacting particles |
| 16056 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG |
| 16057 | * Glauber formalism: collision properties |
| 16058 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, |
| 16059 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC |
| 16060 | * flags for input different options |
| 16061 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 16062 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 16063 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 16064 | * final state after intranuclear cascade step |
| 16065 | COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC |
| 16066 | * parameter for intranuclear cascade |
| 16067 | LOGICAL LPAULI |
| 16068 | COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI |
| 16069 | |
| 16070 | DIMENSION NCWOUN(2) |
| 16071 | |
| 16072 | DATA LSTART /.TRUE./ |
| 16073 | |
| 16074 | LFZC = .TRUE. |
| 16075 | IREJ = 0 |
| 16076 | |
| 16077 | * skip cascade if hadron-hadron interaction or if supressed by user |
| 16078 | IF (((IP.EQ.1).AND.(IT.EQ.1)).OR.(KTAUGE.LT.1)) GOTO 9999 |
| 16079 | * skip cascade if not all possible chains systems are hadronized |
| 16080 | DO 1 I=1,8 |
| 16081 | IF (.NOT.LHADRO(I)) GOTO 9999 |
| 16082 | 1 CONTINUE |
| 16083 | |
| 16084 | IF (LSTART) THEN |
| 16085 | WRITE(LOUT,1000) KTAUGE,TAUFOR,INCMOD |
| 16086 | 1000 FORMAT(/,1X,'FOZOCA: intranuclear cascade treated for a ', |
| 16087 | & 'maximum of',I4,' generations',/,10X,'formation time ', |
| 16088 | & 'parameter:',F5.1,' fm/c',9X,'modus:',I2) |
| 16089 | IF (ITAUVE.EQ.1) WRITE(LOUT,1001) |
| 16090 | IF (ITAUVE.EQ.2) WRITE(LOUT,1002) |
| 16091 | 1001 FORMAT(10X,'p_t dependent formation zone',/) |
| 16092 | 1002 FORMAT(10X,'constant formation zone',/) |
| 16093 | LSTART = .FALSE. |
| 16094 | ENDIF |
| 16095 | |
| 16096 | * in order to avoid wasting of cpu-time the DTEVT1-indices of nucleons |
| 16097 | * which may interact with final state particles are stored in a seperate |
| 16098 | * array - here all proj./target nucleon-indices (just for simplicity) |
| 16099 | NOINC = 0 |
| 16100 | DO 9 I=1,NPOINT(1)-1 |
| 16101 | NOINC = NOINC+1 |
| 16102 | IDXINC(NOINC) = I |
| 16103 | 9 CONTINUE |
| 16104 | |
| 16105 | * initialize Pauli-principle treatment (find wounded nucleons) |
| 16106 | NWOUND(1) = 0 |
| 16107 | NWOUND(2) = 0 |
| 16108 | NCWOUN(1) = 0 |
| 16109 | NCWOUN(2) = 0 |
| 16110 | DO 2 J=1,NPOINT(1) |
| 16111 | DO 3 I=1,2 |
| 16112 | IF (ISTHKK(J).EQ.10+I) THEN |
| 16113 | NWOUND(I) = NWOUND(I)+1 |
| 16114 | EWOUND(I,NWOUND(I)) = PHKK(4,J) |
| 16115 | IF (IDHKK(J).EQ.2212) NCWOUN(I) = NCWOUN(I)+1 |
| 16116 | ENDIF |
| 16117 | 3 CONTINUE |
| 16118 | 2 CONTINUE |
| 16119 | |
| 16120 | * modify nuclear potential for wounded nucleons |
| 16121 | IPRCL = IP -NWOUND(1) |
| 16122 | IPZRCL = IPZ-NCWOUN(1) |
| 16123 | ITRCL = IT -NWOUND(2) |
| 16124 | ITZRCL = ITZ-NCWOUN(2) |
| 16125 | CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1) |
| 16126 | |
| 16127 | NSTART = NPOINT(4) |
| 16128 | NEND = NHKK |
| 16129 | |
| 16130 | 7 CONTINUE |
| 16131 | DO 8 I=NSTART,NEND |
| 16132 | |
| 16133 | IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDCH(I).LT.KTAUGE)) THEN |
| 16134 | * select nucleus the cascade starts first (proj. - 1, target - -1) |
| 16135 | NCAS = 1 |
| 16136 | * projectile/target with probab. 1/2 |
| 16137 | IF ((INCMOD.EQ.1).OR.(IDCH(I).GT.0)) THEN |
| 16138 | IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS |
| 16139 | * in the nucleus with highest mass |
| 16140 | ELSEIF (INCMOD.EQ.2) THEN |
| 16141 | IF (IP.GT.IT) THEN |
| 16142 | NCAS = -NCAS |
| 16143 | ELSEIF (IP.EQ.IT) THEN |
| 16144 | IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS |
| 16145 | ENDIF |
| 16146 | * the nucleus the cascade starts first is requested to be the one |
| 16147 | * moving in the direction of the secondary |
| 16148 | ELSEIF (INCMOD.EQ.3) THEN |
| 16149 | NCAS = INT(SIGN(1.0D0,PHKK(3,I))) |
| 16150 | ENDIF |
| 16151 | * check that the selected "nucleus" is not a hadron |
| 16152 | IF (((NCAS.EQ. 1).AND.(IP.LE.1)).OR. |
| 16153 | & ((NCAS.EQ.-1).AND.(IT.LE.1))) NCAS = -NCAS |
| 16154 | |
| 16155 | * treat intranuclear cascade in the nucleus selected first |
| 16156 | LCAS = .FALSE. |
| 16157 | CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1) |
| 16158 | IF (IREJ1.NE.0) GOTO 9998 |
| 16159 | * treat intranuclear cascade in the other nucleus if this isn't a had. |
| 16160 | NCAS = -NCAS |
| 16161 | IF (((NCAS.EQ. 1).AND.(IP.GT.1)).OR. |
| 16162 | & ((NCAS.EQ.-1).AND.(IT.GT.1))) THEN |
| 16163 | IF (LCAS) CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1) |
| 16164 | IF (IREJ1.NE.0) GOTO 9998 |
| 16165 | ENDIF |
| 16166 | |
| 16167 | ENDIF |
| 16168 | |
| 16169 | 8 CONTINUE |
| 16170 | NSTART = NEND+1 |
| 16171 | NEND = NHKK |
| 16172 | IF (NSTART.LE.NEND) GOTO 7 |
| 16173 | |
| 16174 | RETURN |
| 16175 | |
| 16176 | 9998 CONTINUE |
| 16177 | * reject this event |
| 16178 | IRINC = IRINC+1 |
| 16179 | IREJ = 1 |
| 16180 | |
| 16181 | 9999 CONTINUE |
| 16182 | * intranucl. cascade not treated because of interaction properties or |
| 16183 | * it is supressed by user or it was rejected or... |
| 16184 | LFZC = .FALSE. |
| 16185 | * reset flag characterizing direction of motion in n-n-cms |
| 16186 | **sr14-11-95 |
| 16187 | C DO 9990 I=NPOINT(5),NHKK |
| 16188 | C IF (ISTHKK(I).EQ.-1) ISTHKK(I)=1 |
| 16189 | C9990 CONTINUE |
| 16190 | |
| 16191 | RETURN |
| 16192 | END |
| 16193 | |
| 16194 | *$ CREATE DT_INUCAS.FOR |
| 16195 | *COPY DT_INUCAS |
| 16196 | * |
| 16197 | *===inucas=============================================================* |
| 16198 | * |
| 16199 | SUBROUTINE DT_INUCAS(IT,IP,IDXCAS,LCAS,NCAS,IREJ) |
| 16200 | |
| 16201 | ************************************************************************ |
| 16202 | * Formation zone supressed IntraNUclear CAScade for one final state * |
| 16203 | * particle. * |
| 16204 | * IT, IP mass numbers of target, projectile nuclei * |
| 16205 | * IDXCAS index of final state particle in DTEVT1 * |
| 16206 | * NCAS = 1 intranuclear cascade in projectile * |
| 16207 | * = -1 intranuclear cascade in target * |
| 16208 | * This version dated 18.11.95 is written by S. Roesler * |
| 16209 | ************************************************************************ |
| 16210 | |
| 16211 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 16212 | SAVE |
| 16213 | PARAMETER ( LINP = 10 , |
| 16214 | & LOUT = 6 , |
| 16215 | & LDAT = 9 ) |
| 16216 | |
| 16217 | PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10, |
| 16218 | & OHALF=0.5D0,ONE=1.0D0) |
| 16219 | PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0) |
| 16220 | PARAMETER (TWOPI=6.283185307179586454D+00) |
| 16221 | PARAMETER (PLOWH=0.01D0,PHIH=9.0D0) |
| 16222 | |
| 16223 | LOGICAL LABSOR,LCAS |
| 16224 | |
| 16225 | * event history |
| 16226 | PARAMETER (NMXHKK=200000) |
| 16227 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 16228 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 16229 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 16230 | * extended event history |
| 16231 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 16232 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 16233 | & IHIST(2,NMXHKK) |
| 16234 | * final state after inc step |
| 16235 | PARAMETER (MAXFSP=10) |
| 16236 | COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP |
| 16237 | * flags for input different options |
| 16238 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 16239 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 16240 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 16241 | * particle properties (BAMJET index convention) |
| 16242 | CHARACTER*8 ANAME |
| 16243 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 16244 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 16245 | * Glauber formalism: collision properties |
| 16246 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, |
| 16247 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC |
| 16248 | * nuclear potential |
| 16249 | LOGICAL LFERMI |
| 16250 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, |
| 16251 | & EBINDP(2),EBINDN(2),EPOT(2,210), |
| 16252 | & ETACOU(2),ICOUL,LFERMI |
| 16253 | * parameter for intranuclear cascade |
| 16254 | LOGICAL LPAULI |
| 16255 | COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI |
| 16256 | * final state after intranuclear cascade step |
| 16257 | COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC |
| 16258 | * nucleon-nucleon event-generator |
| 16259 | CHARACTER*8 CMODEL |
| 16260 | LOGICAL LPHOIN |
| 16261 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN |
| 16262 | * statistics: residual nuclei |
| 16263 | COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2), |
| 16264 | & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2), |
| 16265 | & NINCST(2,4),NINCEV(2), |
| 16266 | & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2), |
| 16267 | & NRESPB(2),NRESCH(2),NRESEV(4), |
| 16268 | & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240), |
| 16269 | & NEVAFI(2,2) |
| 16270 | |
| 16271 | DIMENSION PCAS(2,5),PTOCAS(2),COSCAS(2,3),VTXCAS(2,4),VTXCA1(2,4), |
| 16272 | & PCAS1(5),PNUC(5),BGTA(4), |
| 16273 | & BGCAS(2),GACAS(2),BECAS(2), |
| 16274 | & RNUC(2),BIMPC(2),VTXDST(3),IDXSPE(2),IDSPE(2),NWTMP(2) |
| 16275 | |
| 16276 | DATA PDIF /0.545D0/ |
| 16277 | |
| 16278 | IREJ = 0 |
| 16279 | |
| 16280 | * update counter |
| 16281 | IF (NINCEV(1).NE.NEVHKK) THEN |
| 16282 | NINCEV(1) = NEVHKK |
| 16283 | NINCEV(2) = NINCEV(2)+1 |
| 16284 | ENDIF |
| 16285 | |
| 16286 | * "BAMJET-index" of this hadron |
| 16287 | IDCAS = IDBAM(IDXCAS) |
| 16288 | IF (IDT_MCHAD(IDCAS).EQ.-1) RETURN |
| 16289 | |
| 16290 | * skip gammas, electrons, etc.. |
| 16291 | IF (AAM(IDCAS).LT.TINY2) RETURN |
| 16292 | |
| 16293 | * Lorentz-trsf. into projectile rest system |
| 16294 | IF (IP.GT.1) THEN |
| 16295 | CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS), |
| 16296 | & PHKK(4,IDXCAS),PCAS(1,1),PCAS(1,2),PCAS(1,3), |
| 16297 | & PCAS(1,4),IDCAS,-2) |
| 16298 | PTOCAS(1) = SQRT(PCAS(1,1)**2+PCAS(1,2)**2+PCAS(1,3)**2) |
| 16299 | PCAS(1,5) = (PCAS(1,4)-PTOCAS(1))*(PCAS(1,4)+PTOCAS(1)) |
| 16300 | IF (PCAS(1,5).GT.ZERO) THEN |
| 16301 | PCAS(1,5) = SQRT(PCAS(1,5)) |
| 16302 | ELSE |
| 16303 | PCAS(1,5) = AAM(IDCAS) |
| 16304 | ENDIF |
| 16305 | DO 20 K=1,3 |
| 16306 | COSCAS(1,K) = PCAS(1,K)/MAX(PTOCAS(1),TINY10) |
| 16307 | 20 CONTINUE |
| 16308 | * Lorentz-parameters |
| 16309 | * particle rest system --> projectile rest system |
| 16310 | BGCAS(1) = PTOCAS(1)/MAX(PCAS(1,5),TINY10) |
| 16311 | GACAS(1) = PCAS(1,4)/MAX(PCAS(1,5),TINY10) |
| 16312 | BECAS(1) = BGCAS(1)/GACAS(1) |
| 16313 | ELSE |
| 16314 | DO 21 K=1,5 |
| 16315 | PCAS(1,K) = ZERO |
| 16316 | IF (K.LE.3) COSCAS(1,K) = ZERO |
| 16317 | 21 CONTINUE |
| 16318 | PTOCAS(1) = ZERO |
| 16319 | BGCAS(1) = ZERO |
| 16320 | GACAS(1) = ZERO |
| 16321 | BECAS(1) = ZERO |
| 16322 | ENDIF |
| 16323 | * Lorentz-trsf. into target rest system |
| 16324 | IF (IT.GT.1) THEN |
| 16325 | * LEPTO: final state particles are already in target rest frame |
| 16326 | C IF (MCGENE.EQ.3) THEN |
| 16327 | C PCAS(2,1) = PHKK(1,IDXCAS) |
| 16328 | C PCAS(2,2) = PHKK(2,IDXCAS) |
| 16329 | C PCAS(2,3) = PHKK(3,IDXCAS) |
| 16330 | C PCAS(2,4) = PHKK(4,IDXCAS) |
| 16331 | C ELSE |
| 16332 | CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS), |
| 16333 | & PHKK(4,IDXCAS),PCAS(2,1),PCAS(2,2),PCAS(2,3), |
| 16334 | & PCAS(2,4),IDCAS,-3) |
| 16335 | C ENDIF |
| 16336 | PTOCAS(2) = SQRT(PCAS(2,1)**2+PCAS(2,2)**2+PCAS(2,3)**2) |
| 16337 | PCAS(2,5) = (PCAS(2,4)-PTOCAS(2))*(PCAS(2,4)+PTOCAS(2)) |
| 16338 | IF (PCAS(2,5).GT.ZERO) THEN |
| 16339 | PCAS(2,5) = SQRT(PCAS(2,5)) |
| 16340 | ELSE |
| 16341 | PCAS(2,5) = AAM(IDCAS) |
| 16342 | ENDIF |
| 16343 | DO 22 K=1,3 |
| 16344 | COSCAS(2,K) = PCAS(2,K)/MAX(PTOCAS(2),TINY10) |
| 16345 | 22 CONTINUE |
| 16346 | * Lorentz-parameters |
| 16347 | * particle rest system --> target rest system |
| 16348 | BGCAS(2) = PTOCAS(2)/MAX(PCAS(2,5),TINY10) |
| 16349 | GACAS(2) = PCAS(2,4)/MAX(PCAS(2,5),TINY10) |
| 16350 | BECAS(2) = BGCAS(2)/GACAS(2) |
| 16351 | ELSE |
| 16352 | DO 23 K=1,5 |
| 16353 | PCAS(2,K) = ZERO |
| 16354 | IF (K.LE.3) COSCAS(2,K) = ZERO |
| 16355 | 23 CONTINUE |
| 16356 | PTOCAS(2) = ZERO |
| 16357 | BGCAS(2) = ZERO |
| 16358 | GACAS(2) = ZERO |
| 16359 | BECAS(2) = ZERO |
| 16360 | ENDIF |
| 16361 | |
| 16362 | * radii of nuclei (mm) modified by the wall-depth of the Woods-Saxon- |
| 16363 | * potential (see CONUCL) |
| 16364 | RNUC(1) = (RPROJ+4.605D0*PDIF)*FM2MM |
| 16365 | RNUC(2) = (RTARG+4.605D0*PDIF)*FM2MM |
| 16366 | * impact parameter (the projectile moving along z) |
| 16367 | BIMPC(1) = ZERO |
| 16368 | BIMPC(2) = BIMPAC*FM2MM |
| 16369 | |
| 16370 | * get position of initial hadron in projectile/target rest-syst. |
| 16371 | DO 3 K=1,4 |
| 16372 | VTXCAS(1,K) = WHKK(K,IDXCAS) |
| 16373 | VTXCAS(2,K) = VHKK(K,IDXCAS) |
| 16374 | 3 CONTINUE |
| 16375 | |
| 16376 | ICAS = 1 |
| 16377 | I2 = 2 |
| 16378 | IF (NCAS.EQ.-1) THEN |
| 16379 | ICAS = 2 |
| 16380 | I2 = 1 |
| 16381 | ENDIF |
| 16382 | |
| 16383 | IF (PTOCAS(ICAS).LT.TINY10) THEN |
| 16384 | WRITE(LOUT,1000) PTOCAS |
| 16385 | 1000 FORMAT(1X,'INUCAS: warning! zero momentum of initial', |
| 16386 | & ' hadron ',/,20X,2E12.4) |
| 16387 | GOTO 9999 |
| 16388 | ENDIF |
| 16389 | |
| 16390 | * reset spectator flags |
| 16391 | NSPE = 0 |
| 16392 | IDXSPE(1) = 0 |
| 16393 | IDXSPE(2) = 0 |
| 16394 | IDSPE(1) = 0 |
| 16395 | IDSPE(2) = 0 |
| 16396 | |
| 16397 | * formation length (in fm) |
| 16398 | C IF (LCAS) THEN |
| 16399 | C DEL0 = ZERO |
| 16400 | C ELSE |
| 16401 | DEL0 = TAUFOR*BGCAS(ICAS) |
| 16402 | IF (ITAUVE.EQ.1) THEN |
| 16403 | AMT = PCAS(ICAS,1)**2+PCAS(ICAS,2)**2+PCAS(ICAS,5)**2 |
| 16404 | DEL0 = DEL0*PCAS(ICAS,5)**2/AMT |
| 16405 | ENDIF |
| 16406 | C ENDIF |
| 16407 | * sample from exp(-del/del0) |
| 16408 | DEL1 = -DEL0*LOG(MAX(DT_RNDM(DEL0),TINY10)) |
| 16409 | * save formation time |
| 16410 | TAUSA1 = DEL1/BGCAS(ICAS) |
| 16411 | REL1 = TAUSA1*BGCAS(I2) |
| 16412 | |
| 16413 | DEL = DEL1 |
| 16414 | TAUSAM = DEL/BGCAS(ICAS) |
| 16415 | REL = TAUSAM*BGCAS(I2) |
| 16416 | |
| 16417 | * special treatment for negative particles unable to escape |
| 16418 | * nuclear potential (implemented for ap, pi-, K- only) |
| 16419 | LABSOR = .FALSE. |
| 16420 | IF ((IICH(IDCAS).EQ.-1).AND.(IDCAS.LT.20)) THEN |
| 16421 | * threshold energy = nuclear potential + Coulomb potential |
| 16422 | * (nuclear potential for hadron-nucleus interactions only) |
| 16423 | ETHR = AAM(IDCAS)+EPOT(ICAS,IDCAS)+ETACOU(ICAS) |
| 16424 | IF (PCAS(ICAS,4).LT.ETHR) THEN |
| 16425 | DO 4 K=1,5 |
| 16426 | PCAS1(K) = PCAS(ICAS,K) |
| 16427 | 4 CONTINUE |
| 16428 | * "absorb" negative particle in nucleus |
| 16429 | CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,0,IREJ1) |
| 16430 | IF (IREJ1.NE.0) GOTO 9999 |
| 16431 | IF (NSPE.GE.1) LABSOR = .TRUE. |
| 16432 | ENDIF |
| 16433 | ENDIF |
| 16434 | |
| 16435 | * if the initial particle has not been absorbed proceed with |
| 16436 | * "normal" cascade |
| 16437 | IF (.NOT.LABSOR) THEN |
| 16438 | |
| 16439 | * calculate coordinates of hadron at the end of the formation zone |
| 16440 | * transport-time and -step in the rest system where this step is |
| 16441 | * treated |
| 16442 | DSTEP = DEL*FM2MM |
| 16443 | DTIME = DSTEP/BECAS(ICAS) |
| 16444 | RSTEP = REL*FM2MM |
| 16445 | IF ((IP.GT.1).AND.(IT.GT.1)) THEN |
| 16446 | RTIME = RSTEP/BECAS(I2) |
| 16447 | ELSE |
| 16448 | RTIME = ZERO |
| 16449 | ENDIF |
| 16450 | * save step whithout considering the overlapping region |
| 16451 | DSTEP1 = DEL1*FM2MM |
| 16452 | DTIME1 = DSTEP1/BECAS(ICAS) |
| 16453 | RSTEP1 = REL1*FM2MM |
| 16454 | IF ((IP.GT.1).AND.(IT.GT.1)) THEN |
| 16455 | RTIME1 = RSTEP1/BECAS(I2) |
| 16456 | ELSE |
| 16457 | RTIME1 = ZERO |
| 16458 | ENDIF |
| 16459 | * transport to the end of the formation zone in this system |
| 16460 | DO 5 K=1,3 |
| 16461 | VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+DSTEP1*COSCAS(ICAS,K) |
| 16462 | VTXCA1(I2,K) = VTXCAS(I2,K) +RSTEP1*COSCAS(I2,K) |
| 16463 | VTXCAS(ICAS,K) = VTXCAS(ICAS,K)+DSTEP*COSCAS(ICAS,K) |
| 16464 | VTXCAS(I2,K) = VTXCAS(I2,K) +RSTEP*COSCAS(I2,K) |
| 16465 | 5 CONTINUE |
| 16466 | VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME1 |
| 16467 | VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME1 |
| 16468 | VTXCAS(ICAS,4) = VTXCAS(ICAS,4)+DTIME |
| 16469 | VTXCAS(I2,4) = VTXCAS(I2,4) +RTIME |
| 16470 | |
| 16471 | IF ((IP.GT.1).AND.(IT.GT.1)) THEN |
| 16472 | XCAS = VTXCAS(ICAS,1) |
| 16473 | YCAS = VTXCAS(ICAS,2) |
| 16474 | XNCLTA = BIMPAC*FM2MM |
| 16475 | RNCLPR = (RPROJ+RNUCLE)*FM2MM |
| 16476 | RNCLTA = (RTARG+RNUCLE)*FM2MM |
| 16477 | C RNCLPR = (RPROJ+1.605D0*PDIF)*FM2MM |
| 16478 | C RNCLTA = (RTARG+1.605D0*PDIF)*FM2MM |
| 16479 | C RNCLPR = (RPROJ)*FM2MM |
| 16480 | C RNCLTA = (RTARG)*FM2MM |
| 16481 | RCASPR = SQRT( XCAS**2 +YCAS**2) |
| 16482 | RCASTA = SQRT((XCAS-XNCLTA)**2+YCAS**2) |
| 16483 | IF ((RCASPR.LT.RNCLPR).AND.(RCASTA.LT.RNCLTA)) THEN |
| 16484 | IF (IDCH(IDXCAS).EQ.0) NOBAM(IDXCAS) = 3 |
| 16485 | ENDIF |
| 16486 | ENDIF |
| 16487 | |
| 16488 | * check if particle is already outside of the corresp. nucleus |
| 16489 | RDIST = SQRT((VTXCAS(ICAS,1)-BIMPC(ICAS))**2+ |
| 16490 | & VTXCAS(ICAS,2)**2+VTXCAS(ICAS,3)**2) |
| 16491 | IF (RDIST.GE.RNUC(ICAS)) THEN |
| 16492 | * here: IDCH is the generation of the final state part. starting |
| 16493 | * with zero for hadronization products |
| 16494 | * flag particles of generation 0 being outside the nuclei after |
| 16495 | * formation time (to be used for excitation energy calculation) |
| 16496 | IF ((IDCH(IDXCAS).EQ.0).AND.(NOBAM(IDXCAS).LT.3)) |
| 16497 | & NOBAM(IDXCAS) = NOBAM(IDXCAS)+ICAS |
| 16498 | GOTO 9997 |
| 16499 | ENDIF |
| 16500 | DIST = DLARGE |
| 16501 | DISTP = DLARGE |
| 16502 | DISTN = DLARGE |
| 16503 | IDXP = 0 |
| 16504 | IDXN = 0 |
| 16505 | |
| 16506 | * already here: skip particles being outside HADRIN "energy-window" |
| 16507 | * to avoid wasting of time |
| 16508 | NINCHR(ICAS,1) = NINCHR(ICAS,1)+1 |
| 16509 | IF ((PTOCAS(ICAS).LE.PLOWH).OR.(PTOCAS(ICAS).GE.PHIH)) THEN |
| 16510 | NINCHR(ICAS,2) = NINCHR(ICAS,2)+1 |
| 16511 | C WRITE(LOUT,1002) IDXCAS,IDCAS,ICAS,PTOCAS(ICAS),NEVHKK |
| 16512 | C1002 FORMAT(1X,'INUCAS: warning! momentum of particle with ', |
| 16513 | C & 'index ',I5,' (id: ',I3,') ',I3,/,11X,'p_tot = ', |
| 16514 | C & E12.4,', above or below HADRIN-thresholds',I6) |
| 16515 | NSPE = 0 |
| 16516 | GOTO 9997 |
| 16517 | ENDIF |
| 16518 | |
| 16519 | DO 7 IDXHKK=1,NOINC |
| 16520 | I = IDXINC(IDXHKK) |
| 16521 | * scan DTEVT1 for unwounded or excited nucleons |
| 16522 | IF ((ISTHKK(I).EQ.12+ICAS).OR.(ISTHKK(I).EQ.14+ICAS)) THEN |
| 16523 | DO 8 K=1,3 |
| 16524 | IF (ICAS.EQ.1) THEN |
| 16525 | VTXDST(K) = WHKK(K,I)-VTXCAS(1,K) |
| 16526 | ELSEIF (ICAS.EQ.2) THEN |
| 16527 | VTXDST(K) = VHKK(K,I)-VTXCAS(2,K) |
| 16528 | ENDIF |
| 16529 | 8 CONTINUE |
| 16530 | POSNUC = VTXDST(1)*COSCAS(ICAS,1)+ |
| 16531 | & VTXDST(2)*COSCAS(ICAS,2)+ |
| 16532 | & VTXDST(3)*COSCAS(ICAS,3) |
| 16533 | * check if nucleon is situated in forward direction |
| 16534 | IF (POSNUC.GT.ZERO) THEN |
| 16535 | * distance between hadron and this nucleon |
| 16536 | DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+ |
| 16537 | & VTXDST(3)**2) |
| 16538 | * impact parameter |
| 16539 | BIMNU2 = DISTNU**2-POSNUC**2 |
| 16540 | IF (BIMNU2.LT.ZERO) THEN |
| 16541 | WRITE(LOUT,1001) DISTNU,POSNUC,BIMNU2 |
| 16542 | 1001 FORMAT(1X,'INUCAS: warning! inconsistent impact', |
| 16543 | & ' parameter ',/,20X,3E12.4) |
| 16544 | GOTO 7 |
| 16545 | ENDIF |
| 16546 | BIMNU = SQRT(BIMNU2) |
| 16547 | * maximum impact parameter to have interaction |
| 16548 | IDNUC = IDT_ICIHAD(IDHKK(I)) |
| 16549 | IDNUC1 = IDT_MCHAD(IDNUC) |
| 16550 | IDCAS1 = IDT_MCHAD(IDCAS) |
| 16551 | DO 19 K=1,5 |
| 16552 | PCAS1(K) = PCAS(ICAS,K) |
| 16553 | PNUC(K) = PHKK(K,I) |
| 16554 | 19 CONTINUE |
| 16555 | * Lorentz-parameter for trafo into rest-system of target |
| 16556 | DO 18 K=1,4 |
| 16557 | BGTA(K) = PNUC(K)/MAX(PNUC(5),TINY10) |
| 16558 | 18 CONTINUE |
| 16559 | * transformation of projectile into rest-system of target |
| 16560 | CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3), |
| 16561 | & PCAS1(1),PCAS1(2),PCAS1(3),PCAS1(4), |
| 16562 | & PPTOT,PX,PY,PZ,PE) |
| 16563 | ** |
| 16564 | C CALL DT_SIHNIN(IDCAS1,IDNUC1,PPTOT,SIGIN) |
| 16565 | C CALL DT_SIHNEL(IDCAS1,IDNUC1,PPTOT,SIGEL) |
| 16566 | DUMZER = ZERO |
| 16567 | CALL DT_XSHN(IDCAS1,IDNUC1,PPTOT,DUMZER,SIGTOT,SIGEL) |
| 16568 | CALL DT_SIHNAB(IDCAS1,IDNUC1,PPTOT,SIGAB) |
| 16569 | IF (((IDCAS1.EQ.13).OR.(IDCAS1.EQ.14)).AND. |
| 16570 | & (PPTOT.LT.0.15D0)) SIGEL = SIGEL/2.0D0 |
| 16571 | SIGIN = SIGTOT-SIGEL-SIGAB |
| 16572 | C SIGTOT = SIGIN+SIGEL+SIGAB |
| 16573 | ** |
| 16574 | BIMMAX = SQRT(SIGTOT/(5.0D0*TWOPI))*FM2MM |
| 16575 | * check if interaction is possible |
| 16576 | IF (BIMNU.LE.BIMMAX) THEN |
| 16577 | * get nucleon with smallest distance and kind of interaction |
| 16578 | * (elastic/inelastic) |
| 16579 | IF (DISTNU.LT.DIST) THEN |
| 16580 | DIST = DISTNU |
| 16581 | BINT = BIMNU |
| 16582 | IF (IDNUC.NE.IDSPE(1)) THEN |
| 16583 | IDSPE(2) = IDSPE(1) |
| 16584 | IDXSPE(2) = IDXSPE(1) |
| 16585 | IDSPE(1) = IDNUC |
| 16586 | ENDIF |
| 16587 | IDXSPE(1) = I |
| 16588 | NSPE = 1 |
| 16589 | **sr |
| 16590 | SELA = SIGEL |
| 16591 | SABS = SIGAB |
| 16592 | STOT = SIGTOT |
| 16593 | C IF ((IDCAS.EQ.2).OR.(IDCAS.EQ.9)) THEN |
| 16594 | C SELA = SIGEL |
| 16595 | C STOT = SIGIN+SIGEL |
| 16596 | C ELSE |
| 16597 | C SELA = SIGEL+0.75D0*SIGIN |
| 16598 | C STOT = 0.25D0*SIGIN+SELA |
| 16599 | C ENDIF |
| 16600 | ** |
| 16601 | ENDIF |
| 16602 | ENDIf |
| 16603 | ENDIF |
| 16604 | DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+ |
| 16605 | & VTXDST(3)**2) |
| 16606 | IDNUC = IDT_ICIHAD(IDHKK(I)) |
| 16607 | IF (IDNUC.EQ.1) THEN |
| 16608 | IF (DISTNU.LT.DISTP) THEN |
| 16609 | DISTP = DISTNU |
| 16610 | IDXP = I |
| 16611 | POSP = POSNUC |
| 16612 | ENDIF |
| 16613 | ELSEIF (IDNUC.EQ.8) THEN |
| 16614 | IF (DISTNU.LT.DISTN) THEN |
| 16615 | DISTN = DISTNU |
| 16616 | IDXN = I |
| 16617 | POSN = POSNUC |
| 16618 | ENDIF |
| 16619 | ENDIF |
| 16620 | ENDIF |
| 16621 | 7 CONTINUE |
| 16622 | |
| 16623 | * there is no nucleon for a secondary interaction |
| 16624 | IF (NSPE.EQ.0) GOTO 9997 |
| 16625 | |
| 16626 | C IF ((IDCAS.EQ.13).AND.((PCAS(ICAS,4)-PCAS(ICAS,5)).LT.0.1D0)) |
| 16627 | C & WRITE(LOUT,*) STOT,SELA,SABS,IDXSPE |
| 16628 | IF (IDXSPE(2).EQ.0) THEN |
| 16629 | IF ((IDSPE(1).EQ.1).AND.(IDXN.GT.0)) THEN |
| 16630 | C DO 80 K=1,3 |
| 16631 | C IF (ICAS.EQ.1) THEN |
| 16632 | C VTXDST(K) = WHKK(K,IDXN)-WHKK(K,IDXSPE(1)) |
| 16633 | C ELSEIF (ICAS.EQ.2) THEN |
| 16634 | C VTXDST(K) = VHKK(K,IDXN)-VHKK(K,IDXSPE(1)) |
| 16635 | C ENDIF |
| 16636 | C 80 CONTINUE |
| 16637 | C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+ |
| 16638 | C & VTXDST(3)**2) |
| 16639 | C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSN.GT.ZERO)) THEN |
| 16640 | IDXSPE(2) = IDXN |
| 16641 | IDSPE(2) = 8 |
| 16642 | C ELSE |
| 16643 | C STOT = STOT-SABS |
| 16644 | C SABS = ZERO |
| 16645 | C ENDIF |
| 16646 | ELSEIF ((IDSPE(1).EQ.8).AND.(IDXP.GT.0)) THEN |
| 16647 | C DO 81 K=1,3 |
| 16648 | C IF (ICAS.EQ.1) THEN |
| 16649 | C VTXDST(K) = WHKK(K,IDXP)-WHKK(K,IDXSPE(1)) |
| 16650 | C ELSEIF (ICAS.EQ.2) THEN |
| 16651 | C VTXDST(K) = VHKK(K,IDXP)-VHKK(K,IDXSPE(1)) |
| 16652 | C ENDIF |
| 16653 | C 81 CONTINUE |
| 16654 | C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+ |
| 16655 | C & VTXDST(3)**2) |
| 16656 | C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSP.GT.ZERO)) THEN |
| 16657 | IDXSPE(2) = IDXP |
| 16658 | IDSPE(2) = 1 |
| 16659 | C ELSE |
| 16660 | C STOT = STOT-SABS |
| 16661 | C SABS = ZERO |
| 16662 | C ENDIF |
| 16663 | ELSE |
| 16664 | STOT = STOT-SABS |
| 16665 | SABS = ZERO |
| 16666 | ENDIF |
| 16667 | ENDIF |
| 16668 | RR = DT_RNDM(DIST) |
| 16669 | IF (RR.LT.SELA/STOT) THEN |
| 16670 | IPROC = 2 |
| 16671 | ELSEIF ((RR.GE.SELA/STOT).AND.(RR.LT.(SELA+SABS)/STOT)) THEN |
| 16672 | IPROC = 3 |
| 16673 | ELSE |
| 16674 | IPROC = 1 |
| 16675 | ENDIF |
| 16676 | |
| 16677 | DO 9 K=1,5 |
| 16678 | PCAS1(K) = PCAS(ICAS,K) |
| 16679 | PNUC(K) = PHKK(K,IDXSPE(1)) |
| 16680 | 9 CONTINUE |
| 16681 | IF (IPROC.EQ.3) THEN |
| 16682 | * 2-nucleon absorption of pion |
| 16683 | NSPE = 2 |
| 16684 | CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,1,IREJ1) |
| 16685 | IF (IREJ1.NE.0) GOTO 9999 |
| 16686 | IF (NSPE.GE.1) LABSOR = .TRUE. |
| 16687 | ELSE |
| 16688 | * sample secondary interaction |
| 16689 | IDNUC = IDBAM(IDXSPE(1)) |
| 16690 | CALL DT_HADRIN(IDCAS,PCAS1,IDNUC,PNUC,IPROC,IREJ1) |
| 16691 | IF (IREJ1.EQ.1) GOTO 9999 |
| 16692 | IF (IREJ1.GT.1) GOTO 9998 |
| 16693 | ENDIF |
| 16694 | ENDIF |
| 16695 | |
| 16696 | * update arrays to include Pauli-principle |
| 16697 | DO 10 I=1,NSPE |
| 16698 | IF (NWOUND(ICAS).LE.299) THEN |
| 16699 | NWOUND(ICAS) = NWOUND(ICAS)+1 |
| 16700 | EWOUND(ICAS,NWOUND(ICAS)) = PHKK(4,IDXSPE(I)) |
| 16701 | ENDIF |
| 16702 | 10 CONTINUE |
| 16703 | |
| 16704 | * dump initial hadron for energy-momentum conservation check |
| 16705 | IF (LEMCCK) |
| 16706 | & CALL DT_EVTEMC(PCAS(ICAS,1),PCAS(ICAS,2),PCAS(ICAS,3), |
| 16707 | & PCAS(ICAS,4),1,IDUM,IDUM) |
| 16708 | |
| 16709 | * dump final state particles into DTEVT1 |
| 16710 | |
| 16711 | * check if Pauli-principle is fulfilled |
| 16712 | NPAULI = 0 |
| 16713 | NWTMP(1) = NWOUND(1) |
| 16714 | NWTMP(2) = NWOUND(2) |
| 16715 | DO 111 I=1,NFSP |
| 16716 | NPAULI = 0 |
| 16717 | J1 = 2 |
| 16718 | IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR. |
| 16719 | & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1 |
| 16720 | DO 117 J=1,J1 |
| 16721 | IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 117 |
| 16722 | IF (J.EQ.1) THEN |
| 16723 | IDX = ICAS |
| 16724 | PE = PFSP(4,I) |
| 16725 | ELSE |
| 16726 | IDX = I2 |
| 16727 | MODE = 1 |
| 16728 | IF (IDX.EQ.1) MODE = -1 |
| 16729 | CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,MODE) |
| 16730 | ENDIF |
| 16731 | * first check if cascade step is forbidden due to Pauli-principle |
| 16732 | * (in case of absorpion this step is forced) |
| 16733 | IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR. |
| 16734 | & (IDFSP(I).EQ.8))) THEN |
| 16735 | * get nuclear potential barrier |
| 16736 | POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I)) |
| 16737 | IF (IDFSP(I).EQ.1) THEN |
| 16738 | POTLOW = POT-EBINDP(IDX) |
| 16739 | ELSE |
| 16740 | POTLOW = POT-EBINDN(IDX) |
| 16741 | ENDIF |
| 16742 | * final state particle not able to escape nucleus |
| 16743 | IF (PE.LE.POTLOW) THEN |
| 16744 | * check if there are wounded nucleons |
| 16745 | IF ((NWOUND(IDX).GE.1).AND.(PE.GE. |
| 16746 | & EWOUND(IDX,NWOUND(IDX)))) THEN |
| 16747 | NPAULI = NPAULI+1 |
| 16748 | NWOUND(IDX) = NWOUND(IDX)-1 |
| 16749 | ELSE |
| 16750 | * interaction prohibited by Pauli-principle |
| 16751 | NWOUND(1) = NWTMP(1) |
| 16752 | NWOUND(2) = NWTMP(2) |
| 16753 | GOTO 9997 |
| 16754 | ENDIF |
| 16755 | ENDIF |
| 16756 | ENDIF |
| 16757 | 117 CONTINUE |
| 16758 | 111 CONTINUE |
| 16759 | |
| 16760 | NPAULI = 0 |
| 16761 | NWOUND(1) = NWTMP(1) |
| 16762 | NWOUND(2) = NWTMP(2) |
| 16763 | |
| 16764 | DO 11 I=1,NFSP |
| 16765 | |
| 16766 | IST = ISTHKK(IDXCAS) |
| 16767 | |
| 16768 | NPAULI = 0 |
| 16769 | J1 = 2 |
| 16770 | IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR. |
| 16771 | & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1 |
| 16772 | DO 17 J=1,J1 |
| 16773 | IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 17 |
| 16774 | IDX = ICAS |
| 16775 | PE = PFSP(4,I) |
| 16776 | IF (J.EQ.2) THEN |
| 16777 | IDX = I2 |
| 16778 | CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,NCAS) |
| 16779 | ENDIF |
| 16780 | * first check if cascade step is forbidden due to Pauli-principle |
| 16781 | * (in case of absorpion this step is forced) |
| 16782 | IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR. |
| 16783 | & (IDFSP(I).EQ.8))) THEN |
| 16784 | * get nuclear potential barrier |
| 16785 | POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I)) |
| 16786 | IF (IDFSP(I).EQ.1) THEN |
| 16787 | POTLOW = POT-EBINDP(IDX) |
| 16788 | ELSE |
| 16789 | POTLOW = POT-EBINDN(IDX) |
| 16790 | ENDIF |
| 16791 | * final state particle not able to escape nucleus |
| 16792 | IF (PE.LE.POTLOW) THEN |
| 16793 | * check if there are wounded nucleons |
| 16794 | IF ((NWOUND(IDX).GE.1).AND.(PE.GE. |
| 16795 | & EWOUND(IDX,NWOUND(IDX)))) THEN |
| 16796 | NWOUND(IDX) = NWOUND(IDX)-1 |
| 16797 | NPAULI = NPAULI+1 |
| 16798 | IST = 14+IDX |
| 16799 | ELSE |
| 16800 | * interaction prohibited by Pauli-principle |
| 16801 | NWOUND(1) = NWTMP(1) |
| 16802 | NWOUND(2) = NWTMP(2) |
| 16803 | GOTO 9997 |
| 16804 | ENDIF |
| 16805 | **sr |
| 16806 | c ELSEIF (PE.LE.POT) THEN |
| 16807 | cC ELSEIF ((PE.LE.POT).AND.(NWOUND(IDX).GE.1)) THEN |
| 16808 | cC NWOUND(IDX) = NWOUND(IDX)-1 |
| 16809 | c** |
| 16810 | c NPAULI = NPAULI+1 |
| 16811 | c IST = 14+IDX |
| 16812 | ENDIF |
| 16813 | ENDIF |
| 16814 | 17 CONTINUE |
| 16815 | |
| 16816 | * dump final state particles for energy-momentum conservation check |
| 16817 | IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),-PFSP(3,I), |
| 16818 | & -PFSP(4,I),2,IDUM,IDUM) |
| 16819 | |
| 16820 | PX = PFSP(1,I) |
| 16821 | PY = PFSP(2,I) |
| 16822 | PZ = PFSP(3,I) |
| 16823 | PE = PFSP(4,I) |
| 16824 | IF (ABS(IST).EQ.1) THEN |
| 16825 | * transform particles back into n-n cms |
| 16826 | * LEPTO: leave final state particles in target rest frame |
| 16827 | C IF (MCGENE.EQ.3) THEN |
| 16828 | C PFSP(1,I) = PX |
| 16829 | C PFSP(2,I) = PY |
| 16830 | C PFSP(3,I) = PZ |
| 16831 | C PFSP(4,I) = PE |
| 16832 | C ELSE |
| 16833 | IMODE = ICAS+1 |
| 16834 | CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I), |
| 16835 | & PFSP(4,I),IDFSP(I),IMODE) |
| 16836 | C ENDIF |
| 16837 | ELSEIF ((ICAS.EQ.2).AND.(IST.EQ.15)) THEN |
| 16838 | * target cascade but fsp got stuck in proj. --> transform it into |
| 16839 | * proj. rest system |
| 16840 | CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I), |
| 16841 | & PFSP(4,I),IDFSP(I),-1) |
| 16842 | ELSEIF ((ICAS.EQ.1).AND.(IST.EQ.16)) THEN |
| 16843 | * proj. cascade but fsp got stuck in target --> transform it into |
| 16844 | * target rest system |
| 16845 | CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I), |
| 16846 | & PFSP(4,I),IDFSP(I),1) |
| 16847 | ENDIF |
| 16848 | |
| 16849 | * dump final state particles into DTEVT1 |
| 16850 | IGEN = IDCH(IDXCAS)+1 |
| 16851 | ID = IDT_IPDGHA(IDFSP(I)) |
| 16852 | IXR = 0 |
| 16853 | IF (LABSOR) IXR = 99 |
| 16854 | CALL DT_EVTPUT(IST,ID,IDXCAS,IDXSPE(1),PFSP(1,I), |
| 16855 | & PFSP(2,I),PFSP(3,I),PFSP(4,I),0,IXR,IGEN) |
| 16856 | |
| 16857 | * update the counter for particles which got stuck inside the nucleus |
| 16858 | IF ((IST.EQ.15).OR.(IST.EQ.16)) THEN |
| 16859 | NOINC = NOINC+1 |
| 16860 | IDXINC(NOINC) = NHKK |
| 16861 | ENDIF |
| 16862 | IF (LABSOR) THEN |
| 16863 | * in case of absorption the spatial treatment is an approximate |
| 16864 | * solution anyway (the positions of the nucleons which "absorb" the |
| 16865 | * cascade particle are not taken into consideration) therefore the |
| 16866 | * particles are produced at the position of the cascade particle |
| 16867 | DO 12 K=1,4 |
| 16868 | WHKK(K,NHKK) = WHKK(K,IDXCAS) |
| 16869 | VHKK(K,NHKK) = VHKK(K,IDXCAS) |
| 16870 | 12 CONTINUE |
| 16871 | ELSE |
| 16872 | * DDISTL - distance the cascade particle moves to the intera. point |
| 16873 | * (the position where impact-parameter = distance to the interacting |
| 16874 | * nucleon), DIST - distance to the interacting nucleon at the time of |
| 16875 | * formation of the cascade particle, BINT - impact-parameter of this |
| 16876 | * cascade-interaction |
| 16877 | DDISTL = SQRT(DIST**2-BINT**2) |
| 16878 | DTIME = DDISTL/BECAS(ICAS) |
| 16879 | DTIMEL = DDISTL/BGCAS(ICAS) |
| 16880 | RDISTL = DTIMEL*BGCAS(I2) |
| 16881 | IF ((IP.GT.1).AND.(IT.GT.1)) THEN |
| 16882 | RTIME = RDISTL/BECAS(I2) |
| 16883 | ELSE |
| 16884 | RTIME = ZERO |
| 16885 | ENDIF |
| 16886 | * RDISTL, RTIME are this step and time in the rest system of the other |
| 16887 | * nucleus |
| 16888 | DO 13 K=1,3 |
| 16889 | VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+COSCAS(ICAS,K)*DDISTL |
| 16890 | VTXCA1(I2,K) = VTXCAS(I2,K) +COSCAS(I2,K) *RDISTL |
| 16891 | 13 CONTINUE |
| 16892 | VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME |
| 16893 | VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME |
| 16894 | * position of particle production is half the impact-parameter to |
| 16895 | * the interacting nucleon |
| 16896 | DO 14 K=1,3 |
| 16897 | WHKK(K,NHKK) = OHALF*(VTXCA1(1,K)+WHKK(K,IDXSPE(1))) |
| 16898 | VHKK(K,NHKK) = OHALF*(VTXCA1(2,K)+VHKK(K,IDXSPE(1))) |
| 16899 | 14 CONTINUE |
| 16900 | * time of production of secondary = time of interaction |
| 16901 | WHKK(4,NHKK) = VTXCA1(1,4) |
| 16902 | VHKK(4,NHKK) = VTXCA1(2,4) |
| 16903 | ENDIF |
| 16904 | |
| 16905 | 11 CONTINUE |
| 16906 | |
| 16907 | * modify status and position of cascade particle (the latter for |
| 16908 | * statistics reasons only) |
| 16909 | ISTHKK(IDXCAS) = 2 |
| 16910 | IF (LABSOR) ISTHKK(IDXCAS) = 19 |
| 16911 | IF (.NOT.LABSOR) THEN |
| 16912 | DO 15 K=1,4 |
| 16913 | WHKK(K,IDXCAS) = VTXCA1(1,K) |
| 16914 | VHKK(K,IDXCAS) = VTXCA1(2,K) |
| 16915 | 15 CONTINUE |
| 16916 | ENDIF |
| 16917 | |
| 16918 | DO 16 I=1,NSPE |
| 16919 | IS = IDXSPE(I) |
| 16920 | * dump interacting nucleons for energy-momentum conservation check |
| 16921 | IF (LEMCCK) |
| 16922 | & CALL DT_EVTEMC(PHKK(1,IS),PHKK(2,IS),PHKK(3,IS),PHKK(4,IS), |
| 16923 | & 2,IDUM,IDUM) |
| 16924 | * modify entry for interacting nucleons |
| 16925 | IF (ISTHKK(IS).EQ.12+ICAS) ISTHKK(IS)=16+ICAS |
| 16926 | IF (ISTHKK(IS).EQ.14+ICAS) ISTHKK(IS)=2 |
| 16927 | IF (I.GE.2) THEN |
| 16928 | JDAHKK(1,IS) = JDAHKK(1,IDXSPE(1)) |
| 16929 | JDAHKK(2,IS) = JDAHKK(2,IDXSPE(1)) |
| 16930 | ENDIF |
| 16931 | 16 CONTINUE |
| 16932 | |
| 16933 | * check energy-momentum conservation |
| 16934 | IF (LEMCCK) THEN |
| 16935 | CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,500,IREJ1) |
| 16936 | IF (IREJ1.NE.0) GOTO 9999 |
| 16937 | ENDIF |
| 16938 | |
| 16939 | * update counter |
| 16940 | IF (LABSOR) THEN |
| 16941 | NINCCO(ICAS,1) = NINCCO(ICAS,1)+1 |
| 16942 | ELSE |
| 16943 | IF (IPROC.EQ.1) NINCCO(ICAS,2) = NINCCO(ICAS,2)+1 |
| 16944 | IF (IPROC.EQ.2) NINCCO(ICAS,3) = NINCCO(ICAS,3)+1 |
| 16945 | ENDIF |
| 16946 | |
| 16947 | RETURN |
| 16948 | |
| 16949 | 9997 CONTINUE |
| 16950 | 9998 CONTINUE |
| 16951 | * transport-step but no cascade step due to configuration (i.e. there |
| 16952 | * is no nucleon for interaction etc.) |
| 16953 | IF (LCAS) THEN |
| 16954 | DO 100 K=1,4 |
| 16955 | C WHKK(K,IDXCAS) = VTXCAS(1,K) |
| 16956 | C VHKK(K,IDXCAS) = VTXCAS(2,K) |
| 16957 | WHKK(K,IDXCAS) = VTXCA1(1,K) |
| 16958 | VHKK(K,IDXCAS) = VTXCA1(2,K) |
| 16959 | 100 CONTINUE |
| 16960 | ENDIF |
| 16961 | |
| 16962 | C9998 CONTINUE |
| 16963 | * no cascade-step because of configuration |
| 16964 | * (i.e. hadron outside nucleus etc.) |
| 16965 | LCAS = .TRUE. |
| 16966 | RETURN |
| 16967 | |
| 16968 | 9999 CONTINUE |
| 16969 | * rejection |
| 16970 | IREJ = 1 |
| 16971 | RETURN |
| 16972 | END |
| 16973 | |
| 16974 | *$ CREATE DT_ABSORP.FOR |
| 16975 | *COPY DT_ABSORP |
| 16976 | * |
| 16977 | *===absorp=============================================================* |
| 16978 | * |
| 16979 | SUBROUTINE DT_ABSORP(IDCAS,PCAS,NCAS,NSPE,IDSPE,IDXSPE,MODE,IREJ) |
| 16980 | |
| 16981 | ************************************************************************ |
| 16982 | * Two-nucleon absorption of antiprotons, pi-, and K-. * |
| 16983 | * Antiproton absorption is handled by HADRIN. * |
| 16984 | * The following channels for meson-absorption are considered: * |
| 16985 | * pi- + p + p ---> n + p * |
| 16986 | * pi- + p + n ---> n + n * |
| 16987 | * K- + p + p ---> sigma+ + n / Lam + p / sigma0 + p * |
| 16988 | * K- + p + n ---> sigma- + n / Lam + n / sigma0 + n * |
| 16989 | * K- + p + p ---> sigma- + n * |
| 16990 | * IDCAS, PCAS identity, momentum of particle to be absorbed * |
| 16991 | * NCAS = 1 intranuclear cascade in projectile * |
| 16992 | * = -1 intranuclear cascade in target * |
| 16993 | * NSPE number of spectator nucleons involved * |
| 16994 | * IDXSPE(2) DTEVT1-indices of spectator nucleons involved * |
| 16995 | * Revised version of the original STOPIK written by HJM and J. Ranft. * |
| 16996 | * This version dated 24.02.95 is written by S. Roesler * |
| 16997 | ************************************************************************ |
| 16998 | |
| 16999 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 17000 | SAVE |
| 17001 | PARAMETER ( LINP = 10 , |
| 17002 | & LOUT = 6 , |
| 17003 | & LDAT = 9 ) |
| 17004 | PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,ONE=1.0D0, |
| 17005 | & ONETHI=0.3333D0,TWOTHI=0.6666D0) |
| 17006 | |
| 17007 | * event history |
| 17008 | PARAMETER (NMXHKK=200000) |
| 17009 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 17010 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 17011 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 17012 | * extended event history |
| 17013 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 17014 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 17015 | & IHIST(2,NMXHKK) |
| 17016 | * flags for input different options |
| 17017 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 17018 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 17019 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 17020 | * final state after inc step |
| 17021 | PARAMETER (MAXFSP=10) |
| 17022 | COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP |
| 17023 | * particle properties (BAMJET index convention) |
| 17024 | CHARACTER*8 ANAME |
| 17025 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 17026 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 17027 | |
| 17028 | DIMENSION PCAS(5),IDXSPE(2),IDSPE(2),PSPE(2,5),PSPE1(5), |
| 17029 | & PTOT3P(4),BG3P(4), |
| 17030 | & ECMF(2),PCMF(2),CODF(2),COFF(2),SIFF(2) |
| 17031 | |
| 17032 | IREJ = 0 |
| 17033 | NFSP = 0 |
| 17034 | |
| 17035 | * skip particles others than ap, pi-, K- for mode=0 |
| 17036 | IF ((MODE.EQ.0).AND. |
| 17037 | & (IDCAS.NE.2).AND.(IDCAS.NE.14).AND.(IDCAS.NE.16)) RETURN |
| 17038 | * skip particles others than pions for mode=1 |
| 17039 | * (2-nucleon absorption in intranuclear cascade) |
| 17040 | IF ((MODE.EQ.1).AND. |
| 17041 | & (IDCAS.NE.13).AND.(IDCAS.NE.14).AND.(IDCAS.NE.23)) RETURN |
| 17042 | |
| 17043 | NUCAS = NCAS |
| 17044 | IF (NUCAS.EQ.-1) NUCAS = 2 |
| 17045 | |
| 17046 | IF (MODE.EQ.0) THEN |
| 17047 | * scan spectator nucleons for nucleons being able to "absorb" |
| 17048 | NSPE = 0 |
| 17049 | IDXSPE(1) = 0 |
| 17050 | IDXSPE(2) = 0 |
| 17051 | DO 1 I=1,NHKK |
| 17052 | IF ((ISTHKK(I).EQ.12+NUCAS).OR.(ISTHKK(I).EQ.14+NUCAS)) THEN |
| 17053 | NSPE = NSPE+1 |
| 17054 | IDXSPE(NSPE) = I |
| 17055 | IDSPE(NSPE) = IDBAM(I) |
| 17056 | IF ((NSPE.EQ.1).AND.(IDCAS.EQ.2)) GOTO 2 |
| 17057 | IF (NSPE.EQ.2) THEN |
| 17058 | IF ((IDCAS.EQ.14).AND.(IDSPE(1).EQ.8).AND. |
| 17059 | & (IDSPE(2).EQ.8)) THEN |
| 17060 | * there is no pi-+n+n channel |
| 17061 | NSPE = 1 |
| 17062 | GOTO 1 |
| 17063 | ELSE |
| 17064 | GOTO 2 |
| 17065 | ENDIF |
| 17066 | ENDIF |
| 17067 | ENDIF |
| 17068 | 1 CONTINUE |
| 17069 | |
| 17070 | 2 CONTINUE |
| 17071 | ENDIF |
| 17072 | * transform excited projectile nucleons (status=15) into proj. rest s. |
| 17073 | DO 3 I=1,NSPE |
| 17074 | DO 4 K=1,5 |
| 17075 | PSPE(I,K) = PHKK(K,IDXSPE(I)) |
| 17076 | 4 CONTINUE |
| 17077 | 3 CONTINUE |
| 17078 | |
| 17079 | * antiproton absorption |
| 17080 | IF ((IDCAS.EQ.2).AND.(NSPE.GE.1)) THEN |
| 17081 | DO 5 K=1,5 |
| 17082 | PSPE1(K) = PSPE(1,K) |
| 17083 | 5 CONTINUE |
| 17084 | CALL DT_HADRIN(IDCAS,PCAS,IDSPE(1),PSPE1,1,IREJ1) |
| 17085 | IF (IREJ1.NE.0) GOTO 9999 |
| 17086 | |
| 17087 | * meson absorption |
| 17088 | ELSEIF (((IDCAS.EQ.13).OR.(IDCAS.EQ.14).OR.(IDCAS.EQ.23) |
| 17089 | & .OR.(IDCAS.EQ.16)).AND.(NSPE.GE.2)) THEN |
| 17090 | IF (IDCAS.EQ.14) THEN |
| 17091 | * pi- absorption |
| 17092 | IDFSP(1) = 8 |
| 17093 | IDFSP(2) = 8 |
| 17094 | IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) IDFSP(2) = 1 |
| 17095 | ELSEIF (IDCAS.EQ.13) THEN |
| 17096 | * pi+ absorption |
| 17097 | IDFSP(1) = 1 |
| 17098 | IDFSP(2) = 1 |
| 17099 | IF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) IDFSP(2) = 8 |
| 17100 | ELSEIF (IDCAS.EQ.23) THEN |
| 17101 | * pi0 absorption |
| 17102 | IDFSP(1) = IDSPE(1) |
| 17103 | IDFSP(2) = IDSPE(2) |
| 17104 | ELSEIF (IDCAS.EQ.16) THEN |
| 17105 | * K- absorption |
| 17106 | R = DT_RNDM(PCAS) |
| 17107 | IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) THEN |
| 17108 | IF (R.LT.ONETHI) THEN |
| 17109 | IDFSP(1) = 21 |
| 17110 | IDFSP(2) = 8 |
| 17111 | ELSEIF (R.LT.TWOTHI) THEN |
| 17112 | IDFSP(1) = 17 |
| 17113 | IDFSP(2) = 1 |
| 17114 | ELSE |
| 17115 | IDFSP(1) = 22 |
| 17116 | IDFSP(2) = 1 |
| 17117 | ENDIF |
| 17118 | ELSEIF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) THEN |
| 17119 | IDFSP(1) = 20 |
| 17120 | IDFSP(2) = 8 |
| 17121 | ELSE |
| 17122 | IF (R.LT.ONETHI) THEN |
| 17123 | IDFSP(1) = 20 |
| 17124 | IDFSP(2) = 1 |
| 17125 | ELSEIF (R.LT.TWOTHI) THEN |
| 17126 | IDFSP(1) = 17 |
| 17127 | IDFSP(2) = 8 |
| 17128 | ELSE |
| 17129 | IDFSP(1) = 22 |
| 17130 | IDFSP(2) = 8 |
| 17131 | ENDIF |
| 17132 | ENDIF |
| 17133 | ENDIF |
| 17134 | * dump initial particles for energy-momentum cons. check |
| 17135 | IF (LEMCCK) THEN |
| 17136 | CALL DT_EVTEMC(PCAS(1),PCAS(2),PCAS(3),PCAS(4),1,IDUM,IDUM) |
| 17137 | CALL DT_EVTEMC(PSPE(1,1),PSPE(1,2),PSPE(1,3),PSPE(1,4),2, |
| 17138 | & IDUM,IDUM) |
| 17139 | CALL DT_EVTEMC(PSPE(2,1),PSPE(2,2),PSPE(2,3),PSPE(2,4),2, |
| 17140 | & IDUM,IDUM) |
| 17141 | ENDIF |
| 17142 | * get Lorentz-parameter of 3 particle initial state |
| 17143 | DO 6 K=1,4 |
| 17144 | PTOT3P(K) = PCAS(K)+PSPE(1,K)+PSPE(2,K) |
| 17145 | 6 CONTINUE |
| 17146 | P3P = SQRT(PTOT3P(1)**2+PTOT3P(2)**2+PTOT3P(3)**2) |
| 17147 | AM3P = SQRT( (PTOT3P(4)-P3P)*(PTOT3P(4)+P3P) ) |
| 17148 | DO 7 K=1,4 |
| 17149 | BG3P(K) = PTOT3P(K)/MAX(AM3P,TINY10) |
| 17150 | 7 CONTINUE |
| 17151 | * 2-particle decay of the 3-particle compound system |
| 17152 | CALL DT_DTWOPD(AM3P,ECMF(1),ECMF(2),PCMF(1),PCMF(2), |
| 17153 | & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2), |
| 17154 | & AAM(IDFSP(1)),AAM(IDFSP(2))) |
| 17155 | DO 8 I=1,2 |
| 17156 | SDF = SQRT((ONE-CODF(I))*(ONE+CODF(I))) |
| 17157 | PX = PCMF(I)*COFF(I)*SDF |
| 17158 | PY = PCMF(I)*SIFF(I)*SDF |
| 17159 | PZ = PCMF(I)*CODF(I) |
| 17160 | CALL DT_DALTRA(BG3P(4),BG3P(1),BG3P(2),BG3P(3),PX,PY,PZ, |
| 17161 | & ECMF(I),PTOFSP,PFSP(1,I),PFSP(2,I),PFSP(3,I), |
| 17162 | & PFSP(4,I)) |
| 17163 | PFSP(5,I) = SQRT( (PFSP(4,I)-PTOFSP)*(PFSP(4,I)+PTOFSP) ) |
| 17164 | * check consistency of kinematics |
| 17165 | IF (ABS(AAM(IDFSP(I))-PFSP(5,I)).GT.TINY5) THEN |
| 17166 | WRITE(LOUT,1001) IDFSP(I),AAM(IDFSP(I)),PFSP(5,I) |
| 17167 | 1001 FORMAT(1X,'ABSORP: warning! inconsistent', |
| 17168 | & ' tree-particle kinematics',/,20X,'id: ',I3, |
| 17169 | & ' AAM = ',E10.4,' MFSP = ',E10.4) |
| 17170 | ENDIF |
| 17171 | * dump final state particles for energy-momentum cons. check |
| 17172 | IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I), |
| 17173 | & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM) |
| 17174 | 8 CONTINUE |
| 17175 | NFSP = 2 |
| 17176 | IF (LEMCCK) THEN |
| 17177 | CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,100,IREJ1) |
| 17178 | IF (IREJ1.NE.0) THEN |
| 17179 | WRITE(LOUT,*)'ABSORB: EMC ',AAM(IDFSP(1)),AAM(IDFSP(2)), |
| 17180 | & AM3P |
| 17181 | GOTO 9999 |
| 17182 | ENDIF |
| 17183 | ENDIF |
| 17184 | ELSE |
| 17185 | IF (IOULEV(3).GT.0) WRITE(LOUT,1000) IDCAS,NSPE |
| 17186 | 1000 FORMAT(1X,'ABSORP: warning! absorption for particle ',I3, |
| 17187 | & ' impossible',/,20X,'too few spectators (',I2,')') |
| 17188 | NSPE = 0 |
| 17189 | ENDIF |
| 17190 | |
| 17191 | RETURN |
| 17192 | |
| 17193 | 9999 CONTINUE |
| 17194 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in ABSORP' |
| 17195 | IREJ = 1 |
| 17196 | RETURN |
| 17197 | END |
| 17198 | |
| 17199 | *$ CREATE DT_HADRIN.FOR |
| 17200 | *COPY DT_HADRIN |
| 17201 | * |
| 17202 | *===hadrin=============================================================* |
| 17203 | * |
| 17204 | SUBROUTINE DT_HADRIN(IDPR,PPR,IDTA,PTA,MODE,IREJ) |
| 17205 | |
| 17206 | ************************************************************************ |
| 17207 | * Interface to the HADRIN-routines for inelastic and elastic * |
| 17208 | * scattering. * |
| 17209 | * IDPR,PPR(5) identity, momentum of projectile * |
| 17210 | * IDTA,PTA(5) identity, momentum of target * |
| 17211 | * MODE = 1 inelastic interaction * |
| 17212 | * = 2 elastic interaction * |
| 17213 | * Revised version of the original FHAD. * |
| 17214 | * This version dated 27.10.95 is written by S. Roesler * |
| 17215 | ************************************************************************ |
| 17216 | |
| 17217 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 17218 | SAVE |
| 17219 | PARAMETER ( LINP = 10 , |
| 17220 | & LOUT = 6 , |
| 17221 | & LDAT = 9 ) |
| 17222 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3, |
| 17223 | & TINY2=1.0D-2,TINY1=1.0D-1,ONE=1.0D0) |
| 17224 | |
| 17225 | LOGICAL LCORR,LMSSG |
| 17226 | |
| 17227 | * flags for input different options |
| 17228 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 17229 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 17230 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 17231 | * final state after inc step |
| 17232 | PARAMETER (MAXFSP=10) |
| 17233 | COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP |
| 17234 | * particle properties (BAMJET index convention) |
| 17235 | CHARACTER*8 ANAME |
| 17236 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 17237 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 17238 | * output-common for DHADRI/ELHAIN |
| 17239 | * final state from HADRIN interaction |
| 17240 | PARAMETER (MAXFIN=10) |
| 17241 | COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN), |
| 17242 | & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH |
| 17243 | |
| 17244 | DIMENSION PPR(5),PPR1(5),PTA(5),BGTA(4), |
| 17245 | & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4),IMCORR(2) |
| 17246 | |
| 17247 | DATA LMSSG /.TRUE./ |
| 17248 | |
| 17249 | IREJ = 0 |
| 17250 | NFSP = 0 |
| 17251 | KCORR = 0 |
| 17252 | IMCORR(1) = 0 |
| 17253 | IMCORR(2) = 0 |
| 17254 | LCORR = .FALSE. |
| 17255 | |
| 17256 | * dump initial particles for energy-momentum cons. check |
| 17257 | IF (LEMCCK) THEN |
| 17258 | CALL DT_EVTEMC(PPR(1),PPR(2),PPR(3),PPR(4),1,IDUM,IDUM) |
| 17259 | CALL DT_EVTEMC(PTA(1),PTA(2),PTA(3),PTA(4),2,IDUM,IDUM) |
| 17260 | ENDIF |
| 17261 | |
| 17262 | AMP2 = PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2 |
| 17263 | AMT2 = PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2 |
| 17264 | IF ((AMP2.LT.ZERO).OR.(AMT2.LT.ZERO).OR. |
| 17265 | & (ABS(AMP2-AAM(IDPR)**2).GT.TINY5).OR. |
| 17266 | & (ABS(AMT2-AAM(IDTA)**2).GT.TINY5)) THEN |
| 17267 | IF (LMSSG.AND.(IOULEV(3).GT.0)) |
| 17268 | & WRITE(LOUT,1000) AMP2,AAM(IDPR)**2,AMT2,AAM(IDTA)**2 |
| 17269 | 1000 FORMAT(1X,'HADRIN: warning! inconsistent projectile/target', |
| 17270 | & ' mass',/,20X,'AMP2 = ',E12.4,', AAM(IDPR)**2 = ', |
| 17271 | & E12.4,/,20X,'AMT2 = ',E12.4,', AAM(IDTA)**2 = ',E12.4) |
| 17272 | LMSSG = .FALSE. |
| 17273 | LCORR = .TRUE. |
| 17274 | ENDIF |
| 17275 | |
| 17276 | * convert initial state particles into particles which can be |
| 17277 | * handled by HADRIN |
| 17278 | IDHPR = IDPR |
| 17279 | IDHTA = IDTA |
| 17280 | IF ((IDHPR.LE.0).OR.(IDHPR.GE.111).OR.LCORR) THEN |
| 17281 | IF ((IDHPR.LE.0).OR.(IDHPR.GE.111)) IDHPR = 1 |
| 17282 | DO 1 K=1,4 |
| 17283 | P1IN(K) = PPR(K) |
| 17284 | P2IN(K) = PTA(K) |
| 17285 | 1 CONTINUE |
| 17286 | XM1 = AAM(IDHPR) |
| 17287 | XM2 = AAM(IDHTA) |
| 17288 | CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1) |
| 17289 | IF (IREJ1.GT.0) THEN |
| 17290 | WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.' |
| 17291 | GOTO 9999 |
| 17292 | ENDIF |
| 17293 | DO 2 K=1,4 |
| 17294 | PPR(K) = P1OUT(K) |
| 17295 | PTA(K) = P2OUT(K) |
| 17296 | 2 CONTINUE |
| 17297 | PPR(5) = SQRT(PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2) |
| 17298 | PTA(5) = SQRT(PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2) |
| 17299 | ENDIF |
| 17300 | |
| 17301 | * Lorentz-parameter for trafo into rest-system of target |
| 17302 | DO 3 K=1,4 |
| 17303 | BGTA(K) = PTA(K)/PTA(5) |
| 17304 | 3 CONTINUE |
| 17305 | * transformation of projectile into rest-system of target |
| 17306 | CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),PPR(1),PPR(2), |
| 17307 | & PPR(3),PPR(4),PPRTO1,PPR1(1),PPR1(2),PPR1(3), |
| 17308 | & PPR1(4)) |
| 17309 | |
| 17310 | * direction cosines of projectile in target rest system |
| 17311 | CX = PPR1(1)/PPRTO1 |
| 17312 | CY = PPR1(2)/PPRTO1 |
| 17313 | CZ = PPR1(3)/PPRTO1 |
| 17314 | |
| 17315 | * sample inelastic interaction |
| 17316 | IF (MODE.EQ.1) THEN |
| 17317 | CALL DT_DHADRI(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA) |
| 17318 | IF (IRH.EQ.1) GOTO 9998 |
| 17319 | * sample elastic interaction |
| 17320 | ELSEIF (MODE.EQ.2) THEN |
| 17321 | CALL DT_ELHAIN(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA,IREJ1) |
| 17322 | IF (IREJ1.NE.0) THEN |
| 17323 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in HADRIN' |
| 17324 | GOTO 9999 |
| 17325 | ENDIF |
| 17326 | IF (IRH.EQ.1) GOTO 9998 |
| 17327 | ELSE |
| 17328 | WRITE(LOUT,1001) MODE,INTHAD |
| 17329 | 1001 FORMAT(1X,'HADRIN: warning! inconsistent interaction mode', |
| 17330 | & I4,' (INTHAD =',I4,')') |
| 17331 | GOTO 9999 |
| 17332 | ENDIF |
| 17333 | |
| 17334 | * transform final state particles back into Lab. |
| 17335 | DO 4 I=1,IRH |
| 17336 | NFSP = NFSP+1 |
| 17337 | PX = CXRH(I)*PLRH(I) |
| 17338 | PY = CYRH(I)*PLRH(I) |
| 17339 | PZ = CZRH(I)*PLRH(I) |
| 17340 | CALL DT_DALTRA(BGTA(4),BGTA(1),BGTA(2),BGTA(3), |
| 17341 | & PX,PY,PZ,ELRH(I),PTOFSP,PFSP(1,NFSP), |
| 17342 | & PFSP(2,NFSP),PFSP(3,NFSP),PFSP(4,NFSP)) |
| 17343 | IDFSP(NFSP) = ITRH(I) |
| 17344 | AMFSP2 = PFSP(4,NFSP)**2-PFSP(1,NFSP)**2-PFSP(2,NFSP)**2- |
| 17345 | & PFSP(3,NFSP)**2 |
| 17346 | IF (AMFSP2.LT.-TINY3) THEN |
| 17347 | WRITE(LOUT,1002) IDFSP(NFSP),PFSP(1,NFSP),PFSP(2,NFSP), |
| 17348 | & PFSP(3,NFSP),PFSP(4,NFSP),AMFSP2 |
| 17349 | 1002 FORMAT(1X,'HADRIN: warning! final state particle (id = ', |
| 17350 | & I2,') with negative mass^2',/,1X,5E12.4) |
| 17351 | GOTO 9999 |
| 17352 | ELSE |
| 17353 | PFSP(5,NFSP) = SQRT(ABS(AMFSP2)) |
| 17354 | IF (ABS(PFSP(5,NFSP)-AAM(IDFSP(NFSP))).GT.TINY1) THEN |
| 17355 | WRITE(LOUT,1003) IDFSP(NFSP),AAM(IDFSP(NFSP)), |
| 17356 | & PFSP(5,NFSP) |
| 17357 | 1003 FORMAT(1X,'HADRIN: warning! final state particle', |
| 17358 | & ' (id = ',I2,') with inconsistent mass',/,1X, |
| 17359 | & 2E12.4) |
| 17360 | KCORR = KCORR+1 |
| 17361 | IF (KCORR.GT.2) GOTO 9999 |
| 17362 | IMCORR(KCORR) = NFSP |
| 17363 | ENDIF |
| 17364 | ENDIF |
| 17365 | * dump final state particles for energy-momentum cons. check |
| 17366 | IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I), |
| 17367 | & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM) |
| 17368 | 4 CONTINUE |
| 17369 | |
| 17370 | * transform momenta on mass shell in case of inconsistencies in |
| 17371 | * HADRIN |
| 17372 | IF (KCORR.GT.0) THEN |
| 17373 | IF (KCORR.EQ.2) THEN |
| 17374 | I1 = IMCORR(1) |
| 17375 | I2 = IMCORR(2) |
| 17376 | ELSE |
| 17377 | IF (IMCORR(1).EQ.1) THEN |
| 17378 | I1 = 1 |
| 17379 | I2 = 2 |
| 17380 | ELSE |
| 17381 | I1 = 1 |
| 17382 | I2 = IMCORR(1) |
| 17383 | ENDIF |
| 17384 | ENDIF |
| 17385 | IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I1),PFSP(2,I1), |
| 17386 | & PFSP(3,I1),PFSP(4,I1),2,IDUM,IDUM) |
| 17387 | IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I2),PFSP(2,I2), |
| 17388 | & PFSP(3,I2),PFSP(4,I2),2,IDUM,IDUM) |
| 17389 | DO 5 K=1,4 |
| 17390 | P1IN(K) = PFSP(K,I1) |
| 17391 | P2IN(K) = PFSP(K,I2) |
| 17392 | 5 CONTINUE |
| 17393 | XM1 = AAM(IDFSP(I1)) |
| 17394 | XM2 = AAM(IDFSP(I2)) |
| 17395 | CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1) |
| 17396 | IF (IREJ1.GT.0) THEN |
| 17397 | WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.' |
| 17398 | C GOTO 9999 |
| 17399 | ENDIF |
| 17400 | DO 6 K=1,4 |
| 17401 | PFSP(K,I1) = P1OUT(K) |
| 17402 | PFSP(K,I2) = P2OUT(K) |
| 17403 | 6 CONTINUE |
| 17404 | PFSP(5,I1) = SQRT(PFSP(4,I1)**2-PFSP(1,I1)**2 |
| 17405 | & -PFSP(2,I1)**2-PFSP(3,I1)**2) |
| 17406 | PFSP(5,I2) = SQRT(PFSP(4,I2)**2-PFSP(1,I2)**2 |
| 17407 | & -PFSP(2,I2)**2-PFSP(3,I2)**2) |
| 17408 | * dump final state particles for energy-momentum cons. check |
| 17409 | IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I1),-PFSP(2,I1), |
| 17410 | & -PFSP(3,I1),-PFSP(4,I1),2,IDUM,IDUM) |
| 17411 | IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I2),-PFSP(2,I2), |
| 17412 | & -PFSP(3,I2),-PFSP(4,I2),2,IDUM,IDUM) |
| 17413 | ENDIF |
| 17414 | |
| 17415 | * check energy-momentum conservation |
| 17416 | IF (LEMCCK) THEN |
| 17417 | CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,102,IREJ1) |
| 17418 | IF (IREJ1.NE.0) GOTO 9999 |
| 17419 | ENDIF |
| 17420 | |
| 17421 | RETURN |
| 17422 | |
| 17423 | 9998 CONTINUE |
| 17424 | IREJ = 2 |
| 17425 | RETURN |
| 17426 | |
| 17427 | 9999 CONTINUE |
| 17428 | IREJ = 1 |
| 17429 | RETURN |
| 17430 | END |
| 17431 | |
| 17432 | *$ CREATE DT_HADCOL.FOR |
| 17433 | *COPY DT_HADCOL |
| 17434 | * |
| 17435 | *===hadcol=============================================================* |
| 17436 | * |
| 17437 | SUBROUTINE DT_HADCOL(IDPROJ,PPN,IDXTAR,IREJ) |
| 17438 | |
| 17439 | ************************************************************************ |
| 17440 | * Interface to the HADRIN-routines for inelastic and elastic * |
| 17441 | * scattering. This subroutine samples hadron-nucleus interactions * |
| 17442 | * below DPM-threshold. * |
| 17443 | * IDPROJ BAMJET-index of projectile hadron * |
| 17444 | * PPN projectile momentum in target rest frame * |
| 17445 | * IDXTAR DTEVT1-index of target nucleon undergoing * |
| 17446 | * interaction with projectile hadron * |
| 17447 | * This subroutine replaces HADHAD. * |
| 17448 | * This version dated 5.5.95 is written by S. Roesler * |
| 17449 | ************************************************************************ |
| 17450 | |
| 17451 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 17452 | SAVE |
| 17453 | PARAMETER ( LINP = 10 , |
| 17454 | & LOUT = 6 , |
| 17455 | & LDAT = 9 ) |
| 17456 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0) |
| 17457 | |
| 17458 | LOGICAL LSTART |
| 17459 | |
| 17460 | * event history |
| 17461 | PARAMETER (NMXHKK=200000) |
| 17462 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 17463 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 17464 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 17465 | * extended event history |
| 17466 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 17467 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 17468 | & IHIST(2,NMXHKK) |
| 17469 | * nuclear potential |
| 17470 | LOGICAL LFERMI |
| 17471 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, |
| 17472 | & EBINDP(2),EBINDN(2),EPOT(2,210), |
| 17473 | & ETACOU(2),ICOUL,LFERMI |
| 17474 | * interface HADRIN-DPM |
| 17475 | COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA |
| 17476 | * parameter for intranuclear cascade |
| 17477 | LOGICAL LPAULI |
| 17478 | COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI |
| 17479 | * final state after inc step |
| 17480 | PARAMETER (MAXFSP=10) |
| 17481 | COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP |
| 17482 | * particle properties (BAMJET index convention) |
| 17483 | CHARACTER*8 ANAME |
| 17484 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 17485 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 17486 | |
| 17487 | DIMENSION PPROJ(5),PNUC(5) |
| 17488 | |
| 17489 | DATA LSTART /.TRUE./ |
| 17490 | |
| 17491 | IREJ = 0 |
| 17492 | |
| 17493 | NPOINT(1) = NHKK+1 |
| 17494 | |
| 17495 | TAUSAV = TAUFOR |
| 17496 | **sr 6/9/01 commented |
| 17497 | C TAUFOR = TAUFOR/2.0D0 |
| 17498 | ** |
| 17499 | IF (LSTART) THEN |
| 17500 | WRITE(LOUT,1000) |
| 17501 | 1000 FORMAT(/,1X,'HADCOL: Scattering handled by HADRIN') |
| 17502 | WRITE(LOUT,1001) TAUFOR |
| 17503 | 1001 FORMAT(/,1X,'HADCOL: Formation zone parameter set to ', |
| 17504 | & F5.1,' fm/c') |
| 17505 | LSTART = .FALSE. |
| 17506 | ENDIF |
| 17507 | |
| 17508 | IDNUC = IDBAM(IDXTAR) |
| 17509 | IDNUC1 = IDT_MCHAD(IDNUC) |
| 17510 | IDPRO1 = IDT_MCHAD(IDPROJ) |
| 17511 | |
| 17512 | IF ((INTHAD.EQ.1).OR.(INTHAD.EQ.2)) THEN |
| 17513 | IPROC = INTHAD |
| 17514 | ELSE |
| 17515 | ** |
| 17516 | C CALL DT_SIHNIN(IDPRO1,IDNUC1,PPN,SIGIN) |
| 17517 | C CALL DT_SIHNEL(IDPRO1,IDNUC1,PPN,SIGEL) |
| 17518 | DUMZER = ZERO |
| 17519 | CALL DT_XSHN(IDPRO1,IDNUC1,PPN,DUMZER,SIGTOT,SIGEL) |
| 17520 | SIGIN = SIGTOT-SIGEL |
| 17521 | C SIGTOT = SIGIN+SIGEL |
| 17522 | ** |
| 17523 | IPROC = 1 |
| 17524 | IF (DT_RNDM(SIGIN).LT.SIGEL/SIGTOT) IPROC = 2 |
| 17525 | ENDIF |
| 17526 | |
| 17527 | PPROJ(1) = ZERO |
| 17528 | PPROJ(2) = ZERO |
| 17529 | PPROJ(3) = PPN |
| 17530 | PPROJ(5) = AAM(IDPROJ) |
| 17531 | PPROJ(4) = SQRT(PPROJ(5)**2+PPROJ(3)**2) |
| 17532 | DO 1 K=1,5 |
| 17533 | PNUC(K) = PHKK(K,IDXTAR) |
| 17534 | 1 CONTINUE |
| 17535 | |
| 17536 | ILOOP = 0 |
| 17537 | 2 CONTINUE |
| 17538 | ILOOP = ILOOP+1 |
| 17539 | IF (ILOOP.GT.100) GOTO 9999 |
| 17540 | |
| 17541 | CALL DT_HADRIN(IDPROJ,PPROJ,IDNUC,PNUC,IPROC,IREJ1) |
| 17542 | IF (IREJ1.EQ.1) GOTO 9999 |
| 17543 | |
| 17544 | IF (IREJ1.GT.1) THEN |
| 17545 | * no interaction possible |
| 17546 | * require Pauli blocking |
| 17547 | IF ((IDPROJ.EQ.1).AND.(PPROJ(4).LE.PFERMP(2)+PPROJ(5))) GOTO 2 |
| 17548 | IF ((IDPROJ.EQ.8).AND.(PPROJ(4).LE.PFERMN(2)+PPROJ(5))) GOTO 2 |
| 17549 | IF ((IIBAR(IDPROJ).NE.1).AND. |
| 17550 | & (PPROJ(4).LE.EPOT(2,IDPROJ)+PPROJ(5))) GOTO 2 |
| 17551 | * store incoming particle as final state particle |
| 17552 | CALL DT_LTNUC(PPROJ(3),PPROJ(4),PCMS,ECMS,3) |
| 17553 | CALL DT_EVTPUT(1,IDPROJ,1,0,PPROJ(1),PPROJ(2),PCMS,ECMS,0,0,0) |
| 17554 | NPOINT(4) = NHKK |
| 17555 | ELSE |
| 17556 | * require Pauli blocking for final state nucleons |
| 17557 | DO 4 I=1,NFSP |
| 17558 | IF ((IDFSP(I).EQ.1).AND. |
| 17559 | & (PFSP(4,I).LE.PFERMP(2)+AAM(IDFSP(I)))) GOTO 2 |
| 17560 | IF ((IDFSP(I).EQ.8).AND. |
| 17561 | & (PFSP(4,I).LE.PFERMN(2)+AAM(IDFSP(I)))) GOTO 2 |
| 17562 | IF ((IIBAR(IDFSP(I)).NE.1).AND. |
| 17563 | & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I))))GOTO 2 |
| 17564 | 4 CONTINUE |
| 17565 | * store final state particles |
| 17566 | DO 5 I=1,NFSP |
| 17567 | IST = 1 |
| 17568 | IF ((IIBAR(IDFSP(I)).EQ.1).AND. |
| 17569 | & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I)))) IST = 16 |
| 17570 | IDHAD = IDT_IPDGHA(IDFSP(I)) |
| 17571 | CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PCMS,ECMS,3) |
| 17572 | CALL DT_EVTPUT(IST,IDHAD,1,IDXTAR,PFSP(1,I),PFSP(2,I), |
| 17573 | & PCMS,ECMS,0,0,0) |
| 17574 | IF (I.EQ.1) NPOINT(4) = NHKK |
| 17575 | VHKK(1,NHKK) = 0.5D0*(VHKK(1,1)+VHKK(1,IDXTAR)) |
| 17576 | VHKK(2,NHKK) = 0.5D0*(VHKK(2,1)+VHKK(2,IDXTAR)) |
| 17577 | VHKK(3,NHKK) = VHKK(3,IDXTAR) |
| 17578 | VHKK(4,NHKK) = VHKK(4,IDXTAR) |
| 17579 | WHKK(1,NHKK) = 0.5D0*(WHKK(1,1)+WHKK(1,IDXTAR)) |
| 17580 | WHKK(2,NHKK) = 0.5D0*(WHKK(2,1)+WHKK(2,IDXTAR)) |
| 17581 | WHKK(3,NHKK) = WHKK(3,1) |
| 17582 | WHKK(4,NHKK) = WHKK(4,1) |
| 17583 | 5 CONTINUE |
| 17584 | ENDIF |
| 17585 | TAUFOR = TAUSAV |
| 17586 | RETURN |
| 17587 | |
| 17588 | 9999 CONTINUE |
| 17589 | IREJ = 1 |
| 17590 | TAUFOR = TAUSAV |
| 17591 | RETURN |
| 17592 | END |
| 17593 | |
| 17594 | *$ CREATE DT_GETEMU.FOR |
| 17595 | *COPY DT_GETEMU |
| 17596 | * |
| 17597 | *===getemu=============================================================* |
| 17598 | * |
| 17599 | SUBROUTINE DT_GETEMU(IT,ITZ,KKMAT,MODE) |
| 17600 | |
| 17601 | ************************************************************************ |
| 17602 | * Sampling of emulsion component to be considered as target-nucleus. * |
| 17603 | * This version dated 6.5.95 is written by S. Roesler. * |
| 17604 | ************************************************************************ |
| 17605 | |
| 17606 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 17607 | SAVE |
| 17608 | PARAMETER ( LINP = 10 , |
| 17609 | & LOUT = 6 , |
| 17610 | & LDAT = 9 ) |
| 17611 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10) |
| 17612 | |
| 17613 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 17614 | * emulsion treatment |
| 17615 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), |
| 17616 | & NCOMPO,IEMUL |
| 17617 | * Glauber formalism: flags and parameters for statistics |
| 17618 | LOGICAL LPROD |
| 17619 | CHARACTER*8 CGLB |
| 17620 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD |
| 17621 | |
| 17622 | IF (MODE.EQ.0) THEN |
| 17623 | SUMFRA = ZERO |
| 17624 | RR = DT_RNDM(SUMFRA) |
| 17625 | IT = 0 |
| 17626 | ITZ = 0 |
| 17627 | DO 1 ICOMP=1,NCOMPO |
| 17628 | SUMFRA = SUMFRA+EMUFRA(ICOMP) |
| 17629 | IF (SUMFRA.GT.RR) THEN |
| 17630 | IT = IEMUMA(ICOMP) |
| 17631 | ITZ = IEMUCH(ICOMP) |
| 17632 | KKMAT = ICOMP |
| 17633 | GOTO 2 |
| 17634 | ENDIF |
| 17635 | 1 CONTINUE |
| 17636 | 2 CONTINUE |
| 17637 | IF (IT.LE.0) THEN |
| 17638 | WRITE(LOUT,'(1X,A,E12.3)') |
| 17639 | & 'Warning! norm. failure within emulsion fractions', |
| 17640 | & SUMFRA |
| 17641 | STOP |
| 17642 | ENDIF |
| 17643 | ELSEIF (MODE.EQ.1) THEN |
| 17644 | NDIFF = 10000 |
| 17645 | DO 3 I=1,NCOMPO |
| 17646 | IDIFF = ABS(IT-IEMUMA(I)) |
| 17647 | IF (IDIFF.LT.NDIFF) THEN |
| 17648 | KKMAT = I |
| 17649 | NDIFF = IDIFF |
| 17650 | ENDIF |
| 17651 | 3 CONTINUE |
| 17652 | ELSE |
| 17653 | STOP 'DT_GETEMU' |
| 17654 | ENDIF |
| 17655 | |
| 17656 | * bypass for variable projectile/target/energy runs: the correct |
| 17657 | * Glauber data will be always loaded on kkmat=1 |
| 17658 | IF (IOGLB.EQ.100) THEN |
| 17659 | KKMAT = 1 |
| 17660 | ENDIF |
| 17661 | |
| 17662 | RETURN |
| 17663 | END |
| 17664 | |
| 17665 | *$ CREATE DT_NCLPOT.FOR |
| 17666 | *COPY DT_NCLPOT |
| 17667 | * |
| 17668 | *===nclpot=============================================================* |
| 17669 | * |
| 17670 | SUBROUTINE DT_NCLPOT(IPZ,IP,ITZ,IT,AFERP,AFERT,MODE) |
| 17671 | |
| 17672 | ************************************************************************ |
| 17673 | * Calculation of Coulomb and nuclear potential for a given configurat. * |
| 17674 | * IPZ, IP charge/mass number of proj. * |
| 17675 | * ITZ, IT charge/mass number of targ. * |
| 17676 | * AFERP,AFERT factors modifying proj./target pot. * |
| 17677 | * if =0, FERMOD is used * |
| 17678 | * MODE = 0 calculation of binding energy * |
| 17679 | * = 1 pre-calculated binding energy is used * |
| 17680 | * This version dated 16.11.95 is written by S. Roesler. * |
| 17681 | * * |
| 17682 | * Last change 28.12.2006 by S. Roesler. * |
| 17683 | ************************************************************************ |
| 17684 | |
| 17685 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 17686 | SAVE |
| 17687 | PARAMETER ( LINP = 10 , |
| 17688 | & LOUT = 6 , |
| 17689 | & LDAT = 9 ) |
| 17690 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2, |
| 17691 | & TINY10=1.0D-10) |
| 17692 | |
| 17693 | LOGICAL LSTART |
| 17694 | |
| 17695 | * particle properties (BAMJET index convention) |
| 17696 | CHARACTER*8 ANAME |
| 17697 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 17698 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 17699 | * nuclear potential |
| 17700 | LOGICAL LFERMI |
| 17701 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, |
| 17702 | & EBINDP(2),EBINDN(2),EPOT(2,210), |
| 17703 | & ETACOU(2),ICOUL,LFERMI |
| 17704 | |
| 17705 | DIMENSION IDXPOT(14) |
| 17706 | * ap an lam alam sig- sig+ sig0 tet0 tet- asig- |
| 17707 | DATA IDXPOT / 2, 9, 17, 18, 20, 21, 22, 97, 98, 99, |
| 17708 | * asig0 asig+ atet0 atet+ |
| 17709 | & 100, 101, 102, 103/ |
| 17710 | |
| 17711 | DATA AN /0.4D0/ |
| 17712 | DATA LSTART /.TRUE./ |
| 17713 | |
| 17714 | IF (MODE.EQ.0) THEN |
| 17715 | EBINDP(1) = ZERO |
| 17716 | EBINDN(1) = ZERO |
| 17717 | EBINDP(2) = ZERO |
| 17718 | EBINDN(2) = ZERO |
| 17719 | ENDIF |
| 17720 | AIP = DBLE(IP) |
| 17721 | AIPZ = DBLE(IPZ) |
| 17722 | AIT = DBLE(IT) |
| 17723 | AITZ = DBLE(ITZ) |
| 17724 | |
| 17725 | FERMIP = AFERP |
| 17726 | IF (AFERP.LE.ZERO) FERMIP = FERMOD |
| 17727 | FERMIT = AFERT |
| 17728 | IF (AFERT.LE.ZERO) FERMIT = FERMOD |
| 17729 | |
| 17730 | * Fermi momenta and binding energy for projectile |
| 17731 | IF ((IP.GT.1).AND.LFERMI) THEN |
| 17732 | IF (MODE.EQ.0) THEN |
| 17733 | C EBINDP(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ-1) |
| 17734 | C EBINDN(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ) |
| 17735 | BIP = AIP -ONE |
| 17736 | BIPZ = AIPZ-ONE |
| 17737 | EBINDP(1) = 1.0D-3*(DT_ENERGY(ONE,ONE)+DT_ENERGY(BIP,BIPZ) |
| 17738 | & -DT_ENERGY(AIP,AIPZ)) |
| 17739 | IF (AIP.LE.AIPZ) THEN |
| 17740 | EBINDN(1) = EBINDP(1) |
| 17741 | WRITE(LOUT,*) ' DT_NCLPOT: AIP.LE.AIPZ (',AIP,AIPZ,')' |
| 17742 | ELSE |
| 17743 | EBINDN(1) = 1.0D-3*(DT_ENERGY(ONE,ZERO) |
| 17744 | & +DT_ENERGY(BIP,AIPZ)-DT_ENERGY(AIP,AIPZ)) |
| 17745 | ENDIF |
| 17746 | ENDIF |
| 17747 | PFERMP(1) = FERMIP*AN*(AIPZ/AIP)**0.333333D0 |
| 17748 | PFERMN(1) = FERMIP*AN*((AIP-AIPZ)/AIP)**0.33333D0 |
| 17749 | ELSE |
| 17750 | PFERMP(1) = ZERO |
| 17751 | PFERMN(1) = ZERO |
| 17752 | ENDIF |
| 17753 | * effective nuclear potential for projectile |
| 17754 | C EPOT(1,1) = PFERMP(1)**2/(2.0D0*AAM(1)) + EBINDP(1) |
| 17755 | C EPOT(1,8) = PFERMN(1)**2/(2.0D0*AAM(8)) + EBINDN(1) |
| 17756 | EPOT(1,1) = SQRT(PFERMP(1)**2+AAM(1)**2) -AAM(1) + EBINDP(1) |
| 17757 | EPOT(1,8) = SQRT(PFERMN(1)**2+AAM(8)**2) -AAM(8) + EBINDN(1) |
| 17758 | |
| 17759 | * Fermi momenta and binding energy for target |
| 17760 | IF ((IT.GT.1).AND.LFERMI) THEN |
| 17761 | IF (MODE.EQ.0) THEN |
| 17762 | C EBINDP(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ-1) |
| 17763 | C EBINDN(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ) |
| 17764 | BIT = AIT -ONE |
| 17765 | BITZ = AITZ-ONE |
| 17766 | |
| 17767 | EBINDP(2) = 1.0D-3*(DT_ENERGY(ONE,ONE)+DT_ENERGY(BIT,BITZ) |
| 17768 | & -DT_ENERGY(AIT,AITZ)) |
| 17769 | |
| 17770 | IF (AIT.LE.AITZ) THEN |
| 17771 | EBINDN(2) = EBINDP(2) |
| 17772 | WRITE(LOUT,*) ' DT_NCLPOT: AIT.LE.AIPT (',AIT,AIPT,')' |
| 17773 | ELSE |
| 17774 | |
| 17775 | EBINDN(2) = 1.0D-3*(DT_ENERGY(ONE,ZERO) |
| 17776 | & +DT_ENERGY(BIT,AITZ)-DT_ENERGY(AIT,AITZ)) |
| 17777 | |
| 17778 | ENDIF |
| 17779 | ENDIF |
| 17780 | PFERMP(2) = FERMIT*AN*(AITZ/AIT)**0.333333D0 |
| 17781 | PFERMN(2) = FERMIT*AN*((AIT-AITZ)/AIT)**0.33333D0 |
| 17782 | ELSE |
| 17783 | PFERMP(2) = ZERO |
| 17784 | PFERMN(2) = ZERO |
| 17785 | ENDIF |
| 17786 | * effective nuclear potential for target |
| 17787 | C EPOT(2,1) = PFERMP(2)**2/(2.0D0*AAM(1)) + EBINDP(2) |
| 17788 | C EPOT(2,8) = PFERMN(2)**2/(2.0D0*AAM(8)) + EBINDN(2) |
| 17789 | EPOT(2,1) = SQRT(PFERMP(2)**2+AAM(1)**2) -AAM(1) + EBINDP(2) |
| 17790 | EPOT(2,8) = SQRT(PFERMN(2)**2+AAM(8)**2) -AAM(8) + EBINDN(2) |
| 17791 | |
| 17792 | DO 2 I=1,14 |
| 17793 | EPOT(1,IDXPOT(I)) = EPOT(1,8) |
| 17794 | EPOT(2,IDXPOT(I)) = EPOT(2,8) |
| 17795 | 2 CONTINUE |
| 17796 | |
| 17797 | * Coulomb energy |
| 17798 | ETACOU(1) = ZERO |
| 17799 | ETACOU(2) = ZERO |
| 17800 | IF (ICOUL.EQ.1) THEN |
| 17801 | IF (IP.GT.1) |
| 17802 | & ETACOU(1) = 0.001116D0*AIPZ/(1.0D0+AIP**0.333D0) |
| 17803 | IF (IT.GT.1) |
| 17804 | & ETACOU(2) = 0.001116D0*AITZ/(1.0D0+AIT**0.333D0) |
| 17805 | ENDIF |
| 17806 | |
| 17807 | IF (LSTART) THEN |
| 17808 | WRITE(LOUT,1000) IP,IPZ,IT,ITZ,EBINDP,EBINDN, |
| 17809 | & EPOT(1,1)-EBINDP(1),EPOT(2,1)-EBINDP(2), |
| 17810 | & EPOT(1,8)-EBINDN(1),EPOT(2,8)-EBINDN(2), |
| 17811 | & FERMOD,ETACOU |
| 17812 | 1000 FORMAT(/,/,1X,'NCLPOT: quantities for inclusion of nuclear' |
| 17813 | & ,' effects',/,12X,'---------------------------', |
| 17814 | & '----------------',/,/,38X,'projectile', |
| 17815 | & ' target',/,/,1X,'Mass number / charge', |
| 17816 | & 17X,I3,' /',I3,6X,I3,' /',I3,/,1X,'Binding energy -', |
| 17817 | & ' proton (GeV) ',2E14.4,/,17X,'- neutron (GeV)' |
| 17818 | & ,1X,2E14.4,/,1X,'Fermi-potential - proton (GeV)', |
| 17819 | & 1X,2E14.4,/,17X,'- neutron (GeV) ',2E14.4,/,/, |
| 17820 | & 1X,'Scale factor for Fermi-momentum ',F4.2,/, |
| 17821 | & /,1X,'Coulomb-energy ',2(E14.4,' GeV '),/,/) |
| 17822 | LSTART = .FALSE. |
| 17823 | ENDIF |
| 17824 | |
| 17825 | RETURN |
| 17826 | END |
| 17827 | |
| 17828 | *$ CREATE DT_RESNCL.FOR |
| 17829 | *COPY DT_RESNCL |
| 17830 | * |
| 17831 | *===resncl=============================================================* |
| 17832 | * |
| 17833 | SUBROUTINE DT_RESNCL(EPN,NLOOP,MODE) |
| 17834 | |
| 17835 | ************************************************************************ |
| 17836 | * Treatment of residual nuclei and nuclear effects. * |
| 17837 | * MODE = 1 initializations * |
| 17838 | * = 2 treatment of final state * |
| 17839 | * This version dated 16.11.95 is written by S. Roesler. * |
| 17840 | * * |
| 17841 | * Last change 05.01.2007 by S. Roesler. * |
| 17842 | ************************************************************************ |
| 17843 | |
| 17844 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 17845 | SAVE |
| 17846 | PARAMETER ( LINP = 10 , |
| 17847 | & LOUT = 6 , |
| 17848 | & LDAT = 9 ) |
| 17849 | PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,THREE=3.D0,TINY3=1.0D-3, |
| 17850 | & TINY2=1.0D-2,TINY1=1.0D-1,TINY4=1.0D-4,TINY10=1.0D-10, |
| 17851 | & ONETHI=ONE/THREE) |
| 17852 | PARAMETER (AMUAMU = 0.93149432D0, |
| 17853 | & FM2MM = 1.0D-12, |
| 17854 | & RNUCLE = 1.12D0) |
| 17855 | PARAMETER ( EMVGEV = 1.0 D-03 ) |
| 17856 | PARAMETER ( AMUGEV = 0.93149432 D+00 ) |
| 17857 | PARAMETER ( AMPRTN = 0.93827231 D+00 ) |
| 17858 | PARAMETER ( AMNTRN = 0.93956563 D+00 ) |
| 17859 | PARAMETER ( AMELCT = 0.51099906 D-03 ) |
| 17860 | PARAMETER ( HLFHLF = 0.5D+00 ) |
| 17861 | PARAMETER ( FERTHO = 14.33 D-09 ) |
| 17862 | PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 ) |
| 17863 | PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 ) |
| 17864 | PARAMETER ( AMUC12 = AMUGEV - AMUNMU ) |
| 17865 | |
| 17866 | * event history |
| 17867 | PARAMETER (NMXHKK=200000) |
| 17868 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 17869 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 17870 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 17871 | * extended event history |
| 17872 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 17873 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 17874 | & IHIST(2,NMXHKK) |
| 17875 | * particle properties (BAMJET index convention) |
| 17876 | CHARACTER*8 ANAME |
| 17877 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 17878 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 17879 | * flags for input different options |
| 17880 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 17881 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 17882 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 17883 | * nuclear potential |
| 17884 | LOGICAL LFERMI |
| 17885 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, |
| 17886 | & EBINDP(2),EBINDN(2),EPOT(2,210), |
| 17887 | & ETACOU(2),ICOUL,LFERMI |
| 17888 | * properties of interacting particles |
| 17889 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG |
| 17890 | * properties of photon/lepton projectiles |
| 17891 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC |
| 17892 | * Lorentz-parameters of the current interaction |
| 17893 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, |
| 17894 | & UMO,PPCM,EPROJ,PPROJ |
| 17895 | * treatment of residual nuclei: wounded nucleons |
| 17896 | COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210) |
| 17897 | * treatment of residual nuclei: 4-momenta |
| 17898 | LOGICAL LRCLPR,LRCLTA |
| 17899 | COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5), |
| 17900 | & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA |
| 17901 | |
| 17902 | DIMENSION PFSP(4),PSEC(4),PSEC0(4) |
| 17903 | DIMENSION PMOMB(5000),IDXB(5000),PMOMM(10000),IDXM(10000), |
| 17904 | & IDXCOR(15000),IDXOTH(NMXHKK) |
| 17905 | |
| 17906 | GOTO (1,2) MODE |
| 17907 | |
| 17908 | *------- initializations |
| 17909 | 1 CONTINUE |
| 17910 | |
| 17911 | * initialize arrays for residual nuclei |
| 17912 | DO 10 K=1,5 |
| 17913 | IF (K.LE.4) THEN |
| 17914 | PFSP(K) = ZERO |
| 17915 | ENDIF |
| 17916 | PINIPR(K) = ZERO |
| 17917 | PINITA(K) = ZERO |
| 17918 | PRCLPR(K) = ZERO |
| 17919 | PRCLTA(K) = ZERO |
| 17920 | TRCLPR(K) = ZERO |
| 17921 | TRCLTA(K) = ZERO |
| 17922 | 10 CONTINUE |
| 17923 | SCPOT = ONE |
| 17924 | NLOOP = 0 |
| 17925 | |
| 17926 | * correction of projectile 4-momentum for effective target pot. |
| 17927 | * and Coulomb-energy (in case of hadron-nucleus interaction only) |
| 17928 | IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN |
| 17929 | EPNI = EPN |
| 17930 | * Coulomb-energy: |
| 17931 | * positively charged hadron - check energy for Coloumb pot. |
| 17932 | IF (IICH(IJPROJ).EQ.1) THEN |
| 17933 | THRESH = ETACOU(2)+AAM(IJPROJ) |
| 17934 | IF (EPNI.LE.THRESH) THEN |
| 17935 | WRITE(LOUT,1000) |
| 17936 | 1000 FORMAT(/,1X,'KKINC: WARNING! projectile energy', |
| 17937 | & ' below Coulomb threshold - event rejected',/) |
| 17938 | ISTHKK(1) = 1 |
| 17939 | RETURN |
| 17940 | ENDIF |
| 17941 | * negatively charged hadron - increase energy by Coulomb energy |
| 17942 | ELSEIF (IICH(IJPROJ).EQ.-1) THEN |
| 17943 | EPNI = EPNI+ETACOU(2) |
| 17944 | ENDIF |
| 17945 | IF ((IJPROJ.EQ.1).OR.(IJPROJ.EQ.8)) THEN |
| 17946 | * Effective target potential |
| 17947 | *sr 6.6. binding energy only (to avoid negative exc. energies) |
| 17948 | C EPNI = EPNI+EPOT(2,IJPROJ) |
| 17949 | EBIPOT = EBINDP(2) |
| 17950 | IF ((IJPROJ.NE.1).AND.(ABS(EPOT(2,IJPROJ)).GT.5.0D-3)) |
| 17951 | & EBIPOT = EBINDN(2) |
| 17952 | EPNI = EPNI+ABS(EBIPOT) |
| 17953 | * re-initialization of DTLTRA |
| 17954 | DUM1 = ZERO |
| 17955 | DUM2 = ZERO |
| 17956 | CALL DT_LTINI(IJPROJ,IJTARG,EPNI,DUM1,DUM2,0) |
| 17957 | ENDIF |
| 17958 | ENDIF |
| 17959 | |
| 17960 | * projectile in n-n cms |
| 17961 | IF ((IP.LE.1).AND.(IT.GT.1)) THEN |
| 17962 | PMASS1 = AAM(IJPROJ) |
| 17963 | C* VDM assumption |
| 17964 | C IF (IJPROJ.EQ.7) PMASS1 = AAM(33) |
| 17965 | IF (IJPROJ.EQ.7) PMASS1 = AAM(IJPROJ)-SQRT(VIRT) |
| 17966 | PMASS2 = AAM(1) |
| 17967 | PM1 = SIGN(PMASS1**2,PMASS1) |
| 17968 | PM2 = SIGN(PMASS2**2,PMASS2) |
| 17969 | PINIPR(4) = (UMO**2-PM2+PM1)/(TWO*UMO) |
| 17970 | PINIPR(5) = PMASS1 |
| 17971 | IF (PMASS1.GT.ZERO) THEN |
| 17972 | PINIPR(3) = SQRT((PINIPR(4)-PINIPR(5)) |
| 17973 | & *(PINIPR(4)+PINIPR(5))) |
| 17974 | ELSE |
| 17975 | PINIPR(3) = SQRT(PINIPR(4)**2-PM1) |
| 17976 | ENDIF |
| 17977 | AIT = DBLE(IT) |
| 17978 | AITZ = DBLE(ITZ) |
| 17979 | PINITA(5) = AIT*AMUAMU+1.0D-3*DT_ENERGY(AIT,AITZ) |
| 17980 | CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3) |
| 17981 | ELSEIF ((IP.GT.1).AND.(IT.LE.1)) THEN |
| 17982 | PMASS1 = AAM(1) |
| 17983 | PMASS2 = AAM(IJTARG) |
| 17984 | PM1 = SIGN(PMASS1**2,PMASS1) |
| 17985 | PM2 = SIGN(PMASS2**2,PMASS2) |
| 17986 | PINITA(4) = (UMO**2-PM1+PM2)/(TWO*UMO) |
| 17987 | PINITA(5) = PMASS2 |
| 17988 | PINITA(3) = -SQRT((PINITA(4)-PINITA(5)) |
| 17989 | & *(PINITA(4)+PINITA(5))) |
| 17990 | AIP = DBLE(IP) |
| 17991 | AIPZ = DBLE(IPZ) |
| 17992 | PINIPR(5) = AIP*AMUAMU+1.0D-3*DT_ENERGY(AIP,AIPZ) |
| 17993 | CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2) |
| 17994 | ELSEIF ((IP.GT.1).AND.(IT.GT.1)) THEN |
| 17995 | AIP = DBLE(IP) |
| 17996 | AIPZ = DBLE(IPZ) |
| 17997 | PINIPR(5) = AIP*AMUAMU+1.0D-3*DT_ENERGY(AIP,AIPZ) |
| 17998 | CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2) |
| 17999 | AIT = DBLE(IT) |
| 18000 | AITZ = DBLE(ITZ) |
| 18001 | PINITA(5) = AIT*AMUAMU+1.0D-3*DT_ENERGY(AIT,AITZ) |
| 18002 | CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3) |
| 18003 | ENDIF |
| 18004 | |
| 18005 | RETURN |
| 18006 | |
| 18007 | *------- treatment of final state |
| 18008 | 2 CONTINUE |
| 18009 | |
| 18010 | NLOOP = NLOOP+1 |
| 18011 | IF (NLOOP.GT.1) SCPOT = 0.10D0 |
| 18012 | C WRITE(LOUT,*) 'event ',NEVHKK,NLOOP,SCPOT |
| 18013 | |
| 18014 | JPW = NPW |
| 18015 | JPCW = NPCW |
| 18016 | JTW = NTW |
| 18017 | JTCW = NTCW |
| 18018 | DO 40 K=1,4 |
| 18019 | PFSP(K) = ZERO |
| 18020 | 40 CONTINUE |
| 18021 | |
| 18022 | NOB = 0 |
| 18023 | NOM = 0 |
| 18024 | DO 900 I=NPOINT(4),NHKK |
| 18025 | IDXOTH(I) = -1 |
| 18026 | IF (ISTHKK(I).EQ.1) THEN |
| 18027 | IF (IDBAM(I).EQ.7) GOTO 900 |
| 18028 | IPOT = 0 |
| 18029 | IOTHER = 0 |
| 18030 | * particle moving into forward direction |
| 18031 | IF (PHKK(3,I).GE.ZERO) THEN |
| 18032 | * most likely to be effected by projectile potential |
| 18033 | IPOT = 1 |
| 18034 | * there is no projectile nucleus, try target |
| 18035 | IF ((IP.LE.1).OR.((IP-NPW).LE.1)) THEN |
| 18036 | IPOT = 2 |
| 18037 | IF (IP.GT.1) IOTHER = 1 |
| 18038 | * there is no target nucleus --> skip |
| 18039 | IF ((IT.LE.1).OR.((IT-NTW).LE.1)) GOTO 900 |
| 18040 | ENDIF |
| 18041 | * particle moving into backward direction |
| 18042 | ELSE |
| 18043 | * most likely to be effected by target potential |
| 18044 | IPOT = 2 |
| 18045 | * there is no target nucleus, try projectile |
| 18046 | IF ((IT.LE.1).OR.((IT-NTW).LE.1)) THEN |
| 18047 | IPOT = 1 |
| 18048 | IF (IT.GT.1) IOTHER = 1 |
| 18049 | * there is no projectile nucleus --> skip |
| 18050 | IF ((IP.LE.1).OR.((IP-NPW).LE.1)) GOTO 900 |
| 18051 | ENDIF |
| 18052 | ENDIF |
| 18053 | IFLG = -IPOT |
| 18054 | * nobam=3: particle is in overlap-region or neither inside proj. nor target |
| 18055 | * =1: particle is not in overlap-region AND is inside target (2) |
| 18056 | * =2: particle is not in overlap-region AND is inside projectile (1) |
| 18057 | * flag particles which are inside the nucleus ipot but not in its |
| 18058 | * overlap region |
| 18059 | IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) IFLG = IPOT |
| 18060 | IF (IDBAM(I).NE.0) THEN |
| 18061 | * baryons: keep all nucleons and all others where flag is set |
| 18062 | IF (IIBAR(IDBAM(I)).NE.0) THEN |
| 18063 | IF ((IDBAM(I).EQ.1).OR.(IDBAM(I).EQ.8).OR.(IFLG.GT.0)) |
| 18064 | & THEN |
| 18065 | NOB = NOB+1 |
| 18066 | PMOMB(NOB) = PHKK(3,I) |
| 18067 | IDXB(NOB) = SIGN(10000000*IABS(IFLG) |
| 18068 | & +1000000*IOTHER+I,IFLG) |
| 18069 | ENDIF |
| 18070 | * mesons: keep only those mesons where flag is set |
| 18071 | ELSE |
| 18072 | IF (IFLG.GT.0) THEN |
| 18073 | NOM = NOM+1 |
| 18074 | PMOMM(NOM) = PHKK(3,I) |
| 18075 | IDXM(NOM) = 10000000*IFLG+1000000*IOTHER+I |
| 18076 | ENDIF |
| 18077 | ENDIF |
| 18078 | ENDIF |
| 18079 | ENDIF |
| 18080 | 900 CONTINUE |
| 18081 | * |
| 18082 | * sort particles in the arrays according to increasing long. momentum |
| 18083 | CALL DT_SORT1(PMOMB,IDXB,NOB,1,NOB,1) |
| 18084 | CALL DT_SORT1(PMOMM,IDXM,NOM,1,NOM,1) |
| 18085 | * |
| 18086 | * shuffle indices into one and the same array according to the later |
| 18087 | * sequence of correction |
| 18088 | NCOR = 0 |
| 18089 | IF (IT.GT.1) THEN |
| 18090 | DO 910 I=1,NOB |
| 18091 | IF (PMOMB(I).GT.ZERO) GOTO 911 |
| 18092 | NCOR = NCOR+1 |
| 18093 | IDXCOR(NCOR) = IDXB(I) |
| 18094 | 910 CONTINUE |
| 18095 | 911 CONTINUE |
| 18096 | IF (IP.GT.1) THEN |
| 18097 | DO 912 J=1,NOB |
| 18098 | I = NOB+1-J |
| 18099 | IF (PMOMB(I).LT.ZERO) GOTO 913 |
| 18100 | NCOR = NCOR+1 |
| 18101 | IDXCOR(NCOR) = IDXB(I) |
| 18102 | 912 CONTINUE |
| 18103 | 913 CONTINUE |
| 18104 | ELSE |
| 18105 | DO 914 I=1,NOB |
| 18106 | IF (PMOMB(I).GT.ZERO) THEN |
| 18107 | NCOR = NCOR+1 |
| 18108 | IDXCOR(NCOR) = IDXB(I) |
| 18109 | ENDIF |
| 18110 | 914 CONTINUE |
| 18111 | ENDIF |
| 18112 | ELSE |
| 18113 | DO 915 J=1,NOB |
| 18114 | I = NOB+1-J |
| 18115 | NCOR = NCOR+1 |
| 18116 | IDXCOR(NCOR) = IDXB(I) |
| 18117 | 915 CONTINUE |
| 18118 | ENDIF |
| 18119 | DO 925 I=1,NOM |
| 18120 | IF (PMOMM(I).GT.ZERO) GOTO 926 |
| 18121 | NCOR = NCOR+1 |
| 18122 | IDXCOR(NCOR) = IDXM(I) |
| 18123 | 925 CONTINUE |
| 18124 | 926 CONTINUE |
| 18125 | DO 927 J=1,NOM |
| 18126 | I = NOM+1-J |
| 18127 | IF (PMOMM(I).LT.ZERO) GOTO 928 |
| 18128 | NCOR = NCOR+1 |
| 18129 | IDXCOR(NCOR) = IDXM(I) |
| 18130 | 927 CONTINUE |
| 18131 | 928 CONTINUE |
| 18132 | * |
| 18133 | C IF (NEVHKK.EQ.484) THEN |
| 18134 | C WRITE(LOUT,9000) JPCW,JPW-JPCW,JTCW,JTW-JTCW |
| 18135 | C 9000 FORMAT(1X,'wounded nucleons (proj.-p,n targ.-p,n)',/,4I10) |
| 18136 | C WRITE(LOUT,9001) NOB,NOM,NCOR |
| 18137 | C 9001 FORMAT(1X,'produced particles (baryons,mesons,all)',3I10) |
| 18138 | C WRITE(LOUT,'(/,A)') ' baryons ' |
| 18139 | C DO 950 I=1,NOB |
| 18140 | CC J = IABS(IDXB(I)) |
| 18141 | CC INDEX = J-IABS(J/10000000)*10000000 |
| 18142 | C IPOT = IABS(IDXB(I))/10000000 |
| 18143 | C IOTHER = IABS(IDXB(I))/1000000-IPOT*10 |
| 18144 | C INDEX = IABS(IDXB(I))-IPOT*10000000-IOTHER*1000000 |
| 18145 | C WRITE(LOUT,9002) I,INDEX,IDXB(I),IDBAM(INDEX),PMOMB(I) |
| 18146 | C 950 CONTINUE |
| 18147 | C WRITE(LOUT,'(/,A)') ' mesons ' |
| 18148 | C DO 951 I=1,NOM |
| 18149 | CC INDEX = IDXM(I)-IABS(IDXM(I)/10000000)*10000000 |
| 18150 | C IPOT = IABS(IDXM(I))/10000000 |
| 18151 | C IOTHER = IABS(IDXM(I))/1000000-IPOT*10 |
| 18152 | C INDEX = IABS(IDXM(I))-IPOT*10000000-IOTHER*1000000 |
| 18153 | C WRITE(LOUT,9002) I,INDEX,IDXM(I),IDBAM(INDEX),PMOMM(I) |
| 18154 | C 951 CONTINUE |
| 18155 | C 9002 FORMAT(1X,4I14,E14.5) |
| 18156 | C WRITE(LOUT,'(/,A)') ' all ' |
| 18157 | C DO 952 I=1,NCOR |
| 18158 | CC J = IABS(IDXCOR(I)) |
| 18159 | CC INDEX = J-IABS(J/10000000)*10000000 |
| 18160 | CC IPOT = IABS(IDXCOR(I))/10000000 |
| 18161 | C IOTHER = IABS(IDXCOR(I))/1000000-IPOT*10 |
| 18162 | C INDEX = IABS(IDXCOR(I))-IPOT*10000000-IOTHER*1000000 |
| 18163 | C WRITE(LOUT,9003) I,INDEX,IDXCOR(I),IDBAM(INDEX) |
| 18164 | C 952 CONTINUE |
| 18165 | C 9003 FORMAT(1X,4I14) |
| 18166 | C ENDIF |
| 18167 | * |
| 18168 | DO 20 ICOR=1,NCOR |
| 18169 | IPOT = IABS(IDXCOR(ICOR))/10000000 |
| 18170 | IOTHER = IABS(IDXCOR(ICOR))/1000000-IPOT*10 |
| 18171 | I = IABS(IDXCOR(ICOR))-IPOT*10000000-IOTHER*1000000 |
| 18172 | IDXOTH(I) = 1 |
| 18173 | |
| 18174 | IDSEC = IDBAM(I) |
| 18175 | |
| 18176 | * reduction of particle momentum by corresponding nuclear potential |
| 18177 | * (this applies only if Fermi-momenta are requested) |
| 18178 | |
| 18179 | IF (LFERMI) THEN |
| 18180 | |
| 18181 | * Lorentz-transformation into the rest system of the selected nucleus |
| 18182 | IMODE = -IPOT-1 |
| 18183 | CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I), |
| 18184 | & PSEC(1),PSEC(2),PSEC(3),PSEC(4),IDSEC,IMODE) |
| 18185 | PSECO = SQRT(PSEC(1)**2+PSEC(2)**2+PSEC(3)**2) |
| 18186 | AMSEC = SQRT(ABS((PSEC(4)-PSECO)*(PSEC(4)+PSECO))) |
| 18187 | JPMOD = 0 |
| 18188 | |
| 18189 | CHKLEV = TINY3 |
| 18190 | IF ((EPROJ.GE.1.0D4).AND.(IDSEC.EQ.7)) CHKLEV = TINY1 |
| 18191 | IF (EPROJ.GE.2.0D6) CHKLEV = 1.0D0 |
| 18192 | IF (ABS(AMSEC-AAM(IDSEC)).GT.CHKLEV) THEN |
| 18193 | IF (IOULEV(3).GT.0) |
| 18194 | & WRITE(LOUT,2000) I,NEVHKK,IDSEC,AMSEC,AAM(IDSEC) |
| 18195 | 2000 FORMAT(1X,'RESNCL: inconsistent mass of particle', |
| 18196 | & ' at entry ',I5,' (evt.',I8,')',/,' IDSEC: ', |
| 18197 | & I4,' AMSEC: ',E12.3,' AAM(IDSEC): ',E12.3,/) |
| 18198 | GOTO 23 |
| 18199 | ENDIF |
| 18200 | |
| 18201 | DO 21 K=1,4 |
| 18202 | PSEC0(K) = PSEC(K) |
| 18203 | 21 CONTINUE |
| 18204 | |
| 18205 | * the correction for nuclear potential effects is applied to as many |
| 18206 | * p/n as many nucleons were wounded; the momenta of other final state |
| 18207 | * particles are corrected only if they materialize inside the corresp. |
| 18208 | * nucleus (here: NOBAM = 1 part. outside proj., = 2 part. outside targ |
| 18209 | * = 3 part. outside proj. and targ., >=10 in overlapping region) |
| 18210 | IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) THEN |
| 18211 | IF (IPOT.EQ.1) THEN |
| 18212 | IF ((JPW.GT.0).AND.(IOTHER.EQ.0)) THEN |
| 18213 | * this is most likely a wounded nucleon |
| 18214 | **test |
| 18215 | C RDIST = SQRT((VHKK(1,IPW(JPW))/FM2MM)**2 |
| 18216 | C & +(VHKK(2,IPW(JPW))/FM2MM)**2 |
| 18217 | C & +(VHKK(3,IPW(JPW))/FM2MM)**2) |
| 18218 | C RAD = RNUCLE*DBLE(IP)**ONETHI |
| 18219 | C FDEN = 1.4D0*DT_DENSIT(IP,RDIST,RAD) |
| 18220 | C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC) |
| 18221 | ** |
| 18222 | PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC) |
| 18223 | JPW = JPW-1 |
| 18224 | JPMOD = 1 |
| 18225 | ELSE |
| 18226 | * correct only if part. was materialized inside nucleus |
| 18227 | * and if it is ouside the overlapping region |
| 18228 | IF ((NOBAM(I).NE.1).AND.(NOBAM(I).LT.3)) THEN |
| 18229 | PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC) |
| 18230 | JPMOD = 1 |
| 18231 | ENDIF |
| 18232 | ENDIF |
| 18233 | ELSEIF (IPOT.EQ.2) THEN |
| 18234 | IF ((JTW.GT.0).AND.(IOTHER.EQ.0)) THEN |
| 18235 | * this is most likely a wounded nucleon |
| 18236 | **test |
| 18237 | C RDIST = SQRT((VHKK(1,ITW(JTW))/FM2MM)**2 |
| 18238 | C & +(VHKK(2,ITW(JTW))/FM2MM)**2 |
| 18239 | C & +(VHKK(3,ITW(JTW))/FM2MM)**2) |
| 18240 | C RAD = RNUCLE*DBLE(IT)**ONETHI |
| 18241 | C FDEN = 1.4D0*DT_DENSIT(IT,RDIST,RAD) |
| 18242 | C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC) |
| 18243 | ** |
| 18244 | PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC) |
| 18245 | JTW = JTW-1 |
| 18246 | JPMOD = 1 |
| 18247 | ELSE |
| 18248 | * correct only if part. was materialized inside nucleus |
| 18249 | IF ((NOBAM(I).NE.2).AND.(NOBAM(I).LT.3)) THEN |
| 18250 | PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC) |
| 18251 | JPMOD = 1 |
| 18252 | ENDIF |
| 18253 | ENDIF |
| 18254 | ENDIF |
| 18255 | ELSE |
| 18256 | IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) THEN |
| 18257 | PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC) |
| 18258 | JPMOD = 1 |
| 18259 | ENDIF |
| 18260 | ENDIF |
| 18261 | |
| 18262 | IF (NLOOP.EQ.1) THEN |
| 18263 | * Coulomb energy correction: |
| 18264 | * the treatment of Coulomb potential correction is similar to the |
| 18265 | * one for nuclear potential |
| 18266 | IF (IDSEC.EQ.1) THEN |
| 18267 | IF ((IPOT.EQ.1).AND.(JPCW.GT.0)) THEN |
| 18268 | JPCW = JPCW-1 |
| 18269 | ELSEIF ((IPOT.EQ.2).AND.(JTCW.GT.0)) THEN |
| 18270 | JTCW = JTCW-1 |
| 18271 | ELSE |
| 18272 | IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25 |
| 18273 | ENDIF |
| 18274 | ELSE |
| 18275 | IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25 |
| 18276 | ENDIF |
| 18277 | IF (IICH(IDSEC).EQ.1) THEN |
| 18278 | * pos. particles: check if they are able to escape Coulomb potential |
| 18279 | IF (PSEC(4).LT.AMSEC+ETACOU(IPOT)) THEN |
| 18280 | ISTHKK(I) = 14+IPOT |
| 18281 | IF (ISTHKK(I).EQ.15) THEN |
| 18282 | DO 26 K=1,4 |
| 18283 | PHKK(K,I) = PSEC0(K) |
| 18284 | TRCLPR(K) = TRCLPR(K)+PSEC0(K) |
| 18285 | 26 CONTINUE |
| 18286 | IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1 |
| 18287 | IF (IDSEC.EQ.1) NPCW = NPCW-1 |
| 18288 | ELSEIF (ISTHKK(I).EQ.16) THEN |
| 18289 | DO 27 K=1,4 |
| 18290 | PHKK(K,I) = PSEC0(K) |
| 18291 | TRCLTA(K) = TRCLTA(K)+PSEC0(K) |
| 18292 | 27 CONTINUE |
| 18293 | IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1 |
| 18294 | IF (IDSEC.EQ.1) NTCW = NTCW-1 |
| 18295 | ENDIF |
| 18296 | GOTO 20 |
| 18297 | ENDIF |
| 18298 | ELSEIF (IICH(IDSEC).EQ.-1) THEN |
| 18299 | * neg. particles: decrease energy by Coulomb-potential |
| 18300 | PSEC(4) = PSEC(4)-ETACOU(IPOT) |
| 18301 | JPMOD = 1 |
| 18302 | ENDIF |
| 18303 | ENDIF |
| 18304 | |
| 18305 | 25 CONTINUE |
| 18306 | |
| 18307 | IF (PSEC(4).LT.AMSEC) THEN |
| 18308 | IF (IOULEV(6).GT.0) |
| 18309 | & WRITE(LOUT,2001) I,IDSEC,PSEC(4),AMSEC |
| 18310 | 2001 FORMAT(1X,'KKINC: particle at DTEVT1-pos. ',I5, |
| 18311 | & ' is not allowed to escape nucleus',/, |
| 18312 | & 8X,'id : ',I3,' reduced energy: ',E15.4, |
| 18313 | & ' mass: ',E12.3) |
| 18314 | ISTHKK(I) = 14+IPOT |
| 18315 | IF (ISTHKK(I).EQ.15) THEN |
| 18316 | DO 28 K=1,4 |
| 18317 | PHKK(K,I) = PSEC0(K) |
| 18318 | TRCLPR(K) = TRCLPR(K)+PSEC0(K) |
| 18319 | 28 CONTINUE |
| 18320 | IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1 |
| 18321 | IF (IDSEC.EQ.1) NPCW = NPCW-1 |
| 18322 | ELSEIF (ISTHKK(I).EQ.16) THEN |
| 18323 | DO 29 K=1,4 |
| 18324 | PHKK(K,I) = PSEC0(K) |
| 18325 | TRCLTA(K) = TRCLTA(K)+PSEC0(K) |
| 18326 | 29 CONTINUE |
| 18327 | IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1 |
| 18328 | IF (IDSEC.EQ.1) NTCW = NTCW-1 |
| 18329 | ENDIF |
| 18330 | GOTO 20 |
| 18331 | ENDIF |
| 18332 | |
| 18333 | IF (JPMOD.EQ.1) THEN |
| 18334 | PSECN = SQRT( (PSEC(4)-AMSEC)*(PSEC(4)+AMSEC) ) |
| 18335 | * 4-momentum after correction for nuclear potential |
| 18336 | DO 22 K=1,3 |
| 18337 | PSEC(K) = PSEC(K)*PSECN/PSECO |
| 18338 | 22 CONTINUE |
| 18339 | |
| 18340 | * store recoil momentum from particles escaping the nuclear potentials |
| 18341 | DO 30 K=1,4 |
| 18342 | IF (IPOT.EQ.1) THEN |
| 18343 | TRCLPR(K) = TRCLPR(K)+PSEC0(K)-PSEC(K) |
| 18344 | ELSEIF (IPOT.EQ.2) THEN |
| 18345 | TRCLTA(K) = TRCLTA(K)+PSEC0(K)-PSEC(K) |
| 18346 | ENDIF |
| 18347 | 30 CONTINUE |
| 18348 | |
| 18349 | * transform momentum back into n-n cms |
| 18350 | IMODE = IPOT+1 |
| 18351 | CALL DT_LTRANS(PSEC(1),PSEC(2),PSEC(3),PSEC(4), |
| 18352 | & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I), |
| 18353 | & IDSEC,IMODE) |
| 18354 | ENDIF |
| 18355 | |
| 18356 | ENDIF |
| 18357 | |
| 18358 | 23 CONTINUE |
| 18359 | DO 31 K=1,4 |
| 18360 | PFSP(K) = PFSP(K)+PHKK(K,I) |
| 18361 | 31 CONTINUE |
| 18362 | |
| 18363 | 20 CONTINUE |
| 18364 | |
| 18365 | DO 33 I=NPOINT(4),NHKK |
| 18366 | IF ((ISTHKK(I).EQ.1).AND.(IDXOTH(I).LT.0)) THEN |
| 18367 | PFSP(1) = PFSP(1)+PHKK(1,I) |
| 18368 | PFSP(2) = PFSP(2)+PHKK(2,I) |
| 18369 | PFSP(3) = PFSP(3)+PHKK(3,I) |
| 18370 | PFSP(4) = PFSP(4)+PHKK(4,I) |
| 18371 | ENDIF |
| 18372 | 33 CONTINUE |
| 18373 | |
| 18374 | DO 34 K=1,5 |
| 18375 | PRCLPR(K) = TRCLPR(K) |
| 18376 | PRCLTA(K) = TRCLTA(K) |
| 18377 | 34 CONTINUE |
| 18378 | |
| 18379 | IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN |
| 18380 | * hadron-nucleus interactions: get residual momentum from energy- |
| 18381 | * momentum conservation |
| 18382 | DO 32 K=1,4 |
| 18383 | PRCLPR(K) = ZERO |
| 18384 | PRCLTA(K) = PINIPR(K)+PINITA(K)-PFSP(K) |
| 18385 | 32 CONTINUE |
| 18386 | ELSE |
| 18387 | * nucleus-hadron, nucleus-nucleus: get residual momentum from |
| 18388 | * accumulated recoil momenta of particles leaving the spectators |
| 18389 | * transform accumulated recoil momenta of residual nuclei into |
| 18390 | * n-n cms |
| 18391 | PZI = PRCLPR(3) |
| 18392 | PEI = PRCLPR(4) |
| 18393 | CALL DT_LTNUC(PZI,PEI,PRCLPR(3),PRCLPR(4),2) |
| 18394 | PZI = PRCLTA(3) |
| 18395 | PEI = PRCLTA(4) |
| 18396 | CALL DT_LTNUC(PZI,PEI,PRCLTA(3),PRCLTA(4),3) |
| 18397 | C IF (IP.GT.1) THEN |
| 18398 | PRCLPR(3) = PRCLPR(3)+PINIPR(3) |
| 18399 | PRCLPR(4) = PRCLPR(4)+PINIPR(4) |
| 18400 | C ENDIF |
| 18401 | IF (IT.GT.1) THEN |
| 18402 | PRCLTA(3) = PRCLTA(3)+PINITA(3) |
| 18403 | PRCLTA(4) = PRCLTA(4)+PINITA(4) |
| 18404 | ENDIF |
| 18405 | ENDIF |
| 18406 | |
| 18407 | * check momenta of residual nuclei |
| 18408 | IF (LEMCCK) THEN |
| 18409 | CALL DT_EVTEMC(-PINIPR(1),-PINIPR(2),-PINIPR(3),-PINIPR(4), |
| 18410 | & 1,IDUM,IDUM) |
| 18411 | CALL DT_EVTEMC(-PINITA(1),-PINITA(2),-PINITA(3),-PINITA(4), |
| 18412 | & 2,IDUM,IDUM) |
| 18413 | CALL DT_EVTEMC(PRCLPR(1),PRCLPR(2),PRCLPR(3),PRCLPR(4), |
| 18414 | & 2,IDUM,IDUM) |
| 18415 | CALL DT_EVTEMC(PRCLTA(1),PRCLTA(2),PRCLTA(3),PRCLTA(4), |
| 18416 | & 2,IDUM,IDUM) |
| 18417 | CALL DT_EVTEMC(PFSP(1),PFSP(2),PFSP(3),PFSP(4),2,IDUM,IDUM) |
| 18418 | **sr 19.12. changed to avoid output when used with phojet |
| 18419 | C CHKLEV = TINY3 |
| 18420 | CHKLEV = TINY1 |
| 18421 | CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,501,IREJ1) |
| 18422 | C IF ((NEVHKK.EQ.409).OR.(NEVHKK.EQ.460).OR.(NEVHKK.EQ.765)) |
| 18423 | C & CALL DT_EVTOUT(4) |
| 18424 | IF (IREJ1.GT.0) RETURN |
| 18425 | ENDIF |
| 18426 | |
| 18427 | RETURN |
| 18428 | END |
| 18429 | |
| 18430 | *$ CREATE DT_SCN4BA.FOR |
| 18431 | *COPY DT_SCN4BA |
| 18432 | * |
| 18433 | *===scn4ba=============================================================* |
| 18434 | * |
| 18435 | SUBROUTINE DT_SCN4BA |
| 18436 | |
| 18437 | ************************************************************************ |
| 18438 | * SCan /DTEVT1/ 4 BAryons which are not able to escape nuclear pot. * |
| 18439 | * This version dated 12.12.95 is written by S. Roesler. * |
| 18440 | ************************************************************************ |
| 18441 | |
| 18442 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 18443 | SAVE |
| 18444 | PARAMETER ( LINP = 10 , |
| 18445 | & LOUT = 6 , |
| 18446 | & LDAT = 9 ) |
| 18447 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2, |
| 18448 | & TINY10=1.0D-10) |
| 18449 | |
| 18450 | * event history |
| 18451 | PARAMETER (NMXHKK=200000) |
| 18452 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 18453 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 18454 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 18455 | * extended event history |
| 18456 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 18457 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 18458 | & IHIST(2,NMXHKK) |
| 18459 | * particle properties (BAMJET index convention) |
| 18460 | CHARACTER*8 ANAME |
| 18461 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 18462 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 18463 | * properties of interacting particles |
| 18464 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG |
| 18465 | * nuclear potential |
| 18466 | LOGICAL LFERMI |
| 18467 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, |
| 18468 | & EBINDP(2),EBINDN(2),EPOT(2,210), |
| 18469 | & ETACOU(2),ICOUL,LFERMI |
| 18470 | * treatment of residual nuclei: wounded nucleons |
| 18471 | COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210) |
| 18472 | * treatment of residual nuclei: 4-momenta |
| 18473 | LOGICAL LRCLPR,LRCLTA |
| 18474 | COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5), |
| 18475 | & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA |
| 18476 | |
| 18477 | DIMENSION PLAB(2,5),PCMS(4) |
| 18478 | |
| 18479 | IREJ = 0 |
| 18480 | |
| 18481 | * get number of wounded nucleons |
| 18482 | NPW = 0 |
| 18483 | NPW0 = 0 |
| 18484 | NPCW = 0 |
| 18485 | NPSTCK = 0 |
| 18486 | NTW = 0 |
| 18487 | NTW0 = 0 |
| 18488 | NTCW = 0 |
| 18489 | NTSTCK = 0 |
| 18490 | |
| 18491 | ISGLPR = 0 |
| 18492 | ISGLTA = 0 |
| 18493 | LRCLPR = .FALSE. |
| 18494 | LRCLTA = .FALSE. |
| 18495 | |
| 18496 | C DO 2 I=1,NHKK |
| 18497 | DO 2 I=1,NPOINT(1) |
| 18498 | * projectile nucleons wounded in primary interaction and in fzc |
| 18499 | IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.17)) THEN |
| 18500 | NPW = NPW+1 |
| 18501 | IPW(NPW) = I |
| 18502 | NPSTCK = NPSTCK+1 |
| 18503 | IF (IDHKK(I).EQ.2212) NPCW = NPCW+1 |
| 18504 | IF (ISTHKK(I).EQ.11) NPW0 = NPW0+1 |
| 18505 | C IF (IP.GT.1) THEN |
| 18506 | DO 5 K=1,4 |
| 18507 | TRCLPR(K) = TRCLPR(K)-PHKK(K,I) |
| 18508 | 5 CONTINUE |
| 18509 | C ENDIF |
| 18510 | * target nucleons wounded in primary interaction and in fzc |
| 18511 | ELSEIF ((ISTHKK(I).EQ.12).OR.(ISTHKK(I).EQ.18)) THEN |
| 18512 | NTW = NTW+1 |
| 18513 | ITW(NTW) = I |
| 18514 | NTSTCK = NTSTCK+1 |
| 18515 | IF (IDHKK(I).EQ.2212) NTCW = NTCW+1 |
| 18516 | IF (ISTHKK(I).EQ.12) NTW0 = NTW0+1 |
| 18517 | IF (IT.GT.1) THEN |
| 18518 | DO 6 K=1,4 |
| 18519 | TRCLTA(K) = TRCLTA(K)-PHKK(K,I) |
| 18520 | 6 CONTINUE |
| 18521 | ENDIF |
| 18522 | ELSEIF (ISTHKK(I).EQ.13) THEN |
| 18523 | ISGLPR = I |
| 18524 | ELSEIF (ISTHKK(I).EQ.14) THEN |
| 18525 | ISGLTA = I |
| 18526 | ENDIF |
| 18527 | 2 CONTINUE |
| 18528 | |
| 18529 | DO 11 I=NPOINT(4),NHKK |
| 18530 | * baryons which are unable to escape the nuclear potential of proj. |
| 18531 | IF (ISTHKK(I).EQ.15) THEN |
| 18532 | ISGLPR = I |
| 18533 | NPSTCK = NPSTCK-1 |
| 18534 | IF (IIBAR(IDBAM(I)).NE.0) THEN |
| 18535 | NPW = NPW-1 |
| 18536 | IF (IICH(IDBAM(I)).GT.0) NPCW = NPCW-1 |
| 18537 | ENDIF |
| 18538 | DO 7 K=1,4 |
| 18539 | TRCLPR(K) = TRCLPR(K)+PHKK(K,I) |
| 18540 | 7 CONTINUE |
| 18541 | * baryons which are unable to escape the nuclear potential of targ. |
| 18542 | ELSEIF (ISTHKK(I).EQ.16) THEN |
| 18543 | ISGLTA = I |
| 18544 | NTSTCK = NTSTCK-1 |
| 18545 | IF (IIBAR(IDBAM(I)).NE.0) THEN |
| 18546 | NTW = NTW-1 |
| 18547 | IF (IICH(IDBAM(I)).GT.0) NTCW = NTCW-1 |
| 18548 | ENDIF |
| 18549 | DO 8 K=1,4 |
| 18550 | TRCLTA(K) = TRCLTA(K)+PHKK(K,I) |
| 18551 | 8 CONTINUE |
| 18552 | ENDIF |
| 18553 | 11 CONTINUE |
| 18554 | |
| 18555 | * residual nuclei so far |
| 18556 | IRESP = IP-NPSTCK |
| 18557 | IREST = IT-NTSTCK |
| 18558 | |
| 18559 | * ckeck for "residual nuclei" consisting of one nucleon only |
| 18560 | * treat it as final state particle |
| 18561 | IF (IRESP.EQ.1) THEN |
| 18562 | ID = IDBAM(ISGLPR) |
| 18563 | IST = ISTHKK(ISGLPR) |
| 18564 | CALL DT_LTRANS(PHKK(1,ISGLPR),PHKK(2,ISGLPR), |
| 18565 | & PHKK(3,ISGLPR),PHKK(4,ISGLPR), |
| 18566 | & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,2) |
| 18567 | IF (IST.EQ.13) THEN |
| 18568 | ISTHKK(ISGLPR) = 11 |
| 18569 | ELSE |
| 18570 | ISTHKK(ISGLPR) = 2 |
| 18571 | ENDIF |
| 18572 | CALL DT_EVTPUT(1,IDHKK(ISGLPR),ISGLPR,0, |
| 18573 | & PCMS(1),PCMS(2),PCMS(3),PCMS(4), |
| 18574 | & IDRES(ISGLPR),IDXRES(ISGLPR),IDCH(ISGLPR)) |
| 18575 | NOBAM(NHKK) = NOBAM(ISGLPR) |
| 18576 | JDAHKK(1,ISGLPR) = NHKK |
| 18577 | DO 21 K=1,4 |
| 18578 | TRCLPR(K) = TRCLPR(K)-PHKK(K,ISGLPR) |
| 18579 | 21 CONTINUE |
| 18580 | ENDIF |
| 18581 | IF (IREST.EQ.1) THEN |
| 18582 | ID = IDBAM(ISGLTA) |
| 18583 | IST = ISTHKK(ISGLTA) |
| 18584 | CALL DT_LTRANS(PHKK(1,ISGLTA),PHKK(2,ISGLTA), |
| 18585 | & PHKK(3,ISGLTA),PHKK(4,ISGLTA), |
| 18586 | & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,3) |
| 18587 | IF (IST.EQ.14) THEN |
| 18588 | ISTHKK(ISGLTA) = 12 |
| 18589 | ELSE |
| 18590 | ISTHKK(ISGLTA) = 2 |
| 18591 | ENDIF |
| 18592 | CALL DT_EVTPUT(1,IDHKK(ISGLTA),ISGLTA,0, |
| 18593 | & PCMS(1),PCMS(2),PCMS(3),PCMS(4), |
| 18594 | & IDRES(ISGLTA),IDXRES(ISGLTA),IDCH(ISGLTA)) |
| 18595 | NOBAM(NHKK) = NOBAM(ISGLTA) |
| 18596 | JDAHKK(1,ISGLTA) = NHKK |
| 18597 | DO 22 K=1,4 |
| 18598 | TRCLTA(K) = TRCLTA(K)-PHKK(K,ISGLTA) |
| 18599 | 22 CONTINUE |
| 18600 | ENDIF |
| 18601 | |
| 18602 | * get nuclear potential corresp. to the residual nucleus |
| 18603 | IPRCL = IP -NPW |
| 18604 | IPZRCL = IPZ-NPCW |
| 18605 | ITRCL = IT -NTW |
| 18606 | ITZRCL = ITZ-NTCW |
| 18607 | CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1) |
| 18608 | |
| 18609 | * baryons unable to escape the nuclear potential are treated as |
| 18610 | * excited nucleons (ISTHKK=15,16) |
| 18611 | DO 3 I=NPOINT(4),NHKK |
| 18612 | IF (ISTHKK(I).EQ.1) THEN |
| 18613 | ID = IDBAM(I) |
| 18614 | IF ( ((ID.EQ.1).OR.(ID.EQ.8)).AND.(NOBAM(I).NE.3) ) THEN |
| 18615 | * final state n and p not being outside of both nuclei are considered |
| 18616 | NPOTP = 1 |
| 18617 | NPOTT = 1 |
| 18618 | IF ( (IP.GT.1) .AND.(IRESP.GT.1).AND. |
| 18619 | & (NOBAM(I).NE.1).AND.(NPW.GT.0) ) THEN |
| 18620 | * Lorentz-trsf. into proj. rest sys. for those being inside proj. |
| 18621 | CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I), |
| 18622 | & PHKK(4,I),PLAB(1,1),PLAB(1,2),PLAB(1,3), |
| 18623 | & PLAB(1,4),ID,-2) |
| 18624 | PLABT = SQRT(PLAB(1,1)**2+PLAB(1,2)**2+PLAB(1,3)**2) |
| 18625 | PLAB(1,5) = SQRT(ABS( (PLAB(1,4)-PLABT)* |
| 18626 | & (PLAB(1,4)+PLABT) )) |
| 18627 | EKIN = PLAB(1,4)-PLAB(1,5) |
| 18628 | IF (EKIN.LE.EPOT(1,ID)) NPOTP = 15 |
| 18629 | IF ((ID.EQ.1).AND.(NPCW.LE.0)) NPOTP = 1 |
| 18630 | ENDIF |
| 18631 | IF ( (IT.GT.1) .AND.(IREST.GT.1).AND. |
| 18632 | & (NOBAM(I).NE.2).AND.(NTW.GT.0) ) THEN |
| 18633 | * Lorentz-trsf. into targ. rest sys. for those being inside targ. |
| 18634 | CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I), |
| 18635 | & PHKK(4,I),PLAB(2,1),PLAB(2,2),PLAB(2,3), |
| 18636 | & PLAB(2,4),ID,-3) |
| 18637 | PLABT = SQRT(PLAB(2,1)**2+PLAB(2,2)**2+PLAB(2,3)**2) |
| 18638 | PLAB(2,5) = SQRT(ABS( (PLAB(2,4)-PLABT)* |
| 18639 | & (PLAB(2,4)+PLABT) )) |
| 18640 | EKIN = PLAB(2,4)-PLAB(2,5) |
| 18641 | IF (EKIN.LE.EPOT(2,ID)) NPOTT = 16 |
| 18642 | IF ((ID.EQ.1).AND.(NTCW.LE.0)) NPOTT = 1 |
| 18643 | ENDIF |
| 18644 | IF (PHKK(3,I).GE.ZERO) THEN |
| 18645 | ISTHKK(I) = NPOTT |
| 18646 | IF (NPOTP.NE.1) ISTHKK(I) = NPOTP |
| 18647 | ELSE |
| 18648 | ISTHKK(I) = NPOTP |
| 18649 | IF (NPOTT.NE.1) ISTHKK(I) = NPOTT |
| 18650 | ENDIF |
| 18651 | IF (ISTHKK(I).NE.1) THEN |
| 18652 | J = ISTHKK(I)-14 |
| 18653 | DO 4 K=1,5 |
| 18654 | PHKK(K,I) = PLAB(J,K) |
| 18655 | 4 CONTINUE |
| 18656 | IF (ISTHKK(I).EQ.15) THEN |
| 18657 | NPW = NPW-1 |
| 18658 | IF (ID.EQ.1) NPCW = NPCW-1 |
| 18659 | DO 9 K=1,4 |
| 18660 | TRCLPR(K) = TRCLPR(K)+PHKK(K,I) |
| 18661 | 9 CONTINUE |
| 18662 | ELSEIF (ISTHKK(I).EQ.16) THEN |
| 18663 | NTW = NTW-1 |
| 18664 | IF (ID.EQ.1) NTCW = NTCW-1 |
| 18665 | DO 10 K=1,4 |
| 18666 | TRCLTA(K) = TRCLTA(K)+PHKK(K,I) |
| 18667 | 10 CONTINUE |
| 18668 | ENDIF |
| 18669 | ENDIF |
| 18670 | ENDIF |
| 18671 | ENDIF |
| 18672 | 3 CONTINUE |
| 18673 | |
| 18674 | * again: get nuclear potential corresp. to the residual nucleus |
| 18675 | IPRCL = IP -NPW |
| 18676 | IPZRCL = IPZ-NPCW |
| 18677 | ITRCL = IT -NTW |
| 18678 | ITZRCL = ITZ-NTCW |
| 18679 | c AFERP = 1.2D0*FERMOD*(ONE+(DBLE(IP+10-NPW0)/DBLE(IP+10))**1.1D0) |
| 18680 | cC AFERP = 1.21D0*FERMOD*(ONE+(DBLE(IP+40-NPW0)/DBLE(IP+40))**1.1D0) |
| 18681 | c & *(0.94D0+0.3D0*EXP(-DBLE(NPW0)/5.0D0)) /2.0D0 |
| 18682 | C AFERP = 0.0D0 |
| 18683 | c AFERT = 1.2D0*FERMOD*(ONE+(DBLE(IT+10-NTW0)/DBLE(IT+10))**1.1D0) |
| 18684 | cC AFERT = 1.21D0*FERMOD*(ONE+(DBLE(IT+40-NTW0)/DBLE(IT+40))**1.1D0) |
| 18685 | c & *(0.94D0+0.3D0*EXP(-DBLE(NTW0)/5.0D0)) /2.0D0 |
| 18686 | C AFERT = 0.0D0 |
| 18687 | C IF (AFERP.LT.FERMOD) AFERP = FERMOD+0.1 |
| 18688 | C IF (AFERT.LT.FERMOD) AFERT = FERMOD+0.1 |
| 18689 | C IF (AFERP.GT.0.85D0) AFERP = 0.85D0 |
| 18690 | C IF (AFERT.GT.0.85D0) AFERT = 0.85D0 |
| 18691 | AFERP = FERMOD+0.1D0 |
| 18692 | AFERT = FERMOD+0.1D0 |
| 18693 | |
| 18694 | CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,AFERP,AFERT,1) |
| 18695 | |
| 18696 | RETURN |
| 18697 | END |
| 18698 | |
| 18699 | *$ CREATE DT_FICONF.FOR |
| 18700 | *COPY DT_FICONF |
| 18701 | * |
| 18702 | *===ficonf=============================================================* |
| 18703 | * |
| 18704 | SUBROUTINE DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ) |
| 18705 | |
| 18706 | ************************************************************************ |
| 18707 | * Treatment of FInal CONFiguration including evaporation, fission and * |
| 18708 | * Fermi-break-up (for light nuclei only). * |
| 18709 | * Adopted from the original routine FINALE and extended to residual * |
| 18710 | * projectile nuclei. * |
| 18711 | * This version dated 12.12.95 is written by S. Roesler. * |
| 18712 | * * |
| 18713 | * Last change 27.12.2006 by S. Roesler. * |
| 18714 | ************************************************************************ |
| 18715 | |
| 18716 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 18717 | SAVE |
| 18718 | PARAMETER ( LINP = 10 , |
| 18719 | & LOUT = 6 , |
| 18720 | & LDAT = 9 ) |
| 18721 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10) |
| 18722 | PARAMETER (ANGLGB=5.0D-16) |
| 18723 | PARAMETER (AMUAMU=0.93149432D0,AMELEC=0.51099906D-3) |
| 18724 | |
| 18725 | * event history |
| 18726 | PARAMETER (NMXHKK=200000) |
| 18727 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 18728 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 18729 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 18730 | * extended event history |
| 18731 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 18732 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 18733 | & IHIST(2,NMXHKK) |
| 18734 | * rejection counter |
| 18735 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, |
| 18736 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, |
| 18737 | & IREXCI(3),IRDIFF(2),IRINC |
| 18738 | * central particle production, impact parameter biasing |
| 18739 | COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR |
| 18740 | * particle properties (BAMJET index convention) |
| 18741 | CHARACTER*8 ANAME |
| 18742 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 18743 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 18744 | * treatment of residual nuclei: 4-momenta |
| 18745 | LOGICAL LRCLPR,LRCLTA |
| 18746 | COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5), |
| 18747 | & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA |
| 18748 | * treatment of residual nuclei: properties of residual nuclei |
| 18749 | COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2), |
| 18750 | & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2), |
| 18751 | & NTOTFI(2),NPROFI(2) |
| 18752 | * statistics: residual nuclei |
| 18753 | COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2), |
| 18754 | & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2), |
| 18755 | & NINCST(2,4),NINCEV(2), |
| 18756 | & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2), |
| 18757 | & NRESPB(2),NRESCH(2),NRESEV(4), |
| 18758 | & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240), |
| 18759 | & NEVAFI(2,2) |
| 18760 | * flags for input different options |
| 18761 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 18762 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 18763 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 18764 | * (original name: FINUC) |
| 18765 | PARAMETER (MXP=999) |
| 18766 | COMMON /FKFINU/ CXR (MXP), CYR (MXP), CZR (MXP), |
| 18767 | & CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP), |
| 18768 | & TKI (MXP), PLR (MXP), WEI (MXP), |
| 18769 | & TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP, |
| 18770 | & KPART (MXP) |
| 18771 | * (original name: RESNUC) |
| 18772 | LOGICAL LRNFSS, LFRAGM |
| 18773 | COMMON /FKRESN/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1, |
| 18774 | & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT, |
| 18775 | & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES, |
| 18776 | & PYRES, PZRES, PTRES2, KTARP, KTARN, IGREYP, |
| 18777 | & IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE, |
| 18778 | & ICRES, IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU, |
| 18779 | & IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG, |
| 18780 | & IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS, |
| 18781 | & LFRAGM |
| 18782 | COMMON /FKNDAT/ AV0WEL, APFRMX, AEFRMX, AEFRMA, |
| 18783 | & RDSNUC, V0WELL (2), PFRMMX (2), EFRMMX (2), |
| 18784 | & EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2), |
| 18785 | & VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2), |
| 18786 | & PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2), |
| 18787 | & EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2), |
| 18788 | & ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV , |
| 18789 | & AMRCSQ , ATO1O3 , ZTO1O3 , ELBNDE (0:100) |
| 18790 | * (original name: PAREVT) |
| 18791 | LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX, |
| 18792 | & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF |
| 18793 | PARAMETER ( NALLWP = 39 ) |
| 18794 | COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, |
| 18795 | & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY, |
| 18796 | & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV, |
| 18797 | & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF |
| 18798 | * event flag |
| 18799 | COMMON /DTEVNO/ NEVENT,ICASCA |
| 18800 | |
| 18801 | DIMENSION INUC(2),IDXPAR(2),IDPAR(2),AIF(2),AIZF(2),AMRCL(2), |
| 18802 | & PRCL(2,4),MO1(2),MO2(2),VRCL(2,4),WRCL(2,4), |
| 18803 | & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4) |
| 18804 | |
| 18805 | DIMENSION EXPNUC(2),EXC(2,260),NEXC(2,260) |
| 18806 | LOGICAL LLCPOT |
| 18807 | DATA EXC,NEXC /520*ZERO,520*0/ |
| 18808 | DATA EXPNUC /4.0D-3,4.0D-3/ |
| 18809 | |
| 18810 | IREJ = 0 |
| 18811 | LRCLPR = .FALSE. |
| 18812 | LRCLTA = .FALSE. |
| 18813 | |
| 18814 | * skip residual nucleus treatment if not requested or in case |
| 18815 | * of central collisions |
| 18816 | IF ((.NOT.LEVPRT).OR.(ICENTR.GT.0).OR.(ICENTR.EQ.-1)) RETURN |
| 18817 | |
| 18818 | DO 1 K=1,2 |
| 18819 | IDPAR(K) = 0 |
| 18820 | IDXPAR(K)= 0 |
| 18821 | NTOT(K) = 0 |
| 18822 | NTOTFI(K)= 0 |
| 18823 | NPRO(K) = 0 |
| 18824 | NPROFI(K)= 0 |
| 18825 | NN(K) = 0 |
| 18826 | NH(K) = 0 |
| 18827 | NHPOS(K) = 0 |
| 18828 | NQ(K) = 0 |
| 18829 | EEXC(K) = ZERO |
| 18830 | MO1(K) = 0 |
| 18831 | MO2(K) = 0 |
| 18832 | DO 2 I=1,4 |
| 18833 | VRCL(K,I) = ZERO |
| 18834 | WRCL(K,I) = ZERO |
| 18835 | 2 CONTINUE |
| 18836 | 1 CONTINUE |
| 18837 | NFSP = 0 |
| 18838 | INUC(1) = IP |
| 18839 | INUC(2) = IT |
| 18840 | |
| 18841 | DO 3 I=1,NHKK |
| 18842 | |
| 18843 | * number of final state particles |
| 18844 | IF (ABS(ISTHKK(I)).EQ.1) THEN |
| 18845 | NFSP = NFSP+1 |
| 18846 | IDFSP = IDBAM(I) |
| 18847 | ENDIF |
| 18848 | |
| 18849 | * properties of remaining nucleon configurations |
| 18850 | KF = 0 |
| 18851 | IF ((ISTHKK(I).EQ.13).OR.(ISTHKK(I).EQ.15)) KF = 1 |
| 18852 | IF ((ISTHKK(I).EQ.14).OR.(ISTHKK(I).EQ.16)) KF = 2 |
| 18853 | IF (KF.GT.0) THEN |
| 18854 | IF (MO1(KF).EQ.0) MO1(KF) = I |
| 18855 | MO2(KF) = I |
| 18856 | * position of residual nucleus = average position of nucleons |
| 18857 | DO 4 K=1,4 |
| 18858 | VRCL(KF,K) = VRCL(KF,K)+VHKK(K,I) |
| 18859 | WRCL(KF,K) = WRCL(KF,K)+WHKK(K,I) |
| 18860 | 4 CONTINUE |
| 18861 | * total number of particles contributing to each residual nucleus |
| 18862 | NTOT(KF) = NTOT(KF)+1 |
| 18863 | IDTMP = IDBAM(I) |
| 18864 | IDXTMP = I |
| 18865 | * total charge of residual nuclei |
| 18866 | NQ(KF) = NQ(KF)+IICH(IDTMP) |
| 18867 | * number of protons |
| 18868 | IF (IDHKK(I).EQ.2212) THEN |
| 18869 | NPRO(KF) = NPRO(KF)+1 |
| 18870 | * number of neutrons |
| 18871 | ELSEIF (IDHKK(I).EQ.2112) THEN |
| 18872 | NN(KF) = NN(KF)+1 |
| 18873 | ELSE |
| 18874 | * number of baryons other than n, p |
| 18875 | IF (IIBAR(IDTMP).EQ.1) THEN |
| 18876 | NH(KF) = NH(KF)+1 |
| 18877 | IF (IICH(IDTMP).EQ.1) NHPOS(KF) = NHPOS(KF)+1 |
| 18878 | ELSE |
| 18879 | * any other mesons (status set to 1) |
| 18880 | C WRITE(LOUT,1002) KF,IDTMP |
| 18881 | C1002 FORMAT(1X,'FICONF: residual nucleus ',I2, |
| 18882 | C & ' containing meson ',I4,', status set to 1') |
| 18883 | ISTHKK(I) = 1 |
| 18884 | IDTMP = IDPAR(KF) |
| 18885 | IDXTMP = IDXPAR(KF) |
| 18886 | NTOT(KF) = NTOT(KF)-1 |
| 18887 | ENDIF |
| 18888 | ENDIF |
| 18889 | IDPAR(KF) = IDTMP |
| 18890 | IDXPAR(KF) = IDXTMP |
| 18891 | ENDIF |
| 18892 | 3 CONTINUE |
| 18893 | |
| 18894 | * reject elastic events (def: one final state particle = projectile) |
| 18895 | IF ((IP.EQ.1).AND.(NFSP.EQ.1).AND.(IDFSP.EQ.IJPROJ)) THEN |
| 18896 | IREXCI(3) = IREXCI(3)+1 |
| 18897 | GOTO 9999 |
| 18898 | C RETURN |
| 18899 | ENDIF |
| 18900 | |
| 18901 | * check if one nucleus disappeared.. |
| 18902 | C IF ((IP.GT.1).AND.(NTOT(1).EQ.0).AND.(NTOT(2).NE.0)) THEN |
| 18903 | C DO 5 K=1,4 |
| 18904 | C PRCLTA(K) = PRCLTA(K)+PRCLPR(K) |
| 18905 | C PRCLPR(K) = ZERO |
| 18906 | C 5 CONTINUE |
| 18907 | C ELSEIF ((IT.GT.1).AND.(NTOT(2).EQ.0).AND.(NTOT(1).NE.0)) THEN |
| 18908 | C DO 6 K=1,4 |
| 18909 | C PRCLPR(K) = PRCLPR(K)+PRCLTA(K) |
| 18910 | C PRCLTA(K) = ZERO |
| 18911 | C 6 CONTINUE |
| 18912 | C ENDIF |
| 18913 | |
| 18914 | ICOR = 0 |
| 18915 | INORCL = 0 |
| 18916 | DO 7 I=1,2 |
| 18917 | DO 8 K=1,4 |
| 18918 | * get the average of the nucleon positions |
| 18919 | VRCL(I,K) = VRCL(I,K)/MAX(NTOT(I),1) |
| 18920 | WRCL(I,K) = WRCL(I,K)/MAX(NTOT(I),1) |
| 18921 | IF (I.EQ.1) PRCL(1,K) = PRCLPR(K) |
| 18922 | IF (I.EQ.2) PRCL(2,K) = PRCLTA(K) |
| 18923 | 8 CONTINUE |
| 18924 | * mass number and charge of residual nuclei |
| 18925 | AIF(I) = DBLE(NTOT(I)) |
| 18926 | AIZF(I) = DBLE(NPRO(I)+NHPOS(I)) |
| 18927 | IF (NTOT(I).GT.1) THEN |
| 18928 | * masses of residual nuclei in ground state |
| 18929 | AMRCL0(I) = AIF(I)*AMUAMU+1.0D-3*DT_ENERGY(AIF(I),AIZF(I)) |
| 18930 | * masses of residual nuclei |
| 18931 | PTORCL = SQRT(PRCL(I,1)**2+PRCL(I,2)**2+PRCL(I,3)**2) |
| 18932 | AMRCL(I) = (PRCL(I,4)-PTORCL)*(PRCL(I,4)+PTORCL) |
| 18933 | IF (AMRCL(I).GT.ZERO) AMRCL(I) = SQRT(AMRCL(I)) |
| 18934 | * |
| 18935 | * M_res^2 < 0 : configuration not allowed |
| 18936 | * |
| 18937 | * a) re-calculate E_exc with scaled nuclear potential |
| 18938 | * (conditional jump to label 9998) |
| 18939 | * b) or reject event if N_loop(max) is exceeded |
| 18940 | * (conditional jump to label 9999) |
| 18941 | * |
| 18942 | IF (AMRCL(I).LE.ZERO) THEN |
| 18943 | IF (IOULEV(3).GT.0) |
| 18944 | & WRITE(LOUT,1000) I,PRCL(I,1),PRCL(I,2),PRCL(I,3), |
| 18945 | & PRCL(I,4),NTOT |
| 18946 | 1000 FORMAT(1X,'warning! negative excitation energy',/, |
| 18947 | & I4,4E15.4,2I4) |
| 18948 | AMRCL(I) = ZERO |
| 18949 | EEXC(I) = ZERO |
| 18950 | IF (NLOOP.LE.500) THEN |
| 18951 | GOTO 9998 |
| 18952 | ELSE |
| 18953 | IREXCI(2) = IREXCI(2)+1 |
| 18954 | GOTO 9999 |
| 18955 | ENDIF |
| 18956 | * |
| 18957 | * 0 < M_res < M_res0 : mass below ground-state mass |
| 18958 | * |
| 18959 | * a) we had residual nuclei with mass N_tot and reasonable E_exc |
| 18960 | * before- assign average E_exc of those configurations to this |
| 18961 | * one ( Nexc(i,N_tot) > 0 ) |
| 18962 | * b) or (and this applies always if run in transport codes) go up |
| 18963 | * one mass number and |
| 18964 | * i) if mass now larger than proj/targ mass or if run in |
| 18965 | * transport codes assign average E_exc per wounded nucleon |
| 18966 | * x number of wounded nucleons (Inuc-Ntot) |
| 18967 | * ii) or assign average E_exc of those configurations to this |
| 18968 | * one ( Nexc(i,m) > 0 ) |
| 18969 | * |
| 18970 | ELSEIF ((AMRCL(I).GT.ZERO).AND.(AMRCL(I).LT.AMRCL0(I))) |
| 18971 | & THEN |
| 18972 | M = MIN(NTOT(I),260) |
| 18973 | IF (NEXC(I,M).GT.0) THEN |
| 18974 | AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M)) |
| 18975 | ELSE |
| 18976 | 70 CONTINUE |
| 18977 | M = M+1 |
| 18978 | **sr corrected 27.12.06 |
| 18979 | * IF (M.GE.INUC(I)) THEN |
| 18980 | * AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I)) |
| 18981 | IF ((M.GE.INUC(I)).OR.(ICASCA.GT.0)) THEN |
| 18982 | IF ( INUC (I) .GT. NTOT (I) ) THEN |
| 18983 | AMRCL(I) = AMRCL0(I) |
| 18984 | & + EXPNUC(I)*DBLE(MAX(INUC(I)-NTOT(I),0)) |
| 18985 | ELSE |
| 18986 | AMRCL(I) = AMRCL0(I) + 0.5D+00 * EXPNUC(I) |
| 18987 | END IF |
| 18988 | ** |
| 18989 | ELSE |
| 18990 | IF (NEXC(I,M).GT.0) THEN |
| 18991 | AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M)) |
| 18992 | ELSE |
| 18993 | GOTO 70 |
| 18994 | ENDIF |
| 18995 | ENDIF |
| 18996 | ENDIF |
| 18997 | EEXC(I) = AMRCL(I)-AMRCL0(I) |
| 18998 | ICOR = ICOR+I |
| 18999 | * |
| 19000 | * M_res > 2.5 x M_res0 : unreasonably(?) high E_exc |
| 19001 | * |
| 19002 | * a) re-calculate E_exc with scaled nuclear potential |
| 19003 | * (conditional jump to label 9998) |
| 19004 | * b) or reject event if N_loop(max) is exceeded |
| 19005 | * (conditional jump to label 9999) |
| 19006 | * |
| 19007 | * |
| 19008 | ELSEIF (AMRCL(I).GE.2.5D0*AMRCL0(I)) THEN |
| 19009 | IF (IOULEV(3).GT.0) |
| 19010 | & WRITE(LOUT,1004) I,AMRCL(I),AMRCL0(I),NTOT,NEVHKK |
| 19011 | 1004 FORMAT(1X,'warning! too high excitation energy',/, |
| 19012 | & I4,1P,2E15.4,3I5) |
| 19013 | AMRCL(I) = ZERO |
| 19014 | EEXC(I) = ZERO |
| 19015 | IF (NLOOP.LE.500) THEN |
| 19016 | GOTO 9998 |
| 19017 | ELSE |
| 19018 | IREXCI(2) = IREXCI(2)+1 |
| 19019 | GOTO 9999 |
| 19020 | ENDIF |
| 19021 | * |
| 19022 | * Otherwise (reasonable E_exc) : |
| 19023 | * E_exc = M_res - M_res0 |
| 19024 | * in addition: calculate and save E_exc per wounded nucleon as |
| 19025 | * well as E_exc in <E_exc> counter |
| 19026 | * |
| 19027 | ELSE |
| 19028 | * excitation energies of residual nuclei |
| 19029 | EEXC(I) = AMRCL(I)-AMRCL0(I) |
| 19030 | **sr 27.12.06 new excitation energy correction by A.F. |
| 19031 | * |
| 19032 | * all parts with Ilcopt<3 commented since not used |
| 19033 | * |
| 19034 | * still to be done/decided: |
| 19035 | * Increase Icor and put back both residual nuclei on mass shell |
| 19036 | * with the exciting correction further below. |
| 19037 | * For the moment the modification in the excitation energy is simply |
| 19038 | * corrected by scaling the energy of the residual nucleus. |
| 19039 | * |
| 19040 | LLCPOT = .TRUE. |
| 19041 | ILCOPT = 3 |
| 19042 | IF ( LLCPOT ) THEN |
| 19043 | NNCHIT = MAX ( INUC (I) - NTOT (I), 0 ) |
| 19044 | IF ( ILCOPT .LE. 2 ) THEN |
| 19045 | C* Patch for Fermi momentum reduction correlated with impact parameter: |
| 19046 | C FRMRDC = MIN ( (PFRMAV(INUC(I))/APFRMX)**3, ONE ) |
| 19047 | C DLKPRH = 0.1D+00 + 0.5D+00 / SQRT(DBLE(INUC(I))) |
| 19048 | C AKPRHO = ONE - DLKPRH |
| 19049 | C* f x K rho_cen + (1-f) x 0.5 x K rho_cen = frmrdc x rho_cen |
| 19050 | C FRCFLL = MAX ( 2.D+00 * FRMRDC / AKPRHO - ONE, |
| 19051 | C & 0.05D+00 ) |
| 19052 | C* REDORI = 0.75D+00 |
| 19053 | C* REDORI = ONE |
| 19054 | C REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00) |
| 19055 | ELSE |
| 19056 | DLKPRH = ZERO |
| 19057 | RDCORE = 1.14D+00 * DBLE(INUC(I))**(ONE/3.D+00) |
| 19058 | * Take out roughly one/half of the skin: |
| 19059 | RDCORE = RDCORE - 0.5D+00 |
| 19060 | FRCFLL = RDCORE**3 |
| 19061 | PRSKIN = (RDCORE+2.4D+00)**3 - FRCFLL |
| 19062 | PRSKIN = 0.5D+00 * PRSKIN / ( PRSKIN + FRCFLL ) |
| 19063 | FRCFLL = ONE - PRSKIN |
| 19064 | FRMRDC = FRCFLL + 0.5D+00 * PRSKIN |
| 19065 | REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00) |
| 19066 | END IF |
| 19067 | IF ( NNCHIT .GT. 0 ) THEN |
| 19068 | C IF ( ILCOPT .EQ. 1 ) THEN |
| 19069 | C SKINRH = ONE - FRCFLL / (DBLE(INUC(I))-ONE) |
| 19070 | C DO 1220 NCH = 1, 10 |
| 19071 | C ETAETA = ( ONE - SKINRH**INUC(I) |
| 19072 | C & - DBLE(INUC(I))* ( ONE - FRCFLL ) |
| 19073 | C & * ( ONE - SKINRH ) ) |
| 19074 | C & / ( SKINRH**INUC(I) - DBLE (INUC(I)) |
| 19075 | C & * ( ONE - FRCFLL) * SKINRH ) |
| 19076 | C SKINRH = SKINRH * ( ONE + ETAETA ) |
| 19077 | C 1220 CONTINUE |
| 19078 | C PRSKIN = SKINRH**(NNCHIT-1) |
| 19079 | C ELSE IF ( ILCOPT .EQ. 2 ) THEN |
| 19080 | C PRSKIN = ONE - FRCFLL |
| 19081 | C END IF |
| 19082 | REDCTN = ZERO |
| 19083 | DO 1230 NCH = 1, NNCHIT |
| 19084 | IF (DT_RNDM(PRFRMI) .LT. PRSKIN) THEN |
| 19085 | PRFRMI = (( ONE - 2.D+00 * DLKPRH ) |
| 19086 | & * DT_RNDM(PRFRMI))**0.333333333333D+00 |
| 19087 | ELSE |
| 19088 | PRFRMI = ( ONE - 2.D+00 * DLKPRH |
| 19089 | & * DT_RNDM(PRFRMI))**0.333333333333D+00 |
| 19090 | END IF |
| 19091 | REDCTN = REDCTN + PRFRMI**2 |
| 19092 | 1230 CONTINUE |
| 19093 | REDCTN = REDCTN / DBLE (NNCHIT) |
| 19094 | ELSE |
| 19095 | REDCTN = 0.5D+00 |
| 19096 | END IF |
| 19097 | EEXC (I) = EEXC (I) * REDCTN / REDORI |
| 19098 | AMRCL (I) = AMRCL0 (I) + EEXC (I) |
| 19099 | PRCL(I,4) = SQRT ( PTORCL**2 + AMRCL(I)**2 ) |
| 19100 | END IF |
| 19101 | ** |
| 19102 | IF (ICASCA.EQ.0) THEN |
| 19103 | EXPNUC(I) = EEXC(I)/MAX(1,INUC(I)-NTOT(I)) |
| 19104 | M = MIN(NTOT(I),260) |
| 19105 | EXC(I,M) = EXC(I,M)+EEXC(I) |
| 19106 | NEXC(I,M) = NEXC(I,M)+1 |
| 19107 | ENDIF |
| 19108 | ENDIF |
| 19109 | ELSEIF (NTOT(I).EQ.1) THEN |
| 19110 | WRITE(LOUT,1003) I |
| 19111 | 1003 FORMAT(1X,'FICONF: warning! NTOT(I)=1? (I=',I3,')') |
| 19112 | GOTO 9999 |
| 19113 | ELSE |
| 19114 | AMRCL0(I) = ZERO |
| 19115 | AMRCL(I) = ZERO |
| 19116 | EEXC(I) = ZERO |
| 19117 | INORCL = INORCL+I |
| 19118 | ENDIF |
| 19119 | 7 CONTINUE |
| 19120 | |
| 19121 | PRCLPR(5) = AMRCL(1) |
| 19122 | PRCLTA(5) = AMRCL(2) |
| 19123 | |
| 19124 | IF (ICOR.GT.0) THEN |
| 19125 | IF (INORCL.EQ.0) THEN |
| 19126 | * one or both residual nuclei consist of one nucleon only, transform |
| 19127 | * this nucleon on mass shell |
| 19128 | DO 9 K=1,4 |
| 19129 | P1IN(K) = PRCL(1,K) |
| 19130 | P2IN(K) = PRCL(2,K) |
| 19131 | 9 CONTINUE |
| 19132 | XM1 = AMRCL(1) |
| 19133 | XM2 = AMRCL(2) |
| 19134 | CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1) |
| 19135 | IF (IREJ1.GT.0) THEN |
| 19136 | WRITE(LOUT,*) 'ficonf-mashel rejection' |
| 19137 | GOTO 9999 |
| 19138 | ENDIF |
| 19139 | DO 10 K=1,4 |
| 19140 | PRCL(1,K) = P1OUT(K) |
| 19141 | PRCL(2,K) = P2OUT(K) |
| 19142 | PRCLPR(K) = P1OUT(K) |
| 19143 | PRCLTA(K) = P2OUT(K) |
| 19144 | 10 CONTINUE |
| 19145 | PRCLPR(5) = AMRCL(1) |
| 19146 | PRCLTA(5) = AMRCL(2) |
| 19147 | ELSE |
| 19148 | IF (IOULEV(3).GT.0) |
| 19149 | & WRITE(LOUT,1001) NEVHKK,INT(AIF(1)),INT(AIZF(1)), |
| 19150 | & INT(AIF(2)),INT(AIZF(2)),AMRCL0(1), |
| 19151 | & AMRCL(1),AMRCL(1)-AMRCL0(1),AMRCL0(2), |
| 19152 | & AMRCL(2),AMRCL(2)-AMRCL0(2) |
| 19153 | 1001 FORMAT(1X,'FICONF: warning! no residual nucleus for', |
| 19154 | & ' correction',/,11X,'at event',I8, |
| 19155 | & ', nucleon config. 1:',2I4,' 2:',2I4, |
| 19156 | & 2(/,11X,3E12.3)) |
| 19157 | IF (NLOOP.LE.500) THEN |
| 19158 | GOTO 9998 |
| 19159 | ELSE |
| 19160 | IREXCI(1) = IREXCI(1)+1 |
| 19161 | ENDIF |
| 19162 | ENDIF |
| 19163 | ENDIF |
| 19164 | |
| 19165 | * update counter |
| 19166 | C IF (NRESEV(1).NE.NEVHKK) THEN |
| 19167 | C NRESEV(1) = NEVHKK |
| 19168 | C NRESEV(2) = NRESEV(2)+1 |
| 19169 | C ENDIF |
| 19170 | NRESEV(2) = NRESEV(2)+1 |
| 19171 | DO 15 I=1,2 |
| 19172 | EXCDPM(I) = EXCDPM(I)+EEXC(I) |
| 19173 | EXCDPM(I+2) = EXCDPM(I+2)+(EEXC(I)/MAX(NTOT(I),1)) |
| 19174 | NRESTO(I) = NRESTO(I)+NTOT(I) |
| 19175 | NRESPR(I) = NRESPR(I)+NPRO(I) |
| 19176 | NRESNU(I) = NRESNU(I)+NN(I) |
| 19177 | NRESBA(I) = NRESBA(I)+NH(I) |
| 19178 | NRESPB(I) = NRESPB(I)+NHPOS(I) |
| 19179 | NRESCH(I) = NRESCH(I)+NQ(I) |
| 19180 | 15 CONTINUE |
| 19181 | |
| 19182 | * evaporation |
| 19183 | IF (LEVPRT) THEN |
| 19184 | DO 13 I=1,2 |
| 19185 | * initialize evaporation counter |
| 19186 | EEXCFI(I) = ZERO |
| 19187 | IF ((INUC(I).GT.1).AND.(AIF(I).GT.ONE).AND. |
| 19188 | & (EEXC(I).GT.ZERO)) THEN |
| 19189 | * put residual nuclei into DTEVT1 |
| 19190 | IDRCL = 80000 |
| 19191 | JMASS = INT( AIF(I)) |
| 19192 | JCHAR = INT(AIZF(I)) |
| 19193 | * the following patch is required to transmit the correct excitation |
| 19194 | * energy to Eventd |
| 19195 | IF (ITRSPT.EQ.1) THEN |
| 19196 | IF ((ABS(AMRCL(I)-AMRCL0(I)-EEXC(I)).GT.1.D-04).AND. |
| 19197 | & (IOULEV(3).GT.0)) |
| 19198 | & WRITE(LOUT,*) |
| 19199 | & ' DT_FICONF:AMRCL(I),AMRCL0(I),EEXC(I)', |
| 19200 | & AMRCL(I),AMRCL0(I),EEXC(I) |
| 19201 | PRCL0 = PRCL(I,4) |
| 19202 | PRCL(I,4) =SQRT(AMRCL(I)**2+PRCL(I,1)**2+PRCL(I,2)**2 |
| 19203 | & +PRCL(I,3)**2) |
| 19204 | IF (ABS(PRCL0-PRCL(I,4)).GT.0.1D0) THEN |
| 19205 | WRITE(LOUT,*) |
| 19206 | & ' PRCL(I,4) recalculated :',PRCL0,PRCL(I,4) |
| 19207 | ENDIF |
| 19208 | ENDIF |
| 19209 | CALL DT_EVTPUT(1000,IDRCL,MO1(I),MO2(I),PRCL(I,1), |
| 19210 | & PRCL(I,2),PRCL(I,3),PRCL(I,4),JMASS,JCHAR,0) |
| 19211 | **sr 22.6.97 |
| 19212 | NOBAM(NHKK) = I |
| 19213 | ** |
| 19214 | DO 14 J=1,4 |
| 19215 | VHKK(J,NHKK) = VRCL(I,J) |
| 19216 | WHKK(J,NHKK) = WRCL(I,J) |
| 19217 | 14 CONTINUE |
| 19218 | * interface to evaporation module - fill final residual nucleus into |
| 19219 | * common FKRESN |
| 19220 | * fill resnuc only if code is not used as event generator in Fluka |
| 19221 | IF (ITRSPT.NE.1) THEN |
| 19222 | PXRES = PRCL(I,1) |
| 19223 | PYRES = PRCL(I,2) |
| 19224 | PZRES = PRCL(I,3) |
| 19225 | IBRES = NPRO(I)+NN(I)+NH(I) |
| 19226 | ICRES = NPRO(I)+NHPOS(I) |
| 19227 | ANOW = DBLE(IBRES) |
| 19228 | ZNOW = DBLE(ICRES) |
| 19229 | PTRES = SQRT(PXRES**2+PYRES**2+PZRES**2) |
| 19230 | * ground state mass of the residual nucleus (should be equal to AM0T) |
| 19231 | AMMRES = AMRCL0(I) |
| 19232 | AMNRES = AMMRES-ZNOW*AMELEC+ELBNDE(ICRES) |
| 19233 | * common FKFINU |
| 19234 | TV = ZERO |
| 19235 | * kinetic energy of residual nucleus |
| 19236 | TVRECL = PRCL(I,4)-AMRCL(I) |
| 19237 | * excitation energy of residual nucleus |
| 19238 | TVCMS = EEXC(I) |
| 19239 | PTOLD = PTRES |
| 19240 | PTRES = SQRT(ABS(TVRECL*(TVRECL+ |
| 19241 | & 2.0D0*(AMMRES+TVCMS)))) |
| 19242 | IF (PTOLD.LT.ANGLGB) THEN |
| 19243 | CALL DT_RACO(PXRES,PYRES,PZRES) |
| 19244 | PTOLD = ONE |
| 19245 | ENDIF |
| 19246 | PXRES = PXRES*PTRES/PTOLD |
| 19247 | PYRES = PYRES*PTRES/PTOLD |
| 19248 | PZRES = PZRES*PTRES/PTOLD |
| 19249 | * zero counter of secondaries from evaporation |
| 19250 | NP = 0 |
| 19251 | * evaporation |
| 19252 | WE = ONE |
| 19253 | CALL DT_EVEVAP(WE) |
| 19254 | * put evaporated particles and residual nuclei to DTEVT1 |
| 19255 | MO = NHKK |
| 19256 | CALL DT_EVA2HE(MO,EXCITF,I,IREJ1) |
| 19257 | ENDIF |
| 19258 | EEXCFI(I) = EXCITF |
| 19259 | EXCEVA(I) = EXCEVA(I)+EXCITF |
| 19260 | ENDIF |
| 19261 | 13 CONTINUE |
| 19262 | ENDIF |
| 19263 | |
| 19264 | RETURN |
| 19265 | |
| 19266 | C9998 IREXCI(1) = IREXCI(1)+1 |
| 19267 | 9998 IREJ = IREJ+1 |
| 19268 | 9999 CONTINUE |
| 19269 | LRCLPR = .TRUE. |
| 19270 | LRCLTA = .TRUE. |
| 19271 | IREJ = IREJ+1 |
| 19272 | RETURN |
| 19273 | END |
| 19274 | |
| 19275 | *$ CREATE DT_EVA2HE.FOR |
| 19276 | *COPY DT_EVA2HE |
| 19277 | * * |
| 19278 | *====eva2he============================================================* |
| 19279 | * * |
| 19280 | SUBROUTINE DT_EVA2HE(MO,EEXCF,IRCL,IREJ) |
| 19281 | |
| 19282 | ************************************************************************ |
| 19283 | * Interface between common's of evaporation module (FKFINU,FKFHVY) * |
| 19284 | * and DTEVT1. * |
| 19285 | * MO DTEVT1-index of "mother" (residual) nucleus before evap. * |
| 19286 | * EEXCF exitation energy of residual nucleus after evaporation * |
| 19287 | * IRCL = 1 projectile residual nucleus * |
| 19288 | * = 2 target residual nucleus * |
| 19289 | * This version dated 19.04.95 is written by S. Roesler. * |
| 19290 | * * |
| 19291 | * Last change 27.12.2006 by S. Roesler. * |
| 19292 | ************************************************************************ |
| 19293 | |
| 19294 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 19295 | SAVE |
| 19296 | PARAMETER ( LINP = 10 , |
| 19297 | & LOUT = 6 , |
| 19298 | & LDAT = 9 ) |
| 19299 | PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3) |
| 19300 | |
| 19301 | * event history |
| 19302 | PARAMETER (NMXHKK=200000) |
| 19303 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 19304 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 19305 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 19306 | * Note: DTEVT2 - special use for heavy fragments ! |
| 19307 | * (IDRES(I) = mass number, IDXRES(I) = charge) |
| 19308 | * extended event history |
| 19309 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 19310 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 19311 | & IHIST(2,NMXHKK) |
| 19312 | * particle properties (BAMJET index convention) |
| 19313 | CHARACTER*8 ANAME |
| 19314 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 19315 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 19316 | * flags for input different options |
| 19317 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 19318 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 19319 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 19320 | * statistics: residual nuclei |
| 19321 | COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2), |
| 19322 | & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2), |
| 19323 | & NINCST(2,4),NINCEV(2), |
| 19324 | & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2), |
| 19325 | & NRESPB(2),NRESCH(2),NRESEV(4), |
| 19326 | & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240), |
| 19327 | & NEVAFI(2,2) |
| 19328 | * treatment of residual nuclei: properties of residual nuclei |
| 19329 | COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2), |
| 19330 | & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2), |
| 19331 | & NTOTFI(2),NPROFI(2) |
| 19332 | * (original name: FINUC) |
| 19333 | PARAMETER (MXP=999) |
| 19334 | COMMON /FKFINU/ CXR (MXP), CYR (MXP), CZR (MXP), |
| 19335 | & CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP), |
| 19336 | & TKI (MXP), PLR (MXP), WEI (MXP), |
| 19337 | & TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP, |
| 19338 | & KPART (MXP) |
| 19339 | * (original name: FHEAVY,FHEAVC) |
| 19340 | PARAMETER ( MXHEAV = 100 ) |
| 19341 | CHARACTER*8 ANHEAV |
| 19342 | COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV), |
| 19343 | & CZHEAV (MXHEAV), TKHEAV (MXHEAV), |
| 19344 | & PHEAVY (MXHEAV), WHEAVY (MXHEAV), |
| 19345 | & AMHEAV ( 12 ) , AMNHEA ( 12 ) , |
| 19346 | & KHEAVY (MXHEAV), ICHEAV ( 12 ) , |
| 19347 | & IBHEAV ( 12 ) , NPHEAV |
| 19348 | COMMON /FKFHVC/ ANHEAV ( 12 ) |
| 19349 | * (original name: RESNUC) |
| 19350 | LOGICAL LRNFSS, LFRAGM |
| 19351 | COMMON /FKRESN/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1, |
| 19352 | & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT, |
| 19353 | & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES, |
| 19354 | & PYRES, PZRES, PTRES2, KTARP, KTARN, IGREYP, |
| 19355 | & IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE, |
| 19356 | & ICRES, IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU, |
| 19357 | & IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG, |
| 19358 | & IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS, |
| 19359 | & LFRAGM |
| 19360 | |
| 19361 | DIMENSION IPTOKP(39) |
| 19362 | DATA IPTOKP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, |
| 19363 | & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 99, |
| 19364 | & 100, 101, 97, 102, 98, 103, 109, 115 / |
| 19365 | |
| 19366 | IREJ = 0 |
| 19367 | |
| 19368 | * skip if evaporation package is not included |
| 19369 | IF (.NOT.LEVAPO) RETURN |
| 19370 | |
| 19371 | * update counter |
| 19372 | IF (NRESEV(3).NE.NEVHKK) THEN |
| 19373 | NRESEV(3) = NEVHKK |
| 19374 | NRESEV(4) = NRESEV(4)+1 |
| 19375 | ENDIF |
| 19376 | |
| 19377 | IF (LEMCCK) |
| 19378 | & CALL DT_EVTEMC(PHKK(1,MO),PHKK(2,MO),PHKK(3,MO),PHKK(4,MO),1, |
| 19379 | & IDUM,IDUM) |
| 19380 | * mass number/charge of residual nucleus before evaporation |
| 19381 | IBTOT = IDRES(MO) |
| 19382 | IZTOT = IDXRES(MO) |
| 19383 | |
| 19384 | * protons/neutrons/gammas |
| 19385 | DO 1 I=1,NP |
| 19386 | PX = CXR(I)*PLR(I) |
| 19387 | PY = CYR(I)*PLR(I) |
| 19388 | PZ = CZR(I)*PLR(I) |
| 19389 | ID = IPTOKP(KPART(I)) |
| 19390 | IDPDG = IDT_IPDGHA(ID) |
| 19391 | AM = ((PLR(I)+TKI(I))*(PLR(I)-TKI(I)))/ |
| 19392 | & (2.0D0*MAX(TKI(I),TINY10)) |
| 19393 | IF (ABS(AM-AAM(ID)).GT.TINY3) THEN |
| 19394 | WRITE(LOUT,1000) ID,AM,AAM(ID) |
| 19395 | 1000 FORMAT(1X,'EVA2HE: inconsistent mass of evap. ', |
| 19396 | & 'particle',I3,2E10.3) |
| 19397 | ENDIF |
| 19398 | PE = TKI(I)+AM |
| 19399 | CALL DT_EVTPUT(-1,IDPDG,MO,0,PX,PY,PZ,PE,0,0,0) |
| 19400 | NOBAM(NHKK) = IRCL |
| 19401 | IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM) |
| 19402 | IBTOT = IBTOT-IIBAR(ID) |
| 19403 | IZTOT = IZTOT-IICH(ID) |
| 19404 | 1 CONTINUE |
| 19405 | |
| 19406 | * heavy fragments |
| 19407 | DO 2 I=1,NPHEAV |
| 19408 | PX = CXHEAV(I)*PHEAVY(I) |
| 19409 | PY = CYHEAV(I)*PHEAVY(I) |
| 19410 | PZ = CZHEAV(I)*PHEAVY(I) |
| 19411 | IDHEAV = 80000 |
| 19412 | AM = ((PHEAVY(I)+TKHEAV(I))*(PHEAVY(I)-TKHEAV(I)))/ |
| 19413 | & (2.0D0*MAX(TKHEAV(I),TINY10)) |
| 19414 | PE = TKHEAV(I)+AM |
| 19415 | CALL DT_EVTPUT(-1,IDHEAV,MO,0,PX,PY,PZ,PE, |
| 19416 | & IBHEAV(KHEAVY(I)),ICHEAV(KHEAVY(I)),0) |
| 19417 | NOBAM(NHKK) = IRCL |
| 19418 | IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM) |
| 19419 | IBTOT = IBTOT-IBHEAV(KHEAVY(I)) |
| 19420 | IZTOT = IZTOT-ICHEAV(KHEAVY(I)) |
| 19421 | 2 CONTINUE |
| 19422 | |
| 19423 | IF (IBRES.GT.0) THEN |
| 19424 | * residual nucleus after evaporation |
| 19425 | IDNUC = 80000 |
| 19426 | CALL DT_EVTPUT(1001,IDNUC,MO,0,PXRES,PYRES,PZRES,ERES, |
| 19427 | & IBRES,ICRES,0) |
| 19428 | NOBAM(NHKK) = IRCL |
| 19429 | ENDIF |
| 19430 | EEXCF = TVCMS |
| 19431 | NTOTFI(IRCL) = IBRES |
| 19432 | NPROFI(IRCL) = ICRES |
| 19433 | IF (LEMCCK) CALL DT_EVTEMC(-PXRES,-PYRES,-PZRES,-ERES,2,IDUM,IDUM) |
| 19434 | IBTOT = IBTOT-IBRES |
| 19435 | IZTOT = IZTOT-ICRES |
| 19436 | |
| 19437 | * count events with fission |
| 19438 | NEVAFI(1,IRCL) = NEVAFI(1,IRCL)+1 |
| 19439 | IF (LRNFSS) NEVAFI(2,IRCL) = NEVAFI(2,IRCL)+1 |
| 19440 | |
| 19441 | * energy-momentum conservation check |
| 19442 | IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,40,IREJ) |
| 19443 | C IF (IREJ.GT.0) THEN |
| 19444 | C CALL DT_EVTOUT(4) |
| 19445 | C WRITE(*,*) EEXC(2),EEXCFI(2),NP,NPHEAV |
| 19446 | C ENDIF |
| 19447 | * baryon-number/charge conservation check |
| 19448 | IF (IBTOT+IZTOT.NE.0) THEN |
| 19449 | WRITE(LOUT,1001) NEVHKK,IBTOT,IZTOT |
| 19450 | 1001 FORMAT(1X,'EVA2HE: baryon-number/charge conservation ', |
| 19451 | & 'failure at event ',I8,' : IBTOT,IZTOT = ',2I3) |
| 19452 | ENDIF |
| 19453 | |
| 19454 | RETURN |
| 19455 | END |
| 19456 | |
| 19457 | *$ CREATE DT_EBIND.FOR |
| 19458 | *COPY DT_EBIND |
| 19459 | * |
| 19460 | *===ebind==============================================================* |
| 19461 | * |
| 19462 | DOUBLE PRECISION FUNCTION DT_EBIND(IA,IZ) |
| 19463 | |
| 19464 | ************************************************************************ |
| 19465 | * Binding energy for nuclei. * |
| 19466 | * (Shirokov & Yudin, Yad. Fizika, Nauka, Moskva 1972) * |
| 19467 | * IA mass number * |
| 19468 | * IZ atomic number * |
| 19469 | * This version dated 5.5.95 is updated by S. Roesler. * |
| 19470 | ************************************************************************ |
| 19471 | |
| 19472 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 19473 | SAVE |
| 19474 | PARAMETER ( LINP = 10 , |
| 19475 | & LOUT = 6 , |
| 19476 | & LDAT = 9 ) |
| 19477 | PARAMETER (ZERO=0.0D0) |
| 19478 | |
| 19479 | DATA A1, A2, A3, A4, A5 |
| 19480 | & / 0.01575D0, 0.0178D0, 0.000710D0, 0.0237D0, 0.034D0/ |
| 19481 | |
| 19482 | IF ((IA.LE.1).OR.(IZ.EQ.0)) THEN |
| 19483 | WRITE(LOUT,'(1X,A,2I5)') 'DT_EBIND IA,IZ set EBIND=0. ',IA,IZ |
| 19484 | DT_EBIND = ZERO |
| 19485 | RETURN |
| 19486 | ENDIF |
| 19487 | AA = IA |
| 19488 | DT_EBIND = A1*AA - A2*AA**0.666667D0-A3*IZ*IZ*AA**(-0.333333D0) |
| 19489 | & -A4*(IA-2*IZ)**2/AA |
| 19490 | IF (MOD(IA,2).EQ.1) THEN |
| 19491 | IA5 = 0 |
| 19492 | ELSEIF (MOD(IZ,2).EQ.1) THEN |
| 19493 | IA5 = 1 |
| 19494 | ELSE |
| 19495 | IA5 = -1 |
| 19496 | ENDIF |
| 19497 | DT_EBIND = DT_EBIND - IA5*A5*AA**(-0.75D0) |
| 19498 | |
| 19499 | RETURN |
| 19500 | END |
| 19501 | |
| 19502 | **sr 30.6. routine replaced completely |
| 19503 | *$ CREATE DT_ENERGY.FOR |
| 19504 | *COPY DT_ENERGY |
| 19505 | * * |
| 19506 | *=== energy ===========================================================* |
| 19507 | * * |
| 19508 | DOUBLE PRECISION FUNCTION DT_ENERGY( A, Z ) |
| 19509 | |
| 19510 | C INCLUDE '(DBLPRC)' |
| 19511 | * DBLPRC.ADD |
| 19512 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 19513 | SAVE |
| 19514 | * (original name: GLOBAL) |
| 19515 | PARAMETER ( KALGNM = 2 ) |
| 19516 | PARAMETER ( ANGLGB = 5.0D-16 ) |
| 19517 | PARAMETER ( ANGLSQ = 2.5D-31 ) |
| 19518 | PARAMETER ( AXCSSV = 0.2D+16 ) |
| 19519 | PARAMETER ( ANDRFL = 1.0D-38 ) |
| 19520 | PARAMETER ( AVRFLW = 1.0D+38 ) |
| 19521 | PARAMETER ( AINFNT = 1.0D+30 ) |
| 19522 | PARAMETER ( AZRZRZ = 1.0D-30 ) |
| 19523 | PARAMETER ( EINFNT = +69.07755278982137 D+00 ) |
| 19524 | PARAMETER ( EZRZRZ = -69.07755278982137 D+00 ) |
| 19525 | PARAMETER ( EXCSSV = +35.23192357547063 D+00 ) |
| 19526 | PARAMETER ( ENGLGB = -35.23192357547063 D+00 ) |
| 19527 | PARAMETER ( ONEMNS = 0.999999999999999 D+00 ) |
| 19528 | PARAMETER ( ONEPLS = 1.000000000000001 D+00 ) |
| 19529 | PARAMETER ( CSNNRM = 2.0D-15 ) |
| 19530 | PARAMETER ( DMXTRN = 1.0D+08 ) |
| 19531 | PARAMETER ( ZERZER = 0.D+00 ) |
| 19532 | PARAMETER ( ONEONE = 1.D+00 ) |
| 19533 | PARAMETER ( TWOTWO = 2.D+00 ) |
| 19534 | PARAMETER ( THRTHR = 3.D+00 ) |
| 19535 | PARAMETER ( FOUFOU = 4.D+00 ) |
| 19536 | PARAMETER ( FIVFIV = 5.D+00 ) |
| 19537 | PARAMETER ( SIXSIX = 6.D+00 ) |
| 19538 | PARAMETER ( SEVSEV = 7.D+00 ) |
| 19539 | PARAMETER ( EIGEIG = 8.D+00 ) |
| 19540 | PARAMETER ( ANINEN = 9.D+00 ) |
| 19541 | PARAMETER ( TENTEN = 10.D+00 ) |
| 19542 | PARAMETER ( HLFHLF = 0.5D+00 ) |
| 19543 | PARAMETER ( ONETHI = ONEONE / THRTHR ) |
| 19544 | PARAMETER ( TWOTHI = TWOTWO / THRTHR ) |
| 19545 | PARAMETER ( ONEFOU = ONEONE / FOUFOU ) |
| 19546 | PARAMETER ( THRTWO = THRTHR / TWOTWO ) |
| 19547 | PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 ) |
| 19548 | PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 ) |
| 19549 | PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 ) |
| 19550 | PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 ) |
| 19551 | PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 ) |
| 19552 | PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 ) |
| 19553 | PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 ) |
| 19554 | PARAMETER ( EULERO = 0.577215664901532860606512 D+00 ) |
| 19555 | PARAMETER ( EULEXP = 1.781072417990197985236504 D+00 ) |
| 19556 | PARAMETER ( EULLOG =-0.5495393129816448223376619 D+00 ) |
| 19557 | PARAMETER ( E1M2EU = 0.8569023337737540831433017 D+00 ) |
| 19558 | PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 ) |
| 19559 | PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 ) |
| 19560 | PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 ) |
| 19561 | PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 ) |
| 19562 | PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 ) |
| 19563 | PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 ) |
| 19564 | PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 ) |
| 19565 | PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 ) |
| 19566 | PARAMETER ( CLIGHT = 2.99792458 D+10 ) |
| 19567 | PARAMETER ( AVOGAD = 6.0221367 D+23 ) |
| 19568 | PARAMETER ( BOLTZM = 1.380658 D-23 ) |
| 19569 | PARAMETER ( AMELGR = 9.1093897 D-28 ) |
| 19570 | PARAMETER ( PLCKBR = 1.05457266 D-27 ) |
| 19571 | PARAMETER ( ELCCGS = 4.8032068 D-10 ) |
| 19572 | PARAMETER ( ELCMKS = 1.60217733 D-19 ) |
| 19573 | PARAMETER ( AMUGRM = 1.6605402 D-24 ) |
| 19574 | PARAMETER ( AMMUMU = 0.113428913 D+00 ) |
| 19575 | PARAMETER ( AMPRMU = 1.007276470 D+00 ) |
| 19576 | PARAMETER ( AMNEMU = 1.008664904 D+00 ) |
| 19577 | PARAMETER ( ALPFSC = 7.2973530791728595 D-03 ) |
| 19578 | PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 ) |
| 19579 | PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 ) |
| 19580 | PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 ) |
| 19581 | PARAMETER ( PLABRC = 0.197327053 D+00 ) |
| 19582 | PARAMETER ( AMELCT = 0.51099906 D-03 ) |
| 19583 | PARAMETER ( AMUGEV = 0.93149432 D+00 ) |
| 19584 | PARAMETER ( AMMUON = 0.105658389 D+00 ) |
| 19585 | PARAMETER ( AMPRTN = 0.93827231 D+00 ) |
| 19586 | PARAMETER ( AMNTRN = 0.93956563 D+00 ) |
| 19587 | PARAMETER ( AMDEUT = 1.87561339 D+00 ) |
| 19588 | PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13 |
| 19589 | & * 1.D-09 ) |
| 19590 | PARAMETER ( RCLSEL = 2.8179409183694872 D-13 ) |
| 19591 | PARAMETER ( BLTZMN = 8.617385 D-14 ) |
| 19592 | PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT ) |
| 19593 | PARAMETER ( GFOHB3 = 1.16639 D-05 ) |
| 19594 | PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC ) |
| 19595 | PARAMETER ( SIN2TW = 0.2319 D+00 ) |
| 19596 | PARAMETER ( GEVMEV = 1.0 D+03 ) |
| 19597 | PARAMETER ( EMVGEV = 1.0 D-03 ) |
| 19598 | PARAMETER ( ALGVMV = 6.90775527898214 D+00 ) |
| 19599 | PARAMETER ( RADDEG = 180.D+00 / PIPIPI ) |
| 19600 | PARAMETER ( DEGRAD = PIPIPI / 180.D+00 ) |
| 19601 | LOGICAL LGBIAS, LGBANA |
| 19602 | COMMON /FKGLOB/ LGBIAS, LGBANA |
| 19603 | C INCLUDE '(DIMPAR)' |
| 19604 | * DIMPAR.ADD |
| 19605 | PARAMETER ( MXXRGN = 5000 ) |
| 19606 | PARAMETER ( MXXMDF = 82 ) |
| 19607 | PARAMETER ( MXXMDE = 54 ) |
| 19608 | PARAMETER ( MFSTCK = 1000 ) |
| 19609 | PARAMETER ( MESTCK = 100 ) |
| 19610 | PARAMETER ( NALLWP = 39 ) |
| 19611 | PARAMETER ( NELEMX = 80 ) |
| 19612 | PARAMETER ( MPDPDX = 8 ) |
| 19613 | PARAMETER ( ICOMAX = 180 ) |
| 19614 | PARAMETER ( NSTBIS = 304 ) |
| 19615 | PARAMETER ( IDMAXP = 220 ) |
| 19616 | PARAMETER ( IDMXDC = 640 ) |
| 19617 | PARAMETER ( MKBMX1 = 1 ) |
| 19618 | PARAMETER ( MKBMX2 = 1 ) |
| 19619 | C INCLUDE '(IOUNIT)' |
| 19620 | * IOUNIT.ADD |
| 19621 | PARAMETER ( LUNIN = 5 ) |
| 19622 | PARAMETER ( LUNOUT = 6 ) |
| 19623 | **sr 19.5. set error output-unit from 15 to 6 |
| 19624 | PARAMETER ( LUNERR = 6 ) |
| 19625 | PARAMETER ( LUNBER = 14 ) |
| 19626 | PARAMETER ( LUNECH = 8 ) |
| 19627 | PARAMETER ( LUNFLU = 13 ) |
| 19628 | PARAMETER ( LUNGEO = 16 ) |
| 19629 | PARAMETER ( LUNPMF = 12 ) |
| 19630 | PARAMETER ( LUNRAN = 2 ) |
| 19631 | PARAMETER ( LUNXSC = 9 ) |
| 19632 | PARAMETER ( LUNDET = 17 ) |
| 19633 | PARAMETER ( LUNRAY = 10 ) |
| 19634 | PARAMETER ( LUNRDB = 1 ) |
| 19635 | PARAMETER ( LUNPGO = 7 ) |
| 19636 | PARAMETER ( LUNPGS = 4 ) |
| 19637 | PARAMETER ( LUNSCR = 3 ) |
| 19638 | * |
| 19639 | *----------------------------------------------------------------------* |
| 19640 | * * |
| 19641 | * Revised version of the original routine from EVAP: * |
| 19642 | * * |
| 19643 | * Created on 15 may 1990 by Alfredo Ferrari & Paola Sala * |
| 19644 | * Infn - Milan * |
| 19645 | * * |
| 19646 | * Last change on 19-sep-95 by Alfredo Ferrari * |
| 19647 | * * |
| 19648 | * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! * |
| 19649 | * !!! It is supposed to be used with the updated atomic !!! * |
| 19650 | * !!! mass data file !!! * |
| 19651 | * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! * |
| 19652 | * * |
| 19653 | *----------------------------------------------------------------------* |
| 19654 | * |
| 19655 | * Mass number below which "unknown" isotopes out of the Z-interval |
| 19656 | * reported in the mass tabulations are completely unstable and made |
| 19657 | * up by Z proton masses + N neutron masses: |
| 19658 | PARAMETER ( KAFREE = 4 ) |
| 19659 | * Mass number below which "unknown" isotopes out of the Z-interval |
| 19660 | * reported in the mass tabulations are supposed to be particle unstable |
| 19661 | PARAMETER ( KAPUNS = 12 ) |
| 19662 | * Minimum energy required for particle unstable isotopes |
| 19663 | PARAMETER ( DEPUNS = 0.5D+00 ) |
| 19664 | * |
| 19665 | * (original name: EVA0) |
| 19666 | COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001), |
| 19667 | * FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6), |
| 19668 | * CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200), |
| 19669 | * T (4,7), RMASS (297), ALPH (297), BET (297), |
| 19670 | * APRIME (250), IA (6), IZ (6) |
| 19671 | * (original name: ISOTOP) |
| 19672 | PARAMETER ( NAMSMX = 270 ) |
| 19673 | PARAMETER ( NZGVAX = 15 ) |
| 19674 | PARAMETER ( NISMMX = 574 ) |
| 19675 | COMMON /FKISOT/ WAPS (NAMSMX,NZGVAX), T12NUC (NAMSMX,NZGVAX), |
| 19676 | & WAPISM (NISMMX), T12ISM (NISMMX), |
| 19677 | & ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260), |
| 19678 | & AMSSST (100) , ISOMNM (NSTBIS), ISONDX (2,100), |
| 19679 | & JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX), |
| 19680 | & INWAPS (NAMSMX), JSPISM (NISMMX), |
| 19681 | & JPTISM (NISMMX), IZWISM (NISMMX), |
| 19682 | & INWISM (0:NAMSMX) |
| 19683 | * |
| 454792a9 |
19684 | CPH SAVE KA0, KZ0, IZ0 |
| 9aaba0d6 |
19685 | DATA KA0, KZ0, IZ0 / -1, -1, -1 / |
| 19686 | * |
| 19687 | IFLAG = 1 |
| 19688 | GO TO 10 |
| 19689 | *======================================================================* |
| 19690 | * * |
| 19691 | * Entry ENergy - KNOWn * |
| 19692 | * * |
| 19693 | *======================================================================* |
| 19694 | ENTRY DT_ENKNOW ( A, Z, IZZ0 ) |
| 19695 | IZZ0 =-1 |
| 19696 | IFLAG = 2 |
| 19697 | 10 CONTINUE |
| 19698 | * |
| 19699 | KA0 = NINT ( A ) |
| 19700 | KZ0 = NINT ( Z ) |
| 19701 | N = KA0 - KZ0 |
| 19702 | * +-------------------------------------------------------------------* |
| 19703 | * | Null residual nucleus: |
| 19704 | IF ( KA0 .EQ. 0 .AND. KZ0 .LE. 0 ) THEN |
| 19705 | IF ( IFLAG .EQ. 1 ) THEN |
| 19706 | DT_ENERGY = ZERZER |
| 19707 | ELSE |
| 19708 | DT_ENKNOW = ZERZER |
| 19709 | IZZ0 = -1 |
| 19710 | END IF |
| 19711 | RETURN |
| 19712 | * | |
| 19713 | * +-------------------------------------------------------------------* |
| 19714 | * | Only protons: |
| 19715 | ELSE IF ( N .LE. 0 ) THEN |
| 19716 | IF ( N .LT. 0 ) THEN |
| 19717 | WRITE ( LUNOUT, * ) |
| 19718 | & ' DPMJET stopped in energy: mass number =< atomic number !!', |
| 19719 | & KA0, KZ0 |
| 19720 | WRITE ( LUNOUT, * ) |
| 19721 | & ' DPMJET stopped in energy: mass number =< atomic number !!', |
| 19722 | & KA0, KZ0 |
| 19723 | WRITE ( 77, * ) |
| 19724 | & ' ^^^DPMJET stopped in energy: mass number =< atomic number !!', |
| 19725 | & KA0, KZ0 |
| 19726 | STOP 'DT_ENERGY:KA0-KZ0' |
| 19727 | END IF |
| 19728 | IZ0 = -1 |
| 19729 | IF ( IFLAG .EQ. 1 ) THEN |
| 19730 | DT_ENERGY = Z * WAPS ( 1, 2 ) |
| 19731 | ELSE |
| 19732 | DT_ENKNOW = Z * WAPS ( 1, 2 ) |
| 19733 | IZZ0 = -1 |
| 19734 | END IF |
| 19735 | RETURN |
| 19736 | * | |
| 19737 | * +-------------------------------------------------------------------* |
| 19738 | * | Only neutrons: |
| 19739 | ELSE IF ( KZ0 .LE. 0 ) THEN |
| 19740 | IF ( KZ0 .LT. 0 ) THEN |
| 19741 | WRITE ( LUNOUT, * ) |
| 19742 | & ' DPMJET stopped in energy: negative atomic number !!',KA0,KZ0 |
| 19743 | WRITE ( LUNOUT, * ) |
| 19744 | & ' DPMJET stopped in energy: negative atomic number !!',KA0,KZ0 |
| 19745 | WRITE ( 77, * ) |
| 19746 | &' ^^^DPMJET stopped in energy: negative atomic number !!',KA0,KZ0 |
| 19747 | STOP 'DT_ENERGY:KZ0<0' |
| 19748 | END IF |
| 19749 | IZ0 = -1 |
| 19750 | IF ( IFLAG .EQ. 1 ) THEN |
| 19751 | DT_ENERGY = A * WAPS ( 1, 1 ) |
| 19752 | ELSE |
| 19753 | DT_ENKNOW = A * WAPS ( 1, 1 ) |
| 19754 | IZZ0 = -1 |
| 19755 | END IF |
| 19756 | RETURN |
| 19757 | END IF |
| 19758 | * | |
| 19759 | * +-------------------------------------------------------------------* |
| 19760 | * +-------------------------------------------------------------------* |
| 19761 | * | No actual nucleus |
| 19762 | * | |
| 19763 | * +-------------------------------------------------------------------* |
| 19764 | * +-------------------------------------------------------------------* |
| 19765 | * | A larger than maximum allowed: |
| 19766 | IF ( KA0 .GT. NAMSMX ) THEN |
| 19767 | IZ0 = -1 |
| 19768 | IF ( IFLAG .EQ. 1 ) THEN |
| 19769 | DT_ENERGY = DT_ENRG( A, Z ) |
| 19770 | ELSE |
| 19771 | DT_ENKNOW = DT_ENRG( A, Z ) |
| 19772 | IZZ0 = -1 |
| 19773 | END IF |
| 19774 | RETURN |
| 19775 | END IF |
| 19776 | * | |
| 19777 | * +-------------------------------------------------------------------* |
| 19778 | IZZ = INWAPS ( KA0 ) |
| 19779 | * +-------------------------------------------------------------------* |
| 19780 | * | Too much neutron rich with respect to the stability line: |
| 19781 | IF ( KZ0 .LT. IZZ ) THEN |
| 19782 | * | +----------------------------------------------------------------* |
| 19783 | * | | Up to A=Kafree all "bound" masses are known, set it unbound: |
| 19784 | IF ( KA0 .LE. KAFREE ) THEN |
| 19785 | DT_ENERGY = AINFNT |
| 19786 | * | | |
| 19787 | * | +----------------------------------------------------------------* |
| 19788 | * | | Up to Kapuns: be sure it is particle unstable |
| 19789 | ELSE IF ( KA0 .LE. KAPUNS ) THEN |
| 19790 | * | | Exp. excess mass for A,IZZ |
| 19791 | ENEEXP = WAPS ( KA0, 1 ) |
| 19792 | * | | Cameron excess mass for A, IZZ |
| 19793 | ENECA1 = DT_ENRG( A, DBLE (IZZ) ) |
| 19794 | * | | Cameron excess mass for A, Z |
| 19795 | DT_ENERGY = DT_ENRG( A, Z ) |
| 19796 | * | | Use just the difference according to Cameron!!! |
| 19797 | DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1 |
| 19798 | JZZ = INWAPS ( KA0 - 1 ) |
| 19799 | LZZ = INWAPS ( KA0 - 2 ) |
| 19800 | * | | +-------------------------------------------------------------* |
| 19801 | * | | | Residual mass for n-decay known: |
| 19802 | IF ( KZ0 .GE. JZZ .AND. KZ0 .LE. JZZ + NZGVAX - 1 ) THEN |
| 19803 | IZ0 = KZ0 - JZZ + 1 |
| 19804 | DT_ENERGY = MAX(DT_ENERGY,WAPS (KA0-1,IZ0) + WAPS (1,1) |
| 19805 | & + DEPUNS ) |
| 19806 | * | | | |
| 19807 | * | | +-------------------------------------------------------------* |
| 19808 | * | | | Residual mass for 2n-decay known: |
| 19809 | ELSE IF ( KZ0 .GE. LZZ .AND. KZ0 .LE. LZZ + NZGVAX - 1 )THEN |
| 19810 | IZ0 = KZ0 - LZZ + 1 |
| 19811 | DT_ENERGY = MAX ( DT_ENERGY, WAPS (KA0-2,IZ0) + TWOTWO * |
| 19812 | & ( WAPS (1,1) + DEPUNS ) ) |
| 19813 | * | | | |
| 19814 | * | | +-------------------------------------------------------------* |
| 19815 | * | | | Set it unbound: |
| 19816 | ELSE |
| 19817 | DT_ENERGY = AINFNT |
| 19818 | END IF |
| 19819 | * | | | |
| 19820 | * | | +-------------------------------------------------------------* |
| 19821 | * | | |
| 19822 | * | +----------------------------------------------------------------* |
| 19823 | * | | Proceed as usual: |
| 19824 | ELSE |
| 19825 | * | | Exp. excess mass for A,IZZ |
| 19826 | ENEEXP = WAPS ( KA0, 1 ) |
| 19827 | * | | Cameron excess mass for A, IZZ |
| 19828 | ENECA1 = DT_ENRG( A, DBLE (IZZ) ) |
| 19829 | * | | Cameron excess mass for A, Z |
| 19830 | DT_ENERGY = DT_ENRG( A, Z ) |
| 19831 | * | | Use just the difference according to Cameron!!! |
| 19832 | DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1 |
| 19833 | END IF |
| 19834 | * | | |
| 19835 | * | +----------------------------------------------------------------* |
| 19836 | * | Be sure not to have a positive energy state: |
| 19837 | DT_ENERGY = MIN(DT_ENERGY,(A-Z) * WAPS (1,1) + Z * WAPS (1,2) ) |
| 19838 | IZ0 = -1 |
| 19839 | IF ( IFLAG .EQ. 2 ) THEN |
| 19840 | DT_ENKNOW = DT_ENERGY |
| 19841 | IZZ0 = -1 |
| 19842 | END IF |
| 19843 | RETURN |
| 19844 | * | |
| 19845 | * +-------------------------------------------------------------------* |
| 19846 | * | Too much proton rich with respect to the stability line: |
| 19847 | ELSE IF ( KZ0 .GT. IZZ + NZGVAX - 1 ) THEN |
| 19848 | * | +----------------------------------------------------------------* |
| 19849 | * | | Up to A=Kafree all "bound" masses are known, set it unbound: |
| 19850 | IF ( KA0 .LE. KAFREE ) THEN |
| 19851 | DT_ENERGY = AINFNT |
| 19852 | * | | |
| 19853 | * | +----------------------------------------------------------------* |
| 19854 | * | | Up to Kapuns: be sure it is particle unstable |
| 19855 | ELSE IF ( KA0 .LE. KAPUNS ) THEN |
| 19856 | * | | Exp. excess mass for A,IZZ+NZGVAX-1 |
| 19857 | ENEEXP = WAPS ( KA0, NZGVAX ) |
| 19858 | * | | Cameron excess mass for A, IZZ+NZGVAX-1 |
| 19859 | ENECA1 = DT_ENRG( A, DBLE (IZZ+NZGVAX-1) ) |
| 19860 | * | | Cameron excess mass for A, Z |
| 19861 | DT_ENERGY = DT_ENRG( A, Z ) |
| 19862 | * | | Use just the difference according to Cameron!!! |
| 19863 | DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1 |
| 19864 | JZZ = INWAPS ( KA0 - 1 ) |
| 19865 | LZZ = INWAPS ( KA0 - 2 ) |
| 19866 | * | | +-------------------------------------------------------------* |
| 19867 | * | | | Residual mass for p-decay known: |
| 19868 | IF ( KZ0-1 .GE. JZZ .AND. KZ0-1 .LE. JZZ + NZGVAX - 1 ) THEN |
| 19869 | IZ0 = KZ0 - 1 - JZZ + 1 |
| 19870 | DT_ENERGY = MAX (DT_ENERGY, WAPS (KA0-1,IZ0) + WAPS (1,2) |
| 19871 | & + DEPUNS ) |
| 19872 | * | | | |
| 19873 | * | | +-------------------------------------------------------------* |
| 19874 | * | | | Residual mass for 2p-decay known: |
| 19875 | ELSE IF ( KZ0-2 .GE. LZZ .AND. KZ0-2 .LE. LZZ + NZGVAX - 1 ) |
| 19876 | & THEN |
| 19877 | IZ0 = KZ0 - 2 - LZZ + 1 |
| 19878 | DT_ENERGY = MAX ( DT_ENERGY, WAPS (KA0-2,IZ0) + TWOTWO * |
| 19879 | & ( WAPS (1,2) + DEPUNS ) ) |
| 19880 | * | | | |
| 19881 | * | | +-------------------------------------------------------------* |
| 19882 | * | | | Set it unbound: |
| 19883 | ELSE |
| 19884 | DT_ENERGY = AINFNT |
| 19885 | END IF |
| 19886 | * | | | |
| 19887 | * | | +-------------------------------------------------------------* |
| 19888 | * | | |
| 19889 | * | +----------------------------------------------------------------* |
| 19890 | * | | Proceed as usual: |
| 19891 | ELSE |
| 19892 | * | | Exp. excess mass for A,IZZ+NZGVAX-1 |
| 19893 | ENEEXP = WAPS ( KA0, NZGVAX ) |
| 19894 | * | | Cameron excess mass for A, IZZ+NZGVAX-1 |
| 19895 | ENECA1 = DT_ENRG( A, DBLE (IZZ+NZGVAX-1) ) |
| 19896 | * | | Cameron excess mass for A, Z |
| 19897 | DT_ENERGY = DT_ENRG( A, Z ) |
| 19898 | * | | Use just the difference according to Cameron!!! |
| 19899 | DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1 |
| 19900 | END IF |
| 19901 | * | | |
| 19902 | * | +----------------------------------------------------------------* |
| 19903 | * | Be sure not to have a positive energy state: |
| 19904 | DT_ENERGY = MIN(DT_ENERGY,(A-Z) * WAPS (1,1) + Z * WAPS (1,2) ) |
| 19905 | IZ0 = -1 |
| 19906 | IF ( IFLAG .EQ. 2 ) THEN |
| 19907 | DT_ENKNOW = DT_ENERGY |
| 19908 | IZZ0 = -1 |
| 19909 | END IF |
| 19910 | RETURN |
| 19911 | * | |
| 19912 | * +-------------------------------------------------------------------* |
| 19913 | * | Known isotope or anyway isotope "inside" the stability zone |
| 19914 | ELSE |
| 19915 | IZ0 = KZ0 - IZZ + 1 |
| 19916 | DT_ENERGY = WAPS ( KA0, IZ0 ) |
| 19917 | IF ( IFLAG .EQ. 2 ) IZZ0 = IZ0 |
| 19918 | * | +----------------------------------------------------------------* |
| 19919 | * | | Mass not known |
| 19920 | IF ( ABS (DT_ENERGY) .LT. ANGLGB .AND. (KA0 .NE. 12 .OR. KZ0 |
| 19921 | & .NE. 6) ) THEN |
| 19922 | IF ( IFLAG .EQ. 2 ) IZZ0 = -1 |
| 19923 | * | | +-------------------------------------------------------------* |
| 19924 | * | | | Set it unbound: |
| 19925 | IF ( KA0 .LE. KAFREE ) THEN |
| 19926 | DT_ENERGY = AINFNT |
| 19927 | * | | | |
| 19928 | * | | +-------------------------------------------------------------* |
| 19929 | * | | | Try to get a reasonable excess mass: |
| 19930 | ELSE |
| 19931 | JZ0 = -100 |
| 19932 | * | | | +----------------------------------------------------------* |
| 19933 | * | | | | Check the closest one known: |
| 19934 | DO 500 JZZ = 1, NZGVAX |
| 19935 | IF ( ABS ( WAPS (KA0,JZZ) ) .GT. ANGLGB .AND. |
| 19936 | & ABS (JZZ-IZ0) .LT. ABS (JZ0-IZ0) ) JZ0 = JZZ |
| 19937 | IF ( ABS (JZ0-IZ0) .EQ. 1 ) GO TO 550 |
| 19938 | 500 CONTINUE |
| 19939 | * | | | | |
| 19940 | * | | | +----------------------------------------------------------* |
| 19941 | 550 CONTINUE |
| 19942 | * | | | Exp. excess mass for A,IZZ+JZ0-1 |
| 19943 | ENEEXP = WAPS ( KA0, JZ0 ) |
| 19944 | * | | | Cameron excess mass for A, IZZ+JZ0-1 |
| 19945 | ENECA1 = DT_ENRG( A, DBLE (IZZ+JZ0-1) ) |
| 19946 | * | | | Cameron excess mass for A, Z |
| 19947 | DT_ENERGY = DT_ENRG( A, Z ) |
| 19948 | * | | | Use just the difference according to Cameron!!! |
| 19949 | DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1 |
| 19950 | IZ0 = -1 |
| 19951 | END IF |
| 19952 | * | | | |
| 19953 | * | | +-------------------------------------------------------------* |
| 19954 | * | | Be sure not to have a positive energy state: |
| 19955 | DT_ENERGY = MIN(DT_ENERGY,(A-Z)*WAPS(1,1)+Z*WAPS (1,2) ) |
| 19956 | END IF |
| 19957 | * | | |
| 19958 | * | +----------------------------------------------------------------* |
| 19959 | IF ( IFLAG .EQ. 2 ) DT_ENKNOW = DT_ENERGY |
| 19960 | RETURN |
| 19961 | END IF |
| 19962 | * | |
| 19963 | * +-------------------------------------------------------------------* |
| 19964 | *=== End of Function Energy ===========================================* |
| 19965 | * RETURN |
| 19966 | END |
| 19967 | ** |
| 19968 | |
| 19969 | *$ CREATE DT_ENRG.FOR |
| 19970 | *COPY DT_ENRG |
| 19971 | * * |
| 19972 | *=== enrg =============================================================* |
| 19973 | * * |
| 19974 | DOUBLE PRECISION FUNCTION DT_ENRG(A,Z) |
| 19975 | |
| 19976 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 19977 | SAVE |
| 19978 | |
| 19979 | PARAMETER ( ZERZER = 0.D+00 ) |
| 19980 | PARAMETER ( ONEONE = 1.D+00 ) |
| 19981 | PARAMETER ( LUNIN = 5 ) |
| 19982 | PARAMETER ( LUNOUT = 6 ) |
| 19983 | * |
| 19984 | *----------------------------------------------------------------------* |
| 19985 | * * |
| 19986 | * Revised version of the original routine from EVAP: * |
| 19987 | * * |
| 19988 | * Created on 15 may 1990 by Alfredo Ferrari & Paola Sala * |
| 19989 | * Infn - Milan * |
| 19990 | * * |
| 19991 | * Last change on 01-oct-94 by Alfredo Ferrari * |
| 19992 | * * |
| 19993 | * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! * |
| 19994 | * !!! It is supposed to be used with the updated atomic !!! * |
| 19995 | * !!! mass data file !!! * |
| 19996 | * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! * |
| 19997 | * * |
| 19998 | *----------------------------------------------------------------------* |
| 19999 | * |
| 20000 | PARAMETER ( O16OLD = 931.145 D+00 ) |
| 20001 | PARAMETER ( O16NEW = 931.19826D+00 ) |
| 20002 | PARAMETER ( O16RAT = O16NEW / O16OLD ) |
| 20003 | PARAMETER ( C12NEW = 931.49432D+00 ) |
| 20004 | PARAMETER ( ADJUST = -8.322737768178909D-02 ) |
| 20005 | PARAMETER ( AINFNT = 1.0D+30 ) |
| 20006 | * (original name: EVA0) |
| 20007 | COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001), |
| 20008 | * FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6), |
| 20009 | * CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200), |
| 20010 | * T (4,7), RMASS (297), ALPH (297), BET (297), |
| 20011 | * APRIME (250), IA (6), IZ (6) |
| 20012 | LOGICAL LFIRST |
| 454792a9 |
20013 | CPH SAVE LFIRST, EXHYDR, EXNEUT |
| 9aaba0d6 |
20014 | DATA LFIRST / .TRUE. / |
| 20015 | * |
| 20016 | IF ( LFIRST ) THEN |
| 20017 | LFIRST = .FALSE. |
| 20018 | **sr 30.6. |
| 20019 | C EXHYDR = DT_ENERGY( ONEONE, ONEONE ) |
| 20020 | C EXNEUT = DT_ENERGY( ONEONE, ZERZER ) |
| 20021 | EXHYDR = A |
| 20022 | EXNEUT = Z |
| 20023 | DT_ENRG = -AINFNT |
| 20024 | RETURN |
| 20025 | ** |
| 20026 | END IF |
| 20027 | IZ0 = NINT (Z) |
| 20028 | IF ( IZ0 .LE. 0 ) THEN |
| 20029 | DT_ENRG = A * EXNEUT |
| 20030 | RETURN |
| 20031 | END IF |
| 20032 | N = NINT (A-Z) |
| 20033 | IF ( N .LE. 0 ) THEN |
| 20034 | DT_ENRG = Z * EXHYDR |
| 20035 | RETURN |
| 20036 | END IF |
| 20037 | AM2ZOA= (A-Z-Z)/A |
| 20038 | AM2ZOA=AM2ZOA*AM2ZOA |
| 20039 | A13 = RMASS(NINT(A)) |
| 20040 | * A13 = A**.3333333333333333D+00 |
| 20041 | AM13 = 1.D+00/A13 |
| 20042 | EV=-17.0354D+00*(1.D+00 -1.84619 D+00*AM2ZOA)*A |
| 20043 | ES= 25.8357D+00*(1.D+00 -1.712185D+00*AM2ZOA)* |
| 20044 | & (1.D+00 -0.62025D+00*AM13*AM13)* |
| 20045 | & (A13*A13 -.62025D+00) |
| 20046 | EC= 0.799D+00*Z*(Z-1.D+00)*AM13*(((1.5772D+00*AM13 +1.2273D+00)* |
| 20047 | & AM13-1.5849D+00)* |
| 20048 | & AM13*AM13 +1.D+00) |
| 20049 | EEX= -0.4323D+00*AM13*Z**1.3333333D+00* |
| 20050 | & (((0.49597D+00*AM13 -0.14518D+00)*AM13 -0.57811D+00) * AM13 |
| 20051 | & + 1.D+00) |
| 20052 | DT_ENRG=8.367D+00*A-0.783D+00*Z +EV +ES +EC +EEX+CAM2(IZ0)+CAM3(N) |
| 20053 | DT_ENRG=(DT_ENRG + A * O16OLD ) * O16RAT - A * ( C12NEW - ADJUST ) |
| 20054 | DT_ENRG = MIN ( DT_ENRG, Z * EXHYDR + ( A - Z ) * EXNEUT ) |
| 20055 | RETURN |
| 20056 | *=== End of function Enrg =============================================* |
| 20057 | END |
| 20058 | |
| 20059 | *$ CREATE DT_INCINI.FOR |
| 20060 | *COPY DT_INCINI |
| 20061 | * * |
| 20062 | *=== incini ===========================================================* |
| 20063 | * * |
| 20064 | SUBROUTINE DT_INCINI |
| 20065 | |
| 20066 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 20067 | SAVE |
| 20068 | |
| 20069 | PARAMETER ( ZERZER = 0.D+00 ) |
| 20070 | PARAMETER ( ONEONE = 1.D+00 ) |
| 20071 | PARAMETER ( TWOTWO = 2.D+00 ) |
| 20072 | PARAMETER ( THRTHR = 3.D+00 ) |
| 20073 | PARAMETER ( FOUFOU = 4.D+00 ) |
| 20074 | PARAMETER ( EIGEIG = 8.D+00 ) |
| 20075 | PARAMETER ( ANINEN = 9.D+00 ) |
| 20076 | PARAMETER ( HLFHLF = 0.5D+00 ) |
| 20077 | PARAMETER ( ONETHI = ONEONE / THRTHR ) |
| 20078 | PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 ) |
| 20079 | PARAMETER ( PLABRC = 0.197327053 D+00 ) |
| 20080 | PARAMETER ( AMELCT = 0.51099906 D-03 ) |
| 20081 | PARAMETER ( AMUGEV = 0.93149432 D+00 ) |
| 20082 | PARAMETER ( AMPRTN = 0.93827231 D+00 ) |
| 20083 | PARAMETER ( AMNTRN = 0.93956563 D+00 ) |
| 20084 | PARAMETER ( AMDEUT = 1.87561339 D+00 ) |
| 20085 | PARAMETER ( EMVGEV = 1.0 D-03 ) |
| 20086 | |
| 20087 | PARAMETER ( LUNOUT = 6 ) |
| 20088 | * |
| 20089 | *----------------------------------------------------------------------* |
| 20090 | * * |
| 20091 | * Created on 10 june 1990 by Alfredo Ferrari & Paola Sala * |
| 20092 | * Infn - Milan * |
| 20093 | * * |
| 20094 | * Last change on 02-may-95 by Alfredo Ferrari * |
| 20095 | * * |
| 20096 | * * |
| 20097 | *----------------------------------------------------------------------* |
| 20098 | * |
| 20099 | * (original name: FHEAVY,FHEAVC) |
| 20100 | PARAMETER ( MXHEAV = 100 ) |
| 20101 | CHARACTER*8 ANHEAV |
| 20102 | COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV), |
| 20103 | & CZHEAV (MXHEAV), TKHEAV (MXHEAV), |
| 20104 | & PHEAVY (MXHEAV), WHEAVY (MXHEAV), |
| 20105 | & AMHEAV ( 12 ) , AMNHEA ( 12 ) , |
| 20106 | & KHEAVY (MXHEAV), ICHEAV ( 12 ) , |
| 20107 | & IBHEAV ( 12 ) , NPHEAV |
| 20108 | COMMON /FKFHVC/ ANHEAV ( 12 ) |
| 20109 | * (original name: INPFLG) |
| 20110 | COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK |
| 20111 | * (original name: FRBKCM) |
| 20112 | PARAMETER ( MXFFBK = 6 ) |
| 20113 | PARAMETER ( MXZFBK = 9 ) |
| 20114 | PARAMETER ( MXNFBK = 10 ) |
| 20115 | PARAMETER ( MXAFBK = 16 ) |
| 20116 | PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 ) |
| 20117 | PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 ) |
| 20118 | PARAMETER ( NXAFBK = MXAFBK + 1 ) |
| 20119 | PARAMETER ( MXPSST = 300 ) |
| 20120 | PARAMETER ( MXPSFB = 41000 ) |
| 20121 | LOGICAL LFRMBK, LNCMSS |
| 20122 | COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST), |
| 20123 | & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB), |
| 20124 | & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK, |
| 20125 | & IFRBKN (MXPSST), IFRBKZ (MXPSST), |
| 20126 | & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST), |
| 20127 | & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK), |
| 20128 | & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK), |
| 20129 | & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF, |
| 20130 | & IFBFRB, NBUFBK, LFRMBK, LNCMSS |
| 20131 | * (original name: NUCDAT) |
| 20132 | PARAMETER ( AMUAMU = AMUGEV ) |
| 20133 | PARAMETER ( AMPROT = AMPRTN ) |
| 20134 | PARAMETER ( AMNEUT = AMNTRN ) |
| 20135 | PARAMETER ( AMELEC = AMELCT ) |
| 20136 | PARAMETER ( R0NUCL = 1.12 D+00 ) |
| 20137 | PARAMETER ( RCCOUL = 1.7 D+00 ) |
| 20138 | PARAMETER ( FERTHO = 14.33 D-09 ) |
| 20139 | PARAMETER ( EXPEBN = 2.39 D+00 ) |
| 20140 | PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 ) |
| 20141 | PARAMETER ( AMUC12 = AMUGEV - HLFHLF * AMELCT + BEXC12 / 12.D+00 ) |
| 20142 | PARAMETER ( AMHYDR = AMPRTN + AMELCT ) |
| 20143 | PARAMETER ( AMHTON = AMHYDR - AMNTRN ) |
| 20144 | PARAMETER ( AMNTOU = AMNTRN - AMUC12 ) |
| 20145 | PARAMETER ( AMUCSQ = AMUC12 * AMUC12 ) |
| 20146 | PARAMETER ( EBNDAV = HLFHLF * (AMPRTN + AMNTRN) - AMUC12 ) |
| 20147 | PARAMETER ( GAMMIN = 1.0D-06 ) |
| 20148 | PARAMETER ( GAMNSQ = 2.0D+00 * GAMMIN * GAMMIN ) |
| 20149 | PARAMETER ( TVEPSI = GAMMIN / 100.D+00 ) |
| 20150 | COMMON /FKNDAT/ AV0WEL, APFRMX, AEFRMX, AEFRMA, |
| 20151 | & RDSNUC, V0WELL (2), PFRMMX (2), EFRMMX (2), |
| 20152 | & EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2), |
| 20153 | & VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2), |
| 20154 | & PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2), |
| 20155 | & EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2), |
| 20156 | & ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV , |
| 20157 | & AMRCSQ , ATO1O3 , ZTO1O3 , ELBNDE (0:100) |
| 20158 | * (original name: PAREVT) |
| 20159 | LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX, |
| 20160 | & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF |
| 20161 | PARAMETER ( NALLWP = 39 ) |
| 20162 | COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, |
| 20163 | & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY, |
| 20164 | & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV, |
| 20165 | & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF |
| 20166 | * (original name: NUCOLD) |
| 20167 | COMMON /FKNOLD/ HELP (2), HHLP (2), FTVTH (2), FINCX (2), |
| 20168 | & EKPOLD (2), BBOLD, ZZOLD, SQROLD, ASEASQ, |
| 20169 | & FSPRED, FEX0RD |
| 20170 | * |
| 20171 | BBOLD = - 1.D+10 |
| 20172 | ZZOLD = - 1.D+10 |
| 20173 | SQROLD = - 1.D+10 |
| 20174 | APFRMX = PLABRC * ( ANINEN * PIPIPI / EIGEIG )**ONETHI / R0NUCL |
| 20175 | AMNUCL (1) = AMPROT |
| 20176 | AMNUCL (2) = AMNEUT |
| 20177 | AMNUSQ (1) = AMPROT * AMPROT |
| 20178 | AMNUSQ (2) = AMNEUT * AMNEUT |
| 20179 | AMNHLP = HLFHLF * ( AMNUCL (1) + AMNUCL (2) ) |
| 20180 | ASQHLP = AMNHLP**2 |
| 20181 | * ASQHLP = HLFHLF * ( AMNUSQ (1) + AMNUSQ (2) ) |
| 20182 | AEFRMX = SQRT ( ASQHLP + APFRMX**2 ) - AMNHLP |
| 20183 | AEFRMA = 0.3D+00 * APFRMX**2 / AMNHLP * ( ONEONE - APFRMX**2 / |
| 20184 | & ( 5.6D+00 * ASQHLP ) ) |
| 20185 | AV0WEL = AEFRMX + EBNDAV |
| 20186 | EBNDNG (1) = EBNDAV |
| 20187 | EBNDNG (2) = EBNDAV |
| 20188 | AEXC12 = EMVGEV * DT_ENERGY( 12.D+00, 6.D+00 ) |
| 20189 | CEXC12 = EMVGEV * DT_ENRG( 12.D+00, 6.D+00 ) |
| 20190 | AMMC12 = 12.D+00 * AMUGEV + AEXC12 |
| 20191 | AMNC12 = AMMC12 - 6.D+00 * AMELCT + FERTHO * 6.D+00**EXPEBN |
| 20192 | AEXO16 = EMVGEV * DT_ENERGY( 16.D+00, 8.D+00 ) |
| 20193 | CEXO16 = EMVGEV * DT_ENRG( 16.D+00, 8.D+00 ) |
| 20194 | AMMO16 = 16.D+00 * AMUGEV + AEXO16 |
| 20195 | AMNO16 = AMMO16 - 8.D+00 * AMELCT + FERTHO * 8.D+00**EXPEBN |
| 20196 | AEXS28 = EMVGEV * DT_ENERGY( 28.D+00, 14.D+00 ) |
| 20197 | CEXS28 = EMVGEV * DT_ENRG( 28.D+00, 14.D+00 ) |
| 20198 | AMMS28 = 28.D+00 * AMUGEV + AEXS28 |
| 20199 | AMNS28 = AMMS28 - 14.D+00 * AMELCT + FERTHO * 14.D+00**EXPEBN |
| 20200 | AEXC40 = EMVGEV * DT_ENERGY( 40.D+00, 20.D+00 ) |
| 20201 | CEXC40 = EMVGEV * DT_ENRG( 40.D+00, 20.D+00 ) |
| 20202 | AMMC40 = 40.D+00 * AMUGEV + AEXC40 |
| 20203 | AMNC40 = AMMC40 - 20.D+00 * AMELCT + FERTHO * 20.D+00**EXPEBN |
| 20204 | AEXF56 = EMVGEV * DT_ENERGY( 56.D+00, 26.D+00 ) |
| 20205 | CEXF56 = EMVGEV * DT_ENRG( 56.D+00, 26.D+00 ) |
| 20206 | AMMF56 = 56.D+00 * AMUGEV + AEXF56 |
| 20207 | AMNF56 = AMMF56 - 26.D+00 * AMELCT + FERTHO * 26.D+00**EXPEBN |
| 20208 | AEX107 = EMVGEV * DT_ENERGY( 107.D+00, 47.D+00 ) |
| 20209 | CEX107 = EMVGEV * DT_ENRG( 107.D+00, 47.D+00 ) |
| 20210 | AMM107 = 107.D+00 * AMUGEV + AEX107 |
| 20211 | AMN107 = AMM107 - 47.D+00 * AMELCT + FERTHO * 47.D+00**EXPEBN |
| 20212 | AEX132 = EMVGEV * DT_ENERGY( 132.D+00, 54.D+00 ) |
| 20213 | CEX132 = EMVGEV * DT_ENRG( 132.D+00, 54.D+00 ) |
| 20214 | AMM132 = 132.D+00 * AMUGEV + AEX132 |
| 20215 | AMN132 = AMM132 - 54.D+00 * AMELCT + FERTHO * 54.D+00**EXPEBN |
| 20216 | AEX181 = EMVGEV * DT_ENERGY( 181.D+00, 73.D+00 ) |
| 20217 | CEX181 = EMVGEV * DT_ENRG( 181.D+00, 73.D+00 ) |
| 20218 | AMM181 = 181.D+00 * AMUGEV + AEX181 |
| 20219 | AMN181 = AMM181 - 73.D+00 * AMELCT + FERTHO * 73.D+00**EXPEBN |
| 20220 | AEX208 = EMVGEV * DT_ENERGY( 208.D+00, 82.D+00 ) |
| 20221 | CEX208 = EMVGEV * DT_ENRG( 208.D+00, 82.D+00 ) |
| 20222 | AMM208 = 208.D+00 * AMUGEV + AEX208 |
| 20223 | AMN208 = AMM208 - 82.D+00 * AMELCT + FERTHO * 82.D+00**EXPEBN |
| 20224 | AEX238 = EMVGEV * DT_ENERGY( 238.D+00, 92.D+00 ) |
| 20225 | CEX238 = EMVGEV * DT_ENRG( 238.D+00, 92.D+00 ) |
| 20226 | AMM238 = 238.D+00 * AMUGEV + AEX238 |
| 20227 | AMN238 = AMM238 - 92.D+00 * AMELCT + FERTHO * 92.D+00**EXPEBN |
| 20228 | |
| 20229 | AMHEAV (1) = AMUGEV + EMVGEV * DT_ENERGY( ONEONE, ZERZER ) |
| 20230 | AMHEAV (2) = AMUGEV + EMVGEV * DT_ENERGY( ONEONE, ONEONE ) |
| 20231 | AMHEAV (3) = TWOTWO * AMUGEV |
| 20232 | & + EMVGEV * DT_ENERGY( TWOTWO, ONEONE ) |
| 20233 | AMHEAV (4) = THRTHR * AMUGEV |
| 20234 | & + EMVGEV * DT_ENERGY( THRTHR, ONEONE ) |
| 20235 | AMHEAV (5) = THRTHR * AMUGEV |
| 20236 | & + EMVGEV * DT_ENERGY( THRTHR, TWOTWO ) |
| 20237 | AMHEAV (6) = FOUFOU * AMUGEV |
| 20238 | & + EMVGEV * DT_ENERGY( FOUFOU, TWOTWO ) |
| 20239 | ELBNDE (0) = ZERZER |
| 20240 | ELBNDE (1) = 13.6D-09 |
| 20241 | DO 2000 IZ = 2, 100 |
| 20242 | ELBNDE ( IZ ) = FERTHO * DBLE ( IZ )**EXPEBN |
| 20243 | 2000 CONTINUE |
| 20244 | AMNHEA (1) = AMHEAV (1) + ELBNDE (0) |
| 20245 | AMNHEA (2) = AMHEAV (2) - AMELCT + ELBNDE (1) |
| 20246 | AMNHEA (3) = AMHEAV (3) - AMELCT + ELBNDE (1) |
| 20247 | AMNHEA (4) = AMHEAV (4) - AMELCT + ELBNDE (1) |
| 20248 | AMNHEA (5) = AMHEAV (5) - TWOTWO * AMELCT + ELBNDE (2) |
| 20249 | AMNHEA (6) = AMHEAV (6) - TWOTWO * AMELCT + ELBNDE (2) |
| 20250 | IF ( LEVPRT ) THEN |
| 20251 | WRITE ( LUNOUT, * )' **** Evaporation from residual nucleus', |
| 20252 | & ' activated **** ' |
| 20253 | IF ( LDEEXG ) WRITE ( LUNOUT, * )' **** Deexcitation gamma', |
| 20254 | & ' production activated **** ' |
| 20255 | **sr 18.5.95 |
| 20256 | * commented, since obsolete |
| 20257 | C IF ( LHEAVY ) WRITE ( LUNOUT, * )' **** Evaporated "heavies"', |
| 20258 | C & ' transport activated **** ' |
| 20259 | IF ( IFISS .GT. 0 ) |
| 20260 | & WRITE ( LUNOUT, * )' **** High Energy fission ', |
| 20261 | & ' requested & activated **** ' |
| 20262 | IF ( LFRMBK ) |
| 20263 | & WRITE ( LUNOUT, * )' **** Fermi Break Up ', |
| 20264 | & ' requested & activated **** ' |
| 20265 | IF ( LFRMBK ) CALL DT_FRBKIN(.FALSE.,.FALSE.) |
| 20266 | ELSE |
| 20267 | LDEEXG = .FALSE. |
| 20268 | LHEAVY = .FALSE. |
| 20269 | LFRMBK = .FALSE. |
| 20270 | IFISS = 0 |
| 20271 | END IF |
| 20272 | RETURN |
| 20273 | *=== End of subroutine incini =========================================* |
| 20274 | END |
| 20275 | |
| 20276 | *$ CREATE DT_STALIN.FOR |
| 20277 | *COPY DT_STALIN |
| 20278 | * * |
| 20279 | *=== stalin ===========================================================* |
| 20280 | * * |
| 20281 | SUBROUTINE DT_STALIN |
| 20282 | |
| 20283 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 20284 | SAVE |
| 20285 | PARAMETER ( ANGLGB = 5.0D-16 ) |
| 20286 | PARAMETER ( ZERZER = 0.D+00 ) |
| 20287 | PARAMETER ( ONEONE = 1.D+00 ) |
| 20288 | PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 ) |
| 20289 | PARAMETER ( AMUGEV = 0.93149432 D+00 ) |
| 20290 | PARAMETER ( EMVGEV = 1.0 D-03 ) |
| 20291 | PARAMETER ( NSTBIS = 304 ) |
| 20292 | PARAMETER ( LUNIN = 5 ) |
| 20293 | PARAMETER ( LUNOUT = 6 ) |
| 20294 | * |
| 20295 | *----------------------------------------------------------------------* |
| 20296 | * * |
| 20297 | * STAbility LINe calculation: * |
| 20298 | * * |
| 20299 | * Created on 04 december 1992 by Alfredo Ferrari & Paola Sala * |
| 20300 | * Infn - Milan * |
| 20301 | * * |
| 20302 | * Last change on 04-dec-92 by Alfredo Ferrari * |
| 20303 | * * |
| 20304 | * * |
| 20305 | *----------------------------------------------------------------------* |
| 20306 | * |
| 20307 | * (original name: ISOTOP) |
| 20308 | PARAMETER ( NAMSMX = 270 ) |
| 20309 | PARAMETER ( NZGVAX = 15 ) |
| 20310 | PARAMETER ( NISMMX = 574 ) |
| 20311 | COMMON /FKISOT/ WAPS (NAMSMX,NZGVAX), T12NUC (NAMSMX,NZGVAX), |
| 20312 | & WAPISM (NISMMX), T12ISM (NISMMX), |
| 20313 | & ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260), |
| 20314 | & AMSSST (100) , ISOMNM (NSTBIS), ISONDX (2,100), |
| 20315 | & JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX), |
| 20316 | & INWAPS (NAMSMX), JSPISM (NISMMX), |
| 20317 | & JPTISM (NISMMX), IZWISM (NISMMX), |
| 20318 | & INWISM (0:NAMSMX) |
| 20319 | * |
| 20320 | DIMENSION ZNORM (260) |
| 20321 | * +-------------------------------------------------------------------* |
| 20322 | * | |
| 20323 | DO 1000 IZ=1,100 |
| 20324 | DO 500 J=1,2 |
| 20325 | ASTLIN (J,IZ) = ZERZER |
| 20326 | 500 CONTINUE |
| 20327 | 1000 CONTINUE |
| 20328 | * | |
| 20329 | * +-------------------------------------------------------------------* |
| 20330 | * +-------------------------------------------------------------------* |
| 20331 | * | |
| 20332 | DO 2000 IA=1,260 |
| 20333 | ZNORM (IA) = ZERZER |
| 20334 | DO 1500 J=1,2 |
| 20335 | ZSTLIN (J,IA) = ZERZER |
| 20336 | 1500 CONTINUE |
| 20337 | 2000 CONTINUE |
| 20338 | * | |
| 20339 | * +-------------------------------------------------------------------* |
| 20340 | * +-------------------------------------------------------------------* |
| 20341 | * | Loop on the Atomic Number |
| 20342 | DO 3000 IZ=1,100 |
| 20343 | AMSSST (IZ) = ZERZER |
| 20344 | ANORM = ONEONE |
| 20345 | ZTAR = IZ |
| 20346 | * | +----------------------------------------------------------------* |
| 20347 | * | | Loop on the stable isotopes |
| 20348 | DO 2500 IS = ISONDX (1,IZ), ISONDX (2,IZ) |
| 20349 | IA = ISOMNM (IS) |
| 20350 | ASTLIN (1,IZ) = ASTLIN (1,IZ) + ABUISO (IS) * IA |
| 20351 | ASTLIN (2,IZ) = ASTLIN (2,IZ) + ABUISO (IS) * IA**2 |
| 20352 | ZNORM (IA) = ZNORM (IA) + ABUISO (IS) |
| 20353 | ZSTLIN (1,IA) = ZSTLIN (1,IA) + ABUISO (IS) * IZ |
| 20354 | ZSTLIN (2,IA) = ZSTLIN (2,IA) + ABUISO (IS) * IZ**2 |
| 20355 | AHELP = IA |
| 20356 | IF ( AHELP .LE. 1.00001D+00 ) THEN |
| 20357 | ANORM = ONEONE / ( ONEONE - ABUISO (IS) ) |
| 20358 | GO TO 2500 |
| 20359 | END IF |
| 20360 | AMSSST (IZ) = ABUISO (IS) * ( AHELP * AMUGEV |
| 20361 | & + EMVGEV * DT_ENERGY(AHELP,ZTAR) ) + AMSSST (IZ) |
| 20362 | 2500 CONTINUE |
| 20363 | * | | |
| 20364 | * | +----------------------------------------------------------------* |
| 20365 | AMSSST (IZ) = ANORM * AMSSST (IZ) / AMUGEV |
| 20366 | * | Normalize and print A_stab versus Z data: |
| 20367 | ASTLIN (2,IZ) = MAX ( SQRT (ASTLIN(2,IZ)-ASTLIN(1,IZ)**2), |
| 20368 | & 0.5D+00 ) |
| 20369 | * WRITE (LUNOUT,*)' Z:',IZ,' A_stab:',SNGL(ASTLIN(1,IZ)), |
| 20370 | * & ' Sigma_st',SNGL(ASTLIN(2,IZ)) |
| 20371 | 3000 CONTINUE |
| 20372 | * | |
| 20373 | * +-------------------------------------------------------------------* |
| 20374 | * +-------------------------------------------------------------------* |
| 20375 | * | Normalize and print Z_stab versus A data: |
| 20376 | DO 4000 IA=1,260 |
| 20377 | ZSTLIN (1,IA) = ZSTLIN (1,IA) / MAX ( ZNORM (IA), 1.D-10 ) |
| 20378 | ZSTLIN (2,IA) = ZSTLIN (2,IA) / MAX ( ZNORM (IA), 1.D-10 ) |
| 20379 | ZSTLIN (2,IA) = MAX ( ZSTLIN (2,IA), ZSTLIN (1,IA)**2 ) |
| 20380 | IF ( ZNORM (IA) .GT. ANGLGB ) |
| 20381 | **sr 2.11. avoid underflows at Pentium |
| 20382 | & ZSTLIN (2,IA) = |
| 20383 | & MAX ( SQRT ( ABS(ZSTLIN(2,IA)-ZSTLIN(1,IA)**2) ), |
| 20384 | C & ZSTLIN (2,IA) = MAX ( SQRT (ZSTLIN(2,IA)-ZSTLIN(1,IA)**2), |
| 20385 | & 0.3D+00 ) |
| 20386 | 4000 CONTINUE |
| 20387 | * | |
| 20388 | * +-------------------------------------------------------------------* |
| 20389 | * +-------------------------------------------------------------------* |
| 20390 | * | Normalize and print Z_stab versus A data: |
| 20391 | DO 5000 IA=1,260 |
| 20392 | IF ( ZNORM (IA) .LE. ANGLGB ) THEN |
| 20393 | DO 4200 JA = IA-1,1,-1 |
| 20394 | IF ( ZNORM (JA) .GT. ANGLGB ) THEN |
| 20395 | IA1 = JA |
| 20396 | GO TO 4300 |
| 20397 | END IF |
| 20398 | 4200 CONTINUE |
| 20399 | 4300 CONTINUE |
| 20400 | DO 4400 JA = IA+1,260 |
| 20401 | IF ( ZNORM (JA) .GT. ANGLGB ) THEN |
| 20402 | IA2 = JA |
| 20403 | GO TO 4500 |
| 20404 | END IF |
| 20405 | 4400 CONTINUE |
| 20406 | IA2 = IA1 |
| 20407 | IA1 = IA1 - 1 |
| 20408 | 4500 CONTINUE |
| 20409 | ZSTLIN (1,IA) = DBLE (IA-IA1) / DBLE (IA2-IA1) |
| 20410 | & * ( ZSTLIN (1,IA2) - ZSTLIN (1,IA1) ) |
| 20411 | & + ZSTLIN (1,IA1) |
| 20412 | ZSTLIN (2,IA) = DBLE (IA-IA1) / DBLE (IA2-IA1) |
| 20413 | & * ( ZSTLIN (2,IA2) - ZSTLIN (2,IA1) ) |
| 20414 | & + ZSTLIN (2,IA1) |
| 20415 | END IF |
| 20416 | IZ = MIN ( 100, NINT (ZSTLIN(1,IA)) ) |
| 20417 | ATOZ = IZ / ASTLIN (1,IZ) |
| 20418 | ZSTLIN (2,IA) = MAX ( ZSTLIN (2,IA), ATOZ * ASTLIN (2,IZ) ) |
| 20419 | * WRITE (LUNOUT,*)' A:',IA,' Z_stab:',SNGL(ZSTLIN(1,IA)), |
| 20420 | * & ' Sigma_st',SNGL(ZSTLIN(2,IA)) |
| 20421 | 5000 CONTINUE |
| 20422 | * | |
| 20423 | * +-------------------------------------------------------------------* |
| 20424 | RETURN |
| 20425 | END |
| 20426 | |
| 20427 | *$ CREATE DT_BERTTP.FOR |
| 20428 | *COPY DT_BERTTP |
| 20429 | * |
| 20430 | *=== berttp ===========================================================* |
| 20431 | * * |
| 20432 | SUBROUTINE DT_BERTTP |
| 20433 | |
| 20434 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 20435 | SAVE |
| 20436 | |
| 20437 | PARAMETER ( CSNNRM = 2.0D-15 ) |
| 20438 | PARAMETER ( ZERZER = 0.D+00 ) |
| 20439 | PARAMETER ( ONEONE = 1.D+00 ) |
| 20440 | PARAMETER ( THRTHR = 3.D+00 ) |
| 20441 | PARAMETER ( SIXSIX = 6.D+00 ) |
| 20442 | PARAMETER ( ONETHI = ONEONE / THRTHR ) |
| 20443 | PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 ) |
| 20444 | PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 ) |
| 20445 | PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 ) |
| 20446 | PARAMETER ( EMVGEV = 1.0 D-03 ) |
| 20447 | |
| 20448 | PARAMETER ( NSTBIS = 304 ) |
| 20449 | |
| 20450 | PARAMETER ( LUNIN = 5 ) |
| 20451 | PARAMETER ( LUNOUT = 6 ) |
| 20452 | **sr 19.5. set error output-unit from 15 to 6 |
| 20453 | PARAMETER ( LUNERR = 6 ) |
| 20454 | C--------------------------------------------------------------------- |
| 20455 | C SUBNAME = DT_BERTTP --- READ BERTINI DATA |
| 20456 | C--------------------------------------------------------------------- |
| 20457 | C ---------------------------------- I-N-C DATA |
| 20458 | C COMMON R8(2127),R4(64),CRSC(600,4),R8B(336),CS(29849) |
| 20459 | C REAL*8 R8,R8B,CRSC,CS |
| 20460 | C REAL*4 R4 |
| 20461 | C --------------------------------- EVAPORATION DATA |
| 20462 | * (original name: COOKCM) |
| 20463 | PARAMETER ( ASMTOG = SIXSIX / PIPIPI**2 ) |
| 20464 | LOGICAL LDEFOZ, LDEFON |
| 20465 | PARAMETER ( INCOOK = 150, IZCOOK = 98 ) |
| 20466 | COMMON /FKCOOK/ ALPIGN, BETIGN, GAMIGN, POWIGN, |
| 20467 | & SZCOOK (IZCOOK), SNCOOK (INCOOK), PZCOOK (IZCOOK), |
| 20468 | & PNCOOK (INCOOK), LDEFOZ (IZCOOK), LDEFON (INCOOK) |
| 20469 | * (original name: EVA0) |
| 20470 | COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001), |
| 20471 | * FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6), |
| 20472 | * CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200), |
| 20473 | * T (4,7), RMASS (297), ALPH (297), BET (297), |
| 20474 | * APRIME (250), IA (6), IZ (6) |
| 20475 | * (original name: FRBKCM) |
| 20476 | PARAMETER ( MXFFBK = 6 ) |
| 20477 | PARAMETER ( MXZFBK = 9 ) |
| 20478 | PARAMETER ( MXNFBK = 10 ) |
| 20479 | PARAMETER ( MXAFBK = 16 ) |
| 20480 | PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 ) |
| 20481 | PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 ) |
| 20482 | PARAMETER ( NXAFBK = MXAFBK + 1 ) |
| 20483 | PARAMETER ( MXPSST = 300 ) |
| 20484 | PARAMETER ( MXPSFB = 41000 ) |
| 20485 | LOGICAL LFRMBK, LNCMSS |
| 20486 | COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST), |
| 20487 | & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB), |
| 20488 | & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK, |
| 20489 | & IFRBKN (MXPSST), IFRBKZ (MXPSST), |
| 20490 | & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST), |
| 20491 | & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK), |
| 20492 | & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK), |
| 20493 | & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF, |
| 20494 | & IFBFRB, NBUFBK, LFRMBK, LNCMSS |
| 20495 | * (original name: HETTP) |
| 20496 | COMMON /FKHETP/ NHSTP,NBERTP,IOSUB,INSRS |
| 20497 | * (original name: INPFLG) |
| 20498 | COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK |
| 20499 | * (original name: ISOTOP) |
| 20500 | PARAMETER ( NAMSMX = 270 ) |
| 20501 | PARAMETER ( NZGVAX = 15 ) |
| 20502 | PARAMETER ( NISMMX = 574 ) |
| 20503 | COMMON /FKISOT/ WAPS (NAMSMX,NZGVAX), T12NUC (NAMSMX,NZGVAX), |
| 20504 | & WAPISM (NISMMX), T12ISM (NISMMX), |
| 20505 | & ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260), |
| 20506 | & AMSSST (100) , ISOMNM (NSTBIS), ISONDX (2,100), |
| 20507 | & JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX), |
| 20508 | & INWAPS (NAMSMX), JSPISM (NISMMX), |
| 20509 | & JPTISM (NISMMX), IZWISM (NISMMX), |
| 20510 | & INWISM (0:NAMSMX) |
| 20511 | * (original name: NUCGID,NUCGEO,NUCGE2,NUCPWI,NUCGII) |
| 20512 | PARAMETER ( PI = PIPIPI ) |
| 20513 | PARAMETER ( PISQ = PIPISQ ) |
| 20514 | PARAMETER ( SKTOHL = 0.5456645846610345D+00 ) |
| 20515 | PARAMETER ( RZNUCL = 1.12 D+00 ) |
| 20516 | PARAMETER ( RMSPRO = 0.8 D+00 ) |
| 20517 | PARAMETER ( R0PROT = RMSPRO / SQRT12 ) |
| 20518 | PARAMETER ( ARHPRO = 1.D+00 / 8.D+00 / PI / R0PROT / R0PROT |
| 20519 | & / R0PROT ) |
| 20520 | PARAMETER ( RLLE04 = RZNUCL ) |
| 20521 | PARAMETER ( RLLE16 = RZNUCL ) |
| 20522 | PARAMETER ( RLGT16 = RZNUCL ) |
| 20523 | PARAMETER ( RCLE04 = 0.75D+00 / PI / RLLE04 / RLLE04 / RLLE04 ) |
| 20524 | PARAMETER ( RCLE16 = 0.75D+00 / PI / RLLE16 / RLLE16 / RLLE16 ) |
| 20525 | PARAMETER ( RCGT16 = 0.75D+00 / PI / RLGT16 / RLGT16 / RLGT16 ) |
| 20526 | PARAMETER ( SKLE04 = 1.4D+00 ) |
| 20527 | PARAMETER ( SKLE16 = 1.9D+00 ) |
| 20528 | PARAMETER ( SKGT16 = 2.4D+00 ) |
| 20529 | PARAMETER ( HLLE04 = SKTOHL * SKLE04 ) |
| 20530 | PARAMETER ( HLLE16 = SKTOHL * SKLE16 ) |
| 20531 | PARAMETER ( HLGT16 = SKTOHL * SKGT16 ) |
| 20532 | PARAMETER ( ALPHA0 = 0.1D+00 ) |
| 20533 | PARAMETER ( OMALH0 = 1.D+00 - ALPHA0 ) |
| 20534 | PARAMETER ( GAMSK0 = 0.9D+00 ) |
| 20535 | PARAMETER ( OMGAS0 = 1.D+00 - GAMSK0 ) |
| 20536 | PARAMETER ( POTME0 = 0.6666666666666667D+00 ) |
| 20537 | PARAMETER ( POTBA0 = 1.D+00 ) |
| 20538 | PARAMETER ( PNFRAT = 1.533D+00 ) |
| 20539 | PARAMETER ( RADPIM = 0.035D+00 ) |
| 20540 | PARAMETER ( RDPMHL = 14.D+00 ) |
| 20541 | PARAMETER ( APMRST = 4.D+00 / 44.D+00 ) |
| 20542 | PARAMETER ( APMPRO = 1.D+00 / 6.D+00 ) |
| 20543 | PARAMETER ( APPPRO = 5.D+00 / 6.D+00 ) |
| 20544 | PARAMETER ( AP0PFS = 0.5D+00 ) |
| 20545 | PARAMETER ( AP0PFP = 1.D+00 / 3.D+00 ) |
| 20546 | PARAMETER ( AP0NFP = 2.D+00 / 3.D+00 ) |
| 20547 | PARAMETER ( XPAUCO = 1.88495407241652 D+00 ) |
| 20548 | PARAMETER ( MXSCIN = 50 ) |
| 20549 | LOGICAL LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH, LNCDCY, |
| 20550 | & LNUSCT, LPREEQ, LNPHTC, LNWRAD, LPNRHO, LFTCMP, LFTCAC |
| 20551 | COMMON /FKNGID/ RHOTAB (2:260), RHATAB (2:260), ALPTAB (2:260), |
| 20552 | & RADTAB (2:260), SKITAB (2:260), HALTAB (2:260), |
| 20553 | & SK3TAB (2:260), SK4TAB (2:260), HABTAB (2:260), |
| 20554 | & CWSTAB (2:260), EKATAB (2:260), PFATAB (2:260), |
| 20555 | & PFRTAB (2:260) |
| 20556 | COMMON /FKNGEO/ RADTOT, RADIU1, RADIU0, RAD1O2, SKINDP, HALODP, |
| 20557 | & ALPHAL, OMALHL, RADSKN, SKNEFF, CPARWS, RADPRO, |
| 20558 | & RADCOR, RADCO2, RADMAX, BIMPTR, RIMPTR, XIMPTR, |
| 20559 | & YIMPTR, ZIMPTR, RHOIMT, EKFPRO, PFRPRO, RHOCEN, |
| 20560 | & RHOCOR, RHOSKN, EKFCEN (2), PFRCEN (2), EKFBIM, |
| 20561 | & PFRBIM, RHOIMP, EKFIMP, PFRIMP, RHOIM2, EKFIM2, |
| 20562 | & PFRIM2, RHOIM3, EKFIM3, PFRIM3, VPRWLL, RIMPCT, |
| 20563 | & BIMPCT, XIMPCT, YIMPCT, ZIMPCT, RIMPC2, XIMPC2, |
| 20564 | & YIMPC2, ZIMPC2, RIMPC3, XIMPC3, YIMPC3, ZIMPC3, |
| 20565 | & XBIMPC, YBIMPC, ZBIMPC, CXIMPC, CYIMPC, CZIMPC, |
| 20566 | & SQRIMP, SIGMAP, SIGMAN, SIGMAA, RHORED, R0TRAJ, |
| 20567 | & R1TRAJ, SBUSED, SBTOT , SBRES , RHOAVE, EKFAVE, |
| 20568 | & PFRAVE, AVEBIN, ACOLL , ZCOLL , RADSIG, OPACTY, |
| 20569 | & EKECON, PNUCCO, EKEWLL, PPRWLL, PXPROJ, PYPROJ, |
| 20570 | & PZPROJ, EKFERM, PNFRMI, PXFERM, PYFERM, PZFERM, |
| 20571 | & EKFER2, PNFRM2, PXFER2, PYFER2, PZFER2, EKFER3, |
| 20572 | & PNFRM3, PXFER3, PYFER3, PZFER3, RHOMEM, EKFMEM, |
| 20573 | & BIMMEM, WLLRED, VPRBIM, POTINC, POTOUT, EEXMIN |
| 20574 | COMMON /FKNGE2/ RDTTNC (2), RHONCP (2), RHONC2 (2), RHONC3 (2), |
| 20575 | & RHONCT (2), AMOTHR, EKOTHR, AMCREA, EKNCLN, |
| 20576 | & EEXDEL, EEXANY, CLMBBR, RDCLMB, BFCLMB, BFCEFF, |
| 20577 | & BNPROJ, BNDNUC, DEBRLM, SK4PAR, UBIMPC, VBIMPC, |
| 20578 | & WBIMPC, BNDPOT, SIGMAT, SIGABP, SIGABN, WLLRES, |
| 20579 | & POTBAR, POTMES, AGEPRI, OPNOPA, ETHRND, |
| 20580 | & BNENRG (3), DEFNUC (2), SIGMPR (4), SIGMNU (4), |
| 20581 | & SIGPAB (3), SIGNAB (3), HHLP (2), FORTOT (2), |
| 20582 | & FPNBLC, DPNBLC, FFTFLG, IFTFLG, |
| 20583 | & IPWELL, ITNCMX, KPRIN , NTARGT, KNUCIM, KNUCI2, |
| 20584 | & KNUCI3, IEVPRE, ISFCOL, ISFTAR, ISFTA2, ISFTA3, |
| 20585 | & NPOTHR, ICOTHR, IBOTHR, NPUMFN, ISTNCL, ITAUCM, |
| 20586 | & IABCOU, IADFLG, IGSFLG, IALFLG, ICBFLG, LPREEQ, |
| 20587 | & LNPHTC, LPNRHO, LNWRAD, LFTCMP, LFTCAC |
| 20588 | COMMON /FKNPWI/ ALMBAR, BIMMAX, SIGGEO, LLLMAX, LLLACT |
| 20589 | COMMON /FKNGII/ HOLEXP (2*MXSCIN), XEXPIN (3,0:MXSCIN), |
| 20590 | & YEXPIN (3,0:MXSCIN), ZEXPIN (3,0:MXSCIN), |
| 20591 | & AGEXIN (0:MXSCIN), RHOEXP (2), EKFEXP, EHLFIX, |
| 20592 | & NHLEXP, NHLFIX, IPRTYP, NNCEXI (0:MXSCIN), |
| 20593 | & NCEXPI (3,0:MXSCIN), ISEXIN (3,0:MXSCIN), |
| 20594 | & ISCTYP (0:MXSCIN), NUSCIN, NEXPEM, |
| 20595 | & LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH, |
| 20596 | & LNCDCY, LNUSCT |
| 20597 | DIMENSION AWSTAB (2:260), SIGMAB (3) |
| 20598 | EQUIVALENCE ( DEFPRO, DEFNUC (1) ) |
| 20599 | EQUIVALENCE ( DEFNEU, DEFNUC (2) ) |
| 20600 | EQUIVALENCE ( RHOIPP, RHONCP (1) ) |
| 20601 | EQUIVALENCE ( RHOINP, RHONCP (2) ) |
| 20602 | EQUIVALENCE ( RHOIP2, RHONC2 (1) ) |
| 20603 | EQUIVALENCE ( RHOIN2, RHONC2 (2) ) |
| 20604 | EQUIVALENCE ( RHOIP3, RHONC3 (1) ) |
| 20605 | EQUIVALENCE ( RHOIN3, RHONC3 (2) ) |
| 20606 | EQUIVALENCE ( RHOIPT, RHONCT (1) ) |
| 20607 | EQUIVALENCE ( RHOINT, RHONCT (2) ) |
| 20608 | EQUIVALENCE ( OMALHL, SK3PAR ) |
| 20609 | EQUIVALENCE ( ALPHAL, HABPAR ) |
| 20610 | EQUIVALENCE ( ALPTAB (2), AWSTAB (2) ) |
| 20611 | EQUIVALENCE ( SIGMPE, SIGMPR (1) ) |
| 20612 | EQUIVALENCE ( SIGMPC, SIGMPR (2) ) |
| 20613 | EQUIVALENCE ( SIGMPI, SIGMPR (3) ) |
| 20614 | EQUIVALENCE ( SIGMPA, SIGMPR (4) ) |
| 20615 | EQUIVALENCE ( SIGMNE, SIGMNU (1) ) |
| 20616 | EQUIVALENCE ( SIGMNC, SIGMNU (2) ) |
| 20617 | EQUIVALENCE ( SIGMNI, SIGMNU (3) ) |
| 20618 | EQUIVALENCE ( SIGMNA, SIGMNU (4) ) |
| 20619 | EQUIVALENCE ( SIGMA2, SIGPAB (1) ) |
| 20620 | EQUIVALENCE ( SIGMA3, SIGPAB (2) ) |
| 20621 | EQUIVALENCE ( SIGMAS, SIGPAB (3) ) |
| 20622 | EQUIVALENCE ( SIGPAB (1), SIGMAB (1) ) |
| 20623 | * (original name: NUCLEV) |
| 20624 | LOGICAL LCLVSL, LFLVSL, LRLVSL, LEQSBL |
| 20625 | COMMON /FKNLEV/ PAENUC (200,2), SHENUC (200,2), DEFRMI (2), |
| 20626 | & DEFMAG (2), ENNCLV (160,2), RANCLV (160,2), |
| 20627 | & CUMRAD (0:160,2), RUSNUC (2), |
| 20628 | & ENPLVL (114), ENNLVL(164), JUSNUC (160,2), |
| 20629 | & NTANUC (2), NAVNUC (2), NLSNUC (2), NCONUC (2), |
| 20630 | & NSKNUC (2), NHANUC (2), NUSNUC (2), NACNUC (2), |
| 20631 | & JMXNUC (2), IPRNUC (3), JPRNUC (3), MAGNUM (8), |
| 20632 | & MAGNUC (2), MGSNUC (8,2), MGSSNC (25,2), |
| 20633 | & NSBSHL (2), NMNSBS (2), NPRNUC, INUCLV, LCLVSL, |
| 20634 | & LFLVSL, LRLVSL, LEQSBL |
| 20635 | DIMENSION JUSPRO (160), JUSNEU (160), MGSPRO (8), MGSNEU (8), |
| 20636 | & MGSSPR (19) , MGSSNE (25) |
| 20637 | EQUIVALENCE ( RUSNUC (1), RUSPRO ) |
| 20638 | EQUIVALENCE ( RUSNUC (2), RUSNEU ) |
| 20639 | EQUIVALENCE ( JUSNUC (1,1), JUSPRO (1) ) |
| 20640 | EQUIVALENCE ( JUSNUC (1,2), JUSNEU (1) ) |
| 20641 | EQUIVALENCE ( MGSNUC (1,1), MGSPRO (1) ) |
| 20642 | EQUIVALENCE ( MGSNUC (1,2), MGSNEU (1) ) |
| 20643 | EQUIVALENCE ( MGSSNC (1,1), MGSSPR (1) ) |
| 20644 | EQUIVALENCE ( MGSSNC (1,2), MGSSNE (1) ) |
| 20645 | EQUIVALENCE ( NTANUC (1), NTAPRO ) |
| 20646 | EQUIVALENCE ( NTANUC (2), NTANEU ) |
| 20647 | EQUIVALENCE ( NAVNUC (1), NAVPRO ) |
| 20648 | EQUIVALENCE ( NAVNUC (2), NAVNEU ) |
| 20649 | EQUIVALENCE ( NLSNUC (1), NLSPRO ) |
| 20650 | EQUIVALENCE ( NLSNUC (2), NLSNEU ) |
| 20651 | EQUIVALENCE ( NCONUC (1), NCOPRO ) |
| 20652 | EQUIVALENCE ( NCONUC (2), NCONEU ) |
| 20653 | EQUIVALENCE ( NSKNUC (1), NSKPRO ) |
| 20654 | EQUIVALENCE ( NSKNUC (2), NSKNEU ) |
| 20655 | EQUIVALENCE ( NHANUC (1), NHAPRO ) |
| 20656 | EQUIVALENCE ( NHANUC (2), NHANEU ) |
| 20657 | EQUIVALENCE ( NUSNUC (1), NUSPRO ) |
| 20658 | EQUIVALENCE ( NUSNUC (2), NUSNEU ) |
| 20659 | EQUIVALENCE ( NACNUC (1), NACPRO ) |
| 20660 | EQUIVALENCE ( NACNUC (2), NACNEU ) |
| 20661 | EQUIVALENCE ( JMXNUC (1), JMXPRO ) |
| 20662 | EQUIVALENCE ( JMXNUC (2), JMXNEU ) |
| 20663 | EQUIVALENCE ( MAGNUC (1), MAGPRO ) |
| 20664 | EQUIVALENCE ( MAGNUC (2), MAGNEU ) |
| 20665 | * (original name: PAREVT) |
| 20666 | LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX, |
| 20667 | & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF |
| 20668 | PARAMETER ( NALLWP = 39 ) |
| 20669 | COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, |
| 20670 | & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY, |
| 20671 | & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV, |
| 20672 | & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF |
| 20673 | * (original name: XSEPAR) |
| 20674 | COMMON /FKXSEP/ AANXSE (100), BBNXSE (100), CCNXSE (100), |
| 20675 | & DDNXSE (100), EENXSE (100), ZZNXSE (100), |
| 20676 | & EMNXSE (100), XMNXSE (100), |
| 20677 | & AAPXSE (100), BBPXSE (100), CCPXSE (100), |
| 20678 | & DDPXSE (100), EEPXSE (100), FFPXSE (100), |
| 20679 | & ZZPXSE (100), EMPXSE (100), XMPXSE (100) |
| 20680 | |
| 20681 | C--------------------------------------------------------------------- |
| 20682 | **sr 17.5.95 |
| 20683 | * modified for use in DPMJET |
| 20684 | C WRITE( LUNOUT,'(A,I2)') |
| 20685 | C & ' *** Reading evaporation and nuclear data from unit: ', NBERTP |
| 20686 | C REWIND NBERTP |
| 20687 | IF (LEVPRT) WRITE(LUNOUT,1000) |
| 20688 | 1000 FORMAT(/,1X,'BERTTP:',4X,'Initialization of evaporation module', |
| 20689 | & /,12X,'------------------------------------',/) |
| 20690 | NBERNW = 23 |
| f87dab60 |
20691 | CPH OPEN (UNIT=NBERNW,FILE='dpmjet.dat',STATUS='UNKNOWN') |
| 9aaba0d6 |
20692 | |
| 20693 | **sr 17.5. |
| 20694 | *!!!! changed to be able to read the ASCII !!!! |
| 20695 | ** |
| 20696 | C A. Ferrari: first of all read isotopic data |
| 20697 | READ (NBERNW,*) ISONDX |
| 20698 | READ (NBERNW,*) ISOMNM |
| 20699 | READ (NBERNW,*) ABUISO |
| 20700 | C READ (NBERTP) ISONDX |
| 20701 | C READ (NBERTP) ISOMNM |
| 20702 | C READ (NBERTP) ABUISO |
| 20703 | DO 1 I=1,4 |
| 20704 | C READ (NBERTP) (CRSC(J,I),J=1,600) |
| 20705 | C A. Ferrari: commented also the dummy read to save disk space |
| 20706 | C READ (NBERTP) |
| 20707 | 1 CONTINUE |
| 20708 | C READ (NBERTP) CS |
| 20709 | C A. Ferrari: commented also the dummy read to save disk space |
| 20710 | C READ (NBERTP) |
| 20711 | C--------------------------------------------------------------------- |
| 20712 | READ (NBERNW,*) (P0(I),P1(I),P2(I),I=1,1001) |
| 20713 | READ (NBERNW,*) IA,IZ |
| 20714 | DO 2 I=1,6 |
| 20715 | FLA(I)=IA(I) |
| 20716 | FLZ(I)=IZ(I) |
| 20717 | 2 CONTINUE |
| 20718 | READ (NBERNW,*) RHO,OMEGA |
| 20719 | READ (NBERNW,*) EXMASS |
| 20720 | READ (NBERNW,*) CAM2 |
| 20721 | READ (NBERNW,*) CAM3 |
| 20722 | READ (NBERNW,*) CAM4 |
| 20723 | READ (NBERNW,*) CAM5 |
| 20724 | READ (NBERNW,*) ((T(I,J),J=1,7),I=1,3) |
| 20725 | DO 3 I=1,7 |
| 20726 | T(4,I) = ZERZER |
| 20727 | 3 CONTINUE |
| 20728 | READ (NBERNW,*) RMASS |
| 20729 | READ (NBERNW,*) ALPH |
| 20730 | READ (NBERNW,*) BET |
| 20731 | READ (NBERNW,*) INWAPS |
| 20732 | READ (NBERNW,*) WAPS |
| 20733 | READ (NBERNW,*) T12NUC |
| 20734 | READ (NBERNW,*) JSPNUC |
| 20735 | READ (NBERNW,*) JPTNUC |
| 20736 | READ (NBERNW,*) INWISM |
| 20737 | READ (NBERNW,*) IZWISM |
| 20738 | READ (NBERNW,*) WAPISM |
| 20739 | READ (NBERNW,*) T12ISM |
| 20740 | READ (NBERNW,*) JSPISM |
| 20741 | READ (NBERNW,*) JPTISM |
| 20742 | READ (NBERNW,*) APRIME |
| 20743 | IF (LEVPRT) |
| 20744 | &WRITE( LUNOUT,'(A)' ) ' *** Evaporation: using 1977 Waps data ***' |
| 20745 | READ (NBERNW,*) AHELP , BHELP , LRMSCH, LRD1O2, LTRASP |
| 20746 | IF ( ABS (AHELP-ALPHA0) .GT. CSNNRM * ALPHA0 .OR. |
| 20747 | & ABS (BHELP-GAMSK0) .GT. CSNNRM * GAMSK0 ) THEN |
| 20748 | WRITE (LUNOUT,*) |
| 20749 | & ' *** Inconsistent Nuclear Geometry data on file ***' |
| 20750 | STOP |
| 20751 | END IF |
| 20752 | READ (NBERNW,*) RHOTAB, RHATAB, ALPTAB, RADTAB, SKITAB, HALTAB, |
| 20753 | & EKATAB, PFATAB, PFRTAB |
| 20754 | READ (NBERNW,*) AANXSE, BBNXSE, CCNXSE, DDNXSE, EENXSE, ZZNXSE, |
| 20755 | & EMNXSE, XMNXSE |
| 20756 | READ (NBERNW,*) AAPXSE, BBPXSE, CCPXSE, DDPXSE, EEPXSE, FFPXSE, |
| 20757 | & ZZPXSE, EMPXSE, XMPXSE |
| 20758 | * Data about Fermi-breakup: |
| 20759 | READ (NBERNW,*) IPOSST, MXPDUM, MXADUM, MXNDUM, MXZDUM, IFBSTF |
| 20760 | IF ( MXADUM .NE. MXAFBK .OR. MXNDUM .NE. MXNFBK .OR. MXZDUM .NE. |
| 20761 | & MXZFBK .OR. MXPDUM .NE. MXPSST ) THEN |
| 20762 | WRITE (LUNOUT,*)' *** Inconsistent Fermi BreakUp data', |
| 20763 | & ' in the Nuclear Data file ***' |
| 20764 | STOP 'STOP:BERTTP-INCONS-FERMI-BREAKUP-DATA' |
| 20765 | END IF |
| 20766 | READ (NBERNW,*) IFRBKN |
| 20767 | READ (NBERNW,*) IFRBKZ |
| 20768 | READ (NBERNW,*) IFBKSP |
| 20769 | READ (NBERNW,*) IFBKST |
| 20770 | READ (NBERNW,*) EEXFBK |
| 20771 | |
| 20772 | CLOSE (UNIT=NBERNW) |
| 20773 | |
| 20774 | C READ (NBERTP) (P0(I),P1(I),P2(I),I=1,1001) |
| 20775 | C READ (NBERTP) IA,IZ |
| 20776 | C DO 2 I=1,6 |
| 20777 | C FLA(I)=IA(I) |
| 20778 | C FLZ(I)=IZ(I) |
| 20779 | C 2 CONTINUE |
| 20780 | C READ (NBERTP) RHO,OMEGA |
| 20781 | C READ (NBERTP) EXMASS |
| 20782 | C READ (NBERTP) CAM2 |
| 20783 | C READ (NBERTP) CAM3 |
| 20784 | C READ (NBERTP) CAM4 |
| 20785 | C READ (NBERTP) CAM5 |
| 20786 | C READ (NBERTP) ((T(I,J),J=1,7),I=1,3) |
| 20787 | C DO 3 I=1,7 |
| 20788 | C T(4,I) = ZERZER |
| 20789 | C 3 CONTINUE |
| 20790 | C READ (NBERTP) RMASS |
| 20791 | C READ (NBERTP) ALPH |
| 20792 | C READ (NBERTP) BET |
| 20793 | C READ (NBERTP) INWAPS |
| 20794 | C READ (NBERTP) WAPS |
| 20795 | C READ (NBERTP) T12NUC |
| 20796 | C READ (NBERTP) JSPNUC |
| 20797 | C READ (NBERTP) JPTNUC |
| 20798 | C READ (NBERTP) INWISM |
| 20799 | C READ (NBERTP) IZWISM |
| 20800 | C READ (NBERTP) WAPISM |
| 20801 | C READ (NBERTP) T12ISM |
| 20802 | C READ (NBERTP) JSPISM |
| 20803 | C READ (NBERTP) JPTISM |
| 20804 | C READ (NBERTP) APRIME |
| 20805 | C WRITE( LUNOUT,'(A)' ) ' *** Evaporation: using 1977 Waps data ***' |
| 20806 | C READ (NBERTP) AHELP , BHELP , LRMSCH, LRD1O2, LTRASP |
| 20807 | C IF ( ABS (AHELP-ALPHA0) .GT. CSNNRM * ALPHA0 .OR. |
| 20808 | C & ABS (BHELP-GAMSK0) .GT. CSNNRM * GAMSK0 ) THEN |
| 20809 | C WRITE (LUNOUT,*) |
| 20810 | C & ' *** Inconsistent Nuclear Geometry data on file ***' |
| 20811 | C STOP |
| 20812 | C END IF |
| 20813 | C READ (NBERTP) RHOTAB, RHATAB, ALPTAB, RADTAB, SKITAB, HALTAB, |
| 20814 | C & EKATAB, PFATAB, PFRTAB |
| 20815 | C READ (NBERTP) AANXSE, BBNXSE, CCNXSE, DDNXSE, EENXSE, ZZNXSE, |
| 20816 | C & EMNXSE, XMNXSE |
| 20817 | C READ (NBERTP) AAPXSE, BBPXSE, CCPXSE, DDPXSE, EEPXSE, FFPXSE, |
| 20818 | C & ZZPXSE, EMPXSE, XMPXSE |
| 20819 | * Data about Fermi-breakup: |
| 20820 | C READ (NBERTP) IPOSST, MXPDUM, MXADUM, MXNDUM, MXZDUM, IFBSTF |
| 20821 | C IF ( MXADUM .NE. MXAFBK .OR. MXNDUM .NE. MXNFBK .OR. MXZDUM .NE. |
| 20822 | C & MXZFBK .OR. MXPDUM .NE. MXPSST ) THEN |
| 20823 | C WRITE (LUNOUT,*)' *** Inconsistent Fermi BreakUp data', |
| 20824 | C & ' in the Nuclear Data file ***' |
| 20825 | C STOP 'STOP:BERTTP-INCONS-FERMI-BREAKUP-DATA' |
| 20826 | C END IF |
| 20827 | C READ (NBERTP) IFRBKN |
| 20828 | C READ (NBERTP) IFRBKZ |
| 20829 | C READ (NBERTP) IFBKSP |
| 20830 | C READ (NBERTP) IFBKST |
| 20831 | C READ (NBERTP) EEXFBK |
| 20832 | C CLOSE (UNIT=NBERTP) |
| 20833 | DO 100 JZ = 1, 130 |
| 20834 | SHENUC ( JZ, 1 ) = EMVGEV * ( CAM2 (JZ) + CAM4 (JZ) ) |
| 20835 | 100 CONTINUE |
| 20836 | DO 200 JA = 1, 200 |
| 20837 | SHENUC ( JA, 2 ) = EMVGEV * ( CAM3 (JA) + CAM5 (JA) ) |
| 20838 | 200 CONTINUE |
| 20839 | CALL DT_STALIN |
| 20840 | IF ( ILVMOD .LE. 0 ) THEN |
| 20841 | ILVMOD = IB0 |
| 20842 | ELSE |
| 20843 | IB0 = ILVMOD |
| 20844 | END IF |
| 20845 | IF ( LLVMOD ) THEN |
| 20846 | DO 300 JZ = 1, IZCOOK |
| 20847 | CAM4 (JZ) = PZCOOK (JZ) |
| 20848 | 300 CONTINUE |
| 20849 | DO 400 JN = 1, INCOOK |
| 20850 | CAM5 (JN) = PNCOOK (JZ) |
| 20851 | 400 CONTINUE |
| 20852 | END IF |
| 20853 | **sr |
| 20854 | IF (LEVPRT) THEN |
| 20855 | WRITE (LUNOUT,*) |
| 20856 | IF ( ILVMOD .EQ. 1 ) THEN |
| 20857 | WRITE (LUNOUT,*) |
| 20858 | & ' **** Standard EVAP T=0 level density used ****' |
| 20859 | ELSE IF ( ILVMOD .EQ. 2 ) THEN |
| 20860 | WRITE (LUNOUT,*) |
| 20861 | & ' **** Gilbert & Cameron T=0 N,Z-dep. level density used ****' |
| 20862 | ELSE IF ( ILVMOD .EQ. 3 ) THEN |
| 20863 | WRITE (LUNOUT,*) |
| 20864 | & ' **** Julich A-dependent level density used ****' |
| 20865 | ELSE IF ( ILVMOD .EQ. 4 ) THEN |
| 20866 | WRITE (LUNOUT,*) |
| 20867 | & ' **** Brancazio & Cameron T=0 N,Z-dep. level density used', |
| 20868 | & ' ****' |
| 20869 | ELSE |
| 20870 | WRITE (LUNOUT,*) |
| 20871 | & ' **** Unknown T=0 level density option requested ****' |
| 20872 | STOP 'BERTTP-ILVMOD' |
| 20873 | END IF |
| 20874 | IF ( JLVMOD .LE. 0 ) THEN |
| 20875 | GAMIGN = ZERZER |
| 20876 | WRITE (LUNOUT,*) |
| 20877 | & ' **** No Excitation en. dependence for level densities ****' |
| 20878 | ELSE IF ( JLVMOD .EQ. 1 ) THEN |
| 20879 | WRITE (LUNOUT,*) |
| 20880 | & ' **** Ignyatuk (1975, 1st) level density en. dep. used ****' |
| 20881 | WRITE (LUNOUT,*) |
| 20882 | & ' **** with Ignyatuk (1975, 1st) set of parameters for T=oo', |
| 20883 | & ' ****' |
| 20884 | GAMIGN = 0.054D+00 |
| 20885 | BETIGN = -6.3 D-05 |
| 20886 | ALPIGN = 0.154D+00 |
| 20887 | POWIGN = ZERZER |
| 20888 | ELSE IF ( JLVMOD .EQ. 2 ) THEN |
| 20889 | WRITE (LUNOUT,*) |
| 20890 | & ' **** Ignyatuk (1975, 1st) level density en. dep. used ****' |
| 20891 | WRITE (LUNOUT,*) |
| 20892 | & ' **** with UNKNOWN set of parameters for T=oo ****' |
| 20893 | STOP 'BERTTP-JLVMOD' |
| 20894 | ELSE IF ( JLVMOD .EQ. 3 ) THEN |
| 20895 | WRITE (LUNOUT,*) |
| 20896 | & ' **** Ignyatuk (1975, 1st) level density en. dep. used ****' |
| 20897 | WRITE (LUNOUT,*) |
| 20898 | & ' **** with UNKNOWN set of parameters for T=oo ****' |
| 20899 | STOP 'BERTTP-JLVMOD' |
| 20900 | ELSE IF ( JLVMOD .EQ. 4 ) THEN |
| 20901 | WRITE (LUNOUT,*) |
| 20902 | & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****' |
| 20903 | WRITE (LUNOUT,*) |
| 20904 | & ' **** with Ignyatuk (1975, 2nd) set of parameters for T=oo', |
| 20905 | & ' ****' |
| 20906 | GAMIGN = 0.054D+00 |
| 20907 | BETIGN = 0.162D+00 |
| 20908 | ALPIGN = 0.114D+00 |
| 20909 | POWIGN = -ONETHI |
| 20910 | ELSE IF ( JLVMOD .EQ. 5 ) THEN |
| 20911 | WRITE (LUNOUT,*) |
| 20912 | & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****' |
| 20913 | WRITE (LUNOUT,*) |
| 20914 | & ' **** with Iljinov & Mebel 1st set of parameters for T=oo****' |
| 20915 | GAMIGN = 0.051D+00 |
| 20916 | BETIGN = 0.098D+00 |
| 20917 | ALPIGN = 0.114D+00 |
| 20918 | POWIGN = -ONETHI |
| 20919 | ELSE IF ( JLVMOD .EQ. 6 ) THEN |
| 20920 | WRITE (LUNOUT,*) |
| 20921 | & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****' |
| 20922 | WRITE (LUNOUT,*) |
| 20923 | & ' **** with Iljinov & Mebel 2nd set of parameters for T=oo****' |
| 20924 | GAMIGN = -0.46D+00 |
| 20925 | BETIGN = 0.107D+00 |
| 20926 | ALPIGN = 0.111D+00 |
| 20927 | POWIGN = -ONETHI |
| 20928 | ELSE IF ( JLVMOD .EQ. 7 ) THEN |
| 20929 | WRITE (LUNOUT,*) |
| 20930 | & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****' |
| 20931 | WRITE (LUNOUT,*) |
| 20932 | & ' **** with Iljinov & Mebel 3rd set of parameters for T=oo****' |
| 20933 | GAMIGN = 0.059D+00 |
| 20934 | BETIGN = 0.257D+00 |
| 20935 | ALPIGN = 0.072D+00 |
| 20936 | POWIGN = -ONETHI |
| 20937 | ELSE IF ( JLVMOD .EQ. 8 ) THEN |
| 20938 | WRITE (LUNOUT,*) |
| 20939 | & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****' |
| 20940 | WRITE (LUNOUT,*) |
| 20941 | & ' **** with Iljinov & Mebel 4th set of parameters for T=oo****' |
| 20942 | GAMIGN = -0.37D+00 |
| 20943 | BETIGN = 0.229D+00 |
| 20944 | ALPIGN = 0.077D+00 |
| 20945 | POWIGN = -ONETHI |
| 20946 | ELSE |
| 20947 | WRITE (LUNOUT,*) |
| 20948 | & ' **** Unknown T=oo level density option requested ****' |
| 20949 | STOP 'BERTTP-JLVMOD' |
| 20950 | END IF |
| 20951 | IF ( LLVMOD ) THEN |
| 20952 | WRITE (LUNOUT,*) |
| 20953 | & ' **** Cook''s modified pairing energy used ****' |
| 20954 | ELSE |
| 20955 | WRITE (LUNOUT,*) |
| 20956 | & ' **** Original Gilbert/Cameron pairing energy used ****' |
| 20957 | END IF |
| 20958 | ENDIF |
| 20959 | ** |
| 20960 | |
| 20961 | ILVMOD = IB0 |
| 20962 | DO 500 JZ = 1, 130 |
| 20963 | PAENUC ( JZ, 1 ) = EMVGEV * CAM4 (JZ) |
| 20964 | 500 CONTINUE |
| 20965 | DO 600 JA = 1, 200 |
| 20966 | PAENUC ( JA, 2 ) = EMVGEV * CAM5 (JA) |
| 20967 | 600 CONTINUE |
| 20968 | RETURN |
| 20969 | END |
| 20970 | |
| 20971 | *$ CREATE DT_EVEVAP.FOR |
| 20972 | *COPY DT_EVEVAP |
| 20973 | * |
| 20974 | *====evevap============================================================* |
| 20975 | * |
| 20976 | SUBROUTINE DT_EVEVAP(WE) |
| 20977 | |
| 20978 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 20979 | SAVE |
| 20980 | PARAMETER ( LINP = 10 , |
| 20981 | & LOUT = 6 , |
| 20982 | & LDAT = 9 ) |
| 20983 | |
| 20984 | * flags for input different options |
| 20985 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 20986 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 20987 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 20988 | |
| 20989 | LEVAPO = .FALSE. |
| 20990 | |
| 20991 | RETURN |
| 20992 | END |
| 20993 | |
| 20994 | *$ CREATE DT_FRBKIN.FOR |
| 20995 | *COPY DT_FRBKIN |
| 20996 | * |
| 20997 | *====frbkin============================================================* |
| 20998 | * |
| 20999 | SUBROUTINE DT_FRBKIN(LDUM1,LDUM2) |
| 21000 | |
| 21001 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 21002 | SAVE |
| 21003 | PARAMETER ( LINP = 10 , |
| 21004 | & LOUT = 6 , |
| 21005 | & LDAT = 9 ) |
| 21006 | |
| 21007 | LOGICAL LDUM1,LDUM2 |
| 21008 | |
| 21009 | RETURN |
| 21010 | END |
| 21011 | |
| 21012 | *$ CREATE DT_EXPLOD.FOR |
| 21013 | *COPY DT_EXPLOD |
| 21014 | * |
| 21015 | *=== explod ===========================================================* |
| 21016 | * |
| 21017 | SUBROUTINE DT_EXPLOD( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL, |
| 21018 | & PYEXPL, PZEXPL ) |
| 21019 | |
| 21020 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 21021 | SAVE |
| 21022 | |
| 21023 | DIMENSION PXEXPL (NPEXPL), PYEXPL (NPEXPL), PZEXPL (NPEXPL), |
| 21024 | & ETEXPL (NPEXPL), AMEXPL (NPEXPL) |
| 21025 | |
| 21026 | RETURN |
| 21027 | END |
| 21028 | |
| 21029 | ************************************************************************ |
| 21030 | * * |
| 21031 | * DPMJET 3.0: cross section routines * |
| 21032 | * * |
| 21033 | ************************************************************************ |
| 21034 | * |
| 21035 | * |
| 21036 | * SUBROUTINE DT_SHNDIF |
| 21037 | * diffractive cross sections (all energies) |
| 21038 | * SUBROUTINE DT_PHOXS |
| 21039 | * total and inel. cross sections from PHOJET interpol. tables |
| 21040 | * SUBROUTINE DT_XSHN |
| 21041 | * total and el. cross sections for all energies |
| 21042 | * SUBROUTINE DT_SIHNAB |
| 21043 | * pion 2-nucleon absorption cross sections |
| 21044 | * SUBROUTINE DT_SIGEMU |
| 21045 | * cross section for target "compounds" |
| 21046 | * SUBROUTINE DT_SIGGA |
| 21047 | * photon nucleus cross sections |
| 21048 | * SUBROUTINE DT_SIGGAT |
| 21049 | * photon nucleus cross sections from tables |
| 21050 | * SUBROUTINE DT_SANO |
| 21051 | * anomalous hard photon-nucleon cross sections from tables |
| 21052 | * SUBROUTINE DT_SIGGP |
| 21053 | * photon nucleon cross sections |
| 21054 | * SUBROUTINE DT_SIGVEL |
| 21055 | * quasi-elastic vector meson prod. cross sections |
| 21056 | * DOUBLE PRECISION FUNCTION DT_SIGVP |
| 21057 | * sigma_VN(tilde) |
| 21058 | * DOUBLE PRECISION FUNCTION DT_RRM2 |
| 21059 | * DOUBLE PRECISION FUNCTION DT_RM2 |
| 21060 | * DOUBLE PRECISION FUNCTION DT_SAM2 |
| 21061 | * SUBROUTINE DT_CKMT |
| 21062 | * SUBROUTINE DT_CKMTX |
| 21063 | * SUBROUTINE DT_PDF0 |
| 21064 | * SUBROUTINE DT_CKMTQ0 |
| 21065 | * SUBROUTINE DT_CKMTDE |
| 21066 | * SUBROUTINE DT_CKMTPR |
| 21067 | * FUNCTION DT_CKMTFF |
| 21068 | * |
| 21069 | * SUBROUTINE DT_FLUINI |
| 21070 | * total nucleon cross section fluctuation treatment |
| 21071 | * |
| 21072 | * SUBROUTINE DT_SIGTBL |
| 21073 | * pre-tabulation of low-energy elastic x-sec. using SIHNEL |
| 21074 | * SUBROUTINE DT_XSTABL |
| 21075 | * service routines |
| 21076 | * |
| 21077 | * |
| 21078 | *$ CREATE DT_SHNDIF.FOR |
| 21079 | *COPY DT_SHNDIF |
| 21080 | * |
| 21081 | *===shndif===============================================================* |
| 21082 | * |
| 21083 | SUBROUTINE DT_SHNDIF(ECM,KPROJ,KTARG,SIGDIF,SIGDIH) |
| 21084 | |
| 21085 | ********************************************************************** |
| 21086 | * Single diffractive hadron-nucleon cross sections * |
| 21087 | * S.Roesler 14/1/93 * |
| 21088 | * * |
| 21089 | * The cross sections are calculated from extrapolated single * |
| 21090 | * diffractive antiproton-proton cross sections (DTUJET92) using * |
| 21091 | * scaling relations between total and single diffractive cross * |
| 21092 | * sections. * |
| 21093 | ********************************************************************** |
| 21094 | |
| 21095 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 21096 | SAVE |
| 21097 | PARAMETER (ZERO=0.0D0) |
| 21098 | |
| 21099 | * particle properties (BAMJET index convention) |
| 21100 | CHARACTER*8 ANAME |
| 21101 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 21102 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 21103 | * |
| 21104 | CSD1 = 4.201483727D0 |
| 21105 | CSD4 = -0.4763103556D-02 |
| 21106 | CSD5 = 0.4324148297D0 |
| 21107 | * |
| 21108 | CHMSD1 = 0.8519297242D0 |
| 21109 | CHMSD4 = -0.1443076599D-01 |
| 21110 | CHMSD5 = 0.4014954567D0 |
| 21111 | * |
| 21112 | EPN = (ECM**2 -AAM(KPROJ)**2 -AAM(KTARG)**2)/(2.0D0*AAM(KTARG)) |
| 21113 | PPN = SQRT((EPN-AAM(KPROJ))*(EPN+AAM(KPROJ))) |
| 21114 | * |
| 21115 | SDIAPP = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN) |
| 21116 | SHMSD = CHMSD1+CHMSD4*LOG(PPN)**2+CHMSD5*LOG(PPN) |
| 21117 | FRAC = SHMSD/SDIAPP |
| 21118 | * |
| 21119 | GOTO( 10, 20,999,999,999,999,999, 10, 20,999, |
| 21120 | & 999, 20, 20, 20, 20, 20, 10, 20, 20, 10, |
| 21121 | & 10, 10, 20, 20, 20) KPROJ |
| 21122 | * |
| 21123 | 10 CONTINUE |
| 21124 | *---------------------------- p - p , n - p , sigma0+- - p , |
| 21125 | * Lambda - p |
| 21126 | CSD1 = 6.004476070D0 |
| 21127 | CSD4 = -0.1257784606D-03 |
| 21128 | CSD5 = 0.2447335720D0 |
| 21129 | SIGDIF = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN) |
| 21130 | SIGDIH = FRAC*SIGDIF |
| 21131 | RETURN |
| 21132 | * |
| 21133 | 20 CONTINUE |
| 21134 | * |
| 21135 | KPSCAL = 2 |
| 21136 | KTSCAL = 1 |
| 21137 | C F = SDIAPP/DT_SHNTOT(KPSCAL,KTSCAL,ECM,ZERO) |
| 21138 | DUMZER = ZERO |
| 21139 | CALL DT_XSHN(KPSCAL,KTSCAL,DUMZER,ECM,SIGTO,SIGEL) |
| 21140 | F = SDIAPP/SIGTO |
| 21141 | KT = 1 |
| 21142 | C SIGDIF = DT_SHNTOT(KPROJ,KT,ECM,ZERO)*F |
| 21143 | CALL DT_XSHN(KPROJ,KT,DUMZER,ECM,SIGTO,SIGEL) |
| 21144 | SIGDIF = SIGTO*F |
| 21145 | SIGDIH = FRAC*SIGDIF |
| 21146 | RETURN |
| 21147 | * |
| 21148 | 999 CONTINUE |
| 21149 | *-------------------------- leptons.. |
| 21150 | SIGDIF = 1.D-10 |
| 21151 | SIGDIH = 1.D-10 |
| 21152 | RETURN |
| 21153 | END |
| 21154 | |
| 21155 | *$ CREATE DT_PHOXS.FOR |
| 21156 | *COPY DT_PHOXS |
| 21157 | * |
| 21158 | *===phoxs================================================================* |
| 21159 | * |
| 21160 | SUBROUTINE DT_PHOXS(KPROJ,KTARG,ECM,PLAB,STOT,SINE,SDIF1,BEL,MODE) |
| 21161 | |
| 21162 | ************************************************************************ |
| 21163 | * Total/inelastic proton-nucleon cross sections taken from PHOJET- * |
| 21164 | * interpolation tables. * |
| 21165 | * This version dated 05.11.97 is written by S. Roesler * |
| 21166 | ************************************************************************ |
| 21167 | |
| 21168 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 21169 | SAVE |
| 21170 | |
| 21171 | PARAMETER ( LINP = 10 , |
| 21172 | & LOUT = 6 , |
| 21173 | & LDAT = 9 ) |
| 21174 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0) |
| 21175 | PARAMETER (TWOPI = 6.283185307179586454D+00, |
| 21176 | & PI = TWOPI/TWO, |
| 21177 | & GEV2MB = 0.38938D0) |
| 21178 | |
| 21179 | LOGICAL LFIRST |
| 21180 | DATA LFIRST /.TRUE./ |
| 21181 | |
| 21182 | * nucleon-nucleon event-generator |
| 21183 | CHARACTER*8 CMODEL |
| 21184 | LOGICAL LPHOIN |
| 21185 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN |
| 21186 | * particle properties (BAMJET index convention) |
| 21187 | CHARACTER*8 ANAME |
| 21188 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 21189 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 21190 | |
| 21191 | **PHOJET105a |
| 21192 | C PARAMETER (IEETAB=10) |
| 21193 | C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX |
| 21194 | **PHOJET110 |
| 21195 | C energy-interpolation table |
| 21196 | INTEGER IEETA2 |
| 21197 | PARAMETER ( IEETA2 = 20 ) |
| 21198 | INTEGER ISIMAX |
| 21199 | DOUBLE PRECISION SIGTAB,SIGECM |
| 21200 | COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX |
| 21201 | ** |
| 21202 | |
| 21203 | IF ((MCGENE.NE.2).AND.(MODE.NE.1)) THEN |
| 21204 | WRITE(LOUT,*) MCGENE |
| 21205 | 1000 FORMAT(1X,'PHOXS: warning! PHOJET not initialized (',I2,')') |
| 21206 | STOP |
| 21207 | ENDIF |
| 21208 | |
| 21209 | IF (ECM.LE.ZERO) THEN |
| 21210 | EPN = SQRT(AAM(KPROJ)**2+PLAB**2) |
| 21211 | ECM = SQRT(AAM(KPROJ)**2+AAM(KTARG)**2+2.0D0*EPN*AAM(KTARG)) |
| 21212 | ENDIF |
| 21213 | |
| 21214 | IF (MODE.EQ.1) THEN |
| 21215 | * DL |
| 21216 | DELDL = 0.0808D0 |
| 21217 | EPSDL = -0.4525D0 |
| 21218 | S = ECM*ECM |
| 21219 | STOT = 21.7D0*S**DELDL+56.08D0*S**EPSDL |
| 21220 | ALPHAP= 0.25D0 |
| 21221 | BEL = 8.5D0+2.D0*ALPHAP*LOG(S) |
| 21222 | SIGEL = STOT**2/(16.D0*PI*BEL*GEV2MB) |
| 21223 | SINE = STOT-SIGEL |
| 21224 | SDIF1 = ZERO |
| 21225 | ELSE |
| 21226 | * Phojet |
| 21227 | IP = 1 |
| 21228 | IF(ECM.LE.SIGECM(IP,1)) THEN |
| 21229 | I1 = 1 |
| 21230 | I2 = 1 |
| 21231 | ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN |
| 21232 | DO 1 I=2,ISIMAX |
| 21233 | IF (ECM.LE.SIGECM(IP,I)) GOTO 2 |
| 21234 | 1 CONTINUE |
| 21235 | 2 CONTINUE |
| 21236 | I1 = I-1 |
| 21237 | I2 = I |
| 21238 | ELSE |
| 21239 | IF (LFIRST) THEN |
| 21240 | WRITE(LOUT,'(/1X,A,2E12.3)') |
| 21241 | & 'PHOXS: warning! energy above initialization limit (', |
| 21242 | & ECM,SIGECM(IP,ISIMAX) |
| 21243 | LFIRST = .FALSE. |
| 21244 | ENDIF |
| 21245 | I1 = ISIMAX |
| 21246 | I2 = ISIMAX |
| 21247 | ENDIF |
| 21248 | FAC2 = ZERO |
| 21249 | IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1)) |
| 21250 | & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1)) |
| 21251 | FAC1 = ONE-FAC2 |
| 21252 | STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1) |
| 21253 | SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1) |
| 21254 | SDIF1 = FAC2*(SIGTAB(IP,30,I2)+SIGTAB(IP,32,I2))+ |
| 21255 | & FAC1*(SIGTAB(IP,30,I1)+SIGTAB(IP,32,I1)) |
| 21256 | BEL = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1) |
| 21257 | ENDIF |
| 21258 | |
| 21259 | RETURN |
| 21260 | END |
| 21261 | |
| 21262 | *$ CREATE DT_XSHN.FOR |
| 21263 | *COPY DT_XSHN |
| 21264 | * |
| 21265 | *===xshn===============================================================* |
| 21266 | * |
| 21267 | SUBROUTINE DT_XSHN(IP,IT,PL,ECM,STOT,SELA) |
| 21268 | |
| 21269 | ************************************************************************ |
| 21270 | * Total and elastic hadron-nucleon cross section. * |
| 21271 | * Below 500GeV cross sections are based on the '98 data compilation * |
| 21272 | * of the PDG. At higher energies PHOJET results are used (patched to * |
| 21273 | * the low energy data at 500GeV). * |
| 21274 | * IP projectile index (BAMJET numbering scheme) * |
| 21275 | * (should be in the range 1..25) * |
| 21276 | * IT target index (BAMJET numbering scheme) * |
| 21277 | * (1 = proton, 8 = neutron) * |
| 21278 | * PL laboratory momentum * |
| 21279 | * ECM cm. energy (ignored if PL>0) * |
| 21280 | * STOT total cross section * |
| 21281 | * SELA elastic cross section * |
| 21282 | * Last change: 24.4.99 by S. Roesler * |
| 21283 | ************************************************************************ |
| 21284 | |
| 21285 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 21286 | SAVE |
| 21287 | |
| 21288 | PARAMETER ( LINP = 10 , |
| 21289 | & LOUT = 6 , |
| 21290 | & LDAT = 9 ) |
| 21291 | PARAMETER (ZERO=0.0D0,ONE=1.0D0) |
| 21292 | |
| 21293 | PARAMETER (NPOIN1 = 54, NPOIN2 = 8, |
| 21294 | & PLABLO = 0.1D0, PTHRE = 5.0D0, PLABHI = 500.0D0) |
| 21295 | PARAMETER (NPOINT = NPOIN1+NPOIN2+1) |
| 21296 | |
| 21297 | LOGICAL LFIRST |
| 21298 | * particle properties (BAMJET index convention) |
| 21299 | CHARACTER*8 ANAME |
| 21300 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 21301 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 21302 | * nucleon-nucleon event-generator |
| 21303 | CHARACTER*8 CMODEL |
| 21304 | LOGICAL LPHOIN |
| 21305 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN |
| 21306 | **PHOJET105a |
| 21307 | C PARAMETER (IEETAB=10) |
| 21308 | C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX |
| 21309 | **PHOJET110 |
| 21310 | C energy-interpolation table |
| 21311 | INTEGER IEETA2 |
| 21312 | PARAMETER ( IEETA2 = 20 ) |
| 21313 | INTEGER ISIMAX |
| 21314 | DOUBLE PRECISION SIGTAB,SIGECM |
| 21315 | COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX |
| 21316 | |
| 21317 | DIMENSION APL(NPOINT),ASIGTO(10,NPOINT),ASIGEL(10,NPOINT) |
| 21318 | DIMENSION IDXDAT(25,2) |
| 21319 | * |
| 21320 | DATA APL / |
| 21321 | &-1.000,-0.969,-0.937,-0.906,-0.874,-0.843,-0.811,-0.780,-0.748, |
| 21322 | &-0.717,-0.685,-0.654,-0.622,-0.591,-0.560,-0.528,-0.497,-0.465, |
| 21323 | &-0.434,-0.402,-0.371,-0.339,-0.308,-0.276,-0.245,-0.213,-0.182, |
| 21324 | &-0.151,-0.119,-0.088,-0.056,-0.025, 0.007, 0.038, 0.070, 0.101, |
| 21325 | & 0.133, 0.164, 0.196, 0.227, 0.258, 0.290, 0.321, 0.353, 0.384, |
| 21326 | & 0.416, 0.447, 0.479, 0.510, 0.542, 0.573, 0.605, 0.636, 0.668, |
| 21327 | & 0.699, 0.949, 1.199, 1.449, 1.699, 1.949, 2.199, 2.449, 2.699/ |
| 21328 | * |
| 21329 | * total cross sections: |
| 21330 | * p p |
| 21331 | DATA (ASIGTO(1,K),K=1,NPOINT) / |
| 21332 | & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255, |
| 21333 | & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646, |
| 21334 | & 1.577, 1.518, 1.462, 1.420, 1.393, 1.375, 1.363, 1.356, 1.352, |
| 21335 | & 1.350, 1.351, 1.359, 1.381, 1.410, 1.444, 1.487, 1.544, 1.596, |
| 21336 | & 1.650, 1.672, 1.676, 1.677, 1.677, 1.675, 1.675, 1.669, 1.664, |
| 21337 | & 1.658, 1.653, 1.645, 1.640, 1.634, 1.630, 1.625, 1.620, 1.617, |
| 21338 | & 1.614, 1.602, 1.594, 1.589, 1.581, 1.583, 1.588, 1.596, 1.603/ |
| 21339 | * pbar p |
| 21340 | DATA (ASIGTO(2,K),K=1,NPOINT) / |
| 21341 | & 2.778, 2.759, 2.739, 2.718, 2.697, 2.675, 2.651, 2.626, 2.598, |
| 21342 | & 2.569, 2.537, 2.502, 2.471, 2.443, 2.420, 2.389, 2.361, 2.329, |
| 21343 | & 2.313, 2.304, 2.268, 2.244, 2.222, 2.212, 2.178, 2.162, 2.151, |
| 21344 | & 2.132, 2.109, 2.097, 2.089, 2.078, 2.063, 2.049, 2.035, 2.024, |
| 21345 | & 2.014, 2.004, 1.993, 1.981, 1.970, 1.958, 1.946, 1.933, 1.921, |
| 21346 | & 1.909, 1.894, 1.885, 1.871, 1.854, 1.836, 1.825, 1.816, 1.802, |
| 21347 | & 1.790, 1.744, 1.694, 1.663, 1.642, 1.614, 1.623, 1.623, 1.630/ |
| 21348 | * n p |
| 21349 | DATA (ASIGTO(3,K),K=1,NPOINT) / |
| 21350 | & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763, |
| 21351 | & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115, |
| 21352 | & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569, |
| 21353 | & 1.547, 1.534, 1.526, 1.522, 1.520, 1.525, 1.536, 1.550, 1.566, |
| 21354 | & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609, |
| 21355 | & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605, |
| 21356 | & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/ |
| 21357 | * pi+ p |
| 21358 | DATA (ASIGTO(4,K),K=1,NPOINT) / |
| 21359 | & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610, |
| 21360 | & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118, |
| 21361 | & 2.001, 1.875, 1.801, 1.665, 1.609, 1.484, 1.412, 1.334, 1.195, |
| 21362 | & 1.160, 1.166, 1.208, 1.309, 1.356, 1.394, 1.406, 1.419, 1.473, |
| 21363 | & 1.540, 1.596, 1.570, 1.533, 1.516, 1.484, 1.471, 1.478, 1.492, |
| 21364 | & 1.497, 1.491, 1.479, 1.465, 1.453, 1.449, 1.450, 1.444, 1.428, |
| 21365 | & 1.422, 1.406, 1.384, 1.369, 1.364, 1.369, 1.374, 1.388, 1.395/ |
| 21366 | * pi- p |
| 21367 | DATA (ASIGTO(5,K),K=1,NPOINT) / |
| 21368 | & 0.458, 0.540, 0.626, 0.718, 0.819, 0.933, 1.063, 1.208, 1.226, |
| 21369 | & 1.436, 1.470, 1.594, 1.708, 1.786, 1.852, 1.836, 1.763, 1.679, |
| 21370 | & 1.590, 1.492, 1.445, 1.426, 1.423, 1.433, 1.473, 1.506, 1.547, |
| 21371 | & 1.660, 1.671, 1.545, 1.591, 1.687, 1.808, 1.656, 1.582, 1.543, |
| 21372 | & 1.562, 1.560, 1.537, 1.540, 1.549, 1.557, 1.557, 1.551, 1.535, |
| 21373 | & 1.527, 1.511, 1.510, 1.507, 1.500, 1.491, 1.483, 1.478, 1.468, |
| 21374 | & 1.463, 1.435, 1.408, 1.394, 1.384, 1.380, 1.383, 1.393, 1.411/ |
| 21375 | * K+ p |
| 21376 | DATA (ASIGTO(6,K),K=1,NPOINT) / |
| 21377 | & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, |
| 21378 | & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, |
| 21379 | & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.096, 1.095, |
| 21380 | & 1.098, 1.105, 1.111, 1.139, 1.169, 1.209, 1.248, 1.259, 1.268, |
| 21381 | & 1.262, 1.257, 1.254, 1.252, 1.250, 1.249, 1.246, 1.244, 1.244, |
| 21382 | & 1.243, 1.240, 1.238, 1.237, 1.236, 1.235, 1.235, 1.236, 1.236, |
| 21383 | & 1.236, 1.233, 1.238, 1.248, 1.257, 1.272, 1.292, 1.311, 1.336/ |
| 21384 | * K- p |
| 21385 | DATA (ASIGTO(7,K),K=1,NPOINT) / |
| 21386 | & 2.003, 2.002, 2.001, 2.000, 1.999, 1.998, 1.998, 1.997, 1.997, |
| 21387 | & 1.996, 1.995, 1.993, 1.990, 1.992, 1.974, 1.912, 1.865, 1.847, |
| 21388 | & 1.896, 1.950, 1.827, 1.681, 1.637, 1.616, 1.589, 1.545, 1.543, |
| 21389 | & 1.532, 1.603, 1.604, 1.616, 1.658, 1.700, 1.658, 1.595, 1.508, |
| 21390 | & 1.493, 1.514, 1.531, 1.523, 1.501, 1.479, 1.474, 1.467, 1.463, |
| 21391 | & 1.450, 1.444, 1.435, 1.426, 1.424, 1.423, 1.415, 1.401, 1.396, |
| 21392 | & 1.384, 1.364, 1.330, 1.313, 1.310, 1.309, 1.317, 1.329, 1.338/ |
| 21393 | * K+ n |
| 21394 | DATA (ASIGTO(8,K),K=1,NPOINT) / |
| 21395 | & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584, |
| 21396 | & 0.631, 0.675, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931, |
| 21397 | & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.102, 1.125, 1.147, |
| 21398 | & 1.168, 1.187, 1.205, 1.224, 1.248, 1.279, 1.315, 1.324, 1.301, |
| 21399 | & 1.285, 1.279, 1.274, 1.273, 1.272, 1.271, 1.267, 1.263, 1.261, |
| 21400 | & 1.259, 1.256, 1.252, 1.247, 1.244, 1.241, 1.240, 1.240, 1.240, |
| 21401 | & 1.241, 1.243, 1.245, 1.253, 1.265, 1.275, 1.293, 1.314, 1.342/ |
| 21402 | * K- n |
| 21403 | DATA (ASIGTO(9,K),K=1,NPOINT) / |
| 21404 | & 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, |
| 21405 | & 1.778, 1.778, 1.778, 1.778, 1.778, 1.779, 1.779, 1.778, 1.773, |
| 21406 | & 1.765, 1.746, 1.703, 1.646, 1.561, 1.488, 1.454, 1.437, 1.437, |
| 21407 | & 1.458, 1.505, 1.561, 1.588, 1.593, 1.581, 1.551, 1.500, 1.454, |
| 21408 | & 1.427, 1.408, 1.390, 1.372, 1.361, 1.356, 1.351, 1.347, 1.343, |
| 21409 | & 1.341, 1.340, 1.338, 1.337, 1.335, 1.334, 1.332, 1.331, 1.330, |
| 21410 | & 1.330, 1.313, 1.303, 1.288, 1.288, 1.297, 1.305, 1.320, 1.342/ |
| 21411 | * Lambda p |
| 21412 | DATA (ASIGTO(10,K),K=1,NPOINT) / |
| 21413 | & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224, |
| 21414 | & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.629, |
| 21415 | & 1.599, 1.576, 1.558, 1.543, 1.530, 1.520, 1.512, 1.505, 1.499, |
| 21416 | & 1.495, 1.495, 1.497, 1.504, 1.514, 1.525, 1.536, 1.550, 1.567, |
| 21417 | & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609, |
| 21418 | & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605, |
| 21419 | & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/ |
| 21420 | * |
| 21421 | * elastic cross sections: |
| 21422 | * p p |
| 21423 | DATA (ASIGEL(1,K),K=1,NPOINT) / |
| 21424 | & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255, |
| 21425 | & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646, |
| 21426 | & 1.577, 1.518, 1.462, 1.420, 1.393, 1.374, 1.360, 1.353, 1.350, |
| 21427 | & 1.351, 1.356, 1.362, 1.369, 1.376, 1.384, 1.385, 1.399, 1.397, |
| 21428 | & 1.389, 1.385, 1.379, 1.366, 1.358, 1.344, 1.320, 1.294, 1.275, |
| 21429 | & 1.260, 1.248, 1.235, 1.219, 1.199, 1.172, 1.144, 1.126, 1.115, |
| 21430 | & 1.104, 1.013, 0.962, 0.905, 0.869, 0.845, 0.846, 0.850, 0.868/ |
| 21431 | * pbar p |
| 21432 | DATA (ASIGEL(2,K),K=1,NPOINT) / |
| 21433 | & 1.987, 1.985, 1.983, 1.980, 1.978, 1.975, 1.971, 1.968, 1.963, |
| 21434 | & 1.958, 1.951, 1.944, 1.935, 1.925, 1.914, 1.902, 1.889, 1.875, |
| 21435 | & 1.859, 1.845, 1.834, 1.817, 1.792, 1.769, 1.754, 1.738, 1.720, |
| 21436 | & 1.702, 1.688, 1.676, 1.667, 1.659, 1.652, 1.645, 1.640, 1.636, |
| 21437 | & 1.620, 1.591, 1.562, 1.546, 1.540, 1.524, 1.496, 1.475, 1.457, |
| 21438 | & 1.429, 1.402, 1.373, 1.344, 1.330, 1.306, 1.294, 1.265, 1.228, |
| 21439 | & 1.204, 1.086, 0.977, 0.933, 0.914, 0.850, 0.862, 0.848, 0.845/ |
| 21440 | * n p |
| 21441 | DATA (ASIGEL(3,K),K=1,NPOINT) / |
| 21442 | & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763, |
| 21443 | & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115, |
| 21444 | & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569, |
| 21445 | & 1.544, 1.527, 1.514, 1.504, 1.495, 1.486, 1.476, 1.466, 1.454, |
| 21446 | & 1.440, 1.425, 1.409, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304, |
| 21447 | & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136, |
| 21448 | & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/ |
| 21449 | * pi+ p |
| 21450 | DATA (ASIGEL(4,K),K=1,NPOINT) / |
| 21451 | & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610, |
| 21452 | & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118, |
| 21453 | & 2.001, 1.875, 1.801, 1.664, 1.610, 1.479, 1.423, 1.299, 1.166, |
| 21454 | & 1.097, 1.020, 0.958, 0.914, 1.013, 1.088, 1.153, 1.167, 1.235, |
| 21455 | & 1.240, 1.237, 1.202, 1.135, 1.090, 1.026, 0.975, 0.941, 0.904, |
| 21456 | & 0.894, 0.884, 0.862, 0.850, 0.845, 0.827, 0.805, 0.789, 0.776, |
| 21457 | & 0.763, 0.686, 0.626, 0.562, 0.505, 0.518, 0.525, 0.528, 0.528/ |
| 21458 | * pi- p |
| 21459 | DATA (ASIGEL(5,K),K=1,NPOINT) / |
| 21460 | & 0.266, 0.278, 0.294, 0.320, 0.360, 0.419, 0.503, 0.608, 0.727, |
| 21461 | & 0.850, 0.968, 1.071, 1.167, 1.305, 1.369, 1.404, 1.446, 1.217, |
| 21462 | & 1.112, 1.071, 1.014, 1.002, 0.996, 1.008, 1.070, 1.126, 1.209, |
| 21463 | & 1.300, 1.281, 1.188, 1.156, 1.341, 1.423, 1.314, 1.171, 1.140, |
| 21464 | & 1.106, 1.071, 1.011, 1.037, 1.026, 1.024, 0.988, 0.953, 0.895, |
| 21465 | & 0.894, 0.880, 0.871, 0.864, 0.853, 0.837, 0.820, 0.809, 0.800, |
| 21466 | & 0.782, 0.674, 0.612, 0.530, 0.521, 0.528, 0.524, 0.542, 0.569/ |
| 21467 | * K+ p |
| 21468 | DATA (ASIGEL(6,K),K=1,NPOINT) / |
| 21469 | & 1.064, 1.065, 1.065, 1.066, 1.066, 1.066, 1.066, 1.066, 1.066, |
| 21470 | & 1.065, 1.064, 1.063, 1.062, 1.062, 1.062, 1.064, 1.066, 1.070, |
| 21471 | & 1.076, 1.082, 1.088, 1.096, 1.103, 1.104, 1.104, 1.102, 1.093, |
| 21472 | & 1.087, 1.084, 1.079, 1.075, 1.067, 1.058, 1.040, 1.029, 1.012, |
| 21473 | & 1.003, 0.985, 0.935, 0.909, 0.880, 0.846, 0.790, 0.771, 0.759, |
| 21474 | & 0.743, 0.718, 0.681, 0.666, 0.645, 0.622, 0.606, 0.594, 0.584, |
| 21475 | & 0.575, 0.513, 0.453, 0.403, 0.356, 0.365, 0.389, 0.430, 0.477/ |
| 21476 | * K- p |
| 21477 | DATA (ASIGEL(7,K),K=1,NPOINT) / |
| 21478 | & 1.941, 1.936, 1.931, 1.926, 1.919, 1.912, 1.903, 1.892, 1.878, |
| 21479 | & 1.863, 1.844, 1.821, 1.791, 1.755, 1.713, 1.666, 1.615, 1.561, |
| 21480 | & 1.533, 1.531, 1.518, 1.511, 1.452, 1.339, 1.265, 1.233, 1.188, |
| 21481 | & 1.184, 1.236, 1.316, 1.333, 1.336, 1.333, 1.277, 1.216, 1.077, |
| 21482 | & 1.018, 0.912, 0.926, 0.920, 0.910, 0.894, 0.830, 0.825, 0.800, |
| 21483 | & 0.788, 0.747, 0.703, 0.707, 0.689, 0.643, 0.633, 0.635, 0.618, |
| 21484 | & 0.584, 0.579, 0.461, 0.403, 0.405, 0.399, 0.408, 0.418, 0.413/ |
| 21485 | * K+ n |
| 21486 | DATA (ASIGEL(8,K),K=1,NPOINT) / |
| 21487 | & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584, |
| 21488 | & 0.631, 0.676, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931, |
| 21489 | & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.103, 1.126, 1.148, |
| 21490 | & 1.168, 1.187, 1.205, 1.223, 1.248, 1.282, 1.269, 1.185, 1.111, |
| 21491 | & 1.063, 1.031, 0.998, 0.964, 0.928, 0.889, 0.849, 0.814, 0.785, |
| 21492 | & 0.760, 0.738, 0.720, 0.703, 0.688, 0.674, 0.660, 0.648, 0.635, |
| 21493 | & 0.624, 0.536, 0.473, 0.442, 0.428, 0.428, 0.436, 0.453, 0.477/ |
| 21494 | * K- n |
| 21495 | DATA (ASIGEL(9,K),K=1,NPOINT) / |
| 21496 | & 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, |
| 21497 | & 1.613, 1.613, 1.613, 1.612, 1.613, 1.614, 1.614, 1.612, 1.606, |
| 21498 | & 1.593, 1.564, 1.498, 1.402, 1.240, 1.071, 0.977, 0.922, 0.914, |
| 21499 | & 0.961, 1.077, 1.214, 1.271, 1.290, 1.281, 1.217, 1.096, 0.979, |
| 21500 | & 0.896, 0.822, 0.736, 0.655, 0.608, 0.591, 0.580, 0.569, 0.559, |
| 21501 | & 0.550, 0.540, 0.531, 0.522, 0.514, 0.507, 0.500, 0.494, 0.489, |
| 21502 | & 0.485, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477/ |
| 21503 | * Lambda p |
| 21504 | DATA (ASIGEL(10,K),K=1,NPOINT) / |
| 21505 | & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224, |
| 21506 | & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.630, |
| 21507 | & 1.600, 1.577, 1.558, 1.542, 1.528, 1.518, 1.510, 1.505, 1.502, |
| 21508 | & 1.501, 1.500, 1.499, 1.496, 1.491, 1.485, 1.477, 1.466, 1.454, |
| 21509 | & 1.440, 1.425, 1.408, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304, |
| 21510 | & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136, |
| 21511 | & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/ |
| 21512 | |
| 21513 | DATA (IDXDAT(K,1),K=1,25) / |
| 21514 | & 1, 2, 0, 0, 0, 0, 0, 3, 2, 0, 0,67, 4, 5, 6, 7,10, 2,67, 3, |
| 21515 | & 1, 3,45, 8, 9/ |
| 21516 | DATA (IDXDAT(K,2),K=1,25) / |
| 21517 | & 3, 2, 0, 0, 0, 0, 0, 1, 2, 0, 0,89, 5, 4, 8, 9, 1, 2,89, 1, |
| 21518 | & 3, 1,45, 6, 7/ |
| 21519 | |
| 21520 | DATA LFIRST /.TRUE./ |
| 21521 | |
| 21522 | IF (LFIRST) THEN |
| 21523 | APLABL = LOG10(PLABLO) |
| 21524 | APLABH = LOG10(PLABHI) |
| 21525 | APTHRE = LOG10(PTHRE) |
| 21526 | ADP1 = (APTHRE-APLABL)/DBLE(NPOIN1) |
| 21527 | ADP2 = (APLABH-APTHRE)/DBLE(NPOIN2) |
| 21528 | DUM0 = ZERO |
| 21529 | PHOPLA = PLABHI |
| 21530 | PHOELA = SQRT(AAM(1)**2+PHOPLA**2) |
| 21531 | ECMS = SQRT(2.0D0*AAM(1)**2+2.0D0*AAM(1)*PHOELA) |
| 21532 | IF (MCGENE.EQ.2) THEN |
| 21533 | IF (ECMS.LE.SIGECM(1,ISIMAX)) THEN |
| 21534 | CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,0) |
| 21535 | ELSE |
| 21536 | CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1) |
| 21537 | ENDIF |
| 21538 | ELSE |
| 21539 | CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1) |
| 21540 | ENDIF |
| 21541 | PHOSEL = PHOSTO-PHOSIN |
| 21542 | APHOST = LOG10(PHOSTO) |
| 21543 | APHOSE = LOG10(PHOSEL) |
| 21544 | LFIRST = .FALSE. |
| 21545 | ENDIF |
| 21546 | STOT = ZERO |
| 21547 | SELA = ZERO |
| 21548 | PLAB = PL |
| 21549 | ECMS = ECM |
| 21550 | IF ( (IP.LT.1).OR.((IT.NE.1).AND.(IT.NE.8)) ) THEN |
| 21551 | WRITE(LOUT,1000) IP,IT |
| 21552 | 1000 FORMAT(1X,'DT_XSHN: cross sections not implemented for ', |
| 21553 | & 'proj/target',2I4) |
| 21554 | STOP |
| 21555 | ENDIF |
| 21556 | |
| 21557 | IF ((PLAB.LE.ZERO).AND.(ECMS.GT.ZERO)) THEN |
| 21558 | ELAB = (ECMS**2-AAM(IP)**2-AAM(IT)**2)/(2.0D0*AAM(IT)) |
| 21559 | PLAB = SQRT((ELAB-AAM(IP))*(ELAB+AAM(IP))) |
| 21560 | ELSEIF ((PLAB.LE.ZERO).AND.(ECMS.LE.ZERO)) THEN |
| 21561 | WRITE(LOUT,1001) PLAB,ECMS |
| 21562 | 1001 FORMAT(1X,'DT_XSHN: invalid momentum/cm-energy ',2E15.5) |
| 21563 | STOP |
| 21564 | ENDIF |
| 21565 | |
| 21566 | * index of spectrum |
| 21567 | IDXP = IP |
| 21568 | IF (IP.GT.25) THEN |
| 21569 | IF (AAM(IP).GT.ZERO) THEN |
| 21570 | IF (ABS(IIBAR(IP)).GT.0) THEN |
| 21571 | IDXP = 1 |
| 21572 | ELSE |
| 21573 | IDXP = 13 |
| 21574 | ENDIF |
| 21575 | ELSE |
| 21576 | IDXP = 7 |
| 21577 | ENDIF |
| 21578 | ENDIF |
| 21579 | IDXT = 1 |
| 21580 | IF (IT.EQ.8) IDXT = 2 |
| 21581 | IDXS = IDXDAT(IDXP,IDXT) |
| 21582 | IF (IDXS.EQ.0) RETURN |
| 21583 | |
| 21584 | * compute momentum bin indices |
| 21585 | IF (PLAB.LT.PLABLO) THEN |
| 21586 | IDX0 = 1 |
| 21587 | IDX1 = 1 |
| 21588 | ELSEIF (PLAB.GE.PLABHI) THEN |
| 21589 | IDX0 = NPOINT |
| 21590 | IDX1 = NPOINT |
| 21591 | ELSE |
| 21592 | APLAB = LOG10(PLAB) |
| 21593 | IF ((PLAB.GE.PLABLO).AND.(PLAB.LT.PTHRE )) THEN |
| 21594 | IDX0 = INT((APLAB-APLABL)/ADP1)+1 |
| 21595 | ELSEIF ((PLAB.GE.PTHRE ).AND.(PLAB.LT.PLABHI)) THEN |
| 21596 | IDX0 = INT((APLAB-APTHRE)/ADP2)+NPOIN1+1 |
| 21597 | ENDIF |
| 21598 | IDX1 = IDX0+1 |
| 21599 | ENDIF |
| 21600 | |
| 21601 | * interpolate cross section |
| 21602 | IF (IDXS.GT.10) THEN |
| 21603 | IDXS1 = IDXS/10 |
| 21604 | IDXS2 = IDXS-10*IDXS1 |
| 21605 | IF (IDX0.EQ.IDX1) THEN |
| 21606 | IF (IDX0.EQ.1) THEN |
| 21607 | ASTOT = 0.5D0*(ASIGTO(IDXS1,IDX0)+ASIGTO(IDXS2,IDX0)) |
| 21608 | ASELA = 0.5D0*(ASIGEL(IDXS1,IDX0)+ASIGEL(IDXS2,IDX0)) |
| 21609 | ELSE |
| 21610 | DUM0 = ZERO |
| 21611 | CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0) |
| 21612 | PHOSEL = PHOSTO-PHOSIN |
| 21613 | ASTOT1 = ASIGTO(IDXS1,NPOINT)-APHOST+LOG10(PHOSTO) |
| 21614 | ASELA1 = ASIGEL(IDXS1,NPOINT)-APHOSE+LOG10(PHOSEL) |
| 21615 | ASTOT2 = ASIGTO(IDXS2,NPOINT)-APHOST+LOG10(PHOSTO) |
| 21616 | ASELA2 = ASIGEL(IDXS2,NPOINT)-APHOSE+LOG10(PHOSEL) |
| 21617 | ASTOT = 0.5D0*(ASTOT1+ASTOT2) |
| 21618 | ASELA = 0.5D0*(ASELA1+ASELA2) |
| 21619 | ENDIF |
| 21620 | ELSE |
| 21621 | FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0)) |
| 21622 | ASTOT1 = ASIGTO(IDXS1,IDX0)+ |
| 21623 | & FAC*(ASIGTO(IDXS1,IDX1)-ASIGTO(IDXS1,IDX0)) |
| 21624 | ASTOT2 = ASIGTO(IDXS2,IDX0)+ |
| 21625 | & FAC*(ASIGTO(IDXS2,IDX1)-ASIGTO(IDXS2,IDX0)) |
| 21626 | ASTOT = 0.5D0*(ASTOT1+ASTOT2) |
| 21627 | ASELA1 = ASIGEL(IDXS1,IDX0)+ |
| 21628 | & FAC*(ASIGEL(IDXS1,IDX1)-ASIGEL(IDXS1,IDX0)) |
| 21629 | ASELA2 = ASIGEL(IDXS2,IDX0)+ |
| 21630 | & FAC*(ASIGEL(IDXS2,IDX1)-ASIGEL(IDXS2,IDX0)) |
| 21631 | ASELA = 0.5D0*(ASELA1+ASELA2) |
| 21632 | ENDIF |
| 21633 | ELSE |
| 21634 | IF (IDX0.EQ.IDX1) THEN |
| 21635 | IF (IDX0.EQ.1) THEN |
| 21636 | ASTOT = ASIGTO(IDXS,IDX0) |
| 21637 | ASELA = ASIGEL(IDXS,IDX0) |
| 21638 | ELSE |
| 21639 | DUM0 = ZERO |
| 21640 | CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0) |
| 21641 | PHOSEL = PHOSTO-PHOSIN |
| 21642 | ASTOT = ASIGTO(IDXS,NPOINT)-APHOST+LOG10(PHOSTO) |
| 21643 | ASELA = ASIGEL(IDXS,NPOINT)-APHOSE+LOG10(PHOSEL) |
| 21644 | ENDIF |
| 21645 | ELSE |
| 21646 | FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0)) |
| 21647 | ASTOT = ASIGTO(IDXS,IDX0)+ |
| 21648 | & FAC*(ASIGTO(IDXS,IDX1)-ASIGTO(IDXS,IDX0)) |
| 21649 | ASELA = ASIGEL(IDXS,IDX0)+ |
| 21650 | & FAC*(ASIGEL(IDXS,IDX1)-ASIGEL(IDXS,IDX0)) |
| 21651 | ENDIF |
| 21652 | ENDIF |
| 21653 | STOT = 10.0D0**ASTOT |
| 21654 | SELA = 10.0D0**ASELA |
| 21655 | |
| 21656 | RETURN |
| 21657 | END |
| 21658 | |
| 21659 | *$ CREATE DT_SIHNAB.FOR |
| 21660 | *COPY DT_SIHNAB |
| 21661 | * |
| 21662 | *===sihnab===============================================================* |
| 21663 | * |
| 21664 | SUBROUTINE DT_SIHNAB(IDP,IDT,PLAB,SIGABS) |
| 21665 | |
| 21666 | ********************************************************************** |
| 21667 | * Pion 2-nucleon absorption cross sections. * |
| 21668 | * (sigma_tot for pi+ d --> p p, pi- d --> n n * |
| 21669 | * taken from Ritchie PRC 28 (1983) 926 ) * |
| 21670 | * This version dated 18.05.96 is written by S. Roesler * |
| 21671 | ********************************************************************** |
| 21672 | |
| 21673 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 21674 | SAVE |
| 21675 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY3=1.0D-3) |
| 21676 | PARAMETER (AMPR = 938.0D0, |
| 21677 | & AMPI = 140.0D0, |
| 21678 | & AMDE = TWO*AMPR, |
| 21679 | & A = -1.2D0, |
| 21680 | & B = 3.5D0, |
| 21681 | & C = 7.4D0, |
| 21682 | & D = 5600.0D0, |
| 21683 | & ER = 2136.0D0) |
| 21684 | |
| 21685 | SIGABS = ZERO |
| 21686 | IF ( ((IDP.NE.13).AND.(IDP.NE.14).AND.(IDP.NE.23)) |
| 21687 | & .OR.((IDT.NE.1).AND.(IDT.NE.8)) ) RETURN |
| 21688 | PTOT = PLAB*1.0D3 |
| 21689 | EKIN = SQRT(AMPI**2+PTOT**2)-AMPI |
| 21690 | IF ((EKIN.LT.TINY3).OR.(EKIN.GT.400.0D0)) RETURN |
| 21691 | ECM = SQRT( (AMPI+AMDE)**2+TWO*EKIN*AMDE ) |
| 21692 | SIGABS = A+B/SQRT(EKIN)+C*1.0D4/((ECM-ER)**2+D) |
| 21693 | * approximate 3N-abs., I=1-abs. etc. |
| 21694 | SIGABS = SIGABS/0.40D0 |
| 21695 | * pi0-absorption (rough approximation!!) |
| 21696 | IF (IDP.EQ.23) SIGABS = 0.5D0*SIGABS |
| 21697 | |
| 21698 | RETURN |
| 21699 | END |
| 21700 | |
| 21701 | *$ CREATE DT_SIGEMU.FOR |
| 21702 | *COPY DT_SIGEMU |
| 21703 | * |
| 21704 | *===sigemu=============================================================* |
| 21705 | * |
| 21706 | SUBROUTINE DT_SIGEMU |
| 21707 | |
| 21708 | ************************************************************************ |
| 21709 | * Combined cross section for target compounds. * |
| 21710 | * This version dated 6.4.98 is written by S. Roesler * |
| 21711 | ************************************************************************ |
| 21712 | |
| 21713 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 21714 | SAVE |
| 21715 | PARAMETER ( LINP = 10 , |
| 21716 | & LOUT = 6 , |
| 21717 | & LDAT = 9 ) |
| 21718 | PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10, |
| 21719 | & OHALF=0.5D0,ONE=1.0D0) |
| 21720 | |
| 21721 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 21722 | * Glauber formalism: cross sections |
| 21723 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, |
| 21724 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), |
| 21725 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), |
| 21726 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), |
| 21727 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), |
| 21728 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), |
| 21729 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), |
| 21730 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), |
| 21731 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), |
| 21732 | & BSLOPE,NEBINI,NQBINI |
| 21733 | * emulsion treatment |
| 21734 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), |
| 21735 | & NCOMPO,IEMUL |
| 21736 | * nucleon-nucleon event-generator |
| 21737 | CHARACTER*8 CMODEL |
| 21738 | LOGICAL LPHOIN |
| 21739 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN |
| 21740 | |
| 21741 | IF (MCGENE.NE.4) THEN |
| 21742 | WRITE(LOUT,'(A)') ' DT_SIGEMU: Combined cross sections' |
| 21743 | WRITE(LOUT,'(15X,A)') '-----------------------' |
| 21744 | ENDIF |
| 21745 | DO 1 IE=1,NEBINI |
| 21746 | DO 2 IQ=1,NQBINI |
| 21747 | SIGTOT = ZERO |
| 21748 | SIGELA = ZERO |
| 21749 | SIGQEP = ZERO |
| 21750 | SIGQET = ZERO |
| 21751 | SIGQE2 = ZERO |
| 21752 | SIGPRO = ZERO |
| 21753 | SIGDEL = ZERO |
| 21754 | SIGDQE = ZERO |
| 21755 | ERRTOT = ZERO |
| 21756 | ERRELA = ZERO |
| 21757 | ERRQEP = ZERO |
| 21758 | ERRQET = ZERO |
| 21759 | ERRQE2 = ZERO |
| 21760 | ERRPRO = ZERO |
| 21761 | ERRDEL = ZERO |
| 21762 | ERRDQE = ZERO |
| 21763 | IF (NCOMPO.GT.0) THEN |
| 21764 | DO 3 IC=1,NCOMPO |
| 21765 | SIGTOT = SIGTOT+EMUFRA(IC)*XSTOT(IE,IQ,IC) |
| 21766 | SIGELA = SIGELA+EMUFRA(IC)*XSELA(IE,IQ,IC) |
| 21767 | SIGQEP = SIGQEP+EMUFRA(IC)*XSQEP(IE,IQ,IC) |
| 21768 | SIGQET = SIGQET+EMUFRA(IC)*XSQET(IE,IQ,IC) |
| 21769 | SIGQE2 = SIGQE2+EMUFRA(IC)*XSQE2(IE,IQ,IC) |
| 21770 | SIGPRO = SIGPRO+EMUFRA(IC)*XSPRO(IE,IQ,IC) |
| 21771 | SIGDEL = SIGDEL+EMUFRA(IC)*XSDEL(IE,IQ,IC) |
| 21772 | SIGDQE = SIGDQE+EMUFRA(IC)*XSDQE(IE,IQ,IC) |
| 21773 | ERRTOT = ERRTOT+XETOT(IE,IQ,IC)**2 |
| 21774 | ERRELA = ERRELA+XEELA(IE,IQ,IC)**2 |
| 21775 | ERRQEP = ERRQEP+XEQEP(IE,IQ,IC)**2 |
| 21776 | ERRQET = ERRQET+XEQET(IE,IQ,IC)**2 |
| 21777 | ERRQE2 = ERRQE2+XEQE2(IE,IQ,IC)**2 |
| 21778 | ERRPRO = ERRPRO+XEPRO(IE,IQ,IC)**2 |
| 21779 | ERRDEL = ERRDEL+XEDEL(IE,IQ,IC)**2 |
| 21780 | ERRDQE = ERRDQE+XEDQE(IE,IQ,IC)**2 |
| 21781 | 3 CONTINUE |
| 21782 | ERRTOT = SQRT(ERRTOT) |
| 21783 | ERRELA = SQRT(ERRELA) |
| 21784 | ERRQEP = SQRT(ERRQEP) |
| 21785 | ERRQET = SQRT(ERRQET) |
| 21786 | ERRQE2 = SQRT(ERRQE2) |
| 21787 | ERRPRO = SQRT(ERRPRO) |
| 21788 | ERRDEL = SQRT(ERRDEL) |
| 21789 | ERRDQE = SQRT(ERRDQE) |
| 21790 | ELSE |
| 21791 | SIGTOT = XSTOT(IE,IQ,1) |
| 21792 | SIGELA = XSELA(IE,IQ,1) |
| 21793 | SIGQEP = XSQEP(IE,IQ,1) |
| 21794 | SIGQET = XSQET(IE,IQ,1) |
| 21795 | SIGQE2 = XSQE2(IE,IQ,1) |
| 21796 | SIGPRO = XSPRO(IE,IQ,1) |
| 21797 | SIGDEL = XSDEL(IE,IQ,1) |
| 21798 | SIGDQE = XSDQE(IE,IQ,1) |
| 21799 | ERRTOT = XETOT(IE,IQ,1) |
| 21800 | ERRELA = XEELA(IE,IQ,1) |
| 21801 | ERRQEP = XEQEP(IE,IQ,1) |
| 21802 | ERRQET = XEQET(IE,IQ,1) |
| 21803 | ERRQE2 = XEQE2(IE,IQ,1) |
| 21804 | ERRPRO = XEPRO(IE,IQ,1) |
| 21805 | ERRDEL = XEDEL(IE,IQ,1) |
| 21806 | ERRDQE = XEDQE(IE,IQ,1) |
| 21807 | ENDIF |
| 21808 | IF (MCGENE.NE.4) THEN |
| 21809 | WRITE(LOUT,1000) ECMNN(IE),Q2G(IQ) |
| 21810 | 1000 FORMAT(/,1X,'E_cm =',F9.1,' GeV Q^2 =',F6.1,' GeV^2 :',/) |
| 21811 | WRITE(LOUT,1001) SIGTOT,ERRTOT |
| 21812 | 1001 FORMAT(1X,'total',32X,F10.4,' +-',F11.5,' mb') |
| 21813 | WRITE(LOUT,1002) SIGELA,ERRELA |
| 21814 | 1002 FORMAT(1X,'elastic',30X,F10.4,' +-',F11.5,' mb') |
| 21815 | WRITE(LOUT,1003) SIGQEP,ERRQEP |
| 21816 | 1003 FORMAT(1X,'quasi-elastic (A+B-->A+X)',12X,F10.4,' +-', |
| 21817 | & F11.5,' mb') |
| 21818 | WRITE(LOUT,1004) SIGQET,ERRQET |
| 21819 | 1004 FORMAT(1X,'quasi-elastic (A+B-->X+B)',12X,F10.4,' +-', |
| 21820 | & F11.5,' mb') |
| 21821 | WRITE(LOUT,1005) SIGQE2,ERRQE2 |
| 21822 | 1005 FORMAT(1X,'quasi-elastic (A+B-->X, excl. 2-4)',3X,F10.4, |
| 21823 | & ' +-',F11.5,' mb') |
| 21824 | WRITE(LOUT,1006) SIGPRO,ERRPRO |
| 21825 | 1006 FORMAT(1X,'production',27X,F10.4,' +-',F11.5,' mb') |
| 21826 | WRITE(LOUT,1007) SIGDEL,ERRDEL |
| 21827 | 1007 FORMAT(1X,'diff-el ',27X,F10.4,' +-',F11.5,' mb') |
| 21828 | WRITE(LOUT,1008) SIGDQE,ERRDQE |
| 21829 | 1008 FORMAT(1X,'diff-qel ',27X,F10.4,' +-',F11.5,' mb') |
| 21830 | ENDIF |
| 21831 | |
| 21832 | 2 CONTINUE |
| 21833 | 1 CONTINUE |
| 21834 | |
| 21835 | RETURN |
| 21836 | END |
| 21837 | |
| 21838 | *$ CREATE DT_SIGGA.FOR |
| 21839 | *COPY DT_SIGGA |
| 21840 | * |
| 21841 | *===sigga==============================================================* |
| 21842 | * |
| 21843 | SUBROUTINE DT_SIGGA(NTI,XI,Q2I,ECMI,XNUI,STOT,ETOT,SIN,EIN,STOT0) |
| 21844 | |
| 21845 | ************************************************************************ |
| 21846 | * Total/inelastic photon-nucleus cross sections. * |
| 21847 | * !!!! Overwrites SHMAKI-initialization. Do not use it during * |
| 21848 | * production runs !!!! * |
| 21849 | * This version dated 27.03.96 is written by S. Roesler * |
| 21850 | ************************************************************************ |
| 21851 | |
| 21852 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 21853 | SAVE |
| 21854 | PARAMETER ( LINP = 10 , |
| 21855 | & LOUT = 6 , |
| 21856 | & LDAT = 9 ) |
| 21857 | PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10, |
| 21858 | & OHALF=0.5D0,ONE=1.0D0) |
| 21859 | PARAMETER (AMPROT = 0.938D0) |
| 21860 | |
| 21861 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 21862 | * Glauber formalism: cross sections |
| 21863 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, |
| 21864 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), |
| 21865 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), |
| 21866 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), |
| 21867 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), |
| 21868 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), |
| 21869 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), |
| 21870 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), |
| 21871 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), |
| 21872 | & BSLOPE,NEBINI,NQBINI |
| 21873 | |
| 21874 | NT = NTI |
| 21875 | X = XI |
| 21876 | Q2 = Q2I |
| 21877 | ECM = ECMI |
| 21878 | XNU = XNUI |
| 21879 | IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO)) |
| 21880 | & ECM = SQRT(AMPROT**2-Q2+2.0D0*XNUI*AMPROT) |
| 21881 | CALL DT_XSGLAU(1,NT,7,X,Q2,ECM,1,1,-1) |
| 21882 | STOT = XSTOT(1,1,1) |
| 21883 | ETOT = XETOT(1,1,1) |
| 21884 | SIN = XSPRO(1,1,1) |
| 21885 | EIN = XEPRO(1,1,1) |
| 21886 | |
| 21887 | RETURN |
| 21888 | END |
| 21889 | |
| 21890 | *$ CREATE DT_SIGGAT.FOR |
| 21891 | *COPY DT_SIGGAT |
| 21892 | * |
| 21893 | *===siggat=============================================================* |
| 21894 | * |
| 21895 | SUBROUTINE DT_SIGGAT(Q2I,ECMI,STOT,NT) |
| 21896 | |
| 21897 | ************************************************************************ |
| 21898 | * Total/inelastic photon-nucleus cross sections. * |
| 21899 | * Uses pre-tabulated cross section. * |
| 21900 | * This version dated 29.07.96 is written by S. Roesler * |
| 21901 | ************************************************************************ |
| 21902 | |
| 21903 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 21904 | SAVE |
| 21905 | PARAMETER ( LINP = 10 , |
| 21906 | & LOUT = 6 , |
| 21907 | & LDAT = 9 ) |
| 21908 | PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14, |
| 21909 | & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0) |
| 21910 | |
| 21911 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 21912 | * Glauber formalism: cross sections |
| 21913 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, |
| 21914 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), |
| 21915 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), |
| 21916 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), |
| 21917 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), |
| 21918 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), |
| 21919 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), |
| 21920 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), |
| 21921 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), |
| 21922 | & BSLOPE,NEBINI,NQBINI |
| 21923 | |
| 21924 | NTARG = ABS(NT) |
| 21925 | I1 = 1 |
| 21926 | I2 = 1 |
| 21927 | RATE = ONE |
| 21928 | IF (NEBINI.GT.1) THEN |
| 21929 | IF (ECMI.GE.ECMNN(NEBINI)) THEN |
| 21930 | I1 = NEBINI |
| 21931 | I2 = NEBINI |
| 21932 | RATE = ONE |
| 21933 | ELSEIF (ECMI.GT.ECMNN(1)) THEN |
| 21934 | DO 1 I=2,NEBINI |
| 21935 | IF (ECMI.LT.ECMNN(I)) THEN |
| 21936 | I1 = I-1 |
| 21937 | I2 = I |
| 21938 | RATE = (ECMI-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1)) |
| 21939 | GOTO 2 |
| 21940 | ENDIF |
| 21941 | 1 CONTINUE |
| 21942 | 2 CONTINUE |
| 21943 | ENDIF |
| 21944 | ENDIF |
| 21945 | J1 = 1 |
| 21946 | J2 = 1 |
| 21947 | RATQ = ONE |
| 21948 | IF (NQBINI.GT.1) THEN |
| 21949 | IF (Q2I.GE.Q2G(NQBINI)) THEN |
| 21950 | J1 = NQBINI |
| 21951 | J2 = NQBINI |
| 21952 | RATQ = ONE |
| 21953 | ELSEIF (Q2I.GT.Q2G(1)) THEN |
| 21954 | DO 3 I=2,NQBINI |
| 21955 | IF (Q2I.LT.Q2G(I)) THEN |
| 21956 | J1 = I-1 |
| 21957 | J2 = I |
| 21958 | RATQ = LOG10( Q2I/MAX(Q2G(J1),TINY14))/ |
| 21959 | & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14)) |
| 21960 | C RATQ = (Q2I-Q2G(J1))/(Q2G(J2)-Q2G(J1)) |
| 21961 | GOTO 4 |
| 21962 | ENDIF |
| 21963 | 3 CONTINUE |
| 21964 | 4 CONTINUE |
| 21965 | ENDIF |
| 21966 | ENDIF |
| 21967 | |
| 21968 | STOT = XSTOT(I1,J1,NTARG)+ |
| 21969 | & RATE*(XSTOT(I2,J1,NTARG)-XSTOT(I1,J1,NTARG))+ |
| 21970 | & RATQ*(XSTOT(I1,J2,NTARG)-XSTOT(I1,J1,NTARG))+ |
| 21971 | & RATE*RATQ*(XSTOT(I2,J2,NTARG)-XSTOT(I1,J2,NTARG)+ |
| 21972 | & XSTOT(I1,J1,NTARG)-XSTOT(I2,J1,NTARG)) |
| 21973 | |
| 21974 | RETURN |
| 21975 | END |
| 21976 | |
| 21977 | *$ CREATE DT_SANO.FOR |
| 21978 | *COPY DT_SANO |
| 21979 | * |
| 21980 | *===sigano=============================================================* |
| 21981 | * |
| 21982 | DOUBLE PRECISION FUNCTION DT_SANO(ECM) |
| 21983 | |
| 21984 | ************************************************************************ |
| 21985 | * This version dated 31.07.96 is written by S. Roesler * |
| 21986 | ************************************************************************ |
| 21987 | |
| 21988 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 21989 | SAVE |
| 21990 | PARAMETER ( LINP = 10 , |
| 21991 | & LOUT = 6 , |
| 21992 | & LDAT = 9 ) |
| 21993 | PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14, |
| 21994 | & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0) |
| 21995 | PARAMETER (NE = 8) |
| 21996 | |
| 21997 | * VDM parameter for photon-nucleus interactions |
| 21998 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) |
| 21999 | * properties of interacting particles |
| 22000 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG |
| 22001 | |
| 22002 | DIMENSION ECMANO(NE),FRAANO(NE),SIGHRD(NE) |
| 22003 | DATA ECMANO / |
| 22004 | & 0.200D+02,0.500D+02,0.100D+03,0.200D+03,0.500D+03, |
| 22005 | & 0.100D+04,0.200D+04,0.500D+04 |
| 22006 | & / |
| 22007 | * fixed cut (3 GeV/c) |
| 22008 | DATA FRAANO / |
| 22009 | & 0.085D+00,0.114D+00,0.105D+00,0.091D+00,0.073D+00, |
| 22010 | & 0.062D+00,0.054D+00,0.042D+00 |
| 22011 | & / |
| 22012 | DATA SIGHRD / |
| 22013 | & 4.0099D-04,3.3104D-03,1.1905D-02,3.6435D-02,1.3493D-01, |
| 22014 | & 3.3086D-01,7.6255D-01,2.1319D+00 |
| 22015 | & / |
| 22016 | * running cut (based on obsolete Phojet-caluclations, bugs..) |
| 22017 | C DATA FRAANO / |
| 22018 | C & 0.251E+00,0.313E+00,0.279E+00,0.239E+00,0.186E+00, |
| 22019 | C & 0.167E+00,0.150E+00,0.131E+00 |
| 22020 | C & / |
| 22021 | C DATA SIGHRD / |
| 22022 | C & 6.6569E-04,4.4949E-03,1.4837E-02,4.1466E-02,1.5071E-01, |
| 22023 | C & 2.5736E-01,4.5593E-01,8.2550E-01 |
| 22024 | C & / |
| 22025 | |
| 22026 | DT_SANO = ZERO |
| 22027 | IF ((ISHAD(2).NE.1).OR.(IJPROJ.NE.7)) RETURN |
| 22028 | J1 = 0 |
| 22029 | J2 = 0 |
| 22030 | RATE = ONE |
| 22031 | IF (ECM.GE.ECMANO(NE)) THEN |
| 22032 | J1 = NE |
| 22033 | J2 = NE |
| 22034 | ELSEIF (ECM.GT.ECMANO(1)) THEN |
| 22035 | DO 1 IE=2,NE |
| 22036 | IF (ECM.LT.ECMANO(IE)) THEN |
| 22037 | J1 = IE-1 |
| 22038 | J2 = IE |
| 22039 | RATE = LOG10(ECM/ECMANO(J1))/LOG10(ECMANO(J2)/ECMANO(J1)) |
| 22040 | GOTO 2 |
| 22041 | ENDIF |
| 22042 | 1 CONTINUE |
| 22043 | 2 CONTINUE |
| 22044 | ENDIF |
| 22045 | IF ((J1.GT.0).AND.(J2.GT.0)) THEN |
| 22046 | AFRA1 = LOG10(MAX(FRAANO(J1)*SIGHRD(J1),TINY14)) |
| 22047 | AFRA2 = LOG10(MAX(FRAANO(J2)*SIGHRD(J2),TINY14)) |
| 22048 | DT_SANO = 10.0D0**(AFRA1+RATE*(AFRA2-AFRA1)) |
| 22049 | ENDIF |
| 22050 | |
| 22051 | RETURN |
| 22052 | END |
| 22053 | |
| 22054 | *$ CREATE DT_SIGGP.FOR |
| 22055 | *COPY DT_SIGGP |
| 22056 | * |
| 22057 | *===siggp==============================================================* |
| 22058 | * |
| 22059 | SUBROUTINE DT_SIGGP(XI,Q2I,ECMI,XNUI,STOT,SINE,SDIR) |
| 22060 | |
| 22061 | ************************************************************************ |
| 22062 | * Total/inelastic photon-nucleon cross sections. * |
| 22063 | * This version dated 30.04.96 is written by S. Roesler * |
| 22064 | ************************************************************************ |
| 22065 | |
| 22066 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 22067 | SAVE |
| 22068 | PARAMETER ( LINP = 10 , |
| 22069 | & LOUT = 6 , |
| 22070 | & LDAT = 9 ) |
| 22071 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) |
| 22072 | PARAMETER (TWOPI = 6.283185307179586476925286766559D+00, |
| 22073 | & PI = TWOPI/TWO, |
| 22074 | & GEV2MB = 0.38938D0, |
| 22075 | & ALPHEM = ONE/137.0D0) |
| 22076 | |
| 22077 | * particle properties (BAMJET index convention) |
| 22078 | CHARACTER*8 ANAME |
| 22079 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 22080 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 22081 | * VDM parameter for photon-nucleus interactions |
| 22082 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) |
| 22083 | |
| 22084 | **PHOJET105a |
| 22085 | C CHARACTER*8 MDLNA |
| 22086 | C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100) |
| 22087 | C PARAMETER (IEETAB=10) |
| 22088 | C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX |
| 22089 | **PHOJET110 |
| 22090 | C model switches and parameters |
| 22091 | CHARACTER*8 MDLNA |
| 22092 | INTEGER ISWMDL,IPAMDL |
| 22093 | DOUBLE PRECISION PARMDL |
| 22094 | COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400) |
| 22095 | C energy-interpolation table |
| 22096 | INTEGER IEETA2 |
| 22097 | PARAMETER ( IEETA2 = 20 ) |
| 22098 | INTEGER ISIMAX |
| 22099 | DOUBLE PRECISION SIGTAB,SIGECM |
| 22100 | COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX |
| 22101 | ** |
| 22102 | |
| 22103 | C PARAMETER (NPOINT=80) |
| 22104 | PARAMETER (NPOINT=16) |
| 22105 | DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT) |
| 22106 | |
| 22107 | STOT = ZERO |
| 22108 | SINE = ZERO |
| 22109 | SDIR = ZERO |
| 22110 | |
| 22111 | W2 = ECMI**2 |
| 22112 | IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO)) |
| 22113 | & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1) |
| 22114 | Q2 = Q2I |
| 22115 | X = XI |
| 22116 | * photoprod. |
| 22117 | IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN |
| 22118 | Q2 = 0.0001D0 |
| 22119 | X = Q2/(W2+Q2-AAM(1)**2) |
| 22120 | * DIS |
| 22121 | ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN |
| 22122 | X = Q2/(W2+Q2-AAM(1)**2) |
| 22123 | ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN |
| 22124 | Q2 = (W2-AAM(1)**2)*X/(ONE-X) |
| 22125 | ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN |
| 22126 | W2 = Q2*(ONE-X)/X+AAM(1)**2 |
| 22127 | ELSE |
| 22128 | WRITE(LOUT,*) 'SIGGP: inconsistent input ',W2,Q2,X |
| 22129 | STOP |
| 22130 | ENDIF |
| 22131 | ECM = SQRT(W2) |
| 22132 | |
| 22133 | IF (MODEGA.EQ.1) THEN |
| 22134 | SCALE = SQRT(Q2) |
| 22135 | CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2, |
| 22136 | & IDPDF) |
| 22137 | C W = SQRT(W2) |
| 22138 | C ALLMF2 = PHO_ALLM97(Q2,W) |
| 22139 | C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2 |
| 22140 | STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB |
| 22141 | SINE = ZERO |
| 22142 | SDIR = ZERO |
| 22143 | ELSEIF (MODEGA.EQ.2) THEN |
| 22144 | IF (INTRGE(1).EQ.1) THEN |
| 22145 | AMLO2 = (3.0D0*AAM(13))**2 |
| 22146 | ELSEIF (INTRGE(1).EQ.2) THEN |
| 22147 | AMLO2 = AAM(33)**2 |
| 22148 | ELSE |
| 22149 | AMLO2 = AAM(96)**2 |
| 22150 | ENDIF |
| 22151 | IF (INTRGE(2).EQ.1) THEN |
| 22152 | AMHI2 = W2/TWO |
| 22153 | ELSEIF (INTRGE(2).EQ.2) THEN |
| 22154 | AMHI2 = W2/4.0D0 |
| 22155 | ELSE |
| 22156 | AMHI2 = W2 |
| 22157 | ENDIF |
| 22158 | AMHI20 = (ECM-AAM(1))**2 |
| 22159 | IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20 |
| 22160 | XAMLO = LOG( AMLO2+Q2 ) |
| 22161 | XAMHI = LOG( AMHI2+Q2 ) |
| 22162 | **PHOJET105a |
| 22163 | C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT) |
| 22164 | **PHOJET112 |
| 22165 | CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT) |
| 22166 | ** |
| 22167 | SUM = ZERO |
| 22168 | DO 1 J=1,NPOINT |
| 22169 | AM2 = EXP(ABSZX(J))-Q2 |
| 22170 | IF (AM2.LT.16.0D0) THEN |
| 22171 | R = TWO |
| 22172 | ELSEIF ((AM2.GE.16.0D0).AND.(AM2.LT.121.0D0)) THEN |
| 22173 | R = 10.0D0/3.0D0 |
| 22174 | ELSE |
| 22175 | R = 11.0D0/3.0D0 |
| 22176 | ENDIF |
| 22177 | C FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) ) |
| 22178 | FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) ) |
| 22179 | & * (ONE+EPSPOL*Q2/AM2) |
| 22180 | SUM = SUM+WEIGHT(J)*FAC |
| 22181 | 1 CONTINUE |
| 22182 | SINE = SUM |
| 22183 | SDIR = DT_SIGVP(X,Q2) |
| 22184 | STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*SDIR |
| 22185 | SDIR = SDIR/(0.588D0+RL2+Q2) |
| 22186 | C STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*DT_SIGVP(X,Q2) |
| 22187 | ELSEIF (MODEGA.EQ.3) THEN |
| 22188 | CALL DT_SIGGA(1,XI,Q2I,ECMI,ZERO,STOT,ETOT,SINE,EINE,DUM) |
| 22189 | ELSEIF (MODEGA.EQ.4) THEN |
| 22190 | * load cross sections from PHOJET interpolation table |
| 22191 | IP = 1 |
| 22192 | IF(ECM.LE.SIGECM(IP,1)) THEN |
| 22193 | I1 = 1 |
| 22194 | I2 = 1 |
| 22195 | ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN |
| 22196 | DO 2 I=2,ISIMAX |
| 22197 | IF (ECM.LE.SIGECM(IP,I)) GOTO 3 |
| 22198 | 2 CONTINUE |
| 22199 | 3 CONTINUE |
| 22200 | I1 = I-1 |
| 22201 | I2 = I |
| 22202 | ELSE |
| 22203 | WRITE(LOUT,'(/1X,A,2E12.3)') |
| 22204 | & 'SIGGP:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX) |
| 22205 | I1 = ISIMAX |
| 22206 | I2 = ISIMAX |
| 22207 | ENDIF |
| 22208 | FAC2 = ZERO |
| 22209 | IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1)) |
| 22210 | & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1)) |
| 22211 | FAC1 = ONE-FAC2 |
| 22212 | * cross section dependence on photon virtuality |
| 22213 | FSUP1 = ZERO |
| 22214 | DO 4 I=1,3 |
| 22215 | FSUP1 = FSUP1+PARMDL(26+I)*(1.D0+Q2/(4.D0*PARMDL(30+I))) |
| 22216 | & /(1.D0+Q2/PARMDL(30+I))**2 |
| 22217 | 4 CONTINUE |
| 22218 | FSUP1 = FSUP1+PARMDL(30)/(1.D0+Q2/PARMDL(34)) |
| 22219 | FAC1 = FAC1*FSUP1 |
| 22220 | FAC2 = FAC2*FSUP1 |
| 22221 | FSUP2 = 1.0D0 |
| 22222 | STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1) |
| 22223 | SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1) |
| 22224 | SDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1) |
| 22225 | **re: |
| 22226 | STOT = STOT-SDIR |
| 22227 | ** |
| 22228 | SDIR = SDIR/(FSUP1*FSUP2) |
| 22229 | **re: |
| 22230 | STOT = STOT+SDIR |
| 22231 | ** |
| 22232 | ENDIF |
| 22233 | |
| 22234 | RETURN |
| 22235 | END |
| 22236 | |
| 22237 | *$ CREATE DT_SIGVEL.FOR |
| 22238 | *COPY DT_SIGVEL |
| 22239 | * |
| 22240 | *===sigvel=============================================================* |
| 22241 | * |
| 22242 | SUBROUTINE DT_SIGVEL(XI,Q2I,ECMI,XNUI,IDXV,SVEL,SIG1,SIG2) |
| 22243 | |
| 22244 | ************************************************************************ |
| 22245 | * Cross section for elastic vector meson production * |
| 22246 | * This version dated 10.05.96 is written by S. Roesler * |
| 22247 | ************************************************************************ |
| 22248 | |
| 22249 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 22250 | SAVE |
| 22251 | PARAMETER ( LINP = 10 , |
| 22252 | & LOUT = 6 , |
| 22253 | & LDAT = 9 ) |
| 22254 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) |
| 22255 | PARAMETER (TWOPI = 6.283185307179586476925286766559D+00, |
| 22256 | & PI = TWOPI/TWO, |
| 22257 | & GEV2MB = 0.38938D0, |
| 22258 | & ALPHEM = ONE/137.0D0) |
| 22259 | |
| 22260 | * particle properties (BAMJET index convention) |
| 22261 | CHARACTER*8 ANAME |
| 22262 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 22263 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 22264 | * VDM parameter for photon-nucleus interactions |
| 22265 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) |
| 22266 | |
| 22267 | W2 = ECMI**2 |
| 22268 | IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO)) |
| 22269 | & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1) |
| 22270 | Q2 = Q2I |
| 22271 | X = XI |
| 22272 | * photoprod. |
| 22273 | IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN |
| 22274 | Q2 = 0.0001D0 |
| 22275 | X = Q2/(W2+Q2-AAM(1)**2) |
| 22276 | * DIS |
| 22277 | ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN |
| 22278 | X = Q2/(W2+Q2-AAM(1)**2) |
| 22279 | ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN |
| 22280 | Q2 = (W2-AAM(1)**2)*X/(ONE-X) |
| 22281 | ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN |
| 22282 | W2 = Q2*(ONE-X)/X+AAM(1)**2 |
| 22283 | ELSE |
| 22284 | WRITE(LOUT,*) 'SIGVEL: inconsistent input ',W2,Q2,X |
| 22285 | STOP |
| 22286 | ENDIF |
| 22287 | ECM = SQRT(W2) |
| 22288 | |
| 22289 | AMV = AAM(IDXV) |
| 22290 | AMV2 = AMV**2 |
| 22291 | |
| 22292 | BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2) |
| 22293 | & +0.25D0*LOG(W2/(AMV2+Q2)))*GEV2MB |
| 22294 | ROSH = 0.1D0 |
| 22295 | STOVP = DT_SIGVP(X,Q2)/(AMV2+Q2+RL2) |
| 22296 | SELVP = STOVP**2*(ONE+ROSH**2)/(8.0D0*TWOPI*BSLOPE) |
| 22297 | |
| 22298 | IF (IDXV.EQ.33) THEN |
| 22299 | COUPL = 0.00365D0 |
| 22300 | ELSE |
| 22301 | STOP |
| 22302 | ENDIF |
| 22303 | SIG1 = (AMV2/(AMV2+Q2))**2 * (ONE+EPSPOL*Q2/AMV2) |
| 22304 | SIG2 = SELVP |
| 22305 | SVEL = COUPL * (AMV2/(AMV2+Q2))**2 |
| 22306 | & * (ONE+EPSPOL*Q2/AMV2) * SELVP |
| 22307 | |
| 22308 | RETURN |
| 22309 | END |
| 22310 | |
| 22311 | *$ CREATE DT_SIGVP.FOR |
| 22312 | *COPY DT_SIGVP |
| 22313 | * |
| 22314 | *===sigvp==============================================================* |
| 22315 | * |
| 22316 | DOUBLE PRECISION FUNCTION DT_SIGVP(XI,Q2I) |
| 22317 | |
| 22318 | ************************************************************************ |
| 22319 | * sigma_Vp * |
| 22320 | ************************************************************************ |
| 22321 | |
| 22322 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 22323 | SAVE |
| 22324 | |
| 22325 | PARAMETER ( LINP = 10 , |
| 22326 | & LOUT = 6 , |
| 22327 | & LDAT = 9 ) |
| 22328 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) |
| 22329 | PARAMETER (TWOPI = 6.283185307179586476925286766559D+00, |
| 22330 | & PI = TWOPI/TWO, |
| 22331 | & GEV2MB = 0.38938D0, |
| 22332 | & AMPROT = 0.938D0, |
| 22333 | & ALPHEM = ONE/137.0D0) |
| 22334 | * VDM parameter for photon-nucleus interactions |
| 22335 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) |
| 22336 | |
| 22337 | X = XI |
| 22338 | Q2 = Q2I |
| 22339 | IF (XI.LE.ZERO) X = 0.0001D0 |
| 22340 | IF (Q2I.LE.ZERO) Q2 = 0.0001D0 |
| 22341 | |
| 22342 | ECM = SQRT( Q2*(ONE-X)/X+AMPROT**2 ) |
| 22343 | |
| 22344 | SCALE = SQRT(Q2) |
| 22345 | IF (MODEGA.EQ.1) THEN |
| 22346 | CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2, |
| 22347 | & IDPDF) |
| 22348 | C W = ECM |
| 22349 | C ALLMF2 = PHO_ALLM97(Q2,W) |
| 22350 | C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2 |
| 22351 | C STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB |
| 22352 | C DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2)) |
| 22353 | DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))*GEV2MB |
| 22354 | ELSEIF (MODEGA.EQ.4) THEN |
| 22355 | CALL DT_SIGGP(X,Q2,ECM,DUM1,STOT,DUM2,DUM3) |
| 22356 | C F2 = Q2*(ONE-X)/(TWOPI**2*ALPHEM*GEV2MB) * STOT |
| 22357 | DT_SIGVP = 3.0D0*PI/(ALPHEM*DT_RRM2(X,Q2)) * STOT |
| 22358 | ELSE |
| 22359 | STOP ' DT_SIGVP: F2 not defined for this MODEGA !' |
| 22360 | ENDIF |
| 22361 | |
| 22362 | RETURN |
| 22363 | |
| 22364 | END |
| 22365 | |
| 22366 | *$ CREATE DT_RRM2.FOR |
| 22367 | *COPY DT_RRM2 |
| 22368 | * |
| 22369 | *===RRM2===============================================================* |
| 22370 | * |
| 22371 | DOUBLE PRECISION FUNCTION DT_RRM2(X,Q2) |
| 22372 | |
| 22373 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 22374 | SAVE |
| 22375 | PARAMETER ( LINP = 10 , |
| 22376 | & LOUT = 6 , |
| 22377 | & LDAT = 9 ) |
| 22378 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) |
| 22379 | PARAMETER (TWOPI = 6.283185307179586476925286766559D+00, |
| 22380 | & PI = TWOPI/TWO, |
| 22381 | & GEV2MB = 0.38938D0) |
| 22382 | |
| 22383 | * particle properties (BAMJET index convention) |
| 22384 | CHARACTER*8 ANAME |
| 22385 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 22386 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 22387 | * VDM parameter for photon-nucleus interactions |
| 22388 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) |
| 22389 | |
| 22390 | S = Q2*(ONE-X)/X+AAM(1)**2 |
| 22391 | ECM = SQRT(S) |
| 22392 | |
| 22393 | IF (INTRGE(1).EQ.1) THEN |
| 22394 | AMLO2 = (3.0D0*AAM(13))**2 |
| 22395 | ELSEIF (INTRGE(1).EQ.2) THEN |
| 22396 | AMLO2 = AAM(33)**2 |
| 22397 | ELSE |
| 22398 | AMLO2 = AAM(96)**2 |
| 22399 | ENDIF |
| 22400 | IF (INTRGE(2).EQ.1) THEN |
| 22401 | AMHI2 = S/TWO |
| 22402 | ELSEIF (INTRGE(2).EQ.2) THEN |
| 22403 | AMHI2 = S/4.0D0 |
| 22404 | ELSE |
| 22405 | AMHI2 = S |
| 22406 | ENDIF |
| 22407 | AMHI20 = (ECM-AAM(1))**2 |
| 22408 | IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20 |
| 22409 | |
| 22410 | AM1C2 = 16.0D0 |
| 22411 | AM2C2 = 121.0D0 |
| 22412 | IF (AMHI2.LE.AM1C2) THEN |
| 22413 | DT_RRM2 = TWO*DT_RM2(AMLO2,AMHI2,Q2) |
| 22414 | ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN |
| 22415 | DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+ |
| 22416 | & 10.0D0/3.0D0*DT_RM2(AM1C2,AMHI2,Q2) |
| 22417 | ELSE |
| 22418 | DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+ |
| 22419 | & 10.0D0/3.0D0*DT_RM2(AM1C2,AM2C2,Q2)+ |
| 22420 | & 11.0D0/3.0D0*DT_RM2(AM2C2,AMHI2,Q2) |
| 22421 | ENDIF |
| 22422 | |
| 22423 | RETURN |
| 22424 | END |
| 22425 | |
| 22426 | *$ CREATE DT_RM2.FOR |
| 22427 | *COPY DT_RM2 |
| 22428 | * |
| 22429 | *===RM2================================================================* |
| 22430 | * |
| 22431 | DOUBLE PRECISION FUNCTION DT_RM2(AMLO2,AMHI2,Q2) |
| 22432 | |
| 22433 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 22434 | SAVE |
| 22435 | PARAMETER ( LINP = 10 , |
| 22436 | & LOUT = 6 , |
| 22437 | & LDAT = 9 ) |
| 22438 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) |
| 22439 | PARAMETER (TWOPI = 6.283185307179586476925286766559D+00, |
| 22440 | & PI = TWOPI/TWO, |
| 22441 | & GEV2MB = 0.38938D0) |
| 22442 | * VDM parameter for photon-nucleus interactions |
| 22443 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) |
| 22444 | |
| 22445 | IF (RL2.LE.ZERO) THEN |
| 22446 | DT_RM2 = -ONE/(AMHI2+Q2)+Q2/(TWO*(AMHI2+Q2)**2) - |
| 22447 | & (-ONE/(AMLO2+Q2)+Q2/(TWO*(AMLO2+Q2)**2)) |
| 22448 | & +EPSPOL*(-Q2/(TWO*(AMHI2+Q2)**2)+Q2/(TWO*(AMLO2+Q2)**2)) |
| 22449 | ELSE |
| 22450 | TMPMLO = LOG(ONE+RL2/(AMLO2+Q2)) |
| 22451 | TMPMHI = LOG(ONE+RL2/(AMHI2+Q2)) |
| 22452 | DT_RM2 = Q2/(RL2*(AMHI2+Q2))-(Q2+RL2)/RL2**2*TMPMHI |
| 22453 | & -(Q2/(RL2*(AMLO2+Q2))-(Q2+RL2)/RL2**2*TMPMLO) |
| 22454 | & +EPSPOL*( |
| 22455 | & -Q2/(RL2*(AMHI2+Q2))+Q2/RL2**2*TMPMHI |
| 22456 | & -(-Q2/(RL2*(AMLO2+Q2))+Q2/RL2**2*TMPMLO)) |
| 22457 | ENDIF |
| 22458 | |
| 22459 | RETURN |
| 22460 | END |
| 22461 | |
| 22462 | *$ CREATE DT_SAM2.FOR |
| 22463 | *COPY DT_SAM2 |
| 22464 | * |
| 22465 | *===SAM2===============================================================* |
| 22466 | * |
| 22467 | DOUBLE PRECISION FUNCTION DT_SAM2(Q2,ECM) |
| 22468 | |
| 22469 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 22470 | SAVE |
| 22471 | PARAMETER ( LINP = 10 , |
| 22472 | & LOUT = 6 , |
| 22473 | & LDAT = 9 ) |
| 22474 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0, |
| 22475 | & TENTRD=10.0D0/3.0D0,ELVTRD=11.0D0/3.0D0) |
| 22476 | PARAMETER (TWOPI = 6.283185307179586476925286766559D+00, |
| 22477 | & PI = TWOPI/TWO, |
| 22478 | & GEV2MB = 0.38938D0) |
| 22479 | |
| 22480 | * particle properties (BAMJET index convention) |
| 22481 | CHARACTER*8 ANAME |
| 22482 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 22483 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 22484 | * VDM parameter for photon-nucleus interactions |
| 22485 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) |
| 22486 | |
| 22487 | S = ECM**2 |
| 22488 | IF (INTRGE(1).EQ.1) THEN |
| 22489 | AMLO2 = (3.0D0*AAM(13))**2 |
| 22490 | ELSEIF (INTRGE(1).EQ.2) THEN |
| 22491 | AMLO2 = AAM(33)**2 |
| 22492 | ELSE |
| 22493 | AMLO2 = AAM(96)**2 |
| 22494 | ENDIF |
| 22495 | IF (INTRGE(2).EQ.1) THEN |
| 22496 | AMHI2 = S/TWO |
| 22497 | ELSEIF (INTRGE(2).EQ.2) THEN |
| 22498 | AMHI2 = S/4.0D0 |
| 22499 | ELSE |
| 22500 | AMHI2 = S |
| 22501 | ENDIF |
| 22502 | AMHI20 = (ECM-AAM(1))**2 |
| 22503 | IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20 |
| 22504 | |
| 22505 | AM1C2 = 16.0D0 |
| 22506 | AM2C2 = 121.0D0 |
| 22507 | YLO = LOG(AMLO2+Q2) |
| 22508 | YC1 = LOG(AM1C2+Q2) |
| 22509 | YC2 = LOG(AM2C2+Q2) |
| 22510 | YHI = LOG(AMHI2+Q2) |
| 22511 | IF (AMHI2.LE.AM1C2) THEN |
| 22512 | FACHI = TWO |
| 22513 | ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN |
| 22514 | FACHI = TENTRD |
| 22515 | ELSE |
| 22516 | FACHI = ELVTRD |
| 22517 | ENDIF |
| 22518 | |
| 22519 | 1 CONTINUE |
| 22520 | YSAM2 = YLO+(YHI-YLO)*DT_RNDM(AM1C2) |
| 22521 | IF (YSAM2.LE.YC1) THEN |
| 22522 | FAC = TWO |
| 22523 | ELSEIF ((YSAM2.GT.YC1).AND.(YSAM2.LE.YC2)) THEN |
| 22524 | FAC = TENTRD |
| 22525 | ELSE |
| 22526 | FAC = ELVTRD |
| 22527 | ENDIF |
| 22528 | WEIGMX = FACHI*(ONE-Q2*EXP( -YHI)) |
| 22529 | XSAM2 = FAC *(ONE-Q2*EXP(-YSAM2)) |
| 22530 | IF (DT_RNDM(YSAM2)*WEIGMX.GT.XSAM2) GOTO 1 |
| 22531 | |
| 22532 | DT_SAM2 = EXP(YSAM2)-Q2 |
| 22533 | |
| 22534 | RETURN |
| 22535 | END |
| 22536 | |
| 22537 | *$ CREATE DT_CKMT.FOR |
| 22538 | *COPY DT_CKMT |
| 22539 | * |
| 22540 | *===ckmt===============================================================* |
| 22541 | * |
| 22542 | SUBROUTINE DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL, |
| 22543 | & F2,IPAR) |
| 22544 | |
| 22545 | ************************************************************************ |
| 22546 | * This version dated 31.01.96 is written by S. Roesler * |
| 22547 | ************************************************************************ |
| 22548 | |
| 22549 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 22550 | SAVE |
| 22551 | PARAMETER ( LINP = 10 , |
| 22552 | & LOUT = 6 , |
| 22553 | & LDAT = 9 ) |
| 22554 | PARAMETER (ZERO=0.0D0,TWO=2.0D0,TINY10=1.0D-10) |
| 22555 | |
| 22556 | PARAMETER (Q02 = 2.0D0, |
| 22557 | & DQ2 = 10.05D0, |
| 22558 | & Q12 = Q02+DQ2) |
| 22559 | |
| 22560 | DIMENSION PD(-6:6),SEA(3),VAL(2) |
| 22561 | |
| 22562 | CALL DT_PDF0(Q02,X,F2Q0,VAL,SEA,GLU,IPAR) |
| 22563 | CALL DT_PDF0(Q12,X,F2Q1,VAL,SEA,GLU,IPAR) |
| 22564 | ADQ2 = LOG10(Q12)-LOG10(Q02) |
| 22565 | F2P = (F2Q1-F2Q0)/ADQ2 |
| 22566 | CALL DT_CKMTX(IPAR,X,Q02,PD,F2PQ0) |
| 22567 | CALL DT_CKMTX(IPAR,X,Q12,PD,F2PQ1) |
| 22568 | F2PP = (F2PQ1-F2PQ0)/ADQ2 |
| 22569 | FX = (F2P-F2PP)/(F2PP+LOG(DQ2)*F2PQ0+TINY10)*Q02 |
| 22570 | |
| 22571 | Q2 = MAX(SCALE**2.0D0,TINY10) |
| 22572 | SMOOTH = 1.0D0+FX*(Q2-Q02)/Q2**2 |
| 22573 | IF (Q2.LT.Q02) THEN |
| 22574 | CALL DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR) |
| 22575 | UPV = VAL(1) |
| 22576 | DNV = VAL(2) |
| 22577 | USEA = SEA(1) |
| 22578 | DSEA = SEA(2) |
| 22579 | STR = SEA(3) |
| 22580 | CHM = 0.0D0 |
| 22581 | BOT = 0.0D0 |
| 22582 | TOP = 0.0D0 |
| 22583 | GL = GLU |
| 22584 | ELSE |
| 22585 | CALL DT_CKMTX(IPAR,X,Q2,PD,F2) |
| 22586 | F2 = F2*SMOOTH |
| 22587 | UPV = PD(2)-PD(3) |
| 22588 | DNV = PD(1)-PD(3) |
| 22589 | USEA = PD(3) |
| 22590 | DSEA = PD(3) |
| 22591 | STR = PD(3) |
| 22592 | CHM = PD(4) |
| 22593 | BOT = PD(5) |
| 22594 | TOP = PD(6) |
| 22595 | GL = PD(0) |
| 22596 | C UPV = UPV*SMOOTH |
| 22597 | C DNV = DNV*SMOOTH |
| 22598 | C USEA = USEA*SMOOTH |
| 22599 | C DSEA = DSEA*SMOOTH |
| 22600 | C STR = STR*SMOOTH |
| 22601 | C CHM = CHM*SMOOTH |
| 22602 | C GL = GL*SMOOTH |
| 22603 | ENDIF |
| 22604 | |
| 22605 | RETURN |
| 22606 | END |
| 22607 | C |
| 22608 | |
| 22609 | *$ CREATE DT_CKMTX.FOR |
| 22610 | *COPY DT_CKMTX |
| 22611 | SUBROUTINE DT_CKMTX(IPAR,X,SCALE2,PD,F2) |
| 22612 | C********************************************************************** |
| 22613 | C |
| 22614 | C PDF based on Regge theory, evolved with .... by .... |
| 22615 | C |
| 22616 | C input: IPAR 2212 proton (not installed) |
| 22617 | C 45 Pomeron |
| 22618 | C 100 Deuteron |
| 22619 | C |
| 22620 | C output: PD(-6:6) x*f(x) parton distribution functions |
| 22621 | C (PDFLIB convention: d = PD(1), u = PD(2) ) |
| 22622 | C |
| 22623 | C********************************************************************** |
| 22624 | |
| 22625 | SAVE |
| 22626 | DOUBLE PRECISION X,SCALE2,PD(-6:6),CDN,CUP,F2 |
| 22627 | PARAMETER ( LINP = 10 , |
| 22628 | & LOUT = 6 , |
| 22629 | & LDAT = 9 ) |
| 22630 | DIMENSION QQ(7) |
| 22631 | C |
| 22632 | Q2=SNGL(SCALE2) |
| 22633 | Q1S=Q2 |
| 22634 | XX=SNGL(X) |
| 22635 | C QCD lambda for evolution |
| 22636 | OWLAM = 0.23D0 |
| 22637 | OWLAM2=OWLAM**2 |
| 22638 | C Q0**2 for evolution |
| 22639 | Q02 = 2.D0 |
| 22640 | C |
| 22641 | C |
| 22642 | C the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=... |
| 22643 | C q(6)=x*charm, q(7)=x*gluon |
| 22644 | C |
| 22645 | SB=0. |
| 22646 | IF(Q2-Q02) 1,1,2 |
| 22647 | 2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2)) |
| 22648 | 1 CONTINUE |
| 22649 | IF(IPAR.EQ.2212) THEN |
| 22650 | CALL DT_CKMTPR(1,0,XX,SB,QQ(1)) |
| 22651 | CALL DT_CKMTPR(2,0,XX,SB,QQ(2)) |
| 22652 | CALL DT_CKMTPR(3,0,XX,SB,QQ(3)) |
| 22653 | CALL DT_CKMTPR(4,0,XX,SB,QQ(4)) |
| 22654 | CALL DT_CKMTPR(5,0,XX,SB,QQ(5)) |
| 22655 | CALL DT_CKMTPR(8,0,XX,SB,QQ(6)) |
| 22656 | CALL DT_CKMTPR(7,0,XX,SB,QQ(7)) |
| 22657 | C ELSEIF (IPAR.EQ.45) THEN |
| 22658 | C CALL CKMTPO(1,0,XX,SB,QQ(1)) |
| 22659 | C CALL CKMTPO(2,0,XX,SB,QQ(2)) |
| 22660 | C CALL CKMTPO(3,0,XX,SB,QQ(3)) |
| 22661 | C CALL CKMTPO(4,0,XX,SB,QQ(4)) |
| 22662 | C CALL CKMTPO(5,0,XX,SB,QQ(5)) |
| 22663 | C CALL CKMTPO(8,0,XX,SB,QQ(6)) |
| 22664 | C CALL CKMTPO(7,0,XX,SB,QQ(7)) |
| 22665 | ELSEIF (IPAR.EQ.100) THEN |
| 22666 | CALL DT_CKMTDE(1,0,XX,SB,QQ(1)) |
| 22667 | CALL DT_CKMTDE(2,0,XX,SB,QQ(2)) |
| 22668 | CALL DT_CKMTDE(3,0,XX,SB,QQ(3)) |
| 22669 | CALL DT_CKMTDE(4,0,XX,SB,QQ(4)) |
| 22670 | CALL DT_CKMTDE(5,0,XX,SB,QQ(5)) |
| 22671 | CALL DT_CKMTDE(8,0,XX,SB,QQ(6)) |
| 22672 | CALL DT_CKMTDE(7,0,XX,SB,QQ(7)) |
| 22673 | ELSE |
| 22674 | WRITE(LOUT,'(1X,A,I4,A)') |
| 22675 | & 'CKMTX: IPAR =',IPAR,' not implemented!' |
| 22676 | STOP |
| 22677 | ENDIF |
| 22678 | C |
| 22679 | PD(-6) = 0.D0 |
| 22680 | PD(-5) = 0.D0 |
| 22681 | PD(-4) = DBLE(QQ(6)) |
| 22682 | PD(-3) = DBLE(QQ(3)) |
| 22683 | PD(-2) = DBLE(QQ(4)) |
| 22684 | PD(-1) = DBLE(QQ(5)) |
| 22685 | PD(0) = DBLE(QQ(7)) |
| 22686 | PD(1) = DBLE(QQ(2)) |
| 22687 | PD(2) = DBLE(QQ(1)) |
| 22688 | PD(3) = DBLE(QQ(3)) |
| 22689 | PD(4) = DBLE(QQ(6)) |
| 22690 | PD(5) = 0.D0 |
| 22691 | PD(6) = 0.D0 |
| 22692 | IF(IPAR.EQ.45) THEN |
| 22693 | CDN = (PD(1)-PD(-1))/2.D0 |
| 22694 | CUP = (PD(2)-PD(-2))/2.D0 |
| 22695 | PD(-1) = PD(-1) + CDN |
| 22696 | PD(-2) = PD(-2) + CUP |
| 22697 | PD(1) = PD(-1) |
| 22698 | PD(2) = PD(-2) |
| 22699 | ENDIF |
| 22700 | F2 = 4.0D0/9.0D0*(PD(2)-PD(3)+2.0D0*PD(3))+ |
| 22701 | & 1.0D0/9.0D0*(PD(1)-PD(3)+2.0D0*PD(3))+ |
| 22702 | & 1.0D0/9.0D0*(2.0D0*PD(3))+4.0D0/9.0D0*(2.0D0*PD(4)) |
| 22703 | END |
| 22704 | C |
| 22705 | |
| 22706 | *$ CREATE DT_PDF0.FOR |
| 22707 | *COPY DT_PDF0 |
| 22708 | * |
| 22709 | *===pdf0===============================================================* |
| 22710 | * |
| 22711 | SUBROUTINE DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR) |
| 22712 | |
| 22713 | ************************************************************************ |
| 22714 | * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 * |
| 22715 | * an F_2-ansatz given in Capella et al. PLB 337(1994)358. * |
| 22716 | * IPAR = 2212 proton * |
| 22717 | * = 100 deuteron * |
| 22718 | * This version dated 31.01.96 is written by S. Roesler * |
| 22719 | ************************************************************************ |
| 22720 | |
| 22721 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 22722 | SAVE |
| 22723 | PARAMETER ( LINP = 10 , |
| 22724 | & LOUT = 6 , |
| 22725 | & LDAT = 9 ) |
| 22726 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9) |
| 22727 | |
| 22728 | PARAMETER ( |
| 22729 | & AA = 0.1502D0, |
| 22730 | & BBDEU = 1.2D0, |
| 22731 | & BUD = 0.754D0, |
| 22732 | & BDD = 0.4495D0, |
| 22733 | & BUP = 1.2064D0, |
| 22734 | & BDP = 0.1798D0, |
| 22735 | & DELTA0 = 0.07684D0, |
| 22736 | & D = 1.117D0, |
| 22737 | & C = 3.5489D0, |
| 22738 | & A = 0.2631D0, |
| 22739 | & B = 0.6452D0, |
| 22740 | & ALPHAR = 0.415D0, |
| 22741 | & E = 0.1D0 |
| 22742 | & ) |
| 22743 | |
| 22744 | PARAMETER (NPOINT=16) |
| 22745 | C DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT) |
| 22746 | DIMENSION SEA(3),VAL(2) |
| 22747 | |
| 22748 | DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D)) |
| 22749 | AN = 1.5D0*(1.0D0+Q2/(Q2+C)) |
| 22750 | * proton, deuteron |
| 22751 | IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN |
| 22752 | CALL DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0) |
| 22753 | SEA(1) = 0.75D0*SEA0 |
| 22754 | SEA(2) = SEA(1) |
| 22755 | SEA(3) = SEA(1) |
| 22756 | VAL(1) = 9.0D0/4.0D0*VALU0 |
| 22757 | VAL(2) = 9.0D0*VALD0 |
| 22758 | GLU0 = SEA(1)/(1.0D0-X) |
| 22759 | F2 = SEA0+VALU0+VALD0 |
| 22760 | F2PDF = 4.0D0/9.0D0*(VAL(1)+2.0D0*SEA(1))+ |
| 22761 | & 1.0D0/9.0D0*(VAL(2)+2.0D0*SEA(2))+ |
| 22762 | & 1.0D0/9.0D0*(2.0D0*SEA(3)) |
| 22763 | IF (ABS(F2-F2PDF).GT.TINY9) THEN |
| 22764 | WRITE(LOUT,'(1X,A,2E15.5)') 'inconsistent PDF! ',F2,F2PDF |
| 22765 | STOP |
| 22766 | ENDIF |
| 22767 | **PHOJET105a |
| 22768 | C CALL GSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT) |
| 22769 | **PHOJET112 |
| 22770 | C CALL PHO_GAUSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT) |
| 22771 | ** |
| 22772 | C SUMQ = ZERO |
| 22773 | C SUMG = ZERO |
| 22774 | C DO 1 J=1,NPOINT |
| 22775 | C CALL DT_CKMTQ0(Q2,ABSZX(J),IPAR,VALU0,VALD0,SEA0) |
| 22776 | C VALU0 = 9.0D0/4.0D0*VALU0 |
| 22777 | C VALD0 = 9.0D0*VALD0 |
| 22778 | C SEA0 = 0.75D0*SEA0 |
| 22779 | C SUMQ = SUMQ+ (VALU0+VALD0+6.0D0*SEA0) *WEIGHT(J) |
| 22780 | C SUMG = SUMG+ (SEA0/(1.0D0-ABSZX(J))) *WEIGHT(J) |
| 22781 | C 1 CONTINUE |
| 22782 | C GLU = GLU0*(1.0D0-SUMQ)/SUMG |
| 22783 | ELSE |
| 22784 | WRITE(LOUT,'(1X,A,I4,A)') |
| 22785 | & 'PDF0: IPAR =',IPAR,' not implemented!' |
| 22786 | STOP |
| 22787 | ENDIF |
| 22788 | |
| 22789 | RETURN |
| 22790 | END |
| 22791 | |
| 22792 | *$ CREATE DT_CKMTQ0.FOR |
| 22793 | *COPY DT_CKMTQ0 |
| 22794 | * |
| 22795 | *===ckmtq0=============================================================* |
| 22796 | * |
| 22797 | SUBROUTINE DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0) |
| 22798 | |
| 22799 | ************************************************************************ |
| 22800 | * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 * |
| 22801 | * an F_2-ansatz given in Capella et al. PLB 337(1994)358. * |
| 22802 | * IPAR = 2212 proton * |
| 22803 | * = 100 deuteron * |
| 22804 | * This version dated 31.01.96 is written by S. Roesler * |
| 22805 | ************************************************************************ |
| 22806 | |
| 22807 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 22808 | SAVE |
| 22809 | PARAMETER ( LINP = 10 , |
| 22810 | & LOUT = 6 , |
| 22811 | & LDAT = 9 ) |
| 22812 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9) |
| 22813 | |
| 22814 | PARAMETER ( |
| 22815 | & AA = 0.1502D0, |
| 22816 | & BBDEU = 1.2D0, |
| 22817 | & BUD = 0.754D0, |
| 22818 | & BDD = 0.4495D0, |
| 22819 | & BUP = 1.2064D0, |
| 22820 | & BDP = 0.1798D0, |
| 22821 | & DELTA0 = 0.07684D0, |
| 22822 | & D = 1.117D0, |
| 22823 | & C = 3.5489D0, |
| 22824 | & A = 0.2631D0, |
| 22825 | & B = 0.6452D0, |
| 22826 | & ALPHAR = 0.415D0, |
| 22827 | & E = 0.1D0 |
| 22828 | & ) |
| 22829 | |
| 22830 | DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D)) |
| 22831 | AN = 1.5D0*(1.0D0+Q2/(Q2+C)) |
| 22832 | * proton, deuteron |
| 22833 | IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN |
| 22834 | IF (IPAR.EQ.2212) THEN |
| 22835 | BU = BUP |
| 22836 | BD = BDP |
| 22837 | ELSE |
| 22838 | BU = BUD |
| 22839 | BD = BDD |
| 22840 | ENDIF |
| 22841 | SEA0 = AA*X**(-DELTA)*(1.0D0-X)**(AN+4.0D0)* |
| 22842 | & (Q2/(Q2+A))**(1.0D0+DELTA) |
| 22843 | VALU0 = BU*X**(1.0D0-ALPHAR)*(1.0D0-X)**AN* |
| 22844 | & (Q2/(Q2+B))**(ALPHAR) |
| 22845 | VALD0 = BD*X**(1.0D0-ALPHAR)*(1.0D0-X)**(AN+1.0D0)* |
| 22846 | & (Q2/(Q2+B))**(ALPHAR) |
| 22847 | ELSE |
| 22848 | WRITE(LOUT,'(1X,A,I4,A)') |
| 22849 | & 'CKMTQ0: IPAR =',IPAR,' not implemented!' |
| 22850 | STOP |
| 22851 | ENDIF |
| 22852 | RETURN |
| 22853 | END |
| 22854 | C |
| 22855 | C |
| 22856 | |
| 22857 | *$ CREATE DT_CKMTDE.FOR |
| 22858 | *COPY DT_CKMTDE |
| 22859 | SUBROUTINE DT_CKMTDE(I,NDRV,X,S,ANS) |
| 22860 | C |
| 22861 | C********************************************************************** |
| 22862 | C Deuteron - PDFs |
| 22863 | C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc |
| 22864 | C ANS = PDF(I) |
| 22865 | C This version by S. Roesler, 30.01.96 |
| 22866 | C********************************************************************** |
| 22867 | |
| 22868 | SAVE |
| 22869 | DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000) |
| 22870 | EQUIVALENCE (GF(1,1,1),DL(1)) |
| 22871 | DATA DELTA/.13/ |
| 22872 | C |
| 22873 | DATA (DL(K),K= 1, 85) / |
| 22874 | &0.351858E+00,0.388489E+00,0.325356E+00,0.325356E+00,0.325356E+00, |
| 22875 | &0.325356E+00,0.445218E+01,0.000000E+00,0.419818E+00,0.459249E+00, |
| 22876 | &0.391167E+00,0.391143E+00,0.391125E+00,0.391167E+00,0.628186E+01, |
| 22877 | &0.703797E-01,0.498333E+00,0.540626E+00,0.467466E+00,0.467423E+00, |
| 22878 | &0.467393E+00,0.467466E+00,0.837368E+01,0.151191E+00,0.587839E+00, |
| 22879 | &0.633058E+00,0.554689E+00,0.554630E+00,0.554595E+00,0.554689E+00, |
| 22880 | &0.107170E+02,0.242877E+00,0.688652E+00,0.736861E+00,0.653150E+00, |
| 22881 | &0.653080E+00,0.653046E+00,0.653150E+00,0.132960E+02,0.345760E+00, |
| 22882 | &0.800961E+00,0.852226E+00,0.763038E+00,0.762961E+00,0.762933E+00, |
| 22883 | &0.763038E+00,0.160884E+02,0.460033E+00,0.924829E+00,0.979213E+00, |
| 22884 | &0.884414E+00,0.884335E+00,0.884319E+00,0.884414E+00,0.190679E+02, |
| 22885 | &0.585764E+00,0.106016E+01,0.111773E+01,0.101719E+01,0.101711E+01, |
| 22886 | &0.101711E+01,0.101719E+01,0.222033E+02,0.722864E+00,0.120670E+01, |
| 22887 | &0.126752E+01,0.116110E+01,0.116102E+01,0.116105E+01,0.116110E+01, |
| 22888 | &0.254603E+02,0.871079E+00,0.136402E+01,0.142815E+01,0.131571E+01, |
| 22889 | &0.131565E+01,0.131570E+01,0.131571E+01,0.288020E+02,0.102998E+01, |
| 22890 | &0.153151E+01,0.159900E+01,0.148043E+01,0.148038E+01,0.148046E+01/ |
| 22891 | DATA (DL(K),K= 86, 170) / |
| 22892 | &0.148043E+01,0.321898E+02,0.119897E+01,0.170838E+01,0.177930E+01, |
| 22893 | &0.165447E+01,0.165444E+01,0.165455E+01,0.165447E+01,0.355845E+02, |
| 22894 | &0.137726E+01,0.189369E+01,0.196807E+01,0.183687E+01,0.183686E+01, |
| 22895 | &0.183701E+01,0.183687E+01,0.389473E+02,0.156390E+01,0.208631E+01, |
| 22896 | &0.216422E+01,0.202653E+01,0.202654E+01,0.202673E+01,0.202653E+01, |
| 22897 | &0.422402E+02,0.175779E+01,0.228501E+01,0.236648E+01,0.222220E+01, |
| 22898 | &0.222224E+01,0.222248E+01,0.222220E+01,0.454277E+02,0.195768E+01, |
| 22899 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22900 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22901 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22902 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22903 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22904 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22905 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22906 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22907 | &0.326035E+00,0.380777E+00,0.286363E+00,0.286363E+00,0.286363E+00, |
| 22908 | &0.286363E+00,0.392252E+01,-.138778E-16,0.380092E+00,0.438587E+00/ |
| 22909 | DATA (DL(K),K= 171, 255) / |
| 22910 | &0.337452E+00,0.337430E+00,0.337424E+00,0.337452E+00,0.532193E+01, |
| 22911 | &0.553645E-01,0.440879E+00,0.503177E+00,0.395208E+00,0.395169E+00, |
| 22912 | &0.395165E+00,0.395208E+00,0.686454E+01,0.117354E+00,0.508415E+00, |
| 22913 | &0.574566E+00,0.459649E+00,0.459600E+00,0.459604E+00,0.459649E+00, |
| 22914 | &0.853316E+01,0.185994E+00,0.582647E+00,0.652699E+00,0.530722E+00, |
| 22915 | &0.530667E+00,0.530687E+00,0.530722E+00,0.103093E+02,0.261237E+00, |
| 22916 | &0.663404E+00,0.737405E+00,0.608254E+00,0.608199E+00,0.608241E+00, |
| 22917 | &0.608254E+00,0.121710E+02,0.342917E+00,0.750429E+00,0.828423E+00, |
| 22918 | &0.691990E+00,0.691941E+00,0.692009E+00,0.691990E+00,0.140946E+02, |
| 22919 | &0.430783E+00,0.843361E+00,0.925391E+00,0.781571E+00,0.781533E+00, |
| 22920 | &0.781632E+00,0.781571E+00,0.160553E+02,0.524479E+00,0.941741E+00, |
| 22921 | &0.102784E+01,0.876538E+00,0.876515E+00,0.876650E+00,0.876538E+00, |
| 22922 | &0.180277E+02,0.623549E+00,0.104501E+01,0.113521E+01,0.976335E+00, |
| 22923 | &0.976332E+00,0.976506E+00,0.976335E+00,0.199863E+02,0.727439E+00, |
| 22924 | &0.115251E+01,0.124685E+01,0.108031E+01,0.108034E+01,0.108055E+01, |
| 22925 | &0.108031E+01,0.219066E+02,0.835506E+00,0.126352E+01,0.136201E+01, |
| 22926 | &0.118775E+01,0.118780E+01,0.118806E+01,0.118775E+01,0.237652E+02/ |
| 22927 | DATA (DL(K),K= 256, 340) / |
| 22928 | &0.947020E+00,0.137724E+01,0.147989E+01,0.129783E+01,0.129791E+01, |
| 22929 | &0.129822E+01,0.129783E+01,0.255406E+02,0.106119E+01,0.149279E+01, |
| 22930 | &0.159961E+01,0.140972E+01,0.140984E+01,0.141019E+01,0.140972E+01, |
| 22931 | &0.272135E+02,0.117715E+01,0.160929E+01,0.172028E+01,0.152252E+01, |
| 22932 | &0.152267E+01,0.152308E+01,0.152252E+01,0.287669E+02,0.129402E+01, |
| 22933 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22934 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22935 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22936 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22937 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22938 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22939 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22940 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22941 | &0.309785E+00,0.391282E+00,0.250518E+00,0.250518E+00,0.250518E+00, |
| 22942 | &0.250518E+00,0.343842E+01,-.138778E-16,0.352113E+00,0.438463E+00, |
| 22943 | &0.288877E+00,0.288863E+00,0.288878E+00,0.288877E+00,0.446765E+01, |
| 22944 | &0.424850E-01,0.398382E+00,0.489596E+00,0.331132E+00,0.331111E+00/ |
| 22945 | DATA (DL(K),K= 341, 425) / |
| 22946 | &0.331148E+00,0.331132E+00,0.555902E+01,0.888369E-01,0.448375E+00, |
| 22947 | &0.544458E+00,0.377064E+00,0.377043E+00,0.377108E+00,0.377064E+00, |
| 22948 | &0.669490E+01,0.138845E+00,0.501854E+00,0.602811E+00,0.426440E+00, |
| 22949 | &0.426425E+00,0.426523E+00,0.426440E+00,0.785892E+01,0.192281E+00, |
| 22950 | &0.558506E+00,0.664331E+00,0.478946E+00,0.478944E+00,0.479079E+00, |
| 22951 | &0.478946E+00,0.903368E+01,0.248834E+00,0.617972E+00,0.728657E+00, |
| 22952 | &0.534229E+00,0.534244E+00,0.534421E+00,0.534229E+00,0.102022E+02, |
| 22953 | &0.308155E+00,0.679844E+00,0.795370E+00,0.591883E+00,0.591921E+00, |
| 22954 | &0.592141E+00,0.591883E+00,0.113479E+02,0.369841E+00,0.743667E+00, |
| 22955 | &0.864009E+00,0.651460E+00,0.651525E+00,0.651792E+00,0.651460E+00, |
| 22956 | &0.124553E+02,0.433447E+00,0.808951E+00,0.934073E+00,0.712474E+00, |
| 22957 | &0.712571E+00,0.712885E+00,0.712474E+00,0.135102E+02,0.498486E+00, |
| 22958 | &0.875171E+00,0.100503E+01,0.774408E+00,0.774541E+00,0.774902E+00, |
| 22959 | &0.774408E+00,0.144999E+02,0.564446E+00,0.941784E+00,0.107632E+01, |
| 22960 | &0.836726E+00,0.836897E+00,0.837307E+00,0.836726E+00,0.154136E+02, |
| 22961 | &0.630788E+00,0.100823E+01,0.114738E+01,0.898879E+00,0.899092E+00, |
| 22962 | &0.899551E+00,0.898879E+00,0.162423E+02,0.696967E+00,0.107396E+01/ |
| 22963 | DATA (DL(K),K= 426, 510) / |
| 22964 | &0.121764E+01,0.960319E+00,0.960577E+00,0.961084E+00,0.960319E+00, |
| 22965 | &0.169791E+02,0.762433E+00,0.113843E+01,0.128655E+01,0.102051E+01, |
| 22966 | &0.102081E+01,0.102137E+01,0.102051E+01,0.176190E+02,0.826647E+00, |
| 22967 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22968 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22969 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22970 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22971 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22972 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22973 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22974 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22975 | &0.304680E+00,0.425088E+00,0.216504E+00,0.216504E+00,0.216504E+00, |
| 22976 | &0.216504E+00,0.298356E+01,0.000000E+00,0.337300E+00,0.463627E+00, |
| 22977 | &0.244023E+00,0.244024E+00,0.244063E+00,0.244023E+00,0.370271E+01, |
| 22978 | &0.316585E-01,0.371787E+00,0.503942E+00,0.273415E+00,0.273423E+00, |
| 22979 | &0.273505E+00,0.273415E+00,0.443039E+01,0.651685E-01,0.407853E+00, |
| 22980 | &0.545739E+00,0.304395E+00,0.304418E+00,0.304545E+00,0.304395E+00/ |
| 22981 | DATA (DL(K),K= 511, 595) / |
| 22982 | &0.515321E+01,0.100252E+00,0.445229E+00,0.588741E+00,0.336700E+00, |
| 22983 | &0.336744E+00,0.336918E+00,0.336700E+00,0.586004E+01,0.136648E+00, |
| 22984 | &0.483606E+00,0.632629E+00,0.370026E+00,0.370095E+00,0.370318E+00, |
| 22985 | &0.370026E+00,0.654027E+01,0.174056E+00,0.522666E+00,0.677074E+00, |
| 22986 | &0.404062E+00,0.404162E+00,0.404433E+00,0.404062E+00,0.718442E+01, |
| 22987 | &0.212167E+00,0.562075E+00,0.721735E+00,0.438483E+00,0.438618E+00, |
| 22988 | &0.438938E+00,0.438483E+00,0.778423E+01,0.250658E+00,0.601494E+00, |
| 22989 | &0.766258E+00,0.472959E+00,0.473131E+00,0.473500E+00,0.472959E+00, |
| 22990 | &0.833276E+01,0.289199E+00,0.640580E+00,0.810290E+00,0.507156E+00, |
| 22991 | &0.507369E+00,0.507784E+00,0.507156E+00,0.882448E+01,0.327457E+00, |
| 22992 | &0.678993E+00,0.853479E+00,0.540747E+00,0.541003E+00,0.541463E+00, |
| 22993 | &0.540747E+00,0.925529E+01,0.365104E+00,0.716405E+00,0.895483E+00, |
| 22994 | &0.573411E+00,0.573714E+00,0.574216E+00,0.573411E+00,0.962250E+01, |
| 22995 | &0.401821E+00,0.752501E+00,0.935975E+00,0.604848E+00,0.605197E+00, |
| 22996 | &0.605740E+00,0.604848E+00,0.992478E+01,0.437304E+00,0.786987E+00, |
| 22997 | &0.974647E+00,0.634775E+00,0.635173E+00,0.635752E+00,0.634775E+00, |
| 22998 | &0.101620E+02,0.471269E+00,0.819594E+00,0.101122E+01,0.662936E+00/ |
| 22999 | DATA (DL(K),K= 596, 680) / |
| 23000 | &0.663382E+00,0.663995E+00,0.662936E+00,0.103354E+02,0.503459E+00, |
| 23001 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23002 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23003 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23004 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23005 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23006 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23007 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23008 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23009 | &0.312661E+00,0.487836E+00,0.182562E+00,0.182562E+00,0.182562E+00, |
| 23010 | &0.182562E+00,0.253626E+01,0.000000E+00,0.336910E+00,0.518440E+00, |
| 23011 | &0.200702E+00,0.200721E+00,0.200779E+00,0.200702E+00,0.299460E+01, |
| 23012 | &0.224425E-01,0.361554E+00,0.549164E+00,0.219359E+00,0.219402E+00, |
| 23013 | &0.219517E+00,0.219359E+00,0.343183E+01,0.453742E-01,0.386348E+00, |
| 23014 | &0.579759E+00,0.238296E+00,0.238367E+00,0.238536E+00,0.238296E+00, |
| 23015 | &0.384076E+01,0.685610E-01,0.411080E+00,0.610003E+00,0.257305E+00, |
| 23016 | &0.257408E+00,0.257630E+00,0.257305E+00,0.421619E+01,0.917987E-01/ |
| 23017 | DATA (DL(K),K= 681, 765) / |
| 23018 | &0.435528E+00,0.639668E+00,0.276174E+00,0.276313E+00,0.276583E+00, |
| 23019 | &0.276174E+00,0.455400E+01,0.114876E+00,0.459476E+00,0.668531E+00, |
| 23020 | &0.294698E+00,0.294875E+00,0.295191E+00,0.294698E+00,0.485107E+01, |
| 23021 | &0.137589E+00,0.482719E+00,0.696375E+00,0.312682E+00,0.312900E+00, |
| 23022 | &0.313258E+00,0.312682E+00,0.510539E+01,0.159742E+00,0.505060E+00, |
| 23023 | &0.722995E+00,0.329941E+00,0.330200E+00,0.330596E+00,0.329941E+00, |
| 23024 | &0.531589E+01,0.181149E+00,0.526315E+00,0.748199E+00,0.346303E+00, |
| 23025 | &0.346604E+00,0.347034E+00,0.346303E+00,0.548250E+01,0.201638E+00, |
| 23026 | &0.546317E+00,0.771808E+00,0.361613E+00,0.361957E+00,0.362418E+00, |
| 23027 | &0.361613E+00,0.560595E+01,0.221052E+00,0.564917E+00,0.793667E+00, |
| 23028 | &0.375735E+00,0.376122E+00,0.376609E+00,0.375735E+00,0.568772E+01, |
| 23029 | &0.239253E+00,0.581987E+00,0.813638E+00,0.388553E+00,0.388982E+00, |
| 23030 | &0.389491E+00,0.388553E+00,0.572992E+01,0.256122E+00,0.597419E+00, |
| 23031 | &0.831608E+00,0.399972E+00,0.400443E+00,0.400970E+00,0.399972E+00, |
| 23032 | &0.573516E+01,0.271562E+00,0.611129E+00,0.847487E+00,0.409919E+00, |
| 23033 | &0.410430E+00,0.410972E+00,0.409919E+00,0.570642E+01,0.285497E+00, |
| 23034 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ |
| 23035 | DATA (DL(K),K= 766, 850) / |
| 23036 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23037 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23038 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23039 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23040 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23041 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23042 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23043 | &0.335149E+00,0.582072E+00,0.146415E+00,0.146415E+00,0.146415E+00, |
| 23044 | &0.146415E+00,0.206772E+01,0.000000E+00,0.351552E+00,0.603437E+00, |
| 23045 | &0.156515E+00,0.156542E+00,0.156595E+00,0.156515E+00,0.231143E+01, |
| 23046 | &0.146091E-01,0.367407E+00,0.623737E+00,0.166387E+00,0.166442E+00, |
| 23047 | &0.166542E+00,0.166387E+00,0.252488E+01,0.289315E-01,0.382571E+00, |
| 23048 | &0.642832E+00,0.175891E+00,0.175976E+00,0.176118E+00,0.175891E+00, |
| 23049 | &0.270658E+01,0.428312E-01,0.396926E+00,0.660609E+00,0.184917E+00, |
| 23050 | &0.185034E+00,0.185212E+00,0.184917E+00,0.285608E+01,0.561981E-01, |
| 23051 | &0.410365E+00,0.676962E+00,0.193365E+00,0.193513E+00,0.193722E+00, |
| 23052 | &0.193365E+00,0.297375E+01,0.689319E-01,0.422792E+00,0.691796E+00/ |
| 23053 | DATA (DL(K),K= 851, 935) / |
| 23054 | &0.201144E+00,0.201324E+00,0.201560E+00,0.201144E+00,0.306050E+01, |
| 23055 | &0.809434E-01,0.434123E+00,0.705030E+00,0.208181E+00,0.208393E+00, |
| 23056 | &0.208650E+00,0.208181E+00,0.311775E+01,0.921567E-01,0.444287E+00, |
| 23057 | &0.716596E+00,0.214413E+00,0.214656E+00,0.214931E+00,0.214413E+00, |
| 23058 | &0.314738E+01,0.102508E+00,0.453228E+00,0.726441E+00,0.219792E+00, |
| 23059 | &0.220066E+00,0.220354E+00,0.219792E+00,0.315156E+01,0.111949E+00, |
| 23060 | &0.460906E+00,0.734527E+00,0.224285E+00,0.224589E+00,0.224886E+00, |
| 23061 | &0.224285E+00,0.313271E+01,0.120441E+00,0.467291E+00,0.740835E+00, |
| 23062 | &0.227870E+00,0.228203E+00,0.228506E+00,0.227870E+00,0.309338E+01, |
| 23063 | &0.127963E+00,0.472372E+00,0.745357E+00,0.230541E+00,0.230902E+00, |
| 23064 | &0.231208E+00,0.230541E+00,0.303621E+01,0.134506E+00,0.476148E+00, |
| 23065 | &0.748105E+00,0.232304E+00,0.232690E+00,0.232996E+00,0.232304E+00, |
| 23066 | &0.296381E+01,0.140070E+00,0.478635E+00,0.749103E+00,0.233176E+00, |
| 23067 | &0.233586E+00,0.233889E+00,0.233176E+00,0.287874E+01,0.144672E+00, |
| 23068 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23069 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23070 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ |
| 23071 | DATA (DL(K),K= 936, 1020) / |
| 23072 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23073 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23074 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23075 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23076 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23077 | &0.370162E+00,0.695827E+00,0.105823E+00,0.105823E+00,0.105823E+00, |
| 23078 | &0.105823E+00,0.154556E+01,0.208167E-16,0.378214E+00,0.703794E+00, |
| 23079 | &0.109539E+00,0.109554E+00,0.109571E+00,0.109539E+00,0.162770E+01, |
| 23080 | &0.818783E-02,0.385258E+00,0.710067E+00,0.112818E+00,0.112847E+00, |
| 23081 | &0.112879E+00,0.112818E+00,0.168578E+01,0.158212E-01,0.391264E+00, |
| 23082 | &0.714648E+00,0.115620E+00,0.115666E+00,0.115709E+00,0.115620E+00, |
| 23083 | &0.172175E+01,0.228667E-01,0.396214E+00,0.717539E+00,0.117923E+00, |
| 23084 | &0.117985E+00,0.118037E+00,0.117923E+00,0.173756E+01,0.293009E-01, |
| 23085 | &0.400098E+00,0.718759E+00,0.119711E+00,0.119790E+00,0.119848E+00, |
| 23086 | &0.119711E+00,0.173541E+01,0.351123E-01,0.402915E+00,0.718332E+00, |
| 23087 | &0.120979E+00,0.121074E+00,0.121137E+00,0.120979E+00,0.171755E+01, |
| 23088 | &0.402951E-01,0.404672E+00,0.716292E+00,0.121728E+00,0.121840E+00/ |
| 23089 | DATA (DL(K),K= 1021, 1105) / |
| 23090 | &0.121905E+00,0.121728E+00,0.168619E+01,0.448514E-01,0.405385E+00, |
| 23091 | &0.712681E+00,0.121967E+00,0.122095E+00,0.122161E+00,0.121967E+00, |
| 23092 | &0.164352E+01,0.487902E-01,0.405077E+00,0.707551E+00,0.121712E+00, |
| 23093 | &0.121855E+00,0.121920E+00,0.121712E+00,0.159162E+01,0.521265E-01, |
| 23094 | &0.403778E+00,0.700963E+00,0.120984E+00,0.121141E+00,0.121204E+00, |
| 23095 | &0.120984E+00,0.153245E+01,0.548814E-01,0.401525E+00,0.692984E+00, |
| 23096 | &0.119809E+00,0.119980E+00,0.120040E+00,0.119809E+00,0.146780E+01, |
| 23097 | &0.570807E-01,0.398361E+00,0.683691E+00,0.118218E+00,0.118402E+00, |
| 23098 | &0.118457E+00,0.118218E+00,0.139928E+01,0.587542E-01,0.394333E+00, |
| 23099 | &0.673166E+00,0.116244E+00,0.116440E+00,0.116490E+00,0.116244E+00, |
| 23100 | &0.132834E+01,0.599355E-01,0.389495E+00,0.661496E+00,0.113924E+00, |
| 23101 | &0.114131E+00,0.114175E+00,0.113924E+00,0.125620E+01,0.606602E-01, |
| 23102 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23103 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23104 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23105 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23106 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ |
| 23107 | DATA (DL(K),K= 1106, 1190) / |
| 23108 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23109 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23110 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23111 | &0.394012E+00,0.757115E+00,0.772117E-01,0.772117E-01,0.772117E-01, |
| 23112 | &0.772117E-01,0.117279E+01,0.346945E-17,0.395841E+00,0.752988E+00, |
| 23113 | &0.780501E-01,0.780655E-01,0.780723E-01,0.780501E-01,0.118528E+01, |
| 23114 | &0.491697E-02,0.396627E+00,0.747223E+00,0.785386E-01,0.785692E-01, |
| 23115 | &0.785806E-01,0.785386E-01,0.118242E+01,0.932754E-02,0.396401E+00, |
| 23116 | &0.739901E+00,0.786820E-01,0.787273E-01,0.787413E-01,0.786820E-01, |
| 23117 | &0.116673E+01,0.132427E-01,0.395190E+00,0.731092E+00,0.784870E-01, |
| 23118 | &0.785464E-01,0.785613E-01,0.784870E-01,0.114033E+01,0.166738E-01, |
| 23119 | &0.393030E+00,0.720878E+00,0.779683E-01,0.780410E-01,0.780555E-01, |
| 23120 | &0.779683E-01,0.110528E+01,0.196392E-01,0.389962E+00,0.709342E+00, |
| 23121 | &0.771427E-01,0.772280E-01,0.772409E-01,0.771427E-01,0.106344E+01, |
| 23122 | &0.221591E-01,0.386027E+00,0.696571E+00,0.760304E-01,0.761276E-01, |
| 23123 | &0.761378E-01,0.760304E-01,0.101653E+01,0.242567E-01,0.381274E+00, |
| 23124 | &0.682657E+00,0.746543E-01,0.747623E-01,0.747692E-01,0.746543E-01/ |
| 23125 | DATA (DL(K),K= 1191, 1275) / |
| 23126 | &0.966057E+00,0.259571E-01,0.375752E+00,0.667695E+00,0.730389E-01, |
| 23127 | &0.731569E-01,0.731598E-01,0.730389E-01,0.913345E+00,0.272876E-01, |
| 23128 | &0.369514E+00,0.651782E+00,0.712104E-01,0.713374E-01,0.713358E-01, |
| 23129 | &0.712104E-01,0.859530E+00,0.282763E-01,0.362616E+00,0.635021E+00, |
| 23130 | &0.691957E-01,0.693307E-01,0.693243E-01,0.691957E-01,0.805566E+00, |
| 23131 | &0.289524E-01,0.355116E+00,0.617511E+00,0.670220E-01,0.671640E-01, |
| 23132 | &0.671526E-01,0.670220E-01,0.752235E+00,0.293453E-01,0.347072E+00, |
| 23133 | &0.599357E+00,0.647162E-01,0.648642E-01,0.648478E-01,0.647162E-01, |
| 23134 | &0.700161E+00,0.294844E-01,0.338543E+00,0.580659E+00,0.623046E-01, |
| 23135 | &0.624578E-01,0.624363E-01,0.623046E-01,0.649828E+00,0.293983E-01, |
| 23136 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23137 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23138 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23139 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23140 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23141 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23142 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ |
| 23143 | DATA (DL(K),K= 1276, 1360) / |
| 23144 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23145 | &0.408305E+00,0.775318E+00,0.509141E-01,0.509141E-01,0.509141E-01, |
| 23146 | &0.509141E-01,0.818839E+00,-.867362E-17,0.403619E+00,0.758058E+00, |
| 23147 | &0.502245E-01,0.502351E-01,0.502337E-01,0.502245E-01,0.795347E+00, |
| 23148 | &0.264045E-02,0.398068E+00,0.739709E+00,0.493454E-01,0.493661E-01, |
| 23149 | &0.493626E-01,0.493454E-01,0.764942E+00,0.491508E-02,0.391719E+00, |
| 23150 | &0.720394E+00,0.482952E-01,0.483253E-01,0.483192E-01,0.482952E-01, |
| 23151 | &0.729624E+00,0.685202E-02,0.384627E+00,0.700222E+00,0.470896E-01, |
| 23152 | &0.471285E-01,0.471194E-01,0.470896E-01,0.690906E+00,0.847433E-02, |
| 23153 | &0.376851E+00,0.679300E+00,0.457475E-01,0.457946E-01,0.457822E-01, |
| 23154 | &0.457475E-01,0.650078E+00,0.980774E-02,0.368452E+00,0.657739E+00, |
| 23155 | &0.442875E-01,0.443419E-01,0.443261E-01,0.442875E-01,0.608239E+00, |
| 23156 | &0.108769E-01,0.359490E+00,0.635646E+00,0.427281E-01,0.427892E-01, |
| 23157 | &0.427698E-01,0.427281E-01,0.566280E+00,0.117061E-01,0.350026E+00, |
| 23158 | &0.613128E+00,0.410878E-01,0.411549E-01,0.411320E-01,0.410878E-01, |
| 23159 | &0.524918E+00,0.123191E-01,0.340122E+00,0.590292E+00,0.393848E-01, |
| 23160 | &0.394571E-01,0.394308E-01,0.393848E-01,0.484713E+00,0.127393E-01/ |
| 23161 | DATA (DL(K),K= 1361, 1445) / |
| 23162 | &0.329838E+00,0.567240E+00,0.376363E-01,0.377132E-01,0.376836E-01, |
| 23163 | &0.376363E-01,0.446084E+00,0.129888E-01,0.319236E+00,0.544074E+00, |
| 23164 | &0.358589E-01,0.359396E-01,0.359068E-01,0.358589E-01,0.409328E+00, |
| 23165 | &0.130888E-01,0.308374E+00,0.520890E+00,0.340678E-01,0.341517E-01, |
| 23166 | &0.341160E-01,0.340678E-01,0.374641E+00,0.130594E-01,0.297312E+00, |
| 23167 | &0.497781E+00,0.322772E-01,0.323636E-01,0.323253E-01,0.322772E-01, |
| 23168 | &0.342135E+00,0.129195E-01,0.286106E+00,0.474837E+00,0.304999E-01, |
| 23169 | &0.305882E-01,0.305474E-01,0.304999E-01,0.311854E+00,0.126863E-01, |
| 23170 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23171 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23172 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23173 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23174 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23175 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23176 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23177 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23178 | &0.407248E+00,0.746438E+00,0.335640E-01,0.335640E-01,0.335640E-01/ |
| 23179 | DATA (DL(K),K= 1446, 1530) / |
| 23180 | &0.335640E-01,0.573540E+00,0.173472E-16,0.397516E+00,0.719825E+00, |
| 23181 | &0.324649E-01,0.324735E-01,0.324698E-01,0.324649E-01,0.540770E+00, |
| 23182 | &0.147177E-02,0.387197E+00,0.692869E+00,0.312911E-01,0.313075E-01, |
| 23183 | &0.313000E-01,0.312911E-01,0.505972E+00,0.269995E-02,0.376365E+00, |
| 23184 | &0.665689E+00,0.300576E-01,0.300811E-01,0.300699E-01,0.300576E-01, |
| 23185 | &0.470389E+00,0.371147E-02,0.365085E+00,0.638387E+00,0.287770E-01, |
| 23186 | &0.288070E-01,0.287922E-01,0.287770E-01,0.434885E+00,0.452768E-02, |
| 23187 | &0.353423E+00,0.611066E+00,0.274623E-01,0.274980E-01,0.274797E-01, |
| 23188 | &0.274623E-01,0.400103E+00,0.516996E-02,0.341442E+00,0.583823E+00, |
| 23189 | &0.261256E-01,0.261663E-01,0.261448E-01,0.261256E-01,0.366541E+00, |
| 23190 | &0.565807E-02,0.329207E+00,0.556753E+00,0.247782E-01,0.248234E-01, |
| 23191 | &0.247989E-01,0.247782E-01,0.334555E+00,0.601048E-02,0.316777E+00, |
| 23192 | &0.529946E+00,0.234308E-01,0.234798E-01,0.234525E-01,0.234308E-01, |
| 23193 | &0.304384E+00,0.624451E-02,0.304214E+00,0.503489E+00,0.220932E-01, |
| 23194 | &0.221452E-01,0.221155E-01,0.220932E-01,0.276170E+00,0.637618E-02, |
| 23195 | &0.291575E+00,0.477462E+00,0.207739E-01,0.208286E-01,0.207966E-01, |
| 23196 | &0.207739E-01,0.249976E+00,0.642028E-02,0.278917E+00,0.451941E+00/ |
| 23197 | DATA (DL(K),K= 1531, 1615) / |
| 23198 | &0.194809E-01,0.195376E-01,0.195037E-01,0.194809E-01,0.225809E+00, |
| 23199 | &0.639038E-02,0.266293E+00,0.426995E+00,0.182209E-01,0.182791E-01, |
| 23200 | &0.182436E-01,0.182209E-01,0.203629E+00,0.629880E-02,0.253754E+00, |
| 23201 | &0.402686E+00,0.169996E-01,0.170587E-01,0.170219E-01,0.169996E-01, |
| 23202 | &0.183361E+00,0.615665E-02,0.241347E+00,0.379071E+00,0.158217E-01, |
| 23203 | &0.158814E-01,0.158436E-01,0.158217E-01,0.164907E+00,0.597385E-02, |
| 23204 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23205 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23206 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23207 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23208 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23209 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23210 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23211 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23212 | &0.395106E+00,0.689399E+00,0.218554E-01,0.218554E-01,0.218554E-01, |
| 23213 | &0.218554E-01,0.398362E+00,-.173472E-17,0.381441E+00,0.656777E+00, |
| 23214 | &0.207816E-01,0.207886E-01,0.207844E-01,0.207816E-01,0.366703E+00/ |
| 23215 | DATA (DL(K),K= 1616, 1700) / |
| 23216 | &0.826643E-03,0.367505E+00,0.624578E+00,0.197001E-01,0.197133E-01, |
| 23217 | &0.197053E-01,0.197001E-01,0.335573E+00,0.149886E-02,0.353373E+00, |
| 23218 | &0.592889E+00,0.186195E-01,0.186383E-01,0.186266E-01,0.186195E-01, |
| 23219 | &0.305590E+00,0.203730E-02,0.339106E+00,0.561783E+00,0.175468E-01, |
| 23220 | &0.175705E-01,0.175555E-01,0.175468E-01,0.277136E+00,0.245817E-02, |
| 23221 | &0.324766E+00,0.531331E+00,0.164887E-01,0.165166E-01,0.164986E-01, |
| 23222 | &0.164887E-01,0.250424E+00,0.277666E-02,0.310411E+00,0.501599E+00, |
| 23223 | &0.154510E-01,0.154825E-01,0.154618E-01,0.154510E-01,0.225588E+00, |
| 23224 | &0.300658E-02,0.296100E+00,0.472648E+00,0.144390E-01,0.144735E-01, |
| 23225 | &0.144504E-01,0.144390E-01,0.202681E+00,0.316040E-02,0.281885E+00, |
| 23226 | &0.444535E+00,0.134570E-01,0.134940E-01,0.134689E-01,0.134570E-01, |
| 23227 | &0.181693E+00,0.324944E-02,0.267820E+00,0.417309E+00,0.125091E-01, |
| 23228 | &0.125481E-01,0.125212E-01,0.125091E-01,0.162572E+00,0.328396E-02, |
| 23229 | &0.253953E+00,0.391017E+00,0.115984E-01,0.116389E-01,0.116106E-01, |
| 23230 | &0.115984E-01,0.145235E+00,0.327313E-02,0.240328E+00,0.365695E+00, |
| 23231 | &0.107275E-01,0.107690E-01,0.107396E-01,0.107275E-01,0.129575E+00, |
| 23232 | &0.322510E-02,0.226989E+00,0.341375E+00,0.989805E-02,0.994030E-02/ |
| 23233 | DATA (DL(K),K= 1701, 1785) / |
| 23234 | &0.990998E-02,0.989805E-02,0.115477E+00,0.314713E-02,0.213972E+00, |
| 23235 | &0.318081E+00,0.911149E-02,0.915408E-02,0.912316E-02,0.911149E-02, |
| 23236 | &0.102820E+00,0.304556E-02,0.201311E+00,0.295830E+00,0.836852E-02, |
| 23237 | &0.841111E-02,0.837984E-02,0.836852E-02,0.914804E-01,0.292596E-02, |
| 23238 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23239 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23240 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23241 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23242 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23243 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23244 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23245 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23246 | &0.374678E+00,0.616087E+00,0.139531E-01,0.139531E-01,0.139531E-01, |
| 23247 | &0.139531E-01,0.272491E+00,-.693889E-17,0.358052E+00,0.580345E+00, |
| 23248 | &0.130624E-01,0.130680E-01,0.130641E-01,0.130624E-01,0.245861E+00, |
| 23249 | &0.460255E-03,0.341487E+00,0.545719E+00,0.121971E-01,0.122076E-01, |
| 23250 | &0.122002E-01,0.121971E-01,0.220877E+00,0.826785E-03,0.325046E+00/ |
| 23251 | DATA (DL(K),K= 1786, 1870) / |
| 23252 | &0.512244E+00,0.113599E-01,0.113748E-01,0.113641E-01,0.113599E-01, |
| 23253 | &0.197730E+00,0.111366E-02,0.308783E+00,0.479952E+00,0.105534E-01, |
| 23254 | &0.105720E-01,0.105585E-01,0.105534E-01,0.176497E+00,0.133192E-02, |
| 23255 | &0.292747E+00,0.448868E+00,0.977938E-02,0.980112E-02,0.978518E-02, |
| 23256 | &0.977938E-02,0.157150E+00,0.149139E-02,0.276986E+00,0.419015E+00, |
| 23257 | &0.903955E-02,0.906394E-02,0.904584E-02,0.903955E-02,0.139631E+00, |
| 23258 | &0.160093E-02,0.261546E+00,0.390412E+00,0.833509E-02,0.836165E-02, |
| 23259 | &0.834171E-02,0.833509E-02,0.123850E+00,0.166838E-02,0.246467E+00, |
| 23260 | &0.363074E+00,0.766687E-02,0.769516E-02,0.767369E-02,0.766687E-02, |
| 23261 | &0.109695E+00,0.170073E-02,0.231787E+00,0.337008E+00,0.703540E-02, |
| 23262 | &0.706500E-02,0.704230E-02,0.703540E-02,0.970428E-01,0.170416E-02, |
| 23263 | &0.217542E+00,0.312218E+00,0.644083E-02,0.647137E-02,0.644772E-02, |
| 23264 | &0.644083E-02,0.857658E-01,0.168409E-02,0.203759E+00,0.288701E+00, |
| 23265 | &0.588300E-02,0.591415E-02,0.588981E-02,0.588300E-02,0.757385E-01, |
| 23266 | &0.164528E-02,0.190467E+00,0.266449E+00,0.536147E-02,0.539292E-02, |
| 23267 | &0.536812E-02,0.536147E-02,0.668383E-01,0.159185E-02,0.177686E+00, |
| 23268 | &0.245447E+00,0.487551E-02,0.490698E-02,0.488195E-02,0.487551E-02/ |
| 23269 | DATA (DL(K),K= 1871, 1955) / |
| 23270 | &0.589492E-01,0.152735E-02,0.165434E+00,0.225677E+00,0.442416E-02, |
| 23271 | &0.445543E-02,0.443037E-02,0.442416E-02,0.519652E-01,0.145483E-02, |
| 23272 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23273 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23274 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23275 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23276 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23277 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23278 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23279 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23280 | &0.348042E+00,0.534691E+00,0.867977E-02,0.867977E-02,0.867977E-02, |
| 23281 | &0.867977E-02,0.182547E+00,-.693889E-17,0.329349E+00,0.498248E+00, |
| 23282 | &0.800724E-02,0.801198E-02,0.800836E-02,0.800724E-02,0.161948E+00, |
| 23283 | &0.250949E-03,0.311047E+00,0.463485E+00,0.737155E-02,0.738040E-02, |
| 23284 | &0.737356E-02,0.737155E-02,0.143267E+00,0.447662E-03,0.293181E+00, |
| 23285 | &0.430377E+00,0.677169E-02,0.678409E-02,0.677441E-02,0.677169E-02, |
| 23286 | &0.126447E+00,0.598803E-03,0.275787E+00,0.398907E+00,0.620726E-02/ |
| 23287 | DATA (DL(K),K= 1956, 2040) / |
| 23288 | &0.622265E-02,0.621051E-02,0.620726E-02,0.111401E+00,0.711280E-03, |
| 23289 | &0.258900E+00,0.369051E+00,0.567741E-02,0.569532E-02,0.568106E-02, |
| 23290 | &0.567741E-02,0.979944E-01,0.790986E-03,0.242550E+00,0.340785E+00, |
| 23291 | &0.518138E-02,0.520134E-02,0.518531E-02,0.518138E-02,0.860936E-01, |
| 23292 | &0.843227E-03,0.226765E+00,0.314083E+00,0.471828E-02,0.473987E-02, |
| 23293 | &0.472238E-02,0.471828E-02,0.755615E-01,0.872644E-03,0.211568E+00, |
| 23294 | &0.288916E+00,0.428714E-02,0.430998E-02,0.429133E-02,0.428714E-02, |
| 23295 | &0.662627E-01,0.883319E-03,0.196981E+00,0.265252E+00,0.388691E-02, |
| 23296 | &0.391065E-02,0.389112E-02,0.388691E-02,0.580684E-01,0.878818E-03, |
| 23297 | &0.183020E+00,0.243053E+00,0.351645E-02,0.354077E-02,0.352060E-02, |
| 23298 | &0.351645E-02,0.508578E-01,0.862228E-03,0.169696E+00,0.222280E+00, |
| 23299 | &0.317451E-02,0.319914E-02,0.317858E-02,0.317451E-02,0.445190E-01, |
| 23300 | &0.836224E-03,0.157017E+00,0.202888E+00,0.285982E-02,0.288450E-02, |
| 23301 | &0.286376E-02,0.285982E-02,0.389523E-01,0.803096E-03,0.144987E+00, |
| 23302 | &0.184832E+00,0.257101E-02,0.259553E-02,0.257480E-02,0.257101E-02, |
| 23303 | &0.340677E-01,0.764787E-03,0.133605E+00,0.168060E+00,0.230670E-02, |
| 23304 | &0.233087E-02,0.231031E-02,0.230670E-02,0.297820E-01,0.722929E-03/ |
| 23305 | DATA (DL(K),K= 2041, 2125) / |
| 23306 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23307 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23308 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23309 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23310 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23311 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23312 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23313 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23314 | &0.316867E+00,0.451111E+00,0.522815E-02,0.522815E-02,0.522815E-02, |
| 23315 | &0.522815E-02,0.119118E+00,0.889046E-17,0.296950E+00,0.415915E+00, |
| 23316 | &0.475497E-02,0.475914E-02,0.475574E-02,0.475497E-02,0.104204E+00, |
| 23317 | &0.132513E-03,0.277735E+00,0.382805E+00,0.431809E-02,0.432582E-02, |
| 23318 | &0.431944E-02,0.431809E-02,0.910279E-01,0.235347E-03,0.259241E+00, |
| 23319 | &0.351694E+00,0.391455E-02,0.392531E-02,0.391637E-02,0.391455E-02, |
| 23320 | &0.794222E-01,0.313322E-03,0.241485E+00,0.322517E+00,0.354249E-02, |
| 23321 | &0.355575E-02,0.354464E-02,0.354249E-02,0.692354E-01,0.370408E-03, |
| 23322 | &0.224480E+00,0.295202E+00,0.319987E-02,0.321518E-02,0.320226E-02/ |
| 23323 | DATA (DL(K),K= 2126, 2210) / |
| 23324 | &0.319987E-02,0.603106E-01,0.409866E-03,0.208235E+00,0.269681E+00, |
| 23325 | &0.288490E-02,0.290184E-02,0.288744E-02,0.288490E-02,0.525034E-01, |
| 23326 | &0.434663E-03,0.192759E+00,0.245887E+00,0.259589E-02,0.261407E-02, |
| 23327 | &0.259852E-02,0.259589E-02,0.456838E-01,0.447393E-03,0.178054E+00, |
| 23328 | &0.223752E+00,0.233123E-02,0.235033E-02,0.233390E-02,0.233123E-02, |
| 23329 | &0.397318E-01,0.450314E-03,0.164120E+00,0.203207E+00,0.208941E-02, |
| 23330 | &0.210910E-02,0.209206E-02,0.208941E-02,0.345396E-01,0.445394E-03, |
| 23331 | &0.150954E+00,0.184182E+00,0.186896E-02,0.188897E-02,0.187155E-02, |
| 23332 | &0.186896E-02,0.300131E-01,0.434333E-03,0.138548E+00,0.166608E+00, |
| 23333 | &0.166844E-02,0.168854E-02,0.167096E-02,0.166844E-02,0.260692E-01, |
| 23334 | &0.418584E-03,0.126892E+00,0.150412E+00,0.148650E-02,0.150648E-02, |
| 23335 | &0.148891E-02,0.148650E-02,0.226325E-01,0.399380E-03,0.115971E+00, |
| 23336 | &0.135523E+00,0.132180E-02,0.134148E-02,0.132409E-02,0.132180E-02, |
| 23337 | &0.196374E-01,0.377764E-03,0.105767E+00,0.121870E+00,0.117308E-02, |
| 23338 | &0.119231E-02,0.117524E-02,0.117308E-02,0.170312E-01,0.354610E-03, |
| 23339 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23340 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ |
| 23341 | DATA (DL(K),K= 2211, 2295) / |
| 23342 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23343 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23344 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23345 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23346 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23347 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23348 | &0.282579E+00,0.369670E+00,0.302765E-02,0.302765E-02,0.302765E-02, |
| 23349 | &0.302765E-02,0.752529E-01,-.455365E-17,0.262229E+00,0.337209E+00, |
| 23350 | &0.271512E-02,0.271883E-02,0.271564E-02,0.271512E-02,0.651086E-01, |
| 23351 | &0.669321E-04,0.242857E+00,0.307069E+00,0.243269E-02,0.243953E-02, |
| 23352 | &0.243360E-02,0.243269E-02,0.563252E-01,0.118744E-03,0.224455E+00, |
| 23353 | &0.279111E+00,0.217687E-02,0.218631E-02,0.217808E-02,0.217687E-02, |
| 23354 | &0.487143E-01,0.157767E-03,0.207014E+00,0.253223E+00,0.194534E-02, |
| 23355 | &0.195689E-02,0.194675E-02,0.194534E-02,0.421227E-01,0.186063E-03, |
| 23356 | &0.190523E+00,0.229293E+00,0.173585E-02,0.174909E-02,0.173741E-02, |
| 23357 | &0.173585E-02,0.364156E-01,0.205286E-03,0.174969E+00,0.207218E+00, |
| 23358 | &0.154647E-02,0.156100E-02,0.154811E-02,0.154647E-02,0.314732E-01/ |
| 23359 | DATA (DL(K),K= 2296, 2380) / |
| 23360 | &0.216964E-03,0.160335E+00,0.186895E+00,0.137545E-02,0.139092E-02, |
| 23361 | &0.137713E-02,0.137545E-02,0.271927E-01,0.222455E-03,0.146604E+00, |
| 23362 | &0.168227E+00,0.122121E-02,0.123733E-02,0.122290E-02,0.122121E-02, |
| 23363 | &0.234852E-01,0.222947E-03,0.133756E+00,0.151116E+00,0.108234E-02, |
| 23364 | &0.109881E-02,0.108400E-02,0.108234E-02,0.202747E-01,0.219474E-03, |
| 23365 | &0.121765E+00,0.135471E+00,0.957502E-03,0.974107E-03,0.959112E-03, |
| 23366 | &0.957502E-03,0.174932E-01,0.212928E-03,0.110606E+00,0.121198E+00, |
| 23367 | &0.845493E-03,0.862024E-03,0.847037E-03,0.845493E-03,0.150824E-01, |
| 23368 | &0.204075E-03,0.100250E+00,0.108210E+00,0.745196E-03,0.761482E-03, |
| 23369 | &0.746662E-03,0.745196E-03,0.129965E-01,0.193573E-03,0.906661E-01, |
| 23370 | &0.964191E-01,0.655569E-03,0.671466E-03,0.656948E-03,0.655569E-03, |
| 23371 | &0.111930E-01,0.181962E-03,0.818218E-01,0.857412E-01,0.575637E-03, |
| 23372 | &0.591030E-03,0.576925E-03,0.575637E-03,0.962922E-02,0.169687E-03, |
| 23373 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23374 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23375 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23376 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ |
| 23377 | DATA (DL(K),K= 2381, 2465) / |
| 23378 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23379 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23380 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23381 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23382 | &0.246444E+00,0.293515E+00,0.167124E-02,0.167124E-02,0.167124E-02, |
| 23383 | &0.167124E-02,0.456929E-01,-.260209E-17,0.226393E+00,0.264836E+00, |
| 23384 | &0.147748E-02,0.148085E-02,0.147783E-02,0.147748E-02,0.392393E-01, |
| 23385 | &0.318190E-04,0.207552E+00,0.238550E+00,0.130596E-02,0.131212E-02, |
| 23386 | &0.130656E-02,0.130596E-02,0.337276E-01,0.566426E-04,0.189877E+00, |
| 23387 | &0.214470E+00,0.115347E-02,0.116190E-02,0.115427E-02,0.115347E-02, |
| 23388 | &0.290012E-01,0.753776E-04,0.173336E+00,0.192452E+00,0.101789E-02, |
| 23389 | &0.102811E-02,0.101881E-02,0.101789E-02,0.249381E-01,0.889466E-04, |
| 23390 | &0.157889E+00,0.172355E+00,0.897268E-03,0.908872E-03,0.898270E-03, |
| 23391 | &0.897268E-03,0.214419E-01,0.980950E-04,0.143501E+00,0.154046E+00, |
| 23392 | &0.789951E-03,0.802565E-03,0.790996E-03,0.789951E-03,0.184296E-01, |
| 23393 | &0.103536E-03,0.130132E+00,0.137402E+00,0.694510E-03,0.707811E-03, |
| 23394 | &0.695568E-03,0.694510E-03,0.158331E-01,0.105929E-03,0.117743E+00/ |
| 23395 | DATA (DL(K),K= 2466, 2550) / |
| 23396 | &0.122303E+00,0.609684E-03,0.623394E-03,0.610733E-03,0.609684E-03, |
| 23397 | &0.135929E-01,0.105853E-03,0.106293E+00,0.108637E+00,0.534365E-03, |
| 23398 | &0.548244E-03,0.535386E-03,0.534365E-03,0.116583E-01,0.103825E-03, |
| 23399 | &0.957386E-01,0.962976E-01,0.467572E-03,0.481416E-03,0.468551E-03, |
| 23400 | &0.467572E-03,0.999103E-02,0.100301E-03,0.860376E-01,0.851820E-01, |
| 23401 | &0.408422E-03,0.422062E-03,0.409350E-03,0.408422E-03,0.855563E-02, |
| 23402 | &0.956675E-04,0.771455E-01,0.751930E-01,0.356117E-03,0.369416E-03, |
| 23403 | &0.356989E-03,0.356117E-03,0.731542E-02,0.902499E-04,0.690178E-01, |
| 23404 | &0.662386E-01,0.309950E-03,0.322797E-03,0.310761E-03,0.309950E-03, |
| 23405 | &0.624633E-02,0.843305E-04,0.616096E-01,0.582312E-01,0.269281E-03, |
| 23406 | &0.281590E-03,0.270030E-03,0.269281E-03,0.533230E-02,0.781441E-04, |
| 23407 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23408 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23409 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23410 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23411 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23412 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ |
| 23413 | DATA (DL(K),K= 2551, 2635) / |
| 23414 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23415 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23416 | &0.209608E+00,0.224862E+00,0.869706E-03,0.869706E-03,0.869706E-03, |
| 23417 | &0.869706E-03,0.264204E-01,-.138236E-17,0.190523E+00,0.200603E+00, |
| 23418 | &0.757542E-03,0.760626E-03,0.757768E-03,0.757542E-03,0.226261E-01, |
| 23419 | &0.138827E-04,0.172819E+00,0.178656E+00,0.660281E-03,0.665837E-03, |
| 23420 | &0.660670E-03,0.660281E-03,0.194018E-01,0.249832E-04,0.156420E+00, |
| 23421 | &0.158805E+00,0.575414E-03,0.582918E-03,0.575917E-03,0.575414E-03, |
| 23422 | &0.166434E-01,0.334851E-04,0.141265E+00,0.140883E+00,0.501258E-03, |
| 23423 | &0.510252E-03,0.501836E-03,0.501258E-03,0.142710E-01,0.397017E-04, |
| 23424 | &0.127291E+00,0.124732E+00,0.436386E-03,0.446473E-03,0.437008E-03, |
| 23425 | &0.436386E-03,0.122297E-01,0.439154E-04,0.114437E+00,0.110205E+00, |
| 23426 | &0.379575E-03,0.390415E-03,0.380217E-03,0.379575E-03,0.104701E-01, |
| 23427 | &0.464110E-04,0.102644E+00,0.971655E-01,0.329805E-03,0.341109E-03, |
| 23428 | &0.330448E-03,0.329805E-03,0.895086E-02,0.474758E-04,0.918521E-01, |
| 23429 | &0.854876E-01,0.286206E-03,0.297729E-03,0.286836E-03,0.286206E-03, |
| 23430 | &0.764249E-02,0.473771E-04,0.820032E-01,0.750529E-01,0.248027E-03/ |
| 23431 | DATA (DL(K),K= 2636, 2720) / |
| 23432 | &0.259564E-03,0.248633E-03,0.248027E-03,0.651744E-02,0.463561E-04, |
| 23433 | &0.730394E-01,0.657510E-01,0.214611E-03,0.225995E-03,0.215186E-03, |
| 23434 | &0.214611E-03,0.554573E-02,0.446239E-04,0.649040E-01,0.574789E-01, |
| 23435 | &0.185396E-03,0.196491E-03,0.185935E-03,0.185396E-03,0.470938E-02, |
| 23436 | &0.423722E-04,0.575411E-01,0.501405E-01,0.159891E-03,0.170590E-03, |
| 23437 | &0.160391E-03,0.159891E-03,0.399752E-02,0.397689E-04,0.508960E-01, |
| 23438 | &0.436466E-01,0.137650E-03,0.147874E-03,0.138111E-03,0.137650E-03, |
| 23439 | &0.338807E-02,0.369434E-04,0.449157E-01,0.379141E-01,0.118285E-03, |
| 23440 | &0.127973E-03,0.118705E-03,0.118285E-03,0.286125E-02,0.340035E-04, |
| 23441 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23442 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23443 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23444 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23445 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23446 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23447 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23448 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ |
| 23449 | DATA (DL(K),K= 2721, 2805) / |
| 23450 | &0.173133E+00,0.165162E+00,0.420483E-03,0.420483E-03,0.420483E-03, |
| 23451 | &0.420483E-03,0.143704E-01,0.418773E-17,0.155600E+00,0.145586E+00, |
| 23452 | &0.360490E-03,0.363140E-03,0.360629E-03,0.360490E-03,0.123560E-01, |
| 23453 | &0.533279E-05,0.139551E+00,0.128113E+00,0.309555E-03,0.314310E-03, |
| 23454 | &0.309792E-03,0.309555E-03,0.106262E-01,0.982612E-05,0.124876E+00, |
| 23455 | &0.112516E+00,0.265952E-03,0.272344E-03,0.266256E-03,0.265952E-03, |
| 23456 | &0.913151E-02,0.133834E-04,0.111490E+00,0.986188E-01,0.228522E-03, |
| 23457 | &0.236138E-03,0.228869E-03,0.228522E-03,0.783135E-02,0.160429E-04, |
| 23458 | &0.993081E-01,0.862590E-01,0.196336E-03,0.204821E-03,0.196706E-03, |
| 23459 | &0.196336E-03,0.670031E-02,0.178799E-04,0.882484E-01,0.752883E-01, |
| 23460 | &0.168604E-03,0.177655E-03,0.168981E-03,0.168604E-03,0.572016E-02, |
| 23461 | &0.189837E-04,0.782334E-01,0.655714E-01,0.144684E-03,0.154047E-03, |
| 23462 | &0.145058E-03,0.144684E-03,0.487276E-02,0.194655E-04,0.691885E-01, |
| 23463 | &0.569841E-01,0.124035E-03,0.133497E-03,0.124397E-03,0.124035E-03, |
| 23464 | &0.413648E-02,0.194296E-04,0.610420E-01,0.494128E-01,0.106203E-03, |
| 23465 | &0.115592E-03,0.106548E-03,0.106203E-03,0.350042E-02,0.189800E-04, |
| 23466 | &0.537249E-01,0.427533E-01,0.908141E-04,0.999895E-04,0.911377E-04/ |
| 23467 | DATA (DL(K),K= 2806, 2890) / |
| 23468 | &0.908141E-04,0.295961E-02,0.182192E-04,0.471713E-01,0.369100E-01, |
| 23469 | &0.775359E-04,0.863895E-04,0.778360E-04,0.775359E-04,0.249629E-02, |
| 23470 | &0.172287E-04,0.413182E-01,0.317957E-01,0.660857E-04,0.745356E-04, |
| 23471 | &0.663611E-04,0.660857E-04,0.209482E-02,0.160791E-04,0.361056E-01, |
| 23472 | &0.273306E-01,0.562298E-04,0.642173E-04,0.564804E-04,0.562298E-04, |
| 23473 | &0.175588E-02,0.148407E-04,0.314766E-01,0.234421E-01,0.477598E-04, |
| 23474 | &0.552457E-04,0.479859E-04,0.477598E-04,0.147398E-02,0.135653E-04, |
| 23475 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23476 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23477 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23478 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23479 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23480 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23481 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23482 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23483 | &0.138007E+00,0.115214E+00,0.185072E-03,0.185072E-03,0.185072E-03, |
| 23484 | &0.185072E-03,0.722856E-02,-.380826E-17,0.122517E+00,0.100251E+00/ |
| 23485 | DATA (DL(K),K= 2891, 2975) / |
| 23486 | &0.155814E-03,0.158287E-03,0.155901E-03,0.155814E-03,0.630580E-02, |
| 23487 | &0.155371E-05,0.108535E+00,0.870870E-01,0.131535E-03,0.135909E-03, |
| 23488 | &0.131680E-03,0.131535E-03,0.547867E-02,0.304952E-05,0.959260E-01, |
| 23489 | &0.754985E-01,0.111183E-03,0.116980E-03,0.111366E-03,0.111183E-03, |
| 23490 | &0.473794E-02,0.433106E-05,0.845828E-01,0.653163E-01,0.940433E-04, |
| 23491 | &0.100851E-03,0.942493E-04,0.940433E-04,0.407647E-02,0.533613E-05, |
| 23492 | &0.744017E-01,0.563870E-01,0.795843E-04,0.870596E-04,0.798007E-04, |
| 23493 | &0.795843E-04,0.349165E-02,0.606691E-05,0.652864E-01,0.485720E-01, |
| 23494 | &0.673476E-04,0.752069E-04,0.675656E-04,0.673476E-04,0.297273E-02, |
| 23495 | &0.652898E-05,0.571466E-01,0.417472E-01,0.569700E-04,0.649812E-04, |
| 23496 | &0.571831E-04,0.569700E-04,0.251732E-02,0.675028E-05,0.498975E-01, |
| 23497 | &0.358008E-01,0.481618E-04,0.561391E-04,0.483654E-04,0.481618E-04, |
| 23498 | &0.212754E-02,0.677236E-05,0.434594E-01,0.306320E-01,0.406746E-04, |
| 23499 | &0.484724E-04,0.408657E-04,0.406746E-04,0.179059E-02,0.662814E-05, |
| 23500 | &0.377578E-01,0.261500E-01,0.343050E-04,0.418123E-04,0.344818E-04, |
| 23501 | &0.343050E-04,0.149563E-02,0.635273E-05,0.327229E-01,0.222734E-01, |
| 23502 | &0.288923E-04,0.360279E-04,0.290540E-04,0.288923E-04,0.124695E-02/ |
| 23503 | DATA (DL(K),K= 2976, 3060) / |
| 23504 | &0.598767E-05,0.282894E-01,0.189287E-01,0.242960E-04,0.310036E-04, |
| 23505 | &0.244423E-04,0.242960E-04,0.104112E-02,0.556344E-05,0.243968E-01, |
| 23506 | &0.160504E-01,0.203920E-04,0.266363E-04,0.205232E-04,0.203920E-04, |
| 23507 | &0.863677E-03,0.510070E-05,0.209890E-01,0.135797E-01,0.170822E-04, |
| 23508 | &0.228449E-04,0.171989E-04,0.170822E-04,0.711641E-03,0.462338E-05, |
| 23509 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23510 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23511 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23512 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23513 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23514 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23515 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23516 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23517 | &0.105155E+00,0.752467E-01,0.719932E-04,0.719932E-04,0.719932E-04, |
| 23518 | &0.719932E-04,0.328057E-02,-.758942E-18,0.920856E-01,0.645455E-01, |
| 23519 | &0.592305E-04,0.615087E-04,0.592802E-04,0.592305E-04,0.295327E-02, |
| 23520 | &0.945234E-07,0.804695E-01,0.552770E-01,0.489125E-04,0.528632E-04/ |
| 23521 | DATA (DL(K),K= 3061, 3145) / |
| 23522 | &0.489946E-04,0.489125E-04,0.261804E-02,0.365139E-06,0.701499E-01, |
| 23523 | &0.472409E-01,0.404786E-04,0.456186E-04,0.405807E-04,0.404786E-04, |
| 23524 | &0.229460E-02,0.686912E-06,0.610049E-01,0.402864E-01,0.335367E-04, |
| 23525 | &0.394631E-04,0.336495E-04,0.335367E-04,0.198445E-02,0.981070E-06, |
| 23526 | &0.529201E-01,0.342803E-01,0.278134E-04,0.342044E-04,0.279301E-04, |
| 23527 | &0.278134E-04,0.169772E-02,0.122521E-05,0.457907E-01,0.291037E-01, |
| 23528 | &0.230821E-04,0.296833E-04,0.231978E-04,0.230821E-04,0.144575E-02, |
| 23529 | &0.140819E-05,0.395205E-01,0.246522E-01,0.191553E-04,0.257661E-04, |
| 23530 | &0.192666E-04,0.191553E-04,0.122125E-02,0.152152E-05,0.340212E-01, |
| 23531 | &0.208330E-01,0.158874E-04,0.223546E-04,0.159921E-04,0.158874E-04, |
| 23532 | &0.101912E-02,0.156880E-05,0.292116E-01,0.175644E-01,0.131678E-04, |
| 23533 | &0.193783E-04,0.132645E-04,0.131678E-04,0.847586E-03,0.156432E-05, |
| 23534 | &0.250173E-01,0.147740E-01,0.109029E-04,0.167762E-04,0.109910E-04, |
| 23535 | &0.109029E-04,0.705515E-03,0.151845E-05,0.213702E-01,0.123979E-01, |
| 23536 | &0.901273E-05,0.144953E-04,0.909200E-05,0.901273E-05,0.581767E-03, |
| 23537 | &0.143817E-05,0.182083E-01,0.103797E-01,0.743733E-05,0.124978E-04, |
| 23538 | &0.750792E-05,0.743733E-05,0.475483E-03,0.133574E-05,0.154751E-01/ |
| 23539 | DATA (DL(K),K= 3146, 3230) / |
| 23540 | &0.867011E-02,0.612722E-05,0.107517E-04,0.618950E-05,0.612722E-05, |
| 23541 | &0.390116E-03,0.122183E-05,0.131193E-01,0.722560E-02,0.503734E-05, |
| 23542 | &0.922584E-05,0.509185E-05,0.503734E-05,0.319980E-03,0.110130E-05, |
| 23543 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23544 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23545 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23546 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23547 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23548 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23549 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23550 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23551 | &0.754424E-01,0.449848E-01,0.236444E-04,0.236444E-04,0.236444E-04, |
| 23552 | &0.236444E-04,0.129291E-02,0.113079E-17,0.650429E-01,0.379660E-01, |
| 23553 | &0.187739E-04,0.207130E-04,0.187990E-04,0.187739E-04,0.124038E-02, |
| 23554 | &-.327995E-06,0.559588E-01,0.319936E-01,0.149625E-04,0.182671E-04, |
| 23555 | &0.150033E-04,0.149625E-04,0.113497E-02,-.464337E-06,0.480234E-01, |
| 23556 | &0.269030E-01,0.119484E-04,0.161746E-04,0.119982E-04,0.119484E-04/ |
| 23557 | DATA (DL(K),K= 3231, 3315) / |
| 23558 | &0.100877E-02,-.490618E-06,0.411091E-01,0.225716E-01,0.954833E-05, |
| 23559 | &0.143391E-04,0.960250E-05,0.954833E-05,0.883852E-03,-.461770E-06, |
| 23560 | &0.350995E-01,0.188947E-01,0.763738E-05,0.127129E-04,0.769248E-05, |
| 23561 | &0.763738E-05,0.760077E-03,-.403363E-06,0.298897E-01,0.157798E-01, |
| 23562 | &0.611070E-05,0.112548E-04,0.616439E-05,0.611070E-05,0.639505E-03, |
| 23563 | &-.335607E-06,0.253856E-01,0.131470E-01,0.488993E-05,0.994021E-05, |
| 23564 | &0.494070E-05,0.488993E-05,0.534131E-03,-.267652E-06,0.215026E-01, |
| 23565 | &0.109271E-01,0.391276E-05,0.875190E-05,0.395967E-05,0.391276E-05, |
| 23566 | &0.445478E-03,-.205292E-06,0.181648E-01,0.906007E-02,0.312720E-05, |
| 23567 | &0.767418E-05,0.316978E-05,0.312720E-05,0.366232E-03,-.154024E-06, |
| 23568 | &0.153041E-01,0.749382E-02,0.249633E-05,0.670002E-05,0.253440E-05, |
| 23569 | &0.249633E-05,0.297435E-03,-.112673E-06,0.128596E-01,0.618334E-02, |
| 23570 | &0.199074E-05,0.582360E-05,0.202435E-05,0.199074E-05,0.242305E-03, |
| 23571 | &-.794410E-07,0.107770E-01,0.508977E-02,0.158457E-05,0.503733E-05, |
| 23572 | &0.161393E-05,0.158457E-05,0.196927E-03,-.546702E-07,0.900806E-02, |
| 23573 | &0.417964E-02,0.125888E-05,0.433619E-05,0.128428E-05,0.125888E-05, |
| 23574 | &0.158171E-03,-.364714E-07,0.751006E-02,0.342418E-02,0.998674E-06/ |
| 23575 | DATA (DL(K),K= 3316, 3400) / |
| 23576 | &0.371518E-05,0.102046E-05,0.998674E-06,0.126865E-03,-.228706E-07, |
| 23577 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23578 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23579 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23580 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23581 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23582 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23583 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23584 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23585 | &0.496787E-01,0.236961E-01,0.607312E-05,0.607312E-05,0.607312E-05, |
| 23586 | &0.607312E-05,0.415108E-03,-.140523E-17,0.420445E-01,0.196196E-01, |
| 23587 | &0.443589E-05,0.603481E-05,0.444683E-05,0.443589E-05,0.444425E-03, |
| 23588 | &-.375397E-06,0.355108E-01,0.162223E-01,0.321766E-05,0.587645E-05, |
| 23589 | &0.323504E-05,0.321766E-05,0.432635E-03,-.593989E-06,0.299148E-01, |
| 23590 | &0.133836E-01,0.231504E-05,0.562250E-05,0.233581E-05,0.231504E-05, |
| 23591 | &0.395801E-03,-.699904E-06,0.251339E-01,0.110157E-01,0.164651E-05, |
| 23592 | &0.526880E-05,0.166853E-05,0.164651E-05,0.344925E-03,-.733095E-06/ |
| 23593 | DATA (DL(K),K= 3401, 3485) / |
| 23594 | &0.210605E-01,0.904539E-02,0.115940E-05,0.485739E-05,0.118122E-05, |
| 23595 | &0.115940E-05,0.294439E-03,-.715193E-06,0.175989E-01,0.740944E-02, |
| 23596 | &0.808365E-06,0.441709E-05,0.829075E-06,0.808365E-06,0.249093E-03, |
| 23597 | &-.665420E-06,0.146656E-01,0.605433E-02,0.555563E-06,0.396078E-05, |
| 23598 | &0.574607E-06,0.555563E-06,0.205675E-03,-.600648E-06,0.121872E-01, |
| 23599 | &0.493466E-02,0.375914E-06,0.350822E-05,0.393011E-06,0.375914E-06, |
| 23600 | &0.166757E-03,-.529210E-06,0.100993E-01,0.401191E-02,0.250032E-06, |
| 23601 | &0.307359E-05,0.265094E-06,0.250032E-06,0.135196E-03,-.456996E-06, |
| 23602 | &0.834582E-02,0.325348E-02,0.162261E-06,0.266488E-05,0.175325E-06, |
| 23603 | &0.162261E-06,0.108862E-03,-.388821E-06,0.687767E-02,0.263179E-02, |
| 23604 | &0.102273E-06,0.228913E-05,0.113453E-06,0.102273E-06,0.865539E-04, |
| 23605 | &-.326325E-06,0.565221E-02,0.212357E-02,0.620694E-07,0.194975E-05, |
| 23606 | &0.715290E-07,0.620694E-07,0.687156E-04,-.270547E-06,0.463248E-02, |
| 23607 | &0.170926E-02,0.351992E-07,0.164711E-05,0.431226E-07,0.351992E-07, |
| 23608 | &0.543744E-04,-.222379E-06,0.378655E-02,0.137242E-02,0.178902E-07, |
| 23609 | &0.138124E-05,0.244675E-07,0.178902E-07,0.426626E-04,-.181158E-06, |
| 23610 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ |
| 23611 | DATA (DL(K),K= 3486, 3570) / |
| 23612 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23613 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23614 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23615 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23616 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23617 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23618 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23619 | &0.286141E-01,0.102357E-01,0.105702E-05,0.105702E-05,0.105702E-05, |
| 23620 | &0.105702E-05,0.963318E-04,0.591070E-18,0.236608E-01,0.827483E-02, |
| 23621 | &0.548552E-06,0.163293E-05,0.551993E-06,0.548552E-06,0.133058E-03, |
| 23622 | &-.268677E-06,0.195282E-01,0.668247E-02,0.238780E-06,0.183459E-05, |
| 23623 | &0.243802E-06,0.238780E-06,0.135119E-03,-.393414E-06,0.160742E-01, |
| 23624 | &0.538444E-02,0.599864E-07,0.183277E-05,0.655085E-07,0.599864E-07, |
| 23625 | &0.124554E-03,-.428349E-06,0.131940E-01,0.432750E-02,-.392825E-07, |
| 23626 | &0.172071E-05,-.338391E-07,-.392825E-07,0.111121E-03,-.415550E-06, |
| 23627 | &0.107996E-01,0.346954E-02,-.875089E-07,0.154604E-05,-.824926E-07, |
| 23628 | &-.875089E-07,0.941854E-04,-.376855E-06,0.881435E-02,0.277463E-02/ |
| 23629 | DATA (DL(K),K= 3571, 3655) / |
| 23630 | &-.103962E-06,0.135013E-05,-.995446E-07,-.103962E-06,0.772195E-04, |
| 23631 | &-.326008E-06,0.717317E-02,0.221313E-02,-.102844E-06,0.115335E-05, |
| 23632 | &-.990733E-07,-.102844E-06,0.626565E-04,-.272858E-06,0.582050E-02, |
| 23633 | &0.176061E-02,-.929503E-07,0.967229E-06,-.898064E-07,-.929503E-07, |
| 23634 | &0.499930E-04,-.222828E-06,0.470908E-02,0.139692E-02,-.791495E-07, |
| 23635 | &0.800414E-06,-.765797E-07,-.791495E-07,0.394181E-04,-.178141E-06, |
| 23636 | &0.379875E-02,0.110542E-02,-.647230E-07,0.655119E-06,-.626567E-07, |
| 23637 | &-.647230E-07,0.309999E-04,-.140000E-06,0.305549E-02,0.872447E-03, |
| 23638 | &-.515215E-07,0.530834E-06,-.498829E-07,-.515215E-07,0.240354E-04, |
| 23639 | &-.108633E-06,0.245058E-02,0.686769E-03,-.400234E-07,0.426835E-06, |
| 23640 | &-.387401E-07,-.400234E-07,0.184613E-04,-.832544E-07,0.195984E-02, |
| 23641 | &0.539209E-03,-.304312E-07,0.341169E-06,-.294373E-07,-.304312E-07, |
| 23642 | &0.143512E-04,-.630818E-07,0.156297E-02,0.422273E-03,-.228633E-07, |
| 23643 | &0.271199E-06,-.221014E-07,-.228633E-07,0.110898E-04,-.474683E-07, |
| 23644 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23645 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23646 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ |
| 23647 | DATA (DL(K),K= 3656, 3740) / |
| 23648 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23649 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23650 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23651 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23652 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23653 | &0.129345E-01,0.308444E-02,0.903693E-07,0.903693E-07,0.903693E-07, |
| 23654 | &0.903693E-07,0.123538E-04,-.166230E-18,0.103598E-01,0.241354E-02, |
| 23655 | &0.155648E-06,-.205296E-06,0.154889E-06,0.155648E-06,0.267249E-04, |
| 23656 | &0.880707E-07,0.828507E-02,0.188764E-02,0.176333E-06,-.341498E-06, |
| 23657 | &0.175220E-06,0.176333E-06,0.306432E-04,0.125718E-06,0.660736E-02, |
| 23658 | &0.147304E-02,0.173444E-06,-.383695E-06,0.172215E-06,0.173444E-06, |
| 23659 | &0.280787E-04,0.135578E-06,0.525320E-02,0.114618E-02,0.158651E-06, |
| 23660 | &-.373371E-06,0.157437E-06,0.158651E-06,0.243526E-04,0.130412E-06, |
| 23661 | &0.416429E-02,0.889584E-03,0.137131E-06,-.333468E-06,0.136012E-06, |
| 23662 | &0.137131E-06,0.203463E-04,0.116115E-06,0.329102E-02,0.688580E-03, |
| 23663 | &0.113839E-06,-.280874E-06,0.112853E-06,0.113839E-06,0.161038E-04, |
| 23664 | &0.982305E-07,0.259282E-02,0.531508E-03,0.914374E-07,-.225427E-06/ |
| 23665 | DATA (DL(K),K= 3741, 3825) / |
| 23666 | &0.905971E-07,0.914374E-07,0.125639E-04,0.798741E-07,0.203641E-02, |
| 23667 | &0.409120E-03,0.709595E-07,-.173123E-06,0.702607E-07,0.709595E-07, |
| 23668 | &0.979247E-05,0.624138E-07,0.159441E-02,0.314027E-03,0.532256E-07, |
| 23669 | &-.127272E-06,0.526566E-07,0.532256E-07,0.741899E-05,0.469253E-07, |
| 23670 | &0.124447E-02,0.240357E-03,0.385509E-07,-.888851E-07,0.380956E-07, |
| 23671 | &0.385509E-07,0.554070E-05,0.339174E-07,0.968328E-03,0.183454E-03, |
| 23672 | &0.267272E-07,-.580277E-07,0.263687E-07,0.267272E-07,0.420032E-05, |
| 23673 | &0.233280E-07,0.751159E-03,0.139632E-03,0.174605E-07,-.342016E-07, |
| 23674 | &0.171822E-07,0.174605E-07,0.315522E-05,0.149727E-07,0.580936E-03, |
| 23675 | &0.105986E-03,0.104515E-07,-.164567E-07,0.102383E-07,0.104515E-07, |
| 23676 | &0.230829E-05,0.863527E-08,0.447955E-03,0.802293E-04,0.531954E-08, |
| 23677 | &-.376312E-08,0.515829E-08,0.531954E-08,0.170771E-05,0.399662E-08, |
| 23678 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23679 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23680 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23681 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23682 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ |
| 23683 | DATA (DL(K),K= 3826, 3910) / |
| 23684 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23685 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23686 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23687 | &0.324478E-02,0.386879E-03,0.135983E-08,0.135983E-08,0.135983E-08, |
| 23688 | &0.135983E-08,0.371787E-06,-.274599E-19,0.246219E-02,0.286505E-03, |
| 23689 | &-.106852E-06,0.327611E-06,-.106589E-06,-.106852E-06,0.231631E-05, |
| 23690 | &-.107814E-06,0.186777E-02,0.212413E-03,-.161566E-06,0.492001E-06, |
| 23691 | &-.161179E-06,-.161566E-06,0.311589E-05,-.162249E-06,0.141322E-02, |
| 23692 | &0.157212E-03,-.183398E-06,0.557106E-06,-.182972E-06,-.183398E-06, |
| 23693 | &0.267943E-05,-.183884E-06,0.106518E-02,0.115892E-03,-.185231E-06, |
| 23694 | &0.562185E-06,-.184809E-06,-.185231E-06,0.203027E-05,-.185573E-06, |
| 23695 | &0.800350E-03,0.851995E-04,-.174680E-06,0.530096E-06,-.174290E-06, |
| 23696 | &-.174680E-06,0.165870E-05,-.174922E-06,0.599444E-03,0.624676E-04, |
| 23697 | &-.157644E-06,0.478420E-06,-.157300E-06,-.157644E-06,0.130112E-05, |
| 23698 | &-.157815E-06,0.447433E-03,0.456556E-04,-.137838E-06,0.418429E-06, |
| 23699 | &-.137543E-06,-.137838E-06,0.903220E-06,-.137958E-06,0.332836E-03, |
| 23700 | &0.332643E-04,-.117616E-06,0.357179E-06,-.117368E-06,-.117616E-06/ |
| 23701 | DATA (DL(K),K= 3911, 3995) / |
| 23702 | &0.636187E-06,-.117699E-06,0.246754E-03,0.241622E-04,-.984560E-07, |
| 23703 | &0.299077E-06,-.982529E-07,-.984560E-07,0.481221E-06,-.985144E-07, |
| 23704 | &0.182315E-03,0.174961E-04,-.811089E-07,0.246465E-06,-.809446E-07, |
| 23705 | &-.811089E-07,0.342859E-06,-.811495E-07,0.134250E-03,0.126299E-04, |
| 23706 | &-.659052E-07,0.200354E-06,-.657742E-07,-.659052E-07,0.227840E-06, |
| 23707 | &-.659334E-07,0.985288E-04,0.908931E-05,-.529252E-07,0.160947E-06, |
| 23708 | &-.528218E-07,-.529252E-07,0.161641E-06,-.529447E-07,0.720750E-04, |
| 23709 | &0.652153E-05,-.420621E-07,0.127943E-06,-.419814E-07,-.420621E-07, |
| 23710 | &0.119540E-06,-.420756E-07,0.525538E-04,0.466527E-05,-.331141E-07, |
| 23711 | &0.100758E-06,-.330516E-07,-.331141E-07,0.808991E-07,-.331233E-07, |
| 23712 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23713 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23714 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23715 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23716 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23717 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23718 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ |
| 23719 | DATA (DL(K),K= 3996, 4000) / |
| 23720 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ |
| 23721 | C |
| 23722 | ANS = 0. |
| 23723 | IF (X.GT.0.9985) RETURN |
| 23724 | IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN |
| 23725 | C |
| 23726 | IS = S/DELTA+1 |
| 23727 | IS1 = IS+1 |
| 23728 | DO 1 L=1,25 |
| 23729 | KL = L+NDRV*25 |
| 23730 | F1(L) = GF(I,IS,KL) |
| 23731 | F2(L) = GF(I,IS1,KL) |
| 23732 | 1 CONTINUE |
| 23733 | A1 = DT_CKMTFF(X,F1) |
| 23734 | A2 = DT_CKMTFF(X,F2) |
| 23735 | C A1=ALOG(A1) |
| 23736 | C A2=ALOG(A2) |
| 23737 | S1 = (IS-1)*DELTA |
| 23738 | S2 = S1+DELTA |
| 23739 | ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1) |
| 23740 | C ANS=EXP(ANS) |
| 23741 | RETURN |
| 23742 | END |
| 23743 | C |
| 23744 | C |
| 23745 | |
| 23746 | *$ CREATE DT_CKMTPR.FOR |
| 23747 | *COPY DT_CKMTPR |
| 23748 | SUBROUTINE DT_CKMTPR(I,NDRV,X,S,ANS) |
| 23749 | C |
| 23750 | C********************************************************************** |
| 23751 | C Proton - PDFs |
| 23752 | C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc |
| 23753 | C ANS = PDF(I) |
| 23754 | C This version by S. Roesler, 31.01.96 |
| 23755 | C********************************************************************** |
| 23756 | |
| 23757 | SAVE |
| 23758 | DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000) |
| 23759 | EQUIVALENCE (GF(1,1,1),DL(1)) |
| 23760 | DATA DELTA/.10/ |
| 23761 | C |
| 23762 | DATA (DL(K),K= 1, 85) / |
| 23763 | &0.367759E+00,0.350609E+00,0.325356E+00,0.325356E+00,0.325356E+00, |
| 23764 | &0.325356E+00,0.533117E+01,0.138778E-16,0.427988E+00,0.409718E+00, |
| 23765 | &0.382948E+00,0.382920E+00,0.382933E+00,0.382948E+00,0.686279E+01, |
| 23766 | &0.611113E-01,0.494752E+00,0.475328E+00,0.447011E+00,0.446959E+00, |
| 23767 | &0.446984E+00,0.447011E+00,0.855688E+01,0.128659E+00,0.568248E+00, |
| 23768 | &0.547637E+00,0.517743E+00,0.517671E+00,0.517705E+00,0.517743E+00, |
| 23769 | &0.104074E+02,0.202846E+00,0.648622E+00,0.626792E+00,0.595289E+00, |
| 23770 | &0.595201E+00,0.595244E+00,0.595289E+00,0.124065E+02,0.283819E+00, |
| 23771 | &0.735974E+00,0.712890E+00,0.679748E+00,0.679648E+00,0.679696E+00, |
| 23772 | &0.679748E+00,0.145441E+02,0.371679E+00,0.830359E+00,0.805987E+00, |
| 23773 | &0.771173E+00,0.771066E+00,0.771119E+00,0.771173E+00,0.168081E+02, |
| 23774 | &0.466485E+00,0.931778E+00,0.906084E+00,0.869566E+00,0.869456E+00, |
| 23775 | &0.869511E+00,0.869566E+00,0.191850E+02,0.568240E+00,0.104018E+01, |
| 23776 | &0.101313E+01,0.974873E+00,0.974763E+00,0.974819E+00,0.974873E+00, |
| 23777 | &0.216593E+02,0.676890E+00,0.115544E+01,0.112700E+01,0.108698E+01, |
| 23778 | &0.108687E+01,0.108693E+01,0.108698E+01,0.242146E+02,0.792321E+00, |
| 23779 | &0.127738E+01,0.124751E+01,0.120570E+01,0.120560E+01,0.120565E+01/ |
| 23780 | DATA (DL(K),K= 86, 170) / |
| 23781 | &0.120570E+01,0.268333E+02,0.914356E+00,0.140577E+01,0.137444E+01, |
| 23782 | &0.133079E+01,0.133070E+01,0.133075E+01,0.133079E+01,0.294970E+02, |
| 23783 | &0.104275E+01,0.154028E+01,0.150745E+01,0.146194E+01,0.146187E+01, |
| 23784 | &0.146192E+01,0.146194E+01,0.321867E+02,0.117720E+01,0.168054E+01, |
| 23785 | &0.164619E+01,0.159879E+01,0.159874E+01,0.159877E+01,0.159879E+01, |
| 23786 | &0.348836E+02,0.131732E+01,0.182613E+01,0.179020E+01,0.174088E+01, |
| 23787 | &0.174086E+01,0.174088E+01,0.174088E+01,0.375685E+02,0.146269E+01, |
| 23788 | &0.197653E+01,0.193901E+01,0.188774E+01,0.188774E+01,0.188775E+01, |
| 23789 | &0.188774E+01,0.402228E+02,0.161282E+01,0.213121E+01,0.209205E+01, |
| 23790 | &0.203880E+01,0.203884E+01,0.203884E+01,0.203880E+01,0.428285E+02, |
| 23791 | &0.176714E+01,0.228955E+01,0.224873E+01,0.219348E+01,0.219355E+01, |
| 23792 | &0.219353E+01,0.219348E+01,0.453682E+02,0.192507E+01,0.245093E+01, |
| 23793 | &0.240840E+01,0.235113E+01,0.235123E+01,0.235120E+01,0.235113E+01, |
| 23794 | &0.478258E+02,0.208597E+01,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23795 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23796 | &0.349839E+00,0.324128E+00,0.286363E+00,0.286363E+00,0.286363E+00, |
| 23797 | &0.286363E+00,0.469694E+01,0.000000E+00,0.398361E+00,0.371065E+00/ |
| 23798 | DATA (DL(K),K= 171, 255) / |
| 23799 | &0.331239E+00,0.331213E+00,0.331227E+00,0.331239E+00,0.586152E+01, |
| 23800 | &0.481683E-01,0.451010E+00,0.422096E+00,0.380182E+00,0.380137E+00, |
| 23801 | &0.380161E+00,0.380182E+00,0.711349E+01,0.100378E+00,0.507782E+00, |
| 23802 | &0.477215E+00,0.433187E+00,0.433128E+00,0.433160E+00,0.433187E+00, |
| 23803 | &0.844371E+01,0.156627E+00,0.568644E+00,0.536390E+00,0.490220E+00, |
| 23804 | &0.490152E+00,0.490190E+00,0.490220E+00,0.984291E+01,0.216886E+00, |
| 23805 | &0.633517E+00,0.599543E+00,0.551204E+00,0.551133E+00,0.551174E+00, |
| 23806 | &0.551204E+00,0.113005E+02,0.281079E+00,0.702295E+00,0.666565E+00, |
| 23807 | &0.616031E+00,0.615963E+00,0.616004E+00,0.616031E+00,0.128050E+02, |
| 23808 | &0.349101E+00,0.774832E+00,0.737311E+00,0.684556E+00,0.684495E+00, |
| 23809 | &0.684535E+00,0.684556E+00,0.143447E+02,0.420809E+00,0.850945E+00, |
| 23810 | &0.811598E+00,0.756596E+00,0.756547E+00,0.756583E+00,0.756596E+00, |
| 23811 | &0.159073E+02,0.496022E+00,0.930413E+00,0.889207E+00,0.831933E+00, |
| 23812 | &0.831901E+00,0.831931E+00,0.831933E+00,0.174801E+02,0.574524E+00, |
| 23813 | &0.101298E+01,0.969882E+00,0.910312E+00,0.910301E+00,0.910324E+00, |
| 23814 | &0.910312E+00,0.190508E+02,0.656061E+00,0.109836E+01,0.105333E+01, |
| 23815 | &0.991445E+00,0.991459E+00,0.991471E+00,0.991445E+00,0.206070E+02/ |
| 23816 | DATA (DL(K),K= 256, 340) / |
| 23817 | &0.740345E+00,0.118622E+01,0.113923E+01,0.107501E+01,0.107505E+01, |
| 23818 | &0.107505E+01,0.107501E+01,0.221368E+02,0.827056E+00,0.127622E+01, |
| 23819 | &0.122724E+01,0.116065E+01,0.116073E+01,0.116072E+01,0.116065E+01, |
| 23820 | &0.236287E+02,0.915845E+00,0.136797E+01,0.131696E+01,0.124800E+01, |
| 23821 | &0.124812E+01,0.124809E+01,0.124800E+01,0.250721E+02,0.100634E+01, |
| 23822 | &0.146107E+01,0.140801E+01,0.133666E+01,0.133681E+01,0.133677E+01, |
| 23823 | &0.133666E+01,0.264571E+02,0.109813E+01,0.155511E+01,0.149996E+01, |
| 23824 | &0.142621E+01,0.142641E+01,0.142634E+01,0.142621E+01,0.277747E+02, |
| 23825 | &0.119081E+01,0.164964E+01,0.159239E+01,0.151622E+01,0.151646E+01, |
| 23826 | &0.151638E+01,0.151622E+01,0.290168E+02,0.128396E+01,0.174424E+01, |
| 23827 | &0.168485E+01,0.160626E+01,0.160655E+01,0.160645E+01,0.160626E+01, |
| 23828 | &0.301765E+02,0.137713E+01,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23829 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23830 | &0.345345E+00,0.306823E+00,0.250518E+00,0.250518E+00,0.250518E+00, |
| 23831 | &0.250518E+00,0.411726E+01,-.138778E-16,0.384210E+00,0.343514E+00, |
| 23832 | &0.284500E+00,0.284487E+00,0.284496E+00,0.284500E+00,0.496835E+01, |
| 23833 | &0.371582E-01,0.425419E+00,0.382518E+00,0.320782E+00,0.320762E+00/ |
| 23834 | DATA (DL(K),K= 341, 425) / |
| 23835 | &0.320777E+00,0.320782E+00,0.585504E+01,0.765988E-01,0.468853E+00, |
| 23836 | &0.423717E+00,0.359246E+00,0.359226E+00,0.359243E+00,0.359246E+00, |
| 23837 | &0.676824E+01,0.118207E+00,0.514392E+00,0.466990E+00,0.399771E+00, |
| 23838 | &0.399758E+00,0.399775E+00,0.399771E+00,0.769967E+01,0.161865E+00, |
| 23839 | &0.561883E+00,0.512186E+00,0.442209E+00,0.442208E+00,0.442222E+00, |
| 23840 | &0.442209E+00,0.864071E+01,0.207426E+00,0.611162E+00,0.559140E+00, |
| 23841 | &0.486395E+00,0.486411E+00,0.486420E+00,0.486395E+00,0.958280E+01, |
| 23842 | &0.254727E+00,0.662044E+00,0.607667E+00,0.532145E+00,0.532185E+00, |
| 23843 | &0.532185E+00,0.532145E+00,0.105176E+02,0.303587E+00,0.714325E+00, |
| 23844 | &0.657566E+00,0.579261E+00,0.579328E+00,0.579318E+00,0.579261E+00, |
| 23845 | &0.114370E+02,0.353808E+00,0.767786E+00,0.708618E+00,0.627526E+00, |
| 23846 | &0.627625E+00,0.627603E+00,0.627526E+00,0.123333E+02,0.405174E+00, |
| 23847 | &0.822195E+00,0.760591E+00,0.676711E+00,0.676846E+00,0.676810E+00, |
| 23848 | &0.676711E+00,0.131994E+02,0.457458E+00,0.877307E+00,0.813242E+00, |
| 23849 | &0.726575E+00,0.726750E+00,0.726697E+00,0.726575E+00,0.140286E+02, |
| 23850 | &0.510420E+00,0.932865E+00,0.866317E+00,0.776867E+00,0.777085E+00, |
| 23851 | &0.777015E+00,0.776867E+00,0.148150E+02,0.563809E+00,0.988608E+00/ |
| 23852 | DATA (DL(K),K= 426, 510) / |
| 23853 | &0.919556E+00,0.827330E+00,0.827594E+00,0.827505E+00,0.827330E+00, |
| 23854 | &0.155533E+02,0.617368E+00,0.104427E+01,0.972694E+00,0.877703E+00, |
| 23855 | &0.878016E+00,0.877907E+00,0.877703E+00,0.162391E+02,0.670837E+00, |
| 23856 | &0.109958E+01,0.102547E+01,0.927723E+00,0.928088E+00,0.927957E+00, |
| 23857 | &0.927723E+00,0.168687E+02,0.723954E+00,0.115428E+01,0.107761E+01, |
| 23858 | &0.977132E+00,0.977550E+00,0.977397E+00,0.977132E+00,0.174391E+02, |
| 23859 | &0.776458E+00,0.120809E+01,0.112886E+01,0.102567E+01,0.102615E+01, |
| 23860 | &0.102597E+01,0.102567E+01,0.179481E+02,0.828097E+00,0.126078E+01, |
| 23861 | &0.117898E+01,0.107310E+01,0.107363E+01,0.107343E+01,0.107310E+01, |
| 23862 | &0.183942E+02,0.878621E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23863 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23864 | &0.357586E+00,0.299938E+00,0.216504E+00,0.216504E+00,0.216504E+00, |
| 23865 | &0.216504E+00,0.357260E+01,-.277556E-16,0.388529E+00,0.327984E+00, |
| 23866 | &0.241161E+00,0.241168E+00,0.241168E+00,0.241161E+00,0.415893E+01, |
| 23867 | &0.278429E-01,0.420472E+00,0.357015E+00,0.266823E+00,0.266844E+00, |
| 23868 | &0.266842E+00,0.266823E+00,0.474689E+01,0.566783E-01,0.453271E+00, |
| 23869 | &0.386886E+00,0.293349E+00,0.293389E+00,0.293381E+00,0.293349E+00/ |
| 23870 | DATA (DL(K),K= 511, 595) / |
| 23871 | &0.532982E+01,0.863668E-01,0.486793E+00,0.417464E+00,0.320608E+00, |
| 23872 | &0.320673E+00,0.320657E+00,0.320608E+00,0.590219E+01,0.116779E+00, |
| 23873 | &0.520887E+00,0.448601E+00,0.348454E+00,0.348549E+00,0.348523E+00, |
| 23874 | &0.348454E+00,0.645868E+01,0.147773E+00,0.555403E+00,0.480149E+00, |
| 23875 | &0.376740E+00,0.376870E+00,0.376831E+00,0.376740E+00,0.699440E+01, |
| 23876 | &0.179201E+00,0.590183E+00,0.511950E+00,0.405314E+00,0.405482E+00, |
| 23877 | &0.405429E+00,0.405314E+00,0.750493E+01,0.210912E+00,0.625064E+00, |
| 23878 | &0.543845E+00,0.434019E+00,0.434229E+00,0.434159E+00,0.434019E+00, |
| 23879 | &0.798636E+01,0.242750E+00,0.659882E+00,0.575673E+00,0.462696E+00, |
| 23880 | &0.462952E+00,0.462864E+00,0.462696E+00,0.843528E+01,0.274558E+00, |
| 23881 | &0.694472E+00,0.607271E+00,0.491188E+00,0.491492E+00,0.491385E+00, |
| 23882 | &0.491188E+00,0.884885E+01,0.306178E+00,0.728669E+00,0.638478E+00, |
| 23883 | &0.519337E+00,0.519690E+00,0.519563E+00,0.519337E+00,0.922480E+01, |
| 23884 | &0.337451E+00,0.762311E+00,0.669133E+00,0.546987E+00,0.547392E+00, |
| 23885 | &0.547244E+00,0.546987E+00,0.956139E+01,0.368224E+00,0.795240E+00, |
| 23886 | &0.699084E+00,0.573988E+00,0.574447E+00,0.574277E+00,0.573988E+00, |
| 23887 | &0.985744E+01,0.398346E+00,0.827302E+00,0.728181E+00,0.600196E+00/ |
| 23888 | DATA (DL(K),K= 596, 680) / |
| 23889 | &0.600710E+00,0.600518E+00,0.600196E+00,0.101123E+02,0.427671E+00, |
| 23890 | &0.858354E+00,0.756282E+00,0.625475E+00,0.626044E+00,0.625829E+00, |
| 23891 | &0.625475E+00,0.103258E+02,0.456064E+00,0.888257E+00,0.783256E+00, |
| 23892 | &0.649696E+00,0.650321E+00,0.650083E+00,0.649696E+00,0.104982E+02, |
| 23893 | &0.483395E+00,0.916887E+00,0.808981E+00,0.672742E+00,0.673422E+00, |
| 23894 | &0.673161E+00,0.672742E+00,0.106303E+02,0.509546E+00,0.944126E+00, |
| 23895 | &0.833345E+00,0.694506E+00,0.695243E+00,0.694958E+00,0.694506E+00, |
| 23896 | &0.107231E+02,0.534410E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23897 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23898 | &0.390721E+00,0.304671E+00,0.182562E+00,0.182562E+00,0.182562E+00, |
| 23899 | &0.182562E+00,0.303699E+01,0.693889E-17,0.414806E+00,0.325059E+00, |
| 23900 | &0.199103E+00,0.199133E+00,0.199124E+00,0.199103E+00,0.339971E+01, |
| 23901 | &0.198528E-01,0.438929E+00,0.345508E+00,0.215797E+00,0.215862E+00, |
| 23902 | &0.215842E+00,0.215797E+00,0.374624E+01,0.398420E-01,0.462973E+00, |
| 23903 | &0.365903E+00,0.232531E+00,0.232635E+00,0.232601E+00,0.232531E+00, |
| 23904 | &0.407322E+01,0.598565E-01,0.486835E+00,0.386142E+00,0.249208E+00, |
| 23905 | &0.249352E+00,0.249304E+00,0.249208E+00,0.437817E+01,0.797987E-01/ |
| 23906 | DATA (DL(K),K= 681, 765) / |
| 23907 | &0.510407E+00,0.406123E+00,0.265725E+00,0.265913E+00,0.265849E+00, |
| 23908 | &0.265725E+00,0.465901E+01,0.995694E-01,0.533588E+00,0.425746E+00, |
| 23909 | &0.281986E+00,0.282220E+00,0.282139E+00,0.281986E+00,0.491410E+01, |
| 23910 | &0.119072E+00,0.556274E+00,0.444912E+00,0.297897E+00,0.298178E+00, |
| 23911 | &0.298079E+00,0.297897E+00,0.514220E+01,0.138212E+00,0.578369E+00, |
| 23912 | &0.463528E+00,0.313366E+00,0.313696E+00,0.313578E+00,0.313366E+00, |
| 23913 | &0.534249E+01,0.156900E+00,0.599777E+00,0.481503E+00,0.328308E+00, |
| 23914 | &0.328688E+00,0.328549E+00,0.328308E+00,0.551456E+01,0.175048E+00, |
| 23915 | &0.620409E+00,0.498752E+00,0.342642E+00,0.343071E+00,0.342913E+00, |
| 23916 | &0.342642E+00,0.565833E+01,0.192575E+00,0.640181E+00,0.515196E+00, |
| 23917 | &0.356292E+00,0.356770E+00,0.356592E+00,0.356292E+00,0.577410E+01, |
| 23918 | &0.209407E+00,0.659017E+00,0.530764E+00,0.369190E+00,0.369718E+00, |
| 23919 | &0.369519E+00,0.369190E+00,0.586243E+01,0.225474E+00,0.676845E+00, |
| 23920 | &0.545389E+00,0.381275E+00,0.381852E+00,0.381633E+00,0.381275E+00, |
| 23921 | &0.592421E+01,0.240714E+00,0.693604E+00,0.559015E+00,0.392493E+00, |
| 23922 | &0.393118E+00,0.392880E+00,0.392493E+00,0.596052E+01,0.255072E+00, |
| 23923 | &0.709239E+00,0.571593E+00,0.402799E+00,0.403472E+00,0.403213E+00/ |
| 23924 | DATA (DL(K),K= 766, 850) / |
| 23925 | &0.402799E+00,0.597267E+01,0.268502E+00,0.723703E+00,0.583081E+00, |
| 23926 | &0.412157E+00,0.412875E+00,0.412597E+00,0.412157E+00,0.596211E+01, |
| 23927 | &0.280966E+00,0.736960E+00,0.593447E+00,0.420536E+00,0.421299E+00, |
| 23928 | &0.421002E+00,0.420536E+00,0.593045E+01,0.292434E+00,0.748980E+00, |
| 23929 | &0.602669E+00,0.427918E+00,0.428723E+00,0.428408E+00,0.427918E+00, |
| 23930 | &0.587934E+01,0.302884E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23931 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23932 | &0.448390E+00,0.320678E+00,0.146415E+00,0.146415E+00,0.146415E+00, |
| 23933 | &0.146415E+00,0.247594E+01,0.000000E+00,0.465760E+00,0.333734E+00, |
| 23934 | &0.155974E+00,0.156013E+00,0.156000E+00,0.155974E+00,0.265633E+01, |
| 23935 | &0.130329E-01,0.482525E+00,0.346293E+00,0.165233E+00,0.165311E+00, |
| 23936 | &0.165285E+00,0.165233E+00,0.281612E+01,0.257304E-01,0.498626E+00, |
| 23937 | &0.358294E+00,0.174131E+00,0.174249E+00,0.174209E+00,0.174131E+00, |
| 23938 | &0.295484E+01,0.380345E-01,0.514008E+00,0.369688E+00,0.182622E+00, |
| 23939 | &0.182779E+00,0.182724E+00,0.182622E+00,0.307242E+01,0.498976E-01, |
| 23940 | &0.528624E+00,0.380432E+00,0.190660E+00,0.190856E+00,0.190786E+00, |
| 23941 | &0.190660E+00,0.316911E+01,0.612760E-01,0.542428E+00,0.390485E+00/ |
| 23942 | DATA (DL(K),K= 851, 935) / |
| 23943 | &0.198205E+00,0.198441E+00,0.198356E+00,0.198205E+00,0.324538E+01, |
| 23944 | &0.721303E-01,0.555382E+00,0.399810E+00,0.205224E+00,0.205498E+00, |
| 23945 | &0.205398E+00,0.205224E+00,0.330192E+01,0.824256E-01,0.567448E+00, |
| 23946 | &0.408377E+00,0.211687E+00,0.211997E+00,0.211882E+00,0.211687E+00, |
| 23947 | &0.333960E+01,0.921319E-01,0.578597E+00,0.416159E+00,0.217568E+00, |
| 23948 | &0.217915E+00,0.217784E+00,0.217568E+00,0.335945E+01,0.101224E+00, |
| 23949 | &0.588802E+00,0.423136E+00,0.222847E+00,0.223229E+00,0.223084E+00, |
| 23950 | &0.222847E+00,0.336262E+01,0.109681E+00,0.598043E+00,0.429293E+00, |
| 23951 | &0.227512E+00,0.227928E+00,0.227768E+00,0.227512E+00,0.335036E+01, |
| 23952 | &0.117489E+00,0.606305E+00,0.434619E+00,0.231551E+00,0.232000E+00, |
| 23953 | &0.231826E+00,0.231551E+00,0.332398E+01,0.124636E+00,0.613579E+00, |
| 23954 | &0.439110E+00,0.234962E+00,0.235442E+00,0.235254E+00,0.234962E+00, |
| 23955 | &0.328483E+01,0.131119E+00,0.619860E+00,0.442766E+00,0.237745E+00, |
| 23956 | &0.238254E+00,0.238053E+00,0.237745E+00,0.323429E+01,0.136936E+00, |
| 23957 | &0.625150E+00,0.445594E+00,0.239905E+00,0.240441E+00,0.240228E+00, |
| 23958 | &0.239905E+00,0.317371E+01,0.142091E+00,0.629453E+00,0.447603E+00, |
| 23959 | &0.241452E+00,0.242014E+00,0.241788E+00,0.241452E+00,0.310443E+01/ |
| 23960 | DATA (DL(K),K= 936, 1020) / |
| 23961 | &0.146594E+00,0.632782E+00,0.448808E+00,0.242400E+00,0.242987E+00, |
| 23962 | &0.242749E+00,0.242400E+00,0.302775E+01,0.150456E+00,0.635151E+00, |
| 23963 | &0.449228E+00,0.242767E+00,0.243376E+00,0.243127E+00,0.242767E+00, |
| 23964 | &0.294491E+01,0.153694E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23965 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23966 | &0.528765E+00,0.341825E+00,0.105823E+00,0.105823E+00,0.105823E+00, |
| 23967 | &0.105823E+00,0.185069E+01,-.138778E-16,0.538124E+00,0.347118E+00, |
| 23968 | &0.109762E+00,0.109780E+00,0.109774E+00,0.109762E+00,0.189644E+01, |
| 23969 | &0.738880E-02,0.546541E+00,0.351712E+00,0.113300E+00,0.113336E+00, |
| 23970 | &0.113324E+00,0.113300E+00,0.192700E+01,0.143076E-01,0.554014E+00, |
| 23971 | &0.355607E+00,0.116431E+00,0.116485E+00,0.116466E+00,0.116431E+00, |
| 23972 | &0.194356E+01,0.207515E-01,0.560546E+00,0.358805E+00,0.119150E+00, |
| 23973 | &0.119222E+00,0.119196E+00,0.119150E+00,0.194722E+01,0.267179E-01, |
| 23974 | &0.566139E+00,0.361311E+00,0.121459E+00,0.121549E+00,0.121515E+00, |
| 23975 | &0.121459E+00,0.193921E+01,0.322084E-01,0.570802E+00,0.363134E+00, |
| 23976 | &0.123359E+00,0.123467E+00,0.123426E+00,0.123359E+00,0.192071E+01, |
| 23977 | &0.372262E-01,0.574542E+00,0.364286E+00,0.124858E+00,0.124983E+00/ |
| 23978 | DATA (DL(K),K= 1021, 1105) / |
| 23979 | &0.124933E+00,0.124858E+00,0.189295E+01,0.417774E-01,0.577372E+00, |
| 23980 | &0.364779E+00,0.125961E+00,0.126103E+00,0.126046E+00,0.125961E+00, |
| 23981 | &0.185710E+01,0.458703E-01,0.579307E+00,0.364629E+00,0.126681E+00, |
| 23982 | &0.126839E+00,0.126774E+00,0.126681E+00,0.181432E+01,0.495154E-01, |
| 23983 | &0.580363E+00,0.363857E+00,0.127029E+00,0.127202E+00,0.127130E+00, |
| 23984 | &0.127029E+00,0.176571E+01,0.527252E-01,0.580561E+00,0.362483E+00, |
| 23985 | &0.127020E+00,0.127208E+00,0.127128E+00,0.127020E+00,0.171231E+01, |
| 23986 | &0.555142E-01,0.579923E+00,0.360529E+00,0.126670E+00,0.126872E+00, |
| 23987 | &0.126785E+00,0.126670E+00,0.165511E+01,0.578985E-01,0.578474E+00, |
| 23988 | &0.358021E+00,0.125998E+00,0.126213E+00,0.126119E+00,0.125998E+00, |
| 23989 | &0.159501E+01,0.598958E-01,0.576241E+00,0.354987E+00,0.125022E+00, |
| 23990 | &0.125249E+00,0.125148E+00,0.125022E+00,0.153284E+01,0.615248E-01, |
| 23991 | &0.573252E+00,0.351453E+00,0.123762E+00,0.124000E+00,0.123893E+00, |
| 23992 | &0.123762E+00,0.146934E+01,0.628056E-01,0.569539E+00,0.347450E+00, |
| 23993 | &0.122240E+00,0.122488E+00,0.122375E+00,0.122240E+00,0.140517E+01, |
| 23994 | &0.637587E-01,0.565134E+00,0.343008E+00,0.120476E+00,0.120733E+00, |
| 23995 | &0.120615E+00,0.120476E+00,0.134093E+01,0.644054E-01,0.560071E+00/ |
| 23996 | DATA (DL(K),K= 1106, 1190) / |
| 23997 | &0.338158E+00,0.118493E+00,0.118758E+00,0.118635E+00,0.118493E+00, |
| 23998 | &0.127712E+01,0.647671E-01,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23999 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 24000 | &0.584093E+00,0.349173E+00,0.772117E-01,0.772117E-01,0.772117E-01, |
| 24001 | &0.772117E-01,0.140433E+01,0.346945E-17,0.586736E+00,0.349017E+00, |
| 24002 | &0.785355E-01,0.785519E-01,0.785448E-01,0.785355E-01,0.139434E+01, |
| 24003 | &0.447504E-02,0.588402E+00,0.348237E+00,0.795437E-01,0.795759E-01, |
| 24004 | &0.795617E-01,0.795437E-01,0.137550E+01,0.854114E-02,0.589124E+00, |
| 24005 | &0.346861E+00,0.802498E-01,0.802970E-01,0.802758E-01,0.802498E-01, |
| 24006 | &0.134918E+01,0.122148E-01,0.588930E+00,0.344912E+00,0.806656E-01, |
| 24007 | &0.807271E-01,0.806990E-01,0.806656E-01,0.131652E+01,0.155101E-01, |
| 24008 | &0.587849E+00,0.342417E+00,0.808055E-01,0.808805E-01,0.808457E-01, |
| 24009 | &0.808055E-01,0.127862E+01,0.184435E-01,0.585912E+00,0.339402E+00, |
| 24010 | &0.806843E-01,0.807718E-01,0.807306E-01,0.806843E-01,0.123648E+01, |
| 24011 | &0.210315E-01,0.583151E+00,0.335894E+00,0.803173E-01,0.804166E-01, |
| 24012 | &0.803692E-01,0.803173E-01,0.119104E+01,0.232909E-01,0.579599E+00, |
| 24013 | &0.331923E+00,0.797205E-01,0.798308E-01,0.797775E-01,0.797205E-01/ |
| 24014 | DATA (DL(K),K= 1191, 1275) / |
| 24015 | &0.114317E+01,0.252394E-01,0.575288E+00,0.327516E+00,0.789107E-01, |
| 24016 | &0.790310E-01,0.789721E-01,0.789107E-01,0.109362E+01,0.268946E-01, |
| 24017 | &0.570253E+00,0.322704E+00,0.779045E-01,0.780341E-01,0.779698E-01, |
| 24018 | &0.779045E-01,0.104307E+01,0.282745E-01,0.564530E+00,0.317515E+00, |
| 24019 | &0.767190E-01,0.768570E-01,0.767878E-01,0.767190E-01,0.992143E+00, |
| 24020 | &0.293974E-01,0.558155E+00,0.311981E+00,0.753713E-01,0.755169E-01, |
| 24021 | &0.754432E-01,0.753713E-01,0.941341E+00,0.302812E-01,0.551166E+00, |
| 24022 | &0.306131E+00,0.738784E-01,0.740308E-01,0.739528E-01,0.738784E-01, |
| 24023 | &0.891113E+00,0.309441E-01,0.543599E+00,0.299995E+00,0.722571E-01, |
| 24024 | &0.724154E-01,0.723336E-01,0.722571E-01,0.841829E+00,0.314037E-01, |
| 24025 | &0.535494E+00,0.293603E+00,0.705237E-01,0.706871E-01,0.706019E-01, |
| 24026 | &0.705237E-01,0.793794E+00,0.316774E-01,0.526888E+00,0.286986E+00, |
| 24027 | &0.686941E-01,0.688619E-01,0.687736E-01,0.686941E-01,0.747249E+00, |
| 24028 | &0.317823E-01,0.517822E+00,0.280172E+00,0.667836E-01,0.669551E-01, |
| 24029 | &0.668640E-01,0.667836E-01,0.702381E+00,0.317346E-01,0.508333E+00, |
| 24030 | &0.273189E+00,0.648068E-01,0.649814E-01,0.648879E-01,0.648068E-01, |
| 24031 | &0.659330E+00,0.315501E-01,0.000000E+00,0.000000E+00,0.000000E+00/ |
| 24032 | DATA (DL(K),K= 1276, 1360) / |
| 24033 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 24034 | &0.622739E+00,0.340676E+00,0.509141E-01,0.509141E-01,0.509141E-01, |
| 24035 | &0.509141E-01,0.980502E+00,-.173472E-17,0.617764E+00,0.335457E+00, |
| 24036 | &0.507607E-01,0.507701E-01,0.507651E-01,0.507607E-01,0.944375E+00, |
| 24037 | &0.242386E-02,0.611957E+00,0.329837E+00,0.504236E-01,0.504417E-01, |
| 24038 | &0.504321E-01,0.504236E-01,0.905225E+00,0.455851E-02,0.605372E+00, |
| 24039 | &0.323853E+00,0.499207E-01,0.499471E-01,0.499328E-01,0.499207E-01, |
| 24040 | &0.864035E+00,0.642656E-02,0.598052E+00,0.317537E+00,0.492668E-01, |
| 24041 | &0.493008E-01,0.492822E-01,0.492668E-01,0.821557E+00,0.804638E-02, |
| 24042 | &0.590044E+00,0.310919E+00,0.484772E-01,0.485183E-01,0.484955E-01, |
| 24043 | &0.484772E-01,0.778444E+00,0.943663E-02,0.581391E+00,0.304033E+00, |
| 24044 | &0.475665E-01,0.476142E-01,0.475874E-01,0.475665E-01,0.735263E+00, |
| 24045 | &0.106150E-01,0.572137E+00,0.296908E+00,0.465487E-01,0.466024E-01, |
| 24046 | &0.465720E-01,0.465487E-01,0.692487E+00,0.115984E-01,0.562326E+00, |
| 24047 | &0.289573E+00,0.454376E-01,0.454968E-01,0.454629E-01,0.454376E-01, |
| 24048 | &0.650510E+00,0.124032E-01,0.552003E+00,0.282060E+00,0.442463E-01, |
| 24049 | &0.443103E-01,0.442733E-01,0.442463E-01,0.609652E+00,0.130451E-01/ |
| 24050 | DATA (DL(K),K= 1361, 1445) / |
| 24051 | &0.541210E+00,0.274395E+00,0.429871E-01,0.430555E-01,0.430156E-01, |
| 24052 | &0.429871E-01,0.570164E+00,0.135389E-01,0.529991E+00,0.266608E+00, |
| 24053 | &0.416720E-01,0.417443E-01,0.417018E-01,0.416720E-01,0.532237E+00, |
| 24054 | &0.138989E-01,0.518389E+00,0.258725E+00,0.403123E-01,0.403879E-01, |
| 24055 | &0.403431E-01,0.403123E-01,0.496010E+00,0.141386E-01,0.506446E+00, |
| 24056 | &0.250772E+00,0.389186E-01,0.389971E-01,0.389501E-01,0.389186E-01, |
| 24057 | &0.461573E+00,0.142708E-01,0.494204E+00,0.242775E+00,0.375006E-01, |
| 24058 | &0.375815E-01,0.375327E-01,0.375006E-01,0.428979E+00,0.143074E-01, |
| 24059 | &0.481705E+00,0.234757E+00,0.360674E-01,0.361503E-01,0.361000E-01, |
| 24060 | &0.360674E-01,0.398246E+00,0.142598E-01,0.468990E+00,0.226741E+00, |
| 24061 | &0.346276E-01,0.347120E-01,0.346605E-01,0.346276E-01,0.369363E+00, |
| 24062 | &0.141385E-01,0.456098E+00,0.218750E+00,0.331887E-01,0.332743E-01, |
| 24063 | &0.332216E-01,0.331887E-01,0.342300E+00,0.139532E-01,0.443068E+00, |
| 24064 | &0.210804E+00,0.317576E-01,0.318440E-01,0.317905E-01,0.317576E-01, |
| 24065 | &0.317005E+00,0.137130E-01,0.000000E+00,0.000000E+00,0.000000E+00, |
| 24066 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 24067 | &0.631458E+00,0.318714E+00,0.335640E-01,0.335640E-01,0.335640E-01/ |
| 24068 | DATA (DL(K),K= 1446, 1530) / |
| 24069 | &0.335640E-01,0.686773E+00,0.346945E-17,0.620274E+00,0.310241E+00, |
| 24070 | &0.329311E-01,0.329377E-01,0.329337E-01,0.329311E-01,0.646559E+00, |
| 24071 | &0.135960E-02,0.608504E+00,0.301610E+00,0.322083E-01,0.322210E-01, |
| 24072 | &0.322133E-01,0.322083E-01,0.606503E+00,0.252820E-02,0.596205E+00, |
| 24073 | &0.292854E+00,0.314099E-01,0.314281E-01,0.314169E-01,0.314099E-01, |
| 24074 | &0.567134E+00,0.352543E-02,0.583429E+00,0.284002E+00,0.305470E-01, |
| 24075 | &0.305704E-01,0.305558E-01,0.305470E-01,0.528824E+00,0.436693E-02, |
| 24076 | &0.570223E+00,0.275080E+00,0.296307E-01,0.296586E-01,0.296411E-01, |
| 24077 | &0.296307E-01,0.491848E+00,0.506768E-02,0.556637E+00,0.266115E+00, |
| 24078 | &0.286709E-01,0.287030E-01,0.286827E-01,0.286709E-01,0.456422E+00, |
| 24079 | &0.564157E-02,0.542717E+00,0.257131E+00,0.276770E-01,0.277128E-01, |
| 24080 | &0.276900E-01,0.276770E-01,0.422697E+00,0.610148E-02,0.528511E+00, |
| 24081 | &0.248154E+00,0.266578E-01,0.266968E-01,0.266718E-01,0.266578E-01, |
| 24082 | &0.390771E+00,0.645942E-02,0.514062E+00,0.239205E+00,0.256210E-01, |
| 24083 | &0.256629E-01,0.256359E-01,0.256210E-01,0.360700E+00,0.672653E-02, |
| 24084 | &0.499417E+00,0.230307E+00,0.245741E-01,0.246185E-01,0.245896E-01, |
| 24085 | &0.245741E-01,0.332498E+00,0.691312E-02,0.484617E+00,0.221480E+00/ |
| 24086 | DATA (DL(K),K= 1531, 1615) / |
| 24087 | &0.235237E-01,0.235701E-01,0.235397E-01,0.235237E-01,0.306153E+00, |
| 24088 | &0.702875E-02,0.469706E+00,0.212745E+00,0.224757E-01,0.225238E-01, |
| 24089 | &0.224921E-01,0.224757E-01,0.281624E+00,0.708222E-02,0.454725E+00, |
| 24090 | &0.204118E+00,0.214355E-01,0.214850E-01,0.214522E-01,0.214355E-01, |
| 24091 | &0.258855E+00,0.708159E-02,0.439713E+00,0.195618E+00,0.204079E-01, |
| 24092 | &0.204586E-01,0.204249E-01,0.204079E-01,0.237774E+00,0.703428E-02, |
| 24093 | &0.424709E+00,0.187259E+00,0.193972E-01,0.194486E-01,0.194142E-01, |
| 24094 | &0.193972E-01,0.218298E+00,0.694702E-02,0.409750E+00,0.179057E+00, |
| 24095 | &0.184069E-01,0.184588E-01,0.184239E-01,0.184069E-01,0.200339E+00, |
| 24096 | &0.682594E-02,0.394870E+00,0.171023E+00,0.174402E-01,0.174924E-01, |
| 24097 | &0.174571E-01,0.174402E-01,0.183804E+00,0.667657E-02,0.380104E+00, |
| 24098 | &0.163171E+00,0.164997E-01,0.165519E-01,0.165164E-01,0.164997E-01, |
| 24099 | &0.168600E+00,0.650389E-02,0.000000E+00,0.000000E+00,0.000000E+00, |
| 24100 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 24101 | &0.619056E+00,0.288873E+00,0.218554E-01,0.218554E-01,0.218554E-01, |
| 24102 | &0.218554E-01,0.477010E+00,-.867362E-17,0.602890E+00,0.278444E+00, |
| 24103 | &0.211480E-01,0.211530E-01,0.211497E-01,0.211480E-01,0.440877E+00/ |
| 24104 | DATA (DL(K),K= 1616, 1700) / |
| 24105 | &0.767466E-03,0.586431E+00,0.268081E+00,0.204081E-01,0.204175E-01, |
| 24106 | &0.204113E-01,0.204081E-01,0.406417E+00,0.141432E-02,0.569736E+00, |
| 24107 | &0.257807E+00,0.196446E-01,0.196581E-01,0.196491E-01,0.196446E-01, |
| 24108 | &0.373808E+00,0.195508E-02,0.552853E+00,0.247642E+00,0.188646E-01, |
| 24109 | &0.188816E-01,0.188701E-01,0.188646E-01,0.343145E+00,0.240123E-02, |
| 24110 | &0.535829E+00,0.237603E+00,0.180743E-01,0.180945E-01,0.180808E-01, |
| 24111 | &0.180743E-01,0.314460E+00,0.276332E-02,0.518710E+00,0.227710E+00, |
| 24112 | &0.172796E-01,0.173025E-01,0.172868E-01,0.172796E-01,0.287750E+00, |
| 24113 | &0.305100E-02,0.501539E+00,0.217977E+00,0.164854E-01,0.165108E-01, |
| 24114 | &0.164933E-01,0.164854E-01,0.262983E+00,0.327305E-02,0.484360E+00, |
| 24115 | &0.208420E+00,0.156964E-01,0.157239E-01,0.157049E-01,0.156964E-01, |
| 24116 | &0.240098E+00,0.343744E-02,0.467213E+00,0.199053E+00,0.149165E-01, |
| 24117 | &0.149457E-01,0.149254E-01,0.149165E-01,0.219021E+00,0.355144E-02, |
| 24118 | &0.450140E+00,0.189889E+00,0.141493E-01,0.141800E-01,0.141586E-01, |
| 24119 | &0.141493E-01,0.199660E+00,0.362164E-02,0.433177E+00,0.180939E+00, |
| 24120 | &0.133978E-01,0.134297E-01,0.134073E-01,0.133978E-01,0.181918E+00, |
| 24121 | &0.365401E-02,0.416362E+00,0.172214E+00,0.126646E-01,0.126974E-01/ |
| 24122 | DATA (DL(K),K= 1701, 1785) / |
| 24123 | &0.126742E-01,0.126646E-01,0.165692E+00,0.365394E-02,0.399729E+00, |
| 24124 | &0.163725E+00,0.119518E-01,0.119853E-01,0.119615E-01,0.119518E-01, |
| 24125 | &0.150875E+00,0.362628E-02,0.383310E+00,0.155477E+00,0.112613E-01, |
| 24126 | &0.112952E-01,0.112711E-01,0.112613E-01,0.137364E+00,0.357539E-02, |
| 24127 | &0.367138E+00,0.147479E+00,0.105945E-01,0.106287E-01,0.106042E-01, |
| 24128 | &0.105945E-01,0.125056E+00,0.350515E-02,0.351239E+00,0.139737E+00, |
| 24129 | &0.995250E-02,0.998673E-02,0.996211E-02,0.995250E-02,0.113852E+00, |
| 24130 | &0.341903E-02,0.335641E+00,0.132253E+00,0.933610E-02,0.937024E-02, |
| 24131 | &0.934557E-02,0.933610E-02,0.103659E+00,0.332009E-02,0.320367E+00, |
| 24132 | &0.125033E+00,0.874584E-02,0.877973E-02,0.875514E-02,0.874584E-02, |
| 24133 | &0.943886E-01,0.321106E-02,0.000000E+00,0.000000E+00,0.000000E+00, |
| 24134 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 24135 | &0.591114E+00,0.254807E+00,0.139531E-01,0.139531E-01,0.139531E-01, |
| 24136 | &0.139531E-01,0.326288E+00,0.000000E+00,0.571121E+00,0.243424E+00, |
| 24137 | &0.133325E-01,0.133362E-01,0.133336E-01,0.133325E-01,0.296956E+00, |
| 24138 | &0.429082E-03,0.551151E+00,0.232297E+00,0.127105E-01,0.127175E-01, |
| 24139 | &0.127126E-01,0.127105E-01,0.269811E+00,0.785137E-03,0.531253E+00/ |
| 24140 | DATA (DL(K),K= 1786, 1870) / |
| 24141 | &0.221436E+00,0.120916E-01,0.121015E-01,0.120945E-01,0.120916E-01, |
| 24142 | &0.244803E+00,0.107790E-02,0.511467E+00,0.210850E+00,0.114794E-01, |
| 24143 | &0.114918E-01,0.114829E-01,0.114794E-01,0.221863E+00,0.131504E-02, |
| 24144 | &0.491833E+00,0.200545E+00,0.108767E-01,0.108913E-01,0.108808E-01, |
| 24145 | &0.108767E-01,0.200886E+00,0.150337E-02,0.472388E+00,0.190531E+00, |
| 24146 | &0.102861E-01,0.103027E-01,0.102907E-01,0.102861E-01,0.181762E+00, |
| 24147 | &0.164910E-02,0.453170E+00,0.180812E+00,0.970979E-02,0.972799E-02, |
| 24148 | &0.971477E-02,0.970979E-02,0.164371E+00,0.175777E-02,0.434213E+00, |
| 24149 | &0.171394E+00,0.914959E-02,0.916916E-02,0.915488E-02,0.914959E-02, |
| 24150 | &0.148589E+00,0.183434E-02,0.415548E+00,0.162282E+00,0.860700E-02, |
| 24151 | &0.862770E-02,0.861252E-02,0.860700E-02,0.134293E+00,0.188328E-02, |
| 24152 | &0.397208E+00,0.153479E+00,0.808323E-02,0.810484E-02,0.808891E-02, |
| 24153 | &0.808323E-02,0.121361E+00,0.190856E-02,0.379220E+00,0.144989E+00, |
| 24154 | &0.757922E-02,0.760152E-02,0.758501E-02,0.757922E-02,0.109676E+00, |
| 24155 | &0.191374E-02,0.361611E+00,0.136811E+00,0.709565E-02,0.711846E-02, |
| 24156 | &0.710150E-02,0.709565E-02,0.991261E-01,0.190199E-02,0.344406E+00, |
| 24157 | &0.128948E+00,0.663300E-02,0.665614E-02,0.663885E-02,0.663300E-02/ |
| 24158 | DATA (DL(K),K= 1871, 1955) / |
| 24159 | &0.896059E-01,0.187610E-02,0.327627E+00,0.121398E+00,0.619152E-02, |
| 24160 | &0.621484E-02,0.619734E-02,0.619152E-02,0.810177E-01,0.183856E-02, |
| 24161 | &0.311292E+00,0.114161E+00,0.577130E-02,0.579466E-02,0.577706E-02, |
| 24162 | &0.577130E-02,0.732709E-01,0.179155E-02,0.295421E+00,0.107235E+00, |
| 24163 | &0.537228E-02,0.539554E-02,0.537794E-02,0.537228E-02,0.662824E-01, |
| 24164 | &0.173700E-02,0.280026E+00,0.100616E+00,0.499423E-02,0.501728E-02, |
| 24165 | &0.499977E-02,0.499423E-02,0.599766E-01,0.167658E-02,0.265121E+00, |
| 24166 | &0.943000E-01,0.463683E-02,0.465958E-02,0.464223E-02,0.463683E-02, |
| 24167 | &0.542848E-01,0.161174E-02,0.000000E+00,0.000000E+00,0.000000E+00, |
| 24168 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 24169 | &0.551659E+00,0.219084E+00,0.867977E-02,0.867977E-02,0.867977E-02, |
| 24170 | &0.867977E-02,0.218587E+00,-.173472E-16,0.528947E+00,0.207536E+00, |
| 24171 | &0.819621E-02,0.819909E-02,0.819696E-02,0.819621E-02,0.196367E+00, |
| 24172 | &0.234843E-03,0.506575E+00,0.196391E+00,0.772540E-02,0.773082E-02, |
| 24173 | &0.772680E-02,0.772540E-02,0.176280E+00,0.427503E-03,0.484579E+00, |
| 24174 | &0.185646E+00,0.726876E-02,0.727639E-02,0.727069E-02,0.726876E-02, |
| 24175 | &0.158158E+00,0.583933E-03,0.462988E+00,0.175298E+00,0.682746E-02/ |
| 24176 | DATA (DL(K),K= 1956, 2040) / |
| 24177 | &0.683702E-02,0.682985E-02,0.682746E-02,0.141851E+00,0.708874E-03, |
| 24178 | &0.441830E+00,0.165345E+00,0.640226E-02,0.641347E-02,0.640502E-02, |
| 24179 | &0.640226E-02,0.127203E+00,0.806409E-03,0.421129E+00,0.155783E+00, |
| 24180 | &0.599380E-02,0.600641E-02,0.599686E-02,0.599380E-02,0.114065E+00, |
| 24181 | &0.880249E-03,0.400912E+00,0.146609E+00,0.560252E-02,0.561629E-02, |
| 24182 | &0.560581E-02,0.560252E-02,0.102296E+00,0.933676E-03,0.381199E+00, |
| 24183 | &0.137819E+00,0.522870E-02,0.524342E-02,0.523217E-02,0.522870E-02, |
| 24184 | &0.917608E-01,0.969607E-03,0.362011E+00,0.129407E+00,0.487247E-02, |
| 24185 | &0.488796E-02,0.487607E-02,0.487247E-02,0.823356E-01,0.990632E-03, |
| 24186 | &0.343367E+00,0.121370E+00,0.453385E-02,0.454992E-02,0.453753E-02, |
| 24187 | &0.453385E-02,0.739054E-01,0.999042E-03,0.325282E+00,0.113700E+00, |
| 24188 | &0.421272E-02,0.422921E-02,0.421644E-02,0.421272E-02,0.663651E-01, |
| 24189 | &0.996863E-03,0.307770E+00,0.106393E+00,0.390887E-02,0.392563E-02, |
| 24190 | &0.391260E-02,0.390887E-02,0.596195E-01,0.985881E-03,0.290841E+00, |
| 24191 | &0.994399E-01,0.362199E-02,0.363889E-02,0.362570E-02,0.362199E-02, |
| 24192 | &0.535826E-01,0.967664E-03,0.274506E+00,0.928343E-01,0.335170E-02, |
| 24193 | &0.336862E-02,0.335536E-02,0.335170E-02,0.481769E-01,0.943587E-03/ |
| 24194 | DATA (DL(K),K= 2041, 2125) / |
| 24195 | &0.258771E+00,0.865679E-01,0.309756E-02,0.311439E-02,0.310114E-02, |
| 24196 | &0.309756E-02,0.433336E-01,0.914850E-03,0.243639E+00,0.806321E-01, |
| 24197 | &0.285905E-02,0.287571E-02,0.286255E-02,0.285905E-02,0.389912E-01, |
| 24198 | &0.882497E-03,0.229113E+00,0.750177E-01,0.263565E-02,0.265205E-02, |
| 24199 | &0.263905E-02,0.263565E-02,0.350948E-01,0.847432E-03,0.215193E+00, |
| 24200 | &0.697152E-01,0.242677E-02,0.244285E-02,0.243005E-02,0.242677E-02, |
| 24201 | &0.315960E-01,0.810432E-03,0.000000E+00,0.000000E+00,0.000000E+00, |
| 24202 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 24203 | &0.503850E+00,0.183581E+00,0.522815E-02,0.522815E-02,0.522815E-02, |
| 24204 | &0.522815E-02,0.142635E+00,0.123599E-16,0.479478E+00,0.172477E+00, |
| 24205 | &0.488093E-02,0.488328E-02,0.488147E-02,0.488093E-02,0.126767E+00, |
| 24206 | &0.124505E-03,0.455750E+00,0.161879E+00,0.455054E-02,0.455493E-02, |
| 24207 | &0.455153E-02,0.455054E-02,0.112695E+00,0.225968E-03,0.432681E+00, |
| 24208 | &0.151771E+00,0.423664E-02,0.424278E-02,0.423800E-02,0.423664E-02, |
| 24209 | &0.100212E+00,0.307702E-03,0.410286E+00,0.142140E+00,0.393907E-02, |
| 24210 | &0.394671E-02,0.394073E-02,0.393907E-02,0.891488E-01,0.372395E-03, |
| 24211 | &0.388577E+00,0.132974E+00,0.365743E-02,0.366634E-02,0.365934E-02/ |
| 24212 | DATA (DL(K),K= 2126, 2210) / |
| 24213 | &0.365743E-02,0.793490E-01,0.422302E-03,0.367563E+00,0.124259E+00, |
| 24214 | &0.339138E-02,0.340133E-02,0.339347E-02,0.339138E-02,0.706688E-01, |
| 24215 | &0.459484E-03,0.347256E+00,0.115984E+00,0.314049E-02,0.315129E-02, |
| 24216 | &0.314273E-02,0.314049E-02,0.629792E-01,0.485762E-03,0.327660E+00, |
| 24217 | &0.108136E+00,0.290433E-02,0.291580E-02,0.290667E-02,0.290433E-02, |
| 24218 | &0.561642E-01,0.502744E-03,0.308782E+00,0.100701E+00,0.268243E-02, |
| 24219 | &0.269440E-02,0.268483E-02,0.268243E-02,0.501207E-01,0.511853E-03, |
| 24220 | &0.290625E+00,0.936693E-01,0.247429E-02,0.248663E-02,0.247672E-02, |
| 24221 | &0.247429E-02,0.447569E-01,0.514346E-03,0.273189E+00,0.870261E-01, |
| 24222 | &0.227939E-02,0.229197E-02,0.228184E-02,0.227939E-02,0.399920E-01, |
| 24223 | &0.511328E-03,0.256475E+00,0.807592E-01,0.209722E-02,0.210991E-02, |
| 24224 | &0.209965E-02,0.209722E-02,0.357547E-01,0.503769E-03,0.240478E+00, |
| 24225 | &0.748555E-01,0.192721E-02,0.193992E-02,0.192961E-02,0.192721E-02, |
| 24226 | &0.319825E-01,0.492518E-03,0.225194E+00,0.693019E-01,0.176883E-02, |
| 24227 | &0.178147E-02,0.177117E-02,0.176883E-02,0.286209E-01,0.478318E-03, |
| 24228 | &0.210615E+00,0.640851E-01,0.162151E-02,0.163400E-02,0.162379E-02, |
| 24229 | &0.162151E-02,0.256219E-01,0.461813E-03,0.196733E+00,0.591917E-01/ |
| 24230 | DATA (DL(K),K= 2211, 2295) / |
| 24231 | &0.148471E-02,0.149698E-02,0.148691E-02,0.148471E-02,0.229436E-01, |
| 24232 | &0.443561E-03,0.183536E+00,0.546085E-01,0.135786E-02,0.136986E-02, |
| 24233 | &0.135998E-02,0.135786E-02,0.205496E-01,0.424043E-03,0.171011E+00, |
| 24234 | &0.503219E-01,0.124042E-02,0.125211E-02,0.124246E-02,0.124042E-02, |
| 24235 | &0.184079E-01,0.403672E-03,0.000000E+00,0.000000E+00,0.000000E+00, |
| 24236 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 24237 | &0.450310E+00,0.149685E+00,0.302765E-02,0.302765E-02,0.302765E-02, |
| 24238 | &0.302765E-02,0.901099E-01,-.108420E-17,0.425282E+00,0.139479E+00, |
| 24239 | &0.279499E-02,0.279691E-02,0.279537E-02,0.279499E-02,0.794239E-01, |
| 24240 | &0.632140E-04,0.401169E+00,0.129837E+00,0.257801E-02,0.258157E-02, |
| 24241 | &0.257870E-02,0.257801E-02,0.700941E-01,0.114711E-03,0.377966E+00, |
| 24242 | &0.120733E+00,0.237556E-02,0.238052E-02,0.237650E-02,0.237556E-02, |
| 24243 | &0.619270E-01,0.156107E-03,0.355668E+00,0.112145E+00,0.218688E-02, |
| 24244 | &0.219301E-02,0.218802E-02,0.218688E-02,0.547717E-01,0.188777E-03, |
| 24245 | &0.334269E+00,0.104052E+00,0.201113E-02,0.201823E-02,0.201243E-02, |
| 24246 | &0.201113E-02,0.484974E-01,0.213848E-03,0.313762E+00,0.964335E-01, |
| 24247 | &0.184758E-02,0.185546E-02,0.184900E-02,0.184758E-02,0.429879E-01/ |
| 24248 | DATA (DL(K),K= 2296, 2380) / |
| 24249 | &0.232367E-03,0.294139E+00,0.892696E-01,0.169553E-02,0.170402E-02, |
| 24250 | &0.169703E-02,0.169553E-02,0.381432E-01,0.245270E-03,0.275389E+00, |
| 24251 | &0.825414E-01,0.155431E-02,0.156326E-02,0.155586E-02,0.155431E-02, |
| 24252 | &0.338762E-01,0.253383E-03,0.257502E+00,0.762303E-01,0.142329E-02, |
| 24253 | &0.143258E-02,0.142487E-02,0.142329E-02,0.301119E-01,0.257441E-03, |
| 24254 | &0.240464E+00,0.703180E-01,0.130188E-02,0.131138E-02,0.130347E-02, |
| 24255 | &0.130188E-02,0.267853E-01,0.258098E-03,0.224262E+00,0.647867E-01, |
| 24256 | &0.118950E-02,0.119912E-02,0.119108E-02,0.118950E-02,0.238409E-01, |
| 24257 | &0.255929E-03,0.208879E+00,0.596190E-01,0.108562E-02,0.109526E-02, |
| 24258 | &0.108717E-02,0.108562E-02,0.212308E-01,0.251442E-03,0.194298E+00, |
| 24259 | &0.547975E-01,0.989698E-03,0.999283E-03,0.991221E-03,0.989698E-03, |
| 24260 | &0.189136E-01,0.245082E-03,0.180499E+00,0.503054E-01,0.901248E-03, |
| 24261 | &0.910711E-03,0.902726E-03,0.901248E-03,0.168537E-01,0.237238E-03, |
| 24262 | &0.167463E+00,0.461263E-01,0.819789E-03,0.829074E-03,0.821215E-03, |
| 24263 | &0.819789E-03,0.150206E-01,0.228250E-03,0.155167E+00,0.422438E-01, |
| 24264 | &0.744866E-03,0.753925E-03,0.746234E-03,0.744866E-03,0.133878E-01, |
| 24265 | &0.218412E-03,0.143590E+00,0.386421E-01,0.676043E-03,0.684836E-03/ |
| 24266 | DATA (DL(K),K= 2381, 2465) / |
| 24267 | &0.677349E-03,0.676043E-03,0.119320E-01,0.207976E-03,0.132706E+00, |
| 24268 | &0.353058E-01,0.612907E-03,0.621403E-03,0.614147E-03,0.612907E-03, |
| 24269 | &0.106334E-01,0.197159E-03,0.000000E+00,0.000000E+00,0.000000E+00, |
| 24270 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 24271 | &0.393307E+00,0.118409E+00,0.167124E-02,0.167124E-02,0.167124E-02, |
| 24272 | &0.167124E-02,0.547140E-01,0.433681E-17,0.368555E+00,0.109414E+00, |
| 24273 | &0.152547E-02,0.152705E-02,0.152573E-02,0.152547E-02,0.479708E-01, |
| 24274 | &0.303147E-04,0.344946E+00,0.101001E+00,0.139202E-02,0.139494E-02, |
| 24275 | &0.139249E-02,0.139202E-02,0.421517E-01,0.552185E-04,0.322450E+00, |
| 24276 | &0.931345E-01,0.126960E-02,0.127363E-02,0.127024E-02,0.126960E-02, |
| 24277 | &0.371043E-01,0.753524E-04,0.301043E+00,0.857854E-01,0.115731E-02, |
| 24278 | &0.116225E-02,0.115808E-02,0.115731E-02,0.327131E-01,0.913172E-04, |
| 24279 | &0.280698E+00,0.789267E-01,0.105427E-02,0.105995E-02,0.105514E-02, |
| 24280 | &0.105427E-02,0.288844E-01,0.103605E-03,0.261390E+00,0.725323E-01, |
| 24281 | &0.959726E-03,0.965979E-03,0.960659E-03,0.959726E-03,0.255366E-01, |
| 24282 | &0.112688E-03,0.243091E+00,0.665774E-01,0.872987E-03,0.879676E-03, |
| 24283 | &0.873966E-03,0.872987E-03,0.226017E-01,0.119000E-03,0.225775E+00/ |
| 24284 | DATA (DL(K),K= 2466, 2550) / |
| 24285 | &0.610385E-01,0.793435E-03,0.800438E-03,0.794441E-03,0.793435E-03, |
| 24286 | &0.200219E-01,0.122931E-03,0.209414E+00,0.558928E-01,0.720508E-03, |
| 24287 | &0.727716E-03,0.721524E-03,0.720508E-03,0.177490E-01,0.124835E-03, |
| 24288 | &0.193979E+00,0.511187E-01,0.653691E-03,0.661011E-03,0.654703E-03, |
| 24289 | &0.653691E-03,0.157425E-01,0.125031E-03,0.179441E+00,0.466950E-01, |
| 24290 | &0.592513E-03,0.599863E-03,0.593511E-03,0.592513E-03,0.139674E-01, |
| 24291 | &0.123805E-03,0.165770E+00,0.426018E-01,0.536539E-03,0.543850E-03, |
| 24292 | &0.537513E-03,0.536539E-03,0.123945E-01,0.121411E-03,0.152935E+00, |
| 24293 | &0.388195E-01,0.485370E-03,0.492584E-03,0.486314E-03,0.485370E-03, |
| 24294 | &0.109993E-01,0.118076E-03,0.140905E+00,0.353295E-01,0.438636E-03, |
| 24295 | &0.445702E-03,0.439543E-03,0.438636E-03,0.976027E-02,0.113999E-03, |
| 24296 | &0.129648E+00,0.321137E-01,0.395992E-03,0.402871E-03,0.396859E-03, |
| 24297 | &0.395992E-03,0.865895E-02,0.109353E-03,0.119131E+00,0.291550E-01, |
| 24298 | &0.357120E-03,0.363779E-03,0.357945E-03,0.357120E-03,0.767960E-02, |
| 24299 | &0.104292E-03,0.109323E+00,0.264366E-01,0.321725E-03,0.328139E-03, |
| 24300 | &0.322505E-03,0.321725E-03,0.680866E-02,0.989468E-04,0.100191E+00, |
| 24301 | &0.239428E-01,0.289531E-03,0.295679E-03,0.290266E-03,0.289531E-03/ |
| 24302 | DATA (DL(K),K= 2551, 2635) / |
| 24303 | &0.603390E-02,0.934295E-04,0.000000E+00,0.000000E+00,0.000000E+00, |
| 24304 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 24305 | &0.334851E+00,0.904666E-01,0.869706E-03,0.869706E-03,0.869706E-03, |
| 24306 | &0.869706E-03,0.316365E-01,-.311708E-17,0.311223E+00,0.828706E-01, |
| 24307 | &0.784673E-03,0.785968E-03,0.784847E-03,0.784673E-03,0.277037E-01, |
| 24308 | &0.134749E-04,0.288910E+00,0.758361E-01,0.708234E-03,0.710597E-03, |
| 24309 | &0.708543E-03,0.708234E-03,0.243298E-01,0.247881E-04,0.267855E+00, |
| 24310 | &0.693222E-01,0.639256E-03,0.642491E-03,0.639671E-03,0.639256E-03, |
| 24311 | &0.214125E-01,0.340882E-04,0.248015E+00,0.632964E-01,0.576953E-03, |
| 24312 | &0.580887E-03,0.577448E-03,0.576953E-03,0.188764E-01,0.415701E-04, |
| 24313 | &0.229343E+00,0.577274E-01,0.520615E-03,0.525096E-03,0.521167E-03, |
| 24314 | &0.520615E-03,0.166642E-01,0.474027E-04,0.211794E+00,0.525860E-01, |
| 24315 | &0.469624E-03,0.474520E-03,0.470215E-03,0.469624E-03,0.147265E-01, |
| 24316 | &0.517615E-04,0.195325E+00,0.478447E-01,0.423445E-03,0.428640E-03, |
| 24317 | &0.424060E-03,0.423445E-03,0.130234E-01,0.548213E-04,0.179891E+00, |
| 24318 | &0.434776E-01,0.381606E-03,0.387001E-03,0.382232E-03,0.381606E-03, |
| 24319 | &0.115226E-01,0.567474E-04,0.165449E+00,0.394601E-01,0.343691E-03/ |
| 24320 | DATA (DL(K),K= 2636, 2720) / |
| 24321 | &0.349200E-03,0.344317E-03,0.343691E-03,0.101965E-01,0.576952E-04, |
| 24322 | &0.151958E+00,0.357691E-01,0.309329E-03,0.314879E-03,0.309948E-03, |
| 24323 | &0.309329E-03,0.902217E-02,0.578101E-04,0.139374E+00,0.323826E-01, |
| 24324 | &0.278192E-03,0.283721E-03,0.278796E-03,0.278192E-03,0.798131E-02, |
| 24325 | &0.572266E-04,0.127655E+00,0.292797E-01,0.249984E-03,0.255440E-03, |
| 24326 | &0.250569E-03,0.249984E-03,0.705796E-02,0.560672E-04,0.116760E+00, |
| 24327 | &0.264406E-01,0.224440E-03,0.229782E-03,0.225002E-03,0.224440E-03, |
| 24328 | &0.623793E-02,0.544420E-04,0.106647E+00,0.238467E-01,0.201321E-03, |
| 24329 | &0.206513E-03,0.201856E-03,0.201321E-03,0.550962E-02,0.524504E-04, |
| 24330 | &0.972762E-01,0.214802E-01,0.180411E-03,0.185425E-03,0.180918E-03, |
| 24331 | &0.180411E-03,0.486321E-02,0.501804E-04,0.886073E-01,0.193242E-01, |
| 24332 | &0.161512E-03,0.166328E-03,0.161990E-03,0.161512E-03,0.428946E-02, |
| 24333 | &0.477087E-04,0.806013E-01,0.173629E-01,0.144446E-03,0.149048E-03, |
| 24334 | &0.144894E-03,0.144446E-03,0.378030E-02,0.451020E-04,0.732197E-01, |
| 24335 | &0.155814E-01,0.129049E-03,0.133425E-03,0.129467E-03,0.129049E-03, |
| 24336 | &0.332897E-02,0.424179E-04,0.000000E+00,0.000000E+00,0.000000E+00, |
| 24337 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ |
| 24338 | DATA (DL(K),K= 2721, 2805) / |
| 24339 | &0.276761E+00,0.663170E-01,0.420483E-03,0.420483E-03,0.420483E-03, |
| 24340 | &0.420483E-03,0.172075E-01,0.418773E-17,0.255003E+00,0.601925E-01, |
| 24341 | &0.374768E-03,0.375776E-03,0.374876E-03,0.374768E-03,0.151410E-01, |
| 24342 | &0.540038E-05,0.234664E+00,0.545789E-01,0.334420E-03,0.336252E-03, |
| 24343 | &0.334612E-03,0.334420E-03,0.133594E-01,0.101360E-04,0.215665E+00, |
| 24344 | &0.494328E-01,0.298611E-03,0.301108E-03,0.298867E-03,0.298611E-03, |
| 24345 | &0.118079E-01,0.141555E-04,0.197941E+00,0.447203E-01,0.266766E-03, |
| 24346 | &0.269787E-03,0.267068E-03,0.266766E-03,0.104461E-01,0.174750E-04, |
| 24347 | &0.181428E+00,0.404089E-01,0.238391E-03,0.241815E-03,0.238726E-03, |
| 24348 | &0.238391E-03,0.924609E-02,0.201244E-04,0.166064E+00,0.364687E-01, |
| 24349 | &0.213061E-03,0.216782E-03,0.213417E-03,0.213061E-03,0.818507E-02, |
| 24350 | &0.221467E-04,0.151790E+00,0.328719E-01,0.190418E-03,0.194343E-03, |
| 24351 | &0.190785E-03,0.190418E-03,0.724366E-02,0.235974E-04,0.138548E+00, |
| 24352 | &0.295925E-01,0.170150E-03,0.174202E-03,0.170521E-03,0.170150E-03, |
| 24353 | &0.640614E-02,0.245354E-04,0.126282E+00,0.266063E-01,0.151991E-03, |
| 24354 | &0.156104E-03,0.152359E-03,0.151991E-03,0.566089E-02,0.250221E-04, |
| 24355 | &0.114939E+00,0.238907E-01,0.135710E-03,0.139827E-03,0.136071E-03/ |
| 24356 | DATA (DL(K),K= 2806, 2890) / |
| 24357 | &0.135710E-03,0.499773E-02,0.251191E-04,0.104465E+00,0.214245E-01, |
| 24358 | &0.121106E-03,0.125180E-03,0.121455E-03,0.121106E-03,0.440691E-02, |
| 24359 | &0.248850E-04,0.948101E-01,0.191879E-01,0.108002E-03,0.111994E-03, |
| 24360 | &0.108337E-03,0.108002E-03,0.388094E-02,0.243760E-04,0.859247E-01, |
| 24361 | &0.171625E-01,0.962435E-04,0.100124E-03,0.965624E-04,0.962435E-04, |
| 24362 | &0.341379E-02,0.236445E-04,0.777613E-01,0.153309E-01,0.856948E-04, |
| 24363 | &0.894394E-04,0.859960E-04,0.856948E-04,0.299910E-02,0.227378E-04, |
| 24364 | &0.702736E-01,0.136770E-01,0.762337E-04,0.798235E-04,0.765166E-04, |
| 24365 | &0.762337E-04,0.263116E-02,0.216984E-04,0.634174E-01,0.121859E-01, |
| 24366 | &0.677528E-04,0.711742E-04,0.680169E-04,0.677528E-04,0.230551E-02, |
| 24367 | &0.205642E-04,0.571500E-01,0.108434E-01,0.601554E-04,0.633990E-04, |
| 24368 | &0.604008E-04,0.601554E-04,0.201791E-02,0.193681E-04,0.514305E-01, |
| 24369 | &0.963651E-02,0.533545E-04,0.564148E-04,0.535814E-04,0.533545E-04, |
| 24370 | &0.176404E-02,0.181381E-04,0.000000E+00,0.000000E+00,0.000000E+00, |
| 24371 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 24372 | &0.220700E+00,0.461964E-01,0.185072E-03,0.185072E-03,0.185072E-03, |
| 24373 | &0.185072E-03,0.865568E-02,-.294090E-17,0.201438E+00,0.415162E-01/ |
| 24374 | DATA (DL(K),K= 2891, 2975) / |
| 24375 | &0.162774E-03,0.163610E-03,0.162842E-03,0.162774E-03,0.772611E-02, |
| 24376 | &0.184134E-05,0.183625E+00,0.372730E-01,0.143469E-03,0.144974E-03, |
| 24377 | &0.143588E-03,0.143469E-03,0.690038E-02,0.359959E-05,0.167162E+00, |
| 24378 | &0.334245E-01,0.126634E-03,0.128666E-03,0.126791E-03,0.126634E-03, |
| 24379 | &0.616000E-02,0.518075E-05,0.151966E+00,0.299378E-01,0.111904E-03, |
| 24380 | &0.114340E-03,0.112088E-03,0.111904E-03,0.549219E-02,0.654232E-05, |
| 24381 | &0.137959E+00,0.267821E-01,0.989836E-04,0.101716E-03,0.991845E-04, |
| 24382 | &0.989836E-04,0.488896E-02,0.767008E-05,0.125065E+00,0.239289E-01, |
| 24383 | &0.876157E-04,0.905559E-04,0.878269E-04,0.876157E-04,0.434253E-02, |
| 24384 | &0.855860E-05,0.113213E+00,0.213524E-01,0.775899E-04,0.806611E-04, |
| 24385 | &0.778055E-04,0.775899E-04,0.384886E-02,0.921640E-05,0.102335E+00, |
| 24386 | &0.190285E-01,0.687292E-04,0.718676E-04,0.689446E-04,0.687292E-04, |
| 24387 | &0.340422E-02,0.965961E-05,0.923671E-01,0.169353E-01,0.608829E-04, |
| 24388 | &0.640353E-04,0.610944E-04,0.608829E-04,0.300332E-02,0.990752E-05, |
| 24389 | &0.832476E-01,0.150523E-01,0.539242E-04,0.570473E-04,0.541291E-04, |
| 24390 | &0.539242E-04,0.264288E-02,0.998320E-05,0.749179E-01,0.133608E-01, |
| 24391 | &0.477459E-04,0.508046E-04,0.479422E-04,0.477459E-04,0.232088E-02/ |
| 24392 | DATA (DL(K),K= 2976, 3060) / |
| 24393 | &0.991147E-05,0.673221E-01,0.118435E-01,0.422554E-04,0.452220E-04, |
| 24394 | &0.424417E-04,0.422554E-04,0.203376E-02,0.971603E-05,0.604073E-01, |
| 24395 | &0.104845E-01,0.373730E-04,0.402263E-04,0.375483E-04,0.373730E-04, |
| 24396 | &0.177791E-02,0.941959E-05,0.541231E-01,0.926900E-02,0.330304E-04, |
| 24397 | &0.357544E-04,0.331943E-04,0.330304E-04,0.155117E-02,0.904408E-05, |
| 24398 | &0.484216E-01,0.818347E-02,0.291681E-04,0.317517E-04,0.293202E-04, |
| 24399 | &0.291681E-04,0.135108E-02,0.860921E-05,0.432578E-01,0.721549E-02, |
| 24400 | &0.257333E-04,0.281694E-04,0.258738E-04,0.257333E-04,0.117463E-02, |
| 24401 | &0.813214E-05,0.385889E-01,0.635362E-02,0.226802E-04,0.249648E-04, |
| 24402 | &0.228093E-04,0.226802E-04,0.101941E-02,0.762814E-05,0.343746E-01, |
| 24403 | &0.558739E-02,0.199682E-04,0.221003E-04,0.200863E-04,0.199682E-04, |
| 24404 | &0.883469E-03,0.711035E-05,0.000000E+00,0.000000E+00,0.000000E+00, |
| 24405 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 24406 | &0.168205E+00,0.301419E-01,0.719932E-04,0.719932E-04,0.719932E-04, |
| 24407 | &0.719932E-04,0.392825E-02,-.205998E-17,0.151922E+00,0.267932E-01, |
| 24408 | &0.623634E-04,0.630456E-04,0.624028E-04,0.623634E-04,0.361412E-02, |
| 24409 | &0.457084E-06,0.137042E+00,0.237932E-01,0.541981E-04,0.554098E-04/ |
| 24410 | DATA (DL(K),K= 3061, 3145) / |
| 24411 | &0.542663E-04,0.541981E-04,0.330342E-02,0.989813E-06,0.123446E+00, |
| 24412 | &0.211038E-01,0.472163E-04,0.488314E-04,0.473050E-04,0.472163E-04, |
| 24413 | &0.300140E-02,0.152631E-05,0.111042E+00,0.186954E-01,0.412159E-04, |
| 24414 | &0.431273E-04,0.413184E-04,0.412159E-04,0.270826E-02,0.202092E-05, |
| 24415 | &0.997395E-01,0.165410E-01,0.360433E-04,0.381615E-04,0.361542E-04, |
| 24416 | &0.360433E-04,0.242968E-02,0.245400E-05,0.894558E-01,0.146159E-01, |
| 24417 | &0.315670E-04,0.338178E-04,0.316822E-04,0.315670E-04,0.216928E-02, |
| 24418 | &0.281218E-05,0.801130E-01,0.128978E-01,0.276779E-04,0.300002E-04, |
| 24419 | &0.277940E-04,0.276779E-04,0.192603E-02,0.308878E-05,0.716379E-01, |
| 24420 | &0.113663E-01,0.242878E-04,0.266317E-04,0.244024E-04,0.242878E-04, |
| 24421 | &0.170100E-02,0.328451E-05,0.639623E-01,0.100031E-01,0.213246E-04, |
| 24422 | &0.236502E-04,0.214357E-04,0.213246E-04,0.149649E-02,0.340483E-05, |
| 24423 | &0.570222E-01,0.879131E-02,0.187277E-04,0.210033E-04,0.188341E-04, |
| 24424 | &0.187277E-04,0.131163E-02,0.345656E-05,0.507574E-01,0.771565E-02, |
| 24425 | &0.164465E-04,0.186476E-04,0.165471E-04,0.164465E-04,0.114469E-02, |
| 24426 | &0.344782E-05,0.451118E-01,0.676223E-02,0.144396E-04,0.165480E-04, |
| 24427 | &0.145339E-04,0.144396E-04,0.995649E-03,0.338831E-05,0.400330E-01/ |
| 24428 | DATA (DL(K),K= 3146, 3230) / |
| 24429 | &0.591841E-02,0.126720E-04,0.146744E-04,0.127597E-04,0.126720E-04, |
| 24430 | &0.863829E-03,0.328754E-05,0.354720E-01,0.517273E-02,0.111137E-04, |
| 24431 | &0.130013E-04,0.111946E-04,0.111137E-04,0.747293E-03,0.315403E-05, |
| 24432 | &0.313830E-01,0.451477E-02,0.973915E-05,0.115067E-04,0.981339E-05, |
| 24433 | &0.973915E-05,0.644664E-03,0.299600E-05,0.277237E-01,0.393511E-02, |
| 24434 | &0.852687E-05,0.101721E-04,0.859457E-05,0.852687E-05,0.555034E-03, |
| 24435 | &0.282099E-05,0.244545E-01,0.342521E-02,0.745784E-05,0.898076E-05, |
| 24436 | &0.751926E-05,0.745784E-05,0.476998E-03,0.263530E-05,0.215390E-01, |
| 24437 | &0.297737E-02,0.651555E-05,0.791817E-05,0.657100E-05,0.651555E-05, |
| 24438 | &0.409096E-03,0.244427E-05,0.000000E+00,0.000000E+00,0.000000E+00, |
| 24439 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 24440 | &0.120694E+00,0.180081E-01,0.236444E-04,0.236444E-04,0.236444E-04, |
| 24441 | &0.236444E-04,0.154817E-02,0.416656E-17,0.107713E+00,0.158098E-01, |
| 24442 | &0.200945E-04,0.206098E-04,0.201146E-04,0.200945E-04,0.151249E-02, |
| 24443 | &0.192118E-07,0.960063E-01,0.138667E-01,0.171552E-04,0.180593E-04, |
| 24444 | &0.171894E-04,0.171552E-04,0.143574E-02,0.116516E-06,0.854477E-01, |
| 24445 | &0.121473E-01,0.146986E-04,0.158894E-04,0.147425E-04,0.146986E-04/ |
| 24446 | DATA (DL(K),K= 3231, 3315) / |
| 24447 | &0.133744E-02,0.251060E-06,0.759386E-01,0.106275E-01,0.126329E-04, |
| 24448 | &0.140252E-04,0.126830E-04,0.126329E-04,0.122900E-02,0.395272E-06, |
| 24449 | &0.673865E-01,0.928577E-02,0.108901E-04,0.124142E-04,0.109436E-04, |
| 24450 | &0.108901E-04,0.111367E-02,0.535145E-06,0.597062E-01,0.810254E-02, |
| 24451 | &0.941160E-05,0.110108E-04,0.946648E-05,0.941160E-05,0.996785E-03, |
| 24452 | &0.659421E-06,0.528194E-01,0.706039E-02,0.815165E-05,0.978016E-05, |
| 24453 | &0.820627E-05,0.815165E-05,0.885152E-03,0.762600E-06,0.466540E-01, |
| 24454 | &0.614371E-02,0.707299E-05,0.869464E-05,0.712616E-05,0.707299E-05, |
| 24455 | &0.780484E-03,0.842072E-06,0.411433E-01,0.533850E-02,0.614470E-05, |
| 24456 | &0.773135E-05,0.619559E-05,0.614470E-05,0.682563E-03,0.896683E-06, |
| 24457 | &0.362261E-01,0.463223E-02,0.534297E-05,0.687330E-05,0.539102E-05, |
| 24458 | &0.534297E-05,0.593317E-03,0.928176E-06,0.318459E-01,0.401364E-02, |
| 24459 | &0.464848E-05,0.610690E-05,0.469333E-05,0.464848E-05,0.513720E-03, |
| 24460 | &0.939174E-06,0.279510E-01,0.347266E-02,0.404483E-05,0.542054E-05, |
| 24461 | &0.408628E-05,0.404483E-05,0.442713E-03,0.932117E-06,0.244935E-01, |
| 24462 | &0.300029E-02,0.351893E-05,0.480507E-05,0.355692E-05,0.351893E-05, |
| 24463 | &0.379744E-03,0.910085E-06,0.214299E-01,0.258845E-02,0.306021E-05/ |
| 24464 | DATA (DL(K),K= 3316, 3400) / |
| 24465 | &0.425313E-05,0.309476E-05,0.306021E-05,0.324785E-03,0.876365E-06, |
| 24466 | &0.187200E-01,0.222996E-02,0.265958E-05,0.375823E-05,0.269081E-05, |
| 24467 | &0.265958E-05,0.277080E-03,0.833755E-06,0.163273E-01,0.191840E-02, |
| 24468 | &0.230942E-05,0.331477E-05,0.233747E-05,0.230942E-05,0.235661E-03, |
| 24469 | &0.784780E-06,0.142185E-01,0.164805E-02,0.200337E-05,0.291797E-05, |
| 24470 | &0.202844E-05,0.200337E-05,0.199949E-03,0.731774E-06,0.123631E-01, |
| 24471 | &0.141382E-02,0.173596E-05,0.256351E-05,0.175824E-05,0.173596E-05, |
| 24472 | &0.169376E-03,0.676674E-06,0.000000E+00,0.000000E+00,0.000000E+00, |
| 24473 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 24474 | &0.794823E-01,0.948208E-02,0.607312E-05,0.607312E-05,0.607312E-05, |
| 24475 | &0.607312E-05,0.497062E-03,-.140523E-17,0.699344E-01,0.820355E-02, |
| 24476 | &0.500852E-05,0.538347E-05,0.501731E-05,0.500852E-05,0.542262E-03, |
| 24477 | &-.714686E-07,0.614560E-01,0.709106E-02,0.415227E-05,0.479898E-05, |
| 24478 | &0.416702E-05,0.415227E-05,0.549985E-03,-.960102E-07,0.539240E-01, |
| 24479 | &0.612155E-02,0.345977E-05,0.429563E-05,0.347839E-05,0.345977E-05, |
| 24480 | &0.531288E-03,-.894946E-07,0.472426E-01,0.527757E-02,0.289508E-05, |
| 24481 | &0.385164E-05,0.291595E-05,0.289508E-05,0.495120E-03,-.668594E-07/ |
| 24482 | DATA (DL(K),K= 3401, 3485) / |
| 24483 | &0.413245E-01,0.454380E-02,0.243524E-05,0.345851E-05,0.245713E-05, |
| 24484 | &0.243524E-05,0.452156E-03,-.338861E-07,0.360903E-01,0.390658E-02, |
| 24485 | &0.205923E-05,0.310726E-05,0.208123E-05,0.205923E-05,0.406686E-03, |
| 24486 | &0.329349E-08,0.314681E-01,0.335393E-02,0.174861E-05,0.278918E-05, |
| 24487 | &0.177007E-05,0.174861E-05,0.359402E-03,0.387747E-07,0.273932E-01, |
| 24488 | &0.287528E-02,0.149082E-05,0.250013E-05,0.151127E-05,0.149082E-05, |
| 24489 | &0.313779E-03,0.705560E-07,0.238068E-01,0.246132E-02,0.127582E-05, |
| 24490 | &0.223699E-05,0.129498E-05,0.127582E-05,0.272195E-03,0.975744E-07, |
| 24491 | &0.206558E-01,0.210383E-02,0.109488E-05,0.199657E-05,0.111257E-05, |
| 24492 | &0.109488E-05,0.234227E-03,0.118651E-06,0.178921E-01,0.179558E-02, |
| 24493 | &0.941584E-06,0.177694E-05,0.957733E-06,0.941584E-06,0.199907E-03, |
| 24494 | &0.133780E-06,0.154726E-01,0.153020E-02,0.811157E-06,0.157680E-05, |
| 24495 | &0.825743E-06,0.811157E-06,0.169849E-03,0.143581E-06,0.133582E-01, |
| 24496 | &0.130209E-02,0.699567E-06,0.139481E-05,0.712624E-06,0.699567E-06, |
| 24497 | &0.143794E-03,0.148591E-06,0.115137E-01,0.110634E-02,0.603631E-06, |
| 24498 | &0.122977E-05,0.615228E-06,0.603631E-06,0.121163E-03,0.149477E-06, |
| 24499 | &0.990774E-02,0.938615E-03,0.520920E-06,0.108072E-05,0.531148E-06/ |
| 24500 | DATA (DL(K),K= 3486, 3570) / |
| 24501 | &0.520920E-06,0.101725E-03,0.147055E-06,0.851194E-02,0.795146E-03, |
| 24502 | &0.449441E-06,0.946634E-06,0.458405E-06,0.449441E-06,0.852238E-04, |
| 24503 | &0.142064E-06,0.730103E-02,0.672622E-03,0.387542E-06,0.826497E-06, |
| 24504 | &0.395353E-06,0.387542E-06,0.712290E-04,0.135149E-06,0.625244E-02, |
| 24505 | &0.568155E-03,0.333888E-06,0.719316E-06,0.340658E-06,0.333888E-06, |
| 24506 | &0.593824E-04,0.126902E-06,0.000000E+00,0.000000E+00,0.000000E+00, |
| 24507 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 24508 | &0.457819E-01,0.409492E-02,0.105702E-05,0.105702E-05,0.105702E-05, |
| 24509 | &0.105702E-05,0.115350E-03,0.265810E-18,0.395724E-01,0.347873E-02, |
| 24510 | &0.812397E-06,0.103880E-05,0.815187E-06,0.812397E-06,0.160406E-03, |
| 24511 | &-.555147E-07,0.341639E-01,0.295295E-02,0.627904E-06,0.987449E-06, |
| 24512 | &0.632305E-06,0.627904E-06,0.174490E-03,-.847266E-07,0.294481E-01, |
| 24513 | &0.250329E-02,0.490075E-06,0.920197E-06,0.495305E-06,0.490075E-06, |
| 24514 | &0.174490E-03,-.944763E-07,0.253423E-01,0.211912E-02,0.387225E-06, |
| 24515 | &0.845257E-06,0.392760E-06,0.387225E-06,0.167111E-03,-.916775E-07, |
| 24516 | &0.217735E-01,0.179138E-02,0.309989E-06,0.766697E-06,0.315473E-06, |
| 24517 | &0.309989E-06,0.152540E-03,-.819158E-07,0.186760E-01,0.151211E-02/ |
| 24518 | DATA (DL(K),K= 3571, 3655) / |
| 24519 | &0.252109E-06,0.688927E-06,0.257316E-06,0.252109E-06,0.135295E-03, |
| 24520 | &-.682145E-07,0.159921E-01,0.127447E-02,0.208612E-06,0.614302E-06, |
| 24521 | &0.213410E-06,0.208612E-06,0.118648E-03,-.528734E-07,0.136704E-01, |
| 24522 | &0.107254E-02,0.175203E-06,0.543807E-06,0.179526E-06,0.175203E-06, |
| 24523 | &0.102484E-03,-.379748E-07,0.116656E-01,0.901214E-03,0.149064E-06, |
| 24524 | &0.478363E-06,0.152890E-06,0.149064E-06,0.871530E-04,-.245007E-07, |
| 24525 | &0.993760E-02,0.756074E-03,0.128274E-06,0.418496E-06,0.131610E-06, |
| 24526 | &0.128274E-06,0.735682E-04,-.128491E-07,0.845081E-02,0.633315E-03, |
| 24527 | &0.111313E-06,0.364260E-06,0.114187E-06,0.111313E-06,0.617706E-04, |
| 24528 | &-.327698E-08,0.717398E-02,0.529654E-03,0.971373E-07,0.315568E-06, |
| 24529 | &0.995871E-07,0.971373E-07,0.514764E-04,0.421954E-08,0.607950E-02, |
| 24530 | &0.442265E-03,0.850687E-07,0.272228E-06,0.871375E-07,0.850687E-07, |
| 24531 | &0.426580E-04,0.982709E-08,0.514311E-02,0.368716E-03,0.746164E-07, |
| 24532 | &0.233927E-06,0.763489E-07,0.746164E-07,0.352463E-04,0.137715E-07, |
| 24533 | &0.434349E-02,0.306920E-03,0.654439E-07,0.200291E-06,0.668838E-07, |
| 24534 | &0.654439E-07,0.290260E-04,0.163078E-07,0.366196E-02,0.255085E-03, |
| 24535 | &0.573307E-07,0.170932E-06,0.585192E-07,0.573307E-07,0.238196E-04/ |
| 24536 | DATA (DL(K),K= 3656, 3740) / |
| 24537 | &0.177037E-07,0.308217E-02,0.211681E-03,0.501185E-07,0.145441E-06, |
| 24538 | &0.510931E-07,0.501185E-07,0.195033E-04,0.182028E-07,0.258987E-02, |
| 24539 | &0.175396E-03,0.436915E-07,0.123415E-06,0.444860E-07,0.436915E-07, |
| 24540 | &0.159423E-04,0.180204E-07,0.000000E+00,0.000000E+00,0.000000E+00, |
| 24541 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 24542 | &0.206951E-01,0.123383E-02,0.903693E-07,0.903693E-07,0.903693E-07, |
| 24543 | &0.903693E-07,0.147928E-04,0.131925E-18,0.174566E-01,0.102241E-02, |
| 24544 | &0.892028E-07,0.129792E-07,0.885875E-07,0.892028E-07,0.328931E-04, |
| 24545 | &0.168541E-07,0.147092E-01,0.846741E-03,0.841992E-07,-.346085E-07, |
| 24546 | &0.832249E-07,0.841992E-07,0.410825E-04,0.262547E-07,0.123736E-01, |
| 24547 | &0.700287E-03,0.769173E-07,-.620958E-07,0.757563E-07,0.769173E-07, |
| 24548 | &0.418512E-04,0.305542E-07,0.103910E-01,0.578275E-03,0.688622E-07, |
| 24549 | &-.753692E-07,0.676306E-07,0.688622E-07,0.392599E-04,0.318183E-07, |
| 24550 | &0.871109E-02,0.476815E-03,0.611778E-07,-.782788E-07,0.599557E-07, |
| 24551 | &0.611778E-07,0.356221E-04,0.316149E-07,0.728984E-02,0.392546E-03, |
| 24552 | &0.537256E-07,-.749101E-07,0.525642E-07,0.537256E-07,0.312295E-04, |
| 24553 | &0.301630E-07,0.608951E-02,0.322656E-03,0.466227E-07,-.678673E-07/ |
| 24554 | DATA (DL(K),K= 3741, 3825) / |
| 24555 | &0.455521E-07,0.466227E-07,0.265816E-04,0.278681E-07,0.507758E-02, |
| 24556 | &0.264779E-03,0.400790E-07,-.588670E-07,0.391148E-07,0.400790E-07, |
| 24557 | &0.223044E-04,0.251720E-07,0.422604E-02,0.216927E-03,0.341205E-07, |
| 24558 | &-.492124E-07,0.332680E-07,0.341205E-07,0.185283E-04,0.222885E-07, |
| 24559 | &0.351082E-02,0.177427E-03,0.287480E-07,-.397442E-07,0.280058E-07, |
| 24560 | &0.287480E-07,0.152122E-04,0.193702E-07,0.291126E-02,0.144878E-03, |
| 24561 | &0.239699E-07,-.309608E-07,0.233320E-07,0.239699E-07,0.123840E-04, |
| 24562 | &0.165481E-07,0.240962E-02,0.118102E-03,0.197695E-07,-.231453E-07, |
| 24563 | &0.192276E-07,0.197695E-07,0.100316E-04,0.139043E-07,0.199075E-02, |
| 24564 | &0.961132E-04,0.161186E-07,-.164194E-07,0.156628E-07,0.161186E-07, |
| 24565 | &0.808648E-05,0.114903E-07,0.164168E-02,0.780880E-04,0.129826E-07, |
| 24566 | &-.107955E-07,0.126029E-07,0.129826E-07,0.648861E-05,0.933575E-08, |
| 24567 | &0.135135E-02,0.633381E-04,0.103192E-07,-.622051E-08,0.100055E-07, |
| 24568 | &0.103192E-07,0.519042E-05,0.744979E-08,0.111036E-02,0.512898E-04, |
| 24569 | &0.808255E-08,-.260101E-08,0.782557E-08,0.808255E-08,0.414192E-05, |
| 24570 | &0.582811E-08,0.910718E-03,0.414657E-04,0.622640E-08,0.177583E-09, |
| 24571 | &0.601750E-08,0.622640E-08,0.329729E-05,0.445766E-08,0.745657E-03/ |
| 24572 | DATA (DL(K),K= 3826, 3910) / |
| 24573 | &0.334694E-04,0.470431E-08,0.223586E-08,0.453577E-08,0.470431E-08, |
| 24574 | &0.261981E-05,0.331859E-08,0.000000E+00,0.000000E+00,0.000000E+00, |
| 24575 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 24576 | &0.519165E-02,0.154752E-03,0.135983E-08,0.135983E-08,0.135983E-08, |
| 24577 | &0.135983E-08,0.445189E-06,0.165858E-19,0.420352E-02,0.123002E-03, |
| 24578 | &-.202651E-07,0.730203E-07,-.200511E-07,-.202651E-07,0.358557E-05, |
| 24579 | &-.213089E-07,0.340143E-02,0.977718E-04,-.356451E-07,0.114908E-06, |
| 24580 | &-.353066E-07,-.356451E-07,0.384652E-05,-.364475E-07,0.274771E-02, |
| 24581 | &0.776124E-04,-.435588E-07,0.139200E-06,-.431556E-07,-.435588E-07, |
| 24582 | &0.404834E-05,-.441752E-07,0.221524E-02,0.614950E-04,-.471629E-07, |
| 24583 | &0.150069E-06,-.467352E-07,-.471629E-07,0.391615E-05,-.476355E-07, |
| 24584 | &0.178268E-02,0.486476E-04,-.477545E-07,0.151420E-06,-.473296E-07, |
| 24585 | &-.477545E-07,0.334100E-05,-.481163E-07,0.143185E-02,0.384202E-04, |
| 24586 | &-.462359E-07,0.146515E-06,-.458316E-07,-.462359E-07,0.275426E-05, |
| 24587 | &-.465126E-07,0.114781E-02,0.302894E-04,-.434031E-07,0.137587E-06, |
| 24588 | &-.430295E-07,-.434031E-07,0.226010E-05,-.436143E-07,0.918288E-03, |
| 24589 | &0.238367E-04,-.398089E-07,0.126321E-06,-.394715E-07,-.398089E-07/ |
| 24590 | DATA (DL(K),K= 3911, 3995) / |
| 24591 | &0.180947E-05,-.399700E-07,0.733193E-03,0.187249E-04,-.358525E-07, |
| 24592 | &0.113940E-06,-.355529E-07,-.358525E-07,0.142045E-05,-.359751E-07, |
| 24593 | &0.584227E-03,0.146823E-04,-.318183E-07,0.101291E-06,-.315563E-07, |
| 24594 | &-.318183E-07,0.110919E-05,-.319115E-07,0.464586E-03,0.114914E-04, |
| 24595 | &-.278936E-07,0.889550E-07,-.276671E-07,-.278936E-07,0.860964E-06, |
| 24596 | &-.279643E-07,0.368700E-03,0.897731E-05,-.241972E-07,0.773096E-07, |
| 24597 | &-.240033E-07,-.241972E-07,0.662825E-06,-.242508E-07,0.292013E-03, |
| 24598 | &0.700034E-05,-.208001E-07,0.665779E-07,-.206356E-07,-.208001E-07, |
| 24599 | &0.508061E-06,-.208406E-07,0.230814E-03,0.544870E-05,-.177366E-07, |
| 24600 | &0.568734E-07,-.175982E-07,-.177366E-07,0.388493E-06,-.177672E-07, |
| 24601 | &0.182078E-03,0.423324E-05,-.150157E-07,0.482316E-07,-.149000E-07, |
| 24602 | &-.150157E-07,0.296111E-06,-.150387E-07,0.143349E-03,0.328297E-05, |
| 24603 | &-.126295E-07,0.406343E-07,-.125335E-07,-.126295E-07,0.225104E-06, |
| 24604 | &-.126468E-07,0.112639E-03,0.254145E-05,-.105595E-07,0.340280E-07, |
| 24605 | &-.104803E-07,-.105595E-07,0.170871E-06,-.105726E-07,0.883377E-04, |
| 24606 | &0.196395E-05,-.878062E-08,0.283380E-07,-.871555E-08,-.878062E-08, |
| 24607 | &0.129517E-06,-.879039E-08,0.000000E+00,0.000000E+00,0.000000E+00/ |
| 24608 | DATA (DL(K),K= 3996, 4000) / |
| 24609 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ |
| 24610 | C |
| 24611 | ANS = 0. |
| 24612 | IF (X.GT.0.9985) RETURN |
| 24613 | IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN |
| 24614 | C |
| 24615 | IS = S/DELTA+1 |
| 24616 | IS1 = IS+1 |
| 24617 | DO 1 L=1,25 |
| 24618 | KL = L+NDRV*25 |
| 24619 | F1(L) = GF(I,IS,KL) |
| 24620 | F2(L) = GF(I,IS1,KL) |
| 24621 | 1 CONTINUE |
| 24622 | A1 = DT_CKMTFF(X,F1) |
| 24623 | A2 = DT_CKMTFF(X,F2) |
| 24624 | C A1=ALOG(A1) |
| 24625 | C A2=ALOG(A2) |
| 24626 | S1 = (IS-1)*DELTA |
| 24627 | S2 = S1+DELTA |
| 24628 | ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1) |
| 24629 | C ANS=EXP(ANS) |
| 24630 | RETURN |
| 24631 | END |
| 24632 | C |
| 24633 | |
| 24634 | *$ CREATE DT_CKMTFF.FOR |
| 24635 | *COPY DT_CKMTFF |
| 24636 | FUNCTION DT_CKMTFF(X,FVL) |
| 24637 | C********************************************************************** |
| 24638 | C |
| 24639 | C LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE |
| 24640 | C FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1. |
| 24641 | C NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED |
| 24642 | C IN MAIN ROUTINE. |
| 24643 | C |
| 24644 | C********************************************************************** |
| 24645 | |
| 24646 | SAVE |
| 24647 | DIMENSION FVL(25),XGRID(25) |
| 24648 | DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15, |
| 24649 | *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/ |
| 24650 | C |
| 24651 | DT_CKMTFF=0. |
| 24652 | DO 1 I=1,NX |
| 24653 | IF(X.LT.XGRID(I)) GO TO 2 |
| 24654 | 1 CONTINUE |
| 24655 | 2 I=I-1 |
| 24656 | IF(I.EQ.0) THEN |
| 24657 | I=I+1 |
| 24658 | ELSE IF(I.GT.23) THEN |
| 24659 | I=23 |
| 24660 | ENDIF |
| 24661 | J=I+1 |
| 24662 | K=J+1 |
| 24663 | AXI=LOG(XGRID(I)) |
| 24664 | BXI=LOG(1.-XGRID(I)) |
| 24665 | AXJ=LOG(XGRID(J)) |
| 24666 | BXJ=LOG(1.-XGRID(J)) |
| 24667 | AXK=LOG(XGRID(K)) |
| 24668 | BXK=LOG(1.-XGRID(K)) |
| 24669 | FI=LOG(ABS(FVL(I)) +1.E-15) |
| 24670 | FJ=LOG(ABS(FVL(J)) +1.E-16) |
| 24671 | FK=LOG(ABS(FVL(K)) +1.E-17) |
| 24672 | DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ) |
| 24673 | ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ* |
| 24674 | $ BXI))/DET |
| 24675 | ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET |
| 24676 | BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET |
| 24677 | IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.) |
| 24678 | 1RETURN |
| 24679 | C IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN |
| 24680 | C WRITE(6,2001) X,FVL |
| 24681 | C 2001 FORMAT(8E12.4) |
| 24682 | C WRITE(6,2001) ALPHA,BETA,ALOGA,DET |
| 24683 | C ENDIF |
| 24684 | DT_CKMTFF=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA |
| 24685 | RETURN |
| 24686 | END |
| 24687 | |
| 24688 | *$ CREATE DT_FLUINI.FOR |
| 24689 | *COPY DT_FLUINI |
| 24690 | * |
| 24691 | *===fluini=============================================================* |
| 24692 | * |
| 24693 | SUBROUTINE DT_FLUINI |
| 24694 | |
| 24695 | ************************************************************************ |
| 24696 | * Initialisation of the nucleon-nucleon cross section fluctuation * |
| 24697 | * treatment. The original version by J. Ranft. * |
| 24698 | * This version dated 21.04.95 is revised by S. Roesler. * |
| 24699 | ************************************************************************ |
| 24700 | |
| 24701 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 24702 | SAVE |
| 24703 | PARAMETER ( LINP = 10 , |
| 24704 | & LOUT = 6 , |
| 24705 | & LDAT = 9 ) |
| 24706 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) |
| 24707 | |
| 24708 | PARAMETER ( A = 0.1D0, |
| 24709 | & B = 0.893D0, |
| 24710 | & OM = 1.1D0, |
| 24711 | & N = 6, |
| 24712 | & DX = 0.003D0) |
| 24713 | |
| 24714 | * n-n cross section fluctuations |
| 24715 | PARAMETER (NBINS = 1000) |
| 24716 | COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT |
| 24717 | DIMENSION FLUSI(NBINS),FLUIX(NBINS) |
| 24718 | |
| 24719 | WRITE(LOUT,1000) |
| 24720 | 1000 FORMAT(/,1X,'FLUINI: hadronic cross section fluctuations ', |
| 24721 | & 'treated') |
| 24722 | |
| 24723 | FLUSU = ZERO |
| 24724 | FLUSUU = ZERO |
| 24725 | |
| 24726 | DO 1 I=1,NBINS |
| 24727 | X = DBLE(I)*DX |
| 24728 | FLUIX(I) = X |
| 24729 | FLUS = ((X-B)/(OM*B))**N |
| 24730 | IF (FLUS.LE.20.0D0) THEN |
| 24731 | FLUSI(I) = (X/B)*EXP(-FLUS)/(X/B+A) |
| 24732 | ELSE |
| 24733 | FLUSI(I) = ZERO |
| 24734 | ENDIF |
| 24735 | FLUSU = FLUSU+FLUSI(I) |
| 24736 | 1 CONTINUE |
| 24737 | DO 2 I=1,NBINS |
| 24738 | FLUSUU = FLUSUU+FLUSI(I)/FLUSU |
| 24739 | FLUSI(I) = FLUSUU |
| 24740 | 2 CONTINUE |
| 24741 | |
| 24742 | C WRITE(LOUT,1001) |
| 24743 | C1001 FORMAT(1X,'FLUCTUATIONS') |
| 24744 | C CALL PLOT(FLUIX,FLUSI,1000,1,1000,0.0D0,0.06D0,0.0D0,0.01D0) |
| 24745 | |
| 24746 | DO 3 I=1,NBINS |
| 24747 | AF = DBLE(I)*0.001D0 |
| 24748 | DO 4 J=1,NBINS |
| 24749 | IF (AF.LE.FLUSI(J)) THEN |
| 24750 | FLUIXX(I) = FLUIX(J) |
| 24751 | GOTO 5 |
| 24752 | ENDIF |
| 24753 | 4 CONTINUE |
| 24754 | 5 CONTINUE |
| 24755 | 3 CONTINUE |
| 24756 | FLUIXX(1) = FLUIX(1) |
| 24757 | FLUIXX(NBINS) = FLUIX(NBINS) |
| 24758 | |
| 24759 | RETURN |
| 24760 | END |
| 24761 | |
| 24762 | *$ CREATE DT_SIGTBL.FOR |
| 24763 | *COPY DT_SIGTBL |
| 24764 | * |
| 24765 | *===sigtab=============================================================* |
| 24766 | * |
| 24767 | SUBROUTINE DT_SIGTBL(JP,JT,PTOT,SIGE,MODE) |
| 24768 | |
| 24769 | ************************************************************************ |
| 24770 | * This version dated 18.11.95 is written by S. Roesler * |
| 24771 | ************************************************************************ |
| 24772 | |
| 24773 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 24774 | SAVE |
| 24775 | PARAMETER ( LINP = 10 , |
| 24776 | & LOUT = 6 , |
| 24777 | & LDAT = 9 ) |
| 24778 | |
| 24779 | PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10, |
| 24780 | & OHALF=0.5D0,ONE=1.0D0) |
| 24781 | PARAMETER (PLO=0.01D0,PHI=20.0D0,NBINS=150) |
| 24782 | |
| 24783 | LOGICAL LINIT |
| 24784 | |
| 24785 | * particle properties (BAMJET index convention) |
| 24786 | CHARACTER*8 ANAME |
| 24787 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 24788 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 24789 | |
| 24790 | DIMENSION SIGEP(5,NBINS+1),SIGEN(5,NBINS+1),IDSIG(23) |
| 24791 | DATA IDSIG / 1, 0, 0, 0, 0, 0, 0, 2, 0, 0, |
| 24792 | & 0, 0, 3, 4, 0, 0, 0, 0, 0, 0, |
| 24793 | & 0, 0, 5/ |
| 24794 | DATA LINIT /.FALSE./ |
| 24795 | |
| 24796 | * precalculation and tabulation of elastic cross sections |
| 24797 | IF (ABS(MODE).EQ.1) THEN |
| 24798 | IF (MODE.EQ.1) |
| 24799 | & OPEN(LDAT,FILE='outdata0/sigtab.out',STATUS='UNKNOWN') |
| 24800 | PLABLX = LOG10(PLO) |
| 24801 | PLABHX = LOG10(PHI) |
| 24802 | DPLAB = (PLABHX-PLABLX)/DBLE(NBINS) |
| 24803 | DO 1 I=1,NBINS+1 |
| 24804 | PLAB = PLABLX+DBLE(I-1)*DPLAB |
| 24805 | PLAB = 10**PLAB |
| 24806 | DO 2 IPROJ=1,23 |
| 24807 | IDX = IDSIG(IPROJ) |
| 24808 | IF (IDX.GT.0) THEN |
| 24809 | C CALL DT_SIHNEL(IPROJ,1,PLAB,SIGEP(IDX,I)) |
| 24810 | C CALL DT_SIHNEL(IPROJ,8,PLAB,SIGEN(IDX,I)) |
| 24811 | DUMZER = ZERO |
| 24812 | CALL DT_XSHN(IPROJ,1,PLAB,DUMZER,SIGTOT,SIGEP(IDX,I)) |
| 24813 | CALL DT_XSHN(IPROJ,8,PLAB,DUMZER,SIGTOT,SIGEN(IDX,I)) |
| 24814 | ENDIF |
| 24815 | 2 CONTINUE |
| 24816 | IF (MODE.EQ.1) THEN |
| 24817 | WRITE(LDAT,1000) PLAB,(SIGEP(IDX,I),IDX=1,5), |
| 24818 | & (SIGEN(IDX,I),IDX=1,5) |
| 24819 | 1000 FORMAT(F5.1,10F7.2) |
| 24820 | ENDIF |
| 24821 | 1 CONTINUE |
| 24822 | IF (MODE.EQ.1) CLOSE(LDAT) |
| 24823 | LINIT = .TRUE. |
| 24824 | ELSE |
| 24825 | SIGE = -ONE |
| 24826 | IF (LINIT.AND.(JP.LE.23).AND.(PTOT.GE.PLO) |
| 24827 | & .AND.(PTOT.LE.PHI) ) THEN |
| 24828 | IDX = IDSIG(JP) |
| 24829 | IF ( (IDX.GT.0).AND.((JT.EQ.1).OR.(JT.EQ.8)) ) THEN |
| 24830 | PLABX = LOG10(PTOT) |
| 24831 | IF (PLABX.LE.PLABLX) THEN |
| 24832 | I1 = 1 |
| 24833 | I2 = 1 |
| 24834 | ELSEIF (PLABX.GE.PLABHX) THEN |
| 24835 | I1 = NBINS+1 |
| 24836 | I2 = NBINS+1 |
| 24837 | ELSE |
| 24838 | I1 = INT((PLABX-PLABLX)/DPLAB)+1 |
| 24839 | I2 = I1+1 |
| 24840 | ENDIF |
| 24841 | PLAB1X = PLABLX+DBLE(I1-1)*DPLAB |
| 24842 | PLAB2X = PLABLX+DBLE(I2-1)*DPLAB |
| 24843 | PBIN = PLAB2X-PLAB1X |
| 24844 | IF (PBIN.GT.TINY10) THEN |
| 24845 | RATX = (PLABX-PLAB1X)/(PLAB2X-PLAB1X) |
| 24846 | ELSE |
| 24847 | RATX = ZERO |
| 24848 | ENDIF |
| 24849 | IF (JT.EQ.1) THEN |
| 24850 | SIG1 = SIGEP(IDX,I1) |
| 24851 | SIG2 = SIGEP(IDX,I2) |
| 24852 | ELSE |
| 24853 | SIG1 = SIGEN(IDX,I1) |
| 24854 | SIG2 = SIGEN(IDX,I2) |
| 24855 | ENDIF |
| 24856 | SIGE = SIG1+RATX*(SIG2-SIG1) |
| 24857 | ENDIF |
| 24858 | ENDIF |
| 24859 | ENDIF |
| 24860 | |
| 24861 | RETURN |
| 24862 | END |
| 24863 | |
| 24864 | *$ CREATE DT_XSTABL.FOR |
| 24865 | *COPY DT_XSTABL |
| 24866 | * |
| 24867 | *===xstabl=============================================================* |
| 24868 | * |
| 24869 | SUBROUTINE DT_XSTABL(WHAT,IXSQEL,IRATIO) |
| 24870 | |
| 24871 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 24872 | SAVE |
| 24873 | PARAMETER ( LINP = 10 , |
| 24874 | & LOUT = 6 , |
| 24875 | & LDAT = 9 ) |
| 24876 | PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10, |
| 24877 | & OHALF=0.5D0,ONE=1.0D0,TWO=2.0D0) |
| 24878 | LOGICAL LLAB,LELOG,LQLOG |
| 24879 | |
| 24880 | * particle properties (BAMJET index convention) |
| 24881 | CHARACTER*8 ANAME |
| 24882 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 24883 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 24884 | * properties of interacting particles |
| 24885 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG |
| 24886 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 24887 | * Glauber formalism: cross sections |
| 24888 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, |
| 24889 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), |
| 24890 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), |
| 24891 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), |
| 24892 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), |
| 24893 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), |
| 24894 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), |
| 24895 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), |
| 24896 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), |
| 24897 | & BSLOPE,NEBINI,NQBINI |
| 24898 | * emulsion treatment |
| 24899 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), |
| 24900 | & NCOMPO,IEMUL |
| 24901 | |
| 24902 | DIMENSION WHAT(6) |
| 24903 | |
| 24904 | LLAB = (WHAT(1).GT.ZERO).OR.(WHAT(2).GT.ZERO) |
| 24905 | ELO = ABS(WHAT(1)) |
| 24906 | EHI = ABS(WHAT(2)) |
| 24907 | IF (ELO.GT.EHI) ELO = EHI |
| 24908 | LELOG = WHAT(3).LT.ZERO |
| 24909 | NEBINS = MAX(INT(ABS(WHAT(3))),1) |
| 24910 | DEBINS = (EHI-ELO)/DBLE(NEBINS) |
| 24911 | IF (LELOG) THEN |
| 24912 | AELO = LOG10(ELO) |
| 24913 | AEHI = LOG10(EHI) |
| 24914 | ADEBIN = (AEHI-AELO)/DBLE(NEBINS) |
| 24915 | ENDIF |
| 24916 | Q2LO = WHAT(4) |
| 24917 | Q2HI = WHAT(5) |
| 24918 | IF (Q2LO.GT.Q2HI) Q2LO = Q2HI |
| 24919 | LQLOG = WHAT(6).LT.ZERO |
| 24920 | NQBINS = MAX(INT(ABS(WHAT(6))),1) |
| 24921 | DQBINS = (Q2HI-Q2LO)/DBLE(NQBINS) |
| 24922 | IF (LQLOG) THEN |
| 24923 | AQ2LO = LOG10(Q2LO) |
| 24924 | AQ2HI = LOG10(Q2HI) |
| 24925 | ADQBIN = (AQ2HI-AQ2LO)/DBLE(NQBINS) |
| 24926 | ENDIF |
| 24927 | |
| 24928 | IF ( ELO.EQ. EHI) NEBINS = 0 |
| 24929 | IF (Q2LO.EQ.Q2HI) NQBINS = 0 |
| 24930 | |
| 24931 | WRITE(LOUT,1000) ELO,EHI,LLAB,IXSQEL,Q2LO,Q2HI,IJPROJ,IP,IT |
| 24932 | 1000 FORMAT(/,1X,'XSTABL: E_lo =',E10.3,' GeV E_hi =',E10.3, |
| 24933 | & ' GeV Lab = ',L1,' qel: ',I2,/,10X,'Q2_lo =',F10.5, |
| 24934 | & ' GeV^2 Q2_hi =',F10.5,' GeV^2',/,10X,'id_p = ',I2, |
| 24935 | & ' A_p = ',I3,' A_t = ',I3,/) |
| 24936 | |
| 24937 | C IF (IJPROJ.NE.7) THEN |
| 24938 | WRITE(LOUT,'(1X,A,/)')'(E,STOT,SELA,SQEP,SQET,SQE2,SINE,SPROD)' |
| 24939 | * normalize fractions of emulsion components |
| 24940 | IF (NCOMPO.GT.0) THEN |
| 24941 | SUMFRA = ZERO |
| 24942 | DO 10 I=1,NCOMPO |
| 24943 | SUMFRA = SUMFRA+EMUFRA(I) |
| 24944 | 10 CONTINUE |
| 24945 | IF (SUMFRA.GT.ZERO) THEN |
| 24946 | DO 11 I=1,NCOMPO |
| 24947 | EMUFRA(I) = EMUFRA(I)/SUMFRA |
| 24948 | 11 CONTINUE |
| 24949 | ENDIF |
| 24950 | ENDIF |
| 24951 | C ELSE |
| 24952 | C WRITE(LOUT,'(1X,A,/)') '(Q2,E,STOT,ETOT,SIN,EIN,STOT0)' |
| 24953 | C ENDIF |
| 24954 | DO 1 I=1,NEBINS+1 |
| 24955 | IF (LELOG) THEN |
| 24956 | E = 10**(AELO+DBLE(I-1)*ADEBIN) |
| 24957 | ELSE |
| 24958 | E = ELO+DBLE(I-1)*DEBINS |
| 24959 | ENDIF |
| 24960 | DO 2 J=1,NQBINS+1 |
| 24961 | IF (LQLOG) THEN |
| 24962 | Q2 = 10**(AQ2LO+DBLE(J-1)*ADQBIN) |
| 24963 | ELSE |
| 24964 | Q2 = Q2LO+DBLE(J-1)*DQBINS |
| 24965 | ENDIF |
| 24966 | c IF (IJPROJ.NE.7) THEN |
| 24967 | IF (LLAB) THEN |
| 24968 | PLAB = ZERO |
| 24969 | ECM = ZERO |
| 24970 | CALL DT_LTINI(IJPROJ,1,E,PPN0,ECM,0) |
| 24971 | ELSE |
| 24972 | ECM = E |
| 24973 | ENDIF |
| 24974 | XI = ZERO |
| 24975 | Q2I = ZERO |
| 24976 | IF (IJPROJ.EQ.7) Q2I = Q2 |
| 24977 | IF (NCOMPO.GT.0) THEN |
| 24978 | DO 20 IC=1,NCOMPO |
| 24979 | IIT = IEMUMA(IC) |
| 24980 | CALL DT_XSGLAU(IP,IIT,IJPROJ,XI,Q2I,ECM,1,1,-IC) |
| 24981 | 20 CONTINUE |
| 24982 | ELSE |
| 24983 | CALL DT_XSGLAU(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,-1) |
| 24984 | C CALL AMPLIT(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,1) |
| 24985 | ENDIF |
| 24986 | IF (NCOMPO.GT.0) THEN |
| 24987 | XTOT = ZERO |
| 24988 | ETOT = ZERO |
| 24989 | XELA = ZERO |
| 24990 | EELA = ZERO |
| 24991 | XQEP = ZERO |
| 24992 | EQEP = ZERO |
| 24993 | XQET = ZERO |
| 24994 | EQET = ZERO |
| 24995 | XQE2 = ZERO |
| 24996 | EQE2 = ZERO |
| 24997 | XPRO = ZERO |
| 24998 | EPRO = ZERO |
| 24999 | XPRO1= ZERO |
| 25000 | XDEL = ZERO |
| 25001 | EDEL = ZERO |
| 25002 | XDQE = ZERO |
| 25003 | EDQE = ZERO |
| 25004 | DO 21 IC=1,NCOMPO |
| 25005 | XTOT = XTOT+EMUFRA(IC)*XSTOT(1,1,IC) |
| 25006 | ETOT = ETOT+EMUFRA(IC)*XETOT(1,1,IC)**2 |
| 25007 | XELA = XELA+EMUFRA(IC)*XSELA(1,1,IC) |
| 25008 | EELA = EELA+EMUFRA(IC)*XEELA(1,1,IC)**2 |
| 25009 | XQEP = XQEP+EMUFRA(IC)*XSQEP(1,1,IC) |
| 25010 | EQEP = EQEP+EMUFRA(IC)*XEQEP(1,1,IC)**2 |
| 25011 | XQET = XQET+EMUFRA(IC)*XSQET(1,1,IC) |
| 25012 | EQET = EQET+EMUFRA(IC)*XEQET(1,1,IC)**2 |
| 25013 | XQE2 = XQE2+EMUFRA(IC)*XSQE2(1,1,IC) |
| 25014 | EQE2 = EQE2+EMUFRA(IC)*XEQE2(1,1,IC)**2 |
| 25015 | XPRO = XPRO+EMUFRA(IC)*XSPRO(1,1,IC) |
| 25016 | EPRO = EPRO+EMUFRA(IC)*XEPRO(1,1,IC)**2 |
| 25017 | XDEL = XDEL+EMUFRA(IC)*XSDEL(1,1,IC) |
| 25018 | EDEL = EDEL+EMUFRA(IC)*XEDEL(1,1,IC)**2 |
| 25019 | XDQE = XDQE+EMUFRA(IC)*XSDQE(1,1,IC) |
| 25020 | EDQE = EDQE+EMUFRA(IC)*XEDQE(1,1,IC)**2 |
| 25021 | YPRO = XSTOT(1,1,IC)-XSELA(1,1,IC) |
| 25022 | & -XSQEP(1,1,IC)-XSQET(1,1,IC) |
| 25023 | & -XSQE2(1,1,IC) |
| 25024 | XPRO1= XPRO1+EMUFRA(IC)*YPRO |
| 25025 | 21 CONTINUE |
| 25026 | ETOT = SQRT(ETOT) |
| 25027 | EELA = SQRT(EELA) |
| 25028 | EQEP = SQRT(EQEP) |
| 25029 | EQET = SQRT(EQET) |
| 25030 | EQE2 = SQRT(EQE2) |
| 25031 | EPRO = SQRT(EPRO) |
| 25032 | EDEL = SQRT(EDEL) |
| 25033 | EDQE = SQRT(EDQE) |
| 25034 | WRITE(LOUT,'(8E9.3)') |
| 25035 | & E,XTOT,XELA,XQEP,XQET,XQE2,XPRO,XPRO1 |
| 25036 | C WRITE(LOUT,'(4E9.3)') |
| 25037 | C & E,XDEL,XDQE,XDEL+XDQE |
| 25038 | ELSE |
| 25039 | WRITE(LOUT,'(11E10.3)') |
| 25040 | & E, |
| 25041 | & XSTOT(1,1,1),XSELA(1,1,1),XSQEP(1,1,1),XSQET(1,1,1), |
| 25042 | & XSQE2(1,1,1),XSPRO(1,1,1), |
| 25043 | & XSTOT(1,1,1)-XSELA(1,1,1)-XSQEP(1,1,1)-XSQET(1,1,1) |
| 25044 | & -XSQE2(1,1,1),XSDEL(1,1,1),XSDQE(1,1,1), |
| 25045 | & XSDEL(1,1,1)+XSDQE(1,1,1) |
| 25046 | C WRITE(LOUT,'(4E9.3)') E,XSDEL(1,1,1),XSDQE(1,1,1), |
| 25047 | C & XSDEL(1,1,1)+XSDQE(1,1,1) |
| 25048 | ENDIF |
| 25049 | c ELSE |
| 25050 | c IF (LLAB) THEN |
| 25051 | c IF (IT.GT.1) THEN |
| 25052 | c IF (IXSQEL.EQ.0) THEN |
| 25053 | cC CALL DT_SIGGA(IT, Q2, E,ZERO,ZERO, |
| 25054 | cC CALL DT_SIGGA(IT, E,Q2,ZERO,ZERO, |
| 25055 | c CALL DT_SIGGA(IT,ZERO,Q2,ZERO,E, |
| 25056 | c & STOT,ETOT,SIN,EIN,STOT0) |
| 25057 | c IF (IRATIO.EQ.1) THEN |
| 25058 | c CALL DT_SIGGP( Q2, E,ZERO,ZERO,STGP,SIGP,SDGP) |
| 25059 | cC CALL DT_SIGGP( E,Q2,ZERO,ZERO,STGP,SIGP,SDGP) |
| 25060 | cC CALL DT_SIGGP(ZERO,Q2,ZERO,E,STGP,SIGP,SDGP) |
| 25061 | c*!! save cross sections |
| 25062 | c STOTA = STOT |
| 25063 | c ETOTA = ETOT |
| 25064 | c STOTP = STGP |
| 25065 | c*!! |
| 25066 | c STOT = STOT/(DBLE(IT)*STGP) |
| 25067 | c SIN = SIN/(DBLE(IT)*SIGP) |
| 25068 | c STOT0 = STGP |
| 25069 | c ETOT = ZERO |
| 25070 | c EIN = ZERO |
| 25071 | c ENDIF |
| 25072 | c ELSE |
| 25073 | c WRITE(LOUT,*) |
| 25074 | c & ' XSTABL: qel. xs. not implemented for nuclei' |
| 25075 | c STOP |
| 25076 | c ENDIF |
| 25077 | c ELSE |
| 25078 | c ETOT = ZERO |
| 25079 | c EIN = ZERO |
| 25080 | c STOT0= ZERO |
| 25081 | c IF (IXSQEL.EQ.0) THEN |
| 25082 | c CALL DT_SIGGP(ZERO,Q2,ZERO,E,STOT,SIN,SDIR) |
| 25083 | c ELSE |
| 25084 | c SIN = ZERO |
| 25085 | c CALL DT_SIGVEL(ZERO,Q2,ZERO,E,IXSQEL,STOT,SIN,STOT0) |
| 25086 | c ENDIF |
| 25087 | c ENDIF |
| 25088 | c ELSE |
| 25089 | c IF (IT.GT.1) THEN |
| 25090 | c IF (IXSQEL.EQ.0) THEN |
| 25091 | c CALL DT_SIGGA(IT,ZERO,Q2,E,ZERO, |
| 25092 | c & STOT,ETOT,SIN,EIN,STOT0) |
| 25093 | c IF (IRATIO.EQ.1) THEN |
| 25094 | c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STGP,SIGP,SDGP) |
| 25095 | c*!! save cross sections |
| 25096 | c STOTA = STOT |
| 25097 | c ETOTA = ETOT |
| 25098 | c STOTP = STGP |
| 25099 | c*!! |
| 25100 | c STOT = STOT/(DBLE(IT)*STGP) |
| 25101 | c SIN = SIN/(DBLE(IT)*SIGP) |
| 25102 | c STOT0 = STGP |
| 25103 | c ETOT = ZERO |
| 25104 | c EIN = ZERO |
| 25105 | c ENDIF |
| 25106 | c ELSE |
| 25107 | c WRITE(LOUT,*) |
| 25108 | c & ' XSTABL: qel. xs. not implemented for nuclei' |
| 25109 | c STOP |
| 25110 | c ENDIF |
| 25111 | c ELSE |
| 25112 | c ETOT = ZERO |
| 25113 | c EIN = ZERO |
| 25114 | c STOT0= ZERO |
| 25115 | c IF (IXSQEL.EQ.0) THEN |
| 25116 | c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STOT,SIN,SDIR) |
| 25117 | c ELSE |
| 25118 | c SIN = ZERO |
| 25119 | c CALL DT_SIGVEL(ZERO,Q2,E,ZERO,IXSQEL,STOT,SIN,STOT0) |
| 25120 | c ENDIF |
| 25121 | c ENDIF |
| 25122 | c ENDIF |
| 25123 | cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,STOTA,ETOTA,STOTP,ZERO |
| 25124 | cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,SDIR |
| 25125 | cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,STOT0 |
| 25126 | c WRITE(LOUT,'(1X,6E10.3)')Q2,E,STOT,ETOT,SIN,EIN |
| 25127 | c ENDIF |
| 25128 | 2 CONTINUE |
| 25129 | 1 CONTINUE |
| 25130 | |
| 25131 | RETURN |
| 25132 | END |
| 25133 | |
| 25134 | *$ CREATE DT_TESTXS.FOR |
| 25135 | *COPY DT_TESTXS |
| 25136 | * |
| 25137 | *===testxs=============================================================* |
| 25138 | * |
| 25139 | SUBROUTINE DT_TESTXS |
| 25140 | |
| 25141 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 25142 | SAVE |
| 25143 | |
| 25144 | DIMENSION XSTOT(26,2),XSELA(26,2) |
| 25145 | |
| 25146 | OPEN(10,FILE='testxs_ptot.out',STATUS='UNKNOWN') |
| 25147 | OPEN(11,FILE='testxs_pela.out',STATUS='UNKNOWN') |
| 25148 | OPEN(12,FILE='testxs_ntot.out',STATUS='UNKNOWN') |
| 25149 | OPEN(13,FILE='testxs_nela.out',STATUS='UNKNOWN') |
| 25150 | DUMECM = 0.0D0 |
| 25151 | PLABL = 0.01D0 |
| 25152 | PLABH = 10000.0D0 |
| 25153 | NBINS = 120 |
| 25154 | APLABL = LOG10(PLABL) |
| 25155 | APLABH = LOG10(PLABH) |
| 25156 | ADPLAB = (APLABH-APLABL)/DBLE(NBINS) |
| 25157 | DO 1 I=1,NBINS+1 |
| 25158 | ADP = APLABL+DBLE(I-1)*ADPLAB |
| 25159 | P = 10.0D0**ADP |
| 25160 | DO 2 J=1,26 |
| 25161 | CALL DT_XSHN(J,1,P,DUMECM,XSTOT(J,1),XSELA(J,1)) |
| 25162 | CALL DT_XSHN(J,8,P,DUMECM,XSTOT(J,2),XSELA(J,2)) |
| 25163 | 2 CONTINUE |
| 25164 | WRITE(10,1000) P,(XSTOT(K,1),K=1,26) |
| 25165 | WRITE(11,1000) P,(XSELA(K,1),K=1,26) |
| 25166 | WRITE(12,1000) P,(XSTOT(K,2),K=1,26) |
| 25167 | WRITE(13,1000) P,(XSELA(K,2),K=1,26) |
| 25168 | 1 CONTINUE |
| 25169 | 1000 FORMAT(F8.3,26F9.3) |
| 25170 | |
| 25171 | RETURN |
| 25172 | END |
| 25173 | |
| 25174 | ************************************************************************ |
| 25175 | * * |
| 25176 | * DTUNUC 2.0: library routines * |
| 25177 | * processed by S. Roesler, 6.5.95 * |
| 25178 | * * |
| 25179 | ************************************************************************ |
| 25180 | * |
| 25181 | * 1) Handling of parton momenta |
| 25182 | * SUBROUTINE MASHEL |
| 25183 | * SUBROUTINE DFERMI |
| 25184 | * |
| 25185 | * 2) Handling of parton flavors and particle indices |
| 25186 | * INTEGER FUNCTION IPDG2B |
| 25187 | * INTEGER FUNCTION IB2PDG |
| 25188 | * INTEGER FUNCTION IQUARK |
| 25189 | * INTEGER FUNCTION IBJQUA |
| 25190 | * INTEGER FUNCTION ICIHAD |
| 25191 | * INTEGER FUNCTION IPDGHA |
| 25192 | * INTEGER FUNCTION MCHAD |
| 25193 | * SUBROUTINE FLAHAD |
| 25194 | * |
| 25195 | * 3) Energy-momentum and quantum number conservation check routines |
| 25196 | * SUBROUTINE EMC1 |
| 25197 | * SUBROUTINE EMC2 |
| 25198 | * SUBROUTINE EVTEMC |
| 25199 | * SUBROUTINE EVTFLC |
| 25200 | * SUBROUTINE EVTCHG |
| 25201 | * |
| 25202 | * 4) Transformations |
| 25203 | * SUBROUTINE LTINI |
| 25204 | * SUBROUTINE LTRANS |
| 25205 | * SUBROUTINE LTNUC |
| 25206 | * SUBROUTINE DALTRA |
| 25207 | * SUBROUTINE DTRAFO |
| 25208 | * SUBROUTINE STTRAN |
| 25209 | * SUBROUTINE MYTRAN |
| 25210 | * SUBROUTINE LT2LAO |
| 25211 | * SUBROUTINE LT2LAB |
| 25212 | * |
| 25213 | * 5) Sampling from distributions |
| 25214 | * INTEGER FUNCTION NPOISS |
| 25215 | * DOUBLE PRECISION FUNCTION SAMPXB |
| 25216 | * DOUBLE PRECISION FUNCTION SAMPEX |
| 25217 | * DOUBLE PRECISION FUNCTION SAMSQX |
| 25218 | * DOUBLE PRECISION FUNCTION BETREJ |
| 25219 | * DOUBLE PRECISION FUNCTION DGAMRN |
| 25220 | * DOUBLE PRECISION FUNCTION DBETAR |
| 25221 | * SUBROUTINE RANNOR |
| 25222 | * SUBROUTINE DPOLI |
| 25223 | * SUBROUTINE DSFECF |
| 25224 | * SUBROUTINE RACO |
| 25225 | * |
| 25226 | * 6) Special functions, algorithms and service routines |
| 25227 | * DOUBLE PRECISION FUNCTION YLAMB |
| 25228 | * SUBROUTINE SORT |
| 25229 | * SUBROUTINE SORT1 |
| 25230 | * SUBROUTINE DT_XTIME |
| 25231 | * |
| 25232 | * 7) Random number generator package |
| 25233 | * DOUBLE PRECISION FUNCTION DT_RNDM |
| 25234 | * SUBROUTINE DT_RNDMST |
| 25235 | * SUBROUTINE DT_RNDMIN |
| 25236 | * SUBROUTINE DT_RNDMOU |
| 25237 | * SUBROUTINE DT_RNDMTE |
| 25238 | * |
| 25239 | ************************************************************************ |
| 25240 | * * |
| 25241 | * 1) Handling of parton momenta * |
| 25242 | * * |
| 25243 | ************************************************************************ |
| 25244 | *$ CREATE DT_MASHEL.FOR |
| 25245 | *COPY DT_MASHEL |
| 25246 | * |
| 25247 | *===mashel=============================================================* |
| 25248 | * |
| 25249 | SUBROUTINE DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ) |
| 25250 | |
| 25251 | ************************************************************************ |
| 25252 | * * |
| 25253 | * rescaling of momenta of two partons to put both * |
| 25254 | * on mass shell * |
| 25255 | * * |
| 25256 | * input: PA1,PA2 input momentum vectors * |
| 25257 | * XM1,2 desired masses of particles afterwards * |
| 25258 | * P1,P2 changed momentum vectors * |
| 25259 | * * |
| 25260 | * The original version is written by R. Engel. * |
| 25261 | * This version dated 12.12.94 is modified by S. Roesler. * |
| 25262 | ************************************************************************ |
| 25263 | |
| 25264 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 25265 | SAVE |
| 25266 | PARAMETER ( LINP = 10 , |
| 25267 | & LOUT = 6 , |
| 25268 | & LDAT = 9 ) |
| 25269 | PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0) |
| 25270 | |
| 25271 | DIMENSION PA1(4),PA2(4),P1(4),P2(4) |
| 25272 | |
| 25273 | IREJ = 0 |
| 25274 | |
| 25275 | * Lorentz transformation into system CMS |
| 25276 | PX = PA1(1)+PA2(1) |
| 25277 | PY = PA1(2)+PA2(2) |
| 25278 | PZ = PA1(3)+PA2(3) |
| 25279 | EE = PA1(4)+PA2(4) |
| 25280 | XPTOT = SQRT(PX**2+PY**2+PZ**2) |
| 25281 | XMS = (EE-XPTOT)*(EE+XPTOT) |
| 25282 | IF(XMS.LT.(XM1+XM2)**2) THEN |
| 25283 | C WRITE(LOUT,'(3E12.4)')XMS,XM1,XM2 |
| 25284 | GOTO 9999 |
| 25285 | ENDIF |
| 25286 | XMS = SQRT(XMS) |
| 25287 | BGX = PX/XMS |
| 25288 | BGY = PY/XMS |
| 25289 | BGZ = PZ/XMS |
| 25290 | GAM = EE/XMS |
| 25291 | CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3), |
| 25292 | & PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4)) |
| 25293 | * rotation angles |
| 25294 | COD = P1(3)/PTOT1 |
| 25295 | C SID = SQRT((ONE-COD)*(ONE+COD)) |
| 25296 | PPT = SQRT(P1(1)**2+P1(2)**2) |
| 25297 | SID = PPT/PTOT1 |
| 25298 | COF = ONE |
| 25299 | SIF = ZERO |
| 25300 | IF(PTOT1*SID.GT.TINY10) THEN |
| 25301 | COF = P1(1)/(SID*PTOT1) |
| 25302 | SIF = P1(2)/(SID*PTOT1) |
| 25303 | ANORF = SQRT(COF*COF+SIF*SIF) |
| 25304 | COF = COF/ANORF |
| 25305 | SIF = SIF/ANORF |
| 25306 | ENDIF |
| 25307 | * new CM momentum and energies (for masses XM1,XM2) |
| 25308 | XM12 = SIGN(XM1**2,XM1) |
| 25309 | XM22 = SIGN(XM2**2,XM2) |
| 25310 | SS = XMS**2 |
| 25311 | PCMP = DT_YLAMB(SS,XM12,XM22)/(2.D0*XMS) |
| 25312 | EE1 = SQRT(XM12+PCMP**2) |
| 25313 | EE2 = XMS-EE1 |
| 25314 | * back rotation |
| 25315 | MODE = 1 |
| 25316 | CALL DT_MYTRAN(MODE,ZERO,ZERO,PCMP,COD,SID,COF,SIF,XX,YY,ZZ) |
| 25317 | CALL DT_DALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1, |
| 25318 | & PTOT1,P1(1),P1(2),P1(3),P1(4)) |
| 25319 | CALL DT_DALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2, |
| 25320 | & PTOT2,P2(1),P2(2),P2(3),P2(4)) |
| 25321 | * check consistency |
| 25322 | DEL = XMS*0.0001D0 |
| 25323 | IF (ABS(PX-P1(1)-P2(1)).GT.DEL) THEN |
| 25324 | IDEV = 1 |
| 25325 | ELSEIF (ABS(PY-P1(2)-P2(2)).GT.DEL) THEN |
| 25326 | IDEV = 2 |
| 25327 | ELSEIF (ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN |
| 25328 | IDEV = 3 |
| 25329 | ELSEIF (ABS(EE-P1(4)-P2(4)).GT.DEL) THEN |
| 25330 | IDEV = 4 |
| 25331 | ELSE |
| 25332 | IDEV = 0 |
| 25333 | ENDIF |
| 25334 | IF (IDEV.NE.0) THEN |
| 25335 | WRITE(LOUT,'(/1X,A,I3)') |
| 25336 | & 'MASHEL: inconsistent transformation',IDEV |
| 25337 | WRITE(LOUT,'(1X,A)') 'MASHEL: input momenta/masses:' |
| 25338 | WRITE(LOUT,'(1X,5E12.5)') (PA1(K),K=1,4),XM1 |
| 25339 | WRITE(LOUT,'(1X,5E12.5)') (PA2(K),K=1,4),XM2 |
| 25340 | WRITE(LOUT,'(1X,A)') 'MASHEL: output momenta:' |
| 25341 | WRITE(LOUT,'(5X,4E12.5)') (P1(K),K=1,4) |
| 25342 | WRITE(LOUT,'(5X,4E12.5)') (P2(K),K=1,4) |
| 25343 | ENDIF |
| 25344 | RETURN |
| 25345 | |
| 25346 | 9999 CONTINUE |
| 25347 | IREJ = 1 |
| 25348 | RETURN |
| 25349 | END |
| 25350 | |
| 25351 | *$ CREATE DT_DFERMI.FOR |
| 25352 | *COPY DT_DFERMI |
| 25353 | * |
| 25354 | *===dfermi=============================================================* |
| 25355 | * |
| 25356 | SUBROUTINE DT_DFERMI(GPART) |
| 25357 | |
| 25358 | ************************************************************************ |
| 25359 | * Find largest of three random numbers. * |
| 25360 | ************************************************************************ |
| 25361 | |
| 25362 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 25363 | SAVE |
| 25364 | |
| 25365 | DIMENSION G(3) |
| 25366 | |
| 25367 | DO 10 I=1,3 |
| 25368 | G(I)=DT_RNDM(GPART) |
| 25369 | 10 CONTINUE |
| 25370 | IF (G(3).LT.G(2)) GOTO 40 |
| 25371 | IF (G(3).LT.G(1)) GOTO 30 |
| 25372 | GPART = G(3) |
| 25373 | 20 RETURN |
| 25374 | 30 GPART = G(1) |
| 25375 | GOTO 20 |
| 25376 | 40 IF (G(2).LT.G(1)) GOTO 30 |
| 25377 | GPART = G(2) |
| 25378 | GOTO 20 |
| 25379 | |
| 25380 | END |
| 25381 | |
| 25382 | ************************************************************************ |
| 25383 | * * |
| 25384 | * 2) Handling of parton flavors and particle indices * |
| 25385 | * * |
| 25386 | ************************************************************************ |
| 25387 | *$ CREATE IDT_IPDG2B.FOR |
| 25388 | *COPY IDT_IPDG2B |
| 25389 | * |
| 25390 | *===ipdg2b=============================================================* |
| 25391 | * |
| 25392 | INTEGER FUNCTION IDT_IPDG2B(ID,NN,MODE) |
| 25393 | |
| 25394 | ************************************************************************ |
| 25395 | * * |
| 25396 | * conversion of quark numbering scheme * |
| 25397 | * * |
| 25398 | * input: PDG parton numbering * |
| 25399 | * for diquarks: NN number of the constituent quark * |
| 25400 | * (e.g. ID=2301,NN=1 -> ICONV2=1) * |
| 25401 | * * |
| 25402 | * output: BAMJET particle codes * |
| 25403 | * 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) * |
| 25404 | * 2 d 8 a-d -2 a-d * |
| 25405 | * 3 s 9 a-s -3 a-s * |
| 25406 | * 4 c 10 a-c -4 a-c * |
| 25407 | * * |
| 25408 | * This is a modified version of ICONV2 written by R. Engel. * |
| 25409 | * This version dated 13.12.94 is written by S. Roesler. * |
| 25410 | ************************************************************************ |
| 25411 | |
| 25412 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 25413 | SAVE |
| 25414 | PARAMETER ( LINP = 10 , |
| 25415 | & LOUT = 6 , |
| 25416 | & LDAT = 9 ) |
| 25417 | |
| 25418 | IDA = ABS(ID) |
| 25419 | * diquarks |
| 25420 | IF (IDA.GT.6) THEN |
| 25421 | KF = 3 |
| 25422 | IF (IDA.GE.1000) KF = 4 |
| 25423 | IDA = IDA/(10**(KF-NN)) |
| 25424 | IDA = MOD(IDA,10) |
| 25425 | ENDIF |
| 25426 | * exchange up and dn quarks |
| 25427 | IF (IDA.EQ.1) THEN |
| 25428 | IDA = 2 |
| 25429 | ELSEIF (IDA.EQ.2) THEN |
| 25430 | IDA = 1 |
| 25431 | ENDIF |
| 25432 | * antiquarks |
| 25433 | IF (ID.LT.0) THEN |
| 25434 | IF (MODE.EQ.1) THEN |
| 25435 | IDA = IDA+6 |
| 25436 | ELSE |
| 25437 | IDA = -IDA |
| 25438 | ENDIF |
| 25439 | ENDIF |
| 25440 | IDT_IPDG2B = IDA |
| 25441 | |
| 25442 | RETURN |
| 25443 | END |
| 25444 | |
| 25445 | *$ CREATE IDT_IB2PDG.FOR |
| 25446 | *COPY IDT_IB2PDG |
| 25447 | * |
| 25448 | *===ib2pdg=============================================================* |
| 25449 | * |
| 25450 | INTEGER FUNCTION IDT_IB2PDG(ID1,ID2,MODE) |
| 25451 | |
| 25452 | ************************************************************************ |
| 25453 | * * |
| 25454 | * conversion of quark numbering scheme * |
| 25455 | * * |
| 25456 | * input: BAMJET particle codes * |
| 25457 | * 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) * |
| 25458 | * 2 d 8 a-d -2 a-d * |
| 25459 | * 3 s 9 a-s -3 a-s * |
| 25460 | * 4 c 10 a-c -4 a-c * |
| 25461 | * * |
| 25462 | * output: PDG parton numbering * |
| 25463 | * * |
| 25464 | * This version dated 13.12.94 is written by S. Roesler. * |
| 25465 | ************************************************************************ |
| 25466 | |
| 25467 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 25468 | SAVE |
| 25469 | PARAMETER ( LINP = 10 , |
| 25470 | & LOUT = 6 , |
| 25471 | & LDAT = 9 ) |
| 25472 | |
| 25473 | DIMENSION IHKKQ(-6:6),IHKKQQ(-3:3,-3:3) |
| 25474 | DATA IHKKQ/-6,-5,-4,-3,-1,-2,0,2,1,3,4,5,6/ |
| 25475 | DATA IHKKQQ/-3303,-3103,-3203,0,0,0,0, -3103,-1103,-2103,0,0,0,0, |
| 25476 | &-3203,-2103,-2203,0,0,0,0, 0,0,0,0,0,0,0, 0,0,0,0,2203,2103,3203, |
| 25477 | &0,0,0,0,2103,1103,3103, 0,0,0,0,3203,3103,3303/ |
| 25478 | |
| 25479 | IDA = ID1 |
| 25480 | IDB = ID2 |
| 25481 | IF (MODE.EQ.1) THEN |
| 25482 | IF (ID1.GT.6) IDA = -(ID1-6) |
| 25483 | IF (ID2.GT.6) IDB = -(ID2-6) |
| 25484 | ENDIF |
| 25485 | IF (ID2.EQ.0) THEN |
| 25486 | IDT_IB2PDG = IHKKQ(IDA) |
| 25487 | ELSE |
| 25488 | IDT_IB2PDG = IHKKQQ(IDA,IDB) |
| 25489 | ENDIF |
| 25490 | |
| 25491 | RETURN |
| 25492 | END |
| 25493 | |
| 25494 | *$ CREATE IDT_IQUARK.FOR |
| 25495 | *COPY IDT_IQUARK |
| 25496 | * |
| 25497 | *===ipdgqu=============================================================* |
| 25498 | * |
| 25499 | INTEGER FUNCTION IDT_IQUARK(K,IDBAMJ) |
| 25500 | |
| 25501 | ************************************************************************ |
| 25502 | * * |
| 25503 | * quark contents according to PDG conventions * |
| 25504 | * (random selection in case of quark mixing) * |
| 25505 | * * |
| 25506 | * input: IDBAMJ BAMJET particle code * |
| 25507 | * K 1..3 quark number * |
| 25508 | * * |
| 25509 | * output: 1 d (anti --> neg.) * |
| 25510 | * 2 u * |
| 25511 | * 3 s * |
| 25512 | * 4 c * |
| 25513 | * * |
| 25514 | * This version written by R. Engel. * |
| 25515 | ************************************************************************ |
| 25516 | |
| 25517 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 25518 | SAVE |
| 25519 | |
| 25520 | IQ = IDT_IBJQUA(K,IDBAMJ) |
| 25521 | * quark-antiquark |
| 25522 | IF (IQ.GT.6) THEN |
| 25523 | IQ = 6-IQ |
| 25524 | ENDIF |
| 25525 | * exchange of up and down |
| 25526 | IF (ABS(IQ).EQ.1) THEN |
| 25527 | IQ = SIGN(2,IQ) |
| 25528 | ELSEIF (ABS(IQ).EQ.2) THEN |
| 25529 | IQ = SIGN(1,IQ) |
| 25530 | ENDIF |
| 25531 | IDT_IQUARK = IQ |
| 25532 | |
| 25533 | RETURN |
| 25534 | END |
| 25535 | |
| 25536 | *$ CREATE IDT_IBJQUA.FOR |
| 25537 | *COPY IDT_IBJQUA |
| 25538 | * |
| 25539 | *===ibamq==============================================================* |
| 25540 | * |
| 25541 | INTEGER FUNCTION IDT_IBJQUA(K,IDBAMJ) |
| 25542 | |
| 25543 | ************************************************************************ |
| 25544 | * * |
| 25545 | * quark contents according to BAMJET conventions * |
| 25546 | * (random selection in case of quark mixing) * |
| 25547 | * * |
| 25548 | * input: IDBAMJ BAMJET particle code * |
| 25549 | * K 1..3 quark number * |
| 25550 | * * |
| 25551 | * output: 1 u 7 u bar * |
| 25552 | * 2 d 8 d bar * |
| 25553 | * 3 s 9 s bar * |
| 25554 | * 4 c 10 c bar * |
| 25555 | * * |
| 25556 | * This version written by R. Engel. * |
| 25557 | ************************************************************************ |
| 25558 | |
| 25559 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 25560 | SAVE |
| 25561 | |
| 25562 | DIMENSION ITAB(3,210) |
| 25563 | DATA ((ITAB(I,K),I=1,3),K=1,30) / |
| 25564 | & 1, 1, 2, 7, 7, 8, 0, 0, 0, |
| 25565 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 25566 | & 0, 0, 0, 1, 2, 2, 7, 8, 8, |
| 25567 | *sr 10.1.94 |
| 25568 | C & 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 25569 | & 0, 0, 0, 0, 0, 0, 3, 8, 0, |
| 25570 | * |
| 25571 | & 1, 8, 0, 2, 7, 0, 1, 9, 0, |
| 25572 | *sr 10.1.94 |
| 25573 | C & 3, 7, 0, 0, 0, 0, 0, 0, 0, |
| 25574 | & 3, 7, 0, 3, 1, 2, 9, 7, 8, |
| 25575 | *sr 10.1.94 |
| 25576 | C & 0, 0, 0, 2, 2, 3, 1, 1, 3, |
| 25577 | & 2, 9, 0, 2, 2, 3, 1, 1, 3, |
| 25578 | * |
| 25579 | & 1, 2, 3, 201,202, 0, 2, 9, 0, |
| 25580 | & 3, 8, 0, 0, 0, 0, 0, 0, 0, |
| 25581 | & 0, 0, 0, 0, 0, 0, 0, 0, 0 / |
| 25582 | DATA ((ITAB(I,K),I=1,3),K=31,60) / |
| 25583 | & 3, 9, 0, 1, 8, 0, 203,204, 0, |
| 25584 | & 2, 7, 0, 0, 0, 0, 1, 9, 0, |
| 25585 | & 2, 9, 0, 3, 7, 0, 3, 8, 0, |
| 25586 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 25587 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 25588 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 25589 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 25590 | & 0, 0, 0, 1, 1, 1, 1, 1, 2, |
| 25591 | & 1, 2, 2, 2, 2, 2, 0, 0, 0, |
| 25592 | & 0, 0, 0, 0, 0, 0, 0, 0, 0 / |
| 25593 | DATA ((ITAB(I,K),I=1,3),K=61,90) / |
| 25594 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 25595 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 25596 | & 7, 7, 7, 7, 7, 8, 7, 8, 8, |
| 25597 | & 8, 8, 8, 0, 0, 0, 0, 0, 0, |
| 25598 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 25599 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 25600 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 25601 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 25602 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 25603 | & 0, 0, 0, 0, 0, 0, 0, 0, 0 / |
| 25604 | DATA ((ITAB(I,K),I=1,3),K=91,120) / |
| 25605 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 25606 | & 0, 0, 0, 0, 0, 0, 3, 9, 0, |
| 25607 | & 1, 3, 3, 2, 3, 3, 7, 7, 9, |
| 25608 | & 7, 8, 9, 8, 8, 9, 7, 9, 9, |
| 25609 | & 8, 9, 9, 1, 1, 3, 1, 2, 3, |
| 25610 | & 2, 2, 3, 1, 3, 3, 2, 3, 3, |
| 25611 | & 3, 3, 3, 7, 7, 9, 7, 8, 9, |
| 25612 | & 8, 8, 9, 7, 9, 9, 8, 9, 9, |
| 25613 | & 9, 9, 9, 4, 7, 0, 4, 8, 0, |
| 25614 | & 2, 10, 0, 1, 10, 0, 4, 9, 0 / |
| 25615 | DATA ((ITAB(I,K),I=1,3),K=121,150) / |
| 25616 | & 3, 10, 0, 4, 10, 0, 4, 7, 0, |
| 25617 | & 4, 8, 0, 2, 10, 0, 1, 10, 0, |
| 25618 | & 4, 9, 0, 3, 10, 0, 4, 10, 0, |
| 25619 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 25620 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 25621 | & 0, 0, 0, 1, 2, 4, 1, 3, 4, |
| 25622 | & 2, 3, 4, 1, 1, 4, 0, 0, 0, |
| 25623 | & 2, 2, 4, 0, 0, 0, 0, 0, 0, |
| 25624 | & 3, 3, 4, 1, 4, 4, 2, 4, 4, |
| 25625 | & 3, 4, 4, 7, 8, 10, 7, 9, 10 / |
| 25626 | DATA ((ITAB(I,K),I=1,3),K=151,180) / |
| 25627 | & 8, 9, 10, 7, 7, 10, 0, 0, 0, |
| 25628 | & 8, 8, 10, 0, 0, 0, 0, 0, 0, |
| 25629 | & 9, 9, 10, 7, 10, 10, 8, 10, 10, |
| 25630 | & 9, 10, 10, 1, 1, 4, 1, 2, 4, |
| 25631 | & 2, 2, 4, 1, 3, 4, 2, 3, 4, |
| 25632 | & 3, 3, 4, 1, 4, 4, 2, 4, 4, |
| 25633 | & 3, 4, 4, 4, 4, 4, 7, 7, 10, |
| 25634 | & 7, 8, 10, 8, 8, 10, 7, 9, 10, |
| 25635 | & 8, 9, 10, 9, 9, 10, 7, 10, 10, |
| 25636 | & 8, 10, 10, 9, 10, 10, 10, 10, 10 / |
| 25637 | DATA ((ITAB(I,K),I=1,3),K=181,210) / |
| 25638 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 25639 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 25640 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 25641 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 25642 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 25643 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 25644 | & 0, 0, 0, 0, 0, 0, 1, 7, 0, |
| 25645 | & 2, 8, 0, 1, 7, 0, 2, 8, 0, |
| 25646 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 25647 | & 0, 0, 0, 0, 0, 0, 0, 0, 0 / |
| 25648 | DATA IDOLD /0/ |
| 25649 | |
| 25650 | ONE = 1.0D0 |
| 25651 | IF (ITAB(1,IDBAMJ).LE.200) THEN |
| 25652 | ID = ITAB(K,IDBAMJ) |
| 25653 | ELSE |
| 25654 | IF(IDOLD.NE.IDBAMJ) THEN |
| 25655 | IT = AINT((ITAB(2,IDBAMJ)-ITAB(1,IDBAMJ)+0.999999D0)* |
| 25656 | & DT_RNDM(ONE)+ITAB(1,IDBAMJ)) |
| 25657 | ELSE |
| 25658 | IDOLD = 0 |
| 25659 | ENDIF |
| 25660 | ID = ITAB(K,IT) |
| 25661 | ENDIF |
| 25662 | IDOLD = IDBAMJ |
| 25663 | IDT_IBJQUA = ID |
| 25664 | |
| 25665 | RETURN |
| 25666 | END |
| 25667 | |
| 25668 | *$ CREATE IDT_ICIHAD.FOR |
| 25669 | *COPY IDT_ICIHAD |
| 25670 | * |
| 25671 | *===icihad=============================================================* |
| 25672 | * |
| 25673 | INTEGER FUNCTION IDT_ICIHAD(MCIND) |
| 25674 | |
| 25675 | ************************************************************************ |
| 25676 | * Conversion of particle index PDG proposal --> BAMJET-index scheme * |
| 25677 | * This is a completely new version dated 25.10.95. * |
| 25678 | * Renamed to be not in conflict with the modified PHOJET-version * |
| 25679 | ************************************************************************ |
| 25680 | |
| 25681 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 25682 | SAVE |
| 25683 | |
| 25684 | * hadron index conversion (BAMJET <--> PDG) |
| 25685 | COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22), |
| 25686 | & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19), |
| 25687 | & IAMCIN(210) |
| 25688 | |
| 25689 | IDT_ICIHAD = 0 |
| 25690 | KPDG = ABS(MCIND) |
| 25691 | IF ((KPDG.EQ.0).OR.(KPDG.GT.70000)) RETURN |
| 25692 | IF (MCIND.LT.0) THEN |
| 25693 | JSIGN = 1 |
| 25694 | ELSE |
| 25695 | JSIGN = 2 |
| 25696 | ENDIF |
| 25697 | IF (KPDG.GE.10000) THEN |
| 25698 | DO 1 I=1,19 |
| 25699 | IDT_ICIHAD = IBAM5(JSIGN,I) |
| 25700 | IF (IPDG5(JSIGN,I).EQ.MCIND) GOTO 5 |
| 25701 | IDT_ICIHAD = 0 |
| 25702 | 1 CONTINUE |
| 25703 | ELSEIF (KPDG.GE.1000) THEN |
| 25704 | DO 2 I=1,29 |
| 25705 | IDT_ICIHAD = IBAM4(JSIGN,I) |
| 25706 | IF (IPDG4(JSIGN,I).EQ.MCIND) GOTO 5 |
| 25707 | IDT_ICIHAD = 0 |
| 25708 | 2 CONTINUE |
| 25709 | ELSEIF (KPDG.GE.100) THEN |
| 25710 | DO 3 I=1,22 |
| 25711 | IDT_ICIHAD = IBAM3(JSIGN,I) |
| 25712 | IF (IPDG3(JSIGN,I).EQ.MCIND) GOTO 5 |
| 25713 | IDT_ICIHAD = 0 |
| 25714 | 3 CONTINUE |
| 25715 | ELSEIF (KPDG.GE.10) THEN |
| 25716 | DO 4 I=1,7 |
| 25717 | IDT_ICIHAD = IBAM2(JSIGN,I) |
| 25718 | IF (IPDG2(JSIGN,I).EQ.MCIND) GOTO 5 |
| 25719 | IDT_ICIHAD = 0 |
| 25720 | 4 CONTINUE |
| 25721 | ENDIF |
| 25722 | 5 CONTINUE |
| 25723 | |
| 25724 | RETURN |
| 25725 | END |
| 25726 | |
| 25727 | *$ CREATE IDT_IPDGHA.FOR |
| 25728 | *COPY IDT_IPDGHA |
| 25729 | * |
| 25730 | *===ipdgha=============================================================* |
| 25731 | * |
| 25732 | INTEGER FUNCTION IDT_IPDGHA(MCIND) |
| 25733 | |
| 25734 | ************************************************************************ |
| 25735 | * Conversion of particle index BAMJET-index scheme --> PDG proposal * |
| 25736 | * Adopted from the original by S. Roesler. This version dated 12.5.95 * |
| 25737 | * Renamed to be not in conflict with the modified PHOJET-version * |
| 25738 | ************************************************************************ |
| 25739 | |
| 25740 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 25741 | SAVE |
| 25742 | |
| 25743 | * hadron index conversion (BAMJET <--> PDG) |
| 25744 | COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22), |
| 25745 | & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19), |
| 25746 | & IAMCIN(210) |
| 25747 | |
| 25748 | IDT_IPDGHA = IAMCIN(MCIND) |
| 25749 | |
| 25750 | RETURN |
| 25751 | END |
| 25752 | |
| 25753 | *$ CREATE DT_FLAHAD.FOR |
| 25754 | *COPY DT_FLAHAD |
| 25755 | * |
| 25756 | *===flahad=============================================================* |
| 25757 | * |
| 25758 | SUBROUTINE DT_FLAHAD(ID,IF1,IF2,IF3) |
| 25759 | |
| 25760 | ************************************************************************ |
| 25761 | * sampling of FLAvor composition for HADrons/photons * |
| 25762 | * ID BAMJET-id of hadron * |
| 25763 | * IF1,2,3 flavor content * |
| 25764 | * (u,d,s: 1,2,3; au,ad,as: -1,-1,-3) * |
| 25765 | * Note: - u,d numbering as in BAMJET * |
| 25766 | * - ID .le. 30 !! * |
| 25767 | * This version dated 12.03.96 is written by S. Roesler * |
| 25768 | ************************************************************************ |
| 25769 | |
| 25770 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 25771 | SAVE |
| 25772 | |
| 25773 | * auxiliary common for reggeon exchange (DTUNUC 1.x) |
| 25774 | COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6), |
| 25775 | & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6), |
| 25776 | & IQTCHR(-6:6),MQUARK(3,39) |
| 25777 | |
| 25778 | DIMENSION JSEL(3,6) |
| 25779 | DATA JSEL/ 1,2,3, 2,3,1, 3,1,2, 1,3,2, 2,1,3, 3,2,1/ |
| 25780 | |
| 25781 | ONE = 1.0D0 |
| 25782 | IF (ID.EQ.7) THEN |
| 25783 | * photon (charge dependent flavour sampling) |
| 25784 | K = INT(DT_RNDM(ONE)*6.D0+1.D0) |
| 25785 | IF (K.LE.4) THEN |
| 25786 | IF1 = 2 |
| 25787 | IF2 = -2 |
| 25788 | ELSE IF(K.EQ.5) THEN |
| 25789 | IF1 = 1 |
| 25790 | IF2 = -1 |
| 25791 | ELSE |
| 25792 | IF1 = 3 |
| 25793 | IF2 = -3 |
| 25794 | ENDIF |
| 25795 | IF(DT_RNDM(ONE).LT.0.5D0) THEN |
| 25796 | K = IF1 |
| 25797 | IF1 = IF2 |
| 25798 | IF2 = K |
| 25799 | ENDIF |
| 25800 | IF3 = 0 |
| 25801 | ELSE |
| 25802 | * hadron |
| 25803 | IX = INT(1.0D0+5.99999D0*DT_RNDM(ONE)) |
| 25804 | IF1 = MQUARK(JSEL(1,IX),ID) |
| 25805 | IF2 = MQUARK(JSEL(2,IX),ID) |
| 25806 | IF3 = MQUARK(JSEL(3,IX),ID) |
| 25807 | IF ((IF1.EQ.0).AND.(IF3.NE.0)) THEN |
| 25808 | IF1 = IF3 |
| 25809 | IF3 = 0 |
| 25810 | ELSEIF ((IF2.EQ.0).AND.(IF3.NE.0)) THEN |
| 25811 | IF2 = IF3 |
| 25812 | IF3 = 0 |
| 25813 | ENDIF |
| 25814 | ENDIF |
| 25815 | |
| 25816 | RETURN |
| 25817 | END |
| 25818 | |
| 25819 | *$ CREATE IDT_MCHAD.FOR |
| 25820 | *COPY IDT_MCHAD |
| 25821 | * |
| 25822 | *===mchad==============================================================* |
| 25823 | * |
| 25824 | INTEGER FUNCTION IDT_MCHAD(ITDTU) |
| 25825 | |
| 25826 | ************************************************************************ |
| 25827 | * Conversion of particle index BAMJET-index scheme --> HADRIN index s. * |
| 25828 | * Adopted from the original by S. Roesler. This version dated 6.5.95 * |
| 25829 | * * |
| 25830 | * Last change 28.12.2006 by S. Roesler. * |
| 25831 | ************************************************************************ |
| 25832 | |
| 25833 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 25834 | SAVE |
| 25835 | |
| 25836 | DIMENSION ITRANS(210) |
| 25837 | DATA ITRANS / 1, 2, -1, -1, -1, -1, -1, 8, 9, -1, -1, 24, 13, 14, |
| 25838 | &15, 16, 8, 9, 25, 8, 1, 8, 23, 24, 25, -1, -1, -1, -1, -1, 23, 13, |
| 25839 | &23, 14, 23, 15, 24, 16, 25, 15, 24, 16, 25, 15, 24, 16, 25, 1, 8, |
| 25840 | &8, 8, 1, 1, 1, 8, 8, 1, 1, 8, 8, 1, 8, 1, 8, 1, 8, 2, 2, 9, 9, 2, |
| 25841 | &2, 9, 9, 2, 9, 1, 13, 23, 14, 1, 1, 8, 8, 1, 1, 23, 14, 1, 8, 1, |
| 25842 | &8, 1, 8, 23, 23, 8, 8, 2, 9, 9, 9, 9, 1, 8, 8, 8, 8, 8, 2, 9, 9, |
| 25843 | &9, 9, 9, 85*- 1,7*-1,1,8,-1/ |
| 25844 | |
| 25845 | IF ( ITDTU .GT. 0 ) THEN |
| 25846 | IDT_MCHAD = ITRANS(ITDTU) |
| 25847 | ELSE |
| 25848 | IDT_MCHAD = -1 |
| 25849 | END IF |
| 25850 | |
| 25851 | RETURN |
| 25852 | END |
| 25853 | |
| 25854 | ************************************************************************ |
| 25855 | * * |
| 25856 | * 3) Energy-momentum and quantum number conservation check routines * |
| 25857 | * * |
| 25858 | ************************************************************************ |
| 25859 | *$ CREATE DT_EMC1.FOR |
| 25860 | *COPY DT_EMC1 |
| 25861 | * |
| 25862 | *===emc1===============================================================* |
| 25863 | * |
| 25864 | SUBROUTINE DT_EMC1(PP1,PP2,PT1,PT2,MODE,IPOS,IREJ) |
| 25865 | |
| 25866 | ************************************************************************ |
| 25867 | * This version dated 15.12.94 is written by S. Roesler * |
| 25868 | ************************************************************************ |
| 25869 | |
| 25870 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 25871 | SAVE |
| 25872 | PARAMETER ( LINP = 10 , |
| 25873 | & LOUT = 6 , |
| 25874 | & LDAT = 9 ) |
| 25875 | PARAMETER (TINY10=1.0D-10) |
| 25876 | |
| 25877 | DIMENSION PP1(4),PP2(4),PT1(4),PT2(4) |
| 25878 | |
| 25879 | IREJ = 0 |
| 25880 | |
| 25881 | IF ((MODE.EQ.0).OR.(ABS(MODE).GT.3)) |
| 25882 | & WRITE(LOUT,'(1X,A,I6)')'EMC1: not supported MODE ',MODE |
| 25883 | |
| 25884 | IF ((MODE.GT.0).AND.(MODE.LT.3)) THEN |
| 25885 | IF (MODE.EQ.1) THEN |
| 25886 | CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),1,IDUM,IDUM) |
| 25887 | ELSEIF (MODE.EQ.2) THEN |
| 25888 | CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),2,IDUM,IDUM) |
| 25889 | ENDIF |
| 25890 | CALL DT_EVTEMC(PP2(1),PP2(2),PP2(3),PP2(4),2,IDUM,IDUM) |
| 25891 | CALL DT_EVTEMC(PT1(1),PT1(2),PT1(3),PT1(4),2,IDUM,IDUM) |
| 25892 | CALL DT_EVTEMC(PT2(1),PT2(2),PT2(3),PT2(4),2,IDUM,IDUM) |
| 25893 | ELSEIF (MODE.LT.0) THEN |
| 25894 | IF (MODE.EQ.-1) THEN |
| 25895 | CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),1,IDUM,IDUM) |
| 25896 | ELSEIF (MODE.EQ.-2) THEN |
| 25897 | CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),2,IDUM,IDUM) |
| 25898 | ENDIF |
| 25899 | CALL DT_EVTEMC(-PP2(1),-PP2(2),-PP2(3),-PP2(4),2,IDUM,IDUM) |
| 25900 | CALL DT_EVTEMC(-PT1(1),-PT1(2),-PT1(3),-PT1(4),2,IDUM,IDUM) |
| 25901 | CALL DT_EVTEMC(-PT2(1),-PT2(2),-PT2(3),-PT2(4),2,IDUM,IDUM) |
| 25902 | ENDIF |
| 25903 | |
| 25904 | IF (ABS(MODE).EQ.3) THEN |
| 25905 | CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,IPOS,IREJ1) |
| 25906 | IF (IREJ1.NE.0) GOTO 9999 |
| 25907 | ENDIF |
| 25908 | RETURN |
| 25909 | |
| 25910 | 9999 CONTINUE |
| 25911 | IREJ = 1 |
| 25912 | RETURN |
| 25913 | END |
| 25914 | |
| 25915 | *$ CREATE DT_EMC2.FOR |
| 25916 | *COPY DT_EMC2 |
| 25917 | * |
| 25918 | *===emc2===============================================================* |
| 25919 | * |
| 25920 | SUBROUTINE DT_EMC2(IP1,IP2,IP3,IP4,IP5,MP,IN1,IN2,IN3,IN4,IN5,MN, |
| 25921 | & MODE,IPOS,IREJ) |
| 25922 | |
| 25923 | ************************************************************************ |
| 25924 | * MODE = 1 energy-momentum cons. check * |
| 25925 | * = 2 flavor-cons. check * |
| 25926 | * = 3 energy-momentum & flavor cons. check * |
| 25927 | * = 4 energy-momentum & charge cons. check * |
| 25928 | * = 5 energy-momentum & flavor & charge cons. check * |
| 25929 | * This version dated 16.01.95 is written by S. Roesler * |
| 25930 | ************************************************************************ |
| 25931 | |
| 25932 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 25933 | SAVE |
| 25934 | PARAMETER ( LINP = 10 , |
| 25935 | & LOUT = 6 , |
| 25936 | & LDAT = 9 ) |
| 25937 | PARAMETER (TINY10=1.0D-10,ZERO=0.0D0) |
| 25938 | |
| 25939 | * event history |
| 25940 | PARAMETER (NMXHKK=200000) |
| 25941 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 25942 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 25943 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 25944 | * extended event history |
| 25945 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 25946 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 25947 | & IHIST(2,NMXHKK) |
| 25948 | |
| 25949 | IREJ = 0 |
| 25950 | IREJ1 = 0 |
| 25951 | IREJ2 = 0 |
| 25952 | IREJ3 = 0 |
| 25953 | |
| 25954 | IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5)) |
| 25955 | & CALL DT_EVTEMC(ZERO,ZERO,ZERO,ZERO,1,IDUM,IDUM) |
| 25956 | IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5)) |
| 25957 | & CALL DT_EVTFLC(0,IDUM,1,IDUM,IDUM) |
| 25958 | IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,1,IDUM,IDUM) |
| 25959 | DO 1 I=1,NHKK |
| 25960 | IF ((ISTHKK(I).EQ.IP1).OR.(ISTHKK(I).EQ.IP2).OR. |
| 25961 | & (ISTHKK(I).EQ.IP3).OR.(ISTHKK(I).EQ.IP4).OR. |
| 25962 | & (ISTHKK(I).EQ.IP5)) THEN |
| 25963 | IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4) |
| 25964 | & .OR.(MODE.EQ.5)) |
| 25965 | & CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I), |
| 25966 | & 2,IDUM,IDUM) |
| 25967 | IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5)) |
| 25968 | & CALL DT_EVTFLC(IDHKK(I),MP,2,IDUM,IDUM) |
| 25969 | IF ((MODE.EQ.4).OR.(MODE.EQ.5)) |
| 25970 | & CALL DT_EVTCHG(IDHKK(I),2,IDUM,IDUM) |
| 25971 | ENDIF |
| 25972 | IF ((ISTHKK(I).EQ.IN1).OR.(ISTHKK(I).EQ.IN2).OR. |
| 25973 | & (ISTHKK(I).EQ.IN3).OR.(ISTHKK(I).EQ.IN4).OR. |
| 25974 | & (ISTHKK(I).EQ.IN5)) THEN |
| 25975 | IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4) |
| 25976 | & .OR.(MODE.EQ.5)) |
| 25977 | & CALL DT_EVTEMC(-PHKK(1,I),-PHKK(2,I),-PHKK(3,I),-PHKK(4,I), |
| 25978 | & 2,IDUM,IDUM) |
| 25979 | IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5)) |
| 25980 | & CALL DT_EVTFLC(IDHKK(I),MN,-2,IDUM,IDUM) |
| 25981 | IF ((MODE.EQ.4).OR.(MODE.EQ.5)) |
| 25982 | & CALL DT_EVTCHG(IDHKK(I),-2,IDUM,IDUM) |
| 25983 | ENDIF |
| 25984 | 1 CONTINUE |
| 25985 | IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5)) |
| 25986 | & CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,IPOS,IREJ1) |
| 25987 | IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5)) |
| 25988 | & CALL DT_EVTFLC(0,IDUM,3,IPOS,IREJ2) |
| 25989 | IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,3,IPOS,IREJ3) |
| 25990 | IF ((IREJ1.NE.0).OR.(IREJ2.NE.0).OR.(IREJ3.NE.0)) GOTO 9999 |
| 25991 | |
| 25992 | RETURN |
| 25993 | |
| 25994 | 9999 CONTINUE |
| 25995 | IREJ = 1 |
| 25996 | RETURN |
| 25997 | END |
| 25998 | |
| 25999 | *$ CREATE DT_EVTEMC.FOR |
| 26000 | *COPY DT_EVTEMC |
| 26001 | * |
| 26002 | *===evtemc=============================================================* |
| 26003 | * |
| 26004 | SUBROUTINE DT_EVTEMC(PXIO,PYIO,PZIO,EIO,IMODE,IPOS,IREJ) |
| 26005 | |
| 26006 | ************************************************************************ |
| 26007 | * This version dated 13.12.94 is written by S. Roesler * |
| 26008 | ************************************************************************ |
| 26009 | |
| 26010 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 26011 | SAVE |
| 26012 | PARAMETER ( LINP = 10 , |
| 26013 | & LOUT = 6 , |
| 26014 | & LDAT = 9 ) |
| 26015 | PARAMETER (TINY1=1.0D-1,TINY2=1.0D-2,TINY4=1.0D-4,TINY10=1.0D-10, |
| 26016 | & ZERO=0.0D0) |
| 26017 | |
| 26018 | * event history |
| 26019 | PARAMETER (NMXHKK=200000) |
| 26020 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 26021 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 26022 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 26023 | * flags for input different options |
| 26024 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 26025 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 26026 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 26027 | |
| 26028 | IREJ = 0 |
| 26029 | |
| 26030 | MODE = IMODE |
| 26031 | CHKLEV = TINY10 |
| 26032 | IF (MODE.EQ.4) THEN |
| 26033 | CHKLEV = TINY2 |
| 26034 | MODE = 3 |
| 26035 | ELSEIF (MODE.EQ.5) THEN |
| 26036 | CHKLEV = TINY1 |
| 26037 | MODE = 3 |
| 26038 | ELSEIF (MODE.EQ.-1) THEN |
| 26039 | CHKLEV = EIO |
| 26040 | MODE = 3 |
| 26041 | ENDIF |
| 26042 | |
| 26043 | IF (ABS(MODE).EQ.3) THEN |
| 26044 | PXDEV = PX |
| 26045 | PYDEV = PY |
| 26046 | PZDEV = PZ |
| 26047 | EDEV = E |
| 26048 | IF ((IFRAG(1).EQ.2).AND.(CHKLEV.LT.TINY4)) CHKLEV = TINY4 |
| 26049 | IF ((ABS(PXDEV).GT.CHKLEV).OR.(ABS(PYDEV).GT.CHKLEV).OR. |
| 26050 | & (ABS(PZDEV).GT.CHKLEV).OR.(ABS(EDEV).GT.CHKLEV)) THEN |
| 26051 | IF (IOULEV(2).GT.0) WRITE(LOUT,'(1X,A,I4,A,I8,A,/,4G10.3)') |
| 26052 | & 'EVTEMC: energy-momentum cons. failure at pos. ',IPOS, |
| 26053 | & ' event ',NEVHKK, |
| 26054 | & ' ! ',PXDEV,PYDEV,PZDEV,EDEV |
| 26055 | PX = 0.0D0 |
| 26056 | PY = 0.0D0 |
| 26057 | PZ = 0.0D0 |
| 26058 | E = 0.0D0 |
| 26059 | GOTO 9999 |
| 26060 | ENDIF |
| 26061 | PX = 0.0D0 |
| 26062 | PY = 0.0D0 |
| 26063 | PZ = 0.0D0 |
| 26064 | E = 0.0D0 |
| 26065 | RETURN |
| 26066 | ENDIF |
| 26067 | |
| 26068 | IF (MODE.EQ.1) THEN |
| 26069 | PX = 0.0D0 |
| 26070 | PY = 0.0D0 |
| 26071 | PZ = 0.0D0 |
| 26072 | E = 0.0D0 |
| 26073 | ENDIF |
| 26074 | |
| 26075 | PX = PX+PXIO |
| 26076 | PY = PY+PYIO |
| 26077 | PZ = PZ+PZIO |
| 26078 | E = E+EIO |
| 26079 | |
| 26080 | RETURN |
| 26081 | |
| 26082 | 9999 CONTINUE |
| 26083 | IREJ = 1 |
| 26084 | RETURN |
| 26085 | END |
| 26086 | |
| 26087 | *$ CREATE DT_EVTFLC.FOR |
| 26088 | *COPY DT_EVTFLC |
| 26089 | * |
| 26090 | *===evtflc=============================================================* |
| 26091 | * |
| 26092 | SUBROUTINE DT_EVTFLC(ID,ID1,MODE,IPOS,IREJ) |
| 26093 | |
| 26094 | ************************************************************************ |
| 26095 | * Flavor conservation check. * |
| 26096 | * ID identity of particle * |
| 26097 | * ID1 = 1 ID for q,aq,qq,aqaq in PDG-numbering scheme * |
| 26098 | * = 2 ID for particle/resonance in BAMJET numbering scheme * |
| 26099 | * = 3 ID for particle/resonance in PDG numbering scheme * |
| 26100 | * MODE = 1 initialization and add ID * |
| 26101 | * =-1 initialization and subtract ID * |
| 26102 | * = 2 add ID * |
| 26103 | * =-2 subtract ID * |
| 26104 | * = 3 check flavor cons. * |
| 26105 | * IPOS flag to give position of call of EVTFLC to output * |
| 26106 | * unit in case of violation * |
| 26107 | * This version dated 10.01.95 is written by S. Roesler * |
| 26108 | ************************************************************************ |
| 26109 | |
| 26110 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 26111 | SAVE |
| 26112 | PARAMETER ( LINP = 10 , |
| 26113 | & LOUT = 6 , |
| 26114 | & LDAT = 9 ) |
| 26115 | PARAMETER (TINY10=1.0D-10) |
| 26116 | |
| 26117 | IREJ = 0 |
| 26118 | |
| 26119 | IF (MODE.EQ.3) THEN |
| 26120 | IF (IFL.NE.0) THEN |
| 26121 | WRITE(LOUT,'(1X,A,I3,A,I3)') |
| 26122 | & 'EVTFLC: flavor-conservation failure at pos. ',IPOS, |
| 26123 | & ' ! IFL = ',IFL |
| 26124 | IFL = 0 |
| 26125 | GOTO 9999 |
| 26126 | ENDIF |
| 26127 | IFL = 0 |
| 26128 | RETURN |
| 26129 | ENDIF |
| 26130 | |
| 26131 | IF (MODE.EQ.1) IFL = 0 |
| 26132 | IF (ID.EQ.0) RETURN |
| 26133 | |
| 26134 | IF (ID1.EQ.1) THEN |
| 26135 | IDD = ABS(ID) |
| 26136 | NQ = 1 |
| 26137 | IF ((IDD.GE.100).AND.(IDD.LT.1000)) NQ = 2 |
| 26138 | IF (IDD.GE.1000) NQ = 3 |
| 26139 | DO 1 I=1,NQ |
| 26140 | IFBAM = IDT_IPDG2B(ID,I,2) |
| 26141 | IF (ABS(IFBAM).EQ.1) THEN |
| 26142 | IFBAM = SIGN(2,IFBAM) |
| 26143 | ELSEIF (ABS(IFBAM).EQ.2) THEN |
| 26144 | IFBAM = SIGN(1,IFBAM) |
| 26145 | ENDIF |
| 26146 | IF (MODE.GT.0) THEN |
| 26147 | IFL = IFL+IFBAM |
| 26148 | ELSE |
| 26149 | IFL = IFL-IFBAM |
| 26150 | ENDIF |
| 26151 | 1 CONTINUE |
| 26152 | RETURN |
| 26153 | ENDIF |
| 26154 | |
| 26155 | IDD = ID |
| 26156 | IF (ID1.EQ.3) IDD = IDT_ICIHAD(ID) |
| 26157 | IF ((ID1.EQ.2).OR.(ID1.EQ.3)) THEN |
| 26158 | DO 2 I=1,3 |
| 26159 | IF (MODE.GT.0) THEN |
| 26160 | IFL = IFL+IDT_IQUARK(I,IDD) |
| 26161 | ELSE |
| 26162 | IFL = IFL-IDT_IQUARK(I,IDD) |
| 26163 | ENDIF |
| 26164 | 2 CONTINUE |
| 26165 | ENDIF |
| 26166 | RETURN |
| 26167 | |
| 26168 | 9999 CONTINUE |
| 26169 | IREJ = 1 |
| 26170 | RETURN |
| 26171 | END |
| 26172 | |
| 26173 | *$ CREATE DT_EVTCHG.FOR |
| 26174 | *COPY DT_EVTCHG |
| 26175 | * |
| 26176 | *===evtchg=============================================================* |
| 26177 | * |
| 26178 | SUBROUTINE DT_EVTCHG(ID,MODE,IPOS,IREJ) |
| 26179 | |
| 26180 | ************************************************************************ |
| 26181 | * Charge conservation check. * |
| 26182 | * ID identity of particle (PDG-numbering scheme) * |
| 26183 | * MODE = 1 initialization * |
| 26184 | * =-2 subtract ID-charge * |
| 26185 | * = 2 add ID-charge * |
| 26186 | * = 3 check charge cons. * |
| 26187 | * IPOS flag to give position of call of EVTCHG to output * |
| 26188 | * unit in case of violation * |
| 26189 | * This version dated 10.01.95 is written by S. Roesler * |
| 26190 | * Last change: s.r. 21.01.01 * |
| 26191 | ************************************************************************ |
| 26192 | |
| 26193 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 26194 | SAVE |
| 26195 | PARAMETER ( LINP = 10 , |
| 26196 | & LOUT = 6 , |
| 26197 | & LDAT = 9 ) |
| 26198 | |
| 26199 | * event history |
| 26200 | PARAMETER (NMXHKK=200000) |
| 26201 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 26202 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 26203 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 26204 | * particle properties (BAMJET index convention) |
| 26205 | CHARACTER*8 ANAME |
| 26206 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 26207 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 26208 | |
| 26209 | IREJ = 0 |
| 26210 | |
| 26211 | IF (MODE.EQ.1) THEN |
| 26212 | ICH = 0 |
| 26213 | IBAR = 0 |
| 26214 | RETURN |
| 26215 | ENDIF |
| 26216 | |
| 26217 | IF (MODE.EQ.3) THEN |
| 26218 | IF ((ICH.NE.0).OR.(IBAR.NE.0)) THEN |
| 26219 | WRITE(LOUT,'(1X,A,I3,A,2I3,A,I8)') |
| 26220 | & 'EVTCHG: charge/baryo.-cons. failure at pos. ',IPOS, |
| 26221 | & '! ICH/IBAR= ',ICH,IBAR,' event ',NEVHKK |
| 26222 | ICH = 0 |
| 26223 | IBAR = 0 |
| 26224 | GOTO 9999 |
| 26225 | ENDIF |
| 26226 | ICH = 0 |
| 26227 | IBAR = 0 |
| 26228 | RETURN |
| 26229 | ENDIF |
| 26230 | |
| 26231 | IF (ID.EQ.0) RETURN |
| 26232 | |
| 26233 | IDD = IDT_ICIHAD(ID) |
| 26234 | * modification 21.1.01: use intrinsic phojet-functions to determine charge |
| 26235 | * and baryon number |
| 26236 | C IF (IDD.GT.0) THEN |
| 26237 | C IF (MODE.EQ.2) THEN |
| 26238 | C ICH = ICH+IICH(IDD) |
| 26239 | C IBAR = IBAR+IIBAR(IDD) |
| 26240 | C ELSEIF (MODE.EQ.-2) THEN |
| 26241 | C ICH = ICH-IICH(IDD) |
| 26242 | C IBAR = IBAR-IIBAR(IDD) |
| 26243 | C ENDIF |
| 26244 | C ELSE |
| 26245 | C WRITE(LOUT,'(1X,A,3I6)') 'EVTCHG: (IDD = 0 !), IDD,ID=',IDD,ID |
| 26246 | C CALL DT_EVTOUT(4) |
| 26247 | C STOP |
| 26248 | C ENDIF |
| 26249 | IF (MODE.EQ.2) THEN |
| 26250 | ICH = ICH+IPHO_CHR3(ID,1)/3 |
| 26251 | IBAR = IBAR+IPHO_BAR3(ID,1)/3 |
| 26252 | ELSEIF (MODE.EQ.-2) THEN |
| 26253 | ICH = ICH-IPHO_CHR3(ID,1)/3 |
| 26254 | IBAR = IBAR-IPHO_BAR3(ID,1)/3 |
| 26255 | ENDIF |
| 26256 | |
| 26257 | RETURN |
| 26258 | |
| 26259 | 9999 CONTINUE |
| 26260 | IREJ = 1 |
| 26261 | RETURN |
| 26262 | END |
| 26263 | |
| 26264 | ************************************************************************ |
| 26265 | * * |
| 26266 | * 4) Transformations * |
| 26267 | * * |
| 26268 | ************************************************************************ |
| 26269 | *$ CREATE DT_LTINI.FOR |
| 26270 | *COPY DT_LTINI |
| 26271 | * |
| 26272 | *===ltini==============================================================* |
| 26273 | * |
| 26274 | SUBROUTINE DT_LTINI(IDPR,IDTA,EPN0,PPN0,ECM0,MODE) |
| 26275 | |
| 26276 | ************************************************************************ |
| 26277 | * Initializations of Lorentz-transformations, calculation of Lorentz- * |
| 26278 | * parameters. * |
| 26279 | * This version dated 13.11.95 is written by S. Roesler. * |
| 26280 | ************************************************************************ |
| 26281 | |
| 26282 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 26283 | SAVE |
| 26284 | PARAMETER ( LINP = 10 , |
| 26285 | & LOUT = 6 , |
| 26286 | & LDAT = 9 ) |
| 26287 | PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3, |
| 26288 | & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0) |
| 26289 | |
| 26290 | * Lorentz-parameters of the current interaction |
| 26291 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, |
| 26292 | & UMO,PPCM,EPROJ,PPROJ |
| 26293 | * properties of photon/lepton projectiles |
| 26294 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC |
| 26295 | * particle properties (BAMJET index convention) |
| 26296 | CHARACTER*8 ANAME |
| 26297 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 26298 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 26299 | * nucleon-nucleon event-generator |
| 26300 | CHARACTER*8 CMODEL |
| 26301 | LOGICAL LPHOIN |
| 26302 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN |
| 26303 | |
| 26304 | Q2 = VIRT |
| 26305 | IDP = IDPR |
| 26306 | IF (MCGENE.NE.3) THEN |
| 26307 | * lepton-projectiles and PHOJET: initialize real photon instead |
| 26308 | IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR. |
| 26309 | & (IDPR.EQ.10).OR.(IDPR.EQ.11).OR. |
| 26310 | & (IDPR.EQ. 5).OR.(IDPR.EQ. 6)) THEN |
| 26311 | IDP = 7 |
| 26312 | Q2 = ZERO |
| 26313 | ENDIF |
| 26314 | ENDIF |
| 26315 | IDT = IDTA |
| 26316 | EPN = EPN0 |
| 26317 | PPN = PPN0 |
| 26318 | ECM = ECM0 |
| 26319 | AMP = AAM(IDP)-SQRT(ABS(Q2)) |
| 26320 | AMT = AAM(IDT) |
| 26321 | AMP2 = SIGN(AMP**2,AMP) |
| 26322 | AMT2 = AMT**2 |
| 26323 | IF (ECM0.GT.ZERO) THEN |
| 26324 | EPN = (ECM**2-AMP2-AMT2)/(TWO*AMT) |
| 26325 | IF (AMP2.GT.ZERO) THEN |
| 26326 | PPN = SQRT((EPN+AMP)*(EPN-AMP)) |
| 26327 | ELSE |
| 26328 | PPN = SQRT(EPN**2-AMP2) |
| 26329 | ENDIF |
| 26330 | ELSE |
| 26331 | IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN |
| 26332 | IF (IDP.EQ.7) EPN = ABS(EPN) |
| 26333 | IF (EPN.LT.ZERO) EPN = ABS(EPN)+AMP |
| 26334 | IF (AMP2.GT.ZERO) THEN |
| 26335 | PPN = SQRT((EPN+AMP)*(EPN-AMP)) |
| 26336 | ELSE |
| 26337 | PPN = SQRT(EPN**2-AMP2) |
| 26338 | ENDIF |
| 26339 | ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN |
| 26340 | IF (AMP2.GT.ZERO) THEN |
| 26341 | EPN = PPN*SQRT(ONE+(AMP/PPN)**2) |
| 26342 | ELSE |
| 26343 | EPN = SQRT(PPN**2+AMP2) |
| 26344 | ENDIF |
| 26345 | ENDIF |
| 26346 | ECM = SQRT(AMP2+AMT2+TWO*AMT*EPN) |
| 26347 | ENDIF |
| 26348 | UMO = ECM |
| 26349 | EPROJ = EPN |
| 26350 | PPROJ = PPN |
| 26351 | IF (AMP2.GT.ZERO) THEN |
| 26352 | ETARG = (ECM**2-AMP2-AMT2)/(TWO*AMP) |
| 26353 | PTARG = -SQRT((ETARG+AMT)*(ETARG-AMT)) |
| 26354 | ELSE |
| 26355 | ETARG = TINY10 |
| 26356 | PTARG = TINY10 |
| 26357 | ENDIF |
| 26358 | * photon-projectiles (get momentum in cm-frame for virtuality Q^2) |
| 26359 | IF (IDP.EQ.7) THEN |
| 26360 | PGAMM(1) = ZERO |
| 26361 | PGAMM(2) = ZERO |
| 26362 | AMGAM = AMP |
| 26363 | AMGAM2 = AMP2 |
| 26364 | IF (ECM0.GT.ZERO) THEN |
| 26365 | S = ECM0**2 |
| 26366 | ELSE |
| 26367 | IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN |
| 26368 | S = AMGAM2+AMT2+TWO*AMT*ABS(EPN0) |
| 26369 | ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN |
| 26370 | S = AMGAM2+AMT2+TWO*AMT*SQRT(PPN0**2+AMGAM2) |
| 26371 | ENDIF |
| 26372 | ENDIF |
| 26373 | PGAMM(3) = SQRT( (S**2-TWO*AMGAM2*S-TWO*AMT2*S-TWO*AMGAM2*AMT2 |
| 26374 | & +AMGAM2**2+AMT2**2)/(4.0D0*S) ) |
| 26375 | PGAMM(4) = SQRT(AMGAM2+PGAMM(3)**2) |
| 26376 | IF (MODE.EQ.1) THEN |
| 26377 | PNUCL(1) = ZERO |
| 26378 | PNUCL(2) = ZERO |
| 26379 | PNUCL(3) = -PGAMM(3) |
| 26380 | PNUCL(4) = SQRT(S)-PGAMM(4) |
| 26381 | ENDIF |
| 26382 | ENDIF |
| 26383 | IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR. |
| 26384 | & (IDPR.EQ.10).OR.(IDPR.EQ.11)) THEN |
| 26385 | PLEPT0(1) = ZERO |
| 26386 | PLEPT0(2) = ZERO |
| 26387 | * neglect lepton masses |
| 26388 | C AMLPT2 = AAM(IDPR)**2 |
| 26389 | AMLPT2 = ZERO |
| 26390 | * |
| 26391 | IF (ECM0.GT.ZERO) THEN |
| 26392 | S = ECM0**2 |
| 26393 | ELSE |
| 26394 | IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN |
| 26395 | S = AMLPT2+AMT2+TWO*AMT*ABS(EPN0) |
| 26396 | ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN |
| 26397 | S = AMLPT2+AMT2+TWO*AMT*SQRT(PPN0**2+AMLPT2) |
| 26398 | ENDIF |
| 26399 | ENDIF |
| 26400 | PLEPT0(3) = SQRT( (S**2-TWO*AMLPT2*S-TWO*AMT2*S-TWO*AMLPT2*AMT2 |
| 26401 | & +AMLPT2**2+AMT2**2)/(4.0D0*S) ) |
| 26402 | PLEPT0(4) = SQRT(AMLPT2+PLEPT0(3)**2) |
| 26403 | PNUCL(1) = ZERO |
| 26404 | PNUCL(2) = ZERO |
| 26405 | PNUCL(3) = -PLEPT0(3) |
| 26406 | PNUCL(4) = SQRT(S)-PLEPT0(4) |
| 26407 | ENDIF |
| 26408 | * Lorentz-parameter for transformation Lab. - projectile rest system |
| 26409 | IF ((IDP.EQ.7).OR.(AMP.LT.TINY10)) THEN |
| 26410 | GALAB = TINY10 |
| 26411 | BGLAB = TINY10 |
| 26412 | BLAB = TINY10 |
| 26413 | ELSE |
| 26414 | GALAB = EPROJ/AMP |
| 26415 | BGLAB = PPROJ/AMP |
| 26416 | BLAB = BGLAB/GALAB |
| 26417 | ENDIF |
| 26418 | * Lorentz-parameter for transf. proj. rest sys. - nucl.-nucl. cms. |
| 26419 | IF (IDP.EQ.7) THEN |
| 26420 | GACMS(1) = TINY10 |
| 26421 | BGCMS(1) = TINY10 |
| 26422 | ELSE |
| 26423 | GACMS(1) = (ETARG+AMP)/UMO |
| 26424 | BGCMS(1) = PTARG/UMO |
| 26425 | ENDIF |
| 26426 | * Lorentz-parameter for transformation Lab. - nucl.-nucl. cms. |
| 26427 | GACMS(2) = (EPROJ+AMT)/UMO |
| 26428 | BGCMS(2) = PPROJ/UMO |
| 26429 | PPCM = GACMS(2)*PPROJ-BGCMS(2)*EPROJ |
| 26430 | |
| 26431 | EPN0 = EPN |
| 26432 | PPN0 = PPN |
| 26433 | ECM0 = ECM |
| 26434 | |
| 26435 | RETURN |
| 26436 | END |
| 26437 | |
| 26438 | *$ CREATE DT_LTRANS.FOR |
| 26439 | *COPY DT_LTRANS |
| 26440 | * |
| 26441 | *===ltrans=============================================================* |
| 26442 | * |
| 26443 | SUBROUTINE DT_LTRANS(PXI,PYI,PZI,PEI,PXO,PYO,PZO,PEO,ID,MODE) |
| 26444 | |
| 26445 | ************************************************************************ |
| 26446 | * Lorentz-transformations. * |
| 26447 | * MODE = 1(-1) projectile rest syst. --> Lab (back) * |
| 26448 | * = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) * |
| 26449 | * = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) * |
| 26450 | * This version dated 01.11.95 is written by S. Roesler. * |
| 26451 | ************************************************************************ |
| 26452 | |
| 26453 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 26454 | SAVE |
| 26455 | PARAMETER ( LINP = 10 , |
| 26456 | & LOUT = 6 , |
| 26457 | & LDAT = 9 ) |
| 26458 | PARAMETER (TINY3=1.0D-3,ZERO=0.0D0,TWO=2.0D0) |
| 26459 | |
| 26460 | PARAMETER (SQTINF=1.0D+15) |
| 26461 | |
| 26462 | * particle properties (BAMJET index convention) |
| 26463 | CHARACTER*8 ANAME |
| 26464 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 26465 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 26466 | |
| 26467 | PXO = PXI |
| 26468 | PYO = PYI |
| 26469 | CALL DT_LTNUC(PZI,PEI,PZO,PEO,MODE) |
| 26470 | |
| 26471 | * check particle mass for consistency (numerical rounding errors) |
| 26472 | PO = SQRT(PXO*PXO+PYO*PYO+PZO*PZO) |
| 26473 | AMO2 = (PEO-PO)*(PEO+PO) |
| 26474 | AMORQ2 = AAM(ID)**2 |
| 26475 | AMDIF2 = ABS(AMO2-AMORQ2) |
| 26476 | IF ((AMDIF2.GT.TINY3).AND.(PEO.LT.SQTINF).AND.(PO.GT.ZERO)) THEN |
| 26477 | DELTA = (AMORQ2-AMO2)/(TWO*(PEO+PO)) |
| 26478 | PEO = PEO+DELTA |
| 26479 | PO1 = PO -DELTA |
| 26480 | PXO = PXO*PO1/PO |
| 26481 | PYO = PYO*PO1/PO |
| 26482 | PZO = PZO*PO1/PO |
| 26483 | C WRITE(6,*) 'LTRANS corrected', AMDIF2,PZI,PEI,PZO,PEO,MODE,ID |
| 26484 | ENDIF |
| 26485 | |
| 26486 | RETURN |
| 26487 | END |
| 26488 | |
| 26489 | *$ CREATE DT_LTNUC.FOR |
| 26490 | *COPY DT_LTNUC |
| 26491 | * |
| 26492 | *===ltnuc==============================================================* |
| 26493 | * |
| 26494 | SUBROUTINE DT_LTNUC(PIN,EIN,POUT,EOUT,MODE) |
| 26495 | |
| 26496 | ************************************************************************ |
| 26497 | * Lorentz-transformations. * |
| 26498 | * PIN longitudnal momentum (input) * |
| 26499 | * EIN energy (input) * |
| 26500 | * POUT transformed long. momentum (output) * |
| 26501 | * EOUT transformed energy (output) * |
| 26502 | * MODE = 1(-1) projectile rest syst. --> Lab (back) * |
| 26503 | * = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) * |
| 26504 | * = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) * |
| 26505 | * This version dated 01.11.95 is written by S. Roesler. * |
| 26506 | ************************************************************************ |
| 26507 | |
| 26508 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 26509 | SAVE |
| 26510 | PARAMETER ( LINP = 10 , |
| 26511 | & LOUT = 6 , |
| 26512 | & LDAT = 9 ) |
| 26513 | PARAMETER (ZERO=0.0D0) |
| 26514 | |
| 26515 | * Lorentz-parameters of the current interaction |
| 26516 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, |
| 26517 | & UMO,PPCM,EPROJ,PPROJ |
| 26518 | |
| 26519 | BDUM1 = ZERO |
| 26520 | BDUM2 = ZERO |
| 26521 | PDUM1 = ZERO |
| 26522 | PDUM2 = ZERO |
| 26523 | IF (ABS(MODE).EQ.1) THEN |
| 26524 | BG = -SIGN(BGLAB,DBLE(MODE)) |
| 26525 | CALL DT_DALTRA(GALAB,BDUM1,BDUM2,-BG,PDUM1,PDUM2,PIN,EIN, |
| 26526 | & DUM1,DUM2,DUM3,POUT,EOUT) |
| 26527 | ELSEIF (ABS(MODE).EQ.2) THEN |
| 26528 | BG = SIGN(BGCMS(1),DBLE(MODE)) |
| 26529 | CALL DT_DALTRA(GACMS(1),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN, |
| 26530 | & DUM1,DUM2,DUM3,POUT,EOUT) |
| 26531 | ELSEIF (ABS(MODE).EQ.3) THEN |
| 26532 | BG = -SIGN(BGCMS(2),DBLE(MODE)) |
| 26533 | CALL DT_DALTRA(GACMS(2),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN, |
| 26534 | & DUM1,DUM2,DUM3,POUT,EOUT) |
| 26535 | ELSE |
| 26536 | WRITE(LOUT,1000) MODE |
| 26537 | 1000 FORMAT(1X,'LTNUC: not supported mode (MODE = ',I3,')') |
| 26538 | EOUT = EIN |
| 26539 | POUT = PIN |
| 26540 | ENDIF |
| 26541 | |
| 26542 | RETURN |
| 26543 | END |
| 26544 | |
| 26545 | *$ CREATE DT_DALTRA.FOR |
| 26546 | *COPY DT_DALTRA |
| 26547 | * |
| 26548 | *===daltra=============================================================* |
| 26549 | * |
| 26550 | SUBROUTINE DT_DALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E) |
| 26551 | |
| 26552 | ************************************************************************ |
| 26553 | * Arbitrary Lorentz-transformation. * |
| 26554 | * Adopted from the original by S. Roesler. This version dated 15.01.95 * |
| 26555 | ************************************************************************ |
| 26556 | |
| 26557 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 26558 | SAVE |
| 26559 | PARAMETER (ONE=1.0D0) |
| 26560 | |
| 26561 | EP = PCX*BGX+PCY*BGY+PCZ*BGZ |
| 26562 | PE = EP/(GA+ONE)+EC |
| 26563 | PX = PCX+BGX*PE |
| 26564 | PY = PCY+BGY*PE |
| 26565 | PZ = PCZ+BGZ*PE |
| 26566 | P = SQRT(PX*PX+PY*PY+PZ*PZ) |
| 26567 | E = GA*EC+EP |
| 26568 | |
| 26569 | RETURN |
| 26570 | END |
| 26571 | |
| 26572 | *$ CREATE DT_DTRAFO.FOR |
| 26573 | *COPY DT_DTRAFO |
| 26574 | * |
| 26575 | *====dtrafo============================================================* |
| 26576 | * |
| 26577 | SUBROUTINE DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM, |
| 26578 | & PL,CXL,CYL,CZL,EL) |
| 26579 | |
| 26580 | C LORENTZ TRANSFORMATION INTO THE LAB - SYSTEM |
| 26581 | |
| 26582 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 26583 | SAVE |
| 26584 | |
| 26585 | IF (ABS(COD).GT.1.0D0) COD = SIGN(1.0D0,COD) |
| 26586 | SID = SQRT(1.D0-COD*COD) |
| 26587 | PLX = P*SID*COF |
| 26588 | PLY = P*SID*SIF |
| 26589 | PCMZ = P*COD |
| 26590 | PLZ = GAM*PCMZ+BGAM*ECM |
| 26591 | PL = SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ) |
| 26592 | EL = GAM*ECM+BGAM*PCMZ |
| 26593 | C ROTATION INTO THE ORIGINAL DIRECTION |
| 26594 | COZ = PLZ/PL |
| 26595 | SIZ = SQRT(1.D0-COZ**2) |
| 26596 | CALL DT_STTRAN(CX,CY,CZ,COZ,SIZ,SIF,COF,CXL,CYL,CZL) |
| 26597 | |
| 26598 | RETURN |
| 26599 | END |
| 26600 | |
| 26601 | *$ CREATE DT_STTRAN.FOR |
| 26602 | *COPY DT_STTRAN |
| 26603 | * |
| 26604 | *====sttran============================================================* |
| 26605 | * |
| 26606 | SUBROUTINE DT_STTRAN(XO,YO,ZO,CDE,SDE,SFE,CFE,X,Y,Z) |
| 26607 | |
| 26608 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 26609 | SAVE |
| 26610 | DATA ANGLSQ/1.D-30/ |
| 26611 | ************************************************************************ |
| 26612 | * VERSION BY J. RANFT * |
| 26613 | * LEIPZIG * |
| 26614 | * * |
| 26615 | * THIS IS A SUBROUTINE OF FLUKA TO GIVE NEW DIRECTION COSINES * |
| 26616 | * * |
| 26617 | * INPUT VARIABLES: * |
| 26618 | * XO,YO,ZO = ORIGINAL DIRECTION COSINES * |
| 26619 | * CDE,SDE = COSINE AND SINE OF THE POLAR (THETA) * |
| 26620 | * ANGLE OF "SCATTERING" * |
| 26621 | * SDE = SINE OF THE POLAR (THETA) ANGLE OF "SCATTERING" * |
| 26622 | * SFE,CFE = SINE AND COSINE OF THE AZIMUTHAL (PHI) ANGLE * |
| 26623 | * OF "SCATTERING" * |
| 26624 | * * |
| 26625 | * OUTPUT VARIABLES: * |
| 26626 | * X,Y,Z = NEW DIRECTION COSINES * |
| 26627 | * * |
| 26628 | * ROTATION OF COORDINATE SYSTEM (SEE CERN 64-47 ) * |
| 26629 | ************************************************************************ |
| 26630 | * |
| 26631 | * |
| 26632 | * Changed by A. Ferrari |
| 26633 | * |
| 26634 | * IF (ABS(XO)-0.0001D0) 1,1,2 |
| 26635 | * 1 IF (ABS(YO)-0.0001D0) 3,3,2 |
| 26636 | * 3 CONTINUE |
| 26637 | A = XO**2 + YO**2 |
| 26638 | IF ( A .LT. ANGLSQ ) THEN |
| 26639 | X=SDE*CFE |
| 26640 | Y=SDE*SFE |
| 26641 | Z=CDE*ZO |
| 26642 | ELSE |
| 26643 | XI=SDE*CFE |
| 26644 | YI=SDE*SFE |
| 26645 | ZI=CDE |
| 26646 | A=SQRT(A) |
| 26647 | X=-YO*XI/A-ZO*XO*YI/A+XO*ZI |
| 26648 | Y=XO*XI/A-ZO*YO*YI/A+YO*ZI |
| 26649 | Z=A*YI+ZO*ZI |
| 26650 | ENDIF |
| 26651 | |
| 26652 | RETURN |
| 26653 | END |
| 26654 | |
| 26655 | *$ CREATE DT_MYTRAN.FOR |
| 26656 | *COPY DT_MYTRAN |
| 26657 | * |
| 26658 | *===mytran=============================================================* |
| 26659 | * |
| 26660 | SUBROUTINE DT_MYTRAN(IMODE,XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z) |
| 26661 | |
| 26662 | ************************************************************************ |
| 26663 | * This subroutine rotates the coordinate frame * |
| 26664 | * a) theta around y * |
| 26665 | * b) phi around z if IMODE = 1 * |
| 26666 | * * |
| 26667 | * x' cos(ph) -sin(ph) 0 cos(th) 0 sin(th) x * |
| 26668 | * y' = A B = sin(ph) cos(ph) 0 . 0 1 0 y * |
| 26669 | * z' 0 0 1 -sin(th) 0 cos(th) z * |
| 26670 | * * |
| 26671 | * and vice versa if IMODE = 0. * |
| 26672 | * This version dated 5.4.94 is based on the original version DTRAN * |
| 26673 | * by J. Ranft and is written by S. Roesler. * |
| 26674 | ************************************************************************ |
| 26675 | |
| 26676 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 26677 | SAVE |
| 26678 | PARAMETER ( LINP = 10 , |
| 26679 | & LOUT = 6 , |
| 26680 | & LDAT = 9 ) |
| 26681 | |
| 26682 | IF (IMODE.EQ.1) THEN |
| 26683 | X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO |
| 26684 | Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO |
| 26685 | Z=-SDE *XO +CDE *ZO |
| 26686 | ELSE |
| 26687 | X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO |
| 26688 | Y= -SFE*XO+CFE*YO |
| 26689 | Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO |
| 26690 | ENDIF |
| 26691 | RETURN |
| 26692 | END |
| 26693 | |
| 26694 | *$ CREATE DT_LT2LAO.FOR |
| 26695 | *COPY DT_LT2LAO |
| 26696 | * |
| 26697 | *===lt2lab=============================================================* |
| 26698 | * |
| 26699 | SUBROUTINE DT_LT2LAO |
| 26700 | |
| 26701 | ************************************************************************ |
| 26702 | * Lorentz-transformation to lab-system. This subroutine scans DTEVT1 * |
| 26703 | * for final state particles/fragments defined in nucleon-nucleon-cms * |
| 26704 | * and transforms them back to the lab. * |
| 26705 | * This version dated 16.11.95 is written by S. Roesler * |
| 26706 | ************************************************************************ |
| 26707 | |
| 26708 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 26709 | SAVE |
| 26710 | PARAMETER ( LINP = 10 , |
| 26711 | & LOUT = 6 , |
| 26712 | & LDAT = 9 ) |
| 26713 | |
| 26714 | * event history |
| 26715 | PARAMETER (NMXHKK=200000) |
| 26716 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 26717 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 26718 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 26719 | * extended event history |
| 26720 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 26721 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 26722 | & IHIST(2,NMXHKK) |
| 26723 | |
| 26724 | NEND = NHKK |
| 26725 | NPOINT(5) = NHKK+1 |
| 26726 | IF ( (NPOINT(4).EQ.0).OR.(NEND.LT.NPOINT(4)) ) RETURN |
| 26727 | DO 1 I=NPOINT(4),NEND |
| 26728 | C DO 1 I=1,NEND |
| 26729 | IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR. |
| 26730 | & (ISTHKK(I).EQ.1001)) THEN |
| 26731 | CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3) |
| 26732 | NOB = NOBAM(I) |
| 26733 | CALL DT_EVTPUT(ISTHKK(I),IDHKK(I),I,0,PHKK(1,I),PHKK(2,I), |
| 26734 | & PZ,PE,IDRES(I),IDXRES(I),IDCH(I)) |
| 26735 | IF ((ISTHKK(I).EQ.1000).OR.(ISTHKK(I).EQ.1001)) THEN |
| 26736 | ISTHKK(I) = 3*ISTHKK(I) |
| 26737 | NOBAM(NHKK) = NOB |
| 26738 | ELSE |
| 26739 | IF (ISTHKK(I).EQ.-1) NOBAM(NHKK) = NOB |
| 26740 | ISTHKK(I) = SIGN(3,ISTHKK(I)) |
| 26741 | ENDIF |
| 26742 | JDAHKK(1,I) = NHKK |
| 26743 | ENDIF |
| 26744 | 1 CONTINUE |
| 26745 | |
| 26746 | RETURN |
| 26747 | END |
| 26748 | |
| 26749 | *$ CREATE DT_LT2LAB.FOR |
| 26750 | *COPY DT_LT2LAB |
| 26751 | * |
| 26752 | *===lt2lab=============================================================* |
| 26753 | * |
| 26754 | SUBROUTINE DT_LT2LAB |
| 26755 | |
| 26756 | ************************************************************************ |
| 26757 | * Lorentz-transformation to lab-system. This subroutine scans DTEVT1 * |
| 26758 | * for final state particles/fragments defined in nucleon-nucleon-cms * |
| 26759 | * and transforms them to the lab. * |
| 26760 | * This version dated 07.01.96 is written by S. Roesler * |
| 26761 | ************************************************************************ |
| 26762 | |
| 26763 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 26764 | SAVE |
| 26765 | PARAMETER ( LINP = 10 , |
| 26766 | & LOUT = 6 , |
| 26767 | & LDAT = 9 ) |
| 26768 | |
| 26769 | * event history |
| 26770 | PARAMETER (NMXHKK=200000) |
| 26771 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 26772 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 26773 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 26774 | * extended event history |
| 26775 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 26776 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 26777 | & IHIST(2,NMXHKK) |
| 26778 | |
| 26779 | IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN |
| 26780 | DO 1 I=NPOINT(4),NHKK |
| 26781 | IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR. |
| 26782 | & (ISTHKK(I).EQ.1001)) THEN |
| 26783 | CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3) |
| 26784 | PHKK(3,I) = PZ |
| 26785 | PHKK(4,I) = PE |
| 26786 | ENDIF |
| 26787 | 1 CONTINUE |
| 26788 | |
| 26789 | RETURN |
| 26790 | END |
| 26791 | |
| 26792 | ************************************************************************ |
| 26793 | * * |
| 26794 | * 5) Sampling from distributions * |
| 26795 | * * |
| 26796 | ************************************************************************ |
| 26797 | *$ CREATE IDT_NPOISS.FOR |
| 26798 | *COPY IDT_NPOISS |
| 26799 | * |
| 26800 | *===npoiss=============================================================* |
| 26801 | * |
| 26802 | INTEGER FUNCTION IDT_NPOISS(AVN) |
| 26803 | |
| 26804 | ************************************************************************ |
| 26805 | * Sample according to Poisson distribution with Poisson parameter AVN. * |
| 26806 | * The original version written by J. Ranft. * |
| 26807 | * This version dated 11.1.95 is written by S. Roesler. * |
| 26808 | ************************************************************************ |
| 26809 | |
| 26810 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 26811 | SAVE |
| 26812 | PARAMETER ( LINP = 10 , |
| 26813 | & LOUT = 6 , |
| 26814 | & LDAT = 9 ) |
| 26815 | |
| 26816 | EXPAVN = EXP(-AVN) |
| 26817 | K = 1 |
| 26818 | A = 1.0D0 |
| 26819 | |
| 26820 | 10 CONTINUE |
| 26821 | A = DT_RNDM(A)*A |
| 26822 | IF (A.GE.EXPAVN) THEN |
| 26823 | K = K+1 |
| 26824 | GOTO 10 |
| 26825 | ENDIF |
| 26826 | IDT_NPOISS = K-1 |
| 26827 | |
| 26828 | RETURN |
| 26829 | END |
| 26830 | |
| 26831 | *$ CREATE DT_SAMPXB.FOR |
| 26832 | *COPY DT_SAMPXB |
| 26833 | * |
| 26834 | *===sampxb=============================================================* |
| 26835 | * |
| 26836 | DOUBLE PRECISION FUNCTION DT_SAMPXB(X1,X2,B) |
| 26837 | |
| 26838 | ************************************************************************ |
| 26839 | * Sampling from f(x)=1./SQRT(X**2+B**2) between x1 and x2. * |
| 26840 | * Processed by S. Roesler, 6.5.95 * |
| 26841 | ************************************************************************ |
| 26842 | |
| 26843 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 26844 | SAVE |
| 26845 | PARAMETER (TWO=2.0D0) |
| 26846 | |
| 26847 | A1 = LOG(X1+SQRT(X1**2+B**2)) |
| 26848 | A2 = LOG(X2+SQRT(X2**2+B**2)) |
| 26849 | AN = A2-A1 |
| 26850 | A = AN*DT_RNDM(A1)+A1 |
| 26851 | BB = EXP(A) |
| 26852 | DT_SAMPXB = (BB**2-B**2)/(TWO*BB) |
| 26853 | |
| 26854 | RETURN |
| 26855 | END |
| 26856 | |
| 26857 | *$ CREATE DT_SAMPEX.FOR |
| 26858 | *COPY DT_SAMPEX |
| 26859 | * |
| 26860 | *===sampex=============================================================* |
| 26861 | * |
| 26862 | DOUBLE PRECISION FUNCTION DT_SAMPEX(X1,X2) |
| 26863 | |
| 26864 | ************************************************************************ |
| 26865 | * Sampling from f(x)=1./x between x1 and x2. * |
| 26866 | * Processed by S. Roesler, 6.5.95 * |
| 26867 | ************************************************************************ |
| 26868 | |
| 26869 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 26870 | SAVE |
| 26871 | PARAMETER (ONE=1.0D0) |
| 26872 | |
| 26873 | R = DT_RNDM(X1) |
| 26874 | AL1 = LOG(X1) |
| 26875 | AL2 = LOG(X2) |
| 26876 | DT_SAMPEX = EXP((ONE-R)*AL1+R*AL2) |
| 26877 | |
| 26878 | RETURN |
| 26879 | END |
| 26880 | |
| 26881 | *$ CREATE DT_SAMSQX.FOR |
| 26882 | *COPY DT_SAMSQX |
| 26883 | * |
| 26884 | *===samsqx=============================================================* |
| 26885 | * |
| 26886 | DOUBLE PRECISION FUNCTION DT_SAMSQX(X1,X2) |
| 26887 | |
| 26888 | ************************************************************************ |
| 26889 | * Sampling from f(x)=1./x^0.5 between x1 and x2. * |
| 26890 | * Processed by S. Roesler, 6.5.95 * |
| 26891 | ************************************************************************ |
| 26892 | |
| 26893 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 26894 | SAVE |
| 26895 | PARAMETER (ONE=1.0D0) |
| 26896 | |
| 26897 | R = DT_RNDM(X1) |
| 26898 | DT_SAMSQX = (R*SQRT(X2)+(ONE-R)*SQRT(X1))**2 |
| 26899 | |
| 26900 | RETURN |
| 26901 | END |
| 26902 | |
| 26903 | *$ CREATE DT_SAMPLW.FOR |
| 26904 | *COPY DT_SAMPLW |
| 26905 | * |
| 26906 | *===samplw=============================================================* |
| 26907 | * |
| 26908 | DOUBLE PRECISION FUNCTION DT_SAMPLW(XMIN,XMAX,B) |
| 26909 | |
| 26910 | ************************************************************************ |
| 26911 | * Sampling from f(x)=1/x^b between x_min and x_max. * |
| 26912 | * S. Roesler, 18.4.98 * |
| 26913 | ************************************************************************ |
| 26914 | |
| 26915 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 26916 | SAVE |
| 26917 | PARAMETER (ONE=1.0D0) |
| 26918 | |
| 26919 | R = DT_RNDM(B) |
| 26920 | IF (B.EQ.ONE) THEN |
| 26921 | DT_SAMPLW = EXP(R*LOG(XMAX)+(ONE-R)*LOG(XMIN)) |
| 26922 | ELSE |
| 26923 | ONEMB = ONE-B |
| 26924 | DT_SAMPLW = (R*XMAX**ONEMB+(ONE-R)*XMIN**ONEMB)**(ONE/ONEMB) |
| 26925 | ENDIF |
| 26926 | |
| 26927 | RETURN |
| 26928 | END |
| 26929 | |
| 26930 | *$ CREATE DT_BETREJ.FOR |
| 26931 | *COPY DT_BETREJ |
| 26932 | * |
| 26933 | *===betrej=============================================================* |
| 26934 | * |
| 26935 | DOUBLE PRECISION FUNCTION DT_BETREJ(GAM,ETA,XMIN,XMAX) |
| 26936 | |
| 26937 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 26938 | SAVE |
| 26939 | |
| 26940 | PARAMETER ( LINP = 10 , |
| 26941 | & LOUT = 6 , |
| 26942 | & LDAT = 9 ) |
| 26943 | PARAMETER (ONE=1.0D0) |
| 26944 | |
| 26945 | IF (XMIN.GE.XMAX)THEN |
| 26946 | WRITE (LOUT,500) XMIN,XMAX |
| 26947 | 500 FORMAT(1X,'DT_BETREJ: XMIN<XMAX execution stopped ',2F10.5) |
| 26948 | STOP |
| 26949 | ENDIF |
| 26950 | |
| 26951 | 10 CONTINUE |
| 26952 | XX = XMIN+(XMAX-XMIN)*DT_RNDM(ETA) |
| 26953 | BETMAX = XMIN**(GAM-ONE)*(ONE-XMIN)**(ETA-ONE) |
| 26954 | YY = BETMAX*DT_RNDM(XX) |
| 26955 | BETXX = XX**(GAM-ONE)*(ONE-XX)**(ETA-ONE) |
| 26956 | IF (YY.GT.BETXX) GOTO 10 |
| 26957 | DT_BETREJ = XX |
| 26958 | |
| 26959 | RETURN |
| 26960 | END |
| 26961 | |
| 26962 | *$ CREATE DT_DGAMRN.FOR |
| 26963 | *COPY DT_DGAMRN |
| 26964 | * |
| 26965 | *===dgamrn=============================================================* |
| 26966 | * |
| 26967 | DOUBLE PRECISION FUNCTION DT_DGAMRN(ALAM,ETA) |
| 26968 | |
| 26969 | ************************************************************************ |
| 26970 | * Sampling from Gamma-distribution. * |
| 26971 | * F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA) * |
| 26972 | * Processed by S. Roesler, 6.5.95 * |
| 26973 | ************************************************************************ |
| 26974 | |
| 26975 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 26976 | SAVE |
| 26977 | PARAMETER (ZERO=0.0D0,TINY9=1.0D-9,ONE=1.0D0) |
| 26978 | |
| 26979 | NCOU = 0 |
| 26980 | N = INT(ETA) |
| 26981 | F = ETA-DBLE(N) |
| 26982 | IF (F.EQ.ZERO) GOTO 20 |
| 26983 | 10 R = DT_RNDM(F) |
| 26984 | NCOU = NCOU+1 |
| 26985 | IF (NCOU.GE.11) GOTO 20 |
| 26986 | IF (R.LT.F/(F+2.71828D0)) GOTO 30 |
| 26987 | YYY = LOG(DT_RNDM(R)+TINY9)/F |
| 26988 | IF (ABS(YYY).GT.50.0D0) GOTO 20 |
| 26989 | Y = EXP(YYY) |
| 26990 | IF (LOG(DT_RNDM(Y)+TINY9).GT.-Y) GOTO 10 |
| 26991 | GOTO 40 |
| 26992 | 20 Y = 0.0D0 |
| 26993 | GOTO 50 |
| 26994 | 30 Y = ONE-LOG(DT_RNDM(Y)+TINY9) |
| 26995 | IF (DT_RNDM(R).GT.Y**(F-ONE)) GOTO 10 |
| 26996 | 40 IF (N.EQ.0) GOTO 70 |
| 26997 | 50 Z = 1.0D0 |
| 26998 | DO 60 I = 1,N |
| 26999 | 60 Z = Z*DT_RNDM(Z) |
| 27000 | Y = Y-LOG(Z+TINY9) |
| 27001 | 70 DT_DGAMRN = Y/ALAM |
| 27002 | |
| 27003 | RETURN |
| 27004 | END |
| 27005 | |
| 27006 | *$ CREATE DT_DBETAR.FOR |
| 27007 | *COPY DT_DBETAR |
| 27008 | * |
| 27009 | *===dbetar=============================================================* |
| 27010 | * |
| 27011 | DOUBLE PRECISION FUNCTION DT_DBETAR(GAM,ETA) |
| 27012 | |
| 27013 | ************************************************************************ |
| 27014 | * Sampling from Beta -distribution between 0.0 and 1.0 * |
| 27015 | * F(X)=X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM)/(GAMM(GAM)*GAMM(ETA))* |
| 27016 | * Processed by S. Roesler, 6.5.95 * |
| 27017 | ************************************************************************ |
| 27018 | |
| 27019 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 27020 | SAVE |
| 27021 | |
| 27022 | Y = DT_DGAMRN(1.0D0,GAM) |
| 27023 | Z = DT_DGAMRN(1.0D0,ETA) |
| 27024 | DT_DBETAR = Y/(Y+Z) |
| 27025 | |
| 27026 | RETURN |
| 27027 | END |
| 27028 | |
| 27029 | *$ CREATE DT_RANNOR.FOR |
| 27030 | *COPY DT_RANNOR |
| 27031 | * |
| 27032 | *===rannor=============================================================* |
| 27033 | * |
| 27034 | SUBROUTINE DT_RANNOR(X,Y) |
| 27035 | |
| 27036 | ************************************************************************ |
| 27037 | * Sampling from Gaussian distribution. * |
| 27038 | * Processed by S. Roesler, 6.5.95 * |
| 27039 | ************************************************************************ |
| 27040 | |
| 27041 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 27042 | SAVE |
| 27043 | PARAMETER (TINY10=1.0D-10) |
| 27044 | |
| 27045 | CALL DT_DSFECF(SFE,CFE) |
| 27046 | V = MAX(TINY10,DT_RNDM(X)) |
| 27047 | A = SQRT(-2.D0*LOG(V)) |
| 27048 | X = A*SFE |
| 27049 | Y = A*CFE |
| 27050 | |
| 27051 | RETURN |
| 27052 | END |
| 27053 | |
| 27054 | *$ CREATE DT_DPOLI.FOR |
| 27055 | *COPY DT_DPOLI |
| 27056 | * |
| 27057 | *===dpoli==============================================================* |
| 27058 | * |
| 27059 | SUBROUTINE DT_DPOLI(CS,SI) |
| 27060 | |
| 27061 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 27062 | SAVE |
| 27063 | |
| 27064 | U = DT_RNDM(CS) |
| 27065 | CS = DT_RNDM(U) |
| 27066 | IF (U.LT.0.5D0) CS=-CS |
| 27067 | SI = SQRT(1.0D0-CS*CS+1.0D-10) |
| 27068 | |
| 27069 | RETURN |
| 27070 | END |
| 27071 | |
| 27072 | *$ CREATE DT_DSFECF.FOR |
| 27073 | *COPY DT_DSFECF |
| 27074 | * |
| 27075 | *===dsfecf=============================================================* |
| 27076 | * |
| 27077 | SUBROUTINE DT_DSFECF(SFE,CFE) |
| 27078 | |
| 27079 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 27080 | SAVE |
| 27081 | PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0) |
| 27082 | |
| 27083 | 1 CONTINUE |
| 27084 | X = DT_RNDM(SFE) |
| 27085 | Y = DT_RNDM(X) |
| 27086 | XX = X*X |
| 27087 | YY = Y*Y |
| 27088 | XY = XX+YY |
| 27089 | IF (XY.GT.ONE) GOTO 1 |
| 27090 | CFE = (XX-YY)/XY |
| 27091 | SFE = TWO*X*Y/XY |
| 27092 | IF (DT_RNDM(X).LT.OHALF) SFE = -SFE |
| 27093 | RETURN |
| 27094 | END |
| 27095 | |
| 27096 | *$ CREATE DT_RACO.FOR |
| 27097 | *COPY DT_RACO |
| 27098 | * |
| 27099 | *===raco===============================================================* |
| 27100 | * |
| 27101 | SUBROUTINE DT_RACO(WX,WY,WZ) |
| 27102 | |
| 27103 | ************************************************************************ |
| 27104 | * Direction cosines of random uniform (isotropic) direction in three * |
| 27105 | * dimensional space * |
| 27106 | * Processed by S. Roesler, 20.11.95 * |
| 27107 | ************************************************************************ |
| 27108 | |
| 27109 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 27110 | SAVE |
| 27111 | PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0) |
| 27112 | |
| 27113 | 10 CONTINUE |
| 27114 | X = TWO*DT_RNDM(WX)-ONE |
| 27115 | Y = DT_RNDM(X) |
| 27116 | X2 = X*X |
| 27117 | Y2 = Y*Y |
| 27118 | IF (X2+Y2.GT.ONE) GOTO 10 |
| 27119 | |
| 27120 | CFE = (X2-Y2)/(X2+Y2) |
| 27121 | SFE = TWO*X*Y/(X2+Y2) |
| 27122 | * z = 1/2 [ 1 + cos (theta) ] |
| 27123 | Z = DT_RNDM(X) |
| 27124 | * 1/2 sin (theta) |
| 27125 | WZ = SQRT(Z*(ONE-Z)) |
| 27126 | WX = TWO*WZ*CFE |
| 27127 | WY = TWO*WZ*SFE |
| 27128 | WZ = TWO*Z-ONE |
| 27129 | |
| 27130 | RETURN |
| 27131 | END |
| 27132 | |
| 27133 | ************************************************************************ |
| 27134 | * * |
| 27135 | * 6) Special functions, algorithms and service routines * |
| 27136 | * * |
| 27137 | ************************************************************************ |
| 27138 | *$ CREATE DT_YLAMB.FOR |
| 27139 | *COPY DT_YLAMB |
| 27140 | * |
| 27141 | *===ylamb==============================================================* |
| 27142 | * |
| 27143 | DOUBLE PRECISION FUNCTION DT_YLAMB(X,Y,Z) |
| 27144 | |
| 27145 | ************************************************************************ |
| 27146 | * * |
| 27147 | * auxiliary function for three particle decay mode * |
| 27148 | * (standard LAMBDA**(1/2) function) * |
| 27149 | * * |
| 27150 | * Adopted from an original version written by R. Engel. * |
| 27151 | * This version dated 12.12.94 is written by S. Roesler. * |
| 27152 | ************************************************************************ |
| 27153 | |
| 27154 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 27155 | SAVE |
| 27156 | |
| 27157 | YZ = Y-Z |
| 27158 | XLAM = X*X-2.D0*X*(Y+Z)+YZ*YZ |
| 27159 | IF (XLAM.LE.0.D0) XLAM = ABS(XLAM) |
| 27160 | DT_YLAMB = SQRT(XLAM) |
| 27161 | |
| 27162 | RETURN |
| 27163 | END |
| 27164 | |
| 27165 | *$ CREATE DT_SORT.FOR |
| 27166 | *COPY DT_SORT |
| 27167 | * |
| 27168 | *===sort1==============================================================* |
| 27169 | * |
| 27170 | SUBROUTINE DT_SORT(A,N,I0,I1,MODE) |
| 27171 | |
| 27172 | ************************************************************************ |
| 27173 | * This subroutine sorts entries in A in increasing/decreasing order * |
| 27174 | * of A(3,i). * |
| 27175 | * MODE = 1 increasing in A(3,i=1..N) * |
| 27176 | * = 2 decreasing in A(3,i=1..N) * |
| 27177 | * This version dated 21.04.95 is revised by S. Roesler * |
| 27178 | ************************************************************************ |
| 27179 | |
| 27180 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 27181 | SAVE |
| 27182 | |
| 27183 | DIMENSION A(3,N) |
| 27184 | |
| 27185 | M = I1 |
| 27186 | 10 CONTINUE |
| 27187 | M = I1-1 |
| 27188 | IF (M.LE.0) RETURN |
| 27189 | L = 0 |
| 27190 | DO 20 I=I0,M |
| 27191 | J = I+1 |
| 27192 | IF (MODE.EQ.1) THEN |
| 27193 | IF (A(3,I).LE.A(3,J)) GOTO 20 |
| 27194 | ELSE |
| 27195 | IF (A(3,I).GE.A(3,J)) GOTO 20 |
| 27196 | ENDIF |
| 27197 | B = A(3,I) |
| 27198 | C = A(1,I) |
| 27199 | D = A(2,I) |
| 27200 | A(3,I) = A(3,J) |
| 27201 | A(2,I) = A(2,J) |
| 27202 | A(1,I) = A(1,J) |
| 27203 | A(3,J) = B |
| 27204 | A(1,J) = C |
| 27205 | A(2,J) = D |
| 27206 | L = 1 |
| 27207 | 20 CONTINUE |
| 27208 | IF (L.EQ.1) GOTO 10 |
| 27209 | |
| 27210 | RETURN |
| 27211 | END |
| 27212 | |
| 27213 | *$ CREATE DT_SORT1.FOR |
| 27214 | *COPY DT_SORT1 |
| 27215 | * |
| 27216 | *===sort1==============================================================* |
| 27217 | * |
| 27218 | SUBROUTINE DT_SORT1(A,IDX,N,I0,I1,MODE) |
| 27219 | |
| 27220 | ************************************************************************ |
| 27221 | * This subroutine sorts entries in A in increasing/decreasing order * |
| 27222 | * of A(i). * |
| 27223 | * MODE = 1 increasing in A(i=1..N) * |
| 27224 | * = 2 decreasing in A(i=1..N) * |
| 27225 | * This version dated 21.04.95 is revised by S. Roesler * |
| 27226 | ************************************************************************ |
| 27227 | |
| 27228 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 27229 | SAVE |
| 27230 | |
| 27231 | DIMENSION A(N),IDX(N) |
| 27232 | |
| 27233 | M = I1 |
| 27234 | 10 CONTINUE |
| 27235 | M = I1-1 |
| 27236 | IF (M.LE.0) RETURN |
| 27237 | L = 0 |
| 27238 | DO 20 I=I0,M |
| 27239 | J = I+1 |
| 27240 | IF (MODE.EQ.1) THEN |
| 27241 | IF (A(I).LE.A(J)) GOTO 20 |
| 27242 | ELSE |
| 27243 | IF (A(I).GE.A(J)) GOTO 20 |
| 27244 | ENDIF |
| 27245 | B = A(I) |
| 27246 | A(I) = A(J) |
| 27247 | A(J) = B |
| 27248 | IX = IDX(I) |
| 27249 | IDX(I) = IDX(J) |
| 27250 | IDX(J) = IX |
| 27251 | L = 1 |
| 27252 | 20 CONTINUE |
| 27253 | IF (L.EQ.1) GOTO 10 |
| 27254 | |
| 27255 | RETURN |
| 27256 | END |
| 27257 | |
| 27258 | *$ CREATE DT_XTIME.FOR |
| 27259 | *COPY DT_XTIME |
| 27260 | * |
| 27261 | *===xtime==============================================================* |
| 27262 | * |
| 27263 | SUBROUTINE DT_XTIME |
| 27264 | |
| 27265 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 27266 | SAVE |
| 27267 | PARAMETER ( LINP = 10 , |
| 27268 | & LOUT = 6 , |
| 27269 | & LDAT = 9 ) |
| 27270 | |
| 27271 | CHARACTER DAT*9,TIM*11 |
| 27272 | |
| 27273 | DAT = ' ' |
| 27274 | TIM = ' ' |
| 27275 | C CALL GETDAT(IYEAR,IMONTH,IDAY) |
| 27276 | C CALL GETTIM(IHOUR,IMINUT,ISECND,IHSCND) |
| 27277 | |
| 27278 | C CALL DATE(DAT) |
| 27279 | C CALL TIME(TIM) |
| 27280 | C WRITE(LOUT,1000) DAT,TIM |
| 27281 | 1000 FORMAT(/,2X,'Date: ',A9,3X,'Time: ',A11,/) |
| 27282 | |
| 27283 | RETURN |
| 27284 | END |
| 27285 | |
| 27286 | ************************************************************************ |
| 27287 | * * |
| 27288 | * 7) Random number generator package * |
| 27289 | * * |
| 27290 | * THIS IS A PACKAGE CONTAINING A RANDOM NUMBER GENERATOR AND * |
| 27291 | * SERVICE ROUTINES. * |
| 27292 | * THE ALGORITHM IS FROM * |
| 27293 | * 'TOWARD A UNVERSAL RANDOM NUMBER GENERATOR' * |
| 27294 | * G.MARSAGLIA, A.ZAMAN ; FSU-SCRI-87-50 * |
| 27295 | * IMPLEMENTATION BY K. HAHN DEC. 88, * |
| 27296 | * THIS GENERATOR SHOULD NOT DEPEND ON THE HARD WARE ( IF A REAL HAS * |
| 27297 | * AT LEAST 24 SIGNIFICANT BITS IN INTERNAL REPRESENTATION ), * |
| 27298 | * THE PERIOD IS ABOUT 2**144, * |
| 27299 | * TIME FOR ONE CALL AT IBM-XT IS ABOUT 0.7 MILLISECONDS, * |
| 27300 | * THE PACKAGE CONTAINS * |
| 27301 | * FUNCTION DT_RNDM(I) : GENERATOR * |
| 27302 | * SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB4): INITIALIZATION * |
| 27303 | * SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) : PUT SEED TO GENERATOR * |
| 27304 | * SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) : TAKE SEED FROM GENERATOR * |
| 27305 | * SUBROUTINE DT_RNDMTE(IO) : TEST OF GENERATOR * |
| 27306 | *--- * |
| 27307 | * FUNCTION DT_RNDM(I) * |
| 27308 | * GIVES UNIFORMLY DISTRIBUTED RANDOM NUMBERS IN (0..1) * |
| 27309 | * I - DUMMY VARIABLE, NOT USED * |
| 27310 | * SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1) * |
| 27311 | * INITIALIZES THE GENERATOR, MUST BE CALLED BEFORE USING DT_RNDM * |
| 27312 | * NA1,NA2,NA3,NB1 - VALUES FOR INITIALIZING THE GENERATOR * |
| 27313 | * NA? MUST BE IN 1..178 AND NOT ALL 1 * |
| 27314 | * 12,34,56 ARE THE STANDARD VALUES * |
| 27315 | * NB1 MUST BE IN 1..168 * |
| 27316 | * 78 IS THE STANDARD VALUE * |
| 27317 | * SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) * |
| 27318 | * PUTS SEED TO GENERATOR ( BRINGS GENERATOR IN THE SAME STATUS * |
| 27319 | * AS AFTER THE LAST DT_RNDMOU CALL ) * |
| 27320 | * U(97),C,CD,CM,I,J - SEED VALUES AS TAKEN FROM DT_RNDMOU * |
| 27321 | * SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) * |
| 27322 | * TAKES SEED FROM GENERATOR * |
| 27323 | * U(97),C,CD,CM,I,J - SEED VALUES * |
| 27324 | * SUBROUTINE DT_RNDMTE(IO) * |
| 27325 | * TEST OF THE GENERATOR * |
| 27326 | * IO - DEFINES OUTPUT * |
| 27327 | * = 0 OUTPUT ONLY IF AN ERROR IS DETECTED * |
| 27328 | * = 1 OUTPUT INDEPENDEND ON AN ERROR * |
| 27329 | * DT_RNDMTE USES DT_RNDMIN AND DT_RNDMOU TO BRING GENERATOR TO * |
| 27330 | * SAME STATUS * |
| 27331 | * AS BEFORE CALL OF DT_RNDMTE * |
| 27332 | ************************************************************************ |
| 27333 | *$ CREATE DT_RNDM.FOR |
| 27334 | *COPY DT_RNDM |
| 27335 | * |
| 839efe5b |
27336 | c$$$*===rndm===============================================================* |
| 27337 | c$$$* |
| 27338 | c$$$ DOUBLE PRECISION FUNCTION DT_RNDM(VDUMMY) |
| 27339 | c$$$ |
| 27340 | c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 27341 | c$$$ SAVE |
| 27342 | c$$$ |
| 27343 | c$$$* random number generator |
| 27344 | c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J |
| 27345 | c$$$ |
| 27346 | c$$$* counter of calls to random number generator |
| 27347 | c$$$* uncomment if needed |
| 27348 | c$$$C COMMON /DTRNCT/ IRNCT0,IRNCT1 |
| 27349 | c$$$C LOGICAL LFIRST |
| 27350 | c$$$C DATA LFIRST /.TRUE./ |
| 27351 | c$$$ |
| 27352 | c$$$* counter of calls to random number generator |
| 27353 | c$$$* uncomment if needed |
| 27354 | c$$$C IF (LFIRST) THEN |
| 27355 | c$$$C IRNCT0 = 0 |
| 27356 | c$$$C IRNCT1 = 0 |
| 27357 | c$$$C LFIRST = .FALSE. |
| 27358 | c$$$C ENDIF |
| 27359 | c$$$ 100 CONTINUE |
| 27360 | c$$$ DT_RNDM = U(I)-U(J) |
| 27361 | c$$$ IF ( DT_RNDM.LT.0.0D0 ) DT_RNDM = DT_RNDM+1.0D0 |
| 27362 | c$$$ U(I) = DT_RNDM |
| 27363 | c$$$ I = I-1 |
| 27364 | c$$$ IF ( I.EQ.0 ) I = 97 |
| 27365 | c$$$ J = J-1 |
| 27366 | c$$$ IF ( J.EQ.0 ) J = 97 |
| 27367 | c$$$ C = C-CD |
| 27368 | c$$$ IF ( C.LT.0.0D0 ) C = C+CM |
| 27369 | c$$$ DT_RNDM = DT_RNDM-C |
| 27370 | c$$$ IF ( DT_RNDM.LT.0.0D0 ) DT_RNDM = DT_RNDM+1.0D0 |
| 27371 | c$$$ |
| 27372 | c$$$ IF ((DT_RNDM.EQ.0.D0).OR.(DT_RNDM.EQ.1.D0)) GOTO 100 |
| 27373 | c$$$ |
| 27374 | c$$$* counter of calls to random number generator |
| 27375 | c$$$* uncomment if needed |
| 27376 | c$$$C IRNCT0 = IRNCT0+1 |
| 27377 | c$$$ |
| 27378 | c$$$ RETURN |
| 27379 | c$$$ END |
| 27380 | c$$$ |
| 27381 | c$$$*$ CREATE DT_RNDMST.FOR |
| 27382 | c$$$*COPY DT_RNDMST |
| 27383 | c$$$* |
| 27384 | c$$$*===rndmst=============================================================* |
| 27385 | c$$$* |
| 27386 | c$$$ SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1) |
| 27387 | c$$$ |
| 27388 | c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 27389 | c$$$ SAVE |
| 27390 | c$$$ |
| 27391 | c$$$* random number generator |
| 27392 | c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J |
| 27393 | c$$$ |
| 27394 | c$$$ MA1 = NA1 |
| 27395 | c$$$ MA2 = NA2 |
| 27396 | c$$$ MA3 = NA3 |
| 27397 | c$$$ MB1 = NB1 |
| 27398 | c$$$ I = 97 |
| 27399 | c$$$ J = 33 |
| 27400 | c$$$ DO 20 II2 = 1,97 |
| 27401 | c$$$ S = 0 |
| 27402 | c$$$ T = 0.5D0 |
| 27403 | c$$$ DO 10 II1 = 1,24 |
| 27404 | c$$$ MAT = MOD(MOD(MA1*MA2,179)*MA3,179) |
| 27405 | c$$$ MA1 = MA2 |
| 27406 | c$$$ MA2 = MA3 |
| 27407 | c$$$ MA3 = MAT |
| 27408 | c$$$ MB1 = MOD(53*MB1+1,169) |
| 27409 | c$$$ IF ( MOD(MB1*MAT,64).GE.32 ) S = S+T |
| 27410 | c$$$ 10 T = 0.5D0*T |
| 27411 | c$$$ 20 U(II2) = S |
| 27412 | c$$$ C = 362436.0D0/16777216.0D0 |
| 27413 | c$$$ CD = 7654321.0D0/16777216.0D0 |
| 27414 | c$$$ CM = 16777213.0D0/16777216.0D0 |
| 27415 | c$$$ RETURN |
| 27416 | c$$$ END |
| 27417 | c$$$ |
| 27418 | c$$$*$ CREATE DT_RNDMIN.FOR |
| 27419 | c$$$*COPY DT_RNDMIN |
| 27420 | c$$$* |
| 27421 | c$$$*===rndmin=============================================================* |
| 27422 | c$$$* |
| 27423 | c$$$ SUBROUTINE DT_RNDMIN(UIN,CIN,CDIN,CMIN,IIN,JIN) |
| 27424 | c$$$ |
| 27425 | c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 27426 | c$$$ SAVE |
| 27427 | c$$$ |
| 27428 | c$$$* random number generator |
| 27429 | c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J |
| 27430 | c$$$ |
| 27431 | c$$$ DIMENSION UIN(97) |
| 27432 | c$$$ |
| 27433 | c$$$ DO 10 KKK = 1,97 |
| 27434 | c$$$ 10 U(KKK) = UIN(KKK) |
| 27435 | c$$$ C = CIN |
| 27436 | c$$$ CD = CDIN |
| 27437 | c$$$ CM = CMIN |
| 27438 | c$$$ I = IIN |
| 27439 | c$$$ J = JIN |
| 27440 | c$$$ |
| 27441 | c$$$ RETURN |
| 27442 | c$$$ END |
| 27443 | c$$$ |
| 27444 | c$$$*$ CREATE DT_RNDMOU.FOR |
| 27445 | c$$$*COPY DT_RNDMOU |
| 27446 | c$$$* |
| 27447 | c$$$*===rndmou=============================================================* |
| 27448 | c$$$* |
| 27449 | c$$$ SUBROUTINE DT_RNDMOU(UOUT,COUT,CDOUT,CMOUT,IOUT,JOUT) |
| 27450 | c$$$ |
| 27451 | c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 27452 | c$$$ SAVE |
| 27453 | c$$$ |
| 27454 | c$$$* random number generator |
| 27455 | c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J |
| 27456 | c$$$ |
| 27457 | c$$$ DIMENSION UOUT(97) |
| 27458 | c$$$ |
| 27459 | c$$$ DO 10 KKK = 1,97 |
| 27460 | c$$$ 10 UOUT(KKK) = U(KKK) |
| 27461 | c$$$ COUT = C |
| 27462 | c$$$ CDOUT = CD |
| 27463 | c$$$ CMOUT = CM |
| 27464 | c$$$ IOUT = I |
| 27465 | c$$$ JOUT = J |
| 27466 | c$$$ |
| 27467 | c$$$ RETURN |
| 27468 | c$$$ END |
| 27469 | c$$$ |
| 27470 | c$$$*$ CREATE DT_RNDMTE.FOR |
| 27471 | c$$$*COPY DT_RNDMTE |
| 27472 | c$$$* |
| 27473 | c$$$*===rndmte=============================================================* |
| 27474 | c$$$* |
| 27475 | c$$$ SUBROUTINE DT_RNDMTE(IO) |
| 27476 | c$$$ |
| 27477 | c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 27478 | c$$$ SAVE |
| 27479 | c$$$ |
| 27480 | c$$$ DIMENSION UU(97),U(6),X(6),D(6) |
| 27481 | c$$$ DATA U / 6533892.D0, 14220222.D0, 7275067.D0, 6172232.D0, |
| 27482 | c$$$ +8354498.D0, 10633180.D0/ |
| 27483 | c$$$ |
| 27484 | c$$$ CALL DT_RNDMOU(UU,CC,CCD,CCM,II,JJ) |
| 27485 | c$$$ CALL DT_RNDMST(12,34,56,78) |
| 27486 | c$$$ DO 10 II1 = 1,20000 |
| 27487 | c$$$ 10 XX = DT_RNDM(XX) |
| 27488 | c$$$ SD = 0.0D0 |
| 27489 | c$$$ DO 20 II2 = 1,6 |
| 27490 | c$$$ X(II2) = 4096.D0*(4096.D0*DT_RNDM(SD)) |
| 27491 | c$$$ D(II2) = X(II2)-U(II2) |
| 27492 | c$$$ 20 SD = SD+D(II2) |
| 27493 | c$$$ CALL DT_RNDMIN(UU,CC,CCD,CCM,II,JJ) |
| 27494 | c$$$**sr 24.01.95 |
| 27495 | c$$$C IF ( IO.EQ. 1.OR. SD.NE.0. 0) WRITE(6,500) (U(I),X(I),D(I),I=1,6) |
| 27496 | c$$$ IF ((IO.EQ.1).OR.(SD.NE.0.0)) THEN |
| 27497 | c$$$C WRITE(6,1000) |
| 27498 | c$$$ 1000 FORMAT(/,/,1X,'DT_RNDMTE: Test of random-number generator...', |
| 27499 | c$$$ & ' passed') |
| 27500 | c$$$ ENDIF |
| 27501 | c$$$** |
| 27502 | c$$$ RETURN |
| 27503 | c$$$ 500 FORMAT(' === TEST OF THE RANDOM-GENERATOR ===',/, |
| 27504 | c$$$ &' EXPECTED VALUE CALCULATED VALUE DIFFERENCE',/, 6(F17. |
| 27505 | c$$$ &1,F20.1,F15.3,/), ' === END OF TEST ;', |
| 27506 | c$$$ &' GENERATOR HAS THE SAME STATUS AS BEFORE CALLING DT_RNDMTE') |
| 27507 | c$$$ END |
| 9aaba0d6 |
27508 | * |
| 27509 | *$ CREATE PHO_RNDM.FOR |
| 27510 | *COPY PHO_RNDM |
| 27511 | * |
| 27512 | *===pho_rndm===========================================================* |
| 27513 | * |
| 27514 | DOUBLE PRECISION FUNCTION PHO_RNDM(DUMMY) |
| 27515 | |
| 27516 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 27517 | SAVE |
| 27518 | |
| 27519 | PHO_RNDM = DT_RNDM(DUMMY) |
| 27520 | |
| 27521 | RETURN |
| 27522 | END |
| 27523 | |
| 27524 | *$ CREATE PYR.FOR |
| 27525 | *COPY PYR |
| 27526 | * |
| 27527 | *===pyr================================================================* |
| 27528 | * |
| 27529 | DOUBLE PRECISION FUNCTION PYR(IDUMMY) |
| 27530 | |
| 27531 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 27532 | SAVE |
| 27533 | |
| 27534 | DUMMY = DBLE(IDUMMY) |
| 27535 | PYR = DT_RNDM(DUMMY) |
| 27536 | |
| 27537 | RETURN |
| 27538 | END |
| 27539 | |
| 27540 | *$ CREATE DT_TITLE.FOR |
| 27541 | *COPY DT_TITLE |
| 27542 | * |
| 27543 | *===title==============================================================* |
| 27544 | * |
| 27545 | SUBROUTINE DT_TITLE |
| 27546 | |
| 27547 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 27548 | SAVE |
| 27549 | PARAMETER ( LINP = 10 , |
| 27550 | & LOUT = 6 , |
| 27551 | & LDAT = 9 ) |
| 27552 | |
| 27553 | CHARACTER*6 CVERSI |
| 27554 | CHARACTER*11 CCHANG |
| 27555 | DATA CVERSI,CCHANG /'3.0-5 ','08 Jan 2007'/ |
| 27556 | |
| 27557 | CALL DT_XTIME |
| 27558 | WRITE(LOUT,1000) CVERSI,CCHANG |
| 27559 | 1000 FORMAT(1X,'+-------------------------------------------------', |
| 27560 | & '----------------------+',/, |
| 27561 | & 1X,'|',71X,'|',/, |
| 27562 | & 1X,'|',26X,'DPMJET version ',A6,24X,'|',/, |
| 27563 | & 1X,'|',71X,'|',/, |
| 27564 | & 1X,'|',22X,'(Last change: ',A11,')',23X,'|',/, |
| 27565 | & 1X,'|',71X,'|',/, |
| 27566 | & 1X,'|',12X,'Authors: Stefan Roesler (CERN)',27X,'|',/, |
| 27567 | & 1X,'|',21X,'Ralph Engel (FZ Karlsruhe)',19X,'|',/, |
| 27568 | & 1X,'|',21X,'Johannes Ranft (Siegen Univ.)',19X,'|',/, |
| 27569 | & 1X,'|',71X,'|',/, |
| 27570 | & 1X,'|',12X,'http://home.cern.ch/~sroesler/dpmjet3.html', |
| 27571 | & 17X,'|',/, |
| 27572 | & 1X,'|',71X,'|',/, |
| 27573 | & 1X,'+-------------------------------------------------', |
| 27574 | & '----------------------+',/, |
| 27575 | & 1X,'| Please send suggestions, bug reports, etc. to: ', |
| 27576 | & 'Stefan.Roesler@cern.ch |',/, |
| 27577 | & 1X,'+-------------------------------------------------', |
| 27578 | & '----------------------+',/) |
| 27579 | |
| 27580 | RETURN |
| 27581 | END |
| 27582 | |
| 27583 | *$ CREATE DT_EVTINI.FOR |
| 27584 | *COPY DT_EVTINI |
| 27585 | * |
| 27586 | *===evtini=============================================================* |
| 27587 | * |
| 27588 | SUBROUTINE DT_EVTINI |
| 27589 | |
| 27590 | ************************************************************************ |
| 27591 | * Initialization of DTEVT1. * |
| 27592 | * This version dated 15.01.94 is written by S. Roesler * |
| 27593 | ************************************************************************ |
| 27594 | |
| 27595 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 27596 | SAVE |
| 27597 | PARAMETER ( LINP = 10 , |
| 27598 | & LOUT = 6 , |
| 27599 | & LDAT = 9 ) |
| 27600 | |
| 27601 | * event history |
| 27602 | PARAMETER (NMXHKK=200000) |
| 27603 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 27604 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 27605 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 27606 | * extended event history |
| 27607 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 27608 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 27609 | & IHIST(2,NMXHKK) |
| 27610 | * event flag |
| 27611 | COMMON /DTEVNO/ NEVENT,ICASCA |
| 27612 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 27613 | * emulsion treatment |
| 27614 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), |
| 27615 | & NCOMPO,IEMUL |
| 27616 | |
| 27617 | * initialization of DTEVT1/DTEVT2 |
| 27618 | NEND = NHKK |
| 27619 | IF (NEVENT.EQ.1) NEND = NMXHKK |
| 27620 | NHKK = 0 |
| 27621 | NEVHKK = NEVENT |
| 27622 | DO 1 I=1,NEND |
| 27623 | ISTHKK(I) = 0 |
| 27624 | IDHKK(I) = 0 |
| 27625 | JMOHKK(1,I) = 0 |
| 27626 | JMOHKK(2,I) = 0 |
| 27627 | JDAHKK(1,I) = 0 |
| 27628 | JDAHKK(2,I) = 0 |
| 27629 | IDRES(I) = 0 |
| 27630 | IDXRES(I) = 0 |
| 27631 | NOBAM(I) = 0 |
| 27632 | IDCH(I) = 0 |
| 27633 | IHIST(1,I) = 0 |
| 27634 | IHIST(2,I) = 0 |
| 27635 | DO 2 J=1,4 |
| 27636 | PHKK(J,I) = 0.0D0 |
| 27637 | VHKK(J,I) = 0.0D0 |
| 27638 | WHKK(J,I) = 0.0D0 |
| 27639 | 2 CONTINUE |
| 27640 | PHKK(5,I) = 0.0D0 |
| 27641 | 1 CONTINUE |
| 27642 | DO 3 I=1,10 |
| 27643 | NPOINT(I) = 0 |
| 27644 | 3 CONTINUE |
| 27645 | CALL DT_CHASTA(-1) |
| 27646 | |
| 27647 | C* initialization of DTLTRA |
| 27648 | C IF (NCOMPO.GT.0) CALL DT_LTINI(ID,EPN,PPN,ECM) |
| 27649 | |
| 27650 | RETURN |
| 27651 | END |
| 27652 | |
| 27653 | *$ CREATE DT_STATIS.FOR |
| 27654 | *COPY DT_STATIS |
| 27655 | * |
| 27656 | *===statis=============================================================* |
| 27657 | * |
| 27658 | SUBROUTINE DT_STATIS(MODE) |
| 27659 | |
| 27660 | ************************************************************************ |
| 27661 | * Initialization and output of run-statistics. * |
| 27662 | * MODE = 1 initialization * |
| 27663 | * = 2 output * |
| 27664 | * This version dated 23.01.94 is written by S. Roesler * |
| 27665 | ************************************************************************ |
| 27666 | |
| 27667 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 27668 | SAVE |
| 27669 | PARAMETER ( LINP = 10 , |
| 27670 | & LOUT = 6 , |
| 27671 | & LDAT = 9 ) |
| 27672 | PARAMETER (TINY3=1.0D-3) |
| 27673 | |
| 27674 | * statistics |
| 27675 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, |
| 27676 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), |
| 27677 | & ICEVTG(8,0:30) |
| 27678 | * rejection counter |
| 27679 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, |
| 27680 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, |
| 27681 | & IREXCI(3),IRDIFF(2),IRINC |
| 27682 | * central particle production, impact parameter biasing |
| 27683 | COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR |
| 27684 | * various options for treatment of partons (DTUNUC 1.x) |
| 27685 | * (chain recombination, Cronin,..) |
| 27686 | LOGICAL LCO2CR,LINTPT |
| 27687 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, |
| 27688 | & LCO2CR,LINTPT |
| 27689 | * nucleon-nucleon event-generator |
| 27690 | CHARACTER*8 CMODEL |
| 27691 | LOGICAL LPHOIN |
| 27692 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN |
| 27693 | * flags for particle decays |
| 27694 | COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20), |
| 27695 | & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20), |
| 27696 | & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0 |
| 27697 | * diquark-breaking mechanism |
| 27698 | COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3 |
| 27699 | |
| 27700 | DIMENSION PP(4),PT(4) |
| 27701 | |
| 27702 | GOTO (1,2) MODE |
| 27703 | |
| 27704 | * initialization |
| 27705 | 1 CONTINUE |
| 27706 | |
| 27707 | * initialize statistics counter |
| 27708 | ICREQU = 0 |
| 27709 | ICSAMP = 0 |
| 27710 | ICCPRO = 0 |
| 27711 | ICDPR = 0 |
| 27712 | ICDTA = 0 |
| 27713 | ICRJSS = 0 |
| 27714 | ICVV2S = 0 |
| 27715 | DO 10 I=1,9 |
| 27716 | ICRES(I) = 0 |
| 27717 | ICCHAI(1,I) = 0 |
| 27718 | ICCHAI(2,I) = 0 |
| 27719 | 10 CONTINUE |
| 27720 | * initialize rejection counter |
| 27721 | IRPT = 0 |
| 27722 | IRHHA = 0 |
| 27723 | LOMRES = 0 |
| 27724 | LOBRES = 0 |
| 27725 | IRFRAG = 0 |
| 27726 | IREVT = 0 |
| 27727 | IRRES(1) = 0 |
| 27728 | IRRES(2) = 0 |
| 27729 | IRCHKI(1) = 0 |
| 27730 | IRCHKI(2) = 0 |
| 27731 | IRCRON(1) = 0 |
| 27732 | IRCRON(2) = 0 |
| 27733 | IRCRON(3) = 0 |
| 27734 | IRDIFF(1) = 0 |
| 27735 | IRDIFF(2) = 0 |
| 27736 | IRINC = 0 |
| 27737 | DO 11 I=1,5 |
| 27738 | ICDIFF(I) = 0 |
| 27739 | 11 CONTINUE |
| 27740 | DO 12 I=1,8 |
| 27741 | DO 13 J=0,30 |
| 27742 | ICEVTG(I,J) = 0 |
| 27743 | 13 CONTINUE |
| 27744 | 12 CONTINUE |
| 27745 | |
| 27746 | RETURN |
| 27747 | |
| 27748 | * output |
| 27749 | 2 CONTINUE |
| 27750 | |
| 27751 | * statistics counter |
| 27752 | WRITE(LOUT,1000) |
| 27753 | 1000 FORMAT(/,/,1X,'STATIS:',20X,'statistics of the run',/, |
| 27754 | & 28X,'---------------------') |
| be6523b4 |
27755 | IF (ICREQU.GT.0) THEN |
| 9aaba0d6 |
27756 | WRITE(LOUT,1001) ICREQU,ICSAMP,DBLE(ICSAMP)/DBLE(ICREQU) |
| 27757 | 1001 FORMAT(/,1X,'number of events requested / sampled',13X, |
| 27758 | & I8,' / ',I8,/,1X,'number of samp. evts per requested ', |
| 27759 | & 'event',11X,F9.1) |
| be6523b4 |
27760 | ENDIF |
| 9aaba0d6 |
27761 | IF (ICDIFF(1).NE.0) THEN |
| 27762 | WRITE(LOUT,1009) ICDIFF |
| 27763 | 1009 FORMAT(/,1X,'diffractive events: total ',I8,/,49X, |
| 27764 | & 'low mass high mass',/,24X,'single diffraction', |
| 27765 | & 7X,I8,4X,I8,/,24X,'double diffraction',7X,I8,4X,I8) |
| 27766 | ENDIF |
| be6523b4 |
27767 | IF (ICENTR.GT.0.AND.ICSAMP.GT.0.AND.ICCPRO.GT.0) THEN |
| 9aaba0d6 |
27768 | WRITE(LOUT,1002) DBLE(ICCPRO)/DBLE(ICSAMP), |
| 27769 | & DBLE(ICSAMP)/DBLE(ICCPRO) |
| 27770 | 1002 FORMAT(/,1X,'central production:',/,2X,'mean number', |
| 27771 | & ' of sampled Glauber-events per event',9X,F9.1,/, |
| 27772 | & 2X,'fraction of production cross section',21X,F10.6) |
| 27773 | ENDIF |
| be6523b4 |
27774 | IF (ICSAMP.GT.0) THEN |
| 9aaba0d6 |
27775 | WRITE(LOUT,1003) DBLE(ICDPR)/DBLE(ICSAMP), |
| 27776 | & DBLE(ICDTA)/DBLE(ICSAMP) |
| 27777 | 1003 FORMAT(/,54X,'proj. targ.',/,1X,'average number of wounded', |
| 27778 | & ' nucleons after x-sampling',2(4X,F6.2)) |
| be6523b4 |
27779 | ENDIF |
| 9aaba0d6 |
27780 | |
| 27781 | IF (MCGENE.EQ.1) THEN |
| be6523b4 |
27782 | IF (ICSAMP.GT.0) THEN |
| 9aaba0d6 |
27783 | WRITE(LOUT,1004) DBLE(ICRJSS)/DBLE(ICSAMP) |
| 27784 | 1004 FORMAT(/,1X,'mean number of sea-sea chain rejections per', |
| 27785 | & ' event',3X,F9.1) |
| 27786 | IF (ISICHA.EQ.1) THEN |
| 27787 | WRITE(LOUT,1005) DBLE(ICVV2S)/DBLE(ICSAMP) |
| 27788 | 1005 FORMAT(/,1X,'Reggeon contribution:',/,1X,'mean number ', |
| 27789 | & 'of single chains per event',13X,F9.1) |
| 27790 | ENDIF |
| be6523b4 |
27791 | ENDIF |
| 27792 | IF (ICSAMP.GT.0.AND.ICREQU.GT.0) THEN |
| 9aaba0d6 |
27793 | WRITE(LOUT,1006) |
| 27794 | 1006 FORMAT(/,1X,'chain system statistics: (per event)',/, |
| 27795 | & 23X,'mean number of chains mean number of chains',/, |
| 27796 | & 23X,'sampled hadronized having mass of a reso.') |
| 27797 | WRITE(LOUT,1007) (DBLE(ICCHAI(1,J))/(2.0D0*DBLE(ICSAMP)), |
| 27798 | & DBLE(ICCHAI(2,J))/(2.0D0*DBLE(ICREQU)), |
| 27799 | & DBLE(ICRES(J))/(2.0D0*DBLE(ICREQU)),J=1,8), |
| 27800 | & DBLE(ICCHAI(2,9))/MAX(DBLE(ICCHAI(1,9)),TINY3) |
| 27801 | 1007 FORMAT(1X,'sea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/, |
| 27802 | & 1X,'disea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/, |
| 27803 | & 1X,'sea - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/, |
| 27804 | & 1X,'sea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/, |
| 27805 | & 1X,'disea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/, |
| 27806 | & 1X,'valence - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/, |
| 27807 | & 1X,'valence - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/, |
| 27808 | & 1X,'valence - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/, |
| 27809 | & 1X,'fused chains ',18X,F4.1,17X,F4.1,/) |
| 27810 | WRITE(LOUT,1008) |
| 27811 | & (DBLE(IRCRON(I))/MAX(DBLE(IRCRON(1)),TINY3),I=2,3), |
| 27812 | & DBLE(IRPT)/DBLE(ICREQU),(DBLE(IRRES(I))/DBLE(ICREQU),I=1,2), |
| 27813 | & DBLE(LOMRES)/DBLE(ICREQU),DBLE(LOBRES)/DBLE(ICREQU), |
| 27814 | & (DBLE(IRCHKI(I))/DBLE(ICREQU),I=1,2), |
| 27815 | & (DBLE(IRDIFF(I))/DBLE(ICREQU),I=1,2), |
| 27816 | & DBLE(IRHHA)/DBLE(ICREQU), |
| 27817 | & DBLE(IRFRAG)/DBLE(ICREQU),DBLE(IREVT)/DBLE(ICREQU), |
| 27818 | & (DBLE(IREXCI(I))/DBLE(ICREQU),I=1,2),IREXCI(3) |
| 27819 | 1008 FORMAT(/,1X,'Rejection counter: (NEVT = no. of events)',/,/, |
| 27820 | & 1X,'Cronin-effect (CRONIN)',15X,'IRCRON(2)/IRCRON(1) = ', |
| 27821 | & F7.2,/,38X,'IRCRON(3)/IRCRON(1) = ',F7.2,/,1X, |
| 27822 | & 'Intrins. p_t (GETSPT)',21X,'IRPT /NEVT = ',F7.2,/, |
| 27823 | & 1X,'Chain mass corr. for resonances (EVTRES)',2X, |
| 27824 | & 'IRRES(1) /NEVT = ',F7.2,/,33X,'(CH2RES) IRRES(2) /', |
| 27825 | & 'NEVT = ',F7.2,/,43X,'LOMRES /NEVT = ',F7.2,/, |
| 27826 | & 43X,'LOBRES /NEVT = ',F7.2,/,1X,'Kinem. corr. of', |
| 27827 | & ' 2-chain systems (CHKINE) IRCHKI(1)/NEVT = ',F7.2,/, |
| 27828 | & 43X,'IRCHKI(2)/NEVT = ',F7.2,/,1X,'Diffraction',31X, |
| 27829 | & 'IRDIFF(1)/NEVT = ',F7.2,/,43X,'IRDIFF(2)/NEVT = ', |
| 27830 | & F7.2,/,1X,'Total no. of rej.', |
| 27831 | & ' in chain-systems treatment (GETCSY)',/,43X, |
| 27832 | & 'IRHHA /NEVT = ',F7.2,/,1X,'Fragmentation (EVTFRA)', |
| 27833 | & ' (not yet used!)',4X,'IRFRAG /NEVT = ',F7.2,/, |
| 27834 | & 1X,'Total no. of rej. in DPM-treatment of one event', |
| 27835 | & ' (EVENTA)',/,43X,'IREVT /NEVT = ',F7.2,/,1X, |
| 27836 | & 'Treatment of final nucleon conf.',10X,'IREXCI(1)/NEVT = ' |
| 27837 | & ,F7.2,/,43X,'IREXCI(2)/NEVT = ',F7.2,/,48X, |
| 27838 | & 'IREXCI(3) = ',I5,/) |
| be6523b4 |
27839 | ENDIF |
| 9aaba0d6 |
27840 | ELSEIF (MCGENE.EQ.2) THEN |
| 27841 | WRITE(LOUT,1010) ELOJET |
| 27842 | 1010 FORMAT(/,/,1X,'PHOJET-treatment of chain systems above ', |
| 27843 | & F4.1,' GeV') |
| 27844 | WRITE(LOUT,1011) |
| 27845 | 1011 FORMAT(/,1X,'1. chain system statistics - total numbers:',/, |
| 27846 | & 30X,'--------------',/,/,12X,'s-s',5X,'d-s',5X,'s-d', |
| 27847 | & 5X,'s-v',5X,'d-v',5X,'v-s',5X,'v-d',5X,'v-v') |
| 27848 | WRITE(LOUT,1012) ((ICEVTG(I,J),I=1,8),J=0,1), |
| 27849 | & (INT(ICCHAI(2,I)/2.0D0),I=1,8), |
| 27850 | & (ICEVTG(I,2),I=1,8),(ICEVTG(I,29),I=1,8), |
| 27851 | & ((ICEVTG(I,J),I=1,8),J=3,7), |
| 27852 | & ((ICEVTG(I,J),I=1,8),J=19,21), |
| 27853 | & (ICEVTG(I,8),I=1,8), |
| 27854 | & ((ICEVTG(I,J),I=1,8),J=22,24), |
| 27855 | & (ICEVTG(I,9),I=1,8), |
| 27856 | & ((ICEVTG(I,J),I=1,8),J=25,28), |
| 27857 | & ((ICEVTG(I,J),I=1,8),J=10,18) |
| 27858 | 1012 FORMAT(/,1X,'req.to.',8I8,/,/,1X,'low rq.',8I8,/,1X,'low ac.', |
| 27859 | & 8I8,/,/,1X,'PHOJET ',8I8,/,' sngl ',8I8,/,/, |
| 27860 | & ' no-dif.',8I8,/, |
| 27861 | & ' el-sca.',8I8,/,' qel-sc.',8I8,/,' dbl-Po.',8I8,/, |
| 27862 | & ' diff-1 ',8I8,/,' low ',8I8,/,' high ',8I8,/, |
| 27863 | & ' h-diff',8I8,/,' diff-2 ',8I8,/,' low ',8I8,/, |
| 27864 | & ' high ',8I8,/,' h-diff',8I8,/,' dbl-di.',8I8,/, |
| 27865 | & ' lo-lo ',8I8,/,' hi-hi ',8I8,/,' lo-hi ',8I8,/, |
| 27866 | & ' hi-lo ',8I8,/, |
| 27867 | & ' dir-ga.',8I8,/,/,' dir-1 ',8I8,/,' dir-2 ',8I8,/, |
| 27868 | & ' dbl-dir',8I8,/,' s-Pom. ',8I8,/,' h-Pom. ',8I8,/, |
| 27869 | & ' s-Reg. ',8I8,/,' enh-trg',8I8,/,' enh-log',8I8) |
| 27870 | WRITE(LOUT,1013) |
| 27871 | 1013 FORMAT(/,1X,'2. chain system statistics -', |
| 27872 | & ' mean numbers per evt:',/,30X,'---------------------', |
| 27873 | & /,/,16X,'s-s',7X,'d-s',7X,'s-d') |
| be6523b4 |
27874 | IF (ICSAMP.GT.0) THEN |
| 9aaba0d6 |
27875 | WRITE(LOUT,1014) |
| 27876 | & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=0,1), |
| 27877 | & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=1,3), |
| 27878 | & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=2,18) |
| 27879 | 1014 FORMAT(/,1X,'req.to. ',3E10.2,/,/,1X,'low rq. ',3E10.2,/, |
| 27880 | & 1X,'low ac. ',3E10.2,/,/,1X,'PHOJET ',3E10.2,/,/, |
| 27881 | & ' no-dif. ',3E10.2,/,' el-sca. ',3E10.2,/, |
| 27882 | & ' qel-sc. ',3E10.2,/,' dbl-Po. ',3E10.2,/, |
| 27883 | & ' diff-1 ',3E10.2,/,' diff-2 ',3E10.2,/, |
| 27884 | & ' dbl-di. ',3E10.2,/,' dir-ga. ',3E10.2,/,/, |
| 27885 | & ' dir-1 ',3E10.2,/,' dir-2 ',3E10.2,/, |
| 27886 | & ' dbl-dir ',3E10.2,/,' s-Pom. ',3E10.2,/, |
| 27887 | & ' h-Pom. ',3E10.2,/,' s-Reg. ',3E10.2,/, |
| 27888 | & ' enh-trg ',3E10.2,/,' enh-log ',3E10.2) |
| be6523b4 |
27889 | ENDIF |
| 9aaba0d6 |
27890 | WRITE(LOUT,1015) |
| 27891 | 1015 FORMAT(/,16X,'s-v',7X,'d-v',7X,'v-s',7X,'v-d',7X,'v-v') |
| be6523b4 |
27892 | IF (ICSAMP.GT.0) THEN |
| 9aaba0d6 |
27893 | WRITE(LOUT,1016) |
| 27894 | & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=0,1), |
| 27895 | & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=4,8), |
| 27896 | & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=2,18) |
| 27897 | 1016 FORMAT(/,1X,'req.to. ',5E10.2,/,/,1X,'low rq. ',5E10.2,/, |
| 27898 | & 1X,'low ac. ',5E10.2,/,/,1X,'PHOJET ',5E10.2,/,/, |
| 27899 | & ' no-dif. ',5E10.2,/,' el-sca. ',5E10.2,/, |
| 27900 | & ' qel-sc. ',5E10.2,/,' dbl-Po. ',5E10.2,/, |
| 27901 | & ' diff-1 ',5E10.2,/,' diff-2 ',5E10.2,/, |
| 27902 | & ' dbl-di. ',5E10.2,/,' dir-ga. ',5E10.2,/,/, |
| 27903 | & ' dir-1 ',5E10.2,/,' dir-2 ',5E10.2,/, |
| 27904 | & ' dbl-dir ',5E10.2,/,' s-Pom. ',5E10.2,/, |
| 27905 | & ' h-Pom. ',5E10.2,/,' s-Reg. ',5E10.2,/, |
| 27906 | & ' enh-trg ',5E10.2,/,' enh-log ',5E10.2) |
| be6523b4 |
27907 | ENDIF |
| 9aaba0d6 |
27908 | |
| 27909 | ENDIF |
| 27910 | CALL DT_CHASTA(1) |
| 27911 | |
| 27912 | IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0) |
| 27913 | & .OR.(PDBSEA(3).GT.0.0D0)) THEN |
| 27914 | WRITE(LOUT,*)'YGS1S,YGS2S,YUS1S,YUS2S', |
| 27915 | & DBRKA(1,1)+DBRKA(2,1),DBRKA(1,2)+DBRKA(2,2), |
| 27916 | & DBRKA(1,3)+DBRKA(2,3),DBRKA(1,4)+DBRKA(2,4) |
| 27917 | WRITE(LOUT,*)'YGS1R,YGS2R,YUS1R,YUS2R', |
| 27918 | & DBRKR(1,1)+DBRKR(2,1),DBRKR(1,2)+DBRKR(2,2), |
| 27919 | & DBRKR(1,3)+DBRKR(2,3),DBRKR(1,4)+DBRKR(2,4) |
| 27920 | WRITE(LOUT,*)'YGSA1S,YGSA2S,YUSA1S,YUSA2S', |
| 27921 | & DBRKA(1,5)+DBRKA(2,5),DBRKA(1,6)+DBRKA(2,6), |
| 27922 | & DBRKA(1,7)+DBRKA(2,7),DBRKA(1,8)+DBRKA(2,8) |
| 27923 | WRITE(LOUT,*)'YGSA1R,YGSA2R,YUSA1R,YUSA2R', |
| 27924 | & DBRKR(1,5)+DBRKR(2,5),DBRKR(1,6)+DBRKR(2,6), |
| 27925 | & DBRKR(1,7)+DBRKR(2,7),DBRKR(1,8)+DBRKR(2,8) |
| 27926 | WRITE(LOUT,*)'YG31S,YG32S,YU31S,YU32S', |
| 27927 | & DBRKA(3,1),DBRKA(3,2), |
| 27928 | & DBRKA(3,3),DBRKA(3,4) |
| 27929 | WRITE(LOUT,*)'YG31R,YG32R,YU31R,YU32R', |
| 27930 | & DBRKR(3,1),DBRKR(3,2), |
| 27931 | & DBRKR(3,3),DBRKR(3,4) |
| 27932 | WRITE(LOUT,*)'YG3A1S,YG3A2S,YU3A1S,YU3A2S', |
| 27933 | & DBRKA(3,5),DBRKA(3,6), |
| 27934 | & DBRKA(3,7),DBRKA(3,8) |
| 27935 | WRITE(LOUT,*)'YG3A1R,YG3A2R,YU3A1R,YU3A2R', |
| 27936 | & DBRKR(3,5),DBRKR(3,6), |
| 27937 | & DBRKR(3,7),DBRKR(3,8) |
| 27938 | ENDIF |
| 27939 | |
| 27940 | FAC = 1.0D0 |
| 27941 | IF (MCGENE.EQ.2) THEN |
| 27942 | C CALL PHO_PHIST(-2,SIGMAX) |
| 27943 | CALL PHO_EVENT(-2,PP,PT,FAC,IREJ1) |
| 27944 | ENDIF |
| 27945 | |
| 27946 | CALL DT_XTIME |
| 27947 | |
| 27948 | RETURN |
| 27949 | END |
| 27950 | |
| 27951 | *$ CREATE DT_EVTOUT.FOR |
| 27952 | *COPY DT_EVTOUT |
| 27953 | * |
| 27954 | *===evtout=============================================================* |
| 27955 | * |
| 27956 | SUBROUTINE DT_EVTOUT(MODE) |
| 27957 | |
| 27958 | ************************************************************************ |
| 27959 | * MODE = 1 plot content of complete DTEVT1 to out. unit * |
| 27960 | * 3 plot entries of extended DTEVT1 (DTEVT2) * |
| 27961 | * 4 plot entries of DTEVT1 and DTEVT2 * |
| 27962 | * This version dated 11.12.94 is written by S. Roesler * |
| 27963 | ************************************************************************ |
| 27964 | |
| 27965 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 27966 | SAVE |
| 27967 | PARAMETER ( LINP = 10 , |
| 27968 | & LOUT = 6 , |
| 27969 | & LDAT = 9 ) |
| 27970 | * event history |
| 27971 | PARAMETER (NMXHKK=200000) |
| 27972 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 27973 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 27974 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 27975 | |
| 27976 | DIMENSION IRANGE(NMXHKK) |
| 27977 | |
| 27978 | IF (MODE.EQ.2) RETURN |
| 27979 | |
| 27980 | CALL DT_EVTPLO(IRANGE,MODE) |
| 27981 | |
| 27982 | RETURN |
| 27983 | END |
| 27984 | |
| 27985 | *$ CREATE DT_EVTPLO.FOR |
| 27986 | *COPY DT_EVTPLO |
| 27987 | * |
| 27988 | *===evtplo=============================================================* |
| 27989 | * |
| 27990 | SUBROUTINE DT_EVTPLO(IRANGE,MODE) |
| 27991 | |
| 27992 | ************************************************************************ |
| 27993 | * MODE = 1 plot content of complete DTEVT1 to out. unit * |
| 27994 | * 2 plot entries of DTEVT1 given by IRANGE * |
| 27995 | * 3 plot entries of extended DTEVT1 (DTEVT2) * |
| 27996 | * 4 plot entries of DTEVT1 and DTEVT2 * |
| 27997 | * 5 plot rejection counter * |
| 27998 | * This version dated 11.12.94 is written by S. Roesler * |
| 27999 | ************************************************************************ |
| 28000 | |
| 28001 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 28002 | SAVE |
| 28003 | PARAMETER ( LINP = 10 , |
| 28004 | & LOUT = 6 , |
| 28005 | & LDAT = 9 ) |
| 28006 | |
| 28007 | CHARACTER*16 CHAU |
| 28008 | |
| 28009 | * event history |
| 28010 | PARAMETER (NMXHKK=200000) |
| 28011 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 28012 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 28013 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 28014 | * extended event history |
| 28015 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 28016 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 28017 | & IHIST(2,NMXHKK) |
| 28018 | * rejection counter |
| 28019 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, |
| 28020 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, |
| 28021 | & IREXCI(3),IRDIFF(2),IRINC |
| 28022 | |
| 28023 | DIMENSION IRANGE(NMXHKK) |
| 28024 | |
| 28025 | IF ((MODE.EQ.1).OR.(MODE.EQ.4)) THEN |
| 28026 | WRITE(LOUT,1000) |
| 28027 | 1000 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTEVT1/',/, |
| 28028 | & 15X,' --------------------------',/,/, |
| 28029 | & ' ST ID M1 M2 D1 D2 PX PY', |
| 28030 | & ' PZ E M',/) |
| 28031 | DO 1 I=1,NHKK |
| 28032 | WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I), |
| 28033 | & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I), |
| 28034 | & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I), |
| 28035 | & PHKK(5,I) |
| 28036 | C WRITE(LOUT,1011) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I), |
| 28037 | C & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I), |
| 28038 | C & PHKK(3,I),PHKK(4,I) |
| 28039 | C WRITE(LOUT,'(4E15.4)') |
| 28040 | C & VHKK(1,I),VHKK(2,I),VHKK(3,I),VHKK(4,I) |
| 28041 | 1001 FORMAT(I5,I5,I6,4I5,3F7.3,F8.3,F8.4) |
| 28042 | 1011 FORMAT(I5,I5,I6,4I5,2E15.5) |
| 28043 | 1 CONTINUE |
| 28044 | WRITE(LOUT,*) |
| 28045 | C DO 4 I=1,NHKK |
| 28046 | C WRITE(LOUT,1006) I,ISTHKK(I), |
| 28047 | C & VHKK(1,I),VHKK(2,I),VHKK(3,I),WHKK(1,I), |
| 28048 | C & WHKK(2,I),WHKK(3,I) |
| 28049 | C1006 FORMAT(1X,I4,I6,6E10.3) |
| 28050 | C 4 CONTINUE |
| 28051 | ENDIF |
| 28052 | |
| 28053 | IF (MODE.EQ.2) THEN |
| 28054 | WRITE(LOUT,1000) |
| 28055 | NC = 0 |
| 28056 | 2 CONTINUE |
| 28057 | NC = NC+1 |
| 28058 | IF (IRANGE(NC).EQ.-100) GOTO 9999 |
| 28059 | I = IRANGE(NC) |
| 28060 | WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I), |
| 28061 | & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I), |
| 28062 | & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I), |
| 28063 | & PHKK(5,I) |
| 28064 | GOTO 2 |
| 28065 | ENDIF |
| 28066 | |
| 28067 | IF ((MODE.EQ.3).OR.(MODE.EQ.4)) THEN |
| 28068 | WRITE(LOUT,1002) |
| 28069 | 1002 FORMAT(/,1X,'EVTPLO:',14X, |
| 28070 | & ' content of COMMON /DTEVT1/,/DTEVT2/',/, |
| 28071 | & 15X,' -----------------------------------',/,/, |
| 28072 | & ' ST ID M1 M2 D1 D2 IDR IDXR', |
| 28073 | & ' NOBAM IDCH M',/) |
| 28074 | DO 3 I=1,NHKK |
| 28075 | C IF ((ISTHKK(I).GT.10).OR.(ISTHKK(I).EQ.1)) THEN |
| 28076 | KF = IDHKK(I) |
| 28077 | IDCHK = KF/10000 |
| 28078 | IF ((((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND. |
| 28079 | & (KF.NE.80000)).OR.(IDHKK(I).EQ.99999)) KF = 92 |
| 28080 | CALL PYNAME(KF,CHAU) |
| 28081 | WRITE(LOUT,1003) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I), |
| 28082 | & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I), |
| 28083 | & IDRES(I),IDXRES(I),NOBAM(I),IDCH(I), |
| 28084 | & PHKK(5,I),CHAU |
| 28085 | 1003 FORMAT(I5,I5,I6,4I5,4I4,F8.4,2X,A) |
| 28086 | C ENDIF |
| 28087 | 3 CONTINUE |
| 28088 | ENDIF |
| 28089 | |
| 28090 | IF (MODE.EQ.5) THEN |
| 28091 | WRITE(LOUT,1004) |
| 28092 | 1004 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTREJC/',/, |
| 28093 | & 15X,' --------------------------',/) |
| 28094 | WRITE(LOUT,1005) IRPT,IRHHA,IRRES,LOMRES,LOBRES,IREMC,IRFRAG, |
| 28095 | & IRSEA,IRCRON |
| 28096 | 1005 FORMAT(1X,'IRPT = ',I5,' IRHHA = ',I5,/, |
| 28097 | & 1X,'IRRES = ',2I5,' LOMRES = ',I5,' LOBRES = ',I5,/, |
| 28098 | & 1X,'IREMC = ',10I5,/, |
| 28099 | & 1X,'IRFRAG = ',I5,' IRSEA = ',I5,' IRCRON = ',I5,/) |
| 28100 | ENDIF |
| 28101 | |
| 28102 | 9999 RETURN |
| 28103 | END |
| 28104 | |
| 28105 | *$ CREATE DT_EVTPUT.FOR |
| 28106 | *COPY DT_EVTPUT |
| 28107 | * |
| 28108 | *===evtput=============================================================* |
| 28109 | * |
| 28110 | SUBROUTINE DT_EVTPUT(IST,ID,M1,M2,PX,PY,PZ,E,IDR,IDXR,IDC) |
| 28111 | |
| 28112 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 28113 | SAVE |
| 28114 | PARAMETER ( LINP = 10 , |
| 28115 | & LOUT = 6 , |
| 28116 | & LDAT = 9 ) |
| 28117 | PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,TINY3=1.0D-3, |
| 28118 | & TINY2=1.0D-2,SQTINF=1.0D+15,ZERO=0.0D0) |
| 28119 | |
| 28120 | * event history |
| 28121 | PARAMETER (NMXHKK=200000) |
| 28122 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 28123 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 28124 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 28125 | * extended event history |
| 28126 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 28127 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 28128 | & IHIST(2,NMXHKK) |
| 28129 | * Lorentz-parameters of the current interaction |
| 28130 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, |
| 28131 | & UMO,PPCM,EPROJ,PPROJ |
| 28132 | * particle properties (BAMJET index convention) |
| 28133 | CHARACTER*8 ANAME |
| 28134 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 28135 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 28136 | |
| 28137 | C IF (MODE.GT.100) THEN |
| 28138 | C WRITE(LOUT,'(1X,A,I5,A,I5)') |
| 28139 | C & 'EVTPUT: reset NHKK = ',NHKK,' to NHKK =',NHKK-MODE+100 |
| 28140 | C NHKK = NHKK-MODE+100 |
| 28141 | C RETURN |
| 28142 | C ENDIF |
| 28143 | MO1 = M1 |
| 28144 | MO2 = M2 |
| 28145 | NHKK = NHKK+1 |
| 28146 | |
| 28147 | IF (NHKK.GT.NMXHKK) THEN |
| 28148 | WRITE(LOUT,1000) NHKK |
| 28149 | 1000 FORMAT(1X,'EVTPUT: NHKK exeeds NMXHKK = ',I7, |
| 28150 | & '! program execution stopped..') |
| 28151 | STOP |
| 28152 | ENDIF |
| 28153 | IF (M1.LT.0) MO1 = NHKK+M1 |
| 28154 | IF (M2.LT.0) MO2 = NHKK+M2 |
| 28155 | ISTHKK(NHKK) = IST |
| 28156 | IDHKK(NHKK) = ID |
| 28157 | JMOHKK(1,NHKK) = MO1 |
| 28158 | JMOHKK(2,NHKK) = MO2 |
| 28159 | JDAHKK(1,NHKK) = 0 |
| 28160 | JDAHKK(2,NHKK) = 0 |
| 28161 | IDRES(NHKK) = IDR |
| 28162 | IDXRES(NHKK) = IDXR |
| 28163 | IDCH(NHKK) = IDC |
| 28164 | ** here we need to do something.. |
| 28165 | IF (ID.EQ.88888) THEN |
| 28166 | IDMO1 = ABS(IDHKK(MO1)) |
| 28167 | IDMO2 = ABS(IDHKK(MO2)) |
| 28168 | IF ((IDMO1.LT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 3 |
| 28169 | IF ((IDMO1.LT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 4 |
| 28170 | IF ((IDMO1.GT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 5 |
| 28171 | IF ((IDMO1.GT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 6 |
| 28172 | ELSE |
| 28173 | NOBAM(NHKK) = 0 |
| 28174 | ENDIF |
| 28175 | IDBAM(NHKK) = IDT_ICIHAD(ID) |
| 28176 | IF (MO1.GT.0) THEN |
| 28177 | IF (JDAHKK(1,MO1).NE.0) THEN |
| 28178 | JDAHKK(2,MO1) = NHKK |
| 28179 | ELSE |
| 28180 | JDAHKK(1,MO1) = NHKK |
| 28181 | ENDIF |
| 28182 | ENDIF |
| 28183 | IF (MO2.GT.0) THEN |
| 28184 | IF (JDAHKK(1,MO2).NE.0) THEN |
| 28185 | JDAHKK(2,MO2) = NHKK |
| 28186 | ELSE |
| 28187 | JDAHKK(1,MO2) = NHKK |
| 28188 | ENDIF |
| 28189 | ENDIF |
| 28190 | C IF ((IDBAM(NHKK).GT.0).AND.(IDBAM(NHKK).NE.7)) THEN |
| 28191 | C PTOT = SQRT(PX**2+PY**2+PZ**2) |
| 28192 | C AM0 = SQRT(ABS( (E-PTOT)*(E+PTOT) )) |
| 28193 | C AMRQ = AAM(IDBAM(NHKK)) |
| 28194 | C AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ) |
| 28195 | C IF ((ABS(AMDIF2).GT.TINY3).AND.(E.LT.SQTINF).AND. |
| 28196 | C & (PTOT.GT.ZERO)) THEN |
| 28197 | C DELTA = -AMDIF2/(2.0D0*(E+PTOT)) |
| 28198 | CC DELTA = (AMRQ2-AM2)/(2.0D0*(E+PTOT)) |
| 28199 | C E = E+DELTA |
| 28200 | C PTOT1 = PTOT-DELTA |
| 28201 | C PX = PX*PTOT1/PTOT |
| 28202 | C PY = PY*PTOT1/PTOT |
| 28203 | C PZ = PZ*PTOT1/PTOT |
| 28204 | C ENDIF |
| 28205 | C ENDIF |
| 28206 | PHKK(1,NHKK) = PX |
| 28207 | PHKK(2,NHKK) = PY |
| 28208 | PHKK(3,NHKK) = PZ |
| 28209 | PHKK(4,NHKK) = E |
| 28210 | PTOT = SQRT( PX**2+PY**2+PZ**2 ) |
| 28211 | IF ((IDHKK(NHKK).GE.22).AND.(IDHKK(NHKK).LE.24)) THEN |
| 28212 | PHKK(5,NHKK) = PHKK(4,NHKK)**2-PTOT**2 |
| 28213 | PHKK(5,NHKK) = SIGN(SQRT(ABS(PHKK(5,NHKK))),PHKK(5,NHKK)) |
| 28214 | ELSE |
| 28215 | PHKK(5,NHKK) = (PHKK(4,NHKK)-PTOT)*(PHKK(4,NHKK)+PTOT) |
| 28216 | C IF ((PHKK(5,NHKK).LT.0.0D0).AND.(ABS(PHKK(5,NHKK)).GT.TINY4)) |
| 28217 | C & WRITE(LOUT,'(1X,A,G10.3)') |
| 28218 | C & 'EVTPUT: negative mass**2 ',PHKK(5,NHKK) |
| 28219 | PHKK(5,NHKK) = SQRT(ABS(PHKK(5,NHKK))) |
| 28220 | ENDIF |
| 28221 | IDCHK = ID/10000 |
| 28222 | IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.(ID.NE.80000)) THEN |
| 28223 | * special treatment for chains: |
| 28224 | * z coordinate of chain in Lab = pos. of target nucleon |
| 28225 | * time of chain-creation in Lab = time of passage of projectile |
| 28226 | * nucleus at pos. of taget nucleus |
| 28227 | C VHKK(1,NHKK) = 0.5D0*(VHKK(1,MO1)+VHKK(1,MO2)) |
| 28228 | C VHKK(2,NHKK) = 0.5D0*(VHKK(2,MO1)+VHKK(2,MO2)) |
| 28229 | VHKK(1,NHKK) = VHKK(1,MO2) |
| 28230 | VHKK(2,NHKK) = VHKK(2,MO2) |
| 28231 | VHKK(3,NHKK) = VHKK(3,MO2) |
| 28232 | VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB |
| 28233 | C WHKK(1,NHKK) = 0.5D0*(WHKK(1,MO1)+WHKK(1,MO2)) |
| 28234 | C WHKK(2,NHKK) = 0.5D0*(WHKK(2,MO1)+WHKK(2,MO2)) |
| 28235 | WHKK(1,NHKK) = WHKK(1,MO1) |
| 28236 | WHKK(2,NHKK) = WHKK(2,MO1) |
| 28237 | WHKK(3,NHKK) = WHKK(3,MO1) |
| 28238 | WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB |
| 28239 | ELSE |
| 28240 | IF (MO1.GT.0) THEN |
| 28241 | DO 1 I=1,4 |
| 28242 | VHKK(I,NHKK) = VHKK(I,MO1) |
| 28243 | WHKK(I,NHKK) = WHKK(I,MO1) |
| 28244 | 1 CONTINUE |
| 28245 | ELSE |
| 28246 | DO 2 I=1,4 |
| 28247 | VHKK(I,NHKK) = ZERO |
| 28248 | WHKK(I,NHKK) = ZERO |
| 28249 | 2 CONTINUE |
| 28250 | ENDIF |
| 28251 | ENDIF |
| 28252 | |
| 28253 | RETURN |
| 28254 | END |
| 28255 | |
| 28256 | *$ CREATE DT_CHASTA.FOR |
| 28257 | *COPY DT_CHASTA |
| 28258 | * |
| 28259 | *===chasta=============================================================* |
| 28260 | * |
| 28261 | SUBROUTINE DT_CHASTA(MODE) |
| 28262 | |
| 28263 | ************************************************************************ |
| 28264 | * This subroutine performs CHAin STAtistics and checks sequence of * |
| 28265 | * partons in dtevt1 and sorts them with projectile partons coming * |
| 28266 | * first if necessary. * |
| 28267 | * * |
| 28268 | * This version dated 8.5.00 is written by S. Roesler. * |
| 28269 | ************************************************************************ |
| 28270 | |
| 28271 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 28272 | SAVE |
| 28273 | PARAMETER ( LINP = 10 , |
| 28274 | & LOUT = 6 , |
| 28275 | & LDAT = 9 ) |
| 28276 | |
| 28277 | CHARACTER*5 CCHTYP |
| 28278 | |
| 28279 | * event history |
| 28280 | PARAMETER (NMXHKK=200000) |
| 28281 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 28282 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 28283 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 28284 | * extended event history |
| 28285 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 28286 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 28287 | & IHIST(2,NMXHKK) |
| 28288 | * pointer to chains in hkkevt common (used by qq-breaking mechanisms) |
| 28289 | PARAMETER (MAXCHN=10000) |
| 28290 | COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN |
| 28291 | |
| 28292 | DIMENSION ICHCFG(10,10,9,2),ICHTYP(5,5), |
| 28293 | & CCHTYP(9),ICHSTA(10),ITOT(10) |
| 28294 | DATA ICHCFG /1800*0/ |
| 28295 | DATA (ICHTYP(1,K),K=1,5) / 0, 1, 3, 0, 0/ |
| 28296 | DATA (ICHTYP(2,K),K=1,5) / 2, 0, 0, 5, 0/ |
| 28297 | DATA (ICHTYP(3,K),K=1,5) / 4, 0, 0, 7, 0/ |
| 28298 | DATA (ICHTYP(4,K),K=1,5) / 0, 6, 8, 0, 0/ |
| 28299 | DATA (ICHTYP(5,K),K=1,5) / 0, 0, 0, 0, 9/ |
| 28300 | DATA ICHSTA / 21, 22, 31, 32, 41, 42, 51, 52, 61, 62/ |
| 28301 | DATA CCHTYP / ' q aq','aq q ',' q d ',' d q ','aq ad', |
| 28302 | & 'ad aq',' d ad','ad d ',' g g '/ |
| 28303 | * |
| 28304 | * initialization |
| 28305 | * |
| 28306 | IF (MODE.EQ.-1) THEN |
| 28307 | NCHAIN = 0 |
| 28308 | * |
| 28309 | * loop over DTEVT1 and analyse chain configurations |
| 28310 | * |
| 28311 | ELSEIF (MODE.EQ.0) THEN |
| 28312 | DO 21 IDX=NPOINT(3),NHKK |
| 28313 | IDCHK = IDHKK(IDX)/10000 |
| 28314 | IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND. |
| 28315 | & (IDHKK(IDX).NE.80000).AND. |
| 28316 | & (ISTHKK(IDX).NE.2).AND.(IDRES(IDX).EQ.0)) THEN |
| 28317 | IF (JMOHKK(1,IDX).GT.JMOHKK(2,IDX)) THEN |
| 28318 | WRITE(LOUT,*) ' CHASTA: JMOHKK(1,x) > JMOHKK(2,x) ', |
| 28319 | & ' at entry ',IDX |
| 28320 | GOTO 21 |
| 28321 | ENDIF |
| 28322 | * |
| 28323 | IST1 = ABS(ISTHKK(JMOHKK(1,IDX))) |
| 28324 | IST2 = ABS(ISTHKK(JMOHKK(2,IDX))) |
| 28325 | IMO1 = IST1/10 |
| 28326 | IMO1 = IST1-10*IMO1 |
| 28327 | IMO2 = IST2/10 |
| 28328 | IMO2 = IST2-10*IMO2 |
| 28329 | * swop parton entries if necessary since we need projectile partons |
| 28330 | * to come first in the common |
| 28331 | IF (IMO1.GT.IMO2) THEN |
| 28332 | NPTN = JMOHKK(2,IDX)-JMOHKK(1,IDX)+1 |
| 28333 | DO 22 K=1,NPTN/2 |
| 28334 | I0 = JMOHKK(1,IDX)-1+K |
| 28335 | I1 = JMOHKK(2,IDX)+1-K |
| 28336 | ITMP = ISTHKK(I0) |
| 28337 | ISTHKK(I0) = ISTHKK(I1) |
| 28338 | ISTHKK(I1) = ITMP |
| 28339 | ITMP = IDHKK(I0) |
| 28340 | IDHKK(I0) = IDHKK(I1) |
| 28341 | IDHKK(I1) = ITMP |
| 28342 | IF (JDAHKK(1,JMOHKK(1,I0)).EQ.I0) |
| 28343 | & JDAHKK(1,JMOHKK(1,I0)) = I1 |
| 28344 | IF (JDAHKK(2,JMOHKK(1,I0)).EQ.I0) |
| 28345 | & JDAHKK(2,JMOHKK(1,I0)) = I1 |
| 28346 | IF (JDAHKK(1,JMOHKK(2,I0)).EQ.I0) |
| 28347 | & JDAHKK(1,JMOHKK(2,I0)) = I1 |
| 28348 | IF (JDAHKK(2,JMOHKK(2,I0)).EQ.I0) |
| 28349 | & JDAHKK(2,JMOHKK(2,I0)) = I1 |
| 28350 | IF (JDAHKK(1,JMOHKK(1,I1)).EQ.I1) |
| 28351 | & JDAHKK(1,JMOHKK(1,I1)) = I0 |
| 28352 | IF (JDAHKK(2,JMOHKK(1,I1)).EQ.I1) |
| 28353 | & JDAHKK(2,JMOHKK(1,I1)) = I0 |
| 28354 | IF (JDAHKK(1,JMOHKK(2,I1)).EQ.I1) |
| 28355 | & JDAHKK(1,JMOHKK(2,I1)) = I0 |
| 28356 | IF (JDAHKK(2,JMOHKK(2,I1)).EQ.I1) |
| 28357 | & JDAHKK(2,JMOHKK(2,I1)) = I0 |
| 28358 | ITMP = JMOHKK(1,I0) |
| 28359 | JMOHKK(1,I0) = JMOHKK(1,I1) |
| 28360 | JMOHKK(1,I1) = ITMP |
| 28361 | ITMP = JMOHKK(2,I0) |
| 28362 | JMOHKK(2,I0) = JMOHKK(2,I1) |
| 28363 | JMOHKK(2,I1) = ITMP |
| 28364 | ITMP = JDAHKK(1,I0) |
| 28365 | JDAHKK(1,I0) = JDAHKK(1,I1) |
| 28366 | JDAHKK(1,I1) = ITMP |
| 28367 | ITMP = JDAHKK(2,I0) |
| 28368 | JDAHKK(2,I0) = JDAHKK(2,I1) |
| 28369 | JDAHKK(2,I1) = ITMP |
| 28370 | DO 23 J=1,4 |
| 28371 | RTMP1 = PHKK(J,I0) |
| 28372 | RTMP2 = VHKK(J,I0) |
| 28373 | RTMP3 = WHKK(J,I0) |
| 28374 | PHKK(J,I0) = PHKK(J,I1) |
| 28375 | VHKK(J,I0) = VHKK(J,I1) |
| 28376 | WHKK(J,I0) = WHKK(J,I1) |
| 28377 | PHKK(J,I1) = RTMP1 |
| 28378 | VHKK(J,I1) = RTMP2 |
| 28379 | WHKK(J,I1) = RTMP3 |
| 28380 | 23 CONTINUE |
| 28381 | RTMP1 = PHKK(5,I0) |
| 28382 | PHKK(5,I0) = PHKK(5,I1) |
| 28383 | PHKK(5,I1) = RTMP1 |
| 28384 | ITMP = IDRES(I0) |
| 28385 | IDRES(I0) = IDRES(I1) |
| 28386 | IDRES(I1) = ITMP |
| 28387 | ITMP = IDXRES(I0) |
| 28388 | IDXRES(I0) = IDXRES(I1) |
| 28389 | IDXRES(I1) = ITMP |
| 28390 | ITMP = NOBAM(I0) |
| 28391 | NOBAM(I0) = NOBAM(I1) |
| 28392 | NOBAM(I1) = ITMP |
| 28393 | ITMP = IDBAM(I0) |
| 28394 | IDBAM(I0) = IDBAM(I1) |
| 28395 | IDBAM(I1) = ITMP |
| 28396 | ITMP = IDCH(I0) |
| 28397 | IDCH(I0) = IDCH(I1) |
| 28398 | IDCH(I1) = ITMP |
| 28399 | ITMP = IHIST(1,I0) |
| 28400 | IHIST(1,I0) = IHIST(1,I1) |
| 28401 | IHIST(1,I1) = ITMP |
| 28402 | ITMP = IHIST(2,I0) |
| 28403 | IHIST(2,I0) = IHIST(2,I1) |
| 28404 | IHIST(2,I1) = ITMP |
| 28405 | 22 CONTINUE |
| 28406 | ENDIF |
| 28407 | IST1 = ABS(ISTHKK(JMOHKK(1,IDX))) |
| 28408 | IST2 = ABS(ISTHKK(JMOHKK(2,IDX))) |
| 28409 | * |
| 28410 | * parton 1 (projectile side) |
| 28411 | IF (IST1.EQ.21) THEN |
| 28412 | IDX1 = 1 |
| 28413 | ELSEIF (IST1.EQ.22) THEN |
| 28414 | IDX1 = 2 |
| 28415 | ELSEIF (IST1.EQ.31) THEN |
| 28416 | IDX1 = 3 |
| 28417 | ELSEIF (IST1.EQ.32) THEN |
| 28418 | IDX1 = 4 |
| 28419 | ELSEIF (IST1.EQ.41) THEN |
| 28420 | IDX1 = 5 |
| 28421 | ELSEIF (IST1.EQ.42) THEN |
| 28422 | IDX1 = 6 |
| 28423 | ELSEIF (IST1.EQ.51) THEN |
| 28424 | IDX1 = 7 |
| 28425 | ELSEIF (IST1.EQ.52) THEN |
| 28426 | IDX1 = 8 |
| 28427 | ELSEIF (IST1.EQ.61) THEN |
| 28428 | IDX1 = 9 |
| 28429 | ELSEIF (IST1.EQ.62) THEN |
| 28430 | IDX1 = 10 |
| 28431 | ELSE |
| 28432 | c WRITE(LOUT,*) |
| 28433 | c & ' CHASTA: unknown parton status flag (', |
| 28434 | c & IST1,') at entry ',JMOHKK(1,IDX),'(',IDX,')' |
| 28435 | GOTO 21 |
| 28436 | ENDIF |
| 28437 | ID = IDHKK(JMOHKK(1,IDX)) |
| 28438 | IF (ABS(ID).LE.4) THEN |
| 28439 | IF (ID.GT.0) THEN |
| 28440 | ITYP1 = 1 |
| 28441 | ELSE |
| 28442 | ITYP1 = 2 |
| 28443 | ENDIF |
| 28444 | ELSEIF (ABS(ID).GE.1000) THEN |
| 28445 | IF (ID.GT.0) THEN |
| 28446 | ITYP1 = 3 |
| 28447 | ELSE |
| 28448 | ITYP1 = 4 |
| 28449 | ENDIF |
| 28450 | ELSEIF (ID.EQ.21) THEN |
| 28451 | ITYP1 = 5 |
| 28452 | ELSE |
| 28453 | WRITE(LOUT,*) |
| 28454 | & ' CHASTA: inconsistent parton identity (', |
| 28455 | & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')' |
| 28456 | GOTO 21 |
| 28457 | ENDIF |
| 28458 | * |
| 28459 | * parton 2 (target side) |
| 28460 | IF (IST2.EQ.21) THEN |
| 28461 | IDX2 = 1 |
| 28462 | ELSEIF (IST2.EQ.22) THEN |
| 28463 | IDX2 = 2 |
| 28464 | ELSEIF (IST2.EQ.31) THEN |
| 28465 | IDX2 = 3 |
| 28466 | ELSEIF (IST2.EQ.32) THEN |
| 28467 | IDX2 = 4 |
| 28468 | ELSEIF (IST2.EQ.41) THEN |
| 28469 | IDX2 = 5 |
| 28470 | ELSEIF (IST2.EQ.42) THEN |
| 28471 | IDX2 = 6 |
| 28472 | ELSEIF (IST2.EQ.51) THEN |
| 28473 | IDX2 = 7 |
| 28474 | ELSEIF (IST2.EQ.52) THEN |
| 28475 | IDX2 = 8 |
| 28476 | ELSEIF (IST2.EQ.61) THEN |
| 28477 | IDX2 = 9 |
| 28478 | ELSEIF (IST2.EQ.62) THEN |
| 28479 | IDX2 = 10 |
| 28480 | ELSE |
| 28481 | c WRITE(LOUT,*) |
| 28482 | c & ' CHASTA: unknown parton status flag (', |
| 28483 | c & IST2,') at entry ',JMOHKK(2,IDX),'(',IDX,')' |
| 28484 | GOTO 21 |
| 28485 | ENDIF |
| 28486 | ID = IDHKK(JMOHKK(2,IDX)) |
| 28487 | IF (ABS(ID).LE.4) THEN |
| 28488 | IF (ID.GT.0) THEN |
| 28489 | ITYP2 = 1 |
| 28490 | ELSE |
| 28491 | ITYP2 = 2 |
| 28492 | ENDIF |
| 28493 | ELSEIF (ABS(ID).GE.1000) THEN |
| 28494 | IF (ID.GT.0) THEN |
| 28495 | ITYP2 = 3 |
| 28496 | ELSE |
| 28497 | ITYP2 = 4 |
| 28498 | ENDIF |
| 28499 | ELSEIF (ID.EQ.21) THEN |
| 28500 | ITYP2 = 5 |
| 28501 | ELSE |
| 28502 | WRITE(LOUT,*) |
| 28503 | & ' CHASTA: inconsistent parton identity (', |
| 28504 | & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')' |
| 28505 | GOTO 21 |
| 28506 | ENDIF |
| 28507 | * |
| 28508 | * fill counter |
| 28509 | ITYPE = ICHTYP(ITYP1,ITYP2) |
| 28510 | IF (ITYPE.NE.0) THEN |
| 28511 | ICHCFG(IDX1,IDX2,ITYPE,1) =ICHCFG(IDX1,IDX2,ITYPE,1)+1 |
| 28512 | NGLUON = JMOHKK(2,IDX)-JMOHKK(1,IDX)-1 |
| 28513 | ICHCFG(IDX1,IDX2,ITYPE,2) = |
| 28514 | & ICHCFG(IDX1,IDX2,ITYPE,2)+NGLUON |
| 28515 | |
| 28516 | NCHAIN = NCHAIN+1 |
| 28517 | IF (NCHAIN.GT.MAXCHN) THEN |
| 28518 | WRITE(LOUT,*) ' CHASTA: NCHAIN > MAXCHN ! ', |
| 28519 | & NCHAIN,MAXCHN |
| 28520 | STOP |
| 28521 | ENDIF |
| 28522 | IDXCHN(1,NCHAIN) = IDX |
| 28523 | IDXCHN(2,NCHAIN) = ITYPE |
| 28524 | ELSE |
| 28525 | WRITE(LOUT,*) |
| 28526 | & ' CHASTA: inconsistent chain at entry ',IDX |
| 28527 | GOTO 21 |
| 28528 | ENDIF |
| 28529 | ENDIF |
| 28530 | 21 CONTINUE |
| 28531 | * |
| 28532 | * write statistics to output unit |
| 28533 | * |
| 28534 | ELSEIF (MODE.EQ.1) THEN |
| 28535 | WRITE(LOUT,'(/,A)') ' CHASTA: generated chain configurations' |
| 28536 | DO 31 I=1,10 |
| 28537 | WRITE(LOUT,'(/,2A)') |
| 28538 | & ' -----------------------------------------', |
| 28539 | & '------------------------------------' |
| 28540 | WRITE(LOUT,'(2A)') |
| 28541 | & ' p\\t 21 22 31 32 41', |
| 28542 | & ' 42 51 52 61 62' |
| 28543 | WRITE(LOUT,'(2A)') |
| 28544 | & ' -----------------------------------------', |
| 28545 | & '------------------------------------' |
| 28546 | DO 32 J=1,10 |
| 28547 | ITOT(J) = 0 |
| 28548 | DO 33 K=1,9 |
| 28549 | ITOT(J) = ITOT(J)+ICHCFG(I,J,K,1) |
| 28550 | 33 CONTINUE |
| 28551 | 32 CONTINUE |
| 28552 | WRITE(LOUT,'(1X,I2,5X,10I7,/)') ICHSTA(I),(ITOT(J),J=1,10) |
| 28553 | DO 34 K=1,9 |
| 28554 | ISUM = 0 |
| 28555 | DO 35 J=1,10 |
| 28556 | ISUM = ISUM+ICHCFG(I,J,K,1) |
| 28557 | 35 CONTINUE |
| 28558 | IF (ISUM.GT.0) |
| 28559 | & WRITE(LOUT,'(1X,A5,2X,10I7)') |
| 28560 | & CCHTYP(K),(ICHCFG(I,J,K,1),J=1,10) |
| 28561 | 34 CONTINUE |
| 28562 | C WRITE(LOUT,'(2A)') |
| 28563 | C & ' -----------------------------------------', |
| 28564 | C & '-------------------------------' |
| 28565 | 31 CONTINUE |
| 28566 | * |
| 28567 | ELSE |
| 28568 | WRITE(LOUT,*) ' CHASTA: MODE ',MODE,' not supported !' |
| 28569 | STOP |
| 28570 | ENDIF |
| 28571 | |
| 28572 | RETURN |
| 28573 | END |
| 28574 | *$ CREATE PHO_PHIST.FOR |
| 28575 | *COPY PHO_PHIST |
| 28576 | * |
| 28577 | *===pohist=============================================================* |
| 28578 | * |
| 28579 | SUBROUTINE PHO_PHIST(IMODE,WEIGHT) |
| 28580 | |
| 28581 | IMPLICIT DOUBLE PRECISION (A-H,O-X,Z) |
| 28582 | SAVE |
| 28583 | |
| 28584 | PARAMETER ( LINP = 10 , |
| 28585 | & LOUT = 6 , |
| 28586 | & LDAT = 9 ) |
| 28587 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 28588 | * Glauber formalism: cross sections |
| 28589 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, |
| 28590 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), |
| 28591 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), |
| 28592 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), |
| 28593 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), |
| 28594 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), |
| 28595 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), |
| 28596 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), |
| 28597 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), |
| 28598 | & BSLOPE,NEBINI,NQBINI |
| 28599 | |
| 28600 | ILAB = 0 |
| 28601 | IF (IMODE.EQ.10) THEN |
| 28602 | IMODE = 1 |
| 28603 | ILAB = 1 |
| 28604 | ENDIF |
| 28605 | IF (ABS(IMODE).LT.1000) THEN |
| 28606 | * PHOJET-statistics |
| 28607 | C CALL POHISX(IMODE,WEIGHT) |
| 28608 | IF (IMODE.EQ.-1) THEN |
| 28609 | MODE = 1 |
| 28610 | XSTOT(1,1,1) = WEIGHT |
| 28611 | ENDIF |
| 28612 | IF (IMODE.EQ. 1) MODE = 2 |
| 28613 | IF (IMODE.EQ.-2) MODE = 3 |
| 28614 | IF (MODE.EQ.2) CALL DT_SWPPHO(ILAB) |
| 28615 | C IF (MODE.EQ.3) WRITE(LOUT,*) |
| 28616 | C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization' |
| 28617 | CALL DT_HISTOG(MODE) |
| 28618 | CALL DT_USRHIS(MODE) |
| 28619 | ELSE |
| 28620 | * DTUNUC-statistics |
| 28621 | MODE = IMODE/1000 |
| 28622 | C IF (MODE.EQ.3) WRITE(LOUT,*) |
| 28623 | C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization' |
| 28624 | CALL DT_HISTOG(MODE) |
| 28625 | CALL DT_USRHIS(MODE) |
| 28626 | ENDIF |
| 28627 | |
| 28628 | RETURN |
| 28629 | END |
| 28630 | |
| 28631 | *$ CREATE DT_SWPPHO.FOR |
| 28632 | *COPY DT_SWPPHO |
| 28633 | * |
| 28634 | *===swppho=============================================================* |
| 28635 | * |
| 28636 | SUBROUTINE DT_SWPPHO(ILAB) |
| 28637 | |
| 28638 | IMPLICIT DOUBLE PRECISION (A-H,O-X,Z) |
| 28639 | SAVE |
| 28640 | PARAMETER ( LINP = 10 , |
| 28641 | & LOUT = 6 , |
| 28642 | & LDAT = 9 ) |
| 28643 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14) |
| 28644 | |
| 28645 | LOGICAL LSTART |
| 28646 | |
| 28647 | * event history |
| 28648 | PARAMETER (NMXHKK=200000) |
| 28649 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 28650 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 28651 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 28652 | * extended event history |
| 28653 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 28654 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 28655 | & IHIST(2,NMXHKK) |
| 28656 | * flags for input different options |
| 28657 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 28658 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 28659 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 28660 | * properties of photon/lepton projectiles |
| 28661 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC |
| 28662 | |
| 28663 | **PHOJET105a |
| 28664 | C PARAMETER (NMXHEP=2000) |
| 28665 | C COMMON/HEPEVS/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP), |
| 28666 | C &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP) |
| 28667 | C COMMON /GLOCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2) |
| 28668 | C COMMON /PLASAV/ PLAB |
| 28669 | **PHOJET110 |
| 28670 | C standard particle data interface |
| 28671 | INTEGER NMXHEP |
| 28672 | PARAMETER (NMXHEP=4000) |
| 28673 | INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP |
| 28674 | DOUBLE PRECISION PHEP,VHEP |
| 28675 | COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP), |
| 28676 | & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP), |
| 09b429a4 |
28677 | & VHEP(4,NMXHEP),NSD1, NSD2, NDD |
| 9aaba0d6 |
28678 | C extension to standard particle data interface (PHOJET specific) |
| 28679 | INTEGER IMPART,IPHIST,ICOLOR |
| 28680 | COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP) |
| 28681 | C global event kinematics and particle IDs |
| 28682 | INTEGER IFPAP,IFPAB |
| 28683 | DOUBLE PRECISION ECM,PCM,PMASS,PVIRT |
| 28684 | COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2) |
| 28685 | ** |
| 28686 | DATA ICOUNT/0/ |
| 28687 | |
| 28688 | DATA LSTART /.TRUE./ |
| 28689 | |
| 28690 | C IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0).AND.LSTART) THEN |
| 28691 | IF ((IFRAME.EQ.1).AND.LSTART) THEN |
| 28692 | UMO = ECM |
| 28693 | ELA = ZERO |
| 28694 | PLA = ZERO |
| 28695 | IDP = IDT_ICIHAD(IFPAP(1)) |
| 28696 | IDT = IDT_ICIHAD(IFPAP(2)) |
| 28697 | VIRT = PVIRT(1) |
| 28698 | CALL DT_LTINI(IDP,IDT,ELA,PLA,UMO,0) |
| 28699 | PLAB = PLA |
| 28700 | LSTART = .FALSE. |
| 28701 | ENDIF |
| 28702 | |
| 28703 | NHKK = 0 |
| 28704 | ICOUNT = ICOUNT+1 |
| 28705 | C NEVHKK = NEVHEP |
| 28706 | NEVHKK = ICOUNT |
| 28707 | IF (MOD(ICOUNT,500).EQ.0) WRITE(LOUT,*)' SWPPHO: event # ',ICOUNT |
| 28708 | DO 1 I=3,NHEP |
| 28709 | IF (ISTHEP(I).EQ.1) THEN |
| 28710 | NHKK = NHKK+1 |
| 28711 | ISTHKK(NHKK) = 1 |
| 28712 | IDHKK(NHKK) = IDHEP(I) |
| 28713 | JMOHKK(1,NHKK) = 0 |
| 28714 | JMOHKK(2,NHKK) = 0 |
| 28715 | JDAHKK(1,NHKK) = 0 |
| 28716 | JDAHKK(2,NHKK) = 0 |
| 28717 | DO 2 K=1,4 |
| 28718 | PHKK(K,NHKK) = PHEP(K,I) |
| 28719 | VHKK(K,NHKK) = ZERO |
| 28720 | WHKK(K,NHKK) = ZERO |
| 28721 | 2 CONTINUE |
| 28722 | IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0)) |
| 28723 | & CALL DT_LTNUC(PHEP(3,I),PHEP(4,I), |
| 28724 | & PHKK(3,NHKK),PHKK(4,NHKK),-3) |
| 28725 | PHKK(5,NHKK) = PHEP(5,I) |
| 28726 | IDRES(NHKK) = 0 |
| 28727 | IDXRES(NHKK) = 0 |
| 28728 | NOBAM(NHKK) = 0 |
| 28729 | IDBAM(NHKK) = IDT_ICIHAD(IDHEP(I)) |
| 28730 | IDCH(NHKK) = 0 |
| 28731 | ENDIF |
| 28732 | 1 CONTINUE |
| 28733 | |
| 28734 | RETURN |
| 28735 | END |
| 28736 | |
| 28737 | *$ CREATE DT_HISTOG.FOR |
| 28738 | *COPY DT_HISTOG |
| 28739 | * |
| 28740 | *===histog=============================================================* |
| 28741 | * |
| 28742 | SUBROUTINE DT_HISTOG(MODE) |
| 28743 | |
| 28744 | ************************************************************************ |
| 28745 | * This version dated 25.03.96 is written by S. Roesler * |
| 28746 | ************************************************************************ |
| 28747 | |
| 28748 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 28749 | SAVE |
| 28750 | PARAMETER ( LINP = 10 , |
| 28751 | & LOUT = 6 , |
| 28752 | & LDAT = 9 ) |
| 28753 | |
| 28754 | LOGICAL LFSP,LRNL |
| 28755 | |
| 28756 | * event history |
| 28757 | PARAMETER (NMXHKK=200000) |
| 28758 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 28759 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 28760 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 28761 | * extended event history |
| 28762 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 28763 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 28764 | & IHIST(2,NMXHKK) |
| 28765 | * event flag used for histograms |
| 28766 | COMMON /DTNORM/ ICEVT,IEVHKK |
| 28767 | * flags for activated histograms |
| 28768 | COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL |
| 28769 | |
| 28770 | IEVHKK = NEVHKK |
| 28771 | GOTO (1,2,3) MODE |
| 28772 | |
| 28773 | *------------------------------------------------------------------ |
| 28774 | * initialization |
| 28775 | 1 CONTINUE |
| 28776 | ICEVT = 0 |
| 28777 | IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,1) |
| 28778 | IF (IHISPP(2).EQ.1) CALL DT_HIMULT(1) |
| 28779 | |
| 28780 | RETURN |
| 28781 | *------------------------------------------------------------------ |
| 28782 | * filling of histogram with event-record |
| 28783 | 2 CONTINUE |
| 28784 | ICEVT = ICEVT+1 |
| 28785 | |
| 28786 | DO 20 I=1,NHKK |
| 28787 | CALL DT_SWPFSP(I,LFSP,LRNL) |
| 28788 | IF (LFSP) THEN |
| 28789 | IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,2) |
| 28790 | IF (IHISPP(2).EQ.1) CALL DT_HIMULT(2) |
| 28791 | ENDIF |
| 28792 | IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,5) |
| 28793 | 20 CONTINUE |
| 28794 | IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,4) |
| 28795 | |
| 28796 | RETURN |
| 28797 | *------------------------------------------------------------------ |
| 28798 | * output |
| 28799 | 3 CONTINUE |
| 28800 | IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,3) |
| 28801 | IF (IHISPP(2).EQ.1) CALL DT_HIMULT(3) |
| 28802 | |
| 28803 | RETURN |
| 28804 | END |
| 28805 | |
| 28806 | *$ CREATE DT_SWPFSP.FOR |
| 28807 | *COPY DT_SWPFSP |
| 28808 | * |
| 28809 | *===swpfsp=============================================================* |
| 28810 | * |
| 28811 | SUBROUTINE DT_SWPFSP(IDX,LFSP,LRNL) |
| 28812 | |
| 28813 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 28814 | SAVE |
| 28815 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14) |
| 28816 | PARAMETER (TWOPI=6.283185307179586476925286766559D+00, |
| 28817 | & PI =TWOPI/TWO, |
| 28818 | & BOG =TWOPI/360.0D0) |
| 28819 | |
| 28820 | * event history |
| 28821 | PARAMETER (NMXHKK=200000) |
| 28822 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 28823 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 28824 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 28825 | * extended event history |
| 28826 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 28827 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 28828 | & IHIST(2,NMXHKK) |
| 28829 | * particle properties (BAMJET index convention) |
| 28830 | CHARACTER*8 ANAME |
| 28831 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 28832 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 28833 | * Lorentz-parameters of the current interaction |
| 28834 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, |
| 28835 | & UMO,PPCM,EPROJ,PPROJ |
| 28836 | * flags for input different options |
| 28837 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 28838 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 28839 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 28840 | * (original name: PAREVT) |
| 28841 | LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX, |
| 28842 | & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF |
| 28843 | PARAMETER ( NALLWP = 39 ) |
| 28844 | COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, |
| 28845 | & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY, |
| 28846 | & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV, |
| 28847 | & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF |
| 28848 | * temporary storage for one final state particle |
| 28849 | LOGICAL LFRAG,LGREY,LBLACK |
| 28850 | COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN, |
| 28851 | & SINTHE,COSTHE,THETA,THECMS, |
| 28852 | & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF, |
| 28853 | & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF, |
| 28854 | & LFRAG,LGREY,LBLACK |
| 28855 | |
| 28856 | LOGICAL LFSP,LRNL |
| 28857 | |
| 28858 | LFSP = .FALSE. |
| 28859 | LRNL = .FALSE. |
| 28860 | ISTRNL = 1000 |
| 28861 | MULDEF = 1 |
| 28862 | IF (LEVPRT) ISTRNL = 1001 |
| 28863 | |
| 28864 | IF (ABS(ISTHKK(IDX)).EQ.1) THEN |
| 28865 | IST = ISTHKK(IDX) |
| 28866 | IDPDG = IDHKK(IDX) |
| 28867 | LFRAG = .FALSE. |
| 28868 | IF (IDHKK(IDX).LT.80000) THEN |
| 28869 | IDBJT = IDBAM(IDX) |
| 28870 | IBARY = IIBAR(IDBJT) |
| 28871 | ICHAR = IICH(IDBJT) |
| 28872 | AMASS = AAM(IDBJT) |
| 28873 | ELSEIF (IDHKK(IDX).EQ.80000) THEN |
| 28874 | IDBJT = 0 |
| 28875 | IBARY = IDRES(IDX) |
| 28876 | ICHAR = IDXRES(IDX) |
| 28877 | AMASS = PHKK(5,IDX) |
| 28878 | INUT = IBARY-ICHAR |
| 28879 | IF ((ICHAR.EQ.1).AND.(INUT.EQ.1)) IDBJT = 116 |
| 28880 | IF ((ICHAR.EQ.1).AND.(INUT.EQ.2)) IDBJT = 117 |
| 28881 | IF ((ICHAR.EQ.2).AND.(INUT.EQ.1)) IDBJT = 118 |
| 28882 | IF ((ICHAR.EQ.2).AND.(INUT.EQ.2)) IDBJT = 119 |
| 28883 | IF (IDBJT.EQ.0) LFRAG = .TRUE. |
| 28884 | ELSE |
| 28885 | GOTO 9999 |
| 28886 | ENDIF |
| 28887 | PE = PHKK(4,IDX) |
| 28888 | PX = PHKK(1,IDX) |
| 28889 | PY = PHKK(2,IDX) |
| 28890 | PZ = PHKK(3,IDX) |
| 28891 | PT2 = PX**2+PY**2 |
| 28892 | PT = SQRT(PT2) |
| 28893 | PTOT = SQRT(PT2+PZ**2) |
| 28894 | SINTHE = PT/MAX(PTOT,TINY14) |
| 28895 | COSTHE = PZ/MAX(PTOT,TINY14) |
| 28896 | IF (COSTHE.GT.ONE) THEN |
| 28897 | THETA = ZERO |
| 28898 | ELSEIF (COSTHE.LT.-ONE) THEN |
| 28899 | THETA = TWOPI/2.0D0 |
| 28900 | ELSE |
| 28901 | THETA = ACOS(COSTHE) |
| 28902 | ENDIF |
| 28903 | EKIN = PE-AMASS |
| 28904 | **sr 15.4.96 new E_t-definition |
| 28905 | IF (IBARY.GT.0) THEN |
| 28906 | ET = EKIN*SINTHE |
| 28907 | ELSEIF (IBARY.LT.0) THEN |
| 28908 | ET = (EKIN+TWO*AMASS)*SINTHE |
| 28909 | ELSE |
| 28910 | ET = PE*SINTHE |
| 28911 | ENDIF |
| 28912 | ** |
| 28913 | XLAB = PZ/MAX(PPROJ,TINY14) |
| 28914 | C XLAB = PE/MAX(EPROJ,TINY14) |
| 28915 | BETA = SQRT(ABS( (ONE-AMASS/MAX(PE,TINY14)) |
| 28916 | & *(ONE+AMASS/MAX(PE,TINY14)) )) |
| 28917 | PPLUS = PE+PZ |
| 28918 | PMINUS = PE-PZ |
| 28919 | IF (PMINUS.GT.TINY14) THEN |
| 28920 | YY = 0.5D0*LOG(ABS(PPLUS/PMINUS)) |
| 28921 | ELSE |
| 28922 | YY = 100.0D0 |
| 28923 | ENDIF |
| 28924 | IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN |
| 28925 | ETA = -LOG(TAN(THETA/TWO)) |
| 28926 | ELSE |
| 28927 | ETA = 100.0D0 |
| 28928 | ENDIF |
| 28929 | IF (IFRAME.EQ.1) THEN |
| 28930 | CALL DT_LTNUC(PZ,PE,PZCMS,EECMS,3) |
| 28931 | PPLUS = EECMS+PZCMS |
| 28932 | PMINUS = EECMS-PZCMS |
| 28933 | IF ((PPLUS*PMINUS).GT.TINY14) THEN |
| 28934 | YYCMS = 0.5D0*LOG(ABS(PPLUS/PMINUS)) |
| 28935 | ELSE |
| 28936 | YYCMS = 100.0D0 |
| 28937 | ENDIF |
| 28938 | PTOTCM = SQRT(PT2+PZCMS**2) |
| 28939 | COSTH = PZCMS/MAX(PTOTCM,TINY14) |
| 28940 | IF (COSTH.GT.ONE) THEN |
| 28941 | THECMS = ZERO |
| 28942 | ELSEIF (COSTH.LT.-ONE) THEN |
| 28943 | THECMS = TWOPI/2.0D0 |
| 28944 | ELSE |
| 28945 | THECMS = ACOS(COSTH) |
| 28946 | ENDIF |
| 28947 | IF ((THECMS.GT.TINY14).AND.((PI-THECMS).GT.TINY14)) THEN |
| 28948 | ETACMS = -LOG(TAN(THECMS/TWO)) |
| 28949 | ELSE |
| 28950 | ETACMS = 100.0D0 |
| 28951 | ENDIF |
| 28952 | XF = PZCMS/MAX(PPCM,TINY14) |
| 28953 | THECMS = THECMS/BOG |
| 28954 | ELSE |
| 28955 | PZCMS = PZ |
| 28956 | EECMS = PE |
| 28957 | YYCMS = YY |
| 28958 | ETACMS = ETA |
| 28959 | XF = XLAB |
| 28960 | THECMS = THETA/BOG |
| 28961 | ENDIF |
| 28962 | THETA = THETA/BOG |
| 28963 | |
| 28964 | * set flag for "grey/black" |
| 28965 | LGREY = .FALSE. |
| 28966 | LBLACK = .FALSE. |
| 28967 | EK = EKIN |
| 28968 | IF (IDHKK(IDX).EQ.80000) EK = EKIN/DBLE(IBARY) |
| 28969 | IF (MULDEF.EQ.1) THEN |
| 28970 | * EMU01-Def. |
| 28971 | IF ( ( (IDBJT.EQ. 1).AND.(EK.GT. 26.0D-3).AND. |
| 28972 | & (EK.LE.375.0D-3) ).OR. |
| 28973 | & ( (IDBJT.EQ.13).AND.(EK.GT. 12.0D-3).AND. |
| 28974 | & (EK.LE. 56.0D-3) ).OR. |
| 28975 | & ( (IDBJT.EQ.14).AND.(EK.GT. 12.0D-3).AND. |
| 28976 | & (EK.LE. 56.0D-3) ).OR. |
| 28977 | & ( (IDBJT.EQ.15).AND.(EK.GT. 20.0D-3).AND. |
| 28978 | & (EK.LE.198.0D-3) ).OR. |
| 28979 | & ( (IDBJT.EQ.16).AND.(EK.GT. 20.0D-3).AND. |
| 28980 | & (EK.LE.198.0D-3) ).OR. |
| 28981 | & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND. |
| 28982 | & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND. |
| 28983 | & (IDBJT.NE.16).AND. |
| 28984 | & (BETA.GT.0.23D0).AND.(BETA.LE.0.70D0) ) ) |
| 28985 | & LGREY = .TRUE. |
| 28986 | IF ( ( (IDBJT.EQ. 1).AND.(EK.LE. 26.0D-3) ).OR. |
| 28987 | & ( (IDBJT.EQ.13).AND.(EK.LE. 12.0D-3) ).OR. |
| 28988 | & ( (IDBJT.EQ.14).AND.(EK.LE. 12.0D-3) ).OR. |
| 28989 | & ( (IDBJT.EQ.15).AND.(EK.LE. 20.0D-3) ).OR. |
| 28990 | & ( (IDBJT.EQ.16).AND.(EK.LE. 20.0D-3) ).OR. |
| 28991 | & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND. |
| 28992 | & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND. |
| 28993 | & (IDBJT.NE.16).AND.(BETA.LE.0.23D0) ) ) |
| 28994 | & LBLACK = .TRUE. |
| 28995 | ELSE |
| 28996 | * common Def. |
| 28997 | IF ((BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)) LGREY=.TRUE. |
| 28998 | IF (BETA.LE.0.23D0) LBLACK=.TRUE. |
| 28999 | ENDIF |
| 29000 | LFSP = .TRUE. |
| 29001 | ELSEIF (ABS(ISTHKK(IDX)).EQ.ISTRNL) THEN |
| 29002 | IST = ISTHKK(IDX) |
| 29003 | IDPDG = IDHKK(IDX) |
| 29004 | LFRAG = .TRUE. |
| 29005 | IDBJT = 0 |
| 29006 | IBARY = IDRES(IDX) |
| 29007 | ICHAR = IDXRES(IDX) |
| 29008 | AMASS = PHKK(5,IDX) |
| 29009 | PE = PHKK(4,IDX) |
| 29010 | PX = PHKK(1,IDX) |
| 29011 | PY = PHKK(2,IDX) |
| 29012 | PZ = PHKK(3,IDX) |
| 29013 | PT2 = PX**2+PY**2 |
| 29014 | PT = SQRT(PT2) |
| 29015 | PTOT = SQRT(PT2+PZ**2) |
| 29016 | SINTHE = PT/MAX(PTOT,TINY14) |
| 29017 | COSTHE = PZ/MAX(PTOT,TINY14) |
| 29018 | IF (COSTHE.GT.ONE) THEN |
| 29019 | THETA = ZERO |
| 29020 | ELSEIF (COSTHE.LT.-ONE) THEN |
| 29021 | THETA = TWOPI/2.0D0 |
| 29022 | ELSE |
| 29023 | THETA = ACOS(COSTHE) |
| 29024 | ENDIF |
| 29025 | EKIN = PE-AMASS |
| 29026 | **sr 15.4.96 new E_t-definition |
| 29027 | C ET = PE*SINTHE |
| 29028 | ET = EKIN*SINTHE |
| 29029 | ** |
| 29030 | IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN |
| 29031 | ETA = -LOG(TAN(THETA/TWO)) |
| 29032 | ELSE |
| 29033 | ETA = 100.0D0 |
| 29034 | ENDIF |
| 29035 | THETA = THETA/BOG |
| 29036 | LRNL = .TRUE. |
| 29037 | ENDIF |
| 29038 | |
| 29039 | 9999 CONTINUE |
| 29040 | RETURN |
| 29041 | END |
| 29042 | |
| 29043 | *$ CREATE DT_HIMULT.FOR |
| 29044 | *COPY DT_HIMULT |
| 29045 | * |
| 29046 | *===himult=============================================================* |
| 29047 | * |
| 29048 | SUBROUTINE DT_HIMULT(MODE) |
| 29049 | |
| 29050 | ************************************************************************ |
| 29051 | * Tables of average energies/multiplicities. * |
| 29052 | * This version dated 30.08.2000 is written by S. Roesler * |
| 29053 | ************************************************************************ |
| 29054 | |
| 29055 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 29056 | SAVE |
| 29057 | PARAMETER ( LINP = 10 , |
| 29058 | & LOUT = 6 , |
| 29059 | & LDAT = 9 ) |
| 29060 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14) |
| 29061 | |
| 29062 | PARAMETER (SWMEXP=1.7D0) |
| 29063 | |
| 29064 | CHARACTER*8 ANAMEH(4) |
| 29065 | |
| 29066 | * particle properties (BAMJET index convention) |
| 29067 | CHARACTER*8 ANAME |
| 29068 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 29069 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 29070 | * temporary storage for one final state particle |
| 29071 | LOGICAL LFRAG,LGREY,LBLACK |
| 29072 | COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN, |
| 29073 | & SINTHE,COSTHE,THETA,THECMS, |
| 29074 | & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF, |
| 29075 | & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF, |
| 29076 | & LFRAG,LGREY,LBLACK |
| 29077 | * event flag used for histograms |
| 29078 | COMMON /DTNORM/ ICEVT,IEVHKK |
| 29079 | * Lorentz-parameters of the current interaction |
| 29080 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, |
| 29081 | & UMO,PPCM,EPROJ,PPROJ |
| 29082 | |
| 29083 | PARAMETER (NOPART=210) |
| 29084 | DIMENSION AVMULT(4,NOPART),AVE(4,NOPART),AVSWM(4,NOPART), |
| 29085 | & AVPT(4,NOPART),IAVPT(4,NOPART) |
| 29086 | DATA ANAMEH /'DEUTERON','3-H ','3-HE ','4-HE '/ |
| 29087 | |
| 29088 | GOTO (1,2,3) MODE |
| 29089 | |
| 29090 | *------------------------------------------------------------------ |
| 29091 | * initialization |
| 29092 | 1 CONTINUE |
| 29093 | DO 10 I=1,NOPART |
| 29094 | DO 11 J=1,4 |
| 29095 | AVMULT(J,I) = ZERO |
| 29096 | AVE(J,I) = ZERO |
| 29097 | AVSWM(J,I) = ZERO |
| 29098 | AVPT(J,I) = ZERO |
| 29099 | IAVPT(J,I) = 0 |
| 29100 | 11 CONTINUE |
| 29101 | 10 CONTINUE |
| 29102 | |
| 29103 | RETURN |
| 29104 | |
| 29105 | *------------------------------------------------------------------ |
| 29106 | * filling of histogram with event-record |
| 29107 | 2 CONTINUE |
| 29108 | IF (PE.LT.0.0D0) THEN |
| 29109 | WRITE(LOUT,*) ' HIMULT: PE < 0 ! ',PE |
| 29110 | RETURN |
| 29111 | ENDIF |
| 29112 | IF (.NOT.LFRAG) THEN |
| 29113 | IVEL = 2 |
| 29114 | IF (LGREY) IVEL = 3 |
| 29115 | IF (LBLACK) IVEL = 4 |
| 29116 | AVE(1,IDBJT) = AVE(1,IDBJT) +PE |
| 29117 | AVE(IVEL,IDBJT) = AVE(IVEL,IDBJT)+PE |
| 29118 | AVPT(1,IDBJT) = AVPT(1,IDBJT) +PT |
| 29119 | AVPT(IVEL,IDBJT) = AVPT(IVEL,IDBJT)+PT |
| 29120 | IAVPT(1,IDBJT) = IAVPT(1,IDBJT) +1 |
| 29121 | IAVPT(IVEL,IDBJT) = IAVPT(IVEL,IDBJT)+1 |
| 29122 | AVSWM(1,IDBJT) = AVSWM(1,IDBJT) +PE**SWMEXP |
| 29123 | AVSWM(IVEL,IDBJT) = AVSWM(IVEL,IDBJT)+PE**SWMEXP |
| 29124 | AVMULT(1,IDBJT) = AVMULT(1,IDBJT) +ONE |
| 29125 | AVMULT(IVEL,IDBJT) = AVMULT(IVEL,IDBJT)+ONE |
| 29126 | IF (IDBJT.LT.116) THEN |
| 29127 | * total energy, multiplicity |
| 29128 | AVE(1,30) = AVE(1,30) +PE |
| 29129 | AVE(IVEL,30) = AVE(IVEL,30)+PE |
| 29130 | AVPT(1,30) = AVPT(1,30) +PT |
| 29131 | AVPT(IVEL,30) = AVPT(IVEL,30)+PT |
| 29132 | IAVPT(1,30) = IAVPT(1,30) +1 |
| 29133 | IAVPT(IVEL,30) = IAVPT(IVEL,30)+1 |
| 29134 | AVSWM(1,30) = AVSWM(1,30)+PE**SWMEXP |
| 29135 | AVSWM(IVEL,30) = AVSWM(IVEL,30)+PE**SWMEXP |
| 29136 | AVMULT(1,30) = AVMULT(1,30) +ONE |
| 29137 | AVMULT(IVEL,30) = AVMULT(IVEL,30)+ONE |
| 29138 | * charged energy, multiplicity |
| 29139 | IF (ICHAR.LT.0) THEN |
| 29140 | AVE(1,26) = AVE(1,26) +PE |
| 29141 | AVE(IVEL,26) = AVE(IVEL,26)+PE |
| 29142 | AVPT(1,26) = AVPT(1,26) +PT |
| 29143 | AVPT(IVEL,26) = AVPT(IVEL,26)+PT |
| 29144 | IAVPT(1,26) = IAVPT(1,26) +1 |
| 29145 | IAVPT(IVEL,26) = IAVPT(IVEL,26)+1 |
| 29146 | AVSWM(1,26) = AVSWM(1,26) +PE**SWMEXP |
| 29147 | AVSWM(IVEL,26) = AVSWM(IVEL,26)+PE**SWMEXP |
| 29148 | AVMULT(1,26) = AVMULT(1,26) +ONE |
| 29149 | AVMULT(IVEL,26) = AVMULT(IVEL,26)+ONE |
| 29150 | ENDIF |
| 29151 | IF (ICHAR.NE.0) THEN |
| 29152 | AVE(1,27) = AVE(1,27) +PE |
| 29153 | AVE(IVEL,27) = AVE(IVEL,27)+PE |
| 29154 | AVPT(1,27) = AVPT(1,27) +PT |
| 29155 | AVPT(IVEL,27) = AVPT(IVEL,27)+PT |
| 29156 | IAVPT(1,27) = IAVPT(1,27) +1 |
| 29157 | IAVPT(IVEL,27) = IAVPT(IVEL,27)+1 |
| 29158 | AVSWM(1,27) = AVSWM(1,27) +PE**SWMEXP |
| 29159 | AVSWM(IVEL,27) = AVSWM(IVEL,27)+PE**SWMEXP |
| 29160 | AVMULT(1,27) = AVMULT(1,27) +ONE |
| 29161 | AVMULT(IVEL,27) = AVMULT(IVEL,27)+ONE |
| 29162 | ENDIF |
| 29163 | ENDIF |
| 29164 | ENDIF |
| 29165 | |
| 29166 | RETURN |
| 29167 | |
| 29168 | *------------------------------------------------------------------ |
| 29169 | * output |
| 29170 | 3 CONTINUE |
| 29171 | WRITE(LOUT,3000) |
| 29172 | 3000 FORMAT(/,1X,'HIMULT:',21X,'particle - statistics',/, |
| 29173 | & 29X,'---------------------',/) |
| 29174 | IF (MULDEF.EQ.1) THEN |
| 29175 | WRITE(LOUT,'(1X,A,/)') 'fast/grey/black: EMU-def.' |
| 29176 | ELSE |
| 29177 | BETGRE = 0.7D0 |
| 29178 | BETBLC = 0.23D0 |
| 29179 | WRITE(LOUT,3002) BETGRE,BETGRE,BETBLC,BETBLC |
| 29180 | 3002 FORMAT(1X,'fast: beta > ',F4.2,' grey: ',F4.2,' > beta > ' |
| 29181 | & ,F4.2,' black: beta < ',F4.2,/) |
| 29182 | ENDIF |
| 29183 | WRITE(LOUT,3003) SWMEXP |
| 29184 | 3003 FORMAT(1X,'particle |',12X,'average multiplicity',/, |
| 29185 | & 13X,'| total fast', |
| 29186 | C & ' grey black K f(',F3.1,')',/,1X, |
| 29187 | & ' grey black <pt> f(',F3.1,')',/,1X, |
| 29188 | & '------------+--------------', |
| 29189 | & '-------------------------------------------------') |
| 29190 | DO 30 I=1,NOPART |
| 29191 | DO 31 J=1,4 |
| 29192 | AVMULT(J,I) = AVMULT(J,I)/DBLE(MAX(ICEVT,1)) |
| 29193 | AVE(J,I) = AVE(J,I)/DBLE(MAX(ICEVT,1))/EPROJ |
| 29194 | AVPT(J,I) = AVPT(J,I)/DBLE(MAX(IAVPT(J,I),1)) |
| 29195 | AVSWM(J,I) = AVSWM(J,I)/DBLE(MAX(ICEVT,1))/EPROJ**SWMEXP |
| 29196 | 31 CONTINUE |
| 29197 | IF (I.LE.115) THEN |
| 29198 | WRITE(LOUT,3004) ANAME(I),I, |
| 29199 | & AVMULT(1,I),AVMULT(2,I), |
| 29200 | & AVMULT(3,I),AVMULT(4,I), |
| 29201 | C & AVE(1,I),AVSWM(1,I) |
| 29202 | & AVPT(1,I),AVSWM(1,I) |
| 29203 | ELSEIF (I.LE.119) THEN |
| 29204 | WRITE(LOUT,3004) ANAMEH(I-115),I, |
| 29205 | & AVMULT(1,I),AVMULT(2,I), |
| 29206 | & AVMULT(3,I),AVMULT(4,I), |
| 29207 | C & AVE(1,I),AVSWM(1,I) |
| 29208 | & AVPT(1,I),AVSWM(1,I) |
| 29209 | ENDIF |
| 29210 | 3004 FORMAT(1X,A8,I4,'| ',2F13.6,2F9.5,2F9.5) |
| 29211 | 30 CONTINUE |
| 29212 | **temporary |
| 29213 | C WRITE(LOUT,'(A,F7.3)') ' number of charged heavy particles: ', |
| 29214 | C & AVMULT(3,27)+AVMULT(4,27) |
| 29215 | ** |
| 29216 | |
| 29217 | RETURN |
| 29218 | END |
| 29219 | |
| 29220 | *$ CREATE DT_HISTAT.FOR |
| 29221 | *COPY DT_HISTAT |
| 29222 | * |
| 29223 | *===histat=============================================================* |
| 29224 | * |
| 29225 | SUBROUTINE DT_HISTAT(IDX,MODE) |
| 29226 | |
| 29227 | ************************************************************************ |
| 29228 | * This version dated 26.02.96 is written by S. Roesler * |
| 29229 | * * |
| 29230 | * Last change 27.12.2006 by S. Roesler. * |
| 29231 | ************************************************************************ |
| 29232 | |
| 29233 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 29234 | SAVE |
| 29235 | PARAMETER ( LINP = 10 , |
| 29236 | & LOUT = 6 , |
| 29237 | & LDAT = 9 ) |
| 29238 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14) |
| 29239 | PARAMETER (NDIM=199) |
| 29240 | |
| 29241 | * event history |
| 29242 | PARAMETER (NMXHKK=200000) |
| 29243 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 29244 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 29245 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 29246 | * extended event history |
| 29247 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 29248 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 29249 | & IHIST(2,NMXHKK) |
| 29250 | * particle properties (BAMJET index convention) |
| 29251 | CHARACTER*8 ANAME |
| 29252 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 29253 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 29254 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 29255 | * Glauber formalism: cross sections |
| 29256 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, |
| 29257 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), |
| 29258 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), |
| 29259 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), |
| 29260 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), |
| 29261 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), |
| 29262 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), |
| 29263 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), |
| 29264 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), |
| 29265 | & BSLOPE,NEBINI,NQBINI |
| 29266 | * emulsion treatment |
| 29267 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), |
| 29268 | & NCOMPO,IEMUL |
| 29269 | * properties of interacting particles |
| 29270 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG |
| 29271 | * rejection counter |
| 29272 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, |
| 29273 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, |
| 29274 | & IREXCI(3),IRDIFF(2),IRINC |
| 29275 | * statistics: residual nuclei |
| 29276 | COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2), |
| 29277 | & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2), |
| 29278 | & NINCST(2,4),NINCEV(2), |
| 29279 | & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2), |
| 29280 | & NRESPB(2),NRESCH(2),NRESEV(4), |
| 29281 | & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240), |
| 29282 | & NEVAFI(2,2) |
| 29283 | * parameter for intranuclear cascade |
| 29284 | LOGICAL LPAULI |
| 29285 | COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI |
| 29286 | * (original name: PAREVT) |
| 29287 | LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX, |
| 29288 | & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF |
| 29289 | PARAMETER ( NALLWP = 39 ) |
| 29290 | COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, |
| 29291 | & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY, |
| 29292 | & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV, |
| 29293 | & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF |
| 29294 | * (original name: FRBKCM) |
| 29295 | PARAMETER ( MXFFBK = 6 ) |
| 29296 | PARAMETER ( MXZFBK = 9 ) |
| 29297 | PARAMETER ( MXNFBK = 10 ) |
| 29298 | PARAMETER ( MXAFBK = 16 ) |
| 29299 | PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 ) |
| 29300 | PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 ) |
| 29301 | PARAMETER ( NXAFBK = MXAFBK + 1 ) |
| 29302 | PARAMETER ( MXPSST = 300 ) |
| 29303 | PARAMETER ( MXPSFB = 41000 ) |
| 29304 | LOGICAL LFRMBK, LNCMSS |
| 29305 | COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST), |
| 29306 | & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB), |
| 29307 | & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK, |
| 29308 | & IFRBKN (MXPSST), IFRBKZ (MXPSST), |
| 29309 | & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST), |
| 29310 | & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK), |
| 29311 | & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK), |
| 29312 | & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF, |
| 29313 | & IFBFRB, NBUFBK, LFRMBK, LNCMSS |
| 29314 | * (original name: INPFLG) |
| 29315 | COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK |
| 29316 | * temporary storage for one final state particle |
| 29317 | LOGICAL LFRAG,LGREY,LBLACK |
| 29318 | COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN, |
| 29319 | & SINTHE,COSTHE,THETA,THECMS, |
| 29320 | & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF, |
| 29321 | & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF, |
| 29322 | & LFRAG,LGREY,LBLACK |
| 29323 | * event flag used for histograms |
| 29324 | COMMON /DTNORM/ ICEVT,IEVHKK |
| 29325 | * statistics: double-Pomeron exchange |
| 29326 | COMMON /DTFLG2/ INTFLG,IPOPO |
| 29327 | |
| 29328 | DIMENSION EMUSAM(NCOMPX) |
| 29329 | |
| 29330 | CHARACTER*13 CMSG(3) |
| 29331 | DATA CMSG /'not requested','not requested','not requested'/ |
| 29332 | |
| 29333 | GOTO (1,2,3,4,5) MODE |
| 29334 | |
| 29335 | *------------------------------------------------------------------ |
| 29336 | * initialization |
| 29337 | 1 CONTINUE |
| 29338 | * emulsion treatment |
| 29339 | IF (NCOMPO.GT.0) THEN |
| 29340 | DO 10 I=1,NCOMPX |
| 29341 | EMUSAM(I) = ZERO |
| 29342 | 10 CONTINUE |
| 29343 | ENDIF |
| 29344 | * common /DTSTA2/, statistics on i.n.c., residual nuclei, evap. |
| 29345 | NINCGE = 0 |
| 29346 | DO 11 I=1,2 |
| 29347 | EXCDPM(I) = ZERO |
| 29348 | EXCDPM(I+2) = ZERO |
| 29349 | EXCEVA(I) = ZERO |
| 29350 | NINCWO(I) = 0 |
| 29351 | NINCEV(I) = 0 |
| 29352 | NRESTO(I) = 0 |
| 29353 | NRESPR(I) = 0 |
| 29354 | NRESNU(I) = 0 |
| 29355 | NRESBA(I) = 0 |
| 29356 | NRESPB(I) = 0 |
| 29357 | NRESCH(I) = 0 |
| 29358 | NRESEV(I) = 0 |
| 29359 | NRESEV(I+2) = 0 |
| 29360 | NEVAGA(I) = 0 |
| 29361 | NEVAHT(I) = 0 |
| 29362 | NEVAFI(1,I) = 0 |
| 29363 | NEVAFI(2,I) = 0 |
| 29364 | DO 12 J=1,6 |
| 29365 | IF (J.LE.2) NINCHR(I,J) = 0 |
| 29366 | IF (J.LE.3) NINCCO(I,J) = 0 |
| 29367 | IF (J.LE.4) NINCST(I,J) = 0 |
| 29368 | NEVA(I,J) = 0 |
| 29369 | 12 CONTINUE |
| 29370 | DO 13 J=1,210 |
| 29371 | NEVAHY(1,I,J) = 0 |
| 29372 | NEVAHY(2,I,J) = 0 |
| 29373 | 13 CONTINUE |
| 29374 | 11 CONTINUE |
| 29375 | MAXGEN = 0 |
| 29376 | **dble Po statistics. |
| 29377 | KPOPO = 0 |
| 29378 | |
| 29379 | RETURN |
| 29380 | *------------------------------------------------------------------ |
| 29381 | * filling of histogram with event-record |
| 29382 | 2 CONTINUE |
| 29383 | IF (IST.EQ.-1) THEN |
| 29384 | IF (.NOT.LFRAG) THEN |
| 29385 | IF (IDPDG.EQ.2212) THEN |
| 29386 | NEVA(NOBAM(IDX),1) = NEVA(NOBAM(IDX),1)+1 |
| 29387 | ELSEIF (IDPDG.EQ.2112) THEN |
| 29388 | NEVA(NOBAM(IDX),2) = NEVA(NOBAM(IDX),2)+1 |
| 29389 | ELSEIF (IDPDG.EQ.22) THEN |
| 29390 | NEVAGA(NOBAM(IDX)) = NEVAGA(NOBAM(IDX))+1 |
| 29391 | ELSEIF (IDPDG.EQ.80000) THEN |
| 29392 | IF (IDBJT.EQ.116) THEN |
| 29393 | NEVA(NOBAM(IDX),3) = NEVA(NOBAM(IDX),3)+1 |
| 29394 | ELSEIF (IDBJT.EQ.117) THEN |
| 29395 | NEVA(NOBAM(IDX),4) = NEVA(NOBAM(IDX),4)+1 |
| 29396 | ELSEIF (IDBJT.EQ.118) THEN |
| 29397 | NEVA(NOBAM(IDX),5) = NEVA(NOBAM(IDX),5)+1 |
| 29398 | ELSEIF (IDBJT.EQ.119) THEN |
| 29399 | NEVA(NOBAM(IDX),6) = NEVA(NOBAM(IDX),6)+1 |
| 29400 | ENDIF |
| 29401 | ENDIF |
| 29402 | ELSE |
| 29403 | * heavy fragments (here: fission products only) |
| 29404 | NEVAHY(NOBAM(IDX),1,IBARY) = NEVAHY(NOBAM(IDX),1,IBARY)+1 |
| 29405 | NEVAHY(NOBAM(IDX),2,ICHAR) = NEVAHY(NOBAM(IDX),2,ICHAR)+1 |
| 29406 | NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1 |
| 29407 | ENDIF |
| 29408 | ELSEIF ((IST.EQ.1).AND.(.NOT.LFRAG)) THEN |
| 29409 | IF (IDCH(IDX).GT.MAXGEN) MAXGEN = IDCH(IDX) |
| 29410 | ENDIF |
| 29411 | |
| 29412 | RETURN |
| 29413 | *------------------------------------------------------------------ |
| 29414 | * output |
| 29415 | 3 CONTINUE |
| 29416 | |
| 29417 | **dble Po statistics. |
| 29418 | C WRITE(LOUT,'(1X,A,2I7,2E12.4)') |
| 29419 | C & '# evts. / # dble-Po. evts / s_in / s_popo :', |
| 29420 | C & ICEVT,KPOPO,XSPRO(1,1,1),XSPRO(1,1,1)*DBLE(KPOPO)/DBLE(ICEVT) |
| 29421 | |
| 29422 | * emulsion treatment |
| 29423 | IF (NCOMPO.GT.0) THEN |
| 29424 | WRITE(LOUT,3000) |
| 29425 | 3000 FORMAT(/,1X,'HISTAT:',14X,'statistics - target emulsion',/, |
| 29426 | & 22X,'----------------------------',/,/,19X, |
| 29427 | & 'mass charge fraction',/,39X, |
| 29428 | & 'input treated',/) |
| 29429 | DO 30 I=1,NCOMPO |
| 29430 | WRITE(LOUT,3013) I,IEMUMA(I),IEMUCH(I),EMUFRA(I), |
| 29431 | & EMUSAM(I)/DBLE(ICEVT) |
| 29432 | 3013 FORMAT(12X,I2,1X,2I8,6X,F7.3,5X,F7.3) |
| 29433 | 30 CONTINUE |
| 29434 | ENDIF |
| 29435 | |
| 29436 | * i.n.c. statistics: output |
| 29437 | WRITE(LOUT,3001) ICEVT,NRESEV(2),IRINC |
| 29438 | 3001 FORMAT(/,1X,'HISTAT:',14X,'statistics - intranuclear cascade',/, |
| 29439 | & 22X,'---------------------------------',/,/,1X, |
| 29440 | & 'no. of events for normalization: (accepted final events,', |
| 29441 | & ' evt)',4X,I6,/,34X,'(events before evap.-step, evt1)',I6, |
| 29442 | & /,1X,'no. of rejected events due to intranuclear', |
| 29443 | & ' cascade',15X,I6,/) |
| 29444 | ICEV = MAX(ICEVT,1) |
| 29445 | ICEV1 = ICEV |
| 29446 | IF (LEVPRT) ICEV1 = MAX(NRESEV(2),1) |
| 29447 | WRITE(LOUT,3002) |
| 29448 | & (DBLE(NINCWO(I))/DBLE(ICEV),I=1,2), |
| 29449 | & ((DBLE(NINCST(I,J))/DBLE(ICEV),I=1,2),J=1,4), |
| 29450 | & KTAUGE,DBLE(NINCGE)/DBLE(ICEV), |
| 29451 | & (DBLE(NINCCO(I,1)+NINCCO(I,2)+NINCCO(I,3))/DBLE(ICEV1),I=1,2), |
| 29452 | & (DBLE(NINCCO(I,2))/DBLE(ICEV1),I=1,2), |
| 29453 | & (DBLE(NINCCO(I,3))/DBLE(ICEV1),I=1,2), |
| 29454 | & (DBLE(NINCCO(I,1))/DBLE(ICEV1),I=1,2) |
| 29455 | 3002 FORMAT(1X,'no. of wounded nucl. in proj./ target (mean per evt)', |
| 29456 | & 5X,F6.2,' /',F6.2,/,1X,'no. of particles unable to escape', |
| 29457 | & ' proj./ target (mean per evt)',/,8X,'baryons: pos. ', |
| 29458 | & F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3,/,8X, |
| 29459 | & 'mesons: pos. ',F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3, |
| 29460 | & /,1X,'maximum no. of generations treated (maximum allowed:' |
| 29461 | & ,I4,')',/,43X,'(mean per evt)',5X,F6.2,/,1X,'no. of sec.', |
| 29462 | & ' interactions in proj./ target (mean per evt1)', |
| 29463 | & F7.3,' /',F7.3,/,8X,'out of which by inelastic', |
| 29464 | & ' interactions',12X,F7.3,' /',F7.3,/,21X,'by elastic ', |
| 29465 | & 'interactions',14X,F7.3,' /',F7.3,/,21X,'by absorption ', |
| 29466 | & '(ap, K-, pi- only) ',F7.3,' /',F7.3,/) |
| 29467 | WRITE(LOUT,3003) NRESEV(2),NRESEV(4),IREXCI, |
| 29468 | & IREXCI(1)+IREXCI(2)+IREXCI(3) |
| 29469 | 3003 FORMAT(/,1X,'HISTAT:',14X,'statistics - residual nuclei, ', |
| 29470 | & 'evaporation',/,22X,'-----------------------------', |
| 29471 | & '------------',/,/,1X,'no. of events for normal.: ', |
| 29472 | & '(events handled by FICONF, evt)',7X,I6,/,28X,'(events', |
| 29473 | & ' passing the evap.-step, evt1) ',I6,/,1X,'no. of', |
| 29474 | & ' rejected events (',I4,',',I4,',',I4,')',22X,I6,/) |
| 29475 | |
| 29476 | WRITE(LOUT,3004) |
| 29477 | 3004 FORMAT(/,22X,'1) before evaporation-step:',/) |
| 29478 | ICEV = MAX(NRESEV(2),1) |
| 29479 | WRITE(LOUT,3005) |
| 29480 | & (DBLE(NRESTO(I))/DBLE(ICEV),I=1,2), |
| 29481 | & (DBLE(NRESPR(I))/DBLE(ICEV),I=1,2), |
| 29482 | & (DBLE(NRESNU(I))/DBLE(ICEV),I=1,2), |
| 29483 | & (DBLE(NRESBA(I))/DBLE(ICEV),I=1,2), |
| 29484 | & (DBLE(NRESPB(I))/DBLE(ICEV),I=1,2), |
| 29485 | & (DBLE(NRESCH(I))/DBLE(ICEV),I=1,2), |
| 29486 | & (EXCDPM(I)/DBLE(ICEV),I=1,2), |
| 29487 | & (EXCDPM(I+2)/DBLE(ICEV),I=1,2) |
| 29488 | 3005 FORMAT(1X,'residual nuclei: (mean values per evt)',12X, |
| 29489 | & 'proj. / target',/,/,8X,'total number of particles',15X, |
| 29490 | & 2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X, |
| 29491 | & 'neutrons',18X,2F9.3,/,22X,'baryons',19X,2F9.3,/,22X, |
| 29492 | & 'pos. baryons',14X,2F9.3,/,8X,'total charge',28X,2F9.3,/, |
| 29493 | & /,8X,'excitation energy (bef. evap.-step) ',2E11.3,/, |
| 29494 | & 8X,'excitation energy per nucleon ',2E11.3,/,/) |
| 29495 | |
| 29496 | * evaporation / fission / fragmentation statistics: output |
| 29497 | ICEV = MAX(NRESEV(2),1) |
| 29498 | ICEV1 = MAX(NRESEV(4),1) |
| 29499 | NTEVA1 = |
| 29500 | & NEVA(1,1)+NEVA(1,2)+NEVA(1,3)+NEVA(1,4)+NEVA(1,5)+NEVA(1,6) |
| 29501 | NTEVA2 = |
| 29502 | & NEVA(2,1)+NEVA(2,2)+NEVA(2,3)+NEVA(2,4)+NEVA(2,5)+NEVA(2,6) |
| 29503 | IF (LEVPRT) THEN |
| 29504 | IF (IFISS.EQ.1) CMSG(1) = 'requested ' |
| 29505 | IF (LFRMBK) CMSG(2) = 'requested ' |
| 29506 | IF (LDEEXG) CMSG(3) = 'requested ' |
| 29507 | WRITE(LOUT,3006) |
| 29508 | & CMSG, |
| 29509 | & DBLE(NTEVA1)/DBLE(ICEV1),DBLE(NTEVA2)/DBLE(ICEV1), |
| 29510 | & (DBLE(NEVA(I,1))/DBLE(ICEV1),I=1,2), |
| 29511 | & (DBLE(NEVA(I,2))/DBLE(ICEV1),I=1,2), |
| 29512 | & (DBLE(NEVA(I,3))/DBLE(ICEV1),I=1,2), |
| 29513 | & (DBLE(NEVA(I,4))/DBLE(ICEV1),I=1,2), |
| 29514 | & (DBLE(NEVA(I,5))/DBLE(ICEV1),I=1,2), |
| 29515 | & (DBLE(NEVA(I,6))/DBLE(ICEV1),I=1,2), |
| 29516 | & (DBLE(NEVAGA(I))/DBLE(ICEV1),I=1,2), |
| 29517 | & (DBLE(NEVAHT(I))/DBLE(ICEV1),I=1,2) |
| 29518 | 3006 FORMAT(22X,'2) after evaporation-step:',/,/,1X,'Fission:', |
| 29519 | & 13X,A13,/,1X,'Fermi-Break-up:',6X,A13,/,1X,'Gamma-', |
| 29520 | & 'deexcitation:',2X,A13,/,/, |
| 29521 | & 1X,'evaporation/deexcitation: (mean values per evt1) ', |
| 29522 | & 'proj. / target',/,/,8X,'total number of evap. particles', |
| 29523 | & 9X,2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X, |
| 29524 | & 'neutrons',18X,2F9.3,/,22X,'deuterons',17X,2F9.3,/,22X, |
| 29525 | & '3-H',23X,2F9.3,/,22X,'3-He',22X,2F9.3,/,22X,'4-He',22X, |
| 29526 | & 2F9.3,/,8X,'nucl. deexcit. gammas',19X,2F9.3,/,8X, |
| 29527 | & 'heavy fragments',25X,2F9.3,/) |
| 29528 | IF (IFISS.EQ.1) THEN |
| 29529 | WRITE(LOUT,3007) NEVAFI(1,1),NEVAFI(1,2), |
| 29530 | & NEVAFI(2,1),NEVAFI(2,2), |
| 29531 | & DBLE(NEVAFI(2,1))/DBLE(MAX(NEVAFI(1,1),1))*100.0D0, |
| 29532 | & DBLE(NEVAFI(2,2))/DBLE(MAX(NEVAFI(1,2),1))*100.0D0 |
| 29533 | 3007 FORMAT(1X,'Fission: total number of events',14X,2I9,/ |
| 29534 | & 12X,'out of which fission occured',8X,2I9,/, |
| 29535 | & 50X,'(',F5.2,'%) (',F5.2,'%)',/) |
| 29536 | ENDIF |
| 29537 | C IF ((LFRMBK).OR.(IFISS.EQ.1)) THEN |
| 29538 | C WRITE(LOUT,3008) |
| 29539 | C3008 FORMAT(1X,'heavy fragments - statistics:',7X,'charge', |
| 29540 | C & ' proj. / target',/) |
| 29541 | C DO 31 I=1,210 |
| 29542 | C IF ((NEVAHY(1,2,I).NE.0).OR.(NEVAHY(2,2,I).NE.0)) THEN |
| 29543 | C WRITE(LOUT,3009) I, |
| 29544 | C & (DBLE(NEVAHY(K,2,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2) |
| 29545 | C3009 FORMAT(38X,I3,3X,2E12.3) |
| 29546 | C ENDIF |
| 29547 | C 31 CONTINUE |
| 29548 | C WRITE(LOUT,3010) |
| 29549 | C3010 FORMAT(1X,'heavy fragments - statistics:',7X,'mass ', |
| 29550 | C & ' proj. / target',/) |
| 29551 | C DO 32 I=1,210 |
| 29552 | C IF ((NEVAHY(1,1,I).NE.0).OR.(NEVAHY(2,1,I).NE.0)) THEN |
| 29553 | C WRITE(LOUT,3011) I, |
| 29554 | C & (DBLE(NEVAHY(K,1,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2) |
| 29555 | C3011 FORMAT(38X,I3,3X,2E12.3) |
| 29556 | C ENDIF |
| 29557 | C 32 CONTINUE |
| 29558 | C WRITE(LOUT,*) |
| 29559 | C ENDIF |
| 29560 | ELSE |
| 29561 | WRITE(LOUT,3012) |
| 29562 | 3012 FORMAT(22X,'2) after evaporation-step:',/,/,1X, |
| 29563 | & 'Evaporation: not requested',/) |
| 29564 | ENDIF |
| 29565 | |
| 29566 | RETURN |
| 29567 | *------------------------------------------------------------------ |
| 29568 | * filling of histogram with event-record |
| 29569 | 4 CONTINUE |
| 29570 | * emulsion treatment |
| 29571 | IF (NCOMPO.GT.0) THEN |
| 29572 | DO 40 I=1,NCOMPO |
| 29573 | IF (IT.EQ.IEMUMA(I)) THEN |
| 29574 | EMUSAM(I) = EMUSAM(I)+ONE |
| 29575 | ENDIF |
| 29576 | 40 CONTINUE |
| 29577 | ENDIF |
| 29578 | NINCGE = NINCGE+MAXGEN |
| 29579 | MAXGEN = 0 |
| 29580 | **dble Po statistics. |
| 29581 | IF (IPOPO.EQ.1) KPOPO = KPOPO+1 |
| 29582 | |
| 29583 | RETURN |
| 29584 | *------------------------------------------------------------------ |
| 29585 | * filling of histogram with event-record |
| 29586 | 5 CONTINUE |
| 29587 | IF ((ISTHKK(IDX).EQ.15).OR.(ISTHKK(IDX).EQ.16)) THEN |
| 29588 | IB = IIBAR(IDBAM(IDX)) |
| 29589 | IC = IICH(IDBAM(IDX)) |
| 29590 | J = ISTHKK(IDX)-14 |
| 29591 | IF ( ((ABS(IB).EQ.1).AND.(IC.EQ.1)).OR.(IC.EQ.0) ) THEN |
| 29592 | NINCST(J,1) = NINCST(J,1)+1 |
| 29593 | ELSEIF ((ABS(IB).EQ.1).AND.(IC.EQ.-1)) THEN |
| 29594 | NINCST(J,2) = NINCST(J,2)+1 |
| 29595 | ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ. 1)) THEN |
| 29596 | NINCST(J,3) = NINCST(J,3)+1 |
| 29597 | ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ.-1)) THEN |
| 29598 | NINCST(J,4) = NINCST(J,4)+1 |
| 29599 | ENDIF |
| 29600 | ELSEIF (ISTHKK(IDX).EQ.17) THEN |
| 29601 | NINCWO(1) = NINCWO(1)+1 |
| 29602 | ELSEIF (ISTHKK(IDX).EQ.18) THEN |
| 29603 | NINCWO(2) = NINCWO(2)+1 |
| 29604 | ELSEIF (ISTHKK(IDX).EQ.1001) THEN |
| 29605 | IB = IDRES(IDX) |
| 29606 | IC = IDXRES(IDX) |
| 29607 | IF (IC.GT.0) THEN |
| 29608 | NEVAHY(NOBAM(IDX),1,IB) = NEVAHY(NOBAM(IDX),1,IB)+1 |
| 29609 | NEVAHY(NOBAM(IDX),2,IC) = NEVAHY(NOBAM(IDX),2,IC)+1 |
| 29610 | ENDIF |
| 29611 | NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1 |
| 29612 | ENDIF |
| 29613 | |
| 29614 | RETURN |
| 29615 | END |
| 29616 | |
| 29617 | *$ CREATE DT_NEWHGR.FOR |
| 29618 | *COPY DT_NEWHGR |
| 29619 | * |
| 29620 | *===newhgr=============================================================* |
| 29621 | * |
| 29622 | SUBROUTINE DT_NEWHGR(XLIM1,XLIM2,XLIM3,XLIMB,IBIN,IREFN) |
| 29623 | |
| 29624 | ************************************************************************ |
| 29625 | * * |
| 29626 | * Histogram initialization. * |
| 29627 | * * |
| 29628 | * input: XLIM1/XLIM2 lower/upper edge of histogram-window * |
| 29629 | * XLIM3 bin size * |
| 29630 | * IBIN > 0 number of bins in equidistant lin. binning * |
| 29631 | * = -1 reset histograms * |
| 29632 | * < -1 |IBIN| number of bins in equidistant log. * |
| 29633 | * binning or log. binning in user def. struc. * |
| 29634 | * XLIMB(*) user defined bin structure * |
| 29635 | * * |
| 29636 | * The bin structure is sensitive to * |
| 29637 | * XLIM1, XLIM3, IBIN if XLIM3 > 0 (lin.) * |
| 29638 | * XLIM1, XLIM2, IBIN if XLIM3 = 0 (lin. & log.) * |
| 29639 | * XLIMB, IBIN if XLIM3 < 0 * |
| 29640 | * * |
| 29641 | * * |
| 29642 | * output: IREFN histogram index * |
| 29643 | * (= -1 for inconsistent histogr. request) * |
| 29644 | * * |
| 29645 | * This subroutine is based on a original version by R. Engel. * |
| 29646 | * This version dated 22.4.95 is written by S. Roesler. * |
| 29647 | ************************************************************************ |
| 29648 | |
| 29649 | IMPLICIT DOUBLE PRECISION(A-H,O-Z) |
| 29650 | SAVE |
| 29651 | PARAMETER ( LINP = 10 , |
| 29652 | & LOUT = 6 , |
| 29653 | & LDAT = 9 ) |
| 29654 | |
| 29655 | LOGICAL LSTART |
| 29656 | |
| 29657 | PARAMETER (ZERO = 0.0D0, |
| 29658 | & TINY = 1.0D-10) |
| 29659 | |
| 29660 | DIMENSION XLIMB(*) |
| 29661 | |
| 29662 | * histograms |
| 29663 | PARAMETER (NHIS=150, NDIM=250) |
| 29664 | COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS), |
| 29665 | & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL |
| 29666 | * auxiliary common for histograms |
| 29667 | COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS) |
| 29668 | |
| 29669 | DATA LSTART /.TRUE./ |
| 29670 | |
| 29671 | * reset histogram counter |
| 29672 | IF (LSTART.OR.(IBIN.EQ.-1)) THEN |
| 29673 | IHISL = 0 |
| 29674 | IF (IBIN.EQ.-1) RETURN |
| 29675 | LSTART = .FALSE. |
| 29676 | ENDIF |
| 29677 | |
| 29678 | IHIS = IHISL+1 |
| 29679 | * check for maximum number of allowed histograms |
| 29680 | IF (IHIS.GT.NHIS) THEN |
| 29681 | WRITE(LOUT,1003) IHIS,NHIS,IHIS |
| 29682 | 1003 FORMAT(1X,'NEWHGR: warning! number of histograms (', |
| 29683 | & I4,') exceeds array size (',I4,')',/,21X, |
| 29684 | & 'histogram',I3,' skipped!') |
| 29685 | GOTO 9999 |
| 29686 | ENDIF |
| 29687 | |
| 29688 | IREFN = IHIS |
| 29689 | IBINS(IHIS) = ABS(IBIN) |
| 29690 | * check requested number of bins |
| 29691 | IF (IBINS(IHIS).GE.NDIM) THEN |
| 29692 | WRITE(LOUT,1000) IBIN,NDIM,NDIM |
| 29693 | 1000 FORMAT(1X,'NEWHGR: warning! number of bins (', |
| 29694 | & I3,') exceeds array size (',I3,')',/,21X, |
| 29695 | & 'and will be reset to ',I3) |
| 29696 | IBINS(IHIS) = NDIM |
| 29697 | ENDIF |
| 29698 | IF (IBINS(IHIS).EQ.0) THEN |
| 29699 | WRITE(LOUT,1001) IBIN,IHIS |
| 29700 | 1001 FORMAT(1X,'NEWHGR: warning! inconsistent number of', |
| 29701 | & ' bins (',I3,')',/,21X,'histogram',I3,' skipped!') |
| 29702 | GOTO 9999 |
| 29703 | ENDIF |
| 29704 | |
| 29705 | * initialize arrays |
| 29706 | DO 1 I=1,NDIM |
| 29707 | DO 2 K=1,3 |
| 29708 | HIST(K,IHIS,I) = ZERO |
| 29709 | HIST(K+3,IHIS,I) = ZERO |
| 29710 | TMPHIS(K,IHIS,I) = ZERO |
| 29711 | 2 CONTINUE |
| 29712 | HIST(7,IHIS,I) = ZERO |
| 29713 | 1 CONTINUE |
| 29714 | DENTRY(1,IHIS)= ZERO |
| 29715 | DENTRY(2,IHIS)= ZERO |
| 29716 | OVERF(IHIS) = ZERO |
| 29717 | UNDERF(IHIS) = ZERO |
| 29718 | TMPUFL(IHIS) = ZERO |
| 29719 | TMPOFL(IHIS) = ZERO |
| 29720 | |
| 29721 | * bin str. sensitive to lower edge, bin size, and numb. of bins |
| 29722 | IF (XLIM3.GT.ZERO) THEN |
| 29723 | DO 3 K=1,IBINS(IHIS)+1 |
| 29724 | HIST(1,IHIS,K) = XLIM1+DBLE(K-1)*XLIM3 |
| 29725 | 3 CONTINUE |
| 29726 | ISWI(IHIS) = 1 |
| 29727 | * bin str. sensitive to lower/upper edge and numb. of bins |
| 29728 | ELSEIF (XLIM3.EQ.ZERO) THEN |
| 29729 | * linear binning |
| 29730 | IF (IBIN.GT.0) THEN |
| 29731 | XLOW = XLIM1 |
| 29732 | XHI = XLIM2 |
| 29733 | IF (XLIM2.LE.XLIM1) THEN |
| 29734 | WRITE(LOUT,1002) XLIM1,XLIM2 |
| 29735 | 1002 FORMAT(1X,'NEWHGR: warning! inconsistent x-range', |
| 29736 | & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')') |
| 29737 | GOTO 9999 |
| 29738 | ENDIF |
| 29739 | ISWI(IHIS) = 1 |
| 29740 | ELSEIF (IBIN.LT.-1) THEN |
| 29741 | * logarithmic binning |
| 29742 | IF ((XLIM1.LE.ZERO).OR.(XLIM2.LE.ZERO)) THEN |
| 29743 | WRITE(LOUT,1004) XLIM1,XLIM2 |
| 29744 | 1004 FORMAT(1X,'NEWHGR: warning! inconsistent log. ', |
| 29745 | & 'binning',/,21X,'(XLIM1,XLIM2 = ',2E11.4,')') |
| 29746 | GOTO 9999 |
| 29747 | ENDIF |
| 29748 | IF (XLIM2.LE.XLIM1) THEN |
| 29749 | WRITE(LOUT,1005) XLIM1,XLIM2 |
| 29750 | 1005 FORMAT(1X,'NEWHGR: warning! inconsistent x-range', |
| 29751 | & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')') |
| 29752 | GOTO 9999 |
| 29753 | ENDIF |
| 29754 | XLOW = LOG10(XLIM1) |
| 29755 | XHI = LOG10(XLIM2) |
| 29756 | ISWI(IHIS) = 3 |
| 29757 | ENDIF |
| 29758 | DX = ABS(XHI-XLOW)/DBLE(MAX(IBINS(IHIS),1)) |
| 29759 | DO 4 K=1,IBINS(IHIS)+1 |
| 29760 | HIST(1,IHIS,K) = XLOW+DBLE(K-1)*DX |
| 29761 | 4 CONTINUE |
| 29762 | ELSE |
| 29763 | * user defined bin structure |
| 29764 | DO 5 K=1,IBINS(IHIS)+1 |
| 29765 | IF (IBIN.GT.0) THEN |
| 29766 | HIST(1,IHIS,K) = XLIMB(K) |
| 29767 | ISWI(IHIS) = 2 |
| 29768 | ELSEIF (IBIN.LT.-1) THEN |
| 29769 | HIST(1,IHIS,K) = LOG10(XLIMB(K)) |
| 29770 | ISWI(IHIS) = 4 |
| 29771 | ENDIF |
| 29772 | 5 CONTINUE |
| 29773 | ENDIF |
| 29774 | |
| 29775 | * histogram accepted |
| 29776 | IHISL = IHIS |
| 29777 | |
| 29778 | RETURN |
| 29779 | |
| 29780 | 9999 CONTINUE |
| 29781 | IREFN = -1 |
| 29782 | RETURN |
| 29783 | END |
| 29784 | |
| 29785 | *$ CREATE DT_FILHGR.FOR |
| 29786 | *COPY DT_FILHGR |
| 29787 | * |
| 29788 | *===filhgr=============================================================* |
| 29789 | * |
| 29790 | SUBROUTINE DT_FILHGR(XI,YI,IHIS,NEVT) |
| 29791 | |
| 29792 | ************************************************************************ |
| 29793 | * * |
| 29794 | * Scoring for histogram IHIS. * |
| 29795 | * * |
| 29796 | * This subroutine is based on a original version by R. Engel. * |
| 29797 | * This version dated 23.4.95 is written by S. Roesler. * |
| 29798 | ************************************************************************ |
| 29799 | |
| 29800 | IMPLICIT DOUBLE PRECISION(A-H,O-Z) |
| 29801 | SAVE |
| 29802 | PARAMETER ( LINP = 10 , |
| 29803 | & LOUT = 6 , |
| 29804 | & LDAT = 9 ) |
| 29805 | |
| 29806 | PARAMETER (ZERO = 0.0D0, |
| 29807 | & ONE = 1.0D0, |
| 29808 | & TINY = 1.0D-10) |
| 29809 | |
| 29810 | * histograms |
| 29811 | PARAMETER (NHIS=150, NDIM=250) |
| 29812 | COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS), |
| 29813 | & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL |
| 29814 | * auxiliary common for histograms |
| 29815 | COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS) |
| 29816 | |
| 29817 | DATA NCEVT /1/ |
| 29818 | |
| 29819 | X = XI |
| 29820 | Y = YI |
| 29821 | |
| 29822 | * dump content of temorary arrays into histograms |
| 29823 | IF ((NEVT.NE.NCEVT).OR.(NEVT.LT.0)) THEN |
| 29824 | CALL DT_EVTHIS(IDUM) |
| 29825 | NCEVT = NEVT |
| 29826 | ENDIF |
| 29827 | |
| 29828 | * check histogram index |
| 29829 | IF (IHIS.EQ.-1) RETURN |
| 29830 | IF ((IHIS.LT.1).OR.(IHIS.GT.IHISL)) THEN |
| 29831 | C WRITE(LOUT,1000) IHIS,IHISL |
| 29832 | 1000 FORMAT(1X,'FILHGR: warning! histogram index',I4, |
| 29833 | & ' out of range (1..',I3,')') |
| 29834 | RETURN |
| 29835 | ENDIF |
| 29836 | |
| 29837 | IF ((ISWI(IHIS).EQ.1).OR.(ISWI(IHIS).EQ.3)) THEN |
| 29838 | * bin structure not explicitly given |
| 29839 | IF ((ISWI(IHIS).EQ.3).AND.(X.GT.ZERO)) X = LOG10(X) |
| 29840 | DX = ABS(HIST(1,IHIS,2)-HIST(1,IHIS,1)) |
| 29841 | IF (X.LT.HIST(1,IHIS,1)) THEN |
| 29842 | I1 = 0 |
| 29843 | ELSE |
| 29844 | I1 = INT( (X-HIST(1,IHIS,1))/MAX(DX,TINY) )+1 |
| 29845 | ENDIF |
| 29846 | |
| 29847 | ELSEIF ((ISWI(IHIS).EQ.2).OR.(ISWI(IHIS).EQ.4)) THEN |
| 29848 | * user defined bin structure |
| 29849 | IF ((ISWI(IHIS).EQ.4).AND.(X.GT.ZERO)) X = LOG10(X) |
| 29850 | IF (X.LT.HIST(1,IHIS,1)) THEN |
| 29851 | I1 = 0 |
| 29852 | ELSE IF (X.GT.HIST(1,IHIS,IBINS(IHIS)+1)) THEN |
| 29853 | I1 = IBINS(IHIS)+1 |
| 29854 | ELSE |
| 29855 | * binary sort algorithm |
| 29856 | KMIN = 0 |
| 29857 | KMAX = IBINS(IHIS)+1 |
| 29858 | 1 CONTINUE |
| 29859 | IF ((KMAX-KMIN).EQ.1) GOTO 2 |
| 29860 | KK = (KMAX+KMIN)/2 |
| 29861 | IF (X.LE.HIST(1,IHIS,KK)) THEN |
| 29862 | KMAX=KK |
| 29863 | ELSE |
| 29864 | KMIN=KK |
| 29865 | ENDIF |
| 29866 | GOTO 1 |
| 29867 | 2 CONTINUE |
| 29868 | I1 = KMIN |
| 29869 | ENDIF |
| 29870 | |
| 29871 | ELSE |
| 29872 | WRITE(LOUT,1001) |
| 29873 | 1001 FORMAT(1X,'FILHGR: warning! histogram not initialized') |
| 29874 | RETURN |
| 29875 | ENDIF |
| 29876 | |
| 29877 | * scoring |
| 29878 | IF (I1.LE.0) THEN |
| 29879 | TMPUFL(IHIS) = TMPUFL(IHIS)+ONE |
| 29880 | ELSEIF (I1.LE.IBINS(IHIS)) THEN |
| 29881 | TMPHIS(1,IHIS,I1) = TMPHIS(1,IHIS,I1)+ONE |
| 29882 | IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN |
| 29883 | TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+10**X |
| 29884 | ELSE |
| 29885 | TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+X |
| 29886 | ENDIF |
| 29887 | TMPHIS(3,IHIS,I1) = TMPHIS(3,IHIS,I1)+Y |
| 29888 | ELSE |
| 29889 | TMPOFL(IHIS) = TMPOFL(IHIS)+ONE |
| 29890 | ENDIF |
| 29891 | |
| 29892 | RETURN |
| 29893 | END |
| 29894 | |
| 29895 | *$ CREATE DT_EVTHIS.FOR |
| 29896 | *COPY DT_EVTHIS |
| 29897 | * |
| 29898 | *===evthis=============================================================* |
| 29899 | * |
| 29900 | SUBROUTINE DT_EVTHIS(NEVT) |
| 29901 | |
| 29902 | ************************************************************************ |
| 29903 | * Dump content of temorary histograms into /DTHIS1/. This subroutine * |
| 29904 | * is called after each event and for the last event before any call * |
| 29905 | * to OUTHGR. * |
| 29906 | * NEVT number of events dumped, this is only needed to * |
| 29907 | * get the normalization after the last event * |
| 29908 | * This version dated 23.4.95 is written by S. Roesler. * |
| 29909 | ************************************************************************ |
| 29910 | |
| 29911 | IMPLICIT DOUBLE PRECISION(A-H,O-Z) |
| 29912 | SAVE |
| 29913 | PARAMETER ( LINP = 10 , |
| 29914 | & LOUT = 6 , |
| 29915 | & LDAT = 9 ) |
| 29916 | |
| 29917 | LOGICAL LNOETY |
| 29918 | |
| 29919 | PARAMETER (ZERO = 0.0D0, |
| 29920 | & ONE = 1.0D0, |
| 29921 | & TINY = 1.0D-10) |
| 29922 | |
| 29923 | * histograms |
| 29924 | PARAMETER (NHIS=150, NDIM=250) |
| 29925 | COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS), |
| 29926 | & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL |
| 29927 | * auxiliary common for histograms |
| 29928 | COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS) |
| 29929 | |
| 29930 | DATA NCEVT /0/ |
| 29931 | |
| 29932 | NCEVT = NCEVT+1 |
| 29933 | NEVT = NCEVT |
| 29934 | |
| 29935 | DO 1 I=1,IHISL |
| 29936 | LNOETY = .TRUE. |
| 29937 | DO 2 J=1,IBINS(I) |
| 29938 | IF (TMPHIS(1,I,J).GT.ZERO) THEN |
| 29939 | LNOETY = .FALSE. |
| 29940 | HIST(2,I,J) = HIST(2,I,J)+ONE |
| 29941 | HIST(7,I,J) = HIST(7,I,J)+TMPHIS(1,I,J) |
| 29942 | DENTRY(2,I) = DENTRY(2,I)+TMPHIS(1,I,J) |
| 29943 | AVX = TMPHIS(2,I,J)/TMPHIS(1,I,J) |
| 29944 | HIST(3,I,J) = HIST(3,I,J)+TMPHIS(3,I,J)*AVX |
| 29945 | HIST(4,I,J) = HIST(4,I,J)+TMPHIS(3,I,J)*AVX**2 |
| 29946 | HIST(5,I,J) = HIST(5,I,J)+TMPHIS(3,I,J) |
| 29947 | HIST(6,I,J) = HIST(6,I,J)+TMPHIS(3,I,J)**2 |
| 29948 | TMPHIS(1,I,J) = ZERO |
| 29949 | TMPHIS(2,I,J) = ZERO |
| 29950 | TMPHIS(3,I,J) = ZERO |
| 29951 | ENDIF |
| 29952 | 2 CONTINUE |
| 29953 | IF (LNOETY) THEN |
| 29954 | IF (TMPUFL(I).GT.ZERO) THEN |
| 29955 | UNDERF(I) = UNDERF(I)+ONE |
| 29956 | TMPUFL(I) = ZERO |
| 29957 | ELSEIF (TMPOFL(I).GT.ZERO) THEN |
| 29958 | OVERF(I) = OVERF(I)+ONE |
| 29959 | TMPOFL(I) = ZERO |
| 29960 | ENDIF |
| 29961 | ELSE |
| 29962 | DENTRY(1,I) = DENTRY(1,I)+ONE |
| 29963 | ENDIF |
| 29964 | 1 CONTINUE |
| 29965 | |
| 29966 | RETURN |
| 29967 | END |
| 29968 | |
| 29969 | *$ CREATE DT_OUTHGR.FOR |
| 29970 | *COPY DT_OUTHGR |
| 29971 | * |
| 29972 | *===outhgr=============================================================* |
| 29973 | * |
| 29974 | SUBROUTINE DT_OUTHGR(I1,I2,I3,I4,I5,I6,CHEAD,IHEAD,NEVTS,FAC, |
| 29975 | & ILOGY,INORM,NMODE) |
| 29976 | |
| 29977 | ************************************************************************ |
| 29978 | * * |
| 29979 | * Plot histogram(s) to standard output unit * |
| 29980 | * * |
| 29981 | * I1..6 indices of histograms to be plotted * |
| 29982 | * CHEAD,IHEAD header string,integer * |
| 29983 | * NEVTS number of events * |
| 29984 | * FAC scaling factor * |
| 29985 | * ILOGY = 1 logarithmic y-axis * |
| 29986 | * INORM normalization * |
| 29987 | * = 0 no further normalization (FAC is obsolete) * |
| 29988 | * = 1 per event and bin width * |
| 29989 | * = 2 per entry and bin width * |
| 29990 | * = 3 per bin entry * |
| 29991 | * = 4 per event and "bin width" x1^2...x2^2 * |
| 29992 | * = 5 per event and "log. bin width" ln x1..ln x2 * |
| 29993 | * = 6 per event * |
| 29994 | * MODE = 0 no output but normalization applied * |
| 29995 | * = 1 all valid histograms separately (small frame) * |
| 29996 | * all valid histograms separately (small frame) * |
| 29997 | * = -1 and tables as histograms * |
| 29998 | * = 2 all valid histograms (one plot, wide frame) * |
| 29999 | * all valid histograms (one plot, wide frame) * |
| 30000 | * = -2 and tables as histograms * |
| 30001 | * * |
| 30002 | * * |
| 30003 | * Note: All histograms to be plotted with one call to this * |
| 30004 | * subroutine and |MODE|=2 must have the same bin structure! * |
| 30005 | * There is no test included ensuring this fact. * |
| 30006 | * * |
| 30007 | * This version dated 23.4.95 is written by S. Roesler. * |
| 30008 | ************************************************************************ |
| 30009 | |
| 30010 | IMPLICIT DOUBLE PRECISION(A-H,O-Z) |
| 30011 | SAVE |
| 30012 | PARAMETER ( LINP = 10 , |
| 30013 | & LOUT = 6 , |
| 30014 | & LDAT = 9 ) |
| 30015 | |
| 30016 | CHARACTER*72 CHEAD |
| 30017 | |
| 30018 | PARAMETER (ZERO = 0.0D0, |
| 30019 | & IZERO = 0, |
| 30020 | & ONE = 1.0D0, |
| 30021 | & TWO = 2.0D0, |
| 30022 | & OHALF = 0.5D0, |
| 30023 | & EPS = 1.0D-5, |
| 30024 | & TINY = 1.0D-8, |
| 30025 | & SMALL = -1.0D8, |
| 30026 | & RLARGE = 1.0D8 ) |
| 30027 | |
| 30028 | * histograms |
| 30029 | PARAMETER (NHIS=150, NDIM=250) |
| 30030 | COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS), |
| 30031 | & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL |
| 30032 | |
| 30033 | PARAMETER (NDIM2 = 2*NDIM) |
| 30034 | DIMENSION XX(NDIM2),YY(NDIM2) |
| 30035 | |
| 30036 | PARAMETER (NHISTO = 6) |
| 30037 | DIMENSION YY1(NDIM,NHISTO),XX1(NDIM,NHISTO),IDX1(NHISTO), |
| 30038 | & IDX(NHISTO) |
| 30039 | |
| 30040 | CHARACTER*43 CNORM(0:8) |
| 30041 | DATA CNORM /'no further normalization ', |
| 30042 | & 'per event and bin width ', |
| 30043 | & 'per entry1 and bin width ', |
| 30044 | & 'per bin entry ', |
| 30045 | & 'per event and "bin width" x1^2...x2^2 ', |
| 30046 | & 'per event and "log. bin width" ln x1..ln x2', |
| 30047 | & 'per event ', |
| 30048 | & 'per bin entry1 ', |
| 30049 | & 'per entry2 and bin width '/ |
| 30050 | |
| 30051 | IDX1(1) = I1 |
| 30052 | IDX1(2) = I2 |
| 30053 | IDX1(3) = I3 |
| 30054 | IDX1(4) = I4 |
| 30055 | IDX1(5) = I5 |
| 30056 | IDX1(6) = I6 |
| 30057 | |
| 30058 | MODE = NMODE |
| 30059 | |
| 30060 | * initialization if "wide frame" is requested |
| 30061 | IF (ABS(MODE).EQ.2) THEN |
| 30062 | DO 1 I=1,NHISTO |
| 30063 | DO 2 J=1,NDIM |
| 30064 | XX1(J,I) = ZERO |
| 30065 | YY1(J,I) = ZERO |
| 30066 | 2 CONTINUE |
| 30067 | 1 CONTINUE |
| 30068 | ENDIF |
| 30069 | |
| 30070 | * plot header |
| 30071 | WRITE(LOUT,'(/1X,A,I3,/,1X,70A1)') CHEAD,IHEAD,('=',II=1,70) |
| 30072 | |
| 30073 | * check histogram indices |
| 30074 | NHI = 0 |
| 30075 | DO 3 I=1,NHISTO |
| 30076 | IF ((IDX1(I).GE.1).AND.(IDX1(I).LE.IHISL)) THEN |
| 30077 | IF (ISWI(IDX1(I)).NE.0) THEN |
| 30078 | IF (DENTRY(1,IDX1(I)).LT.ONE) THEN |
| 30079 | WRITE(LOUT,1000) |
| 30080 | & IDX1(I),UNDERF(IDX1(I)),OVERF(IDX1(I)) |
| 30081 | 1000 FORMAT(/,1X,'OUTHGR: warning! no entries in', |
| 30082 | & ' histogram ',I3,/,21X,'underflows:',F10.0, |
| 30083 | & ' overflows: ',F10.0) |
| 30084 | ELSE |
| 30085 | NHI = NHI+1 |
| 30086 | IDX(NHI) = IDX1(I) |
| 30087 | ENDIF |
| 30088 | ENDIF |
| 30089 | ENDIF |
| 30090 | 3 CONTINUE |
| 30091 | IF (NHI.EQ.0) THEN |
| 30092 | WRITE(LOUT,1001) |
| 30093 | 1001 FORMAT(/,1X,'OUTHGR: warning! histogram indices not valid') |
| 30094 | RETURN |
| 30095 | ENDIF |
| 30096 | |
| 30097 | * check normalization request |
| 30098 | IF ( ((FAC.EQ.ZERO).AND.(INORM.NE.0)).OR. |
| 30099 | & ((NEVTS.LT.1).AND.((INORM.EQ.1).OR.(INORM.EQ.4).OR. |
| 30100 | & (INORM.EQ.5).OR.(INORM.EQ.6))).OR. |
| 30101 | & (INORM.LT.0).OR.(INORM.GT.8) ) THEN |
| 30102 | WRITE(LOUT,1002) NEVTS,INORM,FAC |
| 30103 | 1002 FORMAT(/,1X,'OUTHGR: warning! normalization request not ', |
| 30104 | & 'valid',/,21X,'NEVTS = ',I7,4X,'INORM = ',I2,4X, |
| 30105 | & 'FAC = ',E11.4) |
| 30106 | RETURN |
| 30107 | ENDIF |
| 30108 | |
| 30109 | WRITE(LOUT,'(/,1X,A,I8)') 'number of events:',NEVTS |
| 30110 | |
| 30111 | * apply normalization |
| 30112 | DO 4 N=1,NHI |
| 30113 | |
| 30114 | I = IDX(N) |
| 30115 | |
| 30116 | IF (ISWI(I).EQ.1) THEN |
| 30117 | WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I) |
| 30118 | 1003 FORMAT(/,1X,'histo.',I4,', linear binning from',2X,E10.4, |
| 30119 | & ' to',2X,E10.4,',',2X,I3,' bins') |
| 30120 | ELSEIF (ISWI(I).EQ.2) THEN |
| 30121 | WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I) |
| 30122 | WRITE(LOUT,1007) |
| 30123 | 1007 FORMAT(1X,'user defined bin structure') |
| 30124 | ELSEIF (ISWI(I).EQ.3) THEN |
| 30125 | WRITE(LOUT,1004) |
| 30126 | & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I) |
| 30127 | 1004 FORMAT(/,1X,'histo.',I4,', logar. binning from',2X,E10.4, |
| 30128 | & ' to',2X,E10.4,',',2X,I3,' bins') |
| 30129 | ELSEIF (ISWI(I).EQ.4) THEN |
| 30130 | WRITE(LOUT,1004) |
| 30131 | & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I) |
| 30132 | WRITE(LOUT,1007) |
| 30133 | ELSE |
| 30134 | WRITE(LOUT,1008) ISWI(I) |
| 30135 | 1008 FORMAT(/,1X,'warning! inconsistent bin structure flag ',I4) |
| 30136 | ENDIF |
| 30137 | WRITE(LOUT,1005) DENTRY(1,I),DENTRY(2,I),UNDERF(I),OVERF(I) |
| 30138 | 1005 FORMAT(13X,'entries:',2F9.0,' underfl.:',F8.0, |
| 30139 | & ' overfl.:',F8.0) |
| 30140 | WRITE(LOUT,1009) CNORM(INORM) |
| 30141 | 1009 FORMAT(1X,'normalization: ',A,/) |
| 30142 | |
| 30143 | DO 5 K=1,IBINS(I) |
| 30144 | CALL DT_GETBIN(I,K,NEVTS,INORM,XLOW,XHI,XMEAN,YMEAN,YERR) |
| 30145 | YMEAN = FAC*YMEAN |
| 30146 | YERR = FAC*YERR |
| 30147 | WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,YERR,HIST(2,I,K) |
| 30148 | WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,YERR,HIST(2,I,K) |
| 30149 | 1006 FORMAT(1X,5E11.3) |
| 30150 | * small frame |
| 30151 | II = 2*K |
| 30152 | XX(II-1) = HIST(1,I,K) |
| 30153 | XX(II) = HIST(1,I,K+1) |
| 30154 | YY(II-1) = YMEAN |
| 30155 | YY(II) = YMEAN |
| 30156 | * wide frame |
| 30157 | XX1(K,N) = XMEAN |
| 30158 | IF ((ISWI(I).EQ.3).OR.(ISWI(I).EQ.4)) |
| 30159 | & XX1(K,N) = LOG10(XMEAN) |
| 30160 | YY1(K,N) = YMEAN |
| 30161 | 5 CONTINUE |
| 30162 | |
| 30163 | * plot small frame |
| 30164 | IF (ABS(MODE).EQ.1) THEN |
| 30165 | IBIN2 = 2*IBINS(I) |
| 30166 | WRITE(LOUT,'(/,1X,A)') 'Preview:' |
| 30167 | IF(ILOGY.EQ.1) THEN |
| 30168 | CALL DT_XGLOGY(IBIN2,1,XX,YY,YY) |
| 30169 | ELSE |
| 30170 | CALL DT_XGRAPH(IBIN2,1,XX,YY,YY) |
| 30171 | ENDIF |
| 30172 | ENDIF |
| 30173 | |
| 30174 | 4 CONTINUE |
| 30175 | |
| 30176 | * plot wide frame |
| 30177 | IF (ABS(MODE).EQ.2) THEN |
| 30178 | WRITE(LOUT,'(/,1X,A)') 'Preview:' |
| 30179 | NSIZE = NDIM*NHISTO |
| 30180 | DXLOW = HIST(1,IDX(1),1) |
| 30181 | DDX = ABS(HIST(1,IDX(1),2)-HIST(1,IDX(1),1)) |
| 30182 | YLOW = RLARGE |
| 30183 | YHI = SMALL |
| 30184 | DO 6 I=1,NHISTO |
| 30185 | DO 7 J=1,NDIM |
| 30186 | IF (YY1(J,I).LT.YLOW) THEN |
| 30187 | IF (ILOGY.EQ.1) THEN |
| 30188 | IF (YY1(J,I).GT.ZERO) YLOW = YY1(J,I) |
| 30189 | ELSE |
| 30190 | YLOW = YY1(J,I) |
| 30191 | ENDIF |
| 30192 | ENDIF |
| 30193 | IF (YY1(J,I).GT.YHI) YHI = YY1(J,I) |
| 30194 | 7 CONTINUE |
| 30195 | 6 CONTINUE |
| 30196 | DY = (YHI-YLOW)/DBLE(NDIM) |
| 30197 | IF (DY.LE.ZERO) THEN |
| 30198 | WRITE(LOUT,'(1X,A,6I4,A,2E12.4)') |
| 30199 | & 'OUTHGR: warning! zero bin width for histograms ', |
| 30200 | & IDX,': ',YLOW,YHI |
| 30201 | RETURN |
| 30202 | ENDIF |
| 30203 | IF (ILOGY.EQ.1) THEN |
| 30204 | YLOW = LOG10(YLOW) |
| 30205 | DY = (LOG10(YHI)-YLOW)/100.0D0 |
| 30206 | DO 8 I=1,NHISTO |
| 30207 | DO 9 J=1,NDIM |
| 30208 | IF (YY1(J,I).LE.ZERO) THEN |
| 30209 | YY1(J,I) = YLOW |
| 30210 | ELSE |
| 30211 | YY1(J,I) = LOG10(YY1(J,I)) |
| 30212 | ENDIF |
| 30213 | 9 CONTINUE |
| 30214 | 8 CONTINUE |
| 30215 | ENDIF |
| 30216 | CALL DT_SRPLOT(XX1,YY1,NSIZE,NHISTO,NDIM,DXLOW,DDX,YLOW,DY) |
| 30217 | ENDIF |
| 30218 | |
| 30219 | RETURN |
| 30220 | END |
| 30221 | |
| 30222 | *$ CREATE DT_GETBIN.FOR |
| 30223 | *COPY DT_GETBIN |
| 30224 | * |
| 30225 | *===getbin=============================================================* |
| 30226 | * |
| 30227 | SUBROUTINE DT_GETBIN(IHIS,IBIN,KEVT,NORM,XLOW,XHI, |
| 30228 | & XMEAN,YMEAN,YERR) |
| 30229 | |
| 30230 | ************************************************************************ |
| 30231 | * This version dated 23.4.95 is written by S. Roesler. * |
| 30232 | ************************************************************************ |
| 30233 | |
| 30234 | IMPLICIT DOUBLE PRECISION(A-H,O-Z) |
| 30235 | SAVE |
| 30236 | PARAMETER ( LINP = 10 , |
| 30237 | & LOUT = 6 , |
| 30238 | & LDAT = 9 ) |
| 30239 | |
| 30240 | PARAMETER (ZERO = 0.0D0, |
| 30241 | & ONE = 1.0D0, |
| 30242 | & TINY35 = 1.0D-35) |
| 30243 | |
| 30244 | * histograms |
| 30245 | PARAMETER (NHIS=150, NDIM=250) |
| 30246 | COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS), |
| 30247 | & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL |
| 30248 | |
| 30249 | XLOW = HIST(1,IHIS,IBIN) |
| 30250 | XHI = HIST(1,IHIS,IBIN+1) |
| 30251 | IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN |
| 30252 | XLOW = 10**XLOW |
| 30253 | XHI = 10**XHI |
| 30254 | ENDIF |
| 30255 | IF (NORM.EQ.2) THEN |
| 30256 | DX = XHI-XLOW |
| 30257 | NEVT = INT(DENTRY(1,IHIS)) |
| 30258 | ELSEIF (NORM.EQ.3) THEN |
| 30259 | DX = ONE |
| 30260 | NEVT = INT(HIST(2,IHIS,IBIN)) |
| 30261 | ELSEIF (NORM.EQ.4) THEN |
| 30262 | DX = XHI**2-XLOW**2 |
| 30263 | NEVT = KEVT |
| 30264 | ELSEIF (NORM.EQ.5) THEN |
| 30265 | DX = LOG(ABS(XHI))-LOG(ABS(XLOW)) |
| 30266 | NEVT = KEVT |
| 30267 | ELSEIF (NORM.EQ.6) THEN |
| 30268 | DX = ONE |
| 30269 | NEVT = KEVT |
| 30270 | ELSEIF (NORM.EQ.7) THEN |
| 30271 | DX = ONE |
| 30272 | NEVT = INT(HIST(7,IHIS,IBIN)) |
| 30273 | ELSEIF (NORM.EQ.8) THEN |
| 30274 | DX = XHI-XLOW |
| 30275 | NEVT = INT(DENTRY(2,IHIS)) |
| 30276 | ELSE |
| 30277 | DX = ABS(XHI-XLOW) |
| 30278 | NEVT = KEVT |
| 30279 | ENDIF |
| 30280 | IF (ABS(DX).LT.TINY35) DX = ONE |
| 30281 | NEVT = MAX(NEVT,1) |
| 30282 | YMEAN = HIST(5,IHIS,IBIN)/DX/DBLE(NEVT) |
| 30283 | YMEAN2 = HIST(6,IHIS,IBIN)/DX**2/DBLE(NEVT) |
| 30284 | YERR = SQRT(ABS(YMEAN2-YMEAN**2))/SQRT(DBLE(NEVT)) |
| 30285 | YSUM = HIST(5,IHIS,IBIN) |
| 30286 | IF (ABS(YSUM).LT.TINY35) YSUM = ONE |
| 30287 | C XMEAN = HIST(3,IHIS,IBIN)/YSUM/MAX(HIST(2,IHIS,IBIN),ONE) |
| 30288 | XMEAN = HIST(3,IHIS,IBIN)/YSUM |
| 30289 | IF (XMEAN.EQ.ZERO) XMEAN = XLOW |
| 30290 | |
| 30291 | RETURN |
| 30292 | END |
| 30293 | |
| 30294 | *$ CREATE DT_JOIHIS.FOR |
| 30295 | *COPY DT_JOIHIS |
| 30296 | * |
| 30297 | *===joihis=============================================================* |
| 30298 | * |
| 30299 | SUBROUTINE DT_JOIHIS(IH1,IH2,COPER,FAC1,FAC2,KEVT,NORM,ILOGY,MODE) |
| 30300 | |
| 30301 | ************************************************************************ |
| 30302 | * * |
| 30303 | * Operation on histograms. * |
| 30304 | * * |
| 30305 | * input: IH1,IH2 histogram indices to be joined * |
| 30306 | * COPER character defining the requested operation, * |
| 30307 | * i.e. '+', '-', '*', '/' * |
| 30308 | * FAC1,FAC2 factors for joining, i.e. * |
| 30309 | * FAC1*histo1 COPER FAC2*histo2 * |
| 30310 | * * |
| 30311 | * This version dated 23.4.95 is written by S. Roesler. * |
| 30312 | ************************************************************************ |
| 30313 | |
| 30314 | IMPLICIT DOUBLE PRECISION(A-H,O-Z) |
| 30315 | SAVE |
| 30316 | PARAMETER ( LINP = 10 , |
| 30317 | & LOUT = 6 , |
| 30318 | & LDAT = 9 ) |
| 30319 | |
| 30320 | CHARACTER COPER*1 |
| 30321 | |
| 30322 | PARAMETER (ZERO = 0.0D0, |
| 30323 | & ONE = 1.0D0, |
| 30324 | & OHALF = 0.5D0, |
| 30325 | & TINY8 = 1.0D-8, |
| 30326 | & SMALL = -1.0D8, |
| 30327 | & RLARGE = 1.0D8 ) |
| 30328 | |
| 30329 | * histograms |
| 30330 | PARAMETER (NHIS=150, NDIM=250) |
| 30331 | COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS), |
| 30332 | & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL |
| 30333 | |
| 30334 | PARAMETER (NDIM2 = 2*NDIM) |
| 30335 | DIMENSION XX(NDIM2),YY(NDIM2),YY1(NDIM),XX1(NDIM) |
| 30336 | |
| 30337 | CHARACTER*43 CNORM(0:6) |
| 30338 | DATA CNORM /'no further normalization ', |
| 30339 | & 'per event and bin width ', |
| 30340 | & 'per entry and bin width ', |
| 30341 | & 'per bin entry ', |
| 30342 | & 'per event and "bin width" x1^2...x2^2 ', |
| 30343 | & 'per event and "log. bin width" ln x1..ln x2', |
| 30344 | & 'per event '/ |
| 30345 | |
| 30346 | * check histogram indices |
| 30347 | IF ((IH1.LT. 1).OR.(IH2.LT. 1).OR. |
| 30348 | & (IH1.GT.IHISL).OR.(IH2.GT.IHISL)) THEN |
| 30349 | WRITE(LOUT,1000) IH1,IH2,IHISL |
| 30350 | 1000 FORMAT(1X,'JOIHIS: warning! inconsistent histogram ', |
| 30351 | & 'indices (',I3,',',I3,'),',/,21X,'valid range: 1,',I3) |
| 30352 | GOTO 9999 |
| 30353 | ENDIF |
| 30354 | |
| 30355 | * check bin structure of histograms to be joined |
| 30356 | IF (IBINS(IH1).NE.IBINS(IH2)) THEN |
| 30357 | WRITE(LOUT,1001) IH1,IH2,IBINS(IH1),IBINS(IH2) |
| 30358 | 1001 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3, |
| 30359 | & ' and ',I3,' failed',/,21X, |
| 30360 | & 'due to different numbers of bins (',I3,',',I3,')') |
| 30361 | GOTO 9999 |
| 30362 | ENDIF |
| 30363 | DO 1 K=1,IBINS(IH1)+1 |
| 30364 | IF (ABS(HIST(1,IH1,K)-HIST(1,IH2,K)).GT.TINY8) THEN |
| 30365 | WRITE(LOUT,1002) IH1,IH2,K,HIST(1,IH1,K),HIST(1,IH2,K) |
| 30366 | 1002 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3, |
| 30367 | & ' and ',I3,' failed at bin edge ',I3,/,21X, |
| 30368 | & 'X1,X2 = ',2E11.4) |
| 30369 | GOTO 9999 |
| 30370 | ENDIF |
| 30371 | 1 CONTINUE |
| 30372 | |
| 30373 | WRITE(LOUT,1003) IH1,IH2,COPER,FAC1,FAC2 |
| 30374 | 1003 FORMAT(1X,'JOIHIS: joining histograms ',I3,',',I3,' with ', |
| 30375 | & 'operation ',A,/,11X,'and factors ',2E11.4) |
| 30376 | WRITE(LOUT,1004) CNORM(NORM) |
| 30377 | 1004 FORMAT(1X,'normalization: ',A,/) |
| 30378 | |
| 30379 | DO 2 K=1,IBINS(IH1) |
| 30380 | CALL DT_GETBIN(IH1,K,KEVT,NORM,XLOW1,XHI1,XMEAN1,YMEAN1,YERR1) |
| 30381 | CALL DT_GETBIN(IH2,K,KEVT,NORM,XLOW2,XHI2,XMEAN2,YMEAN2,YERR2) |
| 30382 | XLOW = XLOW1 |
| 30383 | XHI = XHI1 |
| 30384 | XMEAN = OHALF*(XMEAN1+XMEAN2) |
| 30385 | IF (COPER.EQ.'+') THEN |
| 30386 | YMEAN = FAC1*YMEAN1+FAC2*YMEAN2 |
| 30387 | ELSEIF (COPER.EQ.'*') THEN |
| 30388 | YMEAN = FAC1*YMEAN1*FAC2*YMEAN2 |
| 30389 | ELSEIF (COPER.EQ.'/') THEN |
| 30390 | IF (YMEAN2.EQ.ZERO) THEN |
| 30391 | YMEAN = ZERO |
| 30392 | ELSE |
| 30393 | IF (FAC2.EQ.ZERO) FAC2 = ONE |
| 30394 | YMEAN = FAC1*YMEAN1/(FAC2*YMEAN2) |
| 30395 | ENDIF |
| 30396 | ELSE |
| 30397 | GOTO 9998 |
| 30398 | ENDIF |
| 30399 | WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K) |
| 30400 | WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K) |
| 30401 | 1006 FORMAT(1X,5E11.3) |
| 30402 | * small frame |
| 30403 | II = 2*K |
| 30404 | XX(II-1) = HIST(1,IH1,K) |
| 30405 | XX(II) = HIST(1,IH1,K+1) |
| 30406 | YY(II-1) = YMEAN |
| 30407 | YY(II) = YMEAN |
| 30408 | * wide frame |
| 30409 | XX1(K) = XMEAN |
| 30410 | IF ((ISWI(IH1).EQ.3).OR.(ISWI(IH1).EQ.4)) XX1(K) = LOG10(XMEAN) |
| 30411 | YY1(K) = YMEAN |
| 30412 | 2 CONTINUE |
| 30413 | |
| 30414 | * plot small frame |
| 30415 | IF (ABS(MODE).EQ.1) THEN |
| 30416 | IBIN2 = 2*IBINS(IH1) |
| 30417 | WRITE(LOUT,'(/,1X,A)') 'Preview:' |
| 30418 | IF(ILOGY.EQ.1) THEN |
| 30419 | CALL DT_XGLOGY(IBIN2,1,XX,YY,YY) |
| 30420 | ELSE |
| 30421 | CALL DT_XGRAPH(IBIN2,1,XX,YY,YY) |
| 30422 | ENDIF |
| 30423 | ENDIF |
| 30424 | |
| 30425 | * plot wide frame |
| 30426 | IF (ABS(MODE).EQ.2) THEN |
| 30427 | WRITE(LOUT,'(/,1X,A)') 'Preview:' |
| 30428 | NSIZE = NDIM |
| 30429 | DXLOW = HIST(1,IH1,1) |
| 30430 | DDX = ABS(HIST(1,IH1,2)-HIST(1,IH1,1)) |
| 30431 | YLOW = RLARGE |
| 30432 | YHI = SMALL |
| 30433 | DO 3 I=1,NDIM |
| 30434 | IF (YY1(I).LT.YLOW) THEN |
| 30435 | IF (ILOGY.EQ.1) THEN |
| 30436 | IF (YY1(I).GT.ZERO) YLOW = YY1(I) |
| 30437 | ELSE |
| 30438 | YLOW = YY1(I) |
| 30439 | ENDIF |
| 30440 | ENDIF |
| 30441 | IF (YY1(I).GT.YHI) YHI = YY1(I) |
| 30442 | 3 CONTINUE |
| 30443 | DY = (YHI-YLOW)/DBLE(NDIM) |
| 30444 | IF (DY.LE.ZERO) THEN |
| 30445 | WRITE(LOUT,'(1X,A,2I4,A,2E12.4)') |
| 30446 | & 'JOIHIS: warning! zero bin width for histograms ', |
| 30447 | & IH1,IH2,': ',YLOW,YHI |
| 30448 | RETURN |
| 30449 | ENDIF |
| 30450 | IF (ILOGY.EQ.1) THEN |
| 30451 | YLOW = LOG10(YLOW) |
| 30452 | DY = (LOG10(YHI)-YLOW)/100.0D0 |
| 30453 | DO 4 I=1,NDIM |
| 30454 | IF (YY1(I).LE.ZERO) THEN |
| 30455 | YY1(I) = YLOW |
| 30456 | ELSE |
| 30457 | YY1(I) = LOG10(YY1(I)) |
| 30458 | ENDIF |
| 30459 | 4 CONTINUE |
| 30460 | ENDIF |
| 30461 | CALL DT_SRPLOT(XX1,YY1,NSIZE,1,NDIM,DXLOW,DDX,YLOW,DY) |
| 30462 | ENDIF |
| 30463 | |
| 30464 | RETURN |
| 30465 | |
| 30466 | 9998 CONTINUE |
| 30467 | WRITE(LOUT,1005) COPER |
| 30468 | 1005 FORMAT(1X,'JOIHIS: unknown operation ',A) |
| 30469 | |
| 30470 | 9999 CONTINUE |
| 30471 | RETURN |
| 30472 | END |
| 30473 | |
| 30474 | *$ CREATE DT_XGRAPH.FOR |
| 30475 | *COPY DT_XGRAPH |
| 30476 | * |
| 30477 | *===qgraph=============================================================* |
| 30478 | * |
| 30479 | SUBROUTINE DT_XGRAPH(N,IARG,X,Y1,Y2) |
| 30480 | C*********************************************************************** |
| 30481 | C |
| 30482 | C calculate quasi graphic picture with 25 lines and 79 columns |
| 30483 | C ranges will be chosen automatically |
| 30484 | C |
| 30485 | C input N dimension of input fields |
| 30486 | C IARG number of curves (fields) to plot |
| 30487 | C X field of X |
| 30488 | C Y1 field of Y1 |
| 30489 | C Y2 field of Y2 |
| 30490 | C |
| 30491 | C This subroutine is written by R. Engel. |
| 30492 | C*********************************************************************** |
| 30493 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 30494 | SAVE |
| 30495 | |
| 30496 | PARAMETER ( LINP = 10 , |
| 30497 | & LOUT = 6 , |
| 30498 | & LDAT = 9 ) |
| 30499 | C |
| 30500 | DIMENSION X(N),Y1(N),Y2(N) |
| 30501 | PARAMETER (EPS=1.D-30) |
| 30502 | PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20) |
| 30503 | CHARACTER SYMB(5) |
| 30504 | CHARACTER COL(0:149,0:49) |
| 30505 | C |
| 30506 | DATA SYMB /'0','e','z','#','x'/ |
| 30507 | C |
| 30508 | ISPALT=IBREIT-10 |
| 30509 | C |
| 30510 | C*** automatic range fitting |
| 30511 | C |
| 30512 | XMAX=X(1) |
| 30513 | XMIN=X(1) |
| 30514 | DO 600 I=1,N |
| 30515 | XMAX=MAX(X(I),XMAX) |
| 30516 | XMIN=MIN(X(I),XMIN) |
| 30517 | 600 CONTINUE |
| 30518 | XZOOM=(XMAX-XMIN)/DBLE(ISPALT) |
| 30519 | C |
| 30520 | ITEST=0 |
| 30521 | DO 1100 K=0,IZEIL-1 |
| 30522 | ITEST=ITEST+1 |
| 30523 | IF (ITEST.EQ.IYRAST) THEN |
| 30524 | DO 1010 L=1,ISPALT-1 |
| 30525 | COL(L,K)='-' |
| 30526 | 1010 CONTINUE |
| 30527 | COL(ISPALT,K)='+' |
| 30528 | ITEST=0 |
| 30529 | DO 1020 L=0,ISPALT-1,IXRAST |
| 30530 | COL(L,K)='+' |
| 30531 | 1020 CONTINUE |
| 30532 | ELSE |
| 30533 | DO 1030 L=1,ISPALT-1 |
| 30534 | COL(L,K)=' ' |
| 30535 | 1030 CONTINUE |
| 30536 | DO 1040 L=0,ISPALT-1,IXRAST |
| 30537 | COL(L,K)='|' |
| 30538 | 1040 CONTINUE |
| 30539 | COL(ISPALT,K)='|' |
| 30540 | ENDIF |
| 30541 | 1100 CONTINUE |
| 30542 | C |
| 30543 | C*** plot curve Y1 |
| 30544 | C |
| 30545 | YMAX=Y1(1) |
| 30546 | YMIN=Y1(1) |
| 30547 | DO 500 I=1,N |
| 30548 | YMAX=MAX(Y1(I),YMAX) |
| 30549 | YMIN=MIN(Y1(I),YMIN) |
| 30550 | 500 CONTINUE |
| 30551 | IF(IARG.GT.1) THEN |
| 30552 | DO 550 I=1,N |
| 30553 | YMAX=MAX(Y2(I),YMAX) |
| 30554 | YMIN=MIN(Y2(I),YMIN) |
| 30555 | 550 CONTINUE |
| 30556 | ENDIF |
| 30557 | YMAX=(YMAX-YMIN)/40.0D0+YMAX |
| 30558 | YMIN=YMIN-(YMAX-YMIN)/40.0D0 |
| 30559 | YZOOM=(YMAX-YMIN)/DBLE(IZEIL) |
| 30560 | IF(YZOOM.LT.EPS) THEN |
| 30561 | WRITE(LOUT,'(1X,A)') |
| 30562 | & 'XGRAPH:WARNING: MIN = MAX, OUTPUT SUPPRESSED' |
| 30563 | RETURN |
| 30564 | ENDIF |
| 30565 | C |
| 30566 | C*** plot curve Y1 |
| 30567 | C |
| 30568 | ILAST=-1 |
| 30569 | LLAST=-1 |
| 30570 | DO 1200 K=1,N |
| 30571 | L=NINT((X(K)-XMIN)/XZOOM) |
| 30572 | I=NINT((YMAX-Y1(K))/YZOOM) |
| 30573 | IF(ILAST.GE.0) THEN |
| 30574 | LD = L-LLAST |
| 30575 | ID = I-ILAST |
| 30576 | DO 55 II=0,LD,SIGN(1,LD) |
| 30577 | DO 66 KK=0,ID,SIGN(1,ID) |
| 30578 | COL(II+LLAST,KK+ILAST)=SYMB(1) |
| 30579 | 66 CONTINUE |
| 30580 | 55 CONTINUE |
| 30581 | ELSE |
| 30582 | COL(L,I)=SYMB(1) |
| 30583 | ENDIF |
| 30584 | ILAST = I |
| 30585 | LLAST = L |
| 30586 | 1200 CONTINUE |
| 30587 | C |
| 30588 | IF(IARG.GT.1) THEN |
| 30589 | C |
| 30590 | C*** plot curve Y2 |
| 30591 | C |
| 30592 | DO 1250 K=1,N |
| 30593 | L=NINT((X(K)-XMIN)/XZOOM) |
| 30594 | I=NINT((YMAX-Y2(K))/YZOOM) |
| 30595 | COL(L,I)=SYMB(2) |
| 30596 | 1250 CONTINUE |
| 30597 | ENDIF |
| 30598 | C |
| 30599 | C*** write it |
| 30600 | C |
| 30601 | WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT) |
| 30602 | C |
| 30603 | C*** write range of X |
| 30604 | C |
| 30605 | XZOOM = (XMAX-XMIN)/DBLE(7) |
| 30606 | WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7) |
| 30607 | C |
| 30608 | DO 1300 K=0,IZEIL-1 |
| 30609 | YPOS=YMAX-((DBLE(K)+0.5D0)*YZOOM) |
| 30610 | WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT) |
| 30611 | 110 FORMAT(1X,1PE9.2,70A1) |
| 30612 | 1300 CONTINUE |
| 30613 | C |
| 30614 | C*** write range of X |
| 30615 | C |
| 30616 | XZOOM = (XMAX-XMIN)/DBLE(7) |
| 30617 | WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7) |
| 30618 | WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT) |
| 30619 | 120 FORMAT(6X,7(1PE10.3)) |
| 30620 | END |
| 30621 | |
| 30622 | *$ CREATE DT_XGLOGY.FOR |
| 30623 | *COPY DT_XGLOGY |
| 30624 | * |
| 30625 | *===qglogy=============================================================* |
| 30626 | * |
| 30627 | SUBROUTINE DT_XGLOGY(N,IARG,X,Y1,Y2) |
| 30628 | C*********************************************************************** |
| 30629 | C |
| 30630 | C calculate quasi graphic picture with 25 lines and 79 columns |
| 30631 | C logarithmic y axis |
| 30632 | C ranges will be chosen automatically |
| 30633 | C |
| 30634 | C input N dimension of input fields |
| 30635 | C IARG number of curves (fields) to plot |
| 30636 | C X field of X |
| 30637 | C Y1 field of Y1 |
| 30638 | C Y2 field of Y2 |
| 30639 | C |
| 30640 | C This subroutine is written by R. Engel. |
| 30641 | C*********************************************************************** |
| 30642 | C |
| 30643 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 30644 | SAVE |
| 30645 | |
| 30646 | PARAMETER ( LINP = 10 , |
| 30647 | & LOUT = 6 , |
| 30648 | & LDAT = 9 ) |
| 30649 | DIMENSION X(N),Y1(N),Y2(N) |
| 30650 | PARAMETER (EPS=1.D-30) |
| 30651 | PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20) |
| 30652 | CHARACTER SYMB(5) |
| 30653 | CHARACTER COL(0:149,0:49) |
| 30654 | PARAMETER (DEPS = 1.D-10) |
| 30655 | C |
| 30656 | DATA SYMB /'0','e','z','#','x'/ |
| 30657 | C |
| 30658 | ISPALT=IBREIT-10 |
| 30659 | C |
| 30660 | C*** automatic range fitting |
| 30661 | C |
| 30662 | XMAX=X(1) |
| 30663 | XMIN=X(1) |
| 30664 | DO 600 I=1,N |
| 30665 | XMAX=MAX(X(I),XMAX) |
| 30666 | XMIN=MIN(X(I),XMIN) |
| 30667 | 600 CONTINUE |
| 30668 | XZOOM=(XMAX-XMIN)/DBLE(ISPALT) |
| 30669 | C |
| 30670 | ITEST=0 |
| 30671 | DO 1100 K=0,IZEIL-1 |
| 30672 | ITEST=ITEST+1 |
| 30673 | IF (ITEST.EQ.IYRAST) THEN |
| 30674 | DO 1010 L=1,ISPALT-1 |
| 30675 | COL(L,K)='-' |
| 30676 | 1010 CONTINUE |
| 30677 | COL(ISPALT,K)='+' |
| 30678 | ITEST=0 |
| 30679 | DO 1020 L=0,ISPALT-1,IXRAST |
| 30680 | COL(L,K)='+' |
| 30681 | 1020 CONTINUE |
| 30682 | ELSE |
| 30683 | DO 1030 L=1,ISPALT-1 |
| 30684 | COL(L,K)=' ' |
| 30685 | 1030 CONTINUE |
| 30686 | DO 1040 L=0,ISPALT-1,IXRAST |
| 30687 | COL(L,K)='|' |
| 30688 | 1040 CONTINUE |
| 30689 | COL(ISPALT,K)='|' |
| 30690 | ENDIF |
| 30691 | 1100 CONTINUE |
| 30692 | C |
| 30693 | C*** plot curve Y1 |
| 30694 | C |
| 30695 | YMAX=Y1(1) |
| 30696 | YMIN=MAX(Y1(1),EPS) |
| 30697 | DO 500 I=1,N |
| 30698 | YMAX =MAX(Y1(I),YMAX) |
| 30699 | IF(Y1(I).GT.EPS) THEN |
| 30700 | IF(YMIN.EQ.EPS) THEN |
| 30701 | YMIN = Y1(I)/10.D0 |
| 30702 | ELSE |
| 30703 | YMIN = MIN(Y1(I),YMIN) |
| 30704 | ENDIF |
| 30705 | ENDIF |
| 30706 | 500 CONTINUE |
| 30707 | IF(IARG.GT.1) THEN |
| 30708 | DO 550 I=1,N |
| 30709 | YMAX=MAX(Y2(I),YMAX) |
| 30710 | IF(Y2(I).GT.EPS) THEN |
| 30711 | IF(YMIN.EQ.EPS) THEN |
| 30712 | YMIN = Y2(I) |
| 30713 | ELSE |
| 30714 | YMIN = MIN(Y2(I),YMIN) |
| 30715 | ENDIF |
| 30716 | ENDIF |
| 30717 | 550 CONTINUE |
| 30718 | ENDIF |
| 30719 | C |
| 30720 | DO 560 I=1,N |
| 30721 | Y1(I) = MAX(Y1(I),YMIN) |
| 30722 | 560 CONTINUE |
| 30723 | IF(IARG.GT.1) THEN |
| 30724 | DO 570 I=1,N |
| 30725 | Y2(I) = MAX(Y2(I),YMIN) |
| 30726 | 570 CONTINUE |
| 30727 | ENDIF |
| 30728 | C |
| 30729 | IF(YMAX.LE.YMIN) THEN |
| 30730 | WRITE(LOUT,'(/1X,A,2E12.3,/)') |
| 30731 | & 'XGLOGY:ERROR:YMIN,YMAX ',YMIN,YMAX |
| 30732 | WRITE(LOUT,'(1X,A)') 'MIN = MAX, OUTPUT SUPPRESSED' |
| 30733 | RETURN |
| 30734 | ENDIF |
| 30735 | C |
| 30736 | YMA=(LOG10(YMAX)-LOG10(YMIN))/20.0D0+LOG10(YMAX) |
| 30737 | YMI=LOG10(YMIN)-(LOG10(YMAX)-LOG10(YMIN))/20.0D0 |
| 30738 | YZOOM=(YMA-YMI)/DBLE(IZEIL) |
| 30739 | IF(YZOOM.LT.EPS) THEN |
| 30740 | WRITE(LOUT,'(1X,A)') |
| 30741 | & 'XGLOGY:WARNING: MIN = MAX, OUTPUT SUPPRESSED' |
| 30742 | RETURN |
| 30743 | ENDIF |
| 30744 | C |
| 30745 | C*** plot curve Y1 |
| 30746 | C |
| 30747 | ILAST=-1 |
| 30748 | LLAST=-1 |
| 30749 | DO 1200 K=1,N |
| 30750 | L=NINT((X(K)-XMIN)/XZOOM) |
| 30751 | I=NINT((YMA-LOG10(Y1(K)))/YZOOM) |
| 30752 | IF(ILAST.GE.0) THEN |
| 30753 | LD = L-LLAST |
| 30754 | ID = I-ILAST |
| 30755 | DO 55 II=0,LD,SIGN(1,LD) |
| 30756 | DO 66 KK=0,ID,SIGN(1,ID) |
| 30757 | COL(II+LLAST,KK+ILAST)=SYMB(1) |
| 30758 | 66 CONTINUE |
| 30759 | 55 CONTINUE |
| 30760 | ELSE |
| 30761 | COL(L,I)=SYMB(1) |
| 30762 | ENDIF |
| 30763 | ILAST = I |
| 30764 | LLAST = L |
| 30765 | 1200 CONTINUE |
| 30766 | C |
| 30767 | IF(IARG.GT.1) THEN |
| 30768 | C |
| 30769 | C*** plot curve Y2 |
| 30770 | C |
| 30771 | DO 1250 K=1,N |
| 30772 | L=NINT((X(K)-XMIN)/XZOOM) |
| 30773 | I=NINT((YMA-LOG10(Y2(K)))/YZOOM) |
| 30774 | COL(L,I)=SYMB(2) |
| 30775 | 1250 CONTINUE |
| 30776 | ENDIF |
| 30777 | C |
| 30778 | C*** write it |
| 30779 | C |
| 30780 | WRITE(LOUT,'(2X,A)') '(LOGARITHMIC Y AXIS)' |
| 30781 | WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT) |
| 30782 | C |
| 30783 | C*** write range of X |
| 30784 | C |
| 30785 | XZOOM1 = (XMAX-XMIN)/DBLE(7) |
| 30786 | WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7) |
| 30787 | C |
| 30788 | DO 1300 K=0,IZEIL-1 |
| 30789 | YPOS=10.D0**(YMA-((DBLE(K)+0.5D0)*YZOOM)) |
| 30790 | WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT) |
| 30791 | 110 FORMAT(1X,1PE9.2,70A1) |
| 30792 | 1300 CONTINUE |
| 30793 | C |
| 30794 | C*** write range of X |
| 30795 | C |
| 30796 | WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7) |
| 30797 | WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT) |
| 30798 | 120 FORMAT(6X,7(1PE10.3)) |
| 30799 | C |
| 30800 | END |
| 30801 | |
| 30802 | *$ CREATE DT_SRPLOT.FOR |
| 30803 | *COPY DT_SRPLOT |
| 30804 | * |
| 30805 | *===plot===============================================================* |
| 30806 | * |
| 30807 | SUBROUTINE DT_SRPLOT(X,Y,N,M,MM,XO,DX,YO,DY) |
| 30808 | |
| 30809 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 30810 | SAVE |
| 30811 | |
| 30812 | PARAMETER ( LINP = 10 , |
| 30813 | & LOUT = 6 , |
| 30814 | & LDAT = 9 ) |
| 30815 | * |
| 30816 | * initial version |
| 30817 | * J. Ranft, (FORTRAN-Programmierung,J.R.,Teubner, Leipzig, 72) |
| 30818 | * This is a subroutine of fluka to plot Y across the page |
| 30819 | * as a function of X down the page. Up to 37 curves can be |
| 30820 | * plotted in the same picture with different plotting characters. |
| 30821 | * Output of first 10 overprinted characters addad by FB 88 |
| 30822 | * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - |
| 30823 | * |
| 30824 | * Input Variables: |
| 30825 | * X = array containing the values of X |
| 30826 | * Y = array containing the values of Y |
| 30827 | * N = number of values in X and in Y |
| 30828 | * can exceed the fixed number of lines |
| 30829 | * M = number of different curves X,Y are containing |
| 30830 | * MM = number of points in each curve i.e. N=M*MM |
| 30831 | * XO = smallest value of X to be plotted |
| 30832 | * DX = increment of X between subsequent lines |
| 30833 | * YO = smallest value of Y to be plotted |
| 30834 | * DY = increment of Y between subsequent character spaces |
| 30835 | * |
| 30836 | * other variables used inside: |
| 30837 | * XX = numbers along the X-coordinate axis |
| 30838 | * YY = numbers along the Y-coordinate axis |
| 30839 | * LL = ten lines temporary storage for the plot |
| 30840 | * L = character set used to plot different curves |
| 30841 | * LOV = memorizes overprinted symbols |
| 30842 | * the first 10 overprinted symbols are printed on |
| 30843 | * the end of the line to avoid ambiguities |
| 30844 | * (added by FB as considered quite helpful) |
| 30845 | * |
| 30846 | ********************************************************************* |
| 30847 | * |
| 30848 | DIMENSION XX(61),YY(61),LL(101,10) |
| 30849 | DIMENSION X(N),Y(N),L(40),LOV(40,10) |
| 333481d6 |
30850 | INTEGER*4 LL, L, LOV |
| 9aaba0d6 |
30851 | DATA L/ |
| 30852 | 11H*,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1HZ, |
| 30853 | 21H+,1HA,1HO,1HB,1HC,1HD,1HE,1HF,1HG,1HH, |
| 30854 | 31HI,1HJ,1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR, |
| 30855 | 41HS,1HT,1HU,1HV,1HW,1HX,1HY,1H1,1H-,1H / |
| 30856 | * |
| 30857 | * |
| 30858 | MN=51 |
| 30859 | DO 10 I=1,MN |
| 30860 | AI=I-1 |
| 30861 | 10 XX(I)=XO+AI*DX |
| 30862 | DO 20 I=1,11 |
| 30863 | AI=I-1 |
| 30864 | 20 YY(I)=YO+10.0D0*AI*DY |
| 30865 | WRITE(LOUT, 500) (YY(I),I=1,11) |
| 30866 | MMN=MN-1 |
| 30867 | * |
| 30868 | * |
| 30869 | DO 90 JJ=1,MMN,10 |
| 30870 | JJJ=JJ-1 |
| 30871 | DO 30 I=1,101 |
| 30872 | DO 30 J=1,10 |
| 30873 | 30 LL(I,J)=L(40) |
| 30874 | DO 40 I=1,101 |
| 30875 | 40 LL(I,1)=L(39) |
| 30876 | DO 50 I=1,101,10 |
| 30877 | DO 50 J=1,10 |
| 30878 | 50 LL(I,J)=L(38) |
| 30879 | DO 60 I=1,40 |
| 30880 | DO 60 J=1,10 |
| 30881 | 60 LOV(I,J)=L(40) |
| 30882 | * |
| 30883 | * |
| 30884 | DO 70 I=1,M |
| 30885 | DO 70 J=1,MM |
| 30886 | II=J+(I-1)*MM |
| 30887 | AIX=(X(II)-(XO-DX/2.0D0))/DX+1.0D0 |
| 30888 | AIY=(Y(II)-(YO-DY/2.0D0))/DY+1.0D0 |
| 30889 | AIX=AIX-DBLE(JJJ) |
| 30890 | * changed Sept.88 by FB to avoid INTEGER OVERFLOW |
| 30891 | IF( AIX .GT. 1.D0.AND. AIX .LT. 11.D0.AND. AIY .GT. 1.D0.AND |
| 30892 | + . AIY .LT. 102.D0) THEN |
| 30893 | IX=INT(AIX) |
| 30894 | IY=INT(AIY) |
| 30895 | IF( IX.GT. 0.AND. IX.LE. 10.AND. IY.GT. 0.AND. IY.LE. 101) |
| 30896 | + THEN |
| 30897 | IF(LL(IY,IX).NE.L(38).AND.LL(IY,IX).NE.L(39)) LOV(I,IX) |
| 30898 | + =LL(IY,IX) |
| 30899 | LL(IY,IX)=L(I) |
| 30900 | ENDIF |
| 30901 | ENDIF |
| 30902 | 70 CONTINUE |
| 30903 | * |
| 30904 | * |
| 30905 | DO 80 I=1,10 |
| 30906 | II=I+JJJ |
| 30907 | III=II+1 |
| 30908 | WRITE(LOUT,510) XX(II),XX(III) , (LL(J,I),J=1,101) , |
| 30909 | & (LOV(J,I),J=1,10) |
| 30910 | 80 CONTINUE |
| 30911 | 90 CONTINUE |
| 30912 | * |
| 30913 | * |
| 30914 | WRITE(LOUT, 520) |
| 30915 | WRITE(LOUT, 500) (YY(I),I=1,11) |
| 30916 | RETURN |
| 30917 | * |
| 30918 | 500 FORMAT(11X,11(1PE10.2),11HOVERPRINTED) |
| 30919 | 510 FORMAT(1X,2(1PE10.2),101A1,1H ,10A1) |
| 30920 | 520 FORMAT(20X,10('1---------'),'1') |
| 30921 | END |
| 30922 | |
| 30923 | *$ CREATE DT_DEFSET.FOR |
| 30924 | *COPY DT_DEFSET |
| 30925 | * |
| 30926 | *===defset=============================================================* |
| 30927 | * |
| 30928 | BLOCK DATA DT_DEFSET |
| 30929 | |
| 30930 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 30931 | SAVE |
| 30932 | |
| 30933 | * flags for input different options |
| 30934 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 30935 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 30936 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 30937 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 30938 | * emulsion treatment |
| 30939 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), |
| 30940 | & NCOMPO,IEMUL |
| 30941 | |
| 30942 | * / DTFLG1 / |
| 30943 | DATA IFRAG / 2, 1 / |
| 30944 | DATA IRESCO / 1 / |
| 30945 | DATA IMSHL / 1 / |
| 30946 | DATA IRESRJ / 0 / |
| 30947 | DATA IOULEV / -1, -1, -1, -1, -1, -1 / |
| 30948 | DATA LEMCCK / .FALSE. / |
| 30949 | DATA LHADRO / .FALSE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE., |
| 30950 | & .TRUE.,.TRUE.,.TRUE./ |
| 30951 | DATA LSEADI / .TRUE. / |
| 30952 | DATA LEVAPO / .TRUE. / |
| 30953 | DATA IFRAME / 1 / |
| 30954 | DATA ITRSPT / 0 / |
| 30955 | |
| 30956 | * / DTCOMP / |
| 30957 | DATA EMUFRA / NCOMPX*0.0D0 / |
| 30958 | DATA IEMUMA / NCOMPX*1 / |
| 30959 | DATA IEMUCH / NCOMPX*1 / |
| 30960 | DATA NCOMPO / 0 / |
| 30961 | DATA IEMUL / 0 / |
| 30962 | |
| 30963 | END |
| 30964 | |
| 30965 | *$ CREATE DT_HADPRP.FOR |
| 30966 | *COPY DT_HADPRP |
| 30967 | * |
| 30968 | *===hadprp=============================================================* |
| 30969 | * |
| 30970 | BLOCK DATA DT_HADPRP |
| 30971 | |
| 30972 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 30973 | SAVE |
| 30974 | |
| 30975 | * auxiliary common for reggeon exchange (DTUNUC 1.x) |
| 30976 | COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6), |
| 30977 | & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6), |
| 30978 | & IQTCHR(-6:6),MQUARK(3,39) |
| 30979 | * hadron index conversion (BAMJET <--> PDG) |
| 30980 | COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22), |
| 30981 | & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19), |
| 30982 | & IAMCIN(210) |
| 30983 | * names of hadrons used in input-cards |
| 30984 | CHARACTER*8 BTYPE |
| 30985 | COMMON /DTPAIN/ BTYPE(30) |
| 30986 | |
| 30987 | * / DTQUAR / |
| 30988 | *----------------------------------------------------------------------* |
| 30989 | * * |
| 30990 | * Quark content of particles: * |
| 30991 | * index quark el. charge bar. charge isospin isospin3 * |
| 30992 | * 1 = u 2/3 1/3 1/2 1/2 * |
| 30993 | * -1 = ubar -2/3 -1/3 1/2 -1/2 * |
| 30994 | * 2 = d -1/3 1/3 1/2 -1/2 * |
| 30995 | * -2 = dbar 1/3 -1/3 1/2 1/2 * |
| 30996 | * 3 = s -1/3 1/3 0 0 * |
| 30997 | * -3 = sbar 1/3 -1/3 0 0 * |
| 30998 | * 4 = c 2/3 1/3 0 0 * |
| 30999 | * -4 = cbar -2/3 -1/3 0 0 * |
| 31000 | * 5 = b -1/3 1/3 0 0 * |
| 31001 | * -5 = bbar 1/3 -1/3 0 0 * |
| 31002 | * 6 = t 2/3 1/3 0 0 * |
| 31003 | * -6 = tbar -2/3 -1/3 0 0 * |
| 31004 | * * |
| 31005 | * Mquark = particle quark composition (Paprop numbering) * |
| 31006 | * Iqechr = electric charge ( in 1/3 unit ) * |
| 31007 | * Iqbchr = baryonic charge ( in 1/3 unit ) * |
| 31008 | * Iqichr = isospin ( in 1/2 unit ), z component * |
| 31009 | * Iqschr = strangeness * |
| 31010 | * Iqcchr = charm * |
| 31011 | * Iquchr = beauty * |
| 31012 | * Iqtchr = ...... * |
| 31013 | * * |
| 31014 | *----------------------------------------------------------------------* |
| 31015 | DATA IQECHR / -2, 1, -2, 1, 1, -2, 0, 2, -1, -1, 2, -1, 2 / |
| 31016 | DATA IQBCHR / 6*-1, 0, 6*1 / |
| 31017 | DATA IQICHR / 4*0, 1, -1, 0, 1, -1, 4*0 / |
| 31018 | DATA IQSCHR / 3*0, 1, 5*0, -1, 3*0 / |
| 31019 | DATA IQCCHR / 2*0, -1, 7*0, 1, 2*0 / |
| 31020 | DATA IQUCHR / 0, 1, 9*0, -1, 0 / |
| 31021 | DATA IQTCHR / -1, 11*0, 1 / |
| 31022 | DATA MQUARK / |
| 31023 | & 2, 1, 1, -2,-1,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 31024 | & 0, 0, 0, 0, 0, 0, 2, 2, 1, -2,-2,-1, 0, 0, 0, |
| 31025 | & 0, 0, 0, 0, 0, 0, 1,-2, 0, 2,-1, 0, 1,-3, 0, |
| 31026 | & 3,-1, 0, 1, 2, 3, -1,-2,-3, 0, 0, 0, 2, 2, 3, |
| 31027 | & 1, 1, 3, 1, 2, 3, 1,-1, 0, 2,-3, 0, 3,-2, 0, |
| 31028 | & 2,-2, 0, 3,-3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 31029 | & -1,-1,-3, -1,-2,-3, -2,-2,-3, 1, 3, 3, -1,-3,-3, |
| 31030 | & 2, 3, 3, -2,-3,-3, 3, 3, 3, -3,-3,-3 / |
| 31031 | |
| 31032 | * / DTHAIC / |
| 31033 | * (renamed) (HAdron InDex COnversion) |
| 31034 | * translation table version filled up by r.e. 25.01.94 * |
| 31035 | DATA IAMCIN / |
| 31036 | &2212,-2212,11,-11,12, -12,22,2112,-2112,-13, |
| 31037 | &13,130,211,-211,321, -321,3122,-3122,310,3112, |
| 31038 | &3222,3212,111,311,-311, 0,0,0,0,0, |
| 31039 | &221,213,113,-213,223, 323,313,-323,-313,10323, |
| 31040 | &10313,-10323,-10313,30323,30313, -30323,-30313,3224,3214,3114, |
| 31041 | &3216,3218,2224,2214,2114, 1114,12224,12214,12114,11114, |
| 31042 | &99999,99999,22212,22112,32124, 31214,-2224,-2214,-2114,-1114, |
| 31043 | &-12224,-12214,-12114,-11114,-2124, -1214,4*99999, |
| 31044 | &5*99999, 5*99999, |
| 31045 | &4*99999,331, 333,3322,3312,-3222,-3212, |
| 31046 | &-3112,-3322,-3312,3224,3214, 3114,3324,3314,3334,-3224, |
| 31047 | &-3214,-3114,-3324,-3314,-3334, 421,411,-411,-421,431, |
| 31048 | &-431,441,423,413,-413, -423,433,-433,20443,443, |
| 31049 | &-15,15,16,-16,14, -14,4122,4232,4132,4222, |
| 31050 | &4212,4112,3*99999, 3*99999,-4122,-4232, |
| 31051 | &-4132,-4222,-4212,-4112,99999, 5*99999, |
| 31052 | &5*99999, 5*99999, |
| 31053 | &10*99999, |
| 31054 | &5*99999 , 20211,20111,-20211,99999,20321, |
| 31055 | &-20321,20311,-20311,7*99999 , |
| 31056 | &7*99999,12212,12112,99999/ |
| 31057 | |
| 31058 | * / DTHAIC / |
| 31059 | * (HAdron InDex COnversion) |
| 31060 | DATA (IPDG2(1,K),K=1,7) |
| 31061 | & / -11, -12, -13, -15, -16, -14, 0/ |
| 31062 | DATA (IBAM2(1,K),K=1,7) |
| 31063 | & / 4, 6, 10, 131, 134, 136, 0/ |
| 31064 | DATA (IPDG2(2,K),K=1,7) |
| 31065 | & / 11, 12, 22, 13, 15, 16, 14/ |
| 31066 | DATA (IBAM2(2,K),K=1,7) |
| 31067 | & / 3, 5, 7, 11, 132, 133, 135/ |
| 31068 | DATA (IPDG3(1,K),K=1,22) |
| 31069 | & / -211, -321, -311, -213, -323, -313, -411, -421, |
| 31070 | & -431, -413, -423, -433, 0, 0, 0, 0, |
| 31071 | & 0, 0, 0, 0, 0, 0/ |
| 31072 | DATA (IBAM3(1,K),K=1,22) |
| 31073 | & / 14, 16, 25, 34, 38, 39, 118, 119, |
| 31074 | & 121, 125, 126, 128, 0, 0, 0, 0, |
| 31075 | & 0, 0, 0, 0, 0, 0/ |
| 31076 | DATA (IPDG3(2,K),K=1,22) |
| 31077 | & / 130, 211, 321, 310, 111, 311, 221, 213, |
| 31078 | & 113, 223, 323, 313, 331, 333, 421, 411, |
| 31079 | & 431, 441, 423, 413, 433, 443/ |
| 31080 | DATA (IBAM3(2,K),K=1,22) |
| 31081 | & / 12, 13, 15, 19, 23, 24, 31, 32, |
| 31082 | & 33, 35, 36, 37, 95, 96, 116, 117, |
| 31083 | & 120, 122, 123, 124, 127, 130/ |
| 31084 | DATA (IPDG4(1,K),K=1,29) |
| 31085 | & / -2212, -2112, -3122, -2224, -2214, -2114, -1114, -2124, |
| 31086 | & -1214, -3222, -3212, -3112, -3322, -3312, -3224, -3214, |
| 31087 | & -3114, -3324, -3314, -3334, -4122, -4232, -4132, -4222, |
| 31088 | & -4212, -4112, 0, 0, 0/ |
| 31089 | DATA (IBAM4(1,K),K=1,29) |
| 31090 | & / 2, 9, 18, 67, 68, 69, 70, 75, |
| 31091 | & 76, 99, 100, 101, 102, 103, 110, 111, |
| 31092 | & 112, 113, 114, 115, 149, 150, 151, 152, |
| 31093 | & 153, 154, 0, 0, 0/ |
| 31094 | DATA (IPDG4(2,K),K=1,29) |
| 31095 | & / 2212, 2112, 3122, 3112, 3222, 3212, 3224, 3214, |
| 31096 | & 3114, 3216, 3218, 2224, 2214, 2114, 1114, 3322, |
| 31097 | & 3312, 3224, 3214, 3114, 3324, 3314, 3334, 4122, |
| 31098 | & 4232, 4132, 4222, 4212, 4112/ |
| 31099 | DATA (IBAM4(2,K),K=1,29) |
| 31100 | & / 1, 8, 17, 20, 21, 22, 48, 49, |
| 31101 | & 50, 51, 52, 53, 54, 55, 56, 97, |
| 31102 | & 98, 104, 105, 106, 107, 108, 109, 137, |
| 31103 | & 138, 139, 140, 141, 142/ |
| 31104 | DATA (IPDG5(1,K),K=1,19) |
| 31105 | & /-10323,-10313,-30323,-30313,-12224,-12214,-12114,-11114, |
| 31106 | & -20211,-20321,-20311, 0, 0, 0, 0, 0, |
| 31107 | & 0, 0, 0/ |
| 31108 | DATA (IBAM5(1,K),K=1,19) |
| 31109 | & / 42, 43, 46, 47, 71, 72, 73, 74, |
| 31110 | & 188, 191, 193, 0, 0, 0, 0, 0, |
| 31111 | & 0, 0, 0/ |
| 31112 | DATA (IPDG5(2,K),K=1,19) |
| 31113 | & / 10323, 10313, 30323, 30313, 12224, 12214, 12114, 11114, |
| 31114 | & 22212, 22112, 32124, 31214, 20443, 20211, 20111, 20321, |
| 31115 | & 20311, 12212, 12112/ |
| 31116 | DATA (IBAM5(2,K),K=1,19) |
| 31117 | & / 40, 41, 44, 45, 57, 58, 59, 60, |
| 31118 | & 63, 64, 65, 66, 129, 186, 187, 190, |
| 31119 | & 192, 208, 209/ |
| 31120 | |
| 31121 | * / DTPAIN / |
| 31122 | * internal particle names |
| 31123 | DATA BTYPE / 'PROTON ' , 'APROTON ' , 'ELECTRON' , 'POSITRON' , |
| 31124 | &'NEUTRIE ' , 'ANEUTRIE' , 'PHOTON ' , 'NEUTRON ' , 'ANEUTRON' , |
| 31125 | &'MUON+ ' , 'MUON- ' , 'KAONLONG' , 'PION+ ' , 'PION- ' , |
| 31126 | &'KAON+ ' , 'KAON- ' , 'LAMBDA ' , 'ALAMBDA ' , 'KAONSHRT' , |
| 31127 | &'SIGMA- ' , 'SIGMA+ ' , 'SIGMAZER' , 'PIZERO ' , 'KAONZERO' , |
| 31128 | &'AKAONZER' , 'NEUTRIM ' , 'ANEUTRIM' , 'NEUTRIT ' , 'ANEUTRIT' , |
| 31129 | &'BLANK ' / |
| 31130 | |
| 31131 | END |
| 31132 | |
| 31133 | *$ CREATE DT_BLKD46.FOR |
| 31134 | *COPY DT_BLKD46 |
| 31135 | * |
| 31136 | *===blkd46=============================================================* |
| 31137 | * |
| 31138 | BLOCK DATA DT_BLKD46 |
| 31139 | |
| 31140 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 31141 | SAVE |
| 31142 | |
| 31143 | PARAMETER ( AMELCT = 0.51099906 D-03 ) |
| 31144 | PARAMETER ( AMMUON = 0.105658389 D+00 ) |
| 31145 | |
| 31146 | * particle properties (BAMJET index convention) |
| 31147 | CHARACTER*8 ANAME |
| 31148 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 31149 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 31150 | |
| 31151 | * / DTPART / |
| 31152 | * Particle masses Engel version JETSET compatible |
| 31153 | C DATA (AAM(K),K=1,85) / |
| 31154 | C & .9383D+00, .9383D+00, AMELCT , AMELCT , .0000D+00, |
| 31155 | C & .0000D+00, .0000D+00, .9396D+00, .9396D+00, AMMUON , |
| 31156 | C & AMMUON , .4977D+00, .1396D+00, .1396D+00, .4936D+00, |
| 31157 | C & .4936D+00, .1116D+01, .1116D+01, .4977D+00, .1197D+01, |
| 31158 | C & .1189D+01, .1193D+01, .1350D+00, .4977D+00, .4977D+00, |
| 31159 | C & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00, |
| 31160 | C & .5488D+00, .7669D+00, .7700D+00, .7669D+00, .7820D+00, |
| 31161 | C & .8921D+00, .8962D+00, .8921D+00, .8962D+00, .1300D+01, |
| 31162 | C & .1300D+01, .1300D+01, .1300D+01, .1421D+01, .1421D+01, |
| 31163 | C & .1421D+01, .1421D+01, .1383D+01, .1384D+01, .1387D+01, |
| 31164 | C & .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01, |
| 31165 | C & .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01, |
| 31166 | C & .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01, |
| 31167 | C & .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01, |
| 31168 | C & .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01, |
| 31169 | C & .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00, |
| 31170 | C & .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01 / |
| 31171 | C DATA (AAM(K),K=86,183) / |
| 31172 | C & .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01, |
| 31173 | C & .1700D+01, .1700D+01, .1820D+01, .2030D+01, .9575D+00, |
| 31174 | C & .1019D+01, .1315D+01, .1321D+01, .1189D+01, .1193D+01, |
| 31175 | C & .1197D+01, .1315D+01, .1321D+01, .1383D+01, .1384D+01, |
| 31176 | C & .1387D+01, .1532D+01, .1535D+01, .1672D+01, .1383D+01, |
| 31177 | C & .1384D+01, .1387D+01, .1532D+01, .1535D+01, .1672D+01, |
| 31178 | C & .1865D+01, .1869D+01, .1869D+01, .1865D+01, .1969D+01, |
| 31179 | C & .1969D+01, .2980D+01, .2007D+01, .2010D+01, .2010D+01, |
| 31180 | C & .2007D+01, .2113D+01, .2113D+01, .3686D+01, .3097D+01, |
| 31181 | C & .1784D+01, .1784D+01, .0000D+00, .0000D+00, .0000D+00, |
| 31182 | C & .0000D+00, .2285D+01, .2460D+01, .2460D+01, .2452D+01, |
| 31183 | C & .2453D+01, .2454D+01, .2560D+01, .2560D+01, .2730D+01, |
| 31184 | C & .3610D+01, .3610D+01, .3790D+01, .2285D+01, .2460D+01, |
| 31185 | C & .2460D+01, .2452D+01, .2453D+01, .2454D+01, .2560D+01, |
| 31186 | C & .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01, |
| 31187 | C & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01, |
| 31188 | C & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01, |
| 31189 | C & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01, |
| 31190 | C & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01, |
| 31191 | C & .1250D+01, .1250D+01, .1250D+01 / |
| 31192 | C DATA (AAM ( I ), I = 184,210 ) / |
| 31193 | C & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00, |
| 31194 | C & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00, |
| 31195 | C & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00, |
| 31196 | C & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00, |
| 31197 | C & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00, |
| 31198 | C & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00, |
| 31199 | C & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00, |
| 31200 | C & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00, |
| 31201 | C & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/ |
| 31202 | * sr 25.1.06: particle masses adjusted to Pythia |
| 31203 | DATA (AAM(K),K=1,85) / |
| 31204 | & .938270E+00,.938270E+00, AMELCT , AMELCT ,.000000E+00, |
| 31205 | & .000000E+00,.000000E+00,.939570E+00,.939570E+00, AMMUON , |
| 31206 | & AMMUON ,.497670E+00,.139570E+00,.139570E+00,.493600E+00, |
| 31207 | & .493600E+00,.111568E+01,.111568E+01,.497670E+00,.119744E+01, |
| 31208 | & .118937E+01,.119255E+01,.134980E+00,.497670E+00,.497670E+00, |
| 31209 | & .0000D+00, .0000D+00, .0000D+00 , .0000D+00, .0000D+00, |
| 31210 | & .547450E+00,.766900E+00,.768500E+00,.766900E+00,.781940E+00, |
| 31211 | & .891600E+00,.896100E+00,.891600E+00,.896100E+00,.129000E+01, |
| 31212 | & .129000E+01,.129000E+01,.129000E+01, .1421D+01, .1421D+01, |
| 31213 | & .1421D+01, .1421D+01,.138280E+01,.138370E+01,.138720E+01, |
| 31214 | & .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01, |
| 31215 | & .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01, |
| 31216 | & .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01, |
| 31217 | & .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01, |
| 31218 | & .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01, |
| 31219 | & .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00, |
| 31220 | & .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01 / |
| 31221 | DATA (AAM(K),K=86,183) / |
| 31222 | & .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01, |
| 31223 | & .1700D+01, .1700D+01, .1820D+01, .2030D+01,.957770E+00, |
| 31224 | & .101940E+01,.131490E+01,.132130E+01,.118937E+01,.119255E+01, |
| 31225 | & .119744E+01,.131490E+01,.132130E+01,.138280E+01,.138370E+01, |
| 31226 | & .138720E+01,.153180E+01, .1535D+01,.167245E+01,.138280E+01, |
| 31227 | & .138370E+01,.138720E+01,.153180E+01, .1535D+01,.167245E+01, |
| 31228 | & .186450E+01,.186930E+01,.186930E+01,.186450E+01,.196850E+01, |
| 31229 | & .196850E+01,.297980E+01,.200670E+01, .2010D+01, .2010D+01, |
| 31230 | & .200670E+01,.211240E+01,.211240E+01, .3686D+01,.309688E+01, |
| 31231 | & .177700E+01,.177700E+01, .0000D+00, .0000D+00, .0000D+00, |
| 31232 | & .0000D+00,.228490E+01,.246560E+01,.247030E+01,.245290E+01, |
| 31233 | & .245350E+01,.245210E+01, .2560D+01, .2560D+01, .2730D+01, |
| 31234 | & .3610D+01, .3610D+01, .3790D+01,.228490E+01,.246560E+01, |
| 31235 | & .2460D+01,.245290E+01,.245350E+01,.245210E+01, .2560D+01, |
| 31236 | & .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01, |
| 31237 | & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01, |
| 31238 | & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01, |
| 31239 | & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01, |
| 31240 | & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01, |
| 31241 | & .1250D+01, .1250D+01, .1250D+01 / |
| 31242 | DATA (AAM ( I ), I = 184,210 ) / |
| 31243 | & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00, |
| 31244 | & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00, |
| 31245 | & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00, |
| 31246 | & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00, |
| 31247 | & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00, |
| 31248 | & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00, |
| 31249 | & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00, |
| 31250 | & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00, |
| 31251 | & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/ |
| 31252 | * Particle mean lives |
| 31253 | DATA (TAU(K),K=1,183) / |
| 31254 | & .1000D+19, .1000D+19, .1000D+19, .1000D+19, .1000D+19, |
| 31255 | & .1000D+19, .1000D+19, .9180D+03, .9180D+03, .2200D-05, |
| 31256 | & .2200D-05, .5200D-07, .2600D-07, .2600D-07, .1200D-07, |
| 31257 | & .1200D-07, .2600D-09, .2600D-09, .9000D-10, .1500D-09, |
| 31258 | & .8000D-10, .5000D-14, .8000D-16, .0000D+00, .0000D+00, |
| 31259 | & 70*.0000D+00, |
| 31260 | & .0000D+00, .3000D-09, .1700D-09, .8000D-10, .1000D-13, |
| 31261 | & .1500D-09, .3000D-09, .1700D-09, .0000D+00, .0000D+00, |
| 31262 | & .0000D+00, .0000D+00, .0000D+00, .1000D-09, .0000D+00, |
| 31263 | & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .1000D-09, |
| 31264 | & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00, |
| 31265 | & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00, |
| 31266 | & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00, |
| 31267 | & .9000D-11, .9000D-11, .9000D-11, .9000D-11, .1000D+19, |
| 31268 | & .1000D+19, .0000D+00, .0000D+00, .0000D+00, .0000D+00, |
| 31269 | & 40*.0000D+00, |
| 31270 | & .0000D+00, .0000D+00, .0000D+00 / |
| 31271 | DATA ( TAU ( I ), I = 184,210 ) / |
| 31272 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, |
| 31273 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, |
| 31274 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, |
| 31275 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, |
| 31276 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, |
| 31277 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, |
| 31278 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, |
| 31279 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, |
| 31280 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00/ |
| 31281 | * Resonance width Gamma in GeV |
| 31282 | DATA (GA(K),K= 1,85) / |
| 31283 | & 30*.0000D+00, |
| 31284 | & .8500D-06, .1520D+00, .1520D+00, .1520D+00, .1000D-01, |
| 31285 | & .7900D-01, .7900D-01, .7900D-01, .7900D-01, .4500D+00, |
| 31286 | & .4500D+00, .4500D+00, .4500D+00, .1080D+00, .1080D+00, |
| 31287 | & .1080D+00, .1080D+00, .5000D-01, .5000D-01, .5000D-01, |
| 31288 | & .8500D-01, .1800D+00, .1150D+00, .1150D+00, .1150D+00, |
| 31289 | & .1150D+00, .2000D+00, .2000D+00, .2000D+00, .2000D+00, |
| 31290 | & .2000D+00, .2000D+00, .1000D+00, .1000D+00, .2000D+00, |
| 31291 | & .2000D+00, .1150D+00, .1150D+00, .1150D+00, .1150D+00, |
| 31292 | & .2000D+00, .2000D+00, .2000D+00, .2000D+00, .1000D+00, |
| 31293 | & .1000D+00, .2000D+00, .1000D+00, .1000D+00, .1000D+00, |
| 31294 | & .1000D+00, .1000D+00, .1000D+00, .1000D+00, .2000D+00 / |
| 31295 | DATA (GA(K),K= 86,183) / |
| 31296 | & .2000D+00, .2000D+00, .2000D+00, .1500D+00, .1500D+00, |
| 31297 | & .1500D+00, .1500D+00, .8500D-01, .1800D+00, .2000D-02, |
| 31298 | & .4000D-02, .0000D+00, .0000D+00, .0000D+00, .0000D+00, |
| 31299 | & .0000D+00, .0000D+00, .0000D+00, .3400D-01, .3400D-01, |
| 31300 | & .3600D-01, .9000D-02, .9000D-02, .0000D+00, .3400D-01, |
| 31301 | & .3400D-01, .3600D-01, .9000D-02, .9000D-02, .0000D+00, |
| 31302 | & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00, |
| 31303 | & .0000D+00, .0000D+00, .5000D-02, .2000D-02, .2000D-02, |
| 31304 | & .5000D-02, .2000D-02, .2000D-02, .2000D-03, .7000D-03, |
| 31305 | & 50*.0000D+00, |
| 31306 | & .3000D+00, .3000D+00, .3000D+00 / |
| 31307 | DATA ( GA ( I ), I = 184,210 ) / |
| 31308 | & 2.00000000000000D-01, 2.00000000000000D-01, 3.00000000000000D-01, |
| 31309 | & 3.00000000000000D-01, 3.00000000000000D-01, 2.70000000000000D-01, |
| 31310 | & 2.50000000000000D-01, 2.50000000000000D-01, 2.50000000000000D-01, |
| 31311 | & 2.50000000000000D-01, 1.50000000000000D-01, 1.50000000000000D-01, |
| 31312 | & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01, |
| 31313 | & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01, |
| 31314 | & 6.00000000000000D-02, 6.00000000000000D-02, 6.00000000000000D-02, |
| 31315 | & 6.00000000000000D-02, 5.50000000000000D-02, 5.50000000000000D-02, |
| 31316 | & 2.00000000000000D-01, 2.00000000000000D-01, 0.00000000000000D+00/ |
| 31317 | * Particle names |
| 31318 | * S+1385+Sigma+(1385) L02030+Lambda0(2030) |
| 31319 | * Rho77=Rho(770) Om783=Omega(783) K*14=K*(1420) and so on |
| 31320 | * designation N*@@ means N*@1(@2) |
| 31321 | DATA (ANAME(K),K=1,85) / |
| 31322 | & 'P ','AP ','E- ','E+ ','NUE ', |
| 31323 | & 'ANUE ','GAM ','NEU ','ANEU ','MUE+ ', |
| 31324 | & 'MUE- ','K0L ','PI+ ','PI- ','K+ ', |
| 31325 | & 'K- ','LAM ','ALAM ','K0S ','SIGM- ', |
| 31326 | & 'SIGM+ ','SIGM0 ','PI0 ','K0 ','AK0 ', |
| 31327 | & 'BLANK ','BLANK ','BLANK ','BLANK ','BLANK ', |
| 31328 | & 'ETA550 ','RHO+77 ','RHO077 ','RHO-77 ','OM0783 ', |
| 31329 | & 'K*+892 ','K*0892 ','K*-892 ','AK*089 ','KA+125 ', |
| 31330 | & 'KA0125 ','KA-125 ','AKA012 ','K*+142 ','K*0142 ', |
| 31331 | & 'K*-142 ','AK*014 ','S+1385 ','S01385 ','S-1385 ', |
| 31332 | & 'L01820 ','L02030 ','N*++12 ','N*+ 12 ','N*012 ', |
| 31333 | & 'N*-12 ','N*++16 ','N*+16 ','N*016 ','N*-16 ', |
| 31334 | & 'N*+14 ','N*014 ','N*+15 ','N*015 ','N*+18 ', |
| 31335 | & 'N*018 ','AN--12 ','AN*-12 ','AN*012 ','AN*+12 ', |
| 31336 | & 'AN--16 ','AN*-16 ','AN*016 ','AN*+16 ','AN*-15 ', |
| 31337 | & 'AN*015 ','DE*=24 ','RPI+49 ','RPI049 ','RPI-49 ', |
| 31338 | & 'PIN++ ','PIN+0 ','PIN+- ','PIN-0 ','PPPI ' / |
| 31339 | DATA (ANAME(K),K=86,183) / |
| 31340 | & 'PNPI ','APPPI ','APNPI ','K+PPI ','K-PPI ', |
| 31341 | & 'K+NPI ','K-NPI ','S+1820 ','S-2030 ','ETA* ', |
| 31342 | & 'PHI ','TETA0 ','TETA- ','ASIG- ','ASIG0 ', |
| 31343 | & 'ASIG+ ','ATETA0 ','ATETA+ ','SIG*+ ','SIG*0 ', |
| 31344 | & 'SIG*- ','TETA*0 ','TETA* ','OMEGA- ','ASIG*- ', |
| 31345 | & 'ASIG*0 ','ASIG*+ ','ATET*0 ','ATET*+ ','OMEGA+ ', |
| 31346 | & 'D0 ','D+ ','D- ','AD0 ','F+ ', |
| 31347 | & 'F- ','ETAC ','D*0 ','D*+ ','D*- ', |
| 31348 | & 'AD*0 ','F*+ ','F*- ','PSI ','JPSI ', |
| 31349 | & 'TAU+ ','TAU- ','NUET ','ANUET ','NUEM ', |
| 31350 | & 'ANUEM ','C0+ ','A+ ','A0 ','C1++ ', |
| 31351 | & 'C1+ ','C10 ','S+ ','S0 ','T0 ', |
| 31352 | & 'XU++ ','XD+ ','XS+ ','AC0- ','AA- ', |
| 31353 | & 'AA0 ','AC1-- ','AC1- ','AC10 ','AS- ', |
| 31354 | & 'AS0 ','AT0 ','AXU-- ','AXD- ','AXS ', |
| 31355 | & 'C1*++ ','C1*+ ','C1*0 ','S*+ ','S*0 ', |
| 31356 | & 'T*0 ','XU*++ ','XD*+ ','XS*+ ','TETA++ ', |
| 31357 | & 'AC1*-- ','AC1*- ','AC1*0 ','AS*- ','AS*0 ', |
| 31358 | & 'AT*0 ','AXU*-- ','AXD*- ','AXS*- ','ATET-- ', |
| 31359 | & 'RO ','R+ ','R- ' / |
| 31360 | DATA ( ANAME ( I ), I = 184,210 ) / |
| 31361 | &'AN*-14 ','AN*014 ','PI+130 ','PI0130 ','PI-130 ','F01400 ', |
| 31362 | &'K*+146 ','K*-146 ','K*0146 ','AK0146 ','L01600 ','AL0160 ', |
| 31363 | &'S+1660 ','S01660 ','S-1660 ','AS-166 ','AS0166 ','AS+166 ', |
| 31364 | &'X01950 ','X-1950 ','AX0195 ','AX+195 ','OM-225 ','AOM+22 ', |
| 31365 | &'N*+14 ','N*014 ','BLANK '/ |
| 31366 | * Charge of particles and resonances |
| 31367 | DATA (IICH ( I ), I = 1,210 ) / |
| 31368 | & 1, -1, -1, 1, 0, 0, 0, 0, 0, 1, -1, 0, 1, -1, 1, |
| 31369 | & -1, 0, 0, 0, -1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 31370 | & 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0, |
| 31371 | & -1, 0, 1, 0, -1, 0, 0, 2, 1, 0, -1, 2, 1, 0, -1, |
| 31372 | & 1, 0, 1, 0, 1, 0, -2, -1, 0, 1, -2, -1, 0, 1, -1, |
| 31373 | & 0, 1, 1, 0, -1, 2, 1, 0, -1, 2, 1, 0, -1, 2, 0, |
| 31374 | & 1, -1, 1, -1, 0, 0, 0, -1, -1, 0, 1, 0, 1, 1, 0, |
| 31375 | & -1, 0, -1, -1, -1, 0, 1, 0, 1, 1, 0, 1, -1, 0, 1, |
| 31376 | & -1, 0, 0, 1, -1, 0, 1, -1, 0, 0, 1, -1, 0, 0, 0, |
| 31377 | & 0, 1, 1, 0, 2, 1, 0, 1, 0, 0, 2, 1, 1, -1, -1, |
| 31378 | & 0, -2, -1, 0, -1, 0, 0, -2, -1, -1, 2, 1, 0, 1, 0, |
| 31379 | & 0, 2, 1, 1, 2, -2, -1, 0, -1, 0, 0, -2, -1, -1, -2, |
| 31380 | & 0, 1, -1, -1, 0, 1, 0, -1, 0, 1, -1, 0, 0, 0, 0, |
| 31381 | & 1, 0, -1, -1, 0, 1, 0, -1, 0, 1, -1, 1, 1, 0, 0/ |
| 31382 | * Particle baryonic charges |
| 31383 | DATA (IIBAR ( I ), I = 1,210 ) / |
| 31384 | & 1, -1, 0, 0, 0, 0, 0, 1, -1, 0, 0, 0, 0, 0, 0, |
| 31385 | & 0, 1, -1, 0, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, |
| 31386 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 31387 | & 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, |
| 31388 | & 1, 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1, |
| 31389 | & -1, 2, 0, 0, 0, 1, 1, 1, 1, 2, 2, 0, 0, 1, 1, |
| 31390 | & 1, 1, 1, 1, 0, 0, 1, 1, -1, -1, -1, -1, -1, 1, 1, |
| 31391 | & 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, 0, 0, 0, 0, 0, |
| 31392 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 31393 | & 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, -1, -1, |
| 31394 | & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 1, 1, 1, 1, 1, |
| 31395 | & 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, |
| 31396 | & 0, 0, 0, -1, -1, 0, 0, 0, 0, 0, 0, 0, 0, 1, -1, |
| 31397 | & 1, 1, 1, -1, -1, -1, 1, 1, -1, -1, 1, -1, 1, 1, 0/ |
| 31398 | * First number of decay channels used for resonances |
| 31399 | * and decaying particles |
| 31400 | DATA K1/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 16, 17, |
| 31401 | & 18, 24, 30, 34, 38, 40, 41, 43, 44, 136, 138, 330, 327, 328, |
| 31402 | & 2*330, 46, 51, 52, 54, 55, 58, |
| 31403 | * 50 |
| 31404 | & 60, 62, 64, 66, 68, 70, 72, 74, 82, 90, 98, 106, 109, 112, 114, |
| 31405 | & 123, 140, 141, 143, 145, 146, 150, 157, 164, 168, 174, 180, 187, |
| 31406 | & 194, 202, 210, 211, 213, 215, 216, 220, 227, 234, 238, 245, 252, |
| 31407 | * 85 |
| 31408 | & 254, 255, 256, 257, 259, 262, 265, 267, 269, 272, 276, 279, 282, |
| 31409 | & 286, 290, 293, 299, 331, 335, 339, 340, 341, 343, 344, 345, 346, |
| 31410 | & 347, 350, 353, 356, 358, 360, 363, 366, 369, 372, 374, 376, 379, |
| 31411 | & 383, 385, 387, 391, 394, 397, 400, 402, 405, 408, 410, 412, 414, |
| 31412 | & 417, 420, 425, 430, 431, 432, 433, 434, 448, 452, 457, 458, 459, |
| 31413 | & 460, 461, 462, 466, 468, 470, 472, 486, 490, 495, 496, 497, 498, |
| 31414 | & 499, 500, 504, 506, 508, 510, 511, 512, 513, 514, 515, 516, 517, |
| 31415 | & 518, 519, 522, 523, 524, 525, 526, 527, 528, 529, 530, 531, 534, |
| 31416 | & 537, 539, 541, 547, 553, 558, 563, 568, 572, 573, 574, 575, 576, |
| 31417 | & 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588, 589, |
| 31418 | & 590, 596, 602 / |
| 31419 | * Last number of decay channels used for resonances |
| 31420 | * and decaying particles |
| 31421 | DATA K2/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 15, 16, 17, |
| 31422 | & 23, 29, 31, 35, 39, 40, 42, 43, 45, 137, 139, 330, 327, 328, |
| 31423 | & 2* 330, 50, 51, 53, 54, 57, |
| 31424 | * 50 |
| 31425 | & 59, 61, 63, 65, 67, 69, 71, 73, 81, 89, 97, 105, 108, 111, 113, |
| 31426 | & 122, 135, 140, 142, 144, 145, 149, 156, 163, 167, 173, 179, 186, |
| 31427 | & 193, 201, 209, 210, 212, 214, 215, 219, 226, 233, 237, 244, 251, |
| 31428 | * 85 |
| 31429 | & 253, 254, 255, 256, 258, 261, 264, 266, 268, 271, 275, 278, 281, |
| 31430 | & 285, 289, 292, 298, 307, 334, 338, 339, 340, 342, 343, 344, 345, |
| 31431 | & 346, 349, 352, 355, 357, 359, 362, 365, 368, 371, 373, 375, 378, |
| 31432 | & 382, 384, 386, 390, 393, 396, 399, 401, 404, 407, 409, 411, 413, |
| 31433 | & 416, 419, 424, 429, 430, 431, 432, 433, 447, 451, 456, 457, 458, |
| 31434 | & 459, 460, 461, 465, 467, 469, 471, 485, 489, 494, 495, 496, 497, |
| 31435 | & 498, 499, 503, 505, 507, 509, 510, 511, 512, 513, 514, 515, 516, |
| 31436 | & 517, 518, 521, 522, 523, 524, 525, 526, 527, 528, 529, 530, 533, |
| 31437 | & 536, 538, 540, 546, 552, 557, 562, 567, 571, 572, 573, 574, 575, |
| 31438 | & 576, 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588, |
| 31439 | & 589, 595, 601, 602 / |
| 31440 | |
| 31441 | END |
| 31442 | |
| 31443 | *$ CREATE DT_BLKD47.FOR |
| 31444 | *COPY DT_BLKD47 |
| 31445 | * |
| 31446 | *===blkd47=============================================================* |
| 31447 | * |
| 31448 | BLOCK DATA DT_BLKD47 |
| 31449 | |
| 31450 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 31451 | SAVE |
| 31452 | |
| 31453 | * HADRIN: decay channel information |
| 31454 | PARAMETER (IDMAX9=602) |
| 31455 | CHARACTER*8 ZKNAME |
| 31456 | COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3) |
| 31457 | |
| 31458 | * Name of decay channel |
| 31459 | * Designation N*@ means N*@1(1236) |
| 31460 | * @1=# means ++, @1 = = means -- |
| 31461 | * Designation P+/0/- means Pi+/Pi0/Pi- , respectively |
| 31462 | DATA (ZKNAME(K),K= 1, 85) / |
| 31463 | & 'P ','AP ','E- ','E+ ','NUE ', |
| 31464 | & 'ANUE ','GAM ','PE-NUE ','APEANU ','EANUNU ', |
| 31465 | & 'E-NUAN ','3PI0 ','PI+-0 ','PIMUNU ','PIE-NU ', |
| 31466 | & 'MU+NUE ','MU-NUE ','MU+NUE ','PI+PI0 ','PI++- ', |
| 31467 | & 'PI+00 ','M+P0NU ','E+P0NU ','MU-NU ','PI-0 ', |
| 31468 | & 'PI+-- ','PI-00 ','M-P0NU ','E-P0NU ','PPI- ', |
| 31469 | & 'NPI0 ','PD-NUE ','PM-NUE ','APPI+ ','ANPI0 ', |
| 31470 | & 'APE+NU ','APM+NU ','PI+PI- ','PI0PI0 ','NPI- ', |
| 31471 | & 'PPI0 ','NPI+ ','LAGA ','GAGA ','GAE+E- ', |
| 31472 | & 'GAGA ','GAGAP0 ','PI000 ','PI+-0 ','PI+-GA ', |
| 31473 | & 'PI+0 ','PI+- ','PI00 ','PI-0 ','PI+-0 ', |
| 31474 | & 'PI+- ','PI0GA ','K+PI0 ','K0PI+ ','KOPI0 ', |
| 31475 | & 'K+PI- ','K-PI0 ','AK0PI- ','AK0PI0 ','K-PI+ ', |
| 31476 | & 'K+PI0 ','K0PI+ ','K0PI0 ','K+PI- ','K-PI0 ', |
| 31477 | & 'K0PI- ','AK0PI0 ','K-PI+ ','K+PI0 ','K0PI+ ', |
| 31478 | & 'K+89P0 ','K08PI+ ','K+RO77 ','K0RO+7 ','K+OM07 ', |
| 31479 | & 'K+E055 ','K0PI0 ','K+PI+ ','K089P0 ','K+8PI- ' / |
| 31480 | DATA (ZKNAME(K),K= 86,170) / |
| 31481 | & 'K0R077 ','K+R-77 ','K+R-77 ','K0OM07 ','K0E055 ', |
| 31482 | & 'K-PI0 ','K0PI- ','K-89P0 ','AK08P- ','K-R077 ', |
| 31483 | & 'AK0R-7 ','K-OM07 ','K-E055 ','AK0PI0 ','K-PI+ ', |
| 31484 | & 'AK08P0 ','K-8PI+ ','AK0R07 ','AK0OM7 ','AK0E05 ', |
| 31485 | & 'LA0PI+ ','SI0PI+ ','SI+PI0 ','LA0PI0 ','SI+PI- ', |
| 31486 | & 'SI-PI+ ','LA0PI- ','SI0PI- ','NEUAK0 ','PK- ', |
| 31487 | & 'SI+PI- ','SI0PI0 ','SI-PI+ ','LA0ET0 ','S+1PI- ', |
| 31488 | & 'S-1PI+ ','SO1PI0 ','NEUAK0 ','PK- ','LA0PI0 ', |
| 31489 | & 'LA0OM0 ','LA0RO0 ','SI+RO- ','SI-RO+ ','SI0RO0 ', |
| 31490 | & 'LA0ET0 ','SI0ET0 ','SI+PI- ','SI-PI+ ','SI0PI0 ', |
| 31491 | & 'K0S ','K0L ','K0S ','K0L ','P PI+ ', |
| 31492 | & 'P PI0 ','N PI+ ','P PI- ','N PI0 ','N PI- ', |
| 31493 | & 'P PI+ ','N*#PI0 ','N*+PI+ ','PRHO+ ','P PI0 ', |
| 31494 | & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ', |
| 31495 | & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ', |
| 31496 | & 'N*-PI+ ','PRHO- ','NRHO0 ','N PI- ','N*0PI- ', |
| 31497 | & 'N*-PI0 ','NRHO- ','PETA0 ','N*#PI- ','N*+PI0 ' / |
| 31498 | DATA (ZKNAME(K),K=171,255) / |
| 31499 | & 'N*0PI+ ','PRHO0 ','NRHO+ ','NETA0 ','N*+PI- ', |
| 31500 | & 'N*0PI0 ','N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ', |
| 31501 | & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ', |
| 31502 | & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ', |
| 31503 | & 'N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ','N PI+ ', |
| 31504 | & 'PRHO0 ','NRHO+ ','LAMK+ ','S+ K0 ','S0 K+ ', |
| 31505 | & 'PETA0 ','P PI- ','N PI0 ','PRHO- ','NRHO0 ', |
| 31506 | & 'LAMK0 ','S0 K0 ','S- K+ ','NETA/ ','APPI- ', |
| 31507 | & 'APPI0 ','ANPI- ','APPI+ ','ANPI0 ','ANPI+ ', |
| 31508 | & 'APPI- ','AN*=P0 ','AN*-P- ','APRHO- ','APPI0 ', |
| 31509 | & 'ANPI- ','AN*=P+ ','AN*-P0 ','AN*0P- ','APRHO0 ', |
| 31510 | & 'ANRHO- ','APPI+ ','ANPI0 ','AN*-P+ ','AN*0P0 ', |
| 31511 | & 'AN*+P- ','APRHO+ ','ANRHO0 ','ANPI+ ','AN*0P+ ', |
| 31512 | & 'AN*+P0 ','ANRHO+ ','APPI0 ','ANPI- ','AN*=P+ ', |
| 31513 | & 'AN*-P0 ','AN*0P- ','APRHO0 ','ANRHO- ','APPI+, ', |
| 31514 | & 'ANPI0 ','AN*-P+ ','AN*0P0 ','AN*+P- ','APRHO+ ', |
| 31515 | & 'ANRHO0 ','PN*014 ','NN*=14 ','PI+0 ','PI+- ' / |
| 31516 | DATA (ZKNAME(K),K=256,340) / |
| 31517 | & 'PI-0 ','P+0 ','N++ ','P+- ','P00 ', |
| 31518 | & 'N+0 ','N+- ','N00 ','P-0 ','N-0 ', |
| 31519 | & 'P-- ','PPPI0 ','PNPI+ ','PNPI0 ','PPPI- ', |
| 31520 | & 'NNPI+ ','APPPI0 ','APNPI+ ','ANNPI0 ','ANPPI- ', |
| 31521 | & 'APNPI0 ','APPPI- ','ANNPI- ','K+PPI0 ','K+NPI+ ', |
| 31522 | & 'K0PPI0 ','K-PPI0 ','K-NPI+ ','AKPPI- ','AKNPI0 ', |
| 31523 | & 'K+NPI0 ','K+PPI- ','K0PPI0 ','K0NPI+ ','K-NPI0 ', |
| 31524 | & 'K-PPI- ','AKNPI- ','PAK0 ','SI+PI0 ','SI0PI+ ', |
| 31525 | & 'SI+ETA ','S+1PI0 ','S01PI+ ','NEUK- ','LA0PI- ', |
| 31526 | & 'SI-OM0 ','LA0RO- ','SI0RO- ','SI-RO0 ','SI-ET0 ', |
| 31527 | & 'SI0PI- ','SI-0 ','BLANC ','BLANC ','BLANC ', |
| 31528 | & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ', |
| 31529 | & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ', |
| 31530 | & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ', |
| 31531 | & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ', |
| 31532 | & 'EPI+- ','EPI00 ','GAPI+- ','GAGA* ','K+- ', |
| 31533 | & 'KLKS ','PI+-0 ','EGA ','LPI0 ','LPI ' / |
| 31534 | DATA (ZKNAME(K),K=341,425) / |
| 31535 | & 'APPI0 ','ANPI- ','ALAGA ','ANPI ','ALPI0 ', |
| 31536 | & 'ALPI+ ','LAPI+ ','SI+PI0 ','SI0PI+ ','LAPI0 ', |
| 31537 | & 'SI+PI- ','SI-PI+ ','LAPI- ','SI-PI0 ','SI0PI- ', |
| 31538 | & 'TE0PI0 ','TE-PI+ ','TE0PI- ','TE-PI0 ','TE0PI ', |
| 31539 | & 'TE-PI ','LAK- ','ALPI- ','AS-PI0 ','AS0PI- ', |
| 31540 | & 'ALPI0 ','AS+PI- ','AS-PI+ ','ALPI+ ','AS+PI0 ', |
| 31541 | & 'AS0PI+ ','AT0PI0 ','AT+PI- ','AT0PI+ ','AT+PI0 ', |
| 31542 | & 'AT0PI ','AT+PI ','ALK+ ','K-PI+ ','K-PI+0 ', |
| 31543 | & 'K0PI+- ','K0PI0 ','K-PI++ ','AK0PI+ ','K+PI-- ', |
| 31544 | & 'K0PI- ','K+PI- ','K+PI-0 ','AKPI-+ ','AK0PI0 ', |
| 31545 | & 'ETAPIF ','K++- ','K+AK0 ','ETAPI- ','K--+ ', |
| 31546 | & 'K-K0 ','PI00 ','PI+- ','GAGA ','D0PI0 ', |
| 31547 | & 'D0GA ','D0PI+ ','D+PI0 ','DFGA ','AD0PI- ', |
| 31548 | & 'D-PI0 ','D-GA ','AD0PI0 ','AD0GA ','F+GA ', |
| 31549 | & 'F+GA ','F-GA ','F-GA ','PSPI+- ','PSPI00 ', |
| 31550 | & 'PSETA ','E+E- ','MUE+- ','PI+-0 ','M+NN ', |
| 31551 | & 'E+NN ','RHO+NT ','PI+ANT ','K*+ANT ','M-NN ' / |
| 31552 | DATA (ZKNAME(K),K=426,510) / |
| 31553 | & 'E-NN ','RHO-NT ','PI-NT ','K*-NT ','NUET ', |
| 31554 | & 'ANUET ','NUEM ','ANUEM ','SI+ETA ','SI+ET* ', |
| 31555 | & 'PAK0 ','TET0K+ ','SI*+ET ','N*+AK0 ','N*++K- ', |
| 31556 | & 'LAMRO+ ','SI0RO+ ','SI+RO0 ','SI+OME ','PAK*0 ', |
| 31557 | & 'N*+AK* ','N*++K* ','SI+AK0 ','TET0PI ','SI+AK* ', |
| 31558 | & 'TET0RO ','SI0AK* ','SI+K*- ','TET0OM ','TET-RO ', |
| 31559 | & 'SI*0AK ','C0+PI+ ','C0+PI0 ','C0+PI- ','A+GAM ', |
| 31560 | & 'A0GAM ','TET0AK ','TET0K* ','OM-RO+ ','OM-PI+ ', |
| 31561 | & 'C1++AK ','A+PI+ ','C0+AK0 ','A0PI+ ','A+AK0 ', |
| 31562 | & 'T0PI+ ','ASI-ET ','ASI-E* ','APK0 ','ATET0K ', |
| 31563 | & 'ASI*-E ','AN*-K0 ','AN*--K ','ALAMRO ','ASI0RO ', |
| 31564 | & 'ASI-RO ','ASI-OM ','APK*0 ','AN*-K* ','AN*--K ', |
| 31565 | & 'ASI-K0 ','ATETPI ','ASI-K* ','ATETRO ','ASI0K* ', |
| 31566 | & 'ASI-K* ','ATE0OM ','ATE+RO ','ASI*0K ','AC-PI- ', |
| 31567 | & 'AC-PI0 ','AC-PI+ ','AA-GAM ','AA0GAM ','ATET0K ', |
| 31568 | & 'ATE0K* ','AOM+RO ','AOM+PI ','AC1--K ','AA-PI- ', |
| 31569 | & 'AC0-K0 ','AA0PI- ','AA-K0 ','AT0PI- ','C1++GA ' / |
| 31570 | DATA (ZKNAME(K),K=511,540) / |
| 31571 | & 'C1++GA ','C10GAM ','S+GAM ','S0GAM ','T0GAM ', |
| 31572 | & 'XU++GA ','XD+GAM ','XS+GAM ','A+AKPI ','T02PI+ ', |
| 31573 | & 'C1++2K ','AC1--G ','AC1-GA ','AC10GA ','AS-GAM ', |
| 31574 | & 'AS0GAM ','AT0GAM ','AXU--G ','AXD-GA ','AXS-GA ', |
| 31575 | & 'AA-KPI ','AT02PI ','AC1--K ','RH-PI+ ','RH+PI- ', |
| 31576 | & 'RH3PI0 ','RH0PI+ ','RH+PI0 ','RH0PI- ','RH-PI0 ' / |
| 31577 | DATA (ZKNAME(I),I=541,602)/ |
| 31578 | & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHO0','ANRHO-','ANETA ', |
| 31579 | & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0','RH0PI+','RH+PI0', |
| 31580 | & '3PI+00','3PI-++','F0PI+ ','RH+PI-','RH0PI0','3PI000','3PI0+-', |
| 31581 | & 'F0PI0 ','RH0PI-','RH-PI0','3PI-00','3PI--+','F0PI- ','PI0PI0', |
| 31582 | & 'PI+PI-','K+K- ','K0AK0 ','L01600','AL0160','K*+146','K*-146', |
| 31583 | & 'K*0146','AK0146','S+1660','S01660','S-1660','AS-166','AS0166', |
| 31584 | & 'AS+166','X01690','X-1690','AX0169','AX+169','OM-225','AOM+22', |
| 31585 | & 'N*PPI0','N*NPI+','N*P2P0','N*PP+-','N*D+P0','N*D0P+','N*NPI0', |
| 31586 | & 'N*PPI-','N*N2P0','N*NP+-','N*D+P-','N*D0P0','BLANK '/ |
| 31587 | * Weight of decay channel |
| 31588 | DATA (WT(K),K= 1, 85) / |
| 31589 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, |
| 31590 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, |
| 31591 | & .1000D+01, .2100D+00, .1200D+00, .2700D+00, .4000D+00, |
| 31592 | & .1000D+01, .1000D+01, .6400D+00, .2100D+00, .6000D-01, |
| 31593 | & .2000D-01, .3000D-01, .4000D-01, .6400D+00, .2100D+00, |
| 31594 | & .6000D-01, .2000D-01, .3000D-01, .4000D-01, .6400D+00, |
| 31595 | & .3600D+00, .0000D+00, .0000D+00, .6400D+00, .3600D+00, |
| 31596 | & .0000D+00, .0000D+00, .6900D+00, .3100D+00, .1000D+01, |
| 31597 | & .5200D+00, .4800D+00, .1000D+01, .9900D+00, .1000D-01, |
| 31598 | & .3800D+00, .3000D-01, .3000D+00, .2400D+00, .5000D-01, |
| 31599 | & .1000D+01, .1000D+01, .0000D+00, .1000D+01, .9000D+00, |
| 31600 | & .1000D-01, .9000D-01, .3300D+00, .6700D+00, .3300D+00, |
| 31601 | & .6700D+00, .3300D+00, .6700D+00, .3300D+00, .6700D+00, |
| 31602 | & .3300D+00, .6700D+00, .3300D+00, .6700D+00, .3300D+00, |
| 31603 | & .6700D+00, .3300D+00, .6700D+00, .1900D+00, .3800D+00, |
| 31604 | & .9000D-01, .2000D+00, .3000D-01, .4000D-01, .5000D-01, |
| 31605 | & .2000D-01, .1900D+00, .3800D+00, .9000D-01, .2000D+00 / |
| 31606 | DATA (WT(K),K= 86,170) / |
| 31607 | & .3000D-01, .4000D-01, .5000D-01, .2000D-01, .1900D+00, |
| 31608 | & .3800D+00, .9000D-01, .2000D+00, .3000D-01, .4000D-01, |
| 31609 | & .5000D-01, .2000D-01, .1900D+00, .3800D+00, .9000D-01, |
| 31610 | & .2000D+00, .3000D-01, .4000D-01, .5000D-01, .2000D-01, |
| 31611 | & .8800D+00, .6000D-01, .6000D-01, .8800D+00, .6000D-01, |
| 31612 | & .6000D-01, .8800D+00, .1200D+00, .1900D+00, .1900D+00, |
| 31613 | & .1600D+00, .1600D+00, .1700D+00, .3000D-01, .3000D-01, |
| 31614 | & .3000D-01, .4000D-01, .1000D+00, .1000D+00, .2000D+00, |
| 31615 | & .1200D+00, .1000D+00, .4000D-01, .4000D-01, .5000D-01, |
| 31616 | & .7500D-01, .7500D-01, .3000D-01, .3000D-01, .4000D-01, |
| 31617 | & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01, |
| 31618 | & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01, |
| 31619 | & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00, |
| 31620 | & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00, |
| 31621 | & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01, |
| 31622 | & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00, |
| 31623 | & .2700D+00, .3000D+00, .4000D+00, .2000D+00, .1250D+00 / |
| 31624 | DATA (WT(K),K=171,255) / |
| 31625 | & .7500D-01, .7500D-01, .1250D+00, .4000D+00, .7500D-01, |
| 31626 | & .1250D+00, .2000D+00, .1250D+00, .7500D-01, .1800D+00, |
| 31627 | & .3700D+00, .1300D+00, .8000D-01, .4000D-01, .7000D-01, |
| 31628 | & .1300D+00, .3700D+00, .1800D+00, .4000D-01, .8000D-01, |
| 31629 | & .1300D+00, .1300D+00, .7000D-01, .7000D-01, .1300D+00, |
| 31630 | & .2300D+00, .4700D+00, .5000D-01, .2000D-01, .1000D-01, |
| 31631 | & .2000D-01, .1300D+00, .7000D-01, .4700D+00, .2300D+00, |
| 31632 | & .5000D-01, .1000D-01, .2000D-01, .2000D-01, .1000D+01, |
| 31633 | & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01, |
| 31634 | & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00, |
| 31635 | & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00, |
| 31636 | & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01, |
| 31637 | & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00, |
| 31638 | & .2700D+00, .3000D+00, .1800D+00, .3700D+00, .1300D+00, |
| 31639 | & .8000D-01, .4000D-01, .7000D-01, .1300D+00, .3700D+00, |
| 31640 | & .1800D+00, .4000D-01, .8000D-01, .1300D+00, .1300D+00, |
| 31641 | & .7000D-01, .5000D+00, .5000D+00, .1000D+01, .1000D+01 / |
| 31642 | DATA (WT(K),K=256,340) / |
| 31643 | & .1000D+01, .8000D+00, .2000D+00, .6000D+00, .3000D+00, |
| 31644 | & .1000D+00, .6000D+00, .3000D+00, .1000D+00, .8000D+00, |
| 31645 | & .2000D+00, .3300D+00, .6700D+00, .6600D+00, .1700D+00, |
| 31646 | & .1700D+00, .3200D+00, .1700D+00, .3200D+00, .1900D+00, |
| 31647 | & .3300D+00, .3300D+00, .3400D+00, .3000D+00, .5000D-01, |
| 31648 | & .6500D+00, .3800D+00, .1200D+00, .3800D+00, .1200D+00, |
| 31649 | & .3800D+00, .1200D+00, .3800D+00, .1200D+00, .3000D+00, |
| 31650 | & .5000D-01, .6500D+00, .3800D+00, .2500D+00, .2500D+00, |
| 31651 | & .2000D-01, .5000D-01, .5000D-01, .2000D+00, .2000D+00, |
| 31652 | & .1200D+00, .1000D+00, .7000D-01, .7000D-01, .1400D+00, |
| 31653 | & .5000D-01, .5000D-01, .1000D+01, .1000D+01, .1000D+01, |
| 31654 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, |
| 31655 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, |
| 31656 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, |
| 31657 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, |
| 31658 | & .4800D+00, .2400D+00, .2600D+00, .2000D-01, .4700D+00, |
| 31659 | & .3500D+00, .1500D+00, .3000D-01, .1000D+01, .1000D+01 / |
| 31660 | DATA (WT(K),K=341,425) / |
| 31661 | & .5200D+00, .4800D+00, .1000D+01, .1000D+01, .1000D+01, |
| 31662 | & .1000D+01, .9000D+00, .5000D-01, .5000D-01, .9000D+00, |
| 31663 | & .5000D-01, .5000D-01, .9000D+00, .5000D-01, .5000D-01, |
| 31664 | & .3300D+00, .6700D+00, .6700D+00, .3300D+00, .2500D+00, |
| 31665 | & .2500D+00, .5000D+00, .9000D+00, .5000D-01, .5000D-01, |
| 31666 | & .9000D+00, .5000D-01, .5000D-01, .9000D+00, .5000D-01, |
| 31667 | & .5000D-01, .3300D+00, .6700D+00, .6700D+00, .3300D+00, |
| 31668 | & .2500D+00, .2500D+00, .5000D+00, .1000D+00, .5000D+00, |
| 31669 | & .1600D+00, .2400D+00, .7000D+00, .3000D+00, .7000D+00, |
| 31670 | & .3000D+00, .1000D+00, .5000D+00, .1600D+00, .2400D+00, |
| 31671 | & .3000D+00, .4000D+00, .3000D+00, .3000D+00, .4000D+00, |
| 31672 | & .3000D+00, .4900D+00, .4900D+00, .2000D-01, .5500D+00, |
| 31673 | & .4500D+00, .6800D+00, .3000D+00, .2000D-01, .6800D+00, |
| 31674 | & .3000D+00, .2000D-01, .5500D+00, .4500D+00, .9000D+00, |
| 31675 | & .1000D+00, .9000D+00, .1000D+00, .6000D+00, .3000D+00, |
| 31676 | & .1000D+00, .1000D+00, .1000D+00, .8000D+00, .2800D+00, |
| 31677 | & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .2800D+00 / |
| 31678 | DATA (WT(K),K=426,510) / |
| 31679 | & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .1000D+01, |
| 31680 | & .1000D+01, .1000D+01, .1000D+01, .2000D-01, .3000D-01, |
| 31681 | & .7000D-01, .2000D-01, .2000D-01, .4000D-01, .1300D+00, |
| 31682 | & .7000D-01, .6000D-01, .6000D-01, .2000D+00, .1400D+00, |
| 31683 | & .4000D-01, .1000D+00, .2500D+00, .3000D-01, .3000D+00, |
| 31684 | & .4200D+00, .2200D+00, .3500D+00, .1900D+00, .1600D+00, |
| 31685 | & .8000D-01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, |
| 31686 | & .1000D+01, .3700D+00, .2000D+00, .3600D+00, .7000D-01, |
| 31687 | & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00, |
| 31688 | & .5000D+00, .2000D-01, .3000D-01, .7000D-01, .2000D-01, |
| 31689 | & .2000D-01, .4000D-01, .1300D+00, .7000D-01, .6000D-01, |
| 31690 | & .6000D-01, .2000D+00, .1400D+00, .4000D-01, .1000D+00, |
| 31691 | & .2500D+00, .3000D-01, .3000D+00, .4200D+00, .2200D+00, |
| 31692 | & .3500D+00, .1900D+00, .1600D+00, .8000D-01, .1000D+01, |
| 31693 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .3700D+00, |
| 31694 | & .2000D+00, .3600D+00, .7000D-01, .5000D+00, .5000D+00, |
| 31695 | & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01 / |
| 31696 | DATA (WT(K),K=511,540) / |
| 31697 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, |
| 31698 | & .1000D+01, .1000D+01, .1000D+01, .3000D+00, .3000D+00, |
| 31699 | & .4000D+00, .1000D+01, .1000D+01, .1000D+01, .1000D+01, |
| 31700 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, |
| 31701 | & .3000D+00, .3000D+00, .4000D+00, .3300D+00, .3300D+00, |
| 31702 | & .3400D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00 / |
| 31703 | C |
| 31704 | DATA (WT(I),I=541,602) / .0D+00, .3334D+00, .2083D+00, 2*.125D+00, |
| 31705 | & .2083D+00, .0D+00, .125D+00, .2083D+00, .3334D+00, .2083D+00, |
| 31706 | & .125D+00, 0.2D+00, 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00, |
| 31707 | & 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00, 0.2D+00, 0.3D+00, |
| 31708 | & 0.3D+00, 0.0D+00, 0.31D+00, 0.62D+00, 0.035D+00, 0.035D+00, |
| 31709 | & 18*1.D+00, 0.5D+00, 0.16D+00, 2*0.12D+00, 2*0.05D+00, 0.5D+00, |
| 31710 | & 0.16D+00, 2*0.12D+00, 2*0.05D+00, 1.D+00 / |
| 31711 | * Particle numbers in decay channel |
| 31712 | DATA (NZK(K,1),K= 1,170) / |
| 31713 | & 1, 2, 3, 4, 5, 6, 7, 1, 2, 4, |
| 31714 | & 3, 23, 13, 13, 13, 10, 11, 10, 13, 13, |
| 31715 | & 13, 10, 4, 11, 14, 14, 14, 11, 3, 1, |
| 31716 | & 8, 1, 1, 2, 9, 2, 2, 13, 23, 8, |
| 31717 | & 1, 8, 17, 7, 7, 7, 23, 23, 13, 13, |
| 31718 | & 13, 13, 23, 14, 13, 13, 23, 15, 24, 24, |
| 31719 | & 15, 16, 25, 25, 16, 15, 24, 24, 15, 16, |
| 31720 | & 24, 25, 16, 15, 24, 36, 37, 15, 24, 15, |
| 31721 | & 15, 24, 15, 37, 36, 24, 15, 24, 24, 16, |
| 31722 | & 24, 38, 39, 16, 25, 16, 16, 25, 16, 39, |
| 31723 | & 38, 25, 16, 25, 25, 17, 22, 21, 17, 21, |
| 31724 | & 20, 17, 22, 8, 1, 21, 22, 20, 17, 48, |
| 31725 | & 50, 49, 8, 1, 17, 17, 17, 21, 20, 22, |
| 31726 | & 17, 22, 21, 20, 22, 19, 12, 19, 12, 1, |
| 31727 | & 1, 8, 1, 8, 8, 1, 53, 54, 1, 1, |
| 31728 | & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55, |
| 31729 | & 56, 1, 8, 8, 55, 56, 8, 1, 53, 54 / |
| 31730 | DATA (NZK(K,1),K=171,340) / |
| 31731 | & 55, 1, 8, 8, 54, 55, 56, 1, 8, 1, |
| 31732 | & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55, |
| 31733 | & 56, 1, 8, 1, 8, 1, 8, 17, 21, 22, |
| 31734 | & 1, 1, 8, 1, 8, 17, 22, 20, 8, 2, |
| 31735 | & 2, 9, 2, 9, 9, 2, 67, 68, 2, 2, |
| 31736 | & 9, 67, 68, 69, 2, 9, 2, 9, 68, 69, |
| 31737 | & 70, 2, 9, 9, 69, 70, 9, 2, 9, 67, |
| 31738 | & 68, 69, 2, 9, 2, 9, 68, 69, 70, 2, |
| 31739 | & 9, 1, 8, 13, 13, 14, 1, 8, 1, 1, |
| 31740 | & 8, 8, 8, 1, 8, 1, 1, 1, 1, 1, |
| 31741 | & 8, 2, 2, 9, 9, 2, 2, 9, 15, 15, |
| 31742 | & 24, 16, 16, 25, 25, 15, 15, 24, 24, 16, |
| 31743 | & 16, 25, 1, 21, 22, 21, 48, 49, 8, 17, |
| 31744 | & 20, 17, 22, 20, 20, 22, 20, 0, 0, 0, |
| 31745 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 31746 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 31747 | & 31, 31, 13, 7, 15, 12, 13, 31, 17, 17 / |
| 31748 | DATA (NZK(K,1),K=341,510) / |
| 31749 | & 2, 9, 18, 9, 18, 18, 17, 21, 22, 17, |
| 31750 | & 21, 20, 17, 20, 22, 97, 98, 97, 98, 97, |
| 31751 | & 98, 17, 18, 99, 100, 18, 101, 99, 18, 101, |
| 31752 | & 100, 102, 103, 102, 103, 102, 103, 18, 16, 16, |
| 31753 | & 24, 24, 16, 25, 15, 24, 15, 15, 25, 25, |
| 31754 | & 31, 15, 15, 31, 16, 16, 23, 13, 7, 116, |
| 31755 | & 116, 116, 117, 117, 119, 118, 118, 119, 119, 120, |
| 31756 | & 120, 121, 121, 130, 130, 130, 4, 10, 13, 10, |
| 31757 | & 4, 32, 13, 36, 11, 3, 34, 14, 38, 133, |
| 31758 | & 134, 135, 136, 21, 21, 1, 97, 104, 54, 53, |
| 31759 | & 17, 22, 21, 21, 1, 54, 53, 21, 97, 21, |
| 31760 | & 97, 22, 21, 97, 98, 105, 137, 137, 137, 138, |
| 31761 | & 139, 97, 97, 109, 109, 140, 138, 137, 139, 138, |
| 31762 | & 145, 99, 99, 2, 102, 110, 68, 67, 18, 100, |
| 31763 | & 99, 99, 2, 68, 67, 99, 102, 99, 102, 100, |
| 31764 | & 99, 102, 103, 111, 149, 149, 149, 150, 151, 113, |
| 31765 | & 113, 115, 115, 152, 150, 149, 151, 150, 157, 140 / |
| 31766 | DATA (NZK(K,1),K=511,540) / |
| 31767 | & 141, 142, 143, 144, 145, 146, 147, 148, 138, 145, |
| 31768 | & 140, 152, 153, 154, 155, 156, 157, 158, 159, 160, |
| 31769 | & 150, 157, 152, 34, 32, 33, 33, 32, 33, 34 / |
| 31770 | DATA (NZK(I,1),I=541,602) / 2, 67, 68, 69, 2, 9, 9, 68, 69, |
| 31771 | & 70, 2, 9, 33, 32, 13, 14, 189, 32, 34, 23, 23, 189, 33, 34, 14, |
| 31772 | & 14, 189, 23, 13, 15, 24, 36, 38, 37, 39, 194, 195, 196, 197, |
| 31773 | & 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 1, 8, 1, 1, 54, |
| 31774 | & 55, 8, 1, 8, 8, 54, 55, 210/ |
| 31775 | DATA (NZK(K,2),K= 1,170) / |
| 31776 | & 0, 0, 0, 0, 0, 0, 0, 3, 4, 6, |
| 31777 | & 5, 23, 14, 11, 3, 5, 5, 5, 23, 13, |
| 31778 | & 23, 23, 23, 5, 23, 13, 23, 23, 23, 14, |
| 31779 | & 23, 3, 11, 13, 23, 4, 10, 14, 23, 14, |
| 31780 | & 23, 13, 7, 7, 4, 7, 7, 23, 14, 14, |
| 31781 | & 23, 14, 23, 23, 14, 14, 7, 23, 13, 23, |
| 31782 | & 14, 23, 14, 23, 13, 23, 13, 23, 14, 23, |
| 31783 | & 14, 23, 13, 23, 13, 23, 13, 33, 32, 35, |
| 31784 | & 31, 23, 14, 23, 14, 33, 34, 35, 31, 23, |
| 31785 | & 14, 23, 14, 33, 34, 35, 31, 23, 13, 23, |
| 31786 | & 13, 33, 32, 35, 31, 13, 13, 23, 23, 14, |
| 31787 | & 13, 14, 14, 25, 16, 14, 23, 13, 31, 14, |
| 31788 | & 13, 23, 25, 16, 23, 35, 33, 34, 32, 33, |
| 31789 | & 31, 31, 14, 13, 23, 0, 0, 0, 0, 13, |
| 31790 | & 23, 13, 14, 23, 14, 13, 23, 13, 78, 23, |
| 31791 | & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23, |
| 31792 | & 13, 80, 79, 14, 14, 23, 80, 31, 14, 23 / |
| 31793 | DATA (NZK(K,2),K=171,340) / |
| 31794 | & 13, 79, 78, 31, 14, 23, 13, 80, 79, 23, |
| 31795 | & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23, |
| 31796 | & 13, 80, 79, 23, 13, 33, 32, 15, 24, 15, |
| 31797 | & 31, 14, 23, 34, 33, 24, 24, 15, 31, 14, |
| 31798 | & 23, 14, 13, 23, 13, 14, 23, 14, 80, 23, |
| 31799 | & 14, 13, 23, 14, 79, 80, 13, 23, 13, 23, |
| 31800 | & 14, 78, 79, 13, 13, 23, 78, 23, 14, 13, |
| 31801 | & 23, 14, 79, 80, 13, 23, 13, 23, 14, 78, |
| 31802 | & 79, 62, 61, 23, 14, 23, 13, 13, 13, 23, |
| 31803 | & 13, 13, 23, 14, 14, 14, 1, 8, 8, 1, |
| 31804 | & 8, 1, 8, 8, 1, 8, 1, 8, 1, 8, |
| 31805 | & 1, 1, 8, 1, 8, 8, 1, 1, 8, 8, |
| 31806 | & 1, 8, 25, 23, 13, 31, 23, 13, 16, 14, |
| 31807 | & 35, 34, 34, 33, 31, 14, 23, 0, 0, 0, |
| 31808 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 31809 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 31810 | & 13, 23, 14, 7, 16, 19, 14, 7, 23, 14 / |
| 31811 | DATA (NZK(K,2),K=341,510) / |
| 31812 | & 23, 14, 7, 13, 23, 13, 13, 23, 13, 23, |
| 31813 | & 14, 13, 14, 23, 14, 23, 13, 14, 23, 14, |
| 31814 | & 23, 16, 14, 23, 14, 23, 14, 13, 13, 23, |
| 31815 | & 13, 23, 14, 13, 23, 13, 23, 15, 13, 13, |
| 31816 | & 13, 23, 13, 13, 14, 14, 14, 14, 14, 23, |
| 31817 | & 13, 16, 25, 14, 15, 24, 23, 14, 7, 23, |
| 31818 | & 7, 13, 23, 7, 14, 23, 7, 23, 7, 7, |
| 31819 | & 7, 7, 7, 13, 23, 31, 3, 11, 14, 135, |
| 31820 | & 5, 134, 134, 134, 136, 6, 133, 133, 133, 0, |
| 31821 | & 0, 0, 0, 31, 95, 25, 15, 31, 95, 16, |
| 31822 | & 32, 32, 33, 35, 39, 39, 38, 25, 13, 39, |
| 31823 | & 32, 39, 38, 35, 32, 39, 13, 23, 14, 7, |
| 31824 | & 7, 25, 37, 32, 13, 25, 13, 25, 13, 25, |
| 31825 | & 13, 31, 95, 24, 16, 31, 24, 15, 34, 34, |
| 31826 | & 33, 35, 37, 37, 36, 24, 14, 37, 34, 37, |
| 31827 | & 36, 35, 34, 37, 14, 23, 13, 7, 7, 24, |
| 31828 | & 39, 34, 14, 24, 14, 24, 14, 24, 14, 7 / |
| 31829 | DATA (NZK(K,2),K=511,540) / |
| 31830 | & 7, 7, 7, 7, 7, 7, 7, 7, 25, 13, |
| 31831 | & 25, 7, 7, 7, 7, 7, 7, 7, 7, 7, |
| 31832 | & 24, 14, 24, 13, 14, 23, 13, 23, 14, 23 / |
| 31833 | DATA (NZK(I,2),I=541,602) / 31, 13, 23, 14, 79, 80, 31, 13, 23, |
| 31834 | & 14, 78, 79, 13, 23, 23, 13, 13, 14, 13, 23, 13, 23, 14, 23, 23, |
| 31835 | & 14, 14, 23, 14, 16, 25, |
| 31836 | & 4*23, 14*0, 23, 13, 23, 13, 23, 13, 23, 14, |
| 31837 | & 23, 13, 14, 23, 0 / |
| 31838 | DATA (NZK(K,3),K= 1,170) / |
| 31839 | & 0, 0, 0, 0, 0, 0, 0, 5, 6, 5, |
| 31840 | & 6, 23, 23, 5, 5, 0, 0, 0, 0, 14, |
| 31841 | & 23, 5, 5, 0, 0, 14, 23, 5, 5, 0, |
| 31842 | & 0, 5, 5, 0, 0, 5, 5, 0, 0, 0, |
| 31843 | & 0, 0, 0, 0, 3, 0, 7, 23, 23, 7, |
| 31844 | & 0, 0, 0, 0, 23, 0, 0, 0, 0, 0, |
| 31845 | & 110*0 / |
| 31846 | DATA (NZK(K,3),K=171,340) / |
| 31847 | & 80*0, |
| 31848 | & 0, 0, 0, 0, 0, 0, 23, 13, 14, 23, |
| 31849 | & 23, 14, 23, 23, 23, 14, 23, 13, 23, 14, |
| 31850 | & 13, 23, 13, 23, 14, 23, 14, 14, 23, 13, |
| 31851 | & 13, 23, 13, 14, 23, 23, 14, 23, 13, 23, |
| 31852 | & 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, |
| 31853 | & 30*0, |
| 31854 | & 14, 23, 7, 0, 0, 0, 23, 0, 0, 0 / |
| 31855 | DATA (NZK(K,3),K=341,510) / |
| 31856 | & 30*0, |
| 31857 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 23, |
| 31858 | & 14, 0, 13, 0, 14, 0, 0, 23, 13, 0, |
| 31859 | & 0, 15, 0, 0, 16, 0, 0, 0, 0, 0, |
| 31860 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 31861 | & 0, 0, 0, 14, 23, 0, 0, 0, 23, 134, |
| 31862 | & 134, 0, 0, 0, 133, 133, 0, 0, 0, 0, |
| 31863 | & 80*0 / |
| 31864 | DATA (NZK(K,3),K=511,540) / |
| 31865 | & 0, 0, 0, 0, 0, 0, 0, 0, 13, 13, |
| 31866 | & 25, 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 31867 | & 14, 14, 24, 0, 0, 0, 0, 0, 0, 0 / |
| 31868 | DATA (NZK(I,3),I=541,602) / 12*0, 2*0, 23, 13, 0, 2*0, 23, 14, 0, |
| 31869 | & 2*0, 23, 13, 0, 4*0, 18*0, 2*0, 23, 14, 2*0, 2*0, 23, 14, 2*0, 0/ |
| 31870 | |
| 31871 | END |
| 31872 | |
| 31873 | *$ CREATE DT_BDEVAP.FOR |
| 31874 | *COPY DT_BDEVAP |
| 31875 | * |
| 31876 | *=== bdevap ===========================================================* |
| 31877 | * |
| 31878 | BLOCK DATA DT_BDEVAP |
| 31879 | |
| 31880 | C INCLUDE '(DBLPRC)' |
| 31881 | * DBLPRC.ADD |
| 31882 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 31883 | SAVE |
| 31884 | * (original name: GLOBAL) |
| 31885 | PARAMETER ( KALGNM = 2 ) |
| 31886 | PARAMETER ( ANGLGB = 5.0D-16 ) |
| 31887 | PARAMETER ( ANGLSQ = 2.5D-31 ) |
| 31888 | PARAMETER ( AXCSSV = 0.2D+16 ) |
| 31889 | PARAMETER ( ANDRFL = 1.0D-38 ) |
| 31890 | PARAMETER ( AVRFLW = 1.0D+38 ) |
| 31891 | PARAMETER ( AINFNT = 1.0D+30 ) |
| 31892 | PARAMETER ( AZRZRZ = 1.0D-30 ) |
| 31893 | PARAMETER ( EINFNT = +69.07755278982137 D+00 ) |
| 31894 | PARAMETER ( EZRZRZ = -69.07755278982137 D+00 ) |
| 31895 | PARAMETER ( EXCSSV = +35.23192357547063 D+00 ) |
| 31896 | PARAMETER ( ENGLGB = -35.23192357547063 D+00 ) |
| 31897 | PARAMETER ( ONEMNS = 0.999999999999999 D+00 ) |
| 31898 | PARAMETER ( ONEPLS = 1.000000000000001 D+00 ) |
| 31899 | PARAMETER ( CSNNRM = 2.0D-15 ) |
| 31900 | PARAMETER ( DMXTRN = 1.0D+08 ) |
| 31901 | PARAMETER ( ZERZER = 0.D+00 ) |
| 31902 | PARAMETER ( ONEONE = 1.D+00 ) |
| 31903 | PARAMETER ( TWOTWO = 2.D+00 ) |
| 31904 | PARAMETER ( THRTHR = 3.D+00 ) |
| 31905 | PARAMETER ( FOUFOU = 4.D+00 ) |
| 31906 | PARAMETER ( FIVFIV = 5.D+00 ) |
| 31907 | PARAMETER ( SIXSIX = 6.D+00 ) |
| 31908 | PARAMETER ( SEVSEV = 7.D+00 ) |
| 31909 | PARAMETER ( EIGEIG = 8.D+00 ) |
| 31910 | PARAMETER ( ANINEN = 9.D+00 ) |
| 31911 | PARAMETER ( TENTEN = 10.D+00 ) |
| 31912 | PARAMETER ( HLFHLF = 0.5D+00 ) |
| 31913 | PARAMETER ( ONETHI = ONEONE / THRTHR ) |
| 31914 | PARAMETER ( TWOTHI = TWOTWO / THRTHR ) |
| 31915 | PARAMETER ( ONEFOU = ONEONE / FOUFOU ) |
| 31916 | PARAMETER ( THRTWO = THRTHR / TWOTWO ) |
| 31917 | PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 ) |
| 31918 | PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 ) |
| 31919 | PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 ) |
| 31920 | PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 ) |
| 31921 | PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 ) |
| 31922 | PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 ) |
| 31923 | PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 ) |
| 31924 | PARAMETER ( EULERO = 0.577215664901532860606512 D+00 ) |
| 31925 | PARAMETER ( EULEXP = 1.781072417990197985236504 D+00 ) |
| 31926 | PARAMETER ( EULLOG =-0.5495393129816448223376619 D+00 ) |
| 31927 | PARAMETER ( E1M2EU = 0.8569023337737540831433017 D+00 ) |
| 31928 | PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 ) |
| 31929 | PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 ) |
| 31930 | PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 ) |
| 31931 | PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 ) |
| 31932 | PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 ) |
| 31933 | PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 ) |
| 31934 | PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 ) |
| 31935 | PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 ) |
| 31936 | PARAMETER ( CLIGHT = 2.99792458 D+10 ) |
| 31937 | PARAMETER ( AVOGAD = 6.0221367 D+23 ) |
| 31938 | PARAMETER ( BOLTZM = 1.380658 D-23 ) |
| 31939 | PARAMETER ( AMELGR = 9.1093897 D-28 ) |
| 31940 | PARAMETER ( PLCKBR = 1.05457266 D-27 ) |
| 31941 | PARAMETER ( ELCCGS = 4.8032068 D-10 ) |
| 31942 | PARAMETER ( ELCMKS = 1.60217733 D-19 ) |
| 31943 | PARAMETER ( AMUGRM = 1.6605402 D-24 ) |
| 31944 | PARAMETER ( AMMUMU = 0.113428913 D+00 ) |
| 31945 | PARAMETER ( AMPRMU = 1.007276470 D+00 ) |
| 31946 | PARAMETER ( AMNEMU = 1.008664904 D+00 ) |
| 31947 | PARAMETER ( ALPFSC = 7.2973530791728595 D-03 ) |
| 31948 | PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 ) |
| 31949 | PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 ) |
| 31950 | PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 ) |
| 31951 | PARAMETER ( PLABRC = 0.197327053 D+00 ) |
| 31952 | PARAMETER ( AMELCT = 0.51099906 D-03 ) |
| 31953 | PARAMETER ( AMUGEV = 0.93149432 D+00 ) |
| 31954 | PARAMETER ( AMMUON = 0.105658389 D+00 ) |
| 31955 | PARAMETER ( AMPRTN = 0.93827231 D+00 ) |
| 31956 | PARAMETER ( AMNTRN = 0.93956563 D+00 ) |
| 31957 | PARAMETER ( AMDEUT = 1.87561339 D+00 ) |
| 31958 | PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13 |
| 31959 | & * 1.D-09 ) |
| 31960 | PARAMETER ( RCLSEL = 2.8179409183694872 D-13 ) |
| 31961 | PARAMETER ( BLTZMN = 8.617385 D-14 ) |
| 31962 | PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT ) |
| 31963 | PARAMETER ( GFOHB3 = 1.16639 D-05 ) |
| 31964 | PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC ) |
| 31965 | PARAMETER ( SIN2TW = 0.2319 D+00 ) |
| 31966 | PARAMETER ( GEVMEV = 1.0 D+03 ) |
| 31967 | PARAMETER ( EMVGEV = 1.0 D-03 ) |
| 31968 | PARAMETER ( ALGVMV = 6.90775527898214 D+00 ) |
| 31969 | PARAMETER ( RADDEG = 180.D+00 / PIPIPI ) |
| 31970 | PARAMETER ( DEGRAD = PIPIPI / 180.D+00 ) |
| 31971 | LOGICAL LGBIAS, LGBANA |
| 31972 | COMMON /FKGLOB/ LGBIAS, LGBANA |
| 31973 | C INCLUDE '(DIMPAR)' |
| 31974 | * DIMPAR.ADD |
| 31975 | PARAMETER ( MXXRGN = 5000 ) |
| 31976 | PARAMETER ( MXXMDF = 82 ) |
| 31977 | PARAMETER ( MXXMDE = 54 ) |
| 31978 | PARAMETER ( MFSTCK = 1000 ) |
| 31979 | PARAMETER ( MESTCK = 100 ) |
| 31980 | PARAMETER ( NELEMX = 80 ) |
| 31981 | PARAMETER ( MPDPDX = 8 ) |
| 31982 | PARAMETER ( ICOMAX = 180 ) |
| 31983 | PARAMETER ( NSTBIS = 304 ) |
| 31984 | PARAMETER ( IDMAXP = 220 ) |
| 31985 | PARAMETER ( IDMXDC = 640 ) |
| 31986 | PARAMETER ( MKBMX1 = 1 ) |
| 31987 | PARAMETER ( MKBMX2 = 1 ) |
| 31988 | C INCLUDE '(IOUNIT)' |
| 31989 | * IOUNIT.ADD |
| 31990 | PARAMETER ( LUNIN = 5 ) |
| 31991 | PARAMETER ( LUNOUT = 6 ) |
| 31992 | **sr 19.5. set error output-unit from 15 to 6 |
| 31993 | PARAMETER ( LUNERR = 6 ) |
| 31994 | PARAMETER ( LUNBER = 14 ) |
| 31995 | PARAMETER ( LUNECH = 8 ) |
| 31996 | PARAMETER ( LUNFLU = 13 ) |
| 31997 | PARAMETER ( LUNGEO = 16 ) |
| 31998 | PARAMETER ( LUNPMF = 12 ) |
| 31999 | PARAMETER ( LUNRAN = 2 ) |
| 32000 | PARAMETER ( LUNXSC = 9 ) |
| 32001 | PARAMETER ( LUNDET = 17 ) |
| 32002 | PARAMETER ( LUNRAY = 10 ) |
| 32003 | PARAMETER ( LUNRDB = 1 ) |
| 32004 | PARAMETER ( LUNPGO = 7 ) |
| 32005 | PARAMETER ( LUNPGS = 4 ) |
| 32006 | PARAMETER ( LUNSCR = 3 ) |
| 32007 | * |
| 32008 | *----------------------------------------------------------------------* |
| 32009 | * * |
| 32010 | * Block Data for the EVAPoration routines: * |
| 32011 | * * |
| 32012 | * Created on 20 may 1990 by Alfredo Ferrari & Paola Sala * |
| 32013 | * Infn - Milan * |
| 32014 | * * |
| 32015 | * Modified from the original version of J.M.Zazula * |
| 32016 | * and, for cookcm, from a LAHET block data kindly provided by * |
| 32017 | * R.E.Prael-LANL * |
| 32018 | * * |
| 32019 | * Last change on 20-feb-95 by Alfredo Ferrari * |
| 32020 | * * |
| 32021 | * * |
| 32022 | *----------------------------------------------------------------------* |
| 32023 | * |
| 32024 | * (original name: COOKCM) |
| 32025 | PARAMETER ( ASMTOG = SIXSIX / PIPIPI**2 ) |
| 32026 | LOGICAL LDEFOZ, LDEFON |
| 32027 | PARAMETER ( INCOOK = 150, IZCOOK = 98 ) |
| 32028 | COMMON /FKCOOK/ ALPIGN, BETIGN, GAMIGN, POWIGN, |
| 32029 | & SZCOOK (IZCOOK), SNCOOK (INCOOK), PZCOOK (IZCOOK), |
| 32030 | & PNCOOK (INCOOK), LDEFOZ (IZCOOK), LDEFON (INCOOK) |
| 32031 | * (original name: EVA0) |
| 32032 | COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001), |
| 32033 | * FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6), |
| 32034 | * CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200), |
| 32035 | * T (4,7), RMASS (297), ALPH (297), BET (297), |
| 32036 | * APRIME (250), IA (6), IZ (6) |
| 32037 | * (original name: HETTP) |
| 32038 | COMMON /FKHETP/ NHSTP,NBERTP,IOSUB,INSRS |
| 32039 | * (original name: HETC7) |
| 32040 | COMMON /FKHET7/ COSKS,SINKS, COSTH,SINTH, COSPHI,SINPHI |
| 32041 | * (original name: INPFLG) |
| 32042 | COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK |
| 32043 | * |
| 32044 | DATA B0 / 8.D+00 /, Y0 / 1.5D+00 / |
| 32045 | DATA IANG / 1 /, IFISS / 1 /, IB0 / 2 /, IGEOM / 0 / |
| 32046 | DATA ISTRAG /0/, KEYDK /0/ |
| 32047 | DATA NBERTP /LUNBER/ |
| 32048 | DATA COSTH /ONEONE/, SINTH /ZERZER/, COSPHI /ONEONE/, |
| 32049 | & SINPHI/ZERZER/ |
| 32050 | * /cookcm/ |
| 32051 | DATA ( PZCOOK(I),I = 1, IZCOOK ) / |
| 32052 | & 0.000D+00, 5.440D+00, 0.000D+00, 2.760D+00, 0.000D+00, 3.340D+00, |
| 32053 | & 0.000D+00, 2.700D+00, 0.000D+00, 2.500D+00, 0.000D+00, 2.460D+00, |
| 32054 | & 0.000D+00, 2.090D+00, 0.000D+00, 1.620D+00, 0.000D+00, 1.620D+00, |
| 32055 | & 0.000D+00, 1.830D+00, 0.000D+00, 1.730D+00, 0.000D+00, 1.350D+00, |
| 32056 | & 0.000D+00, 1.540D+00, 0.000D+00, 1.280D+00, 2.600D-01, 8.800D-01, |
| 32057 | & 1.900D-01, 1.350D+00,-5.000D-02, 1.520D+00,-9.000D-02, 1.170D+00, |
| 32058 | & 4.000D-02, 1.240D+00, 2.900D-01, 1.090D+00, 2.600D-01, 1.170D+00, |
| 32059 | & 2.300D-01, 1.150D+00,-8.000D-02, 1.350D+00, 3.400D-01, 1.050D+00, |
| 32060 | & 2.800D-01, 1.270D+00, 0.000D+00, 1.050D+00, 0.000D+00, 1.000D+00, |
| 32061 | & 9.000D-02, 1.200D+00, 2.000D-01, 1.400D+00, 9.300D-01, 1.000D+00, |
| 32062 | &-2.000D-01, 1.190D+00, 9.000D-02, 9.700D-01, 0.000D+00, 9.200D-01, |
| 32063 | & 1.100D-01, 6.800D-01, 5.000D-02, 6.800D-01,-2.200D-01, 7.900D-01, |
| 32064 | & 9.000D-02, 6.900D-01, 1.000D-02, 7.200D-01, 0.000D+00, 4.000D-01, |
| 32065 | & 1.600D-01, 7.300D-01, 0.000D+00, 4.600D-01, 1.700D-01, 8.900D-01, |
| 32066 | & 0.000D+00, 7.900D-01, 0.000D+00, 8.900D-01, 0.000D+00, 8.100D-01, |
| 32067 | &-6.000D-02, 6.900D-01,-2.000D-01, 7.100D-01,-1.200D-01, 7.200D-01, |
| 32068 | & 0.000D+00, 7.700D-01/ |
| 32069 | DATA ( PNCOOK(I),I = 1, 90 ) / |
| 32070 | & 0.000D+00, 5.980D+00, 0.000D+00, 2.770D+00, 0.000D+00, 3.160D+00, |
| 32071 | & 0.000D+00, 3.010D+00, 0.000D+00, 2.500D+00, 0.000D+00, 2.670D+00, |
| 32072 | & 0.000D+00, 1.800D+00, 0.000D+00, 1.670D+00, 0.000D+00, 1.860D+00, |
| 32073 | & 0.000D+00, 2.040D+00, 0.000D+00, 1.640D+00, 0.000D+00, 1.440D+00, |
| 32074 | & 0.000D+00, 1.540D+00, 0.000D+00, 1.300D+00, 0.000D+00, 1.270D+00, |
| 32075 | & 0.000D+00, 1.290D+00, 8.000D-02, 1.410D+00,-8.000D-02, 1.500D+00, |
| 32076 | &-5.000D-02, 2.240D+00,-4.700D-01, 1.430D+00,-1.500D-01, 1.440D+00, |
| 32077 | & 6.000D-02, 1.560D+00, 2.500D-01, 1.570D+00,-1.600D-01, 1.460D+00, |
| 32078 | & 0.000D+00, 9.300D-01, 1.000D-02, 6.200D-01,-5.000D-01, 1.420D+00, |
| 32079 | & 1.300D-01, 1.520D+00,-6.500D-01, 8.000D-01,-8.000D-02, 1.290D+00, |
| 32080 | &-4.700D-01, 1.250D+00,-4.400D-01, 9.700D-01, 8.000D-02, 1.650D+00, |
| 32081 | &-1.100D-01, 1.260D+00,-4.600D-01, 1.060D+00, 2.200D-01, 1.550D+00, |
| 32082 | &-7.000D-02, 1.370D+00, 1.000D-01, 1.200D+00,-2.700D-01, 9.200D-01, |
| 32083 | &-3.500D-01, 1.190D+00, 0.000D+00, 1.050D+00,-2.500D-01, 1.610D+00, |
| 32084 | &-2.100D-01, 9.000D-01,-2.100D-01, 7.400D-01,-3.800D-01, 7.200D-01/ |
| 32085 | DATA ( PNCOOK(I),I = 91, INCOOK ) / |
| 32086 | &-3.400D-01, 9.200D-01,-2.600D-01, 9.400D-01, 1.000D-02, 6.500D-01, |
| 32087 | &-3.600D-01, 8.300D-01, 1.100D-01, 6.700D-01, 5.000D-02, 1.000D+00, |
| 32088 | & 5.100D-01, 1.040D+00, 3.300D-01, 6.800D-01,-2.700D-01, 8.100D-01, |
| 32089 | & 9.000D-02, 7.500D-01, 1.700D-01, 8.600D-01, 1.400D-01, 1.100D+00, |
| 32090 | &-2.200D-01, 8.400D-01,-4.700D-01, 4.800D-01, 2.000D-02, 8.800D-01, |
| 32091 | & 2.400D-01, 5.200D-01, 2.700D-01, 4.100D-01,-5.000D-02, 3.800D-01, |
| 32092 | & 1.500D-01, 6.700D-01, 0.000D+00, 6.100D-01, 0.000D+00, 7.800D-01, |
| 32093 | & 0.000D+00, 6.700D-01, 0.000D+00, 6.700D-01, 0.000D+00, 7.900D-01, |
| 32094 | & 0.000D+00, 6.000D-01, 4.000D-02, 6.400D-01,-6.000D-02, 4.500D-01, |
| 32095 | & 5.000D-02, 2.600D-01,-2.200D-01, 3.900D-01, 0.000D+00, 3.900D-01/ |
| 32096 | DATA ( SZCOOK(I),I = 1, 98) / |
| 32097 | & 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, |
| 32098 | & 0.000D+00, 0.000D+00,-1.100D-01,-8.100D-01,-2.910D+00,-4.170D+00, |
| 32099 | &-5.720D+00,-7.800D+00,-8.970D+00,-9.700D+00,-1.010D+01,-1.070D+01, |
| 32100 | &-1.138D+01,-1.207D+01,-1.255D+01,-1.324D+01,-1.393D+01,-1.471D+01, |
| 32101 | &-1.553D+01,-1.637D+01,-1.736D+01,-1.860D+01,-1.870D+01,-1.801D+01, |
| 32102 | &-1.787D+01,-1.708D+01,-1.660D+01,-1.675D+01,-1.650D+01,-1.635D+01, |
| 32103 | &-1.622D+01,-1.641D+01,-1.689D+01,-1.643D+01,-1.668D+01,-1.673D+01, |
| 32104 | &-1.745D+01,-1.729D+01,-1.744D+01,-1.782D+01,-1.862D+01,-1.827D+01, |
| 32105 | &-1.939D+01,-1.991D+01,-1.914D+01,-1.826D+01,-1.740D+01,-1.642D+01, |
| 32106 | &-1.577D+01,-1.437D+01,-1.391D+01,-1.310D+01,-1.311D+01,-1.143D+01, |
| 32107 | &-1.089D+01,-1.075D+01,-1.062D+01,-1.041D+01,-1.021D+01,-9.850D+00, |
| 32108 | &-9.470D+00,-9.030D+00,-8.610D+00,-8.130D+00,-7.460D+00,-7.480D+00, |
| 32109 | &-7.200D+00,-7.130D+00,-7.060D+00,-6.780D+00,-6.640D+00,-6.640D+00, |
| 32110 | &-7.680D+00,-7.890D+00,-8.410D+00,-8.490D+00,-7.880D+00,-6.300D+00, |
| 32111 | &-5.470D+00,-4.780D+00,-4.370D+00,-4.170D+00,-4.130D+00,-4.320D+00, |
| 32112 | &-4.550D+00,-5.040D+00,-5.280D+00,-6.060D+00,-6.280D+00,-6.870D+00, |
| 32113 | &-7.200D+00,-7.740D+00/ |
| 32114 | DATA ( SNCOOK(I),I = 1, 90 ) / |
| 32115 | & 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, |
| 32116 | & 0.000D+00, 0.000D+00, 1.030D+01, 5.660D+00, 6.800D+00, 7.530D+00, |
| 32117 | & 7.550D+00, 7.210D+00, 7.440D+00, 8.070D+00, 8.940D+00, 9.810D+00, |
| 32118 | & 1.060D+01, 1.139D+01, 1.254D+01, 1.368D+01, 1.434D+01, 1.419D+01, |
| 32119 | & 1.383D+01, 1.350D+01, 1.300D+01, 1.213D+01, 1.260D+01, 1.326D+01, |
| 32120 | & 1.413D+01, 1.492D+01, 1.552D+01, 1.638D+01, 1.716D+01, 1.755D+01, |
| 32121 | & 1.803D+01, 1.759D+01, 1.903D+01, 1.871D+01, 1.880D+01, 1.899D+01, |
| 32122 | & 1.846D+01, 1.825D+01, 1.776D+01, 1.738D+01, 1.672D+01, 1.562D+01, |
| 32123 | & 1.438D+01, 1.288D+01, 1.323D+01, 1.381D+01, 1.490D+01, 1.486D+01, |
| 32124 | & 1.576D+01, 1.620D+01, 1.762D+01, 1.773D+01, 1.816D+01, 1.867D+01, |
| 32125 | & 1.969D+01, 1.951D+01, 2.017D+01, 1.948D+01, 1.998D+01, 1.983D+01, |
| 32126 | & 2.020D+01, 1.972D+01, 1.987D+01, 1.924D+01, 1.844D+01, 1.761D+01, |
| 32127 | & 1.710D+01, 1.616D+01, 1.590D+01, 1.533D+01, 1.476D+01, 1.354D+01, |
| 32128 | & 1.263D+01, 1.065D+01, 1.010D+01, 8.890D+00, 1.025D+01, 9.790D+00, |
| 32129 | & 1.139D+01, 1.172D+01, 1.243D+01, 1.296D+01, 1.343D+01, 1.337D+01/ |
| 32130 | DATA ( SNCOOK(I),I = 91, INCOOK ) / |
| 32131 | & 1.296D+01, 1.211D+01, 1.192D+01, 1.100D+01, 1.080D+01, 1.042D+01, |
| 32132 | & 1.039D+01, 9.690D+00, 9.270D+00, 8.930D+00, 8.570D+00, 8.020D+00, |
| 32133 | & 7.590D+00, 7.330D+00, 7.230D+00, 7.050D+00, 7.420D+00, 6.750D+00, |
| 32134 | & 6.600D+00, 6.380D+00, 6.360D+00, 6.490D+00, 6.250D+00, 5.850D+00, |
| 32135 | & 5.480D+00, 4.530D+00, 4.300D+00, 3.390D+00, 2.350D+00, 1.660D+00, |
| 32136 | & 8.100D-01, 4.600D-01,-9.600D-01,-1.690D+00,-2.530D+00,-3.160D+00, |
| 32137 | &-1.870D+00,-4.100D-01, 7.100D-01, 1.660D+00, 2.620D+00, 3.220D+00, |
| 32138 | & 3.760D+00, 4.100D+00, 4.460D+00, 4.830D+00, 5.090D+00, 5.180D+00, |
| 32139 | & 5.170D+00, 5.100D+00, 5.010D+00, 4.970D+00, 5.090D+00, 5.030D+00, |
| 32140 | & 4.930D+00, 5.280D+00, 5.490D+00, 5.500D+00, 5.370D+00, 5.300D+00/ |
| 32141 | DATA LDEFOZ / 53*.FALSE.,25*.TRUE.,7*.FALSE.,13*.TRUE. / |
| 32142 | DATA LDEFON / 85*.FALSE.,37*.TRUE.,7*.FALSE.,21*.TRUE. / |
| 32143 | *=== End of Block Data Bdevap =========================================* |
| 32144 | END |
| 32145 | |
| 32146 | *$ CREATE DT_BDNOPT.FOR |
| 32147 | *COPY DT_BDNOPT |
| 32148 | * |
| 32149 | *=== bdnopt ===========================================================* |
| 32150 | *== * |
| 32151 | BLOCK DATA DT_BDNOPT |
| 32152 | |
| 32153 | C INCLUDE '(DBLPRC)' |
| 32154 | * DBLPRC.ADD |
| 32155 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 32156 | SAVE |
| 32157 | * (original name: GLOBAL) |
| 32158 | PARAMETER ( KALGNM = 2 ) |
| 32159 | PARAMETER ( ANGLGB = 5.0D-16 ) |
| 32160 | PARAMETER ( ANGLSQ = 2.5D-31 ) |
| 32161 | PARAMETER ( AXCSSV = 0.2D+16 ) |
| 32162 | PARAMETER ( ANDRFL = 1.0D-38 ) |
| 32163 | PARAMETER ( AVRFLW = 1.0D+38 ) |
| 32164 | PARAMETER ( AINFNT = 1.0D+30 ) |
| 32165 | PARAMETER ( AZRZRZ = 1.0D-30 ) |
| 32166 | PARAMETER ( EINFNT = +69.07755278982137 D+00 ) |
| 32167 | PARAMETER ( EZRZRZ = -69.07755278982137 D+00 ) |
| 32168 | PARAMETER ( EXCSSV = +35.23192357547063 D+00 ) |
| 32169 | PARAMETER ( ENGLGB = -35.23192357547063 D+00 ) |
| 32170 | PARAMETER ( ONEMNS = 0.999999999999999 D+00 ) |
| 32171 | PARAMETER ( ONEPLS = 1.000000000000001 D+00 ) |
| 32172 | PARAMETER ( CSNNRM = 2.0D-15 ) |
| 32173 | PARAMETER ( DMXTRN = 1.0D+08 ) |
| 32174 | PARAMETER ( ZERZER = 0.D+00 ) |
| 32175 | PARAMETER ( ONEONE = 1.D+00 ) |
| 32176 | PARAMETER ( TWOTWO = 2.D+00 ) |
| 32177 | PARAMETER ( THRTHR = 3.D+00 ) |
| 32178 | PARAMETER ( FOUFOU = 4.D+00 ) |
| 32179 | PARAMETER ( FIVFIV = 5.D+00 ) |
| 32180 | PARAMETER ( SIXSIX = 6.D+00 ) |
| 32181 | PARAMETER ( SEVSEV = 7.D+00 ) |
| 32182 | PARAMETER ( EIGEIG = 8.D+00 ) |
| 32183 | PARAMETER ( ANINEN = 9.D+00 ) |
| 32184 | PARAMETER ( TENTEN = 10.D+00 ) |
| 32185 | PARAMETER ( HLFHLF = 0.5D+00 ) |
| 32186 | PARAMETER ( ONETHI = ONEONE / THRTHR ) |
| 32187 | PARAMETER ( TWOTHI = TWOTWO / THRTHR ) |
| 32188 | PARAMETER ( ONEFOU = ONEONE / FOUFOU ) |
| 32189 | PARAMETER ( THRTWO = THRTHR / TWOTWO ) |
| 32190 | PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 ) |
| 32191 | PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 ) |
| 32192 | PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 ) |
| 32193 | PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 ) |
| 32194 | PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 ) |
| 32195 | PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 ) |
| 32196 | PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 ) |
| 32197 | PARAMETER ( EULERO = 0.577215664901532860606512 D+00 ) |
| 32198 | PARAMETER ( EULEXP = 1.781072417990197985236504 D+00 ) |
| 32199 | PARAMETER ( EULLOG =-0.5495393129816448223376619 D+00 ) |
| 32200 | PARAMETER ( E1M2EU = 0.8569023337737540831433017 D+00 ) |
| 32201 | PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 ) |
| 32202 | PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 ) |
| 32203 | PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 ) |
| 32204 | PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 ) |
| 32205 | PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 ) |
| 32206 | PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 ) |
| 32207 | PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 ) |
| 32208 | PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 ) |
| 32209 | PARAMETER ( CLIGHT = 2.99792458 D+10 ) |
| 32210 | PARAMETER ( AVOGAD = 6.0221367 D+23 ) |
| 32211 | PARAMETER ( BOLTZM = 1.380658 D-23 ) |
| 32212 | PARAMETER ( AMELGR = 9.1093897 D-28 ) |
| 32213 | PARAMETER ( PLCKBR = 1.05457266 D-27 ) |
| 32214 | PARAMETER ( ELCCGS = 4.8032068 D-10 ) |
| 32215 | PARAMETER ( ELCMKS = 1.60217733 D-19 ) |
| 32216 | PARAMETER ( AMUGRM = 1.6605402 D-24 ) |
| 32217 | PARAMETER ( AMMUMU = 0.113428913 D+00 ) |
| 32218 | PARAMETER ( AMPRMU = 1.007276470 D+00 ) |
| 32219 | PARAMETER ( AMNEMU = 1.008664904 D+00 ) |
| 32220 | PARAMETER ( ALPFSC = 7.2973530791728595 D-03 ) |
| 32221 | PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 ) |
| 32222 | PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 ) |
| 32223 | PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 ) |
| 32224 | PARAMETER ( PLABRC = 0.197327053 D+00 ) |
| 32225 | PARAMETER ( AMELCT = 0.51099906 D-03 ) |
| 32226 | PARAMETER ( AMUGEV = 0.93149432 D+00 ) |
| 32227 | PARAMETER ( AMMUON = 0.105658389 D+00 ) |
| 32228 | PARAMETER ( AMPRTN = 0.93827231 D+00 ) |
| 32229 | PARAMETER ( AMNTRN = 0.93956563 D+00 ) |
| 32230 | PARAMETER ( AMDEUT = 1.87561339 D+00 ) |
| 32231 | PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13 |
| 32232 | & * 1.D-09 ) |
| 32233 | PARAMETER ( RCLSEL = 2.8179409183694872 D-13 ) |
| 32234 | PARAMETER ( BLTZMN = 8.617385 D-14 ) |
| 32235 | PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT ) |
| 32236 | PARAMETER ( GFOHB3 = 1.16639 D-05 ) |
| 32237 | PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC ) |
| 32238 | PARAMETER ( SIN2TW = 0.2319 D+00 ) |
| 32239 | PARAMETER ( GEVMEV = 1.0 D+03 ) |
| 32240 | PARAMETER ( EMVGEV = 1.0 D-03 ) |
| 32241 | PARAMETER ( ALGVMV = 6.90775527898214 D+00 ) |
| 32242 | PARAMETER ( RADDEG = 180.D+00 / PIPIPI ) |
| 32243 | PARAMETER ( DEGRAD = PIPIPI / 180.D+00 ) |
| 32244 | LOGICAL LGBIAS, LGBANA |
| 32245 | COMMON /FKGLOB/ LGBIAS, LGBANA |
| 32246 | C INCLUDE '(DIMPAR)' |
| 32247 | * DIMPAR.ADD |
| 32248 | PARAMETER ( MXXRGN = 5000 ) |
| 32249 | PARAMETER ( MXXMDF = 82 ) |
| 32250 | PARAMETER ( MXXMDE = 54 ) |
| 32251 | PARAMETER ( MFSTCK = 1000 ) |
| 32252 | PARAMETER ( MESTCK = 100 ) |
| 32253 | PARAMETER ( NELEMX = 80 ) |
| 32254 | PARAMETER ( MPDPDX = 8 ) |
| 32255 | PARAMETER ( ICOMAX = 180 ) |
| 32256 | PARAMETER ( NSTBIS = 304 ) |
| 32257 | PARAMETER ( IDMAXP = 220 ) |
| 32258 | PARAMETER ( IDMXDC = 640 ) |
| 32259 | PARAMETER ( MKBMX1 = 1 ) |
| 32260 | PARAMETER ( MKBMX2 = 1 ) |
| 32261 | C INCLUDE '(IOUNIT)' |
| 32262 | * IOUNIT.ADD |
| 32263 | PARAMETER ( LUNIN = 5 ) |
| 32264 | PARAMETER ( LUNOUT = 6 ) |
| 32265 | **sr 19.5. set error output-unit from 15 to 6 |
| 32266 | PARAMETER ( LUNERR = 6 ) |
| 32267 | PARAMETER ( LUNBER = 14 ) |
| 32268 | PARAMETER ( LUNECH = 8 ) |
| 32269 | PARAMETER ( LUNFLU = 13 ) |
| 32270 | PARAMETER ( LUNGEO = 16 ) |
| 32271 | PARAMETER ( LUNPMF = 12 ) |
| 32272 | PARAMETER ( LUNRAN = 2 ) |
| 32273 | PARAMETER ( LUNXSC = 9 ) |
| 32274 | PARAMETER ( LUNDET = 17 ) |
| 32275 | PARAMETER ( LUNRAY = 10 ) |
| 32276 | PARAMETER ( LUNRDB = 1 ) |
| 32277 | PARAMETER ( LUNPGO = 7 ) |
| 32278 | PARAMETER ( LUNPGS = 4 ) |
| 32279 | PARAMETER ( LUNSCR = 3 ) |
| 32280 | * |
| 32281 | *----------------------------------------------------------------------* |
| 32282 | * * |
| 32283 | * Created on 20 september 1989 by Alfredo Ferrari - Infn Milan * |
| 32284 | * * |
| 32285 | * Last change on 20-apr-95 by Alfredo Ferrari * |
| 32286 | * * |
| 32287 | *----------------------------------------------------------------------* |
| 32288 | * |
| 32289 | C INCLUDE '(BLNKCM)' |
| 32290 | * BLNKCM.ADD |
| 32291 | **sr 17.5. commented since not used here |
| 32292 | C PARAMETER ( NBLNMX = 1100000 ) |
| 32293 | C DIMENSION GMSTOR ( NBLNMX ), BRMBRR ( NBLNMX ), BRMEXP ( NBLNMX ), |
| 32294 | C & BRMSIG ( NBLNMX ), SIGGTT ( KALGNM*NBLNMX ), |
| 32295 | C & COMSCO ( NBLNMX ), LBSTOR ( KALGNM*NBLNMX ) |
| 32296 | C REAL SIGGTT |
| 32297 | C LOGICAL LBSTOR |
| 32298 | C COMMON NSTOR ( KALGNM*NBLNMX ) |
| 32299 | ** |
| 32300 | **sr 18.5. commented since not used for evap. |
| 32301 | C COMMON / ADDRCM / MBLNMX, KBLNKL, KGMBGN, KGMLST, KCMBGN, KCMLST, |
| 32302 | C & KISBGN, KISLST, KDTBGN, KDTLST, KUBBGN, KUBLST, |
| 32303 | C & KUXBGN, KUXLST, KTCBGN, KTCLST, KRNBGN, KRNLST, |
| 32304 | C & KYLBGN, KYLLST, KXSBGN, KXSLST, KIHBGN, KIHLST, |
| 32305 | C & KINBGN, KINLST, KIEBGN, KIELST, KETBGN, KETLST, |
| 32306 | C & KRRBGN, KRRLST, KGLBGN, KGLLST, KNABGN, KNALST, |
| 32307 | C & KGDBGN, KGDLST, KDWBGN, KDWLST, KGCBGN, KGCLST, |
| 32308 | C & KWLBGN, KWLLST, KWHBGN, KWHLST, KWMBGN, KWMLST, |
| 32309 | C & KWSBGN, KWSLST, KNDBGN, KNDLST, KDPBGN, KDPLST, |
| 32310 | C & KRGBGN, KRGLST, KSGBGN, KSGLST, KBRBGN, KBRLST, |
| 32311 | C & KTMBGN |
| 32312 | ** |
| 32313 | |
| 32314 | C EQUIVALENCE ( NSTOR (1), GMSTOR (1) ) |
| 32315 | C EQUIVALENCE ( NSTOR (1), BRMBRR (1) ) |
| 32316 | C EQUIVALENCE ( NSTOR (1), BRMEXP (1) ) |
| 32317 | C EQUIVALENCE ( NSTOR (1), BRMSIG (1) ) |
| 32318 | C EQUIVALENCE ( NSTOR (1), COMSCO (1) ) |
| 32319 | C EQUIVALENCE ( NSTOR (1), SIGGTT (1) ) |
| 32320 | C EQUIVALENCE ( NSTOR (1), LBSTOR (1) ) |
| 32321 | C INCLUDE '(BLNTMP)' |
| 32322 | * BLNTMP.ADD |
| 32323 | **sr 18.5. commented since not used for evap. |
| 32324 | C COMMON / BLNTMP / KIHBTM, KINBTM, KIEBTM, KRRBTM, KGLBTM, KNABTM, |
| 32325 | C & KGCBTM, KGDWTM, KBDWTM, KWLOTM, KWHITM, KWMUTM, |
| 32326 | C & KWSHTM, KEXTTM, KSTXTM, KSTNTM, KECTTM, KPCTTM, |
| 32327 | C & KLPBTM, NXXRGN |
| 32328 | ** |
| 32329 | C INCLUDE '(CMMDNR)' |
| 32330 | * CMMDNR.ADD |
| 32331 | **sr 18.5. commented since not used for evap. |
| 32332 | C LOGICAL LFLDNR |
| 32333 | C COMMON / CMMDNR / DDNEAR, LFLDNR |
| 32334 | ** |
| 32335 | C INCLUDE '(CTITLE)' |
| 32336 | * CTITLE.ADD |
| 32337 | **sr 18.5. commented since not used for evap. |
| 32338 | C CHARACTER RUNTIT*80, RUNTIM*32, RUNKEY*10 |
| 32339 | C COMMON / CTITLE / RUNTIT, RUNTIM, RUNKEY |
| 32340 | C COMMON / CEXPCK / ITEXPI, ITEXMX |
| 32341 | ** |
| 32342 | C INCLUDE '(DETECT)' |
| 32343 | * DETECT.ADD |
| 32344 | **sr 18.5. commented since not used for evap. |
| 32345 | C PARAMETER (NRGNMX = 10) |
| 32346 | C PARAMETER (NDTCMX = 10) |
| 32347 | C PARAMETER (NSCRMX = 10) |
| 32348 | C PARAMETER (NDTBIN = 1024) |
| 32349 | C CHARACTER*10 TITDET,TITSCO |
| 32350 | C LOGICAL LDTCTR |
| 32351 | C COMMON /DETCT/ EDTMIN(NDTCMX), EDTBIN(NDTCMX), EDTCUT(NDTCMX), |
| 32352 | C & KDTREG(NRGNMX,NDTCMX), KDTDET(NDTCMX,NSCRMX), |
| 32353 | C & NDTSCO, NDTDET, LDTCTR, IDTREG(MXXRGN), |
| 32354 | C & KDTSCD(NSCRMX) |
| 32355 | C COMMON /DETCH/ TITDET(NDTCMX), TITSCO(NSCRMX) |
| 32356 | ** |
| 32357 | C INCLUDE '(DETLOC)' |
| 32358 | * DETLOC.ADD |
| 32359 | **sr 18.5. commented since not used for evap. |
| 32360 | C PARAMETER (NDTCM2 = 10) |
| 32361 | C COMMON /DETLOC/ ACCUMP (NDTCM2), ACCUMN (NDTCM2), |
| 32362 | C & ICOINC(NDTCM2), NCLAS |
| 32363 | ** |
| 32364 | C INCLUDE '(EMGTRN)' |
| 32365 | * EMGTRN.ADD |
| 32366 | **sr 18.5. commented since not used for evap. |
| 32367 | C LOGICAL LMCSMG |
| 32368 | C COMMON / EMGTRN / UMCSMG, VMCSMG, WMCSMG, LMCSMG |
| 32369 | ** |
| 32370 | C INCLUDE '(EMSHO)' |
| 32371 | * EMSHO.ADD |
| 32372 | **sr 18.5. commented since not used for evap. |
| 32373 | C LOGICAL EMFLO, EMFHLO, EMFELO, LIMPRE, LEXPTE |
| 32374 | C COMMON /EMSHO/ EMFETH, EMFPTH, EMFHET, EMFHPT, EMFBIA, EMFLO, |
| 32375 | C & EMFHLO, EMFELO, LIMPRE, LEXPTE |
| 32376 | ** |
| 32377 | C INCLUDE '(EPISOR)' |
| 32378 | * EPISOR.ADD |
| 32379 | **sr 18.5. commented since not used for evap. |
| 32380 | C LOGICAL LUSSRC |
| 32381 | C COMMON/EPISOR/TKESUM,LUSSRC |
| 32382 | ** |
| 32383 | * (original name: FHEAVY,FHEAVC) |
| 32384 | PARAMETER ( MXHEAV = 100 ) |
| 32385 | CHARACTER*8 ANHEAV |
| 32386 | COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV), |
| 32387 | & CZHEAV (MXHEAV), TKHEAV (MXHEAV), |
| 32388 | & PHEAVY (MXHEAV), WHEAVY (MXHEAV), |
| 32389 | & AMHEAV ( 12 ) , AMNHEA ( 12 ) , |
| 32390 | & KHEAVY (MXHEAV), ICHEAV ( 12 ) , |
| 32391 | & IBHEAV ( 12 ) , NPHEAV |
| 32392 | COMMON /FKFHVC/ ANHEAV ( 12 ) |
| 32393 | * (original name: FINUC) |
| 32394 | PARAMETER (MXP=999) |
| 32395 | COMMON /FKFINU/ CXR (MXP), CYR (MXP), CZR (MXP), |
| 32396 | & CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP), |
| 32397 | & TKI (MXP), PLR (MXP), WEI (MXP), |
| 32398 | & TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP, |
| 32399 | & KPART (MXP) |
| 32400 | C INCLUDE '(GENTHR)' |
| 32401 | * GENTHR.ADD |
| 32402 | **sr 18.5. commented since not used for evap. |
| 32403 | C COMMON / GENTHR / PEANCT, PEAPIT, PLDNCT, PTHRSH (NALLWP), |
| 32404 | C & PTHDFF (NALLWP), IJNUCR (NALLWP) |
| 32405 | ** |
| 32406 | C INCLUDE '(LOWNEU)' |
| 32407 | * LOWNEU.ADD |
| 32408 | **sr 18.5. commented since not used for evap. |
| 32409 | C PARAMETER ( MXGTHN = 15 ) |
| 32410 | C PARAMETER ( MXGLWN = 200 ) |
| 32411 | C PARAMETER ( MXSHPP = 5 ) |
| 32412 | C LOGICAL LCOMPN, LIMPRN, LBIASN, LDOWNN, LRECPR, LLOWWW, LLOWET |
| 32413 | C CHARACTER*10 TITLOW |
| 32414 | C COMMON / LOWNEU / ATOLOW (MXXMDF), WSHPLN (MXGLWN,MXSHPP), EXTWWL, |
| 32415 | C & SHPIMP (MXGLWN), EXTETL (MXGLWN), WWAMFL, |
| 32416 | C & VLLNTH (MXGTHN,MXXMDF), ABLNTH (MXGTHN,MXXMDF), |
| 32417 | C & STLNTH (MXGTHN,MXXMDF), TMRTLN (MXXMDF), |
| 32418 | C & TMNMLN (MXXMDF), ICHCPT (MXXMDF), |
| 32419 | C & IGTMRT (MXXMDF), NEUMED (MXXMDF), |
| 32420 | C & ID1MED (MXXMDF), ID2MED (MXXMDF), |
| 32421 | C & ID3MED (MXXMDF), MGTMED (MXXMDF), |
| 32422 | C & LCOMPN (MXXMDF), LRECPR (MXXMDF), KPRLOW, NMGP, |
| 32423 | C & NMTG , IGRTHN, LIMPRN, LBIASN, LDOWNN, LLOWWW, |
| 32424 | C & LLOWET, ICLMED, IKRBGN, INABGN, IDWBGN, IETBGN, |
| 32425 | C & I0XSEC, IDXSEC, ISENAV, ISVELN, ISPNAV, IWWLWB, |
| 32426 | C & IWWLWT, IPXBGN, NPXSEC |
| 32427 | C COMMON / CHLWNT / TITLOW (MXXMDF) |
| 32428 | ** |
| 32429 | C INCLUDE '(LTCLCM)' |
| 32430 | * LTCLCM.ADD |
| 32431 | **sr 18.5. commented since not used for evap. |
| 32432 | C COMMON / LTCLCM / MLATTC, NEWLAT, MLATLD, MLATM1, MLTSEN, MLTSM1 |
| 32433 | ** |
| 32434 | C INCLUDE '(MULBOU)' |
| 32435 | * MULBOU.ADD |
| 32436 | **sr 18.5. commented since not used for evap. |
| 32437 | C LOGICAL LLDA , LAGAIN, LSTNEW, LARTEF, LNORML, LSENSE, LMGNOR |
| 32438 | C COMMON / MULBOU / UOLD , VOLD , WOLD , UMAG , VMAG , WMAG , |
| 32439 | C & UNORML, VNORML, WNORML, USENSE, VSENSE, WSENSE, |
| 32440 | C & TSENSE, DDSENS, DSMALL, NSSENS, LLDA , LAGAIN, |
| 32441 | C & LSTNEW, LARTEF, LNORML, LSENSE, LMGNOR |
| 32442 | ** |
| 32443 | C INCLUDE '(MULHD)' |
| 32444 | * MULHD.ADD |
| 32445 | **sr 18.5. commented since not used for evap. |
| 32446 | C PARAMETER ( MXXPT1 = 1 ) |
| 32447 | C PARAMETER ( TIMESS = 2.00D+00 ) |
| 32448 | C PARAMETER ( TMSRLX = 1.50D+00 ) |
| 32449 | C PARAMETER ( EPSINS = 0.15D+00 ) |
| 32450 | C PARAMETER ( EPSRLX = 0.50D+00 ) |
| 32451 | C PARAMETER ( SQEPSN = 0.3872983346207417 D+00 ) |
| 32452 | C PARAMETER ( SQEPSR = 0.7071067811865475 D+00 ) |
| 32453 | C PARAMETER ( PARNSI = 1.732050807568877 D+00 * SQEPSN ) |
| 32454 | C PARAMETER ( PRNSR0 = 1.732050807568877 D+00 * SQEPSR ) |
| 32455 | C PARAMETER ( R0NCMS = 1.20 D+00 ) |
| 32456 | C LOGICAL LTOPT, LSRCRH, LNSCRH |
| 32457 | C COMMON / MULHD / BLCC ( MXXMDF ), BLCCRA ( MXXMDF ), |
| 32458 | C & XCC ( MXXMDF ), ZTILDE ( MXXMDF, 0:MXXPT1 ), |
| 32459 | C & ALPZTL ( MXXMDF, 0:MXXPT1 ), RLDU ( MXXMDF ), |
| 32460 | C & ALPZT2 ( MXXMDF, 0:MXXPT1 ), TEFF0 ( MXXMDF ), |
| 32461 | C & XR0 ( MXXMDF ), ECUTM ( MXXMDF, 39, 2 ), |
| 32462 | C & ESTEPF ( MXXMDF ), HTHNSZ ( MXXMDF, 39 ), |
| 32463 | C & AE1O3 ( MXXMDF ), PARNSR ( MXXMDF ), |
| 32464 | C & HEESLI ( MXXMDF ), THMSPR, THMSSC, HMSAMP, |
| 32465 | C & HMREJE, LSRCRH ( MXXMDF ), LNSCRH ( MXXMDF ), |
| 32466 | C & LTOPT ( MXXMDF ), NFSCAT |
| 32467 | ** |
| 32468 | * (original name: PAREVT) |
| 32469 | LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX, |
| 32470 | & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF |
| 32471 | PARAMETER ( NALLWP = 39 ) |
| 32472 | COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, |
| 32473 | & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY, |
| 32474 | & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV, |
| 32475 | & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF |
| 32476 | * (original name: RESNUC) |
| 32477 | LOGICAL LRNFSS, LFRAGM |
| 32478 | COMMON /FKRESN/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1, |
| 32479 | & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT, |
| 32480 | & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES, |
| 32481 | & PYRES, PZRES, PTRES2, KTARP, KTARN, IGREYP, |
| 32482 | & IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE, |
| 32483 | & ICRES, IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU, |
| 32484 | & IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG, |
| 32485 | & IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS, |
| 32486 | & LFRAGM |
| 32487 | C INCLUDE '(SCOHLP)' |
| 32488 | * SCOHLP.ADD |
| 32489 | **sr 18.5. commented since not used for evap. |
| 32490 | C LOGICAL LSCZER |
| 32491 | C COMMON / SCOHLP / ISCRNG, JSCRNG, LSCZER |
| 32492 | ** |
| 32493 | C INCLUDE '(TRACKR)' |
| 32494 | * TRACKR.ADD |
| 32495 | **sr 18.5. commented since not used for evap. |
| 32496 | C PARAMETER ( MXTRCK = 2500 ) |
| 32497 | C LOGICAL LFSSSC |
| 32498 | C COMMON / TRACKR / XTRACK ( 0:MXTRCK ), YTRACK ( 0:MXTRCK ), |
| 32499 | C & ZTRACK ( 0:MXTRCK ), TTRACK ( MXTRCK ), |
| 32500 | C & DTRACK ( MXTRCK ), ETRACK, PTRACK, WTRACK, |
| 32501 | C & ATRACK, CTRACK, AKSHRT, AKLONG, WSCRNG, |
| 32502 | C & NTRACK, MTRACK, JTRACK, KTRACK, MMTRCK, |
| 32503 | C & LT1TRK, LT2TRK, LTRACK, LLOUSE, LFSSSC |
| 32504 | ** |
| 32505 | C INCLUDE '(USRBDX)' |
| 32506 | * USRBDX.ADD |
| 32507 | **sr 18.5. commented since not used for evap. |
| 32508 | C PARAMETER ( MXUSBX = 600 ) |
| 32509 | C LOGICAL LUSBDX, LFUSBX, LWUSBX, LLNUSX |
| 32510 | C CHARACTER*10 TITUSX |
| 32511 | C COMMON /USRBX/ EBXLOW(MXUSBX), EBXHGH(MXUSBX), ABXLOW(MXUSBX), |
| 32512 | C & ABXHGH(MXUSBX), DEBXBN(MXUSBX), DABXBN(MXUSBX), |
| 32513 | C & AUSBDX(MXUSBX), |
| 32514 | C & NEBXBN(MXUSBX), NABXBN(MXUSBX), NR1USX(MXUSBX), |
| 32515 | C & NR2USX(MXUSBX), ITUSBX(MXUSBX), IDUSBX(MXUSBX), |
| 32516 | C & KBUSBX(MXUSBX), IPUSBX(MXUSBX), IGMUSX(MXUSBX), |
| 32517 | C & LFUSBX(MXUSBX), LWUSBX(MXUSBX), LLNUSX(MXUSBX), |
| 32518 | C & NUSRBX, LUSBDX |
| 32519 | C COMMON /USXCH/ TITUSX(MXUSBX) |
| 32520 | ** |
| 32521 | C INCLUDE '(USRBIN)' |
| 32522 | * USRBIN.ADD |
| 32523 | **sr 18.5. commented since not used for evap. |
| 32524 | C PARAMETER ( MXUSBN = 100 ) |
| 32525 | C LOGICAL LUSBIN, LEVTBN, LNTZER, LUSEVT, LUSTKB, LTRKBN |
| 32526 | C CHARACTER*10 TITUSB |
| 32527 | C COMMON /USRBN/ XLOW (MXUSBN), XHIGH (MXUSBN), YLOW (MXUSBN), |
| 32528 | C & YHIGH (MXUSBN), ZLOW (MXUSBN), ZHIGH (MXUSBN), |
| 32529 | C & DXUSBN(MXUSBN), DYUSBN(MXUSBN), DZUSBN(MXUSBN), |
| 32530 | C & TCUSBN(MXUSBN), BKUSBN(MXUSBN), B2USBN(MXUSBN), |
| 32531 | C & NXBIN (MXUSBN), NYBIN (MXUSBN), NZBIN (MXUSBN), |
| 32532 | C & ITUSBN(MXUSBN), IDUSBN(MXUSBN), KBUSBN(MXUSBN), |
| 32533 | C & IPUSBN(MXUSBN), LEVTBN(MXUSBN), LNTZER(MXUSBN), |
| 32534 | C & LTRKBN(MXUSBN), NUSRBN, LUSBIN, LUSEVT, LUSTKB |
| 32535 | C COMMON /USRCH/ TITUSB(MXUSBN) |
| 32536 | ** |
| 32537 | C INCLUDE '(USRSNC)' |
| 32538 | * USRSNC.ADD |
| 32539 | **sr 18.5. commented since not used for evap. |
| 32540 | C PARAMETER ( MXRSNC = 400 ) |
| 32541 | C PARAMETER ( NMZMIN = -5 ) |
| 32542 | C LOGICAL LURSNC |
| 32543 | C CHARACTER*10 TIURSN |
| 32544 | C COMMON /USRSNC/ VURSNC(MXRSNC), IZRHGH(MXRSNC), IMRHGH(MXRSNC), |
| 32545 | C & NRURSN(MXRSNC), ITURSN(MXRSNC), KBURSN(MXRSNC), |
| 32546 | C & IPURSN(MXRSNC), NURSNC, LURSNC |
| 32547 | C COMMON /USRSCH/ TIURSN(MXRSNC) |
| 32548 | C INCLUDE '(USRTRC)' |
| 32549 | * USRTRC.ADD |
| 32550 | **sr 18.5. commented since not used for evap. |
| 32551 | C PARAMETER ( MXUSTC = 400 ) |
| 32552 | C LOGICAL LUSRTC, LUSTRK, LUSCLL, LLNUTC |
| 32553 | C CHARACTER*10 TITUTC |
| 32554 | C COMMON /USRTC/ ETCLOW(MXUSTC), ETCHGH(MXUSTC), DETCBN(MXUSTC), |
| 32555 | C & VUSRTC(MXUSTC), |
| 32556 | C & IUSTRK(MXUSTC), IUSCLL(MXUSTC), NETCBN(MXUSTC), |
| 32557 | C & NRUSTC(MXUSTC), ITUSTC(MXUSTC), IDUSTC(MXUSTC), |
| 32558 | C & KBUSTC(MXUSTC), IPUSTC(MXUSTC), IGMUTC(MXUSTC), |
| 32559 | C & LLNUTC(MXUSTC), NUSRTC, NUSTRK, NUSCLL, LUSRTC, |
| 32560 | C & LUSTRK, LUSCLL |
| 32561 | C COMMON /USTCH/ TITUTC(MXUSTC) |
| 32562 | ** |
| 32563 | C INCLUDE '(USRYLD)' |
| 32564 | * USRYLD.ADD |
| 32565 | **sr 18.5. commented since not used for evap. |
| 32566 | C PARAMETER ( MXUSYL = 500 ) |
| 32567 | C LOGICAL LUSRYL, LLNUYL, LSCUYL |
| 32568 | C CHARACTER*10 TITUYL |
| 32569 | C COMMON /USRYL/ EYLLOW(MXUSYL), EYLHGH(MXUSYL), DEYLBN(MXUSYL), |
| 32570 | C & USNRYL(MXUSYL), SGUSYL(MXUSYL), AYLLOW(MXUSYL), |
| 32571 | C & AYLHGH(MXUSYL), PUSRYL, UUSRYL, VUSRYL, WUSRYL, |
| 32572 | C & ETXUYL, ETYUYL, ETZUYL, GAMUYL, SQSUYL, UCMUYL, |
| 32573 | C & VCMUYL, WCMUYL, IJUSYL, JTUSYL, |
| 32574 | C & NEYLBN(MXUSYL), NR1UYL(MXUSYL), NR2UYL(MXUSYL), |
| 32575 | C & IXUSYL(MXUSYL), ITUSYL(MXUSYL), IDUSYL(MXUSYL), |
| 32576 | C & KBUSYL(MXUSYL), IPUSYL(MXUSYL), IGMUYL(MXUSYL), |
| 32577 | C & IEUSYL(MXUSYL), IAUSYL(MXUSYL), LLNUYL(MXUSYL), |
| 32578 | C & NUSRYL, LUSRYL, LSCUYL |
| 32579 | C COMMON /USYCH/ TITUYL(MXUSYL) |
| 32580 | ** |
| 32581 | C INCLUDE '(WWINDW)' |
| 32582 | * WWINDW.ADD |
| 32583 | **sr 18.5. commented since not used for evap. |
| 32584 | C PARAMETER ( MXWWSP = 3 ) |
| 32585 | C PARAMETER ( WWSPMX = 50.D+00 ) |
| 32586 | C LOGICAL LWWNDW, LWWPRM |
| 32587 | C COMMON / WWINDW / ETHWW1 (NALLWP), ETHWW2 (NALLWP), |
| 32588 | C & WWEXWD (NALLWP), EXTWWN (NALLWP), |
| 32589 | C & IWLBGN, IWHBGN, IWMBGN, LWWNDW, LWWPRM |
| 32590 | ** |
| 32591 | |
| 32592 | * /blnkcm/ |
| 32593 | * *** If blank common dimension has to be superseded substitute in the |
| 32594 | * *** following two lines the new dimension in real*8 units to Nblnmx |
| 32595 | **sr 18.5. commented since not used for evap. |
| 32596 | C PARAMETER (MXDUMM = KALGNM * NBLNMX) |
| 32597 | C DATA KTMBGN / NBLNMX / |
| 32598 | C DATA MBLNMX / MXDUMM / |
| 32599 | C DATA KBLNKL, KGMBGN, KGMLST, KCMBGN, KCMLST, KISBGN, KISLST, |
| 32600 | C & KDTBGN, KDTLST, KUBBGN, KUBLST, KUXBGN, KUXLST, KTCBGN, |
| 32601 | C & KTCLST, KRNBGN, KRNLST, KYLBGN, KYLLST, KXSBGN, KXSLST, |
| 32602 | C & KIHBGN, KIHLST, KINBGN, KINLST, KIEBGN, KIELST, KETBGN, |
| 32603 | C & KETLST, KRRBGN, KRRLST, KGLBGN, KGLLST, KNABGN, KNALST, |
| 32604 | C & KGDBGN, KGDLST, KDWBGN, KDWLST, KGCBGN, KGCLST, KWLBGN, |
| 32605 | C & KWLLST, KWHBGN, KWHLST, KWMBGN, KWMLST, KWSBGN, KWSLST, |
| 32606 | C & KDPBGN, KDPLST, KRGBGN, KRGLST, KSGBGN, KSGLST, KBRBGN, |
| 32607 | C & KBRLST / 57*0 / |
| 32608 | |
| 32609 | * /blntmp/ |
| 32610 | **sr 18.5. commented since not used for evap. |
| 32611 | C DATA KIHBTM, KINBTM, KIEBTM, KRRBTM, KGLBTM, KNABTM, KGDWTM, |
| 32612 | C & KBDWTM, KGCBTM, KWLOTM, KWHITM, KWMUTM, KWSHTM, KEXTTM, |
| 32613 | C & KSTXTM, KSTNTM, KECTTM, KPCTTM, KLPBTM / 19*0 / |
| 32614 | |
| 32615 | * /cmmdnr/ |
| 32616 | **sr 18.5. commented since not used for evap. |
| 32617 | C DATA DDNEAR / 0.D+00 /, LFLDNR / .FALSE. / |
| 32618 | |
| 32619 | * /ctitle/ |
| 32620 | **sr 18.5. commented since not used for evap. |
| 32621 | C DATA RUNTIT (1:40) / '****************************************' / |
| 32622 | C DATA RUNTIT(41:80) / '****************************************' / |
| 32623 | C DATA ITEXPI, ITEXMX / 100000000, 150 / |
| 32624 | * /detect/ |
| 32625 | **sr 18.5. commented since not used for evap. |
| 32626 | C PARAMETER (NNN1 = NRGNMX*NDTCMX) |
| 32627 | C PARAMETER (NNN2 = NSCRMX*NDTCMX) |
| 32628 | C DATA LDTCTR /.FALSE./, NDTSCO /0/, NDTDET /0/ |
| 32629 | C DATA EDTMIN/NDTCMX*0.D0/, EDTBIN/NDTCMX*0.D0/, EDTCUT/NDTCMX*0.D0/ |
| 32630 | C DATA KDTREG/NNN1*0/, KDTDET/NNN2*0/, KDTSCD/NSCRMX*0/ |
| 32631 | C DATA TITDET/NDTCMX*' '/, TITSCO/NSCRMX*' '/ |
| 32632 | |
| 32633 | * /detloc/ |
| 32634 | **sr 18.5. commented since not used for evap. |
| 32635 | C DATA ACCUMP /NDTCM2*0.D0/, ACCUMN /NDTCM2*0.D0/, ICOINC /NDTCM2*0/ |
| 32636 | C DATA NCLAS /0/ |
| 32637 | |
| 32638 | * /emgtrn/ |
| 32639 | **sr 18.5. commented since not used for evap. |
| 32640 | C DATA LMCSMG / .FALSE. / |
| 32641 | |
| 32642 | * /emsho/ |
| 32643 | **sr 18.5. commented since not used for evap. |
| 32644 | C DATA LIMPRE, LEXPTE / 2 * .FALSE. / |
| 32645 | |
| 32646 | * /episor/ |
| 32647 | **sr 18.5. commented since not used for evap. |
| 32648 | C DATA TKESUM / 0.D+00 /, LUSSRC / .FALSE. / |
| 32649 | |
| 32650 | * /fheavy/ |
| 32651 | DATA AMHEAV / 12 * 0.D+00 / |
| 32652 | DATA ANHEAV / 'NEUTRON ', 'PROTON ', 'DEUTERON', '3-H ', |
| 32653 | & '3-He ', '4-He ', 'H-FRAG-1', 'H-FRAG-2', |
| 32654 | & 'H-FRAG-3', 'H-FRAG-4', 'H-FRAG-5', 'H-FRAG-6'/ |
| 32655 | DATA ICHEAV / 0, 1, 1, 1, 2, 2, 6*0 /, |
| 32656 | & IBHEAV / 1, 1, 2, 3, 3, 4, 6*0 / |
| 32657 | DATA NPHEAV / 0 / |
| 32658 | |
| 32659 | * /finuc/ |
| 32660 | DATA NP / 0 /, TV / 0.D+00 /, TVCMS / 0.D+00 /, TVRECL / 0.D+00/, |
| 32661 | & TVHEAV / 0.D+00 /, TVBIND / 0.D+00 / |
| 32662 | |
| 32663 | * /genthr/ |
| 32664 | * Up to 20-apr-'95 |
| 32665 | * DATA PEANCT, PEAPIT / 2*1.D+00 / |
| 32666 | * DATA PTHRSH / 16*5.D+00,2*2.5D+00,5.D+00,3*2.5D+00,8*5.D+00, |
| 32667 | * & 9*2.5D+00 / |
| 32668 | * DATA PTHDFF / 39*5.D+00 / |
| 32669 | * & 9*2.5D+00 / |
| 32670 | * New values: |
| 32671 | **sr 18.5. commented since not used for evap. |
| 32672 | C DATA PEANCT, PEAPIT / 1.3D+00, 1.1D+00 / |
| 32673 | C DATA PTHRSH / 12*5.D+00, 2*3.5D+00, 2*5.D+00, 2*2.5D+00, 5.D+00, |
| 32674 | C & 3*2.5D+00, 3.5D+00, 2*5.D+00, 3.5D+00, 4*5.D+00, |
| 32675 | C & 9*2.5D+00 / |
| 32676 | C DATA PTHDFF / 12*5.D+00, 2*3.5D+00, 8*5.D+00, 3.5D+00, 2*5.D+00, |
| 32677 | C & 3.5D+00, 13*5.D+00 / |
| 32678 | C DATA PLDNCT / 0.26D+00 / |
| 32679 | C DATA IJNUCR / 16*1, 2*0, 1, 3*0, 8*1, 9*0 / |
| 32680 | |
| 32681 | * /lowneu/ |
| 32682 | **sr 18.5. commented since not used for evap. |
| 32683 | C DATA WWAMFL / 10.D+00 /, EXTWWL / 1.D+00 / |
| 32684 | C DATA IWWLWB, IWWLWT / 2 * 100000000 / |
| 32685 | C DATA ICLMED, INABGN, IDWBGN, IETBGN / 4*0 / |
| 32686 | C DATA IGRTHN / 1 / |
| 32687 | C DATA LIMPRN / .FALSE. /, LBIASN / .FALSE. /, LDOWNN / .FALSE. /, |
| 32688 | C & LLOWWW / .FALSE. /, LLOWET / .FALSE. / |
| 32689 | |
| 32690 | * /ltclcm/ |
| 32691 | **sr 18.5. commented since not used for evap. |
| 32692 | C DATA MLATTC, NEWLAT, MLATLD, MLATM1, MLTSEN, MLTSM1 / 6*0 / |
| 32693 | |
| 32694 | * /mulbou/ |
| 32695 | **sr 18.5. commented since not used for evap. |
| 32696 | C DATA LLDA, LAGAIN, LSTNEW, LARTEF, LSENSE, LNORML, LMGNOR |
| 32697 | C & / 7 * .FALSE. / |
| 32698 | C DATA TSENSE / AINFNT /, NSSENS / -1 / |
| 32699 | C DATA DSMALL / ANGLGB / |
| 32700 | |
| 32701 | * /mulhd/ |
| 32702 | **sr 18.5. commented since not used for evap. |
| 32703 | C DATA LTOPT / MXXMDF * .FALSE. /, NFSCAT / 0 / |
| 32704 | C DATA ESTEPF / MXXMDF * 0.1D+00 / |
| 32705 | C DATA LSRCRH / MXXMDF * .FALSE. /, LNSCRH / MXXMDF * .FALSE. / |
| 32706 | C DATA THMSPR / 0.02D+00 /, THMSSC / 1.D+00 / |
| 32707 | |
| 32708 | * /parevt/ |
| 32709 | DATA DPOWER /-13.D+00 /, FSPRD0 / 0.6D+00 /, FSHPFN / 0.0D+00 /, |
| 32710 | & RN1GSC /-1.0D+00 /, RN2GSC /-1.0D+00 / |
| 32711 | DATA LDIFFR / .TRUE., .TRUE., 6 * .TRUE., .TRUE., 8 * .TRUE., |
| 32712 | & .TRUE., 4 * .TRUE., .TRUE., 3 * .TRUE., |
| 32713 | & 4 * .FALSE., 9 * .TRUE./ |
| 32714 | **sr 17.5.95 |
| 32715 | * default value for LEVPRT changed (reset sr 25.7.97) |
| 32716 | * default value for LHEAVY changed 25.7.97 |
| 32717 | C DATA LPOWER / .TRUE. /, LINCTV / .TRUE. /, LEVPRT / .TRUE. /, |
| 32718 | C & LHEAVY / .FALSE. /, LDEEXG / .TRUE. /, LGDHPR / .TRUE. /, |
| 32719 | C & LPREEX / .TRUE. /, LHLFIX / .FALSE. /, LPRFIX / .FALSE. /, |
| 32720 | C & LPARWV / .TRUE. /, LSNGCH / .TRUE. /, LSCHDF / .TRUE. / |
| 32721 | DATA LPOWER / .TRUE. /, LINCTV / .TRUE. /, LEVPRT / .TRUE. /, |
| 32722 | & LHEAVY / .TRUE. /, LDEEXG / .TRUE. /, LGDHPR / .TRUE. /, |
| 32723 | & LPREEX / .TRUE. /, LHLFIX / .FALSE. /, LPRFIX / .FALSE. /, |
| 32724 | & LPARWV / .TRUE. /, LSNGCH / .TRUE. /, LSCHDF / .TRUE. / |
| 32725 | ** |
| 32726 | **sr 27.5.97 |
| 32727 | * default value for ILVMOD changed |
| 32728 | C DATA ILVMOD / 0 /, JLVMOD / 1 /, LLVMOD / .TRUE. / |
| 32729 | DATA ILVMOD / 1 /, JLVMOD / 1 /, LLVMOD / .TRUE. / |
| 32730 | ** |
| 32731 | |
| 32732 | * /resnuc/ |
| 32733 | DATA IPREEH / 0 /, IPRTRI / 0 /, IPRDEU / 0 /, IPR3HE / 0 /, |
| 32734 | & IPR4HE / 0 / |
| 32735 | DATA IEVAPL / 0 /, IEVAPH / 0 /, IEVNEU / 0 /, IEVPRO / 0 /, |
| 32736 | & IEVTRI / 0 /, IEVDEU / 0 /, IEV3HE / 0 /, IEV4HE / 0 /, |
| 32737 | & IDEEXG / 0 / |
| 32738 | DATA LRNFSS / .FALSE. / |
| 32739 | |
| 32740 | * /scohlp/ |
| 32741 | **sr 18.5. commented since not used for evap. |
| 32742 | C DATA ISCRNG, JSCRNG / 2*0 /, LSCZER / .FALSE. / |
| 32743 | |
| 32744 | * /trackr/ |
| 32745 | **sr 18.5. commented since not used for evap. |
| 32746 | C DATA ETRACK /0.D+00/, WTRACK /0.D+00/, ATRACK /0.D+00/, |
| 32747 | C & CTRACK /0.D+00/, NTRACK /0/, MTRACK /0/, JTRACK /0/ |
| 32748 | |
| 32749 | * /usrbin/ |
| 32750 | **sr 18.5. commented since not used for evap. |
| 32751 | C DATA LUSBIN, LUSEVT, LUSTKB /3*.FALSE./, NUSRBN /0/ |
| 32752 | |
| 32753 | * /usrbdx/ |
| 32754 | **sr 18.5. commented since not used for evap. |
| 32755 | C DATA LUSBDX /.FALSE./, NUSRBX /0/ |
| 32756 | |
| 32757 | * /usrsnc/ |
| 32758 | **sr 18.5. commented since not used for evap. |
| 32759 | C DATA LURSNC /.FALSE./, NURSNC /0/ |
| 32760 | |
| 32761 | * /usrtrc/ |
| 32762 | **sr 18.5. commented since not used for evap. |
| 32763 | C DATA LUSRTC, LUSTRK, LUSCLL / 3*.FALSE. / |
| 32764 | C DATA NUSRTC, NUSTRK, NUSCLL / 3*0 / |
| 32765 | |
| 32766 | * /usryld/ |
| 32767 | **sr 18.5. commented since not used for evap. |
| 32768 | C DATA LUSRYL / .FALSE./, LSCUYL / .FALSE. /, NUSRYL /0/, |
| 32769 | C & IJUSYL /0/, JTUSYL /0/ |
| 32770 | C DATA PUSRYL, UUSRYL, VUSRYL, WUSRYL / 4*ZERZER / |
| 32771 | |
| 32772 | * /wwindw/ |
| 32773 | **sr 18.5. commented since not used for evap. |
| 32774 | C DATA IWLBGN, IWHBGN, IWMBGN / 3*0 / |
| 32775 | C DATA LWWPRM / .TRUE. / |
| 32776 | |
| 32777 | *= end*block.bdnopt * |
| 32778 | END |
| 32779 | |
| 32780 | *$ CREATE DT_BDPREE.FOR |
| 32781 | *COPY DT_BDPREE |
| 32782 | * |
| 32783 | *=== bdpree ===========================================================* |
| 32784 | * |
| 32785 | BLOCK DATA DT_BDPREE |
| 32786 | |
| 32787 | C INCLUDE '(DBLPRC)' |
| 32788 | * DBLPRC.ADD |
| 32789 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 32790 | SAVE |
| 32791 | * (original name: GLOBAL) |
| 32792 | PARAMETER ( KALGNM = 2 ) |
| 32793 | PARAMETER ( ANGLGB = 5.0D-16 ) |
| 32794 | PARAMETER ( ANGLSQ = 2.5D-31 ) |
| 32795 | PARAMETER ( AXCSSV = 0.2D+16 ) |
| 32796 | PARAMETER ( ANDRFL = 1.0D-38 ) |
| 32797 | PARAMETER ( AVRFLW = 1.0D+38 ) |
| 32798 | PARAMETER ( AINFNT = 1.0D+30 ) |
| 32799 | PARAMETER ( AZRZRZ = 1.0D-30 ) |
| 32800 | PARAMETER ( EINFNT = +69.07755278982137 D+00 ) |
| 32801 | PARAMETER ( EZRZRZ = -69.07755278982137 D+00 ) |
| 32802 | PARAMETER ( EXCSSV = +35.23192357547063 D+00 ) |
| 32803 | PARAMETER ( ENGLGB = -35.23192357547063 D+00 ) |
| 32804 | PARAMETER ( ONEMNS = 0.999999999999999 D+00 ) |
| 32805 | PARAMETER ( ONEPLS = 1.000000000000001 D+00 ) |
| 32806 | PARAMETER ( CSNNRM = 2.0D-15 ) |
| 32807 | PARAMETER ( DMXTRN = 1.0D+08 ) |
| 32808 | PARAMETER ( ZERZER = 0.D+00 ) |
| 32809 | PARAMETER ( ONEONE = 1.D+00 ) |
| 32810 | PARAMETER ( TWOTWO = 2.D+00 ) |
| 32811 | PARAMETER ( THRTHR = 3.D+00 ) |
| 32812 | PARAMETER ( FOUFOU = 4.D+00 ) |
| 32813 | PARAMETER ( FIVFIV = 5.D+00 ) |
| 32814 | PARAMETER ( SIXSIX = 6.D+00 ) |
| 32815 | PARAMETER ( SEVSEV = 7.D+00 ) |
| 32816 | PARAMETER ( EIGEIG = 8.D+00 ) |
| 32817 | PARAMETER ( ANINEN = 9.D+00 ) |
| 32818 | PARAMETER ( TENTEN = 10.D+00 ) |
| 32819 | PARAMETER ( HLFHLF = 0.5D+00 ) |
| 32820 | PARAMETER ( ONETHI = ONEONE / THRTHR ) |
| 32821 | PARAMETER ( TWOTHI = TWOTWO / THRTHR ) |
| 32822 | PARAMETER ( ONEFOU = ONEONE / FOUFOU ) |
| 32823 | PARAMETER ( THRTWO = THRTHR / TWOTWO ) |
| 32824 | PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 ) |
| 32825 | PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 ) |
| 32826 | PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 ) |
| 32827 | PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 ) |
| 32828 | PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 ) |
| 32829 | PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 ) |
| 32830 | PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 ) |
| 32831 | PARAMETER ( EULERO = 0.577215664901532860606512 D+00 ) |
| 32832 | PARAMETER ( EULEXP = 1.781072417990197985236504 D+00 ) |
| 32833 | PARAMETER ( EULLOG =-0.5495393129816448223376619 D+00 ) |
| 32834 | PARAMETER ( E1M2EU = 0.8569023337737540831433017 D+00 ) |
| 32835 | PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 ) |
| 32836 | PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 ) |
| 32837 | PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 ) |
| 32838 | PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 ) |
| 32839 | PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 ) |
| 32840 | PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 ) |
| 32841 | PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 ) |
| 32842 | PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 ) |
| 32843 | PARAMETER ( CLIGHT = 2.99792458 D+10 ) |
| 32844 | PARAMETER ( AVOGAD = 6.0221367 D+23 ) |
| 32845 | PARAMETER ( BOLTZM = 1.380658 D-23 ) |
| 32846 | PARAMETER ( AMELGR = 9.1093897 D-28 ) |
| 32847 | PARAMETER ( PLCKBR = 1.05457266 D-27 ) |
| 32848 | PARAMETER ( ELCCGS = 4.8032068 D-10 ) |
| 32849 | PARAMETER ( ELCMKS = 1.60217733 D-19 ) |
| 32850 | PARAMETER ( AMUGRM = 1.6605402 D-24 ) |
| 32851 | PARAMETER ( AMMUMU = 0.113428913 D+00 ) |
| 32852 | PARAMETER ( AMPRMU = 1.007276470 D+00 ) |
| 32853 | PARAMETER ( AMNEMU = 1.008664904 D+00 ) |
| 32854 | PARAMETER ( ALPFSC = 7.2973530791728595 D-03 ) |
| 32855 | PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 ) |
| 32856 | PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 ) |
| 32857 | PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 ) |
| 32858 | PARAMETER ( PLABRC = 0.197327053 D+00 ) |
| 32859 | PARAMETER ( AMELCT = 0.51099906 D-03 ) |
| 32860 | PARAMETER ( AMUGEV = 0.93149432 D+00 ) |
| 32861 | PARAMETER ( AMMUON = 0.105658389 D+00 ) |
| 32862 | PARAMETER ( AMPRTN = 0.93827231 D+00 ) |
| 32863 | PARAMETER ( AMNTRN = 0.93956563 D+00 ) |
| 32864 | PARAMETER ( AMDEUT = 1.87561339 D+00 ) |
| 32865 | PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13 |
| 32866 | & * 1.D-09 ) |
| 32867 | PARAMETER ( RCLSEL = 2.8179409183694872 D-13 ) |
| 32868 | PARAMETER ( BLTZMN = 8.617385 D-14 ) |
| 32869 | PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT ) |
| 32870 | PARAMETER ( GFOHB3 = 1.16639 D-05 ) |
| 32871 | PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC ) |
| 32872 | PARAMETER ( SIN2TW = 0.2319 D+00 ) |
| 32873 | PARAMETER ( GEVMEV = 1.0 D+03 ) |
| 32874 | PARAMETER ( EMVGEV = 1.0 D-03 ) |
| 32875 | PARAMETER ( ALGVMV = 6.90775527898214 D+00 ) |
| 32876 | PARAMETER ( RADDEG = 180.D+00 / PIPIPI ) |
| 32877 | PARAMETER ( DEGRAD = PIPIPI / 180.D+00 ) |
| 32878 | LOGICAL LGBIAS, LGBANA |
| 32879 | COMMON /FKGLOB/ LGBIAS, LGBANA |
| 32880 | C INCLUDE '(DIMPAR)' |
| 32881 | * DIMPAR.ADD |
| 32882 | PARAMETER ( MXXRGN = 5000 ) |
| 32883 | PARAMETER ( MXXMDF = 82 ) |
| 32884 | PARAMETER ( MXXMDE = 54 ) |
| 32885 | PARAMETER ( MFSTCK = 1000 ) |
| 32886 | PARAMETER ( MESTCK = 100 ) |
| 32887 | PARAMETER ( NALLWP = 39 ) |
| 32888 | PARAMETER ( NELEMX = 80 ) |
| 32889 | PARAMETER ( MPDPDX = 8 ) |
| 32890 | PARAMETER ( ICOMAX = 180 ) |
| 32891 | PARAMETER ( NSTBIS = 304 ) |
| 32892 | PARAMETER ( IDMAXP = 220 ) |
| 32893 | PARAMETER ( IDMXDC = 640 ) |
| 32894 | PARAMETER ( MKBMX1 = 1 ) |
| 32895 | PARAMETER ( MKBMX2 = 1 ) |
| 32896 | C INCLUDE '(IOUNIT)' |
| 32897 | * IOUNIT.ADD |
| 32898 | PARAMETER ( LUNIN = 5 ) |
| 32899 | PARAMETER ( LUNOUT = 6 ) |
| 32900 | **sr 19.5. set error output-unit from 15 to 6 |
| 32901 | PARAMETER ( LUNERR = 6 ) |
| 32902 | PARAMETER ( LUNBER = 14 ) |
| 32903 | PARAMETER ( LUNECH = 8 ) |
| 32904 | PARAMETER ( LUNFLU = 13 ) |
| 32905 | PARAMETER ( LUNGEO = 16 ) |
| 32906 | PARAMETER ( LUNPMF = 12 ) |
| 32907 | PARAMETER ( LUNRAN = 2 ) |
| 32908 | PARAMETER ( LUNXSC = 9 ) |
| 32909 | PARAMETER ( LUNDET = 17 ) |
| 32910 | PARAMETER ( LUNRAY = 10 ) |
| 32911 | PARAMETER ( LUNRDB = 1 ) |
| 32912 | PARAMETER ( LUNPGO = 7 ) |
| 32913 | PARAMETER ( LUNPGS = 4 ) |
| 32914 | PARAMETER ( LUNSCR = 3 ) |
| 32915 | * |
| 32916 | *----------------------------------------------------------------------* |
| 32917 | * * |
| 32918 | * Created on 16 september 1991 by Alfredo Ferrari & Paola Sala * |
| 32919 | * Infn - Milan * |
| 32920 | * * |
| 32921 | * Last change on 03-feb-94 by Alfredo Ferrari * |
| 32922 | * * |
| 32923 | * * |
| 32924 | *----------------------------------------------------------------------* |
| 32925 | * |
| 32926 | * (original name: CMPISG,CHPISG) |
| 32927 | PARAMETER ( TPPPI0 = 0.279656044337515D+00 ) |
| 32928 | PARAMETER ( TNNPI0 = 0.279642680857450D+00 ) |
| 32929 | PARAMETER ( TPPPIP = 0.292295207182790D+00 ) |
| 32930 | PARAMETER ( TPPDEP = 0.287514778898469D+00 ) |
| 32931 | PARAMETER ( TNNPIM = 0.286723140900975D+00 ) |
| 32932 | PARAMETER ( TNNDEM = 0.281949292916434D+00 ) |
| 32933 | PARAMETER ( TPNPI0 = 0.279456888147740D+00 ) |
| 32934 | PARAMETER ( TPNDE0 = 0.274693916135245D+00 ) |
| 32935 | PARAMETER ( TPNPIP = 0.292086756473890D+00 ) |
| 32936 | PARAMETER ( TNPPI0 = 0.279842093144975D+00 ) |
| 32937 | PARAMETER ( TNPDE0 = 0.275072555824202D+00 ) |
| 32938 | PARAMETER ( TNPPIP = 0.292489370554958D+00 ) |
| 32939 | PARAMETER ( PIRSMX = 1.2D+00 ) |
| 32940 | PARAMETER ( NPIREA = 10 ) |
| 32941 | PARAMETER ( NPIRTA = 68 ) |
| 32942 | PARAMETER ( NPIRLN = 21 ) |
| 32943 | PARAMETER ( NPIRLG = NPIRTA - NPIRLN ) |
| 32944 | PARAMETER ( NPISIS = NPIRLN + 20 ) |
| 32945 | PARAMETER ( NPISEX = NPIRLN + 21 ) |
| 32946 | PARAMETER ( NPIIMN = 14 ) |
| 32947 | PARAMETER ( NPIIRC = 6 ) |
| 32948 | PARAMETER ( DELWLL = 0.035D+00 ) |
| 32949 | CHARACTER CHPIRE*8 |
| 32950 | LOGICAL LDLRES |
| 32951 | COMMON /FKCMPI/ PMNPIS, PMMPIS, PISPIS, PEXPIS, PMXPIS, DPPISG, |
| 32952 | & RTPISG, AMNPIS, AMMPIS, AISPIS, AEXPIS, AMXPIS, |
| 32953 | & ARPISG, BPISLO (NPIRLN:NPIRTA,NPIREA), |
| 32954 | & CPISLO (NPIRLN:NPIRTA,NPIREA), PPITHR (NPIREA), |
| 32955 | & SPISLO (NPIRLN:NPIRTA,NPIREA), APITHR (NPIREA), |
| 32956 | & SGPIIN (NPIIMN:NPIRTA,NPIIRC), RHPICR (1:5) , |
| 32957 | & SGPICU (0:20,NPIRTA,NPIREA) , SGRTRS (NPIREA), |
| 32958 | & SGPIDF (0:20,NPIRTA,NPIREA) , BRREIN (NPIREA), |
| 32959 | & SGPIIS (NPIRTA,NPIREA) , BRREOU (NPIREA), |
| 32960 | & BRD3OU (2,2,-1:2), BRDEOU (2,-1:2), |
| 32961 | & SGABSR (2,2,4) , PRRSDL, |
| 32962 | & IPIREA (2,2,3:5) , IPIINE (2,3:5) , NPIRVR , |
| 32963 | & KPIIRE (2,NPIREA), KPIORE (2,NPIREA) , |
| 32964 | & JSTOKP (5), KPTOJS (23), ITTRRS (3:5), LDLRES |
| 32965 | COMMON /FKCHPI/ CHPIRE (NPIREA) |
| 32966 | DIMENSION SG2BRS (2,2), SGABSW (2,2), SG3BRS (2,2,2) |
| 32967 | EQUIVALENCE ( SG2BRS (1,1), SGABSR (1,1,1) ) |
| 32968 | EQUIVALENCE ( SGABSW (1,1), SGABSR (1,1,2) ) |
| 32969 | EQUIVALENCE ( SG3BRS (1,1,1), SGABSR (1,1,3) ) |
| 32970 | * (original name: FRBKCM) |
| 32971 | PARAMETER ( MXFFBK = 6 ) |
| 32972 | PARAMETER ( MXZFBK = 9 ) |
| 32973 | PARAMETER ( MXNFBK = 10 ) |
| 32974 | PARAMETER ( MXAFBK = 16 ) |
| 32975 | PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 ) |
| 32976 | PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 ) |
| 32977 | PARAMETER ( NXAFBK = MXAFBK + 1 ) |
| 32978 | PARAMETER ( MXPSST = 300 ) |
| 32979 | PARAMETER ( MXPSFB = 41000 ) |
| 32980 | LOGICAL LFRMBK, LNCMSS |
| 32981 | COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST), |
| 32982 | & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB), |
| 32983 | & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK, |
| 32984 | & IFRBKN (MXPSST), IFRBKZ (MXPSST), |
| 32985 | & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST), |
| 32986 | & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK), |
| 32987 | & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK), |
| 32988 | & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF, |
| 32989 | & IFBFRB, NBUFBK, LFRMBK, LNCMSS |
| 32990 | * (original name: NUCGID,NUCGEO,NUCGE2,NUCPWI,NUCGII) |
| 32991 | PARAMETER ( PI = PIPIPI ) |
| 32992 | PARAMETER ( PISQ = PIPISQ ) |
| 32993 | PARAMETER ( SKTOHL = 0.5456645846610345D+00 ) |
| 32994 | PARAMETER ( RZNUCL = 1.12 D+00 ) |
| 32995 | PARAMETER ( RMSPRO = 0.8 D+00 ) |
| 32996 | PARAMETER ( R0PROT = RMSPRO / SQRT12 ) |
| 32997 | PARAMETER ( ARHPRO = 1.D+00 / 8.D+00 / PI / R0PROT / R0PROT |
| 32998 | & / R0PROT ) |
| 32999 | PARAMETER ( RLLE04 = RZNUCL ) |
| 33000 | PARAMETER ( RLLE16 = RZNUCL ) |
| 33001 | PARAMETER ( RLGT16 = RZNUCL ) |
| 33002 | PARAMETER ( RCLE04 = 0.75D+00 / PI / RLLE04 / RLLE04 / RLLE04 ) |
| 33003 | PARAMETER ( RCLE16 = 0.75D+00 / PI / RLLE16 / RLLE16 / RLLE16 ) |
| 33004 | PARAMETER ( RCGT16 = 0.75D+00 / PI / RLGT16 / RLGT16 / RLGT16 ) |
| 33005 | PARAMETER ( SKLE04 = 1.4D+00 ) |
| 33006 | PARAMETER ( SKLE16 = 1.9D+00 ) |
| 33007 | PARAMETER ( SKGT16 = 2.4D+00 ) |
| 33008 | PARAMETER ( HLLE04 = SKTOHL * SKLE04 ) |
| 33009 | PARAMETER ( HLLE16 = SKTOHL * SKLE16 ) |
| 33010 | PARAMETER ( HLGT16 = SKTOHL * SKGT16 ) |
| 33011 | PARAMETER ( ALPHA0 = 0.1D+00 ) |
| 33012 | PARAMETER ( OMALH0 = 1.D+00 - ALPHA0 ) |
| 33013 | PARAMETER ( GAMSK0 = 0.9D+00 ) |
| 33014 | PARAMETER ( OMGAS0 = 1.D+00 - GAMSK0 ) |
| 33015 | PARAMETER ( POTME0 = 0.6666666666666667D+00 ) |
| 33016 | PARAMETER ( POTBA0 = 1.D+00 ) |
| 33017 | PARAMETER ( PNFRAT = 1.533D+00 ) |
| 33018 | PARAMETER ( RADPIM = 0.035D+00 ) |
| 33019 | PARAMETER ( RDPMHL = 14.D+00 ) |
| 33020 | PARAMETER ( APMRST = 4.D+00 / 44.D+00 ) |
| 33021 | PARAMETER ( APMPRO = 1.D+00 / 6.D+00 ) |
| 33022 | PARAMETER ( APPPRO = 5.D+00 / 6.D+00 ) |
| 33023 | PARAMETER ( AP0PFS = 0.5D+00 ) |
| 33024 | PARAMETER ( AP0PFP = 1.D+00 / 3.D+00 ) |
| 33025 | PARAMETER ( AP0NFP = 2.D+00 / 3.D+00 ) |
| 33026 | PARAMETER ( XPAUCO = 1.88495407241652 D+00 ) |
| 33027 | PARAMETER ( MXSCIN = 50 ) |
| 33028 | LOGICAL LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH, LNCDCY, |
| 33029 | & LNUSCT, LPREEQ, LNPHTC, LNWRAD, LPNRHO, LFTCMP, LFTCAC |
| 33030 | COMMON /FKNGID/ RHOTAB (2:260), RHATAB (2:260), ALPTAB (2:260), |
| 33031 | & RADTAB (2:260), SKITAB (2:260), HALTAB (2:260), |
| 33032 | & SK3TAB (2:260), SK4TAB (2:260), HABTAB (2:260), |
| 33033 | & CWSTAB (2:260), EKATAB (2:260), PFATAB (2:260), |
| 33034 | & PFRTAB (2:260) |
| 33035 | COMMON /FKNGEO/ RADTOT, RADIU1, RADIU0, RAD1O2, SKINDP, HALODP, |
| 33036 | & ALPHAL, OMALHL, RADSKN, SKNEFF, CPARWS, RADPRO, |
| 33037 | & RADCOR, RADCO2, RADMAX, BIMPTR, RIMPTR, XIMPTR, |
| 33038 | & YIMPTR, ZIMPTR, RHOIMT, EKFPRO, PFRPRO, RHOCEN, |
| 33039 | & RHOCOR, RHOSKN, EKFCEN (2), PFRCEN (2), EKFBIM, |
| 33040 | & PFRBIM, RHOIMP, EKFIMP, PFRIMP, RHOIM2, EKFIM2, |
| 33041 | & PFRIM2, RHOIM3, EKFIM3, PFRIM3, VPRWLL, RIMPCT, |
| 33042 | & BIMPCT, XIMPCT, YIMPCT, ZIMPCT, RIMPC2, XIMPC2, |
| 33043 | & YIMPC2, ZIMPC2, RIMPC3, XIMPC3, YIMPC3, ZIMPC3, |
| 33044 | & XBIMPC, YBIMPC, ZBIMPC, CXIMPC, CYIMPC, CZIMPC, |
| 33045 | & SQRIMP, SIGMAP, SIGMAN, SIGMAA, RHORED, R0TRAJ, |
| 33046 | & R1TRAJ, SBUSED, SBTOT , SBRES , RHOAVE, EKFAVE, |
| 33047 | & PFRAVE, AVEBIN, ACOLL , ZCOLL , RADSIG, OPACTY, |
| 33048 | & EKECON, PNUCCO, EKEWLL, PPRWLL, PXPROJ, PYPROJ, |
| 33049 | & PZPROJ, EKFERM, PNFRMI, PXFERM, PYFERM, PZFERM, |
| 33050 | & EKFER2, PNFRM2, PXFER2, PYFER2, PZFER2, EKFER3, |
| 33051 | & PNFRM3, PXFER3, PYFER3, PZFER3, RHOMEM, EKFMEM, |
| 33052 | & BIMMEM, WLLRED, VPRBIM, POTINC, POTOUT, EEXMIN |
| 33053 | COMMON /FKNGE2/ RDTTNC (2), RHONCP (2), RHONC2 (2), RHONC3 (2), |
| 33054 | & RHONCT (2), AMOTHR, EKOTHR, AMCREA, EKNCLN, |
| 33055 | & EEXDEL, EEXANY, CLMBBR, RDCLMB, BFCLMB, BFCEFF, |
| 33056 | & BNPROJ, BNDNUC, DEBRLM, SK4PAR, UBIMPC, VBIMPC, |
| 33057 | & WBIMPC, BNDPOT, SIGMAT, SIGABP, SIGABN, WLLRES, |
| 33058 | & POTBAR, POTMES, AGEPRI, OPNOPA, ETHRND, |
| 33059 | & BNENRG (3), DEFNUC (2), SIGMPR (4), SIGMNU (4), |
| 33060 | & SIGPAB (3), SIGNAB (3), HHLP (2), FORTOT (2), |
| 33061 | & FPNBLC, DPNBLC, FFTFLG, IFTFLG, |
| 33062 | & IPWELL, ITNCMX, KPRIN , NTARGT, KNUCIM, KNUCI2, |
| 33063 | & KNUCI3, IEVPRE, ISFCOL, ISFTAR, ISFTA2, ISFTA3, |
| 33064 | & NPOTHR, ICOTHR, IBOTHR, NPUMFN, ISTNCL, ITAUCM, |
| 33065 | & IABCOU, IADFLG, IGSFLG, IALFLG, ICBFLG, LPREEQ, |
| 33066 | & LNPHTC, LPNRHO, LNWRAD, LFTCMP, LFTCAC |
| 33067 | COMMON /FKNPWI/ ALMBAR, BIMMAX, SIGGEO, LLLMAX, LLLACT |
| 33068 | COMMON /FKNGII/ HOLEXP (2*MXSCIN), XEXPIN (3,0:MXSCIN), |
| 33069 | & YEXPIN (3,0:MXSCIN), ZEXPIN (3,0:MXSCIN), |
| 33070 | & AGEXIN (0:MXSCIN), RHOEXP (2), EKFEXP, EHLFIX, |
| 33071 | & NHLEXP, NHLFIX, IPRTYP, NNCEXI (0:MXSCIN), |
| 33072 | & NCEXPI (3,0:MXSCIN), ISEXIN (3,0:MXSCIN), |
| 33073 | & ISCTYP (0:MXSCIN), NUSCIN, NEXPEM, |
| 33074 | & LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH, |
| 33075 | & LNCDCY, LNUSCT |
| 33076 | DIMENSION AWSTAB (2:260), SIGMAB (3) |
| 33077 | EQUIVALENCE ( DEFPRO, DEFNUC (1) ) |
| 33078 | EQUIVALENCE ( DEFNEU, DEFNUC (2) ) |
| 33079 | EQUIVALENCE ( RHOIPP, RHONCP (1) ) |
| 33080 | EQUIVALENCE ( RHOINP, RHONCP (2) ) |
| 33081 | EQUIVALENCE ( RHOIP2, RHONC2 (1) ) |
| 33082 | EQUIVALENCE ( RHOIN2, RHONC2 (2) ) |
| 33083 | EQUIVALENCE ( RHOIP3, RHONC3 (1) ) |
| 33084 | EQUIVALENCE ( RHOIN3, RHONC3 (2) ) |
| 33085 | EQUIVALENCE ( RHOIPT, RHONCT (1) ) |
| 33086 | EQUIVALENCE ( RHOINT, RHONCT (2) ) |
| 33087 | EQUIVALENCE ( OMALHL, SK3PAR ) |
| 33088 | EQUIVALENCE ( ALPHAL, HABPAR ) |
| 33089 | EQUIVALENCE ( ALPTAB (2), AWSTAB (2) ) |
| 33090 | EQUIVALENCE ( SIGMPE, SIGMPR (1) ) |
| 33091 | EQUIVALENCE ( SIGMPC, SIGMPR (2) ) |
| 33092 | EQUIVALENCE ( SIGMPI, SIGMPR (3) ) |
| 33093 | EQUIVALENCE ( SIGMPA, SIGMPR (4) ) |
| 33094 | EQUIVALENCE ( SIGMNE, SIGMNU (1) ) |
| 33095 | EQUIVALENCE ( SIGMNC, SIGMNU (2) ) |
| 33096 | EQUIVALENCE ( SIGMNI, SIGMNU (3) ) |
| 33097 | EQUIVALENCE ( SIGMNA, SIGMNU (4) ) |
| 33098 | EQUIVALENCE ( SIGMA2, SIGPAB (1) ) |
| 33099 | EQUIVALENCE ( SIGMA3, SIGPAB (2) ) |
| 33100 | EQUIVALENCE ( SIGMAS, SIGPAB (3) ) |
| 33101 | EQUIVALENCE ( SIGPAB (1), SIGMAB (1) ) |
| 33102 | * (original name: NUCLEV) |
| 33103 | LOGICAL LCLVSL, LFLVSL, LRLVSL, LEQSBL |
| 33104 | COMMON /FKNLEV/ PAENUC (200,2), SHENUC (200,2), DEFRMI (2), |
| 33105 | & DEFMAG (2), ENNCLV (160,2), RANCLV (160,2), |
| 33106 | & CUMRAD (0:160,2), RUSNUC (2), |
| 33107 | & ENPLVL (114), ENNLVL(164), JUSNUC (160,2), |
| 33108 | & NTANUC (2), NAVNUC (2), NLSNUC (2), NCONUC (2), |
| 33109 | & NSKNUC (2), NHANUC (2), NUSNUC (2), NACNUC (2), |
| 33110 | & JMXNUC (2), IPRNUC (3), JPRNUC (3), MAGNUM (8), |
| 33111 | & MAGNUC (2), MGSNUC (8,2), MGSSNC (25,2), |
| 33112 | & NSBSHL (2), NMNSBS (2), NPRNUC, INUCLV, LCLVSL, |
| 33113 | & LFLVSL, LRLVSL, LEQSBL |
| 33114 | DIMENSION JUSPRO (160), JUSNEU (160), MGSPRO (8), MGSNEU (8), |
| 33115 | & MGSSPR (19) , MGSSNE (25) |
| 33116 | EQUIVALENCE ( RUSNUC (1), RUSPRO ) |
| 33117 | EQUIVALENCE ( RUSNUC (2), RUSNEU ) |
| 33118 | EQUIVALENCE ( JUSNUC (1,1), JUSPRO (1) ) |
| 33119 | EQUIVALENCE ( JUSNUC (1,2), JUSNEU (1) ) |
| 33120 | EQUIVALENCE ( MGSNUC (1,1), MGSPRO (1) ) |
| 33121 | EQUIVALENCE ( MGSNUC (1,2), MGSNEU (1) ) |
| 33122 | EQUIVALENCE ( MGSSNC (1,1), MGSSPR (1) ) |
| 33123 | EQUIVALENCE ( MGSSNC (1,2), MGSSNE (1) ) |
| 33124 | EQUIVALENCE ( NTANUC (1), NTAPRO ) |
| 33125 | EQUIVALENCE ( NTANUC (2), NTANEU ) |
| 33126 | EQUIVALENCE ( NAVNUC (1), NAVPRO ) |
| 33127 | EQUIVALENCE ( NAVNUC (2), NAVNEU ) |
| 33128 | EQUIVALENCE ( NLSNUC (1), NLSPRO ) |
| 33129 | EQUIVALENCE ( NLSNUC (2), NLSNEU ) |
| 33130 | EQUIVALENCE ( NCONUC (1), NCOPRO ) |
| 33131 | EQUIVALENCE ( NCONUC (2), NCONEU ) |
| 33132 | EQUIVALENCE ( NSKNUC (1), NSKPRO ) |
| 33133 | EQUIVALENCE ( NSKNUC (2), NSKNEU ) |
| 33134 | EQUIVALENCE ( NHANUC (1), NHAPRO ) |
| 33135 | EQUIVALENCE ( NHANUC (2), NHANEU ) |
| 33136 | EQUIVALENCE ( NUSNUC (1), NUSPRO ) |
| 33137 | EQUIVALENCE ( NUSNUC (2), NUSNEU ) |
| 33138 | EQUIVALENCE ( NACNUC (1), NACPRO ) |
| 33139 | EQUIVALENCE ( NACNUC (2), NACNEU ) |
| 33140 | EQUIVALENCE ( JMXNUC (1), JMXPRO ) |
| 33141 | EQUIVALENCE ( JMXNUC (2), JMXNEU ) |
| 33142 | EQUIVALENCE ( MAGNUC (1), MAGPRO ) |
| 33143 | EQUIVALENCE ( MAGNUC (2), MAGNEU ) |
| 33144 | * (original name: PARNUC) |
| 33145 | PARAMETER ( PIGRK = PIPIPI ) |
| 33146 | PARAMETER ( ALEVEL = 8.D-03 ) |
| 33147 | PARAMETER ( RCNUCL = 1.12D+00 ) |
| 33148 | PARAMETER ( R0SIG = 1.3D+00 ) |
| 33149 | PARAMETER ( R0SIGK = 1.5D+00 ) |
| 33150 | PARAMETER ( RCOULB = 1.5D+00 ) |
| 33151 | PARAMETER ( COULBH = 0.88235D-03 ) |
| 33152 | PARAMETER ( RHONU0 = 0.75D+00 / PIGRK / RCNUCL / RCNUCL / RCNUCL ) |
| 33153 | PARAMETER ( TAUFO0 = 10.0D+00 ) |
| 33154 | PARAMETER ( EKEEXP = 0.03D+00 ) |
| 33155 | PARAMETER ( EKREXP = 0.05D+00 ) |
| 33156 | PARAMETER ( EKEMNM = 0.01D+00 ) |
| 33157 | PARAMETER ( NCPMX = 120 ) |
| 33158 | COMMON /FKPARN/ EKORI , PXORI , PYORI , PZORI , PTORI , TAUFOR, |
| 33159 | & ENNUC (NCPMX), PNUCL (NCPMX), EKFNUC (NCPMX), |
| 33160 | & XSTNUC (NCPMX), YSTNUC (NCPMX), ZSTNUC (NCPMX), |
| 33161 | & PXNUCL (NCPMX), PYNUCL (NCPMX), PZNUCL (NCPMX), |
| 33162 | & RSTNUC (NCPMX), FREEPA (NCPMX), CRRPAN (NCPMX), |
| 33163 | & CRRPAP (NCPMX), BSTNUC (NCPMX), AGENUC (NCPMX), |
| 33164 | & TAUFPA (NCPMX), RHNUCL(NCPMX,2), BNDGAV, DEFMIN, |
| 33165 | & KPNUCL (NCPMX), KRFNUC (NCPMX), ILINUC (NCPMX), |
| 33166 | & INUCTS (NCPMX), ISFNUC (NCPMX), KPORI , IBORI , |
| 33167 | & IBNUCL, NPNUC , NNUCTS |
| 33168 | * |
| 33169 | DATA LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH / 6*.FALSE. / |
| 33170 | DATA POTBAR / POTBA0 /, POTMES / POTME0 /, WLLRES / 0.D+00 / |
| 33171 | DATA JUSNUC / 320 * 0 /, INUCLV / 1 /, IEVPRE / 0 / |
| 33172 | DATA MAGNUM / 2, 8, 20, 28, 50, 82, 126, 160 / |
| 33173 | DATA LPREEQ / .FALSE. / |
| 33174 | * /cmpisg/ |
| 33175 | DATA JSTOKP / 1, 8, 13, 14, 23 / |
| 33176 | DATA KPTOJS / 1, 6*0, 2, 4*0, 3, 4, 8*0, 5 / |
| 33177 | DATA CHPIRE / 'PI+PPI+P','PI-PPI-P','PI-PPI0N','PI0PPI0P', |
| 33178 | & 'PI0PPI+N','PI-NPI-N','PI+NPI+N','PI+NPI0P', |
| 33179 | & 'PI0NPI0N','PI0NPI-P' / |
| 33180 | DATA KPIIRE / 13, 1, 14, 1, 14, 1, 23, 1, 23, 1, 14, 8, |
| 33181 | & 13, 8, 13, 8, 23, 8, 23, 8 / |
| 33182 | DATA KPIORE / 13, 1, 14, 1, 23, 8, 23, 1, 13, 8, 14, 8, |
| 33183 | & 13, 8, 23, 1, 23, 8, 14, 1 / |
| 33184 | DATA IPIREA / 1, 0, 7, 8, 2, 3, 6, 0, 4, 5, 9, 10 / |
| 33185 | DATA IPIINE / 1, 2, 3, 4, 5, 6 / |
| 33186 | * /frbkcm/ |
| 33187 | DATA LFRMBK / .FALSE. / |
| 33188 | DATA NBUFBK / 500 / |
| 33189 | DATA EXMXFB / 80.0 D+00 / |
| 33190 | DATA R0FRBK / 1.18 D+00 / |
| 33191 | DATA R0CFBK / 2.173D+00 / |
| 33192 | DATA C1CFBK / 6.103D-03 / |
| 33193 | DATA C2CFBK / 9.443D-03 / |
| 33194 | * /parnuc/ |
| 33195 | DATA TAUFOR / TAUFO0 / |
| 33196 | *=== End of Block Data Bdpree =========================================* |
| 33197 | END |
| 33198 | |
| 33199 | *$ CREATE DT_XHOINI.FOR |
| 33200 | *COPY DT_XHOINI |
| 33201 | * |
| 33202 | *====phoini============================================================* |
| 33203 | * |
| 33204 | SUBROUTINE DT_XHOINI |
| 33205 | C SUBROUTINE DT_PHOINI |
| 33206 | |
| 33207 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 33208 | SAVE |
| 33209 | PARAMETER ( LINP = 10 , |
| 33210 | & LOUT = 6 , |
| 33211 | & LDAT = 9 ) |
| 33212 | |
| 33213 | RETURN |
| 33214 | END |
| 33215 | |
| 33216 | *$ CREATE DT_XVENTB.FOR |
| 33217 | *COPY DT_XVENTB |
| 33218 | * |
| 33219 | *====eventb============================================================* |
| 33220 | * |
| 33221 | SUBROUTINE DT_XVENTB(NCSY,IREJ) |
| 33222 | C SUBROUTINE DT_EVENTB(NCSY,IREJ) |
| 33223 | |
| 33224 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 33225 | SAVE |
| 33226 | PARAMETER ( LINP = 10 , |
| 33227 | & LOUT = 6 , |
| 33228 | & LDAT = 9 ) |
| 33229 | |
| 33230 | WRITE(LOUT,1000) |
| 33231 | 1000 FORMAT(1X,'EVENTB: PHOJET-package requested but not linked!') |
| 33232 | STOP |
| 33233 | |
| 33234 | END |
| 33235 | |
| 33236 | *$ CREATE DT_XVENT.FOR |
| 33237 | *COPY DT_XVENT |
| 33238 | * |
| 33239 | *===event==============================================================* |
| 33240 | * |
| 33241 | SUBROUTINE DT_XVENT(IDUM,PP,PT,DUM,IREJ) |
| 33242 | C SUBROUTINE EVENT(IDUM,PP,PT,DUM,IREJ) |
| 33243 | |
| 33244 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 33245 | SAVE |
| 33246 | |
| 33247 | DIMENSION PP(4),PT(4) |
| 33248 | |
| 33249 | RETURN |
| 33250 | END |
| 33251 | |
| 33252 | *$ CREATE DT_XOHISX.FOR |
| 33253 | *COPY DT_XOHISX |
| 33254 | * |
| 33255 | *===pohisx=============================================================* |
| 33256 | * |
| 33257 | SUBROUTINE DT_XOHISX(I,X) |
| 33258 | C SUBROUTINE POHISX(I,X) |
| 33259 | |
| 33260 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 33261 | SAVE |
| 33262 | |
| 33263 | RETURN |
| 33264 | END |
| 33265 | |
| 33266 | *$ CREATE PHO_LHIST.FOR |
| 33267 | *COPY PHO_LHIST |
| 33268 | * |
| 33269 | *===poluhi=============================================================* |
| 33270 | * |
| 33271 | SUBROUTINE PHO_LHIST(I,X) |
| 33272 | ** |
| 33273 | |
| 33274 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 33275 | SAVE |
| 33276 | |
| 33277 | RETURN |
| 33278 | END |
| 33279 | |
| 33280 | *$ CREATE PDFSET.FOR |
| 33281 | *COPY PDFSET |
| 33282 | * |
| 33283 | C********************************************************************** |
| 33284 | C |
| 33285 | C dummy subroutines, remove to link PDFLIB |
| 33286 | C |
| 33287 | C********************************************************************** |
| 33288 | SUBROUTINE PDFSET(PARAM,VALUE) |
| 33289 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 33290 | DIMENSION PARAM(20),VALUE(20) |
| 33291 | CHARACTER*20 PARAM |
| 33292 | END |
| 33293 | |
| 33294 | *$ CREATE STRUCTM.FOR |
| 33295 | *COPY STRUCTM |
| 33296 | * |
| 33297 | SUBROUTINE STRUCTM(XI,SCALE2,UV,DV,US,DS,SS,CS,BS,TS,GL) |
| 33298 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 33299 | END |
| 33300 | |
| 33301 | *$ CREATE STRUCTP.FOR |
| 33302 | *COPY STRUCTP |
| 33303 | * |
| 33304 | SUBROUTINE STRUCTP(XI,SCALE2,P2,IP2,UV,DV,US,DS,SS,CS,BS,TS,GL) |
| 33305 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 33306 | END |
| 33307 | |
| 33308 | *$ CREATE DT_DIQBRK.FOR |
| 33309 | *COPY DT_DIQBRK |
| 33310 | * |
| 33311 | *===diqbrk=============================================================* |
| 33312 | * |
| 33313 | SUBROUTINE DT_XIQBRK |
| 33314 | C SUBROUTINE DT_DIQBRK |
| 33315 | |
| 33316 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 33317 | SAVE |
| 33318 | |
| 33319 | STOP 'diquark-breaking not implemeted !' |
| 33320 | |
| 33321 | RETURN |
| 33322 | END |
| 33323 | |
| 33324 | *$ CREATE DT_ELHAIN.FOR |
| 33325 | *COPY DT_ELHAIN |
| 33326 | * |
| 33327 | *===elhain=============================================================* |
| 33328 | * |
| 33329 | SUBROUTINE DT_ELHAIN(IP,PLA,ELAB,CX,CY,CZ,IT,IREJ) |
| 33330 | |
| 33331 | ************************************************************************ |
| 33332 | * Elastic hadron-hadron scattering. * |
| 33333 | * This is a revised version of the original. * |
| 33334 | * This version dated 03.04.98 is written by S. Roesler * |
| 33335 | ************************************************************************ |
| 33336 | |
| 33337 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 33338 | SAVE |
| 33339 | PARAMETER ( LINP = 10 , |
| 33340 | & LOUT = 6 , |
| 33341 | & LDAT = 9 ) |
| 33342 | PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0, |
| 33343 | & TINY10=1.0D-10) |
| 33344 | |
| 33345 | PARAMETER (ENNTHR = 3.5D0) |
| 33346 | PARAMETER (PLOWH=0.01D0,PHIH=9.0D0, |
| 33347 | & BLOWB=0.05D0,BHIB=0.2D0, |
| 33348 | & BLOWM=0.1D0, BHIM=2.0D0) |
| 33349 | |
| 33350 | * particle properties (BAMJET index convention) |
| 33351 | CHARACTER*8 ANAME |
| 33352 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 33353 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 33354 | * final state from HADRIN interaction |
| 33355 | PARAMETER (MAXFIN=10) |
| 33356 | COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN), |
| 33357 | & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH |
| 33358 | |
| 33359 | C DATA TSLOPE /10.0D0/ |
| 33360 | |
| 33361 | IREJ = 0 |
| 33362 | |
| 33363 | 1 CONTINUE |
| 33364 | |
| 33365 | PLAB = SQRT( (ELAB-AAM(IP))*(ELAB+AAM(IP)) ) |
| 33366 | EKIN = ELAB-AAM(IP) |
| 33367 | * kinematical quantities in cms of the hadrons |
| 33368 | AMP2 = AAM(IP)**2 |
| 33369 | AMT2 = AAM(IT)**2 |
| 33370 | S = AMP2+AMT2+TWO*ELAB*AAM(IT) |
| 33371 | ECM = SQRT(S) |
| 33372 | ECMP = OHALF*ECM+(AMP2-AMT2)/(TWO*ECM) |
| 33373 | PCM = SQRT( (ECMP-AAM(IP))*(ECMP+AAM(IP)) ) |
| 33374 | |
| 33375 | * nucleon-nucleon scattering at E_kin<3.5: use DT_TSAMCS(HETC-KFA) |
| 33376 | IF ( ((IP.EQ.1).OR.(IP.EQ.8)).AND. |
| 33377 | & ((IT.EQ.1).OR.(IT.EQ.8)).AND.(EKIN.LT.ENNTHR) ) THEN |
| 33378 | * TSAMCS treats pp and np only, therefore change pn into np and |
| 33379 | * nn into pp |
| 33380 | IF (IT.EQ.1) THEN |
| 33381 | KPROJ = IP |
| 33382 | ELSE |
| 33383 | KPROJ = 8 |
| 33384 | IF (IP.EQ.8) KPROJ = 1 |
| 33385 | ENDIF |
| 33386 | CALL DT_TSAMCS(KPROJ,EKIN,CTCMS) |
| 33387 | T = TWO*PCM**2*(CTCMS-ONE) |
| 33388 | |
| 33389 | * very crude treatment otherwise: sample t from exponential dist. |
| 33390 | ELSE |
| 33391 | * momentum transfer t |
| 33392 | TMAX = TWO*TWO*PCM**2 |
| 33393 | RR = (PLAB-PLOWH)/(PHIH-PLOWH) |
| 33394 | IF (IIBAR(IP).NE.0) THEN |
| 33395 | TSLOPE = BLOWB+RR*(BHIB-BLOWB) |
| 33396 | ELSE |
| 33397 | TSLOPE = BLOWM+RR*(BHIM-BLOWM) |
| 33398 | ENDIF |
| 33399 | FMAX = EXP(-TSLOPE*TMAX)-ONE |
| 33400 | R = DT_RNDM(RR) |
| 33401 | T = LOG(ONE+R*FMAX+TINY10)/TSLOPE |
| 33402 | IF (T.GT.ZERO) T = LOG(ONE+R*FMAX)/TSLOPE |
| 33403 | ENDIF |
| 33404 | |
| 33405 | * target hadron in Lab after scattering |
| 33406 | ELRH(2) = (TWO*AMT2-T)/(TWO*AAM(IT)) |
| 33407 | PLRH(2) = SQRT( ABS(ELRH(2)-AAM(IT))*(ELRH(2)+AAM(IT)) ) |
| 33408 | IF (PLRH(2).LE.TINY10) THEN |
| 33409 | C WRITE(*,*)'ELHAIN: T,PLRH(2) ',T,PLRH(2) |
| 33410 | GOTO 1 |
| 33411 | ENDIF |
| 33412 | * projectile hadron in Lab after scattering |
| 33413 | ELRH(1) = ELAB+AAM(IT)-ELRH(2) |
| 33414 | PLRH(1) = SQRT( ABS(ELRH(1)-AAM(IP))*(ELRH(1)+AAM(IP)) ) |
| 33415 | * scattering angle of projectile in Lab |
| 33416 | CTLABP = (T-TWO*AMP2+TWO*ELAB*ELRH(1))/(TWO*PLAB*PLRH(1)) |
| 33417 | STLABP = SQRT( (ONE-CTLABP)*(ONE+CTLABP) ) |
| 33418 | CALL DT_DSFECF(SPLABP,CPLABP) |
| 33419 | * direction cosines of projectile in Lab |
| 33420 | CALL DT_STTRAN(CX,CY,CZ,CTLABP,STLABP,SPLABP,CPLABP, |
| 33421 | & CXRH(1),CYRH(1),CZRH(1)) |
| 33422 | * scattering angle of target in Lab |
| 33423 | PLLABT = PLAB-CTLABP*PLRH(1) |
| 33424 | CTLABT = PLLABT/PLRH(2) |
| 33425 | STLABT = SQRT( (ONE-CTLABT)*(ONE+CTLABT) ) |
| 33426 | * direction cosines of target in Lab |
| 33427 | CALL DT_STTRAN(CX,CY,CZ,CTLABT,STLABT,-SPLABP,-CPLABP, |
| 33428 | & CXRH(2),CYRH(2),CZRH(2)) |
| 33429 | * fill /HNFSPA/ |
| 33430 | IRH = 2 |
| 33431 | ITRH(1) = IP |
| 33432 | ITRH(2) = IT |
| 33433 | |
| 33434 | RETURN |
| 33435 | END |
| 33436 | |
| 33437 | *$ CREATE DT_TSAMCS.FOR |
| 33438 | *COPY DT_TSAMCS |
| 33439 | * |
| 33440 | *===tsamcs=============================================================* |
| 33441 | * |
| 33442 | SUBROUTINE DT_TSAMCS(KPROJ,EKIN,CST) |
| 33443 | |
| 33444 | ************************************************************************ |
| 33445 | * Sampling of cos(theta) for nucleon-proton scattering according to * |
| 33446 | * hetkfa2/bertini parametrization. * |
| 33447 | * This is a revised version of the original (HJM 24/10/88) * |
| 33448 | * This version dated 28.10.95 is written by S. Roesler * |
| 33449 | ************************************************************************ |
| 33450 | |
| 33451 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 33452 | SAVE |
| 33453 | PARAMETER ( LINP = 10 , |
| 33454 | & LOUT = 6 , |
| 33455 | & LDAT = 9 ) |
| 33456 | PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0, |
| 33457 | & TINY10=1.0D-10) |
| 33458 | |
| 33459 | DIMENSION DCLIN(195),DCHN(143),DCHNA(36),DCHNB(60) |
| 33460 | DIMENSION PDCI(60),PDCH(55) |
| 33461 | |
| 33462 | DATA (DCLIN(I),I=1,80) / |
| 33463 | & 5.000D-01, 1.000D+00, 0.000D+00, 1.000D+00, 0.000D+00, |
| 33464 | & 4.993D-01, 9.881D-01, 5.963D-02, 9.851D-01, 5.945D-02, |
| 33465 | & 4.936D-01, 8.955D-01, 5.224D-01, 8.727D-01, 5.091D-01, |
| 33466 | & 4.889D-01, 8.228D-01, 8.859D-01, 7.871D-01, 8.518D-01, |
| 33467 | & 4.874D-01, 7.580D-01, 1.210D+00, 7.207D-01, 1.117D+00, |
| 33468 | & 4.912D-01, 6.969D-01, 1.516D+00, 6.728D-01, 1.309D+00, |
| 33469 | & 5.075D-01, 6.471D-01, 1.765D+00, 6.667D-01, 1.333D+00, |
| 33470 | & 5.383D-01, 6.054D-01, 1.973D+00, 7.059D-01, 1.176D+00, |
| 33471 | & 5.397D-01, 5.990D-01, 2.005D+00, 7.023D-01, 1.191D+00, |
| 33472 | & 5.336D-01, 6.083D-01, 1.958D+00, 6.959D-01, 1.216D+00, |
| 33473 | & 5.317D-01, 6.075D-01, 1.962D+00, 6.897D-01, 1.241D+00, |
| 33474 | & 5.300D-01, 6.016D-01, 1.992D+00, 6.786D-01, 1.286D+00, |
| 33475 | & 5.281D-01, 6.063D-01, 1.969D+00, 6.786D-01, 1.286D+00, |
| 33476 | & 5.280D-01, 5.960D-01, 2.020D+00, 6.667D-01, 1.333D+00, |
| 33477 | & 5.273D-01, 5.920D-01, 2.040D+00, 6.604D-01, 1.358D+00, |
| 33478 | & 5.273D-01, 5.862D-01, 2.069D+00, 6.538D-01, 1.385D+00/ |
| 33479 | DATA (DCLIN(I),I=81,160) / |
| 33480 | & 5.223D-01, 5.980D-01, 2.814D+00, 6.538D-01, 1.385D+00, |
| 33481 | & 5.202D-01, 5.969D-01, 2.822D+00, 6.471D-01, 1.412D+00, |
| 33482 | & 5.183D-01, 5.881D-01, 2.883D+00, 6.327D-01, 1.469D+00, |
| 33483 | & 5.159D-01, 5.866D-01, 2.894D+00, 6.250D-01, 1.500D+00, |
| 33484 | & 5.133D-01, 5.850D-01, 2.905D+00, 6.170D-01, 1.532D+00, |
| 33485 | & 5.106D-01, 5.833D-01, 2.917D+00, 6.087D-01, 1.565D+00, |
| 33486 | & 5.084D-01, 5.801D-01, 2.939D+00, 6.000D-01, 1.600D+00, |
| 33487 | & 5.063D-01, 5.763D-01, 2.966D+00, 5.909D-01, 1.636D+00, |
| 33488 | & 5.036D-01, 5.730D-01, 2.989D+00, 5.814D-01, 1.674D+00, |
| 33489 | & 5.014D-01, 5.683D-01, 3.022D+00, 5.714D-01, 1.714D+00, |
| 33490 | & 4.986D-01, 5.641D-01, 3.051D+00, 5.610D-01, 1.756D+00, |
| 33491 | & 4.964D-01, 5.580D-01, 3.094D+00, 5.500D-01, 1.800D+00, |
| 33492 | & 4.936D-01, 5.573D-01, 3.099D+00, 5.431D-01, 1.827D+00, |
| 33493 | & 4.909D-01, 5.509D-01, 3.144D+00, 5.313D-01, 1.875D+00, |
| 33494 | & 4.885D-01, 5.512D-01, 3.142D+00, 5.263D-01, 1.895D+00, |
| 33495 | & 4.857D-01, 5.437D-01, 3.194D+00, 5.135D-01, 1.946D+00/ |
| 33496 | DATA (DCLIN(I),I=161,195) / |
| 33497 | & 4.830D-01, 5.353D-01, 3.253D+00, 5.000D-01, 2.000D+00, |
| 33498 | & 4.801D-01, 5.323D-01, 3.274D+00, 4.915D-01, 2.034D+00, |
| 33499 | & 4.770D-01, 5.228D-01, 3.341D+00, 4.767D-01, 2.093D+00, |
| 33500 | & 4.738D-01, 5.156D-01, 3.391D+00, 4.643D-01, 2.143D+00, |
| 33501 | & 4.701D-01, 5.010D-01, 3.493D+00, 4.444D-01, 2.222D+00, |
| 33502 | & 4.672D-01, 4.990D-01, 3.507D+00, 4.375D-01, 2.250D+00, |
| 33503 | & 4.634D-01, 4.856D-01, 3.601D+00, 4.194D-01, 2.323D+00/ |
| 33504 | |
| 33505 | DATA PDCI / |
| 33506 | & 4.400D+02, 1.896D-01, 1.931D-01, 1.982D-01, 1.015D-01, |
| 33507 | & 1.029D-01, 4.180D-02, 4.228D-02, 4.282D-02, 4.350D-02, |
| 33508 | & 2.204D-02, 2.236D-02, 5.900D+02, 1.433D-01, 1.555D-01, |
| 33509 | & 1.774D-01, 1.000D-01, 1.128D-01, 5.132D-02, 5.600D-02, |
| 33510 | & 6.158D-02, 6.796D-02, 3.660D-02, 3.820D-02, 6.500D+02, |
| 33511 | & 1.192D-01, 1.334D-01, 1.620D-01, 9.527D-02, 1.141D-01, |
| 33512 | & 5.283D-02, 5.952D-02, 6.765D-02, 7.878D-02, 4.796D-02, |
| 33513 | & 6.957D-02, 8.000D+02, 4.872D-02, 6.694D-02, 1.152D-01, |
| 33514 | & 9.348D-02, 1.368D-01, 6.912D-02, 7.953D-02, 9.577D-02, |
| 33515 | & 1.222D-01, 7.755D-02, 9.525D-02, 1.000D+03, 3.997D-02, |
| 33516 | & 5.456D-02, 9.804D-02, 8.084D-02, 1.208D-01, 6.520D-02, |
| 33517 | & 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02, 1.093D-01/ |
| 33518 | |
| 33519 | DATA PDCH / |
| 33520 | & 1.000D+03, 9.453D-02, 9.804D-02, 8.084D-02, 1.208D-01, |
| 33521 | & 6.520D-02, 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02, |
| 33522 | & 1.093D-01, 1.400D+03, 1.072D-01, 7.450D-02, 6.645D-02, |
| 33523 | & 1.136D-01, 6.750D-02, 8.580D-02, 1.110D-01, 1.530D-01, |
| 33524 | & 1.010D-01, 1.350D-01, 2.170D+03, 4.004D-02, 3.013D-02, |
| 33525 | & 2.664D-02, 5.511D-02, 4.240D-02, 7.660D-02, 1.364D-01, |
| 33526 | & 2.300D-01, 1.670D-01, 2.010D-01, 2.900D+03, 1.870D-02, |
| 33527 | & 1.804D-02, 1.320D-02, 2.970D-02, 2.860D-02, 5.160D-02, |
| 33528 | & 1.020D-01, 2.400D-01, 2.250D-01, 3.370D-01, 4.400D+03, |
| 33529 | & 1.196D-03, 8.784D-03, 1.517D-02, 2.874D-02, 2.488D-02, |
| 33530 | & 4.464D-02, 8.330D-02, 2.008D-01, 2.360D-01, 3.567D-01/ |
| 33531 | |
| 33532 | DATA (DCHN(I),I=1,90) / |
| 33533 | & 4.770D-01, 4.750D-01, 4.715D-01, 4.685D-01, 4.650D-01, |
| 33534 | & 4.610D-01, 4.570D-01, 4.550D-01, 4.500D-01, 4.450D-01, |
| 33535 | & 4.405D-01, 4.350D-01, 4.300D-01, 4.250D-01, 4.200D-01, |
| 33536 | & 4.130D-01, 4.060D-01, 4.000D-01, 3.915D-01, 3.840D-01, |
| 33537 | & 3.760D-01, 3.675D-01, 3.580D-01, 3.500D-01, 3.400D-01, |
| 33538 | & 3.300D-01, 3.200D-01, 3.100D-01, 3.000D-01, 2.900D-01, |
| 33539 | & 2.800D-01, 2.700D-01, 2.600D-01, 2.500D-01, 2.400D-01, |
| 33540 | & 2.315D-01, 2.240D-01, 2.150D-01, 2.060D-01, 2.000D-01, |
| 33541 | & 1.915D-01, 1.850D-01, 1.780D-01, 1.720D-01, 1.660D-01, |
| 33542 | & 1.600D-01, 1.550D-01, 1.500D-01, 1.450D-01, 1.400D-01, |
| 33543 | & 1.360D-01, 1.320D-01, 1.280D-01, 1.250D-01, 1.210D-01, |
| 33544 | & 1.180D-01, 1.150D-01, 1.120D-01, 1.100D-01, 1.070D-01, |
| 33545 | & 1.050D-01, 1.030D-01, 1.010D-01, 9.900D-02, 9.700D-02, |
| 33546 | & 9.550D-02, 9.480D-02, 9.400D-02, 9.200D-02, 9.150D-02, |
| 33547 | & 9.100D-02, 9.000D-02, 8.990D-02, 8.900D-02, 8.850D-02, |
| 33548 | & 8.750D-02, 8.700D-02, 8.650D-02, 8.550D-02, 8.500D-02, |
| 33549 | & 8.499D-02, 8.450D-02, 8.350D-02, 8.300D-02, 8.250D-02, |
| 33550 | & 8.150D-02, 8.100D-02, 8.030D-02, 8.000D-02, 7.990D-02/ |
| 33551 | DATA (DCHN(I),I=91,143) / |
| 33552 | & 7.980D-02, 7.950D-02, 7.900D-02, 7.860D-02, 7.800D-02, |
| 33553 | & 7.750D-02, 7.650D-02, 7.620D-02, 7.600D-02, 7.550D-02, |
| 33554 | & 7.530D-02, 7.500D-02, 7.499D-02, 7.498D-02, 7.480D-02, |
| 33555 | & 7.450D-02, 7.400D-02, 7.350D-02, 7.300D-02, 7.250D-02, |
| 33556 | & 7.230D-02, 7.200D-02, 7.100D-02, 7.050D-02, 7.020D-02, |
| 33557 | & 7.000D-02, 6.999D-02, 6.995D-02, 6.993D-02, 6.991D-02, |
| 33558 | & 6.990D-02, 6.870D-02, 6.850D-02, 6.800D-02, 6.780D-02, |
| 33559 | & 6.750D-02, 6.700D-02, 6.650D-02, 6.630D-02, 6.600D-02, |
| 33560 | & 6.550D-02, 6.525D-02, 6.510D-02, 6.500D-02, 6.499D-02, |
| 33561 | & 6.498D-02, 6.496D-02, 6.494D-02, 6.493D-02, 6.490D-02, |
| 33562 | & 6.488D-02, 6.485D-02, 6.480D-02/ |
| 33563 | |
| 33564 | DATA DCHNA / |
| 33565 | & 6.300D+02, 7.810D-02, 1.421D-01, 1.979D-01, 2.479D-01, |
| 33566 | & 3.360D-01, 5.400D-01, 7.236D-01, 1.000D+00, 1.540D+03, |
| 33567 | & 2.225D-01, 3.950D-01, 5.279D-01, 6.298D-01, 7.718D-01, |
| 33568 | & 9.405D-01, 9.835D-01, 1.000D+00, 2.560D+03, 2.625D-01, |
| 33569 | & 4.550D-01, 5.963D-01, 7.020D-01, 8.380D-01, 9.603D-01, |
| 33570 | & 9.903D-01, 1.000D+00, 3.520D+03, 4.250D-01, 6.875D-01, |
| 33571 | & 8.363D-01, 9.163D-01, 9.828D-01, 1.000D+00, 1.000D+00, |
| 33572 | & 1.000D+00/ |
| 33573 | |
| 33574 | DATA DCHNB / |
| 33575 | & 6.300D+02, 3.800D-02, 7.164D-02, 1.275D-01, 2.171D-01, |
| 33576 | & 3.227D-01, 4.091D-01, 5.051D-01, 6.061D-01, 7.074D-01, |
| 33577 | & 8.434D-01, 1.000D+00, 2.040D+03, 1.200D-01, 2.115D-01, |
| 33578 | & 3.395D-01, 5.295D-01, 7.251D-01, 8.511D-01, 9.487D-01, |
| 33579 | & 9.987D-01, 1.000D+00, 1.000D+00, 1.000D+00, 2.200D+03, |
| 33580 | & 1.344D-01, 2.324D-01, 3.754D-01, 5.674D-01, 7.624D-01, |
| 33581 | & 8.896D-01, 9.808D-01, 1.000D+00, 1.000D+00, 1.000D+00, |
| 33582 | & 1.000D+00, 2.850D+03, 2.330D-01, 4.130D-01, 6.610D-01, |
| 33583 | & 9.010D-01, 9.970D-01, 1.000D+00, 1.000D+00, 1.000D+00, |
| 33584 | & 1.000D+00, 1.000D+00, 1.000D+00, 3.500D+03, 3.300D-01, |
| 33585 | & 5.450D-01, 7.950D-01, 1.000D+00, 1.000D+00, 1.000D+00, |
| 33586 | & 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00/ |
| 33587 | |
| 33588 | CST = ONE |
| 33589 | IF (EKIN.GT.3.5D0) RETURN |
| 33590 | C |
| 33591 | IF(KPROJ.EQ.8) GOTO 101 |
| 33592 | IF(KPROJ.EQ.1) GOTO 102 |
| 33593 | C* INVALID REACTION |
| 33594 | WRITE(LOUT,'(A,I5/A)') |
| 33595 | & ' INVALID PARTICLE TYPE IN DNUPRE - KPROJ=',KPROJ, |
| 33596 | & ' COS(THETA) = 1D0 RETURNED' |
| 33597 | RETURN |
| 33598 | C-------------------------------- NP ELASTIC SCATTERING---------- |
| 33599 | 101 CONTINUE |
| 33600 | IF (EKIN.GT.0.740D0)GOTO 1000 |
| 33601 | IF (EKIN.LT.0.300D0)THEN |
| 33602 | C EKIN .LT. 300 MEV |
| 33603 | IDAT=1 |
| 33604 | ELSE |
| 33605 | C 300 MEV < EKIN < 740 MEV |
| 33606 | IDAT=6 |
| 33607 | END IF |
| 33608 | C |
| 33609 | ENER=EKIN |
| 33610 | IE=INT(ABS(ENER/0.020D0)) |
| 33611 | UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0 |
| 33612 | C FORWARD/BACKWARD DECISION |
| 33613 | K=IDAT+5*IE |
| 33614 | BWFW=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K) |
| 33615 | IF (DT_RNDM(CST).LT.BWFW)THEN |
| 33616 | VALUE2=-1D0 |
| 33617 | K=K+1 |
| 33618 | ELSE |
| 33619 | VALUE2=1D0 |
| 33620 | K=K+3 |
| 33621 | END IF |
| 33622 | C |
| 33623 | COEF=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K) |
| 33624 | RND=DT_RNDM(COEF) |
| 33625 | C |
| 33626 | IF(RND.LT.COEF)THEN |
| 33627 | CST=DT_RNDM(RND) |
| 33628 | CST=CST*VALUE2 |
| 33629 | ELSE |
| 33630 | R1=DT_RNDM(CST) |
| 33631 | R2=DT_RNDM(R1) |
| 33632 | R3=DT_RNDM(R2) |
| 33633 | R4=DT_RNDM(R3) |
| 33634 | C |
| 33635 | IF(VALUE2.GT.0.0)THEN |
| 33636 | CST=MAX(R1,R2,R3,R4) |
| 33637 | GOTO 1500 |
| 33638 | ELSE |
| 33639 | R5=DT_RNDM(R4) |
| 33640 | C |
| 33641 | IF (IDAT.EQ.1)THEN |
| 33642 | CST=-MAX(R1,R2,R3,R4,R5) |
| 33643 | ELSE |
| 33644 | R6=DT_RNDM(R5) |
| 33645 | R7=DT_RNDM(R6) |
| 33646 | CST=-MAX(R1,R2,R3,R4,R5,R6,R7) |
| 33647 | END IF |
| 33648 | C |
| 33649 | END IF |
| 33650 | C |
| 33651 | END IF |
| 33652 | C |
| 33653 | GOTO 1500 |
| 33654 | C |
| 33655 | C******** EKIN .GT. 0.74 GEV |
| 33656 | C |
| 33657 | 1000 ENER=EKIN - 0.66D0 |
| 33658 | C IE=ABS(ENER/0.02) |
| 33659 | IE=INT(ENER/0.02D0) |
| 33660 | EMEV=EKIN*1D3 |
| 33661 | C |
| 33662 | UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0 |
| 33663 | K=IE |
| 33664 | BWFW=(DCHN(K+1)-DCHN(K))*UNIV + DCHN(K) |
| 33665 | RND=DT_RNDM(BWFW) |
| 33666 | C FORWARD NEUTRON |
| 33667 | IF (RND.GE.BWFW)THEN |
| 33668 | DO 1200 K=10,36,9 |
| 33669 | IF (DCHNA(K).GT.EMEV) THEN |
| 33670 | UNIVE=(EMEV-DCHNA(K-9))/(DCHNA(K)-DCHNA(K-9)) |
| 33671 | UNIV=DT_RNDM(UNIVE) |
| 33672 | DO 1100 I=1,8 |
| 33673 | II=K+I |
| 33674 | P=(DCHNA(II)-DCHNA(II-9))*UNIVE + DCHNA(II-9) |
| 33675 | C |
| 33676 | IF (P.GT.UNIV)THEN |
| 33677 | UNIV=DT_RNDM(UNIVE) |
| 33678 | FLTI=DBLE(I)-UNIV |
| 33679 | GOTO(290,290,290,290,330,340,350,360) I |
| 33680 | END IF |
| 33681 | 1100 CONTINUE |
| 33682 | END IF |
| 33683 | 1200 CONTINUE |
| 33684 | C |
| 33685 | ELSE |
| 33686 | C BACKWARD NEUTRON |
| 33687 | DO 1400 K=13,60,12 |
| 33688 | IF (DCHNB(K).GT.EMEV) THEN |
| 33689 | UNIVE=(EMEV-DCHNB(K-12))/(DCHNB(K)-DCHNB(K-12)) |
| 33690 | UNIV=DT_RNDM(UNIVE) |
| 33691 | DO 1300 I=1,11 |
| 33692 | II=K+I |
| 33693 | P=(DCHNB(II)-DCHNB(II-12))*UNIVE + DCHNB(II-12) |
| 33694 | C |
| 33695 | IF (P.GT.UNIV)THEN |
| 33696 | UNIV=DT_RNDM(P) |
| 33697 | FLTI=DBLE(I)-UNIV |
| 33698 | GOTO(120,120,140,150,160,160,180,190,200,210,220) I |
| 33699 | END IF |
| 33700 | 1300 CONTINUE |
| 33701 | END IF |
| 33702 | 1400 CONTINUE |
| 33703 | END IF |
| 33704 | C |
| 33705 | 120 CST=1.0D-2*FLTI-1.0D0 |
| 33706 | GOTO 1500 |
| 33707 | 140 CST=2.0D-2*UNIV-0.98D0 |
| 33708 | GOTO 1500 |
| 33709 | 150 CST=4.0D-2*UNIV-0.96D0 |
| 33710 | GOTO 1500 |
| 33711 | 160 CST=6.0D-2*FLTI-1.16D0 |
| 33712 | GOTO 1500 |
| 33713 | 180 CST=8.0D-2*UNIV-0.80D0 |
| 33714 | GOTO 1500 |
| 33715 | 190 CST=1.0D-1*UNIV-0.72D0 |
| 33716 | GOTO 1500 |
| 33717 | 200 CST=1.2D-1*UNIV-0.62D0 |
| 33718 | GOTO 1500 |
| 33719 | 210 CST=2.0D-1*UNIV-0.50D0 |
| 33720 | GOTO 1500 |
| 33721 | 220 CST=3.0D-1*(UNIV-1.0D0) |
| 33722 | GOTO 1500 |
| 33723 | C |
| 33724 | 290 CST=1.0D0-2.5d-2*FLTI |
| 33725 | GOTO 1500 |
| 33726 | 330 CST=0.85D0+0.5D-1*UNIV |
| 33727 | GOTO 1500 |
| 33728 | 340 CST=0.70D0+1.5D-1*UNIV |
| 33729 | GOTO 1500 |
| 33730 | 350 CST=0.50D0+2.0D-1*UNIV |
| 33731 | GOTO 1500 |
| 33732 | 360 CST=0.50D0*UNIV |
| 33733 | C |
| 33734 | 1500 RETURN |
| 33735 | C |
| 33736 | C----------------------------------- PP ELASTIC SCATTERING ------- |
| 33737 | C |
| 33738 | 102 CONTINUE |
| 33739 | EMEV=EKIN*1D3 |
| 33740 | C |
| 33741 | IF (EKIN.LE.0.500D0) THEN |
| 33742 | RND=DT_RNDM(EMEV) |
| 33743 | CST=2.0D0*RND-1.0D0 |
| 33744 | RETURN |
| 33745 | C |
| 33746 | ELSEIF (EKIN.LT.1.0D0) THEN |
| 33747 | DO 2200 K=13,60,12 |
| 33748 | IF (PDCI(K).GT.EMEV) THEN |
| 33749 | UNIVE=(EMEV-PDCI(K-12))/(PDCI(K)-PDCI(K-12)) |
| 33750 | UNIV=DT_RNDM(UNIVE) |
| 33751 | SUM=0 |
| 33752 | DO 2100 I=1,11 |
| 33753 | II=K+I |
| 33754 | SUM=SUM + (PDCI(II)-PDCI(II-12))*UNIVE + PDCI(II-12) |
| 33755 | C |
| 33756 | IF (UNIV.LT.SUM)THEN |
| 33757 | UNIV=DT_RNDM(SUM) |
| 33758 | FLTI=DBLE(I)-UNIV |
| 33759 | GOTO(55,55,55,60,60,65,65,65,65,70,70) I |
| 33760 | END IF |
| 33761 | 2100 CONTINUE |
| 33762 | END IF |
| 33763 | 2200 CONTINUE |
| 33764 | ELSE |
| 33765 | DO 2400 K=12,55,11 |
| 33766 | IF (PDCH(K).GT.EMEV) THEN |
| 33767 | UNIVE=(EMEV-PDCH(K-11))/(PDCH(K)-PDCH(K-11)) |
| 33768 | UNIV=DT_RNDM(UNIVE) |
| 33769 | SUM=0.0D0 |
| 33770 | DO 2300 I=1,10 |
| 33771 | II=K+I |
| 33772 | SUM=SUM + (PDCH(II)-PDCH(II-11))*UNIVE + PDCH(II-11) |
| 33773 | C |
| 33774 | IF (UNIV.LT.SUM)THEN |
| 33775 | UNIV=DT_RNDM(SUM) |
| 33776 | FLTI=UNIV+DBLE(I) |
| 33777 | GOTO(50,55,60,60,65,65,65,65,70,70) I |
| 33778 | END IF |
| 33779 | 2300 CONTINUE |
| 33780 | END IF |
| 33781 | 2400 CONTINUE |
| 33782 | END IF |
| 33783 | C |
| 33784 | 50 CST=0.4D0*UNIV |
| 33785 | GOTO 2500 |
| 33786 | 55 CST=0.2D0*FLTI |
| 33787 | GOTO 2500 |
| 33788 | 60 CST=0.3D0+0.1D0*FLTI |
| 33789 | GOTO 2500 |
| 33790 | 65 CST=0.6D0+0.04D0*FLTI |
| 33791 | GOTO 2500 |
| 33792 | 70 CST=0.78D0+0.02D0*FLTI |
| 33793 | C |
| 33794 | 2500 CONTINUE |
| 33795 | IF (DT_RNDM(CST).GT.0.5D0) CST=-CST |
| 33796 | C |
| 33797 | RETURN |
| 33798 | END |
| 33799 | |
| 33800 | *$ CREATE DT_DHADRI.FOR |
| 33801 | *COPY DT_DHADRI |
| 33802 | * |
| 33803 | *===dhadri=============================================================* |
| 33804 | * |
| 33805 | SUBROUTINE DT_DHADRI(N,PLAB,ELAB,CX,CY,CZ,ITTA) |
| 33806 | |
| 33807 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 33808 | SAVE |
| 33809 | |
| 33810 | PARAMETER ( LINP = 10 , |
| 33811 | & LOUT = 6 , |
| 33812 | & LDAT = 9 ) |
| 33813 | C |
| 33814 | C----------------------------- |
| 33815 | C*** INPUT VARIABLES LIST: |
| 33816 | C*** SAMPLING OF HADRON NUCLEON INTERACTION FOR (ABOUT) 0.1 LE PLAB LE 6 |
| 33817 | C*** GEV/C LABORATORY MOMENTUM REGION |
| 33818 | C*** N - PROJECTILE HADRON INDEX |
| 33819 | C*** PLAB - LABORATORY MOMENTUM OF N (GEV/C) |
| 33820 | C*** ELAB - LABORATORY ENERGY OF N (GEV) |
| 33821 | C*** CX,CY,CZ - DIRECTION COSINES OF N IN THE LABORATORY SYSTEM |
| 33822 | C*** ITTA - TARGET NUCLEON INDEX |
| 33823 | C*** OUTPUT VARIABLES LIST OF PARTICLE CHARACTERISTICS IN /FINLSP/ |
| 33824 | C IR COUNTS THE NUMBER OF PRODUCED PARTICLES |
| 33825 | C*** ITR - PARTICLE INDEX, CXR,CYR,CZR - DIRECTION COSINES (LAB. SYST.) |
| 33826 | C*** ELR,PLR LAB. ENERGY AND LAB. MOMENTUM OF THE SAMPLED PARTICLE |
| 33827 | C*** RESPECT., UNITS (GEV/C AND GEV) |
| 33828 | C---------------------------- |
| 33829 | |
| 33830 | COMMON /HNGAMR/ REDU,AMO,AMM(15) |
| 33831 | COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17) |
| 33832 | COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184), |
| 33833 | & NRK(2,268),NURE(30,2) |
| 33834 | * particle properties (BAMJET index convention), |
| 33835 | * (dublicate of DTPART for HADRIN) |
| 33836 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), |
| 33837 | & K1H(110),K2H(110) |
| 33838 | COMMON /HNSPLI/ WTI(460),NZKI(460,3) |
| 33839 | COMMON /HNMETL/ CXS(149),CYS(149),CZS(149),ELS(149),PLS(149), |
| 33840 | & ITS(149),IS |
| 33841 | COMMON /HNDRUN/ RUNTES,EFTES |
| 33842 | * particle properties (BAMJET index convention) |
| 33843 | CHARACTER*8 ANAME |
| 33844 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 33845 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 33846 | * final state from HADRIN interaction |
| 33847 | PARAMETER (MAXFIN=10) |
| 33848 | COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN), |
| 33849 | & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH |
| 33850 | |
| 33851 | DIMENSION ITPRF(110) |
| 33852 | DATA NNN/0/ |
| 33853 | DATA UMODA/0./ |
| 33854 | DATA ITPRF/-1,-1,5*1,-1,-1,1,1,1,-1,-1,-1,-1,6*1,-1,-1,-1,85*1/ |
| 33855 | LOWP=0 |
| 33856 | IF (N.LE.0.OR.N.GE.111)N=1 |
| 33857 | IF (ITPRF( N ).GT.0 .OR. ITTA.GT.8) THEN |
| 33858 | GOTO 280 |
| 33859 | * WRITE (6,1000) |
| 33860 | * + ' FALSE USE OF THE PARTICLE TYPE INDEX: N, ITTA', N, ITTA |
| 33861 | * STOP |
| 33862 | *1000 FORMAT (3(5H ****/),A,2I4,3(5H ****/)) |
| 33863 | * + 45H FALSE USE OF THE PARTICLE TYPE INDEX, N,LUE ,I4,3(5H ****/)) |
| 33864 | ENDIF |
| 33865 | IATMPT=0 |
| 33866 | IF (ABS(PLAB-5.0D0).LT.4.99999D0) GO TO 20 |
| 33867 | C IF(IPRI.GE.1) WRITE (6,1010) PLAB |
| 33868 | C STOP |
| 33869 | 1010 FORMAT ( ' PROJECTILE HADRON MOMENTUM OUTSIDE OF THE |
| 33870 | + ALLOWED REGION, PLAB=',1E15.5) |
| 33871 | |
| 33872 | 20 CONTINUE |
| 33873 | UMODAT=N*1.11111D0+ITTA*2.19291D0 |
| 33874 | IF(UMODAT.NE.UMODA) CALL DT_DCALUM(N,ITTA) |
| 33875 | UMODA=UMODAT |
| 33876 | 30 IATMPT=0 |
| 33877 | LOWP=LOWP+1 |
| 33878 | 40 CONTINUE |
| 33879 | IMACH=0 |
| 33880 | REDU=2.0D0 |
| 33881 | IF (LOWP.GT.20) THEN |
| 33882 | C WRITE(LOUT,*) ' jump 1' |
| 33883 | GO TO 280 |
| 33884 | ENDIF |
| 33885 | NNN=N |
| 33886 | IF (NNN.EQ.N) GO TO 50 |
| 33887 | RUNTES=0.0D0 |
| 33888 | EFTES=0.0D0 |
| 33889 | 50 CONTINUE |
| 33890 | IS=1 |
| 33891 | IRH=0 |
| 33892 | IST=1 |
| 33893 | NSTAB=23 |
| 33894 | IRE=NURE(N,1) |
| 33895 | IF(ITTA.GT.1) IRE=NURE(N,2) |
| 33896 | C |
| 33897 | C----------------------------- |
| 33898 | C*** IE,AMT,ECM,SI DETERMINATION |
| 33899 | C---------------------------- |
| 33900 | CALL DT_DSIGIN(IRE,PLAB,N,IE,AMT ,AMN,ECM,SI,ITTA) |
| 33901 | IANTH=-1 |
| 33902 | **sr |
| 33903 | C IF (AMH(1).NE.0.93828D0) IANTH=1 |
| 33904 | IF (AMH(1).NE.0.9383D0) IANTH=1 |
| 33905 | ** |
| 33906 | IF (IANTH.GE.0) SI=1.0D0 |
| 33907 | ECMMH=ECM |
| 33908 | C |
| 33909 | C----------------------------- |
| 33910 | C ENERGY INDEX |
| 33911 | C IRE CHARACTERIZES THE REACTION |
| 33912 | C IE IS THE ENERGY INDEX |
| 33913 | C---------------------------- |
| 33914 | IF (SI.LT.1.D-6) THEN |
| 33915 | C WRITE(LOUT,*) ' jump 2' |
| 33916 | GO TO 280 |
| 33917 | ENDIF |
| 33918 | IF (N.LE.NSTAB) GO TO 60 |
| 33919 | RUNTES=RUNTES+1.0D0 |
| 33920 | IF (RUNTES.LT.20.D0) WRITE(LOUT,1020)N |
| 33921 | 1020 FORMAT(3H N=,I10,30H THE PROEKTILE IS A RESONANCE ) |
| 33922 | IF(IBARH(N).EQ.1) N=8 |
| 33923 | IF(IBARH(N).EQ.-1) N=9 |
| 33924 | 60 CONTINUE |
| 33925 | IMACH=IMACH+1 |
| 33926 | **sr 19.2.97: loop for direct channel suppression |
| 33927 | C IF (IMACH.GT.10) THEN |
| 33928 | IF (IMACH.GT.1000) THEN |
| 33929 | ** |
| 33930 | C WRITE(LOUT,*) ' jump 3' |
| 33931 | GO TO 280 |
| 33932 | ENDIF |
| 33933 | ECM =ECMMH |
| 33934 | AMN2=AMN**2 |
| 33935 | AMT2=AMT**2 |
| 33936 | ECMN=(ECM**2+AMN2-AMT2)/(2.0D0*ECM ) |
| 33937 | IF(ECMN.LE.AMN) ECMN=AMN |
| 33938 | PCMN=SQRT(ECMN**2-AMN2) |
| 33939 | GAM=(ELAB+AMT)/ECM |
| 33940 | BGAM=PLAB/ECM |
| 33941 | IF (IANTH.GE.0) ECM=2.1D0 |
| 33942 | C |
| 33943 | C----------------------------- |
| 33944 | C*** RANDOM CHOICE OF REACTION CHANNEL |
| 33945 | C---------------------------- |
| 33946 | IST=0 |
| 33947 | VV=DT_RNDM(AMN2) |
| 33948 | VV=VV-1.D-17 |
| 33949 | C |
| 33950 | C----------------------------- |
| 33951 | C*** PLACE REDUCED VERSION |
| 33952 | C---------------------------- |
| 33953 | IIEI=IEII(IRE) |
| 33954 | IDWK=IEII(IRE+1)-IIEI |
| 33955 | IIWK=IRII(IRE) |
| 33956 | IIKI=IKII(IRE) |
| 33957 | C |
| 33958 | C----------------------------- |
| 33959 | C*** SHRINKAGE TO THE CONSIDERED ENERGY REGION FOR THE USE OF WEIGHTS |
| 33960 | C---------------------------- |
| 33961 | HECM=ECM |
| 33962 | HUMO=2.0D0*UMO(IIEI+IDWK)-UMO(IIEI+IDWK-1) |
| 33963 | IF (HUMO.LT.ECM) ECM=HUMO |
| 33964 | C |
| 33965 | C----------------------------- |
| 33966 | C*** INTERPOLATION PREPARATION |
| 33967 | C---------------------------- |
| 33968 | ECMO=UMO(IE) |
| 33969 | ECM1=UMO(IE-1) |
| 33970 | DECM=ECMO-ECM1 |
| 33971 | DEC=ECMO-ECM |
| 33972 | C |
| 33973 | C----------------------------- |
| 33974 | C*** RANDOM LOOP |
| 33975 | C---------------------------- |
| 33976 | IK=0 |
| 33977 | WKK=0.0D0 |
| 33978 | WICOR=0.0D0 |
| 33979 | 70 IK=IK+1 |
| 33980 | IWK=IIWK+(IK-1)*IDWK+IE-IIEI |
| 33981 | WOK=WK(IWK) |
| 33982 | WDK=WOK-WK(IWK-1) |
| 33983 | C |
| 33984 | C----------------------------- |
| 33985 | C*** TESTVARIABLE WICO/WICOR: IF CHANNEL IK HAS THE SAME WEIGHTS LIKE IK |
| 33986 | C GO TO NEXT CHANNEL, BECAUSE WKK((IK))-WKK((IK-1))=0, IK CAN NOT |
| 33987 | C CONTRIBUTE |
| 33988 | C---------------------------- |
| 33989 | IF (PLAB.LT.PLABF(IIEI+2)) WDK=0.0D0 |
| 33990 | WICO=WOK*1.23459876D0+WDK*1.735218469D0 |
| 33991 | IF (WICO.EQ.WICOR) GO TO 70 |
| 33992 | IF (UMO(IIEI+IDWK).LT.HECM) WDK=0.0D0 |
| 33993 | WICOR=WICO |
| 33994 | C |
| 33995 | C----------------------------- |
| 33996 | C*** INTERPOLATION IN CHANNEL WEIGHTS |
| 33997 | C---------------------------- |
| 33998 | EKLIM=-THRESH(IIKI+IK) |
| 33999 | IELIM=IDT_IEFUND(EKLIM,IRE) |
| 34000 | DELIM=UMO(IELIM)+EKLIM |
| 34001 | *+1.D-16 |
| 34002 | DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0 |
| 34003 | IF (DELIM*DELIM-DETE*DETE) 90,90,80 |
| 34004 | 80 DECC=DELIM |
| 34005 | GO TO 100 |
| 34006 | 90 DECC=DECM |
| 34007 | 100 CONTINUE |
| 34008 | WKK=WOK-WDK*DEC/(DECC+1.D-9) |
| 34009 | C |
| 34010 | C----------------------------- |
| 34011 | C*** RANDOM CHOICE |
| 34012 | C---------------------------- |
| 34013 | C |
| 34014 | IF (VV.GT.WKK) GO TO 70 |
| 34015 | C |
| 34016 | C***IK IS THE REACTION CHANNEL |
| 34017 | C---------------------------- |
| 34018 | INRK=IKII(IRE)+IK |
| 34019 | ECM=HECM |
| 34020 | I1001 =0 |
| 34021 | C |
| 34022 | 110 CONTINUE |
| 34023 | IT1=NRK(1,INRK) |
| 34024 | AM1=DT_DAMG(IT1) |
| 34025 | IT2=NRK(2,INRK) |
| 34026 | AM2=DT_DAMG(IT2) |
| 34027 | AMS=AM1+AM2 |
| 34028 | I1001=I1001+1 |
| 34029 | IF (I1001.GT.50) GO TO 60 |
| 34030 | C |
| 34031 | IF (IT2*AMS.GT.IT2*ECM) GO TO 110 |
| 34032 | IT11=IT1 |
| 34033 | IT22=IT2 |
| 34034 | IF (IANTH.GE.0) ECM=ELAB+AMT+0.00001D0 |
| 34035 | AM11=AM1 |
| 34036 | AM22=AM2 |
| 34037 | IF (IT2.GT.0) GO TO 120 |
| 34038 | **sr 19.2.97: supress direct channel for pp-collisions |
| 34039 | IF ((N.EQ.1).AND.(ITTA.EQ.1).AND.(IT2.LE.0)) THEN |
| 34040 | RR = DT_RNDM(AM11) |
| 34041 | IF (RR.LE.0.75D0) GOTO 60 |
| 34042 | ENDIF |
| 34043 | ** |
| 34044 | C |
| 34045 | C----------------------------- |
| 34046 | C INCLUSION OF DIRECT RESONANCES |
| 34047 | C RANDOM CHOICE OF DECAY CHANNELS OF THE DIRECT RESONANCE IT1 |
| 34048 | C------------------------ |
| 34049 | KZ1=K1H(IT1) |
| 34050 | IST=IST+1 |
| 34051 | IECO=0 |
| 34052 | ECO=ECM |
| 34053 | GAM=(ELAB+AMT)/ECO |
| 34054 | BGAM=PLAB/ECO |
| 34055 | CXS(1)=CX |
| 34056 | CYS(1)=CY |
| 34057 | CZS(1)=CZ |
| 34058 | GO TO 170 |
| 34059 | 120 CONTINUE |
| 34060 | WW=DT_RNDM(ECO) |
| 34061 | IF(WW.LT. 0.5D0) GO TO 130 |
| 34062 | IT1=IT22 |
| 34063 | IT2=IT11 |
| 34064 | AM1=AM22 |
| 34065 | AM2=AM11 |
| 34066 | 130 CONTINUE |
| 34067 | C |
| 34068 | C----------------------------- |
| 34069 | C THE FIRST PARTICLE IS DEFINED TO BE THE FORWARD GOING ONE AT SMALL T |
| 34070 | IBN=IBARH(N) |
| 34071 | IB1=IBARH(IT1) |
| 34072 | IT11=IT1 |
| 34073 | IT22=IT2 |
| 34074 | AM11=AM1 |
| 34075 | AM22=AM2 |
| 34076 | IF(IB1.EQ.IBN) GO TO 140 |
| 34077 | IT1=IT22 |
| 34078 | IT2=IT11 |
| 34079 | AM1=AM22 |
| 34080 | AM2=AM11 |
| 34081 | 140 CONTINUE |
| 34082 | C----------------------------- |
| 34083 | C***IT1,IT2 ARE THE CREATED PARTICLES |
| 34084 | C***MOMENTA AND DIRECTION COSINA IN THE CM - SYSTEM |
| 34085 | C------------------------ |
| 34086 | CALL DT_DTWOPA(ECM1,ECM2,PCM1,PCM2,COD1,COD2,COF1,COF2,SIF1,SIF2, |
| 34087 | *IT1,IT2,ECM,ECMN,PCMN,N,AM1,AM2) |
| 34088 | IST=IST+1 |
| 34089 | ITS(IST)=IT1 |
| 34090 | AMM(IST)=AM1 |
| 34091 | C |
| 34092 | C----------------------------- |
| 34093 | C***TRANSFORMATION INTO LAB SYSTEM AND ROTATION |
| 34094 | C---------------------------- |
| 34095 | CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD1,COF1,SIF1, |
| 34096 | &PCM1,ECM1,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST)) |
| 34097 | IST=IST+1 |
| 34098 | ITS(IST)=IT2 |
| 34099 | AMM(IST)=AM2 |
| 34100 | CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD2,COF2,SIF2, |
| 34101 | *PCM2,ECM2,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST)) |
| 34102 | 150 CONTINUE |
| 34103 | C |
| 34104 | C----------------------------- |
| 34105 | C***TEST STABLE OR UNSTABLE |
| 34106 | C---------------------------- |
| 34107 | IF(ITS(IST).GT.NSTAB) GO TO 160 |
| 34108 | IRH=IRH+1 |
| 34109 | C |
| 34110 | C----------------------------- |
| 34111 | C***IRH IS THE NUMBER OF THE FINAL STABLE PARTICLE |
| 34112 | C---------------------------- |
| 34113 | C* IF (REDU.LT.0.D0) GO TO 1009 |
| 34114 | ITRH(IRH)=ITS(IST) |
| 34115 | PLRH(IRH)=PLS(IST) |
| 34116 | CXRH(IRH)=CXS(IST) |
| 34117 | CYRH(IRH)=CYS(IST) |
| 34118 | CZRH(IRH)=CZS(IST) |
| 34119 | ELRH(IRH)=ELS(IST) |
| 34120 | IST=IST-1 |
| 34121 | IF(IST.GE.1) GO TO 150 |
| 34122 | GO TO 260 |
| 34123 | 160 CONTINUE |
| 34124 | C |
| 34125 | C RANDOM CHOICE OF DECAY CHANNELS |
| 34126 | C---------------------------- |
| 34127 | C |
| 34128 | IT=ITS(IST) |
| 34129 | ECO=AMM(IST) |
| 34130 | GAM=ELS(IST)/ECO |
| 34131 | BGAM=PLS(IST)/ECO |
| 34132 | IECO=0 |
| 34133 | KZ1=K1H(IT) |
| 34134 | 170 CONTINUE |
| 34135 | IECO=IECO+1 |
| 34136 | VV=DT_RNDM(GAM) |
| 34137 | VV=VV-1.D-17 |
| 34138 | IIK=KZ1-1 |
| 34139 | 180 IIK=IIK+1 |
| 34140 | IF (VV.GT.WTI(IIK)) GO TO 180 |
| 34141 | C |
| 34142 | C IIK IS THE DECAY CHANNEL |
| 34143 | C---------------------------- |
| 34144 | IT1=NZKI(IIK,1) |
| 34145 | I310=0 |
| 34146 | 190 CONTINUE |
| 34147 | I310=I310+1 |
| 34148 | AM1=DT_DAMG(IT1) |
| 34149 | IT2=NZKI(IIK,2) |
| 34150 | AM2=DT_DAMG(IT2) |
| 34151 | IF (IT2-1.LT.0) GO TO 240 |
| 34152 | IT3=NZKI(IIK,3) |
| 34153 | AM3=DT_DAMG(IT3) |
| 34154 | AMS=AM1+AM2+AM3 |
| 34155 | C |
| 34156 | C IF IIK-KIN.LIM.GT.ACTUAL TOTAL CM-ENERGY, DO AGAIN RANDOM IIK-CHOICE |
| 34157 | C---------------------------- |
| 34158 | IF (IECO.LE.10) GO TO 200 |
| 34159 | IATMPT=IATMPT+1 |
| 34160 | IF(IATMPT.GT.3) THEN |
| 34161 | C WRITE(LOUT,*) ' jump 4' |
| 34162 | GO TO 280 |
| 34163 | ENDIF |
| 34164 | GO TO 40 |
| 34165 | 200 CONTINUE |
| 34166 | IF (I310.GT.50) GO TO 170 |
| 34167 | IF (AMS.GT.ECO) GO TO 190 |
| 34168 | C |
| 34169 | C FOR THE DECAY CHANNEL |
| 34170 | C IT1,IT2, IT3 ARE THE PRODUCED PARTICLES FROM IT |
| 34171 | C---------------------------- |
| 34172 | IF (REDU.LT.0.D0) GO TO 30 |
| 34173 | ITWTHC=0 |
| 34174 | REDU=2.0D0 |
| 34175 | IF(IT3.EQ.0) GO TO 220 |
| 34176 | 210 CONTINUE |
| 34177 | ITWTH=1 |
| 34178 | CALL DT_DTHREP(ECO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,SIF1, |
| 34179 | *COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3) |
| 34180 | GO TO 230 |
| 34181 | 220 CALL DT_DTWOPD(ECO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1, |
| 34182 | &COD2,COF2,SIF2,AM1,AM2) |
| 34183 | ITWTH=-1 |
| 34184 | IT3=0 |
| 34185 | 230 CONTINUE |
| 34186 | ITWTHC=ITWTHC+1 |
| 34187 | IF (REDU.GT.0.D0) GO TO 240 |
| 34188 | REDU=2.0D0 |
| 34189 | IF (ITWTHC.GT.100) GO TO 30 |
| 34190 | IF (ITWTH) 220,220,210 |
| 34191 | 240 CONTINUE |
| 34192 | ITS(IST )=IT1 |
| 34193 | IF (IT2-1.LT.0) GO TO 250 |
| 34194 | ITS(IST+1) =IT2 |
| 34195 | ITS(IST+2)=IT3 |
| 34196 | RX=CXS(IST) |
| 34197 | RY=CYS(IST) |
| 34198 | RZ=CZS(IST) |
| 34199 | AMM(IST)=AM1 |
| 34200 | CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD1,COF1,SIF1,PCM1,ECM1, |
| 34201 | *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST)) |
| 34202 | IST=IST+1 |
| 34203 | AMM(IST)=AM2 |
| 34204 | CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD2,COF2,SIF2,PCM2,ECM2, |
| 34205 | *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST)) |
| 34206 | IF (IT3.LE.0) GO TO 250 |
| 34207 | IST=IST+1 |
| 34208 | AMM(IST)=AM3 |
| 34209 | CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD3,COF3,SIF3,PCM3,ECM3, |
| 34210 | *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST)) |
| 34211 | 250 CONTINUE |
| 34212 | GO TO 150 |
| 34213 | 260 CONTINUE |
| 34214 | 270 CONTINUE |
| 34215 | RETURN |
| 34216 | 280 CONTINUE |
| 34217 | C |
| 34218 | C---------------------------- |
| 34219 | C |
| 34220 | C ZERO CROSS SECTION CASE |
| 34221 | C---------------------------- |
| 34222 | C |
| 34223 | IRH=1 |
| 34224 | ITRH(1)=N |
| 34225 | CXRH(1)=CX |
| 34226 | CYRH(1)=CY |
| 34227 | CZRH(1)=CZ |
| 34228 | ELRH(1)=ELAB |
| 34229 | PLRH(1)=PLAB |
| 34230 | RETURN |
| 34231 | END |
| 34232 | |
| 34233 | *$ CREATE DT_RUNTT.FOR |
| 34234 | *COPY DT_RUNTT |
| 34235 | * |
| 34236 | *===runtt==============================================================* |
| 34237 | * |
| 34238 | BLOCK DATA DT_RUNTT |
| 34239 | |
| 34240 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 34241 | SAVE |
| 34242 | |
| 34243 | COMMON /HNDRUN/ RUNTES,EFTES |
| 34244 | |
| 34245 | DATA RUNTES,EFTES /100.D0,100.D0/ |
| 34246 | |
| 34247 | END |
| 34248 | |
| 34249 | *$ CREATE DT_NONAME.FOR |
| 34250 | *COPY DT_NONAME |
| 34251 | * |
| 34252 | *===noname=============================================================* |
| 34253 | * |
| 34254 | BLOCK DATA DT_NONAME |
| 34255 | |
| 34256 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 34257 | SAVE |
| 34258 | |
| 34259 | * slope parameters for HADRIN interactions |
| 34260 | COMMON /HNSLOP/ SM(25),BBM(25),BBB(25) |
| 34261 | COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17) |
| 34262 | |
| 34263 | C DATAS DATAS DATAS DATAS DATAS |
| 34264 | C****** ********* |
| 34265 | DATA IKII/ 0, 15, 41, 67, 82, 93, 110, 133, 148, 159, 172, 183, |
| 34266 | & 207, 224, 241, 252, 268 / |
| 34267 | DATA IEII/ 0, 21, 46, 71, 92, 109, 126, 143, 160, 173, 186, 199, |
| 34268 | & 220, 241, 262, 279, 296 / |
| 34269 | DATA IRII/ 0, 315, 965, 1615, 1930, 2117, 2406, 2797, 3052, 3195, |
| 34270 | & 3364, 3507, 4011, 4368, 4725, 4912, 5184/ |
| 34271 | |
| 34272 | C |
| 34273 | C MASSES FOR THE SLOPE B(M) IN GEV |
| 34274 | C SLOPE B(M) FOR AN MESONIC SYSTEM |
| 34275 | C SLOPE B(M) FOR A BARYONIC SYSTEM |
| 34276 | |
| 34277 | * |
| 34278 | DATA SM,BBM,BBB/ 0.8D0, 0.85D0, 0.9D0, 0.95D0, 1.D0, |
| 34279 | & 1.05D0, 1.1D0, 1.15D0, 1.2D0, 1.25D0, |
| 34280 | & 1.3D0, 1.35D0, 1.4D0, 1.45D0, 1.5D0, |
| 34281 | & 1.55D0, 1.6D0, 1.65D0, 1.7D0, 1.75D0, |
| 34282 | & 1.8D0, 1.85D0, 1.9D0, 1.95D0, 2.D0, |
| 34283 | & 15.6D0, 14.95D0, 14.3D0, 13.65D0, 13.D0, |
| 34284 | & 12.35D0, 11.7D0, 10.85D0, 10.D0, 9.15D0, |
| 34285 | & 8.3D0, 7.8D0, 7.3D0, 7.25D0, 7.2D0, |
| 34286 | & 6.95D0, 6.7D0, 6.6D0, 6.5D0, 6.3D0, |
| 34287 | & 6.1D0, 5.85D0, 5.6D0, 5.35D0, 5.1D0, |
| 34288 | & 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, |
| 34289 | & 14.2D0, 13.4D0, 12.6D0, |
| 34290 | & 11.8D0, 11.2D0, 10.6D0, 9.8D0, 9.D0, |
| 34291 | & 8.25D0, 7.5D0, 6.25D0, 5.D0, 4.5D0, 5*4.D0 / |
| 34292 | * |
| 34293 | END |
| 34294 | |
| 34295 | *$ CREATE DT_DAMG.FOR |
| 34296 | *COPY DT_DAMG |
| 34297 | * |
| 34298 | *===damg===============================================================* |
| 34299 | * |
| 34300 | DOUBLE PRECISION FUNCTION DT_DAMG(IT) |
| 34301 | |
| 34302 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 34303 | SAVE |
| 34304 | |
| 34305 | * particle properties (BAMJET index convention), |
| 34306 | * (dublicate of DTPART for HADRIN) |
| 34307 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), |
| 34308 | & K1H(110),K2H(110) |
| 34309 | |
| 34310 | DIMENSION GASUNI(14) |
| 34311 | DATA GASUNI/ |
| 34312 | *-1.D0,-.98D0,-.95D0,-.87D0,-.72D0,-.48D0, |
| 34313 | *-.17D0,.17D0,.48D0,.72D0,.87D0,.95D0,.98D0,1.D0/ |
| 34314 | DATA GAUNO/2.352D0/ |
| 34315 | DATA GAUNON/2.4D0/ |
| 34316 | DATA IO/14/ |
| 34317 | DATA NSTAB/23/ |
| 34318 | |
| 34319 | I=1 |
| 34320 | IF (IT.LE.0) GO TO 30 |
| 34321 | IF (IT.LE.NSTAB) GO TO 20 |
| 34322 | DGAUNI=GAUNO*GAUNON/DBLE(IO-1) |
| 34323 | VV=DT_RNDM(DGAUNI) |
| 34324 | VV=VV*2.0D0-1.0D0+1.D-16 |
| 34325 | 10 CONTINUE |
| 34326 | VO=GASUNI(I) |
| 34327 | I=I+1 |
| 34328 | V1=GASUNI(I) |
| 34329 | IF (VV.GT.V1) GO TO 10 |
| 34330 | UNIGA=DGAUNI*(DBLE(I)-2.0D0+(VV-VO+1.D-16)/ |
| 34331 | & (V1-VO)-(DBLE(IO)-1.0D0)*0.5D0) |
| 34332 | DAM=GAH(IT)*UNIGA/GAUNO |
| 34333 | AAM=AMH(IT)+DAM |
| 34334 | DT_DAMG=AAM |
| 34335 | RETURN |
| 34336 | 20 CONTINUE |
| 34337 | DT_DAMG=AMH(IT) |
| 34338 | RETURN |
| 34339 | 30 CONTINUE |
| 34340 | DT_DAMG=0.0D0 |
| 34341 | RETURN |
| 34342 | END |
| 34343 | |
| 34344 | *$ CREATE DT_DCALUM.FOR |
| 34345 | *COPY DT_DCALUM |
| 34346 | * |
| 34347 | *===dcalum=============================================================* |
| 34348 | * |
| 34349 | SUBROUTINE DT_DCALUM(N,ITTA) |
| 34350 | |
| 34351 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 34352 | SAVE |
| 34353 | |
| 34354 | C*** C.M.S.-ENERGY AND REACTION CHANNEL THRESHOLD CALCULATION |
| 34355 | |
| 34356 | * particle properties (BAMJET index convention), |
| 34357 | * (dublicate of DTPART for HADRIN) |
| 34358 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), |
| 34359 | & K1H(110),K2H(110) |
| 34360 | COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17) |
| 34361 | COMMON /HNSPLI/ WTI(460),NZKI(460,3) |
| 34362 | COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184), |
| 34363 | & NRK(2,268),NURE(30,2) |
| 34364 | |
| 34365 | IRE=NURE(N,ITTA/8+1) |
| 34366 | IEO=IEII(IRE)+1 |
| 34367 | IEE=IEII(IRE +1) |
| 34368 | AM1=AMH(N ) |
| 34369 | AM12=AM1**2 |
| 34370 | AM2=AMH(ITTA) |
| 34371 | AM22=AM2**2 |
| 34372 | DO 10 IE=IEO,IEE |
| 34373 | PLAB2=PLABF(IE)**2 |
| 34374 | ELAB=SQRT(AM12+AM22+2.0D0*SQRT(PLAB2+AM12)*AM2) |
| 34375 | UMO(IE)=ELAB |
| 34376 | 10 CONTINUE |
| 34377 | IKO=IKII(IRE)+1 |
| 34378 | IKE=IKII(IRE +1) |
| 34379 | UMOO=UMO(IEO) |
| 34380 | DO 30 IK=IKO,IKE |
| 34381 | IF(NRK(2,IK).GT.0) GO TO 30 |
| 34382 | IKI=NRK(1,IK) |
| 34383 | AMSS=5.0D0 |
| 34384 | K11=K1H(IKI) |
| 34385 | K22=K2H(IKI) |
| 34386 | DO 20 IK1=K11,K22 |
| 34387 | IN=NZKI(IK1,1) |
| 34388 | AMS=AMH(IN) |
| 34389 | IN=NZKI(IK1,2) |
| 34390 | IF(IN.GT.0)AMS=AMS+AMH(IN) |
| 34391 | IN=NZKI(IK1,3) |
| 34392 | IF(IN.GT.0) AMS=AMS+AMH(IN) |
| 34393 | IF (AMS.LT.AMSS) AMSS=AMS |
| 34394 | 20 CONTINUE |
| 34395 | IF(UMOO.LT.AMSS) UMOO=AMSS |
| 34396 | THRESH(IK)=UMOO |
| 34397 | 30 CONTINUE |
| 34398 | RETURN |
| 34399 | END |
| 34400 | |
| 34401 | *$ CREATE DT_DCHANH.FOR |
| 34402 | *COPY DT_DCHANH |
| 34403 | * |
| 34404 | *===dchanh=============================================================* |
| 34405 | * |
| 34406 | SUBROUTINE DT_DCHANH |
| 34407 | |
| 34408 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 34409 | SAVE |
| 34410 | |
| 34411 | PARAMETER ( LINP = 10 , |
| 34412 | & LOUT = 6 , |
| 34413 | & LDAT = 9 ) |
| 34414 | * particle properties (BAMJET index convention), |
| 34415 | * (dublicate of DTPART for HADRIN) |
| 34416 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), |
| 34417 | & K1H(110),K2H(110) |
| 34418 | COMMON /HNSPLI/ WTI(460),NZKI(460,3) |
| 34419 | COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17) |
| 34420 | COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184), |
| 34421 | & NRK(2,268),NURE(30,2) |
| 34422 | |
| 34423 | DIMENSION HWT(460),HWK(40),SI(5184) |
| 34424 | EQUIVALENCE (WK(1),SI(1)) |
| 34425 | C-------------------- |
| 34426 | C*** USE ONLY FOR DATAPREPARATION OF PURE HADRIN |
| 34427 | C*** CALCULATION OF REACTION- AND DECAY-CHANNEL-WEIGHTS, |
| 34428 | C*** THRESHOLD ENERGIES+MOMENTA OF REACTION CHNLS. |
| 34429 | C*** CHANGE OF WT- AND WK-INPUTDATA INTO WEIGHTS FOR THE M.-C.-PROCEDURE |
| 34430 | C*** (ADDED ONE TO EACH OTHER FOR CORRESPONDING CHANNELS) |
| 34431 | C-------------------------- |
| 34432 | IREG=16 |
| 34433 | DO 90 IRE=1,IREG |
| 34434 | IWKO=IRII(IRE) |
| 34435 | IEE=IEII(IRE+1)-IEII(IRE) |
| 34436 | IKE=IKII(IRE+1)-IKII(IRE) |
| 34437 | IEO=IEII(IRE)+1 |
| 34438 | IIKA=IKII(IRE) |
| 34439 | * modifications to suppress elestic scattering 24/07/91 |
| 34440 | DO 80 IE=1,IEE |
| 34441 | SIS=1.D-14 |
| 34442 | SINORC=0.0D0 |
| 34443 | DO 10 IK=1,IKE |
| 34444 | IWK=IWKO+IEE*(IK-1)+IE |
| 34445 | IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0 |
| 34446 | SIS=SIS+SI(IWK)*SINORC |
| 34447 | 10 CONTINUE |
| 34448 | SIIN(IEO+IE-1)=SIS |
| 34449 | SIO=0.D0 |
| 34450 | IF (SIS.GE.1.D-12) GO TO 20 |
| 34451 | SIS=1.D0 |
| 34452 | SIO=1.D0 |
| 34453 | 20 CONTINUE |
| 34454 | SINORC=0.0D0 |
| 34455 | DO 30 IK=1,IKE |
| 34456 | IWK=IWKO+IEE*(IK-1)+IE |
| 34457 | IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0 |
| 34458 | SIO=SIO+SI(IWK)*SINORC/SIS |
| 34459 | HWK(IK)=SIO |
| 34460 | 30 CONTINUE |
| 34461 | DO 40 IK=1,IKE |
| 34462 | IWK=IWKO+IEE*(IK-1)+IE |
| 34463 | 40 WK(IWK)=HWK(IK) |
| 34464 | IIKI=IKII(IRE) |
| 34465 | DO 70 IK=1,IKE |
| 34466 | AM111=0.D0 |
| 34467 | INRK1=NRK(1,IIKI+IK) |
| 34468 | IF (INRK1.GT.0) AM111=AMH(INRK1) |
| 34469 | AM222=0.D0 |
| 34470 | INRK2=NRK(2,IIKI+IK) |
| 34471 | IF (INRK2.GT.0) AM222=AMH(INRK2) |
| 34472 | THRESH(IIKI+IK)=AM111 +AM222 |
| 34473 | IF (INRK2-1.GE.0) GO TO 60 |
| 34474 | INRKK=K1H(INRK1) |
| 34475 | AMSS=5.D0 |
| 34476 | INRKO=K2H(INRK1) |
| 34477 | DO 50 INRK1=INRKK,INRKO |
| 34478 | INZK1=NZKI(INRK1,1) |
| 34479 | INZK2=NZKI(INRK1,2) |
| 34480 | INZK3=NZKI(INRK1,3) |
| 34481 | IF (INZK1.LE.0.OR.INZK1.GT.110) GO TO 50 |
| 34482 | IF (INZK2.LE.0.OR.INZK2.GT.110) GO TO 50 |
| 34483 | IF (INZK3.LE.0.OR.INZK3.GT.110) GO TO 50 |
| 34484 | C WRITE (6,310)INRK1,INZK1,INZK2,INZK3 |
| 34485 | 1000 FORMAT (4I10) |
| 34486 | AMS=AMH(INZK1)+AMH(INZK2) |
| 34487 | IF (INZK3-1.GE.0) AMS=AMS+AMH(INZK3) |
| 34488 | IF (AMSS.GT.AMS) AMSS=AMS |
| 34489 | 50 CONTINUE |
| 34490 | AMS=AMSS |
| 34491 | IF (AMS.LT.UMO(IEO)) AMS=UMO(IEO) |
| 34492 | THRESH(IIKI+IK)=AMS |
| 34493 | 60 CONTINUE |
| 34494 | 70 CONTINUE |
| 34495 | 80 CONTINUE |
| 34496 | 90 CONTINUE |
| 34497 | DO 100 J=1,460 |
| 34498 | 100 HWT(J)=0.D0 |
| 34499 | DO 120 I=1,110 |
| 34500 | IK1=K1H(I) |
| 34501 | IK2=K2H(I) |
| 34502 | HV=0.D0 |
| 34503 | IF (IK2.GT.460)IK2=460 |
| 34504 | IF (IK1.LE.0)IK1=1 |
| 34505 | DO 110 J=IK1,IK2 |
| 34506 | HV=HV+WTI(J) |
| 34507 | HWT(J)=HV |
| 34508 | JI=J |
| 34509 | 110 CONTINUE |
| 34510 | IF (ABS(HV-1.0D0).GT.1.D-4) WRITE(LOUT,1010)I,JI,HV |
| 34511 | 1010 FORMAT (35H ERROR IN HWT, FALSE USE OF CHANWH ,2I6,F10.2) |
| 34512 | 120 CONTINUE |
| 34513 | DO 130 J=1,460 |
| 34514 | 130 WTI(J)=HWT(J) |
| 34515 | RETURN |
| 34516 | END |
| 34517 | |
| 34518 | *$ CREATE DT_DHADDE.FOR |
| 34519 | *COPY DT_DHADDE |
| 34520 | * |
| 34521 | *===dhadde=============================================================* |
| 34522 | * |
| 34523 | SUBROUTINE DT_DHADDE |
| 34524 | |
| 34525 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 34526 | SAVE |
| 34527 | |
| 34528 | * particle properties (BAMJET index convention) |
| 34529 | CHARACTER*8 ANAME |
| 34530 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 34531 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 34532 | * HADRIN: decay channel information |
| 34533 | PARAMETER (IDMAX9=602) |
| 34534 | CHARACTER*8 ZKNAME |
| 34535 | COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3) |
| 34536 | * particle properties (BAMJET index convention), |
| 34537 | * (dublicate of DTPART for HADRIN) |
| 34538 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), |
| 34539 | & K1H(110),K2H(110) |
| 34540 | COMMON /HNSPLI/ WTI(460),NZKI(460,3) |
| 34541 | * decay channel information for HADRIN |
| 34542 | COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16), |
| 34543 | & K1Z(16),K2Z(16),WTZ(153),II22, |
| 34544 | & NZK1(153),NZK2(153),NZK3(153) |
| 34545 | |
| 34546 | DATA IRETUR/0/ |
| 34547 | |
| 34548 | IRETUR=IRETUR+1 |
| 34549 | AMH(31)=0.48D0 |
| 34550 | IF (IRETUR.GT.1) RETURN |
| 34551 | DO 10 I=1,94 |
| 34552 | AMH(I) = AAM(I) |
| 34553 | GAH(I) = GA(I) |
| 34554 | TAUH(I) = TAU(I) |
| 34555 | ICHH(I) = IICH(I) |
| 34556 | IBARH(I) = IIBAR(I) |
| 34557 | K1H(I) = K1(I) |
| 34558 | K2H(I) = K2(I) |
| 34559 | 10 CONTINUE |
| 34560 | **sr |
| 34561 | C AMH(1)=0.93828D0 |
| 34562 | AMH(1)=0.9383D0 |
| 34563 | ** |
| 34564 | AMH(2)=AMH(1) |
| 34565 | DO 20 I=26,30 |
| 34566 | K1H(I)=452 |
| 34567 | K2H(I)=452 |
| 34568 | 20 CONTINUE |
| 34569 | DO 30 I=1,307 |
| 34570 | WTI(I) = WT(I) |
| 34571 | NZKI(I,1) = NZK(I,1) |
| 34572 | NZKI(I,2) = NZK(I,2) |
| 34573 | NZKI(I,3) = NZK(I,3) |
| 34574 | 30 CONTINUE |
| 34575 | DO 40 I=1,16 |
| 34576 | L=I+94 |
| 34577 | AMH(L)=AMZ(I) |
| 34578 | GAH( L)=GAZ(I) |
| 34579 | TAUH( L)=TAUZ(I) |
| 34580 | ICHH( L)=ICHZ(I) |
| 34581 | IBARH( L)=IBARZ(I) |
| 34582 | K1H( L)=K1Z(I) |
| 34583 | K2H( L)=K2Z(I) |
| 34584 | 40 CONTINUE |
| 34585 | DO 50 I=1,153 |
| 34586 | L=I+307 |
| 34587 | WTI(L) = WTZ(I) |
| 34588 | NZKI(L,3) = NZK3(I) |
| 34589 | NZKI(L,2) = NZK2(I) |
| 34590 | NZKI(L,1) = NZK1(I) |
| 34591 | 50 CONTINUE |
| 34592 | RETURN |
| 34593 | END |
| 34594 | |
| 34595 | *$ CREATE IDT_IEFUND.FOR |
| 34596 | *COPY IDT_IEFUND |
| 34597 | * |
| 34598 | *===iefund=============================================================* |
| 34599 | * |
| 34600 | INTEGER FUNCTION IDT_IEFUND(PL,IRE) |
| 34601 | |
| 34602 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 34603 | SAVE |
| 34604 | |
| 34605 | C*****IEFUN CALCULATES A MOMENTUM INDEX |
| 34606 | |
| 34607 | PARAMETER ( LINP = 10 , |
| 34608 | & LOUT = 6 , |
| 34609 | & LDAT = 9 ) |
| 34610 | COMMON /HNDRUN/ RUNTES,EFTES |
| 34611 | COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17) |
| 34612 | COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184), |
| 34613 | & NRK(2,268),NURE(30,2) |
| 34614 | |
| 34615 | IPLA=IEII(IRE)+1 |
| 34616 | *+1 |
| 34617 | IPLE=IEII(IRE+1) |
| 34618 | IF (PL.LT.0.) GO TO 30 |
| 34619 | DO 10 I=IPLA,IPLE |
| 34620 | J=I-IPLA+1 |
| 34621 | IF (PL.LE.PLABF(I)) GO TO 60 |
| 34622 | 10 CONTINUE |
| 34623 | I=IPLE |
| 34624 | IF ( EFTES.GT.40.D0) GO TO 20 |
| 34625 | EFTES=EFTES+1.0D0 |
| 34626 | WRITE(LOUT,1000)PL,J |
| 34627 | 20 CONTINUE |
| 34628 | GO TO 70 |
| 34629 | 30 CONTINUE |
| 34630 | DO 40 I=IPLA,IPLE |
| 34631 | J=I-IPLA+1 |
| 34632 | IF (-PL.LE.UMO(I)) GO TO 60 |
| 34633 | 40 CONTINUE |
| 34634 | I=IPLE |
| 34635 | IF ( EFTES.GT.40.D0) GO TO 50 |
| 34636 | EFTES=EFTES+1.0D0 |
| 34637 | WRITE(LOUT,1000)PL,I |
| 34638 | 50 CONTINUE |
| 34639 | 60 CONTINUE |
| 34640 | 70 CONTINUE |
| 34641 | IDT_IEFUND=I |
| 34642 | RETURN |
| 34643 | 1000 FORMAT(14H PLAB OR -ECM=,E12.4,27H IS OUT OF CONSIDERED RANGE , |
| 34644 | +7H IEFUN=,I5) |
| 34645 | END |
| 34646 | |
| 34647 | *$ CREATE DT_DSIGIN.FOR |
| 34648 | *COPY DT_DSIGIN |
| 34649 | * |
| 34650 | *===dsigin=============================================================* |
| 34651 | * |
| 34652 | SUBROUTINE DT_DSIGIN(IRE ,PLAB,N,IE ,AMT ,AMN,ECM ,SI ,ITAR) |
| 34653 | |
| 34654 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 34655 | SAVE |
| 34656 | |
| 34657 | * particle properties (BAMJET index convention), |
| 34658 | * (dublicate of DTPART for HADRIN) |
| 34659 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), |
| 34660 | & K1H(110),K2H(110) |
| 34661 | COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17) |
| 34662 | COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184), |
| 34663 | & NRK(2,268),NURE(30,2) |
| 34664 | |
| 34665 | IE=IDT_IEFUND(PLAB,IRE) |
| 34666 | IF (IE.LE.IEII(IRE)) IE=IE+1 |
| 34667 | AMT=AMH(ITAR) |
| 34668 | AMN=AMH(N) |
| 34669 | AMN2=AMN*AMN |
| 34670 | AMT2=AMT*AMT |
| 34671 | ECM=SQRT(AMN2+AMT2+2.0D0*AMT*SQRT(AMN2+PLAB**2)) |
| 34672 | C*** INTERPOLATION PREPARATION |
| 34673 | ECMO=UMO(IE) |
| 34674 | ECM1=UMO(IE-1) |
| 34675 | DECM=ECMO-ECM1 |
| 34676 | DEC=ECMO-ECM |
| 34677 | IIKI=IKII(IRE)+1 |
| 34678 | EKLIM=-THRESH(IIKI) |
| 34679 | WOK=SIIN(IE) |
| 34680 | WDK=WOK-SIIN(IE-1) |
| 34681 | IF (ECM.GT.ECMO) WDK=0.0D0 |
| 34682 | C*** INTERPOLATION IN CHANNEL WEIGHTS |
| 34683 | IELIM=IDT_IEFUND(EKLIM,IRE) |
| 34684 | DELIM=UMO(IELIM)+EKLIM |
| 34685 | *+1.D-16 |
| 34686 | DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0 |
| 34687 | IF (DELIM*DELIM-DETE*DETE) 20,20,10 |
| 34688 | 10 DECC=DELIM |
| 34689 | GO TO 30 |
| 34690 | 20 DECC=DECM |
| 34691 | 30 CONTINUE |
| 34692 | WKK=WOK-WDK*DEC/(DECC+1.D-9) |
| 34693 | IF (WKK.LT.0.0D0) WKK=0.0D0 |
| 34694 | SI=WKK+1.D-12 |
| 34695 | IF (-EKLIM.GT.ECM) SI=1.D-14 |
| 34696 | RETURN |
| 34697 | END |
| 34698 | |
| 34699 | *$ CREATE DT_DTCHOI.FOR |
| 34700 | *COPY DT_DTCHOI |
| 34701 | * |
| 34702 | *===dtchoi=============================================================* |
| 34703 | * |
| 34704 | SUBROUTINE DT_DTCHOI(T,P,PP,E,EE,I,II,N,AM1,AM2) |
| 34705 | |
| 34706 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 34707 | SAVE |
| 34708 | |
| 34709 | C **************************** |
| 34710 | C TCHOIC CALCULATES A RANDOM VALUE |
| 34711 | C FOR THE FOUR-MOMENTUM-TRANSFER T |
| 34712 | C **************************** |
| 34713 | |
| 34714 | * particle properties (BAMJET index convention), |
| 34715 | * (dublicate of DTPART for HADRIN) |
| 34716 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), |
| 34717 | & K1H(110),K2H(110) |
| 34718 | * slope parameters for HADRIN interactions |
| 34719 | COMMON /HNSLOP/ SM(25),BBM(25),BBB(25) |
| 34720 | |
| 34721 | AMA=AM1 |
| 34722 | AMB=AM2 |
| 34723 | IF (I.GT.30.AND.II.GT.30) GO TO 20 |
| 34724 | III=II |
| 34725 | AM3=AM2 |
| 34726 | IF (I.LE.30) GO TO 10 |
| 34727 | III=I |
| 34728 | AM3=AM1 |
| 34729 | 10 CONTINUE |
| 34730 | GO TO 30 |
| 34731 | 20 CONTINUE |
| 34732 | III=II |
| 34733 | AM3=AM2 |
| 34734 | IF (AMA.LE.AMB) GO TO 30 |
| 34735 | III=I |
| 34736 | AM3=AM1 |
| 34737 | 30 CONTINUE |
| 34738 | IB=IBARH(III) |
| 34739 | AMA=AM3 |
| 34740 | K=INT((AMA-0.75D0)/0.05D0) |
| 34741 | IF (K-2.LT.0) K=1 |
| 34742 | IF (K-26.GE.0) K=25 |
| 34743 | IF (IB)50,40,50 |
| 34744 | 40 BM=BBM(K) |
| 34745 | GO TO 60 |
| 34746 | 50 BM=BBB(K) |
| 34747 | 60 CONTINUE |
| 34748 | C NORMALIZATION |
| 34749 | TMIN=-2.0D0*(E*EE-P*PP)+AMH(N)**2+AM1 **2 |
| 34750 | TMAX=-2.0D0*(E*EE+P*PP)+AMH(N)**2+AM1 **2 |
| 34751 | VB=DT_RNDM(TMIN) |
| 34752 | **sr test |
| 34753 | C IF (VB.LT.0.2D0) BM=BM*0.1 |
| 34754 | C **0.5 |
| 34755 | BM = BM*5.05D0 |
| 34756 | ** |
| 34757 | TMI=BM*TMIN |
| 34758 | TMA=BM*TMAX |
| 34759 | ETMA=0.D0 |
| 34760 | IF (ABS(TMA).GT.120.D0) GO TO 70 |
| 34761 | ETMA=EXP(TMA) |
| 34762 | 70 CONTINUE |
| 34763 | AN=(1.0D0/BM)*(EXP(TMI)-ETMA) |
| 34764 | C*** RANDOM CHOICE OF THE T - VALUE |
| 34765 | R=DT_RNDM(TMI) |
| 34766 | T=(1.0D0/BM)*LOG(ETMA+R*AN*BM) |
| 34767 | RETURN |
| 34768 | END |
| 34769 | |
| 34770 | *$ CREATE DT_DTWOPA.FOR |
| 34771 | *COPY DT_DTWOPA |
| 34772 | * |
| 34773 | *===dtwopa=============================================================* |
| 34774 | * |
| 34775 | SUBROUTINE DT_DTWOPA(E1,E2,P1,P2,COD1,COD2,COF1,COF2,SIF1,SIF2, |
| 34776 | &IT1,IT2,UMOO,ECM,P,N,AM1,AM2) |
| 34777 | |
| 34778 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 34779 | SAVE |
| 34780 | |
| 34781 | C ****************************************************** |
| 34782 | C QUASI TWO PARTICLE PRODUCTION |
| 34783 | C TWOPAR CALCULATES THE ENERGYS AND THE MOMENTA |
| 34784 | C FOR THE CREATED PARTICLES OR RESONANCES IT1 AND IT2 |
| 34785 | C IN THE CM - SYSTEM |
| 34786 | C COD1,COD2,COF1,COF2,SIF1,SIF2 ARE THE ANGLES FOR |
| 34787 | C SPHERICAL COORDINATES |
| 34788 | C ****************************************************** |
| 34789 | |
| 34790 | * particle properties (BAMJET index convention), |
| 34791 | * (dublicate of DTPART for HADRIN) |
| 34792 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), |
| 34793 | & K1H(110),K2H(110) |
| 34794 | |
| 34795 | AMA=AM1 |
| 34796 | AMB=AM2 |
| 34797 | AMA2=AMA*AMA |
| 34798 | E1=((UMOO-AMB)*(UMOO+AMB) + AMA2)/(2.0D0*UMOO) |
| 34799 | E2=UMOO - E1 |
| 34800 | IF (E1.LT.AMA*1.00001D0) E1=AMA*1.00001D0 |
| 34801 | AMTE=(E1-AMA)*(E1+AMA) |
| 34802 | AMTE=AMTE+1.D-18 |
| 34803 | P1=SQRT(AMTE) |
| 34804 | P2=P1 |
| 34805 | C / P2 / = / P1 / BUT OPPOSITE DIRECTIONS |
| 34806 | C DETERMINATION OF THE ANGLES |
| 34807 | C COS(THETA1)=COD1 COS(THETA2)=COD2 |
| 34808 | C SIN(PHI1)=SIF1 SIN(PHI2)=SIF2 |
| 34809 | C COS(PHI1)=COF1 COS(PHI2)=COF2 |
| 34810 | C PHI IS UNIFORMLY DISTRIBUTED IN ( 0,2*PI ) |
| 34811 | CALL DT_DSFECF(COF1,SIF1) |
| 34812 | COF2=-COF1 |
| 34813 | SIF2=-SIF1 |
| 34814 | C CALCULATION OF THETA1 |
| 34815 | CALL DT_DTCHOI(TR,P,P1,ECM,E1,IT1,IT2,N,AM1,AM2) |
| 34816 | COD1=(TR-AMA2-AMH(N)*AMH(N)+2.0D0*ECM*E1)/(2.0D0*P*P1+1.D-18) |
| 34817 | IF (COD1.GT.0.9999999D0) COD1=0.9999999D0 |
| 34818 | COD2=-COD1 |
| 34819 | RETURN |
| 34820 | END |
| 34821 | |
| 34822 | *$ CREATE DT_ZK.FOR |
| 34823 | *COPY DT_ZK |
| 34824 | * |
| 34825 | *===zk=================================================================* |
| 34826 | * |
| 34827 | BLOCK DATA DT_ZK |
| 34828 | |
| 34829 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 34830 | SAVE |
| 34831 | |
| 34832 | * decay channel information for HADRIN |
| 34833 | COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16), |
| 34834 | & K1Z(16),K2Z(16),WTZ(153),II22, |
| 34835 | & NZK1(153),NZK2(153),NZK3(153) |
| 34836 | * decay channel information for HADRIN |
| 34837 | CHARACTER*8 ANAMZ,ZKNAM4,ZKNAM5,ZKNAM6 |
| 34838 | COMMON /HNADDN/ ANAMZ(16),ZKNAM4(9),ZKNAM5(90),ZKNAM6(54) |
| 34839 | |
| 34840 | * Particle masses in GeV * |
| 34841 | DATA AMZ/ 3*2.2D0, 0.9576D0, 3*1.887D0, 2.4D0, 2.03D0, 2*1.44D0, |
| 34842 | & 2*1.7D0, 3*0.D0/ |
| 34843 | * Resonance width Gamma in GeV * |
| 34844 | DATA GAZ/ 3*.2D0, .1D0, 4*.2D0, .18D0, 2*.2D0, 2*.15D0, 3*0.D0 / |
| 34845 | * Mean life time in seconds * |
| 34846 | DATA TAUZ / 16*0.D0 / |
| 34847 | * Charge of particles and resonances * |
| 34848 | DATA ICHZ/ 0, 1, 3*0, 1, -1, 0, 1, -1, 0, 0, 1 , 3*0 / |
| 34849 | * Baryonic charge * |
| 34850 | DATA IBARZ/ 2, 7*0, 1, -1, -1, 1, 1, 3*0 / |
| 34851 | * First number of decay channels used for resonances * |
| 34852 | * and decaying particles * |
| 34853 | DATA K1Z/ 308,310,313,317,322,365,393,421,425,434,440,446,449, |
| 34854 | & 3*460/ |
| 34855 | * Last number of decay channels used for resonances * |
| 34856 | * and decaying particles * |
| 34857 | DATA K2Z/ 309,312,316,321,364,392,420,424,433,439,445,448,451, |
| 34858 | & 3*460/ |
| 34859 | * Weight of decay channel * |
| 34860 | DATA WTZ/ .17D0, .83D0, 2*.33D0, .34D0, .17D0, 2*.33D0, .17D0, |
| 34861 | & .01D0, .13D0, .36D0, .27D0, .23D0, .0014D0, .0029D0, .0014D0, |
| 34862 | & .0029D0, 4*.0007D0, .0517D0, .0718D0, .0144D0, .0431D0, .0359D0, |
| 34863 | & .0718D0, .0014D0, .0273D0, .0014D0, .0431D0, 2*.0129D0, .0259D0, |
| 34864 | & .0517D0, .0359D0, .0014D0, 2*.0144D0, .0129D0, .0014D0, .0259D0, |
| 34865 | & .0359D0, .0072D0, .0474D0, .0948D0, .0259D0, .0072D0, .0144D0, |
| 34866 | & .0287D0, .0431D0, .0144D0, .0287D0, .0474D0, .0144D0, .0075D0, |
| 34867 | & .0057D0, .0019D0, .0038D0, .0095D0, 2*.0014D0, .0191D0, .0572D0, |
| 34868 | & .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0, .0686D0,.0172D0, |
| 34869 | & .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0, .0190D0, |
| 34870 | & .0057D0, .0019D0, .0038D0, .0095D0, .0014D0, .0014D0, .0191D0, |
| 34871 | & .0572D0, .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0,.0686D0, |
| 34872 | & .0172D0, .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0, |
| 34873 | & .0190D0, 4*.25D0, 2*.2D0, .12D0, .1D0, .07D0, .07D0, .14D0, |
| 34874 | & 2*.05D0, .0D0, .3334D0, .2083D0, 2*.125D0, .2083D0, .0D0, .125D0, |
| 34875 | & .2083D0, .3334D0, .2083D0, .125D0, .3D0, .05D0, .65D0, .3D0, |
| 34876 | & .05D0, .65D0, 9*1.D0 / |
| 34877 | * Particle numbers in decay channel * |
| 34878 | DATA NZK1/ 8, 1, 2, 9, 1, 2, 9, 2, 9, 7, 13, 31, 15, 24, 23, 13, |
| 34879 | & 23, 13, 2*23, 14, 13, 23, 31, 98, 2*33, 32, 23, 14, 13, 35, 2*23, |
| 34880 | & 14, 13, 33, 23, 98, 31, 23, 14, 13, 35, 2*33, 32, 23, 35, 33, 32, |
| 34881 | & 98, 5*35, 4*13, 23, 13, 98, 32, 33, 23, 13, 23, 13, 14, 13, 32, |
| 34882 | & 13, 98, 23, 13, 2*32, 13, 33, 32, 98, 2*35, 4*14, 23, 14, 98, |
| 34883 | & 2*34, 23, 14, 23, 2*14, 13, 34, 14, 98, 23, 14, 2*34, 14, 33, 32, |
| 34884 | & 98, 2*35, 104, 61, 105, 62, 1, 17, 21, 17, 22, 2*21, 22, 21, 2, |
| 34885 | & 67, 68, 69, 2, 2*9, 68, 69, 70, 2, 9, 2*24, 15, 2*25, 16, 9*0/ |
| 34886 | DATA NZK2/ 2*8, 1, 8, 9, 2*8, 2*1, 7, 14, 13, 16, 25, 23, 14, 23, |
| 34887 | & 14, 31, 33, 32, 34, 35, 31, 23, 31, 33, 34, 31, 32, 34, 31, 33, |
| 34888 | & 32, 2*33, 35, 31, 33, 31, 33, 32, 34, 35, 31, 33, 34, 35, 31, |
| 34889 | & 4*33, 32, 3*35, 2*23, 13, 31, 32, 33, 13, 31, 32, 2*31, 32, 33, |
| 34890 | & 32, 32, 35, 31, 2*32, 33, 31, 33, 35, 33, 3*32, 35, 2*23, 14, |
| 34891 | & 31, 34, 33, 14, 31, 33, 2*31, 34, 32, 33, 34, 35, 31, 2*34, 33, |
| 34892 | & 31, 33, 35, 33, 2*34, 33, 35, 1, 2, 8, 9, 25, 13, 35, 2*32, 33, |
| 34893 | & 31, 13, 23, 31, 13, 23, 14, 79, 80, 31, 13, 23, 14, 78, 79, 8, |
| 34894 | & 1, 8, 1, 8, 1, 9*0 / |
| 34895 | DATA NZK3/ 23, 14, 2*13, 23, 13, 2*23, 14, 0, 7, 14, 4*0, 2*23, |
| 34896 | & 10*0, 33, 2*31, 0, 33, 34, 32, 34, 0, 35, 0, 31, 3*35, 0, 3*31, |
| 34897 | & 35, 31, 33, 34, 31, 33, 34, 31, 33, 35, 0, 23, 14, 6*0, 32, 3*33, |
| 34898 | & 32, 34, 0, 35, 0, 2*35, 2*31, 35, 32, 34, 31, 33, 32, 0, 23, 13, |
| 34899 | & 6*0, 34, 2*33, 34, 33, 34, 0, 35, 0,2*35, 2*31, 35, 2*34, 31, |
| 34900 | & 2*34, 25*0, 23, 2*14, 23, 2*13, 9*0 / |
| 34901 | * Particle names * |
| 34902 | DATA ANAMZ / 'NNPI', 'ANPPI', 'ANNPI', ' ETS ',' PAP ',' PAN ', |
| 34903 | & 'APN', 'DEO ', 'S+2030', 'AN*-14', 'AN*014','KONPI ','AKOPPI', |
| 34904 | & 3*'BLANK' / |
| 34905 | * Name of decay channel * |
| 34906 | DATA ZKNAM4/'NNPI0','PNPI-','APPPI+','ANNPI+','ANPPI0','APNPI+', |
| 34907 | & 'ANNPI0','APPPI0','ANPPI-'/ |
| 34908 | DATA ZKNAM5/' GAGA ','P+P-GA','ETP+P-','K+K- ','K0AK0 ', |
| 34909 | & ' POPO ',' P+P- ','POPOPO','P+P0P-','P0ET ','&0R0 ','P-R+ ', |
| 34910 | & 'P+R- ','POOM ',' ETET ','ETSP0 ','R0ET ',' R0R0 ','R+R- ', |
| 34911 | & 'P0ETR0','P-ETR+','P+ETR-',' OMET ','P0R0R0','P0R+R-','P-R+R0', |
| 34912 | & 'P+R-R0','R0OM ','P0ETOM','ETSR0 ','ETETET','P0R0OM','P-R+OM', |
| 34913 | & 'P+R-OM','OMOM ','R0ETET','R0R0ET','R+R-ET','P0OMOM','OMETET', |
| 34914 | & 'R0R0R0','R+R0R-','ETSRET','OMR0R0','OMR+R-','OMOMET','OMOMR0', |
| 34915 | & 'OMOMOM', |
| 34916 | & ' P+PO ','P+POPO','P+P+P-','P+ET ','P0R+ ','P+R0 ','ETSP+ ', |
| 34917 | & 'R+ET ',' R0R+ ','POETR+','P+ETR0','POR+R-','P+R0R0','P-R+R+', |
| 34918 | & 'P+R-R+','R+OM ','P+ETOM','ETSR+ ','POR+OM','P+R0OM','R+ETET', |
| 34919 | & 'R+R0ET','P+OMOM','R0R0R+','R+R+R-','ETSR+E','OMR+R0','OMOMR+', |
| 34920 | & 'P-PO ','P-POPO','P-P-P+','P-ET ','POR- ','P-R0 ','ETSP- ', |
| 34921 | & 'R-ET ','R-R0 ','POETR-','P-ETR0','POR-R0','P-R+R-','P-R0R0'/ |
| 34922 | DATA ZKNAM6/'P+R-R-','R-OM ','P-ETOM','ETSR- ','POR-OM','P-R0OM', |
| 34923 | & 'R-ETET','R-R0ET','P-OMOM','R0R0R-','R+R-R-','ETSR-E','OMR0R-', |
| 34924 | & 'OMOMR-', 'PAN-14','APN+14','NAN014','ANN014','PAKO ','LPI+ ', |
| 34925 | & 'SI+OM','LAMRO+','SI0RO+','SI+RO0','SI+ETA','SI0PI+','SI+PI0', |
| 34926 | & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHOO','ANRHO-','ANETA ', |
| 34927 | & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0', |
| 34928 | & 'KONPIO','KOPPI-','K+NPI-','AKOPPO','AKONP+','K-PPI+', |
| 34929 | & 9*'BLANK'/ |
| 34930 | *= end*block.zk * |
| 34931 | END |
| 34932 | |
| 34933 | *$ CREATE DT_BLKD43.FOR |
| 34934 | *COPY DT_BLKD43 |
| 34935 | * |
| 34936 | *===blkd43=============================================================* |
| 34937 | * |
| 34938 | BLOCK DATA DT_BLKD43 |
| 34939 | |
| 34940 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 34941 | SAVE |
| 34942 | |
| 34943 | * |
| 34944 | *=== reac =============================================================* |
| 34945 | * |
| 34946 | *----------------------------------------------------------------------* |
| 34947 | * * |
| 34948 | * Created on 10 december 1991 by Alfredo Ferrari & Paola Sala * |
| 34949 | * Infn - Milan * |
| 34950 | * * |
| 34951 | * Last change on 10-dec-91 by Alfredo Ferrari * |
| 34952 | * * |
| 34953 | * This is the original common reac of Hadrin * |
| 34954 | * * |
| 34955 | *----------------------------------------------------------------------* |
| 34956 | * |
| 34957 | COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184), |
| 34958 | & NRK(2,268),NURE(30,2) |
| 34959 | |
| 34960 | DIMENSION |
| 34961 | & UMOPI(92), UMOKC(68), UMOP(39), UMON(63), UMOK0(34), |
| 34962 | & PLAPI(92), PLAKC(68), PLAP(39), PLAN(63), PLAK0(34), |
| 34963 | & SPIKP1(315), SPIKPU(278), SPIKPV(372), |
| 34964 | & SPIKPW(278), SPIKPX(372), SPIKP4(315), |
| 34965 | & SPIKP5(187), SPIKP6(289), |
| 34966 | & SKMPEL(102), SPIKP7(289), SKMNEL(68), SPIKP8(187), |
| 34967 | & SPIKP9(143), SPIKP0(169), SPKPV(143), |
| 34968 | & SAPPEL(105), SPIKPE(399), SAPNEL(84), SPIKPZ(273), |
| 34969 | & SANPEL(84) , SPIKPF(273), |
| 34970 | & SPKP15(187), SPKP16(272), |
| 34971 | & NRKPI(164), NRKKC(132), NRKP(70), NRKN(116), NRKK0(54), |
| 34972 | & NURELN(60) |
| 34973 | * |
| 34974 | DIMENSION NRKLIN(532) |
| 34975 | EQUIVALENCE (NRK(1,1), NRKLIN(1)) |
| 34976 | EQUIVALENCE ( UMO( 1), UMOPI(1)), ( UMO( 93), UMOKC(1)) |
| 34977 | EQUIVALENCE ( UMO(161), UMOP(1)), ( UMO(200), UMON(1)) |
| 34978 | EQUIVALENCE ( UMO(263), UMOK0(1)) |
| 34979 | EQUIVALENCE ( PLABF( 1), PLAPI(1)), ( PLABF( 93), PLAKC(1)) |
| 34980 | EQUIVALENCE ( PLABF(161), PLAP(1)), ( PLABF(200), PLAN(1)) |
| 34981 | EQUIVALENCE ( PLABF(263), PLAK0(1)) |
| 34982 | EQUIVALENCE ( WK( 1), SPIKP1(1)), ( WK( 316), SPIKPU(1)) |
| 34983 | EQUIVALENCE ( WK( 594), SPIKPV(1)), ( WK( 966), SPIKPW(1)) |
| 34984 | EQUIVALENCE ( WK(1244), SPIKPX(1)), ( WK(1616), SPIKP4(1)) |
| 34985 | EQUIVALENCE ( WK(1931), SPIKP5(1)), ( WK(2118), SPIKP6(1)) |
| 34986 | EQUIVALENCE ( WK(2407), SKMPEL(1)), ( WK(2509), SPIKP7(1)) |
| 34987 | EQUIVALENCE ( WK(2798), SKMNEL(1)), ( WK(2866), SPIKP8(1)) |
| 34988 | EQUIVALENCE ( WK(3053), SPIKP9(1)), ( WK(3196), SPIKP0(1)) |
| 34989 | EQUIVALENCE ( WK(3365), SPKPV(1)), ( WK(3508), SAPPEL(1)) |
| 34990 | EQUIVALENCE ( WK(3613), SPIKPE(1)), ( WK(4012), SAPNEL(1)) |
| 34991 | EQUIVALENCE ( WK(4096), SPIKPZ(1)), ( WK(4369), SANPEL(1)) |
| 34992 | EQUIVALENCE ( WK(4453), SPIKPF(1)), ( WK(4726), SPKP15(1)) |
| 34993 | EQUIVALENCE ( WK(4913), SPKP16(1)) |
| 34994 | EQUIVALENCE (NRK(1,1), NRKLIN(1)) |
| 34995 | EQUIVALENCE (NRKLIN( 1), NRKPI(1)), (NRKLIN( 165), NRKKC(1)) |
| 34996 | EQUIVALENCE (NRKLIN( 297), NRKP(1)), (NRKLIN( 367), NRKN(1)) |
| 34997 | EQUIVALENCE (NRKLIN( 483), NRKK0(1)) |
| 34998 | EQUIVALENCE (NURE(1,1), NURELN(1)) |
| 34999 | * |
| 35000 | **** pi- p data * |
| 35001 | **** pi+ n data * |
| 35002 | DATA PLAPI / 0.D0, .3D0, .5D0, .6D0, .7D0, .8D0, .9D0, .95D0,1.D0, |
| 35003 | & 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0, |
| 35004 | & 3.D0, 3.5D0, 4.D0, 0.D0, .285D0, .4D0, .45D0, .5D0, .6D0, .7D0, |
| 35005 | & .75D0, .8D0, .85D0, .9D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, |
| 35006 | & 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0, |
| 35007 | & .285D0, .4D0, .45D0, .5D0, .6D0, .7D0, .75D0, .8D0, .85D0, .9D0, |
| 35008 | & 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0, |
| 35009 | & 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0, .3D0, .5D0, .6D0, .7D0, |
| 35010 | & .8D0, .9D0, .95D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, |
| 35011 | & 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0 / |
| 35012 | DATA PLAKC / |
| 35013 | & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0, |
| 35014 | & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0, |
| 35015 | & 3.51D0, 3.84D0, 4.16D0, 4.49D0, |
| 35016 | & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0, |
| 35017 | & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0, |
| 35018 | & 3.51D0, 3.84D0, 4.16D0, 4.49D0, |
| 35019 | & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0, |
| 35020 | & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0, |
| 35021 | & 3.51D0, 3.84D0, 4.16D0, 4.49D0, |
| 35022 | & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0, |
| 35023 | & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0, |
| 35024 | & 3.51D0, 3.84D0, 4.16D0, 4.49D0/ |
| 35025 | DATA PLAK0 / |
| 35026 | & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0, |
| 35027 | & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0, |
| 35028 | & 3.51D0, 3.84D0, 4.16D0, 4.49D0, |
| 35029 | & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0, |
| 35030 | & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0, |
| 35031 | & 3.51D0, 3.84D0, 4.16D0, 4.49D0/ |
| 35032 | * pp pn np nn * |
| 35033 | DATA PLAP / |
| 35034 | & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0, |
| 35035 | & 3.43D0, 3.75D0, 4.07D0, 4.43D0, |
| 35036 | & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0, |
| 35037 | & 3.43D0, 3.75D0, 4.07D0, 4.43D0, |
| 35038 | & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0, |
| 35039 | & 3.43D0, 3.75D0, 4.07D0, 4.43D0 / |
| 35040 | * app apn anp ann * |
| 35041 | DATA PLAN / |
| 35042 | & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0, |
| 35043 | & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0, |
| 35044 | & 3.43D0, 3.75D0, 4.07D0, 4.43D0, |
| 35045 | & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0, |
| 35046 | & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0, |
| 35047 | & 3.43D0, 3.75D0, 4.07D0, 4.43D0, |
| 35048 | & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0, |
| 35049 | & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0, |
| 35050 | & 3.43D0, 3.75D0, 4.07D0, 4.43D0 / |
| 35051 | DATA SIIN / 296*0.D0 / |
| 35052 | DATA UMOPI/ 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0, |
| 35053 | & 1.557D0,1.615D0,1.6435D0, |
| 35054 | & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0, |
| 35055 | & 2.286D0,2.366D0,2.482D0,2.56D0, |
| 35056 | & 2.735D0,2.90D0, |
| 35057 | & 1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0, |
| 35058 | & 1.496D0,1.527D0,1.557D0, |
| 35059 | & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0, |
| 35060 | & 2.071D0,2.159D0,2.286D0,2.366D0, |
| 35061 | & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0, |
| 35062 | & 1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0, |
| 35063 | & 1.496D0,1.527D0,1.557D0, |
| 35064 | & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0, |
| 35065 | & 2.071D0,2.159D0,2.286D0,2.366D0, |
| 35066 | & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0, |
| 35067 | & 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0, |
| 35068 | & 1.557D0,1.615D0,1.6435D0, |
| 35069 | & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0, |
| 35070 | & 2.286D0,2.366D0,2.482D0,2.56D0, |
| 35071 | & 2.735D0, 2.90D0/ |
| 35072 | DATA UMOKC/ 1.44D0, |
| 35073 | & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0, |
| 35074 | & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0, |
| 35075 | & 3.1D0,1.44D0, |
| 35076 | & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0, |
| 35077 | & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0, |
| 35078 | & 3.1D0,1.44D0, |
| 35079 | & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0, |
| 35080 | & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0, |
| 35081 | & 3.1D0,1.44D0, |
| 35082 | & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0, |
| 35083 | & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0, |
| 35084 | & 3.1D0/ |
| 35085 | DATA UMOK0/ 1.44D0, |
| 35086 | & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0, |
| 35087 | & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0, |
| 35088 | & 3.1D0,1.44D0, |
| 35089 | & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0, |
| 35090 | & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0, |
| 35091 | & 3.1D0/ |
| 35092 | * pp pn np nn * |
| 35093 | DATA UMOP/ |
| 35094 | & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0, |
| 35095 | & 3.D0,3.1D0,3.2D0, |
| 35096 | & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0, |
| 35097 | & 3.D0,3.1D0,3.2D0, |
| 35098 | & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0, |
| 35099 | & 3.D0,3.1D0,3.2D0/ |
| 35100 | * app apn anp ann * |
| 35101 | DATA UMON / |
| 35102 | & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0, |
| 35103 | & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0, |
| 35104 | & 3.D0,3.1D0,3.2D0, |
| 35105 | & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0, |
| 35106 | & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0, |
| 35107 | & 3.D0,3.1D0,3.2D0, |
| 35108 | & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0, |
| 35109 | & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0, |
| 35110 | & 3.D0,3.1D0,3.2D0/ |
| 35111 | **** reaction channel state particles * |
| 35112 | DATA NRKPI / 13, 1, 15, 21, 81, 0, 13, 54, 23, 53, 13, 63, 13, 58, |
| 35113 | & 23, 57, 13, 65, 1, 32, 53, 31, 54, 32, 53, 33, 53, 35, 63, 32, |
| 35114 | & 13, 8, 23, 1, 17, 15, 21, 24, 22, 15, 82, 0, 61, 0, 13, 55, 23, |
| 35115 | & 54, 14, 53, 13, 64, 23, 63, 13, 59, 23, 58, 14, 57, 13, 66, 23, |
| 35116 | & 65, 1, 31, 8, 32, 1, 33, 1, 35, 54, 31, 55, 32, 54, 33, 53, 34, |
| 35117 | & 54, 35, 14, 1, 23, 8, 17, 24, 20, 15, 22, 24, 83, 0, 62, 0, 14, |
| 35118 | & 54, 23, 55, 13, 56, 14, 63, 23, 64, 14, 58, 23, 59, 13, 60, 14, |
| 35119 | & 65, 23, 66, 8, 31, 1, 34, 8, 33, 8, 35, 55, 31, 54, 34, 55, 33, |
| 35120 | & 56, 32, 55, 35, 14, 8, 24, 20, 84, 0, 14, 55, 23, 56, 14, 64, 14, |
| 35121 | & 59, 23, 60, 14, 66, 8, 34, 56, 31, 55, 34, 56, 33, 56, 35, 64,34/ |
| 35122 | DATA NRKKC/ 15, 1, 89, 0, 24, 53, 15, 54, 1, 36, 1, 40, 1, 44, 36, |
| 35123 | & 63, 15, 63, 45, 53, 44, 54, 15, 8, 24, 1, 91, 0, 24, 54, 15, 55, |
| 35124 | & 8, 36, 1, 37, 8, 40, 1, 41, 8, 44, 1, 45, 36, 64, 37, 63, 15, 64, |
| 35125 | & 24, 63, 45, 54, 44, 55, 16, 1, 25, 8, 17, 23, 21, 14, 20, |
| 35126 | & 13, 22, 23, 90, 0, 38, 1, 39, 8, 16, 54, 25, 55, 1, 42, 8, 43, |
| 35127 | & 16, 63, 25, 64, 39, 64, 38, 63, 46, 54, 47, 55, 8, 47, 1, 46, 52, |
| 35128 | & 0, 51, 0, 16, 8, 17, 14, 20, 23, 22, 14, 92, 0, 8, 38, 16, 55, |
| 35129 | & 25, 56, 8, 42, 16, 64, 38, 64, 46, 55, 47, 56, 8, 46, 94, 0 / |
| 35130 | * * |
| 35131 | * k0 p k0 n ak0 p ak/ n * |
| 35132 | * * |
| 35133 | DATA NRKK0 / 24, 8, 106, 0, 15, 56, 24, 55, 37, 8, 41, 8, 45, 8, |
| 35134 | & 37, 64, 24, 64, 44, 56, 45, 55, 25, 1, 17, 13, 22, 13, 21, 23, |
| 35135 | & 107, 0, 39, 1, 25, 54, 16, 53, 43, 1, 25, 63, 39, 63, 47, 54, 46, |
| 35136 | & 53, 47, 1, 103, 0, 93, 0/ |
| 35137 | * pp pn np nn * |
| 35138 | DATA NRKP / 1, 1, 85, 0, 8, 53, 1, 54, 1, 63, 8, 57, 1, 58, 2*54, |
| 35139 | & 53, 55, 63, 54, 64, 53, 1, 8, 86, 0, 8, 54, 1, 55, 8, 63, 1, 64, |
| 35140 | & 8, 58, 1, 59, 64, 54, 63, 55, 54, 55, 53, 56, 77, 0, 2*8, 95, 0, |
| 35141 | & 8, 55, 1, 56, 8, 64, 8, 59, 1, 60, 2*55, 54, 56, 64, 55, 63, 56 / |
| 35142 | * app apn anp ann * |
| 35143 | DATA NRKN/ 1, 2, 17, 18, 15, 16, 8, 9, 13, 14, 99, 0, 87, 0, 1, |
| 35144 | & 68, 8, 69, 2, 54, 9, 55, 102, 0, 2, 63, 9, 64, 1, 75, 8, 76, 53, |
| 35145 | & 67, 54, 68, 55, 69, 56, 70, 63, 68, 64, 69, 75, 54, 76, 55, 2, 8, |
| 35146 | & 18, 20, 16, 24, 14, 23, 101, 0, 88, 0, 2, 55, 9, 56, 1, 67, 8, |
| 35147 | & 68, 2, 64, 8, 75, 2, 59, 8, 72, 68, 55, 67, 54, 69, 56, 1, 9, 18, |
| 35148 | & 21, 15, 25, 13, 23, 100, 0, 96, 0, 2, 53, 9, 54, 1, 69, 8, 70, 1, |
| 35149 | & 76, 9, 63, 1, 73, 9, 58, 55, 70, 53, 68, 54, 69 / |
| 35150 | **** channel cross section * |
| 35151 | DATA SPIKP1/ 0.D0, 300.D0, 40.D0, 20.D0, 13.D0,8.5D0,8.D0, 9.5D0, |
| 35152 | & 12.D0,14.D0,15.5D0,20.D0,17.D0,13.D0,10.D0,9.D0,8.5D0,8.D0,7.8D0, |
| 35153 | & 7.3D0, 6.7D0, 9*0.D0,.23D0,.35D0,.7D0,.52D0,.4D0,.3D0,.2D0,.15D0, |
| 35154 | & .13D0, .11D0, .09D0, .07D0, 0.D0, .033D0,.8D0,1.35D0,1.35D0,.5D0, |
| 35155 | & 15*0.D0, 3*0.D0,.00D0,0.80D0,2.2D0,3.6D0,4.6D0,4.7D0,3.5D0,2.4D0, |
| 35156 | &1.8D0,1.4D0,.75D0,.47D0,.25D0,.13D0,.08D0,6*0.D0,0.D0,1.2D0,3.3D0, |
| 35157 | & 5.4D0,6.9D0,7.3D0,5.3D0,3.6D0,2.7D0,2.2D0,1.1D0,.73D0,.4D0,.22D0, |
| 35158 | & .12D0,9*0.D0,.0D0,0.D0,2.0D0,4.4D0,6.8D0,9.9D0,7.9D0,6.0D0,3.8D0, |
| 35159 | &2.5D0,2.D0,1.4D0,1.D0,.6D0,.35D0,10*0.D0,.25D0,.55D0,.75D0,1.25D0, |
| 35160 | & 1.9D0,2.D0,1.8D0,1.5D0,1.25D0,1.D0,.8D0,6*0.D0,4*0.D0,.4D0,.85D0, |
| 35161 | & 1.1D0, 1.85D0, 2.8D0, 3.D0,2.7D0,2.2D0,1.85D0,1.5D0,1.2D0,6*0.D0, |
| 35162 | & 6*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0, 5.6D0, |
| 35163 | & 5.2D0, 6*0.D0, 2*0.D0, .0D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0, |
| 35164 | & 2.75D0, 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 6*0.D0, 3*0.D0, |
| 35165 | & .0D0, .45D0, 1.4D0, 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0, |
| 35166 | & 8*0.D0, 5*0.D0, .0D0, .0D0, .6D0, .8D0, .95D0, .8D0, .7D0, .6D0, |
| 35167 | & .5D0, .4D0, 6*0.D0, 5*0.D0, .0D0, .00D0, .85D0, 1.2D0, 1.4D0, |
| 35168 | & 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 6*0.D0, 5*0.D0, .0D0, .00D0, |
| 35169 | & 1.D0, 1.5D0, 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 6*0.D0, |
| 35170 | & 10*0.D0, .5D0, 2.0D0, 3.3D0, 5.4D0, 7.D0 / |
| 35171 | **** pi+ n data * |
| 35172 | DATA SPIKPU/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 20.D0, |
| 35173 | & 20.D0, 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0, |
| 35174 | & 10.D0, 10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0, |
| 35175 | & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0, |
| 35176 | & 4.2D0, 7.5D0, 3.4D0, 2.5D0, 2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0, |
| 35177 | & .6D0, .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0, |
| 35178 | & .48D0, .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0, |
| 35179 | & .065D0, .05D0, .04D0, 12*0.D0, .2D0, .25D0, .25D0, .2D0, .1D0, |
| 35180 | & .08D0, .06D0, .045D0, .03D0, .02D0, .01D0, .005D0, .003D0, |
| 35181 | & 12*0.D0, .3D0, .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0, |
| 35182 | & .09D0, .08D0, .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0, |
| 35183 | & 3.1D0, 4.5D0, 2.D0, 18*0.D0, 3*.0D0, 0.D0, 0.D0, 4.0D0, 11.D0, |
| 35184 | & 11.4D0, 10.3D0, 7.5D0, 6.8D0, 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0, |
| 35185 | & .35D0, 13*0.D0, .1D0, .34D0, .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0, |
| 35186 | & 2.3D0, 1.6D0, .95D0, .45D0, .28D0, .15D0, 10*0.D0, 2*0.D0, .17D0, |
| 35187 | & .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0, 6.2D0, 4.4D0, 3.D0, 1.8D0, |
| 35188 | & .9D0, .53D0, .28D0, 10*0.D0, 2*0.D0, .25D0, .82D0, |
| 35189 | & 1.3D0, 1.9D0, 2.8D0, 5.5D0 , 8.D0, 5.7D0, 3.9D0, 2.35D0, 1.15D0, |
| 35190 | & .69D0, .37D0, 10*0.D0, 7*0.D0, .0D0, .34D0, 1.5D0, 3.47D0, |
| 35191 | & 5.87D0, 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/ |
| 35192 | * |
| 35193 | DATA SPIKPV/ 7*0.D0, .00D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0, |
| 35194 | & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 6*0.D0, 10*0.D0, .2D0, |
| 35195 | & .6D0, .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0, |
| 35196 | & 1.D0, .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0, |
| 35197 | & 3.5D0, 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0, |
| 35198 | & .31D0, .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0, |
| 35199 | & .23D0, 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0, |
| 35200 | & 5.D0, 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0, |
| 35201 | & 2.5D0, 3*0.D0, 3*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0, |
| 35202 | & 1.5D0, 1.1D0, .8D0, .7D0, .55D0, .3D0, 10*0.D0, 9*0.D0, .1D0, |
| 35203 | & .4D0, 1.D0, 1.4D0, 2.2D0, 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0, |
| 35204 | & .8D0, .6D0, .4D0, 12*0.D0, .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0, |
| 35205 | & 3.8D0, 3.3D0, 2.45D0, 2.05D0, 1.65D0, 1.2D0, .9D0, .6D0, 3*0.D0, |
| 35206 | & 9*0.D0, .10D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0, |
| 35207 | & 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, 13*0.D0, .2D0, .5D0, .7D0, |
| 35208 | & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, |
| 35209 | & 17*0.D0, .2D0, .5D0, .85D0, 2.D0, 2.15D0, 2.05D0, 1.75D0, 1.D0, |
| 35210 | & 17*0.D0, .13D0, .33D0, .57D0, 1.33D0, 1.43D0, 1.36D0, 1.17D0, |
| 35211 | & .67D0, 17*0.D0, .07D0, .17D0, .28D0, .67D0, .72D0, .69D0, .58D0, |
| 35212 | & .33D0,17*0.D0,.4D0, .7D0, 1.D0, 1.6D0, 1.8D0, 2.3D0,1.9D0,1.7D0 / |
| 35213 | **** pi- p data * |
| 35214 | DATA SPIKPW/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 2*20.D0, |
| 35215 | & 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0, |
| 35216 | & 2*10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0, |
| 35217 | & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0, |
| 35218 | & 4.2D0, 7.5D0, 3.4D0, 2*2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0, .6D0, |
| 35219 | & .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0, .48D0, |
| 35220 | & .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0, .065D0, |
| 35221 | & .05D0, .04D0, 12*0.D0, .2D0, 2*.25D0, .2D0, .1D0, .08D0, .06D0, |
| 35222 | & .045D0, .03D0, .02D0, .01D0, .005D0, .003D0, 12*0.D0, .3D0, |
| 35223 | & .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0, .09D0, .08D0, |
| 35224 | & .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0, 3.1D0, 4.5D0, |
| 35225 | & 2.D0, 23*0.D0, 4.0D0, 11.D0, 11.4D0, 10.3D0, 7.5D0, 6.8D0, |
| 35226 | & 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0, .35D0, 13*0.D0, .1D0, .34D0, |
| 35227 | & .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0, 2.3D0, 1.6D0, .95D0, .45D0, |
| 35228 | & .28D0, .15D0, 12*0.D0, .17D0, .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0, |
| 35229 | & 6.2D0, 4.4D0, 3.D0, 1.8D0, .9D0, .53D0, .28D0, 12*0.D0, .25D0, |
| 35230 | & .82D0, 1.3D0, 1.9D0, 2.8D0, 5.5D0, 8.D0, 5.7D0, 3.9D0, 2.35D0, |
| 35231 | & 1.15D0, .69D0, .37D0, 18*0.D0, .34D0, 1.5D0, 3.47D0, 5.87D0, |
| 35232 | & 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/ |
| 35233 | * |
| 35234 | DATA SPIKPX/ 8*0.D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0, |
| 35235 | & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 16*0.D0, .2D0, .6D0, |
| 35236 | & .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0, 1.D0, |
| 35237 | & .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0, 3.5D0, |
| 35238 | & 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0, .31D0, |
| 35239 | & .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0, .23D0, |
| 35240 | & 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0, 5.D0, |
| 35241 | & 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0, 2.5D0, |
| 35242 | & 6*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0, 1.5D0, 1.1D0, |
| 35243 | & .8D0, .7D0, .55D0, .3D0, 19*0.D0, .1D0, .4D0, 1.D0, 1.4D0, 2.2D0, |
| 35244 | & 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0, .8D0, .6D0, .4D0, 12*0.D0, |
| 35245 | & .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0, 3.8D0, 3.3D0, 2.45D0, 2.05D0, |
| 35246 | & 1.65D0, 1.2D0, .9D0, .6D0, 12*0.D0, .10D0, .2D0, .5D0, .7D0, |
| 35247 | & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, |
| 35248 | & 13*0.D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, |
| 35249 | & 1.35D0, 1.15D0, .95D0, .7D0, 17*0.D0, .2D0, .5D0, .85D0, 2.D0, |
| 35250 | & 2.15D0, 2.05D0, 1.75D0, 1.D0, 17*0.D0, .13D0, .33D0, .57D0, |
| 35251 | & 1.33D0, 1.43D0, 1.36D0, 1.17D0, .67D0, 17*0.D0, .07D0, .17D0, |
| 35252 | & .28D0, .67D0, .72D0, .69D0, .58D0, .33D0, 17*0.D0, .4D0, .7D0, |
| 35253 | & 1.D0, 1.6D0, 1.8D0, 2.3D0, 1.9D0, 1.7D0 / |
| 35254 | **** pi- n data * |
| 35255 | DATA SPIKP4 / 0.D0, 300.D0, 40.D0, 20.D0, 13.D0, 8.5D0, 8.D0, |
| 35256 | & 9.5D0, 12.D0, 14.D0, 15.5D0, 20.D0, 17.D0, 13.D0, 10.D0, 9.D0, |
| 35257 | & 8.5D0, 8.D0, 7.8D0, 7.3D0, 6.7D0, 9*0.D0, .23D0, .35D0, .7D0, |
| 35258 | & .52D0, .4D0, .3D0, .2D0, .15D0, .13D0, .11D0, .09D0, .07D0, 0.D0, |
| 35259 | & .033D0, .8D0, 2*1.35D0, .5D0, 19*0.D0, 0.8D0, 2.2D0, 3.6D0, |
| 35260 | & 4.6D0, 4.7D0, 3.5D0, 2.4D0, 1.8D0, 1.4D0, .75D0, .47D0, .25D0, |
| 35261 | & .13D0, .08D0, 7*0.D0, 1.2D0, 3.3D0, 5.4D0, 6.9D0, 7.3D0, 5.3D0, |
| 35262 | & 3.6D0, 2.7D0, 2.2D0, 1.1D0, .73D0, .4D0, .22D0, .12D0, 11*0.D0, |
| 35263 | & 2.0D0, 4.4D0, 6.8D0, 9.9D0, 7.9D0, 6.0D0, 3.8D0, 2.5D0, 2.D0, |
| 35264 | & 1.4D0, 1.D0, .6D0, .35D0, 10*0.D0, .25D0, .55D0, .75D0, 1.25D0, |
| 35265 | & 1.9D0, 2.D0, 1.8D0, 1.5D0, 1.25D0, 1.D0, .8D0, 10*0.D0, .4D0, |
| 35266 | & .85D0, 1.1D0, 1.85D0, 2.8D0, 3.D0, 2.7D0, 2.2D0, 1.85D0, 1.5D0, |
| 35267 | & 1.2D0, 12*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0, |
| 35268 | & 5.6D0, 5.2D0, 9*0.D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0, 2.75D0, |
| 35269 | & 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 10*0.D0, .45D0, 1.4D0, |
| 35270 | & 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0, 15*0.D0, .6D0, |
| 35271 | & .8D0, .95D0, .8D0, .7D0, .6D0, .5D0, .4D0, 13*0.D0, .85D0, 1.2D0, |
| 35272 | & 1.4D0, 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 13*0.D0, 1.D0, 1.5D0, |
| 35273 | & 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 16*0.D0, .5D0, 2.0D0, |
| 35274 | & 3.3D0, 5.4D0, 7.D0 / |
| 35275 | **** k+ p data * |
| 35276 | DATA SPIKP5/ 0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0, |
| 35277 | & 7.D0, 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0, |
| 35278 | & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 13*0.D0, 0.9D0, |
| 35279 | & 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0, |
| 35280 | & .45D0, .21D0, .2D0, 3*0.D0, .9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, |
| 35281 | & 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0, |
| 35282 | & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0, 1.4D0, |
| 35283 | & 1.2D0, 1.05D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0, 2*1.D0, .9D0, |
| 35284 | & .7D0, .4D0, .3D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.2D0, |
| 35285 | & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, |
| 35286 | & 1.71D0, 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0, |
| 35287 | & 3.5D0, 2.85D0, 2.35D0, 2.01D0, 1.8D0, 12*0.D0, .1D0, .8D0,2.05D0, |
| 35288 | & 3.31D0, 3.5D0, 12*0.D0, .034D0, .2D0, .75D0, 1.04D0, 1.24D0 / |
| 35289 | **** k+ n data * |
| 35290 | DATA SPIKP6/ 0.D0, 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0, |
| 35291 | & 1.5D0, 1.2D0, 1.D0, .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0, |
| 35292 | & 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0, 1.5D0, 1.2D0, 1.D0, |
| 35293 | & .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0, .5D0, 1.3D0, 2.8D0, |
| 35294 | & 2.3D0, 1.6D0, .9D0, 13*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, |
| 35295 | & 2.D0, 1.7D0, 1.5D0,1.2D0,.9D0,.6D0,.45D0,.21D0,.2D0,3*0.D0,0.9D0, |
| 35296 | & 2.5D0, 3.D0, 2.5D0, 2.3D0,2.D0,1.7D0,1.5D0,1.2D0,.9D0,.6D0,.45D0, |
| 35297 | & .21D0, .2D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.D0,1.8D0,1.7D0,1.4D0, |
| 35298 | & 1.2D0,1.15D0,.9D0,.66D0,.5D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.1D0, |
| 35299 | & 1.8D0,1.7D0,1.4D0,1.2D0, 1.15D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0, |
| 35300 | & 2*1.D0, .9D0, .7D0, .4D0, .35D0, .2D0, 9*0.D0, .3D0, 2*1.D0,.9D0, |
| 35301 | & .7D0, .4D0, .35D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.4D0,3.5D0,4.25D0, |
| 35302 | & 4.55D0, 4.85D0, 4.9D0, 9*0.D0, .1D0, 1.D0, 2.4D0, 3.5D0, 4.25D0, |
| 35303 | & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, |
| 35304 | & 1.71D0, 1.6D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0, |
| 35305 | & 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0,4.4D0,4.D0,3.5D0,2.85D0, |
| 35306 | & 2.35D0, 2.01D0, 1.8D0, 6*0.D0, 1.4D0,3.8D0,5.D0,4.7D0,4.4D0,4.D0, |
| 35307 | & 3.5D0,2.85D0,2.35D0,2.01D0,1.8D0,12*0.D0,.1D0,.8D0,2.05D0,3.31D0, |
| 35308 | & 3.5D0, 12*0.D0, .034D0,.2D0,.75D0,1.04D0,1.24D0 / |
| 35309 | **** k- p data * |
| 35310 | DATA SKMPEL/ 0.D0, 35.D0, 22.D0, 25.D0, 17.D0, 9.D0, 9.5D0, 8.D0, |
| 35311 | & 7.D0, 6.5D0, 6.1D0, 5.D0, 4.8D0, 4.6D0, 4.45D0, 4.3D0, 4.2D0, |
| 35312 | & 0.D0, 8.D0, 3.5D0, 8.D0, 3.D0, 1.9D0, 1.7D0, 1.D0, .9D0, .8D0, |
| 35313 | & .75D0, .5D0, .42D0, .38D0, .34D0, .25D0, .2D0, |
| 35314 | & 0.D0, 3.D0, 3.2D0, 3.5D0, 1.5D0, 1.4D0, 1.1D0, .6D0, .5D0, |
| 35315 | & .35D0, .28D0, .25D0, .18D0, .12D0, .1D0, .08D0, .04D0, |
| 35316 | & 0.D0, 8.5D0, 2.4D0, 1.7D0, 1.3D0, 1.3D0, 1.1D0, .5D0, |
| 35317 | & .4D0, .4D0, .35D0, .3D0, .28D0, .2D0, .16D0, .13D0, .11D0, |
| 35318 | & 0.D0, 7.D0, 4.8D0, 1.4D0, 1.9D0, .9D0, .4D0, .2D0, .13D0, |
| 35319 | & .1D0, .08D0, .06D0, .04D0, .02D0, .015D0, .01D0, .01D0, |
| 35320 | & 0.D0, 5.5D0, 1.D0, .8D0, .75D0, .32D0, .2D0, .1D0, .09D0, |
| 35321 | & .08D0, .065D0, .05D0, .04D0, .022D0, .017D0, 2*.01D0/ |
| 35322 | DATA SPIKP7 / 0.D0, .56D0, 1.46D0, 3.16D0, 2.01D0, 1.28D0, .74D0, |
| 35323 | & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, |
| 35324 | & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 4*0.D0, |
| 35325 | & 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0, 1.57D0, |
| 35326 | & 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0, 3.03D0, |
| 35327 | & 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, |
| 35328 | & .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0, 2.8D0, |
| 35329 | & 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, |
| 35330 | & .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, |
| 35331 | & .45D0, .39D0, .22D0, .07D0, 0.D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, |
| 35332 | & 1.01D0, .78D0, .45D0, .39D0, .22D0, .07D0, 0.D0, 6*0.D0, 1.71D0, |
| 35333 | & 4.26D0, 5.6D0, 5.57D0, 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0, |
| 35334 | & 2.25D0, 2.D0, 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0, |
| 35335 | & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0, .22D0, |
| 35336 | & .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 10*0.D0, .22D0, .8D0, |
| 35337 | & .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0, .3D0, .7D0,1.D0, |
| 35338 | & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0, 1.72D0, 2.69D0, |
| 35339 | & 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 9*0.D0, .11D0, 1.72D0, |
| 35340 | & 2.69D0, 3.92D0, 4.76D0, 5.1D0, 5.44D0, 5.3D0, 5*0.D0,9.2D0,4.7D0, |
| 35341 | & 1.9D0, 10*0.D0, 2.5D0, 15.D0, 21.5D0, 15.3D0, 3.D0, 1.5D0, |
| 35342 | & 10*0.D0/ |
| 35343 | ***** k- n data * |
| 35344 | DATA SKMNEL/0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0, |
| 35345 | & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0, |
| 35346 | & 0.D0, 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0, |
| 35347 | & 1.9D0, .9D0, .5D0, .3D0, .24D0, .2D0, .18D0, .1D0, .09D0, |
| 35348 | & 0.D0, 1.8D0, 2.D0, 1.1D0, .9D0, .5D0, .5D0, .4D0, .4D0, |
| 35349 | & .2D0, .1D0, .06D0, .05D0, .04D0, .03D0, .02D0, .02D0, |
| 35350 | & 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0, .7D0, .65D0, |
| 35351 | & .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0, .03D0/ |
| 35352 | DATA SPIKP8/0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0, |
| 35353 | & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, |
| 35354 | & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, |
| 35355 | & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, |
| 35356 | & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0, |
| 35357 | & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, |
| 35358 | & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0, |
| 35359 | & 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, .45D0, |
| 35360 | & .39D0, .22D0, .07D0, 0.D0, |
| 35361 | & 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0, |
| 35362 | & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, |
| 35363 | & 10*0.D0, .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, |
| 35364 | & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, |
| 35365 | & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, |
| 35366 | & 9*0.D0, .11D0, 1.72D0, 2.69D0, 3.92D0, 4.76D0, |
| 35367 | & 5.10D0, 5.44D0, 5.3D0, |
| 35368 | & 4*0.D0, 0.00D0, 9.2D0, 4.7D0, 1.9D0, 9*0.D0/ |
| 35369 | ***** p p data * |
| 35370 | DATA SPIKP9/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0, |
| 35371 | & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0, |
| 35372 | & 0.D0, 3.6D0, 1.7D0, 10*0.D0, |
| 35373 | & .0D0, 0.D0, 8.7D0, 17.7D0, 18.8D0, 15.9D0, |
| 35374 | & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0, |
| 35375 | & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0, |
| 35376 | & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0, |
| 35377 | & 5*0.D0, 4.6D0, 10.2D0, 15.1D0, |
| 35378 | & 16.9D0, 16.5D0, 11.D0, 5.5D0, 3.5D0, |
| 35379 | & 10*0.D0, 4.3D0, 7.6D0, 9.D0, |
| 35380 | & 10*0.D0, 1.7D0, 2.6D0, 3.D0, |
| 35381 | & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0, |
| 35382 | & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0, |
| 35383 | & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0, |
| 35384 | & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/ |
| 35385 | ***** p n data * |
| 35386 | DATA SPIKP0/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0, |
| 35387 | & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0, |
| 35388 | & 0.D0, 1.8D0, .2D0, 12*0.D0, |
| 35389 | & 3.2D0, 6.05D0, 9.9D0, 5.1D0, |
| 35390 | & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0, |
| 35391 | & 2*.0D0, 3.2D0, 6.05D0, 9.9D0, 5.1D0, |
| 35392 | & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0, |
| 35393 | & 5*0.D0, 4.6D0, 10.2D0, 15.1D0, |
| 35394 | & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0, |
| 35395 | & 5*0.D0, 4.6D0, 10.2D0, 15.1D0, |
| 35396 | & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0, |
| 35397 | & 10*0.D0, .7D0, 5.1D0, 8.D0, |
| 35398 | & 10*0.D0, .7D0, 5.1D0, 8.D0, |
| 35399 | & 10*.0D0, .3D0, 2.8D0, 4.7D0, |
| 35400 | & 10*.0D0, .3D0, 2.8D0, 4.7D0, |
| 35401 | & 7*0.D0, 1.2D0, 2.5D0, 3.5D0, 6.D0, 5.3D0, 2.9D0, |
| 35402 | & 7*0.D0, 1.7D0, 3.6D0, 5.4D0, 9.D0, 7.6D0, 4.2D0, |
| 35403 | & 5*0.D0, 7.7D0, 6.1D0, 2.9D0, 5*0.D0/ |
| 35404 | * nn - data * |
| 35405 | * * |
| 35406 | DATA SPKPV/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0, |
| 35407 | & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0, |
| 35408 | & 0.D0, 3.6D0, 1.7D0, 12*0.D0, |
| 35409 | & 8.7D0, 17.7D0, 18.8D0, 15.9D0, |
| 35410 | & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0, |
| 35411 | & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0, |
| 35412 | & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0, |
| 35413 | & 5*0.D0, 4.6D0, 10.2D0, 15.1D0, 16.9D0, 16.5D0, |
| 35414 | & 11.D0, 5.5D0, 3.5D0, |
| 35415 | & 10*0.D0, 4.3D0, 7.6D0, 9.D0, |
| 35416 | & 10*0.D0, 1.7D0, 2.6D0, 3.D0, |
| 35417 | & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0, |
| 35418 | & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0, |
| 35419 | & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0, |
| 35420 | & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/ |
| 35421 | **************** ap - p - data * |
| 35422 | DATA SAPPEL/ 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, |
| 35423 | & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0, |
| 35424 | & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0, |
| 35425 | & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0, |
| 35426 | & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0, |
| 35427 | & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0, |
| 35428 | & 0.D0, 55.D0, 50.D0, 25.D0, 15.D0, 15.D0, 14.D0, 12.D0, |
| 35429 | & 10.D0, 7.D0, 6.D0, 4.D0, 3.3D0, 2.8D0, 2.4D0, 2.D0, 1.8D0, |
| 35430 | & 1.55D0, 1.3D0, .95D0, .75D0, |
| 35431 | & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, |
| 35432 | & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0, |
| 35433 | & .01D0, .008D0, .006D0, .005D0/ |
| 35434 | DATA SPIKPE/0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0, |
| 35435 | & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0, |
| 35436 | & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, |
| 35437 | & 9*0.D0, 2.D0, 2.5D0, .2D0, 19*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0, |
| 35438 | & 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0, .3D0, 1.4D0, |
| 35439 | & 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0, |
| 35440 | & .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, |
| 35441 | & .3D0, 10*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, |
| 35442 | & .6D0, .5D0, .4D0, .3D0, 9*0.D0, .6D0, 2.5D0, 5.D0, 5.2D0, 5.1D0, |
| 35443 | & 5.4D0, 5.8D0, 2.8D0, 2.1D0, 1.8D0, 1.6D0, 1.2D0, 13*0.D0, 1.3D0, |
| 35444 | & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0, |
| 35445 | & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0, |
| 35446 | & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0, |
| 35447 | & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 14*0.D0, .2D0, |
| 35448 | & .5D0, 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, |
| 35449 | & 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0, |
| 35450 | & 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0, 1.6D0, |
| 35451 | & 1.4D0, 1.1D0, .9D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0, |
| 35452 | & .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, |
| 35453 | & 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0 / |
| 35454 | **************** ap - n - data * |
| 35455 | DATA SAPNEL/ |
| 35456 | & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, |
| 35457 | & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0, |
| 35458 | & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0, |
| 35459 | & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, |
| 35460 | & .85D0, 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, |
| 35461 | & .14D0, .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0, |
| 35462 | & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, |
| 35463 | & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0, |
| 35464 | & .01D0, .008D0, .006D0, .005D0 / |
| 35465 | DATA SPIKPZ/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0, |
| 35466 | & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0, |
| 35467 | & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0, |
| 35468 | & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, |
| 35469 | & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, |
| 35470 | & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, |
| 35471 | & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, |
| 35472 | & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, |
| 35473 | & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0, |
| 35474 | & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0, |
| 35475 | & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0, |
| 35476 | & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, |
| 35477 | & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0, |
| 35478 | & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 / |
| 35479 | * * |
| 35480 | * * |
| 35481 | **************** an - p - data * |
| 35482 | * * |
| 35483 | DATA SANPEL/ |
| 35484 | & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, 50.D0, |
| 35485 | & 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0, |
| 35486 | & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0, .05D0, |
| 35487 | & .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0, |
| 35488 | & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0, |
| 35489 | & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0, |
| 35490 | & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, .25D0, |
| 35491 | & .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0, |
| 35492 | & .01D0, .008D0, .006D0, .005D0 / |
| 35493 | DATA SPIKPF/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0, |
| 35494 | & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0, |
| 35495 | & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0, |
| 35496 | & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, |
| 35497 | & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, |
| 35498 | & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, |
| 35499 | & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, |
| 35500 | & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, |
| 35501 | & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0, |
| 35502 | & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0, |
| 35503 | & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0, |
| 35504 | & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, |
| 35505 | & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0, |
| 35506 | & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 / |
| 35507 | **** ko - n - data * |
| 35508 | DATA SPKP15/0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0, 7.D0, |
| 35509 | & 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0, |
| 35510 | & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 10*0.D0, |
| 35511 | & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, |
| 35512 | & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0, |
| 35513 | & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, |
| 35514 | & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0, |
| 35515 | & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0, |
| 35516 | & 1.4D0, 1.2D0, 1.05D0, .9D0, .66D0, .5D0, |
| 35517 | & 7*0.D0, .3D0, 1.D0, 1.D0, .9D0, .7D0, .4D0, .30D0, .2D0, |
| 35518 | & 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.20D0, 4.55D0, |
| 35519 | & 4.85D0, 4.9D0, |
| 35520 | & 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0, 1.6D0, |
| 35521 | & 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0, 3.5D0, |
| 35522 | & 2.85D0, 2.35D0, 2.01D0, 1.8D0, |
| 35523 | & 12*0.D0, .1D0, .8D0, 2.05D0, 3.31D0, 3.5D0, |
| 35524 | & 12*0.D0, .034D0, .20D0, .75D0, 1.04D0, 1.24D0 / |
| 35525 | **** ako - p - data * |
| 35526 | DATA SPKP16/ 0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0, |
| 35527 | & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0, 0.D0, |
| 35528 | & 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0, 1.9D0, .9D0, .5D0, |
| 35529 | & .3D0, .24D0, .2D0, .18D0, .1D0, .09D0, 0.D0, 1.8D0, 2.D0, 1.1D0, |
| 35530 | & .9D0, .5D0, .5D0, .4D0, .4D0, .2D0, .1D0, .06D0, .05D0, .04D0, |
| 35531 | & .03D0, .02D0, .02D0, 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0, |
| 35532 | & .7D0, .65D0, .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0, |
| 35533 | & .03D0, 0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0, |
| 35534 | & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0, |
| 35535 | & 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0, |
| 35536 | & 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, |
| 35537 | & 1.01D0, .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0, |
| 35538 | & 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, |
| 35539 | & .5D0, .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, |
| 35540 | & .45D0, .39D0, .22D0, .07D0, 7*0.D0, 1.71D0, 4.26D0, 5.6D0,5.57D0, |
| 35541 | & 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0, |
| 35542 | & .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0, |
| 35543 | & .3D0, .7D0, 1.D0, 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0, |
| 35544 | & 1.72D0, 2.69D0, 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 5*0.D0, |
| 35545 | & 9.2D0, 4.7D0, 1.9D0, 9*0.D0, .0D0,2.5D0,15.D0, |
| 35546 | & 21.5D0, 15.3D0, 3.D0, 1.5D0, 10*0.D0 / |
| 35547 | DATA NURELN/9, 12, 5*0, 10, 14, 3*0, 1, 3, 5, 7, 6*0, 2, 6, 16, |
| 35548 | & 5*0, 10, 13, 5*0, 11, 12, 3*0, 2, 4, 6, 8, 6*0, 3, 15, 7, 5*0 / |
| 35549 | *= end*block.blkdt3 * |
| 35550 | END |
| 35551 | |
| 35552 | *$ CREATE DT_QEL_POL.FOR |
| 35553 | *COPY DT_QEL_POL |
| 35554 | * |
| 35555 | *===qel_pol============================================================* |
| 35556 | * |
| 35557 | SUBROUTINE DT_QEL_POL(ENU,LTYP,P21,P22,P23,P24,P25) |
| 35558 | |
| 35559 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 35560 | SAVE |
| 35561 | |
| 35562 | CALL DT_MASS_INI |
| 35563 | CALL DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25) |
| 35564 | |
| 35565 | RETURN |
| 35566 | END |
| 35567 | |
| 35568 | *$ CREATE DT_GEN_QEL.FOR |
| 35569 | *COPY DT_GEN_QEL |
| 35570 | C================================================================== |
| 35571 | C Generation of a Quasi-Elastic neutrino scattering |
| 35572 | C================================================================== |
| 35573 | * |
| 35574 | *===gen_qel============================================================* |
| 35575 | * |
| 35576 | SUBROUTINE DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25) |
| 35577 | |
| 35578 | C...Generate a quasi-elastic neutrino/antineutrino |
| 35579 | C. Interaction on a nuclear target |
| 35580 | C. INPUT : LTYP = neutrino type (1,...,6) |
| 35581 | C. ENU (GeV) = neutrino energy |
| 35582 | C---------------------------------------------------- |
| 35583 | |
| 35584 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 35585 | SAVE |
| 35586 | |
| 35587 | PARAMETER ( LINP = 10 , |
| 35588 | & LOUT = 6 , |
| 35589 | & LDAT = 9 ) |
| 35590 | PARAMETER (MAXLND=4000) |
| 35591 | COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5) |
| 35592 | * nuclear potential |
| 35593 | LOGICAL LFERMI |
| 35594 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, |
| 35595 | & EBINDP(2),EBINDN(2),EPOT(2,210), |
| 35596 | & ETACOU(2),ICOUL,LFERMI |
| 35597 | * steering flags for qel neutrino scattering modules |
| 35598 | COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC |
| 35599 | **sr - removed (not needed) |
| 35600 | C COMMON /CBAD/ LBAD, NBAD |
| 35601 | C COMMON /CNUC/ XMN,XMN2,PFERMI,EFERMI,EBIND,EB2,C0 |
| 35602 | ** |
| 35603 | |
| 35604 | DIMENSION PI(3),PO(3) |
| 35605 | CJR+ |
| 35606 | DATA ININU/0/ |
| 35607 | CJR- |
| 35608 | C REAL*8 DBETA(3) |
| 35609 | C REAL*8 MN(2), ML0(6), ML, ML2, MI, MI2, MF, MF2 |
| 35610 | DIMENSION DBETA(3),DBETB(3),AMN(2),AML0(6) |
| 35611 | DATA AMN /0.93827231D0, 0.93956563D0/ |
| 35612 | DATA AML0 /2*0.51100D-03,2*0.105659D0, 2*1.777D0/ |
| 35613 | DATA INIPRI/0/ |
| 35614 | |
| 35615 | C DATA PFERMI/0.22D0/ |
| 35616 | CGB+...Binding Energy |
| 35617 | DATA EBIND/0.008D0/ |
| 35618 | CGB-... |
| 35619 | |
| 35620 | ININU=ININU+1 |
| 35621 | IF(ININU.EQ.1)NDSIG=0 |
| 35622 | LBAD = 0 |
| 35623 | enu0=enu |
| 35624 | c write(*,*) enu0 |
| 35625 | C...Lepton mass |
| 35626 | AML = AML0(LTYP) ! massa leptoni |
| 35627 | AML2 = AML**2 ! massa leptoni **2 |
| 35628 | C...Particle labels (LUND) |
| 35629 | N = 5 |
| 35630 | K(1,1) = 21 |
| 35631 | K(2,1) = 21 |
| 35632 | K(3,1) = 21 |
| 35633 | K(3,3) = 1 |
| 35634 | K(4,1) = 1 |
| 35635 | K(4,3) = 1 |
| 35636 | K(5,1) = 1 |
| 35637 | K(5,3) = 2 |
| 35638 | K0 = (LTYP-1)/2 ! 2 |
| 35639 | K1 = LTYP/2 ! 2 |
| 35640 | KA = 12 + 2*K0 ! 16 |
| 35641 | IS = -1 + 2*LTYP - 4*K1 ! -1 +10 -8 = 1 |
| 35642 | K(1,2) = IS*KA |
| 35643 | K(4,2) = IS*(KA-1) |
| 35644 | K(3,2) = IS*24 |
| 35645 | LNU = 2 - LTYP + 2*K1 ! 2 - 5 + 2 = - 1 |
| 35646 | IF (LNU .EQ. 2) THEN |
| 35647 | K(2,2) = 2212 |
| 35648 | K(5,2) = 2112 |
| 35649 | AMI = AMN(1) |
| 35650 | AMF = AMN(2) |
| 35651 | CJR+ |
| 35652 | PFERMI=PFERMN(2) |
| 35653 | CJR- |
| 35654 | ELSE |
| 35655 | K(2,2) = 2112 |
| 35656 | K(5,2) = 2212 |
| 35657 | AMI = AMN(2) |
| 35658 | AMF = AMN(1) |
| 35659 | CJR+ |
| 35660 | PFERMI=PFERMP(2) |
| 35661 | CJR- |
| 35662 | ENDIF |
| 35663 | AMI2 = AMI**2 |
| 35664 | AMF2 = AMF**2 |
| 35665 | |
| 35666 | DO IGB=1,5 |
| 35667 | P(3,IGB) = 0. |
| 35668 | P(4,IGB) = 0. |
| 35669 | P(5,IGB) = 0. |
| 35670 | END DO |
| 35671 | |
| 35672 | NTRY = 0 |
| 35673 | CGB+... |
| 35674 | EFMAX = SQRT(PFERMI**2 + AMI2) -AMI ! max. Fermi Energy |
| 35675 | ENWELL = EFMAX + EBIND ! depth of nuclear potential well |
| 35676 | CGB-... |
| 35677 | |
| 35678 | 100 CONTINUE |
| 35679 | |
| 35680 | C...4-momentum initial lepton |
| 35681 | P(1,5) = 0. ! massa |
| 35682 | P(1,4) = ENU0 ! energia |
| 35683 | P(1,1) = 0. ! px |
| 35684 | P(1,2) = 0. ! py |
| 35685 | P(1,3) = ENU0 ! pz |
| 35686 | |
| 35687 | C PF = PFERMI*PYR(0)**(1./3.) |
| 35688 | c write(23,*) PYR(0) |
| 35689 | c write(*,*) 'Pfermi=',PF |
| 35690 | c PF = 0. |
| 35691 | NTRY=NTRY+1 |
| 35692 | C IF(ntry.GT.2) WRITE(*,*) ntry,enu0,k2 |
| 35693 | IF (NTRY .GT. 500) THEN |
| 35694 | LBAD = 1 |
| 35695 | WRITE (LOUT,1001) NBAD, ENU |
| 35696 | RETURN |
| 35697 | ENDIF |
| 35698 | C CT = -1. + 2.*PYR(0) |
| 35699 | c CT = -1. |
| 35700 | C ST = SQRT(1.-CT*CT) |
| 35701 | C F = 2.*3.1415926*PYR(0) |
| 35702 | c F = 0. |
| 35703 | |
| 35704 | C P(2,4) = SQRT(PF*PF + MI2) - EBIND ! energia |
| 35705 | C P(2,1) = PF*ST*COS(F) ! px |
| 35706 | C P(2,2) = PF*ST*SIN(F) ! py |
| 35707 | C P(2,3) = PF*CT ! pz |
| 35708 | C P(2,5) = SQRT(P(2,4)**2-PF*PF) ! massa |
| 35709 | P(2,1) = P21 |
| 35710 | P(2,2) = P22 |
| 35711 | P(2,3) = P23 |
| 35712 | P(2,4) = P24 |
| 35713 | P(2,5) = P25 |
| 35714 | beta1=-p(2,1)/p(2,4) |
| 35715 | beta2=-p(2,2)/p(2,4) |
| 35716 | beta3=-p(2,3)/p(2,4) |
| 35717 | N=2 |
| 35718 | C WRITE(6,*)' before transforming into target rest frame' |
| 35719 | CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3) |
| 35720 | C print*,' nucl. rest fram ( fermi incl.) prima della rotazione' |
| 35721 | N=5 |
| 35722 | |
| 35723 | phi11=atan(p(1,2)/p(1,3)) |
| 35724 | pi(1)=p(1,1) |
| 35725 | pi(2)=p(1,2) |
| 35726 | pi(3)=p(1,3) |
| 35727 | |
| 35728 | CALL DT_TESTROT(PI,Po,PHI11,1) |
| 35729 | DO ll=1,3 |
| 35730 | IF(abs(po(ll)).LT.1.D-07) po(ll)=0. |
| 35731 | END DO |
| 35732 | c WRITE(*,*) po |
| 35733 | p(1,1)=po(1) |
| 35734 | p(1,2)=po(2) |
| 35735 | p(1,3)=po(3) |
| 35736 | phi12=atan(p(1,1)/p(1,3)) |
| 35737 | |
| 35738 | pi(1)=p(1,1) |
| 35739 | pi(2)=p(1,2) |
| 35740 | pi(3)=p(1,3) |
| 35741 | CALL DT_TESTROT(Pi,Po,PHI12,2) |
| 35742 | DO ll=1,3 |
| 35743 | IF(abs(po(ll)).LT.1.D-07) po(ll)=0. |
| 35744 | END DO |
| 35745 | c WRITE(*,*) po |
| 35746 | p(1,1)=po(1) |
| 35747 | p(1,2)=po(2) |
| 35748 | p(1,3)=po(3) |
| 35749 | |
| 35750 | enu=p(1,4) |
| 35751 | |
| 35752 | C...Kinematical limits in Q**2 |
| 35753 | c S = P(2,5)**2 + 2.*ENU*(P(2,4)-P(2,3)) ! ???? |
| 35754 | S = P(2,5)**2 + 2.*ENU*P(2,5) |
| 35755 | SQS = SQRT(S) ! E centro massa |
| 35756 | IF (SQS .LT. (AML + AMF + 3.E-03)) GOTO 100 |
| 35757 | ELF = (S-AMF2+AML2)/(2.*SQS) ! energia leptone finale p |
| 35758 | PSTAR = (S-P(2,5)**2)/(2.*SQS) ! p* neutrino nel c.m. |
| 35759 | PLF = SQRT(ELF**2-AML2) ! 3-momento leptone finale |
| 35760 | Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF) ! + o - |
| 35761 | Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF) ! according con cos(theta) |
| 35762 | IF (Q2MIN .LT. 0.) Q2MIN = 0. ! ??? non fisico |
| 35763 | |
| 35764 | C...Generate Q**2 |
| 35765 | DSIGMAX = DT_DSQEL_Q2 (LTYP,ENU, Q2MIN) |
| 35766 | 200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0) |
| 35767 | DSIG = DT_DSQEL_Q2 (LTYP,ENU, Q2) |
| 35768 | IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200 |
| 35769 | CALL DT_QGAUS(Q2MIN,Q2MAX,DSIGEV,ENU,LTYP) |
| 35770 | NDSIG=NDSIG+1 |
| 35771 | C WRITE(6,*)' Q2,Q2min,Q2MAX,DSIGEV', |
| 35772 | C &Q2,Q2min,Q2MAX,DSIGEV |
| 35773 | |
| 35774 | C...c.m. frame. Neutrino along z axis |
| 35775 | DETOT = (P(1,4)) + (P(2,4)) ! e totale |
| 35776 | DBETA(1) = ((P(1,1)) + (P(2,1)))/DETOT ! px1+px2/etot = beta_x |
| 35777 | DBETA(2) = ((P(1,2)) + (P(2,2)))/DETOT ! |
| 35778 | DBETA(3) = ((P(1,3)) + (P(2,3)))/DETOT ! |
| 35779 | c WRITE(*,*) |
| 35780 | c WRITE(*,*) |
| 35781 | C WRITE(*,*) 'Input values laboratory frame' |
| 35782 | N=2 |
| 35783 | |
| 35784 | CALL PYROBO(0,0,0.0D0,0.0D0,-DBETA(1),-DBETA(2),-DBETA(3)) |
| 35785 | |
| 35786 | N=5 |
| 35787 | c STHETA = ULANGL(P(1,3),P(1,1)) |
| 35788 | c write(*,*) 'stheta' ,stheta |
| 35789 | c stheta=0. |
| 35790 | c CALL PYROBO (0,0,-STHETA,0.,0.D0,0.D0,0.D0) |
| 35791 | c WRITE(*,*) |
| 35792 | c WRITE(*,*) |
| 35793 | C WRITE(*,*) 'Output values cm frame' |
| 35794 | C...Kinematic in c.m. frame |
| 35795 | CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF) ! cos(theta) cm |
| 35796 | STSTAR = SQRT(1.-CTSTAR**2) |
| 35797 | PHI = 6.28319*PYR(0) ! random phi tra 0 e 2*pi |
| 35798 | P(4,5) = AML ! massa leptone |
| 35799 | P(4,4) = ELF ! e leptone |
| 35800 | P(4,3) = PLF*CTSTAR ! px |
| 35801 | P(4,1) = PLF*STSTAR*COS(PHI) ! py |
| 35802 | P(4,2) = PLF*STSTAR*SIN(PHI) ! pz |
| 35803 | |
| 35804 | P(5,5) = AMF ! barione |
| 35805 | P(5,4) = (S+AMF2-AML2)/(2.*SQS)! e barione |
| 35806 | P(5,3) = -P(4,3) ! px |
| 35807 | P(5,1) = -P(4,1) ! py |
| 35808 | P(5,2) = -P(4,2) ! pz |
| 35809 | |
| 35810 | P(3,5) = -Q2 |
| 35811 | P(3,1) = P(1,1)-P(4,1) |
| 35812 | P(3,2) = P(1,2)-P(4,2) |
| 35813 | P(3,3) = P(1,3)-P(4,3) |
| 35814 | P(3,4) = P(1,4)-P(4,4) |
| 35815 | |
| 35816 | C...Transform back to laboratory frame |
| 35817 | C WRITE(*,*) 'before going back to nucl rest frame' |
| 35818 | c CALL PYROBO (0,0,STHETA,0.,0.D0,0.D0,0.D0) |
| 35819 | N=5 |
| 35820 | |
| 35821 | CALL PYROBO(0,0,0.0D0,0.0D0,DBETA(1),DBETA(2),DBETA(3)) |
| 35822 | |
| 35823 | C WRITE(*,*) 'Now back in nucl rest frame' |
| 35824 | IF(LTYP.GE.3) CALL DT_PREPOLA(Q2,LTYP,ENU) |
| 35825 | |
| 35826 | c******************************************** |
| 35827 | |
| 35828 | DO kw=1,5 |
| 35829 | pi(1)=p(kw,1) |
| 35830 | pi(2)=p(kw,2) |
| 35831 | pi(3)=p(kw,3) |
| 35832 | CALL DT_TESTROT(Pi,Po,PHI12,3) |
| 35833 | DO ll=1,3 |
| 35834 | IF(abs(po(ll)).LT.1.D-07) po(ll)=0. |
| 35835 | END DO |
| 35836 | p(kw,1)=po(1) |
| 35837 | p(kw,2)=po(2) |
| 35838 | p(kw,3)=po(3) |
| 35839 | END DO |
| 35840 | c******************************************** |
| 35841 | |
| 35842 | DO kw=1,5 |
| 35843 | pi(1)=p(kw,1) |
| 35844 | pi(2)=p(kw,2) |
| 35845 | pi(3)=p(kw,3) |
| 35846 | CALL DT_TESTROT(Pi,Po,PHI11,4) |
| 35847 | DO ll=1,3 |
| 35848 | IF(abs(po(ll)).LT.1.D-07) po(ll)=0. |
| 35849 | END DO |
| 35850 | p(kw,1)=po(1) |
| 35851 | p(kw,2)=po(2) |
| 35852 | p(kw,3)=po(3) |
| 35853 | END DO |
| 35854 | |
| 35855 | c******************************************** |
| 35856 | |
| 35857 | C WRITE(*,*) 'Now back in lab frame' |
| 35858 | |
| 35859 | CALL PYROBO(1,5,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3) |
| 35860 | |
| 35861 | CGB+... |
| 35862 | C...test (on final momentum of nucleon) if Fermi-blocking |
| 35863 | C...is operating |
| 35864 | ENUCL = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2 + P(5,5)**2) |
| 35865 | & - P(5,5) |
| 35866 | IF (ENUCL.LT. EFMAX) THEN |
| 35867 | IF(INIPRI.LT.10)THEN |
| 35868 | INIPRI=INIPRI+1 |
| 35869 | C WRITE(6,*)' qel: Pauli ENUCL.LT.EFMAX ', ENUCL,EFMAX |
| 35870 | C...the interaction is not possible due to Pauli-Blocking and |
| 35871 | C...it must be resampled |
| 35872 | ENDIF |
| 35873 | GOTO 100 |
| 35874 | ELSE IF (ENUCL.LT.ENWELL.and.ENUCL.GE.EFMAX) THEN |
| 35875 | IF(INIPRI.LT.10)THEN |
| 35876 | INIPRI=INIPRI+1 |
| 35877 | C WRITE(6,*)' qel: inside ENUCL.LT.ENWELL ', ENUCL,ENWELL |
| 35878 | ENDIF |
| 35879 | C Reject (J:R) here all these events |
| 35880 | C are otherwise rejected in dpmjet |
| 35881 | GOTO 100 |
| 35882 | C...the interaction is possible, but the nucleon remains inside |
| 35883 | C...the nucleus. The nucleus is therefore left excited. |
| 35884 | C...We treat this case as a nucleon with 0 kinetic energy. |
| 35885 | C P(5,5) = AMF |
| 35886 | C P(5,4) = AMF |
| 35887 | C P(5,1) = 0. |
| 35888 | C P(5,2) = 0. |
| 35889 | C P(5,3) = 0. |
| 35890 | ELSE IF (ENUCL.GE.ENWELL) THEN |
| 35891 | C WRITE(6,*)' qel ENUCL.GE.ENWELL ',ENUCL,ENWELL |
| 35892 | C...the interaction is possible, the nucleon can exit the nucleus |
| 35893 | C...but the nuclear well depth must be subtracted. The nucleus could be |
| 35894 | C...left in an excited state. |
| 35895 | Pstart = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2) |
| 35896 | C P(5,4) = ENUCL-ENWELL + AMF |
| 35897 | Pnucl = SQRT(P(5,4)**2-AMF**2) |
| 35898 | C...The 3-momentum is scaled assuming that the direction remains |
| 35899 | C...unaffected |
| 35900 | P(5,1) = P(5,1) * Pnucl/Pstart |
| 35901 | P(5,2) = P(5,2) * Pnucl/Pstart |
| 35902 | P(5,3) = P(5,3) * Pnucl/Pstart |
| 35903 | C WRITE(6,*)' qel new P(5,4) ',P(5,4) |
| 35904 | ENDIF |
| 35905 | CGB-... |
| 35906 | DSIGSU=DSIGSU+DSIGEV |
| 35907 | |
| 35908 | GA=P(4,4)/P(4,5) |
| 35909 | BGX=P(4,1)/P(4,5) |
| 35910 | BGY=P(4,2)/P(4,5) |
| 35911 | BGZ=P(4,3)/P(4,5) |
| 35912 | * |
| 35913 | DBETB(1)=BGX/GA |
| 35914 | DBETB(2)=BGY/GA |
| 35915 | DBETB(3)=BGZ/GA |
| 35916 | IF(NEUDEC.EQ.1.OR.NEUDEC.EQ.2) THEN |
| 35917 | |
| 35918 | CALL PYROBO(6,8,0.0D0,0.0D0,DBETB(1),DBETB(2),DBETB(3)) |
| 35919 | |
| 35920 | ENDIF |
| 35921 | c |
| 35922 | C PRINT*,' FINE EVENTO ' |
| 35923 | enu=enu0 |
| 35924 | RETURN |
| 35925 | |
| 35926 | 1001 FORMAT(2X, 'DT_GEN_QEL : event rejected ', I5, G10.3) |
| 35927 | END |
| 35928 | |
| 35929 | *$ CREATE DT_MASS_INI.FOR |
| 35930 | *COPY DT_MASS_INI |
| 35931 | C==================================================================== |
| 35932 | C. Masses |
| 35933 | C==================================================================== |
| 35934 | * |
| 35935 | *===mass_ini===========================================================* |
| 35936 | * |
| 35937 | SUBROUTINE DT_MASS_INI |
| 35938 | C...Initialize the kinematics for the quasi-elastic cross section |
| 35939 | |
| 35940 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 35941 | SAVE |
| 35942 | |
| 35943 | * particle masses used in qel neutrino scattering modules |
| 35944 | COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6), |
| 35945 | & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN, |
| 35946 | & EMPROTSQ,EMNEUTSQ,EMNSQ |
| 35947 | |
| 35948 | EML(1) = 0.51100D-03 ! e- |
| 35949 | EML(2) = EML(1) ! e+ |
| 35950 | EML(3) = 0.105659D0 ! mu- |
| 35951 | EML(4) = EML(3) ! mu+ |
| 35952 | EML(5) = 1.7777D0 ! tau- |
| 35953 | EML(6) = EML(5) ! tau+ |
| 35954 | EMPROT = 0.93827231D0 ! p |
| 35955 | EMNEUT = 0.93956563D0 ! n |
| 35956 | EMPROTSQ = EMPROT**2 |
| 35957 | EMNEUTSQ = EMNEUT**2 |
| 35958 | EMN = (EMPROT + EMNEUT)/2. |
| 35959 | EMNSQ = EMN**2 |
| 35960 | DO J=1,3 |
| 35961 | J0 = 2*(J-1) |
| 35962 | EMN1(J0+1) = EMNEUT |
| 35963 | EMN1(J0+2) = EMPROT |
| 35964 | EMN2(J0+1) = EMPROT |
| 35965 | EMN2(J0+2) = EMNEUT |
| 35966 | ENDDO |
| 35967 | DO J=1,6 |
| 35968 | EMLSQ(J) = EML(J)**2 |
| 35969 | ETQE(J) = ((EMN2(J)+ EML(J))**2-EMN1(J)**2)/(2.*EMN1(J)) |
| 35970 | ENDDO |
| 35971 | RETURN |
| 35972 | END |
| 35973 | |
| 35974 | *$ CREATE DT_DSQEL_Q2.FOR |
| 35975 | *COPY DT_DSQEL_Q2 |
| 35976 | * |
| 35977 | *===dsqel_q2===========================================================* |
| 35978 | * |
| 35979 | DOUBLE PRECISION FUNCTION DT_DSQEL_Q2 (JTYP,ENU, Q2) |
| 35980 | |
| 35981 | C...differential cross section for Quasi-Elastic scattering |
| 35982 | C. nu + N -> l + N' |
| 35983 | C. From Llewellin Smith Phys.Rep. 3C, 261, (1971). |
| 35984 | C. |
| 35985 | C. INPUT : JTYP = 1,...,6 nu_e, ...., nubar_tau |
| 35986 | C. ENU (GeV) = Neutrino energy |
| 35987 | C. Q2 (GeV**2) = (Transfer momentum)**2 |
| 35988 | C. |
| 35989 | C. OUTPUT : DSQEL_Q2 = differential cross section : |
| 35990 | C. dsigma/dq**2 (10**-38 cm+2/GeV**2) |
| 35991 | C------------------------------------------------------------------ |
| 35992 | |
| 35993 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 35994 | SAVE |
| 35995 | |
| 35996 | * particle masses used in qel neutrino scattering modules |
| 35997 | COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6), |
| 35998 | & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN, |
| 35999 | & EMPROTSQ,EMNEUTSQ,EMNSQ |
| 36000 | **sr - removed (not needed) |
| 36001 | C COMMON /CAXIAL/ FA0, AXIAL2 |
| 36002 | ** |
| 36003 | |
| 36004 | DIMENSION SS(6) |
| 36005 | DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2 |
| 36006 | DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/ |
| 36007 | DATA AXIAL2 /1.03D0/ ! to be checked |
| 36008 | |
| 36009 | FA0=-1.253D0 |
| 36010 | CSI = 3.71D0 ! ??? |
| 36011 | GVE = 1.D0/ (1.D0 + Q2/0.84D0**2)**2 ! G_e(q**2) |
| 36012 | GVM = (1.D0+CSI)*GVE ! G_m (q**2) |
| 36013 | X = Q2/(EMN*EMN) ! emn=massa barione |
| 36014 | XA = X/4.D0 |
| 36015 | FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM) |
| 36016 | FV2 = 1.D0/(1.D0+XA)*(GVM-GVE) |
| 36017 | FA = FA0/(1.D0 + Q2/AXIAL2)**2 |
| 36018 | FFA = FA*FA |
| 36019 | FFV1 = FV1*FV1 |
| 36020 | FFV2 = FV2*FV2 |
| 36021 | RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp) |
| 36022 | A1 = (4.D0+X)*FFA - (4.D0-X)*FFV1 + X*FFV2*(1.D0-XA)+4*X*FV1*FV2 |
| 36023 | A2 = -RM * ((FV1 + FV2)**2 + FFA) |
| 36024 | AA = (XA+0.25D0*RM)*(A1 + A2) |
| 36025 | BB = -X*FA*(FV1 + FV2) |
| 36026 | CC = 0.25D0*(FFA + FFV1 + XA*FFV2) |
| 36027 | SU = (4.D0*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN) |
| 36028 | DT_DSQEL_Q2 = C0*(AA + SS(JTYP)*BB*SU + CC*SU*SU) / (ENU*ENU) ! |
| 36029 | IF(DT_DSQEL_Q2 .LT. 0.D0) DT_DSQEL_Q2 = 0.D0 |
| 36030 | |
| 36031 | RETURN |
| 36032 | END |
| 36033 | |
| 36034 | *$ CREATE DT_PREPOLA.FOR |
| 36035 | *COPY DT_PREPOLA |
| 36036 | * |
| 36037 | *===prepola============================================================* |
| 36038 | * |
| 36039 | SUBROUTINE DT_PREPOLA(Q2,JTYP,ENU) |
| 36040 | |
| 36041 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 36042 | SAVE |
| 36043 | c |
| 36044 | c By G. Battistoni and E. Scapparone (sept. 1997) |
| 36045 | c According to: |
| 36046 | c Albright & Jarlskog, Nucl Phys B84 (1975) 467 |
| 36047 | c |
| 36048 | c |
| 36049 | PARAMETER (MAXLND=4000) |
| 36050 | COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5) |
| 36051 | COMMON /QNPOL/ POLARX(4),PMODUL |
| 36052 | * particle masses used in qel neutrino scattering modules |
| 36053 | COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6), |
| 36054 | & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN, |
| 36055 | & EMPROTSQ,EMNEUTSQ,EMNSQ |
| 36056 | * steering flags for qel neutrino scattering modules |
| 36057 | COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC |
| 36058 | **sr - removed (not needed) |
| 36059 | C COMMON /CAXIAL/ FA0, AXIAL2 |
| 36060 | C COMMON /TAUTAU/Q(4,5),ETL,PXL,PYL,PZL, |
| 36061 | C & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN |
| 36062 | ** |
| 36063 | REAL*8 POL(4,4),BB2(3) |
| 36064 | DIMENSION SS(6) |
| 36065 | C DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2 |
| 36066 | DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/ |
| 36067 | **sr uncommented since common block CAXIAL is now commented |
| 36068 | DATA AXIAL2 /1.03D0/ ! to be checked |
| 36069 | ** |
| 36070 | |
| 36071 | RML=P(4,5) |
| 36072 | RMM=0.93960D+00 |
| 36073 | FM2 = RMM**2 |
| 36074 | MPI = 0.135D+00 |
| 36075 | OLDQ2=Q2 |
| 36076 | FA0=-1.253D+00 |
| 36077 | CSI = 3.71D+00 ! |
| 36078 | GVE = 1.D0/ (1.D0 + Q2/(0.84D+00)**2)**2 ! G_e(q**2) |
| 36079 | GVM = (1.D0+CSI)*GVE ! G_m (q**2) |
| 36080 | X = Q2/(EMN*EMN) ! emn=massa barione |
| 36081 | XA = X/4.D0 |
| 36082 | FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM) |
| 36083 | FV2 = 1.D0/(1.D0+XA)*(GVM-GVE) |
| 36084 | FA = FA0/(1.D0 + Q2/AXIAL2**2)**2 |
| 36085 | FFA = FA*FA |
| 36086 | FFV1 = FV1*FV1 |
| 36087 | FFV2 = FV2*FV2 |
| 36088 | FP=2.D0*FA*RMM/(MPI**2 + Q2) |
| 36089 | RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp) |
| 36090 | A1 = (4.D0+X)*FFA-(4.D0-X)*FFV1+X*FFV2*(1.D0-XA)+4.D0*X*FV1*FV2 |
| 36091 | A2 = -RM * ((FV1 + FV2)**2 + FFA) |
| 36092 | AA = (XA+0.25D+00*RM)*(A1 + A2) |
| 36093 | BB = -X*FA*(FV1 + FV2) |
| 36094 | CC = 0.25D+00*(FFA + FFV1 + XA*FFV2) |
| 36095 | SU = (4.D+00*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN) |
| 36096 | |
| 36097 | OMEGA1=FFA+XA*(FFA+(FV1+FV2)**2 ) ! articolo di ll...-smith |
| 36098 | OMEGA2=4.D+00*CC |
| 36099 | OMEGA3=2.D+00*FA*(FV1+FV2) |
| 36100 | OMEGA4P=(-(FV1+FV2)**2-(FA+2*FP)**2+(4.0D+00+ |
| 36101 | 1 (Q2/FM2))*FP**2) |
| 36102 | OMEGA5=OMEGA2 |
| 36103 | OMEGA4=(OMEGA4P-OMEGA2+2*OMEGA5)/4.D+00 |
| 36104 | WW1=2.D+00*OMEGA1*EMN**2 |
| 36105 | WW2=2.D+00*OMEGA2*EMN**2 |
| 36106 | WW3=2.D+00*OMEGA3*EMN**2 |
| 36107 | WW4=2.D+00*OMEGA4*EMN**2 |
| 36108 | WW5=2.D+00*OMEGA5*EMN**2 |
| 36109 | |
| 36110 | DO I=1,3 |
| 36111 | BB2(I)=-P(4,I)/P(4,4) |
| 36112 | END DO |
| 36113 | c WRITE(*,*) |
| 36114 | c WRITE(*,*) |
| 36115 | c WRITE(*,*) 'Prepola: ready to transform to lepton rest frame' |
| 36116 | N=5 |
| 36117 | CALL PYROBO(0,0,0.0D0,0.0D0,BB2(1),BB2(2),BB2(3)) |
| 36118 | * NOW PARTICLES ARE IN THE SCATTERED LEPTON REST FRAME |
| 36119 | c WRITE(*,*) |
| 36120 | c WRITE(*,*) |
| 36121 | c WRITE(*,*) 'Prepola: now in lepton rest frame' |
| 36122 | EE=ENU |
| 36123 | QM2=Q2+RML**2 |
| 36124 | U=Q2/(2.*RMM) |
| 36125 | FRAC=QM2*WW1 + (2.D+00*EE*(EE-U) - 0.5D+00*QM2)*WW2 - SS(JTYP)* |
| 36126 | + (0.5D+00/(RMM**2))*(2.D+00*RMM*EE*Q2 - U*QM2)*WW3 + |
| 36127 | + ((RML**2)/(2.D+00*FM2))*(QM2*WW4-2.D+00*RMM*EE*WW5) !<=FM2 inv di RMM!! |
| 36128 | |
| 36129 | FACTK=2.D+00*WW1 -WW2 -SS(JTYP)*(EE/RMM)*WW3 +((EE-U)/RMM)*WW5 |
| 36130 | + - ((RML**2)/FM2)*WW4 !<=FM2 inv di RMM!! |
| 36131 | |
| 36132 | FACTP=2.D+00*EE/RMM*WW2 - (QM2/(2.D+00*RMM**2))*(SS(JTYP)*WW3+WW5) |
| 36133 | |
| 36134 | DO I=1,3 |
| 36135 | POL(4,I)=RML*SS(JTYP)*(FACTK*P(1,I)+FACTP*P(2,I))/FRAC |
| 36136 | POLARX(I)=POL(4,I) |
| 36137 | END DO |
| 36138 | |
| 36139 | PMODUL=0.D0 |
| 36140 | DO I=1,3 |
| 36141 | PMODUL=PMODUL+POL(4,I)**2 |
| 36142 | END DO |
| 36143 | |
| 36144 | IF(JTYP.GT.4.AND.NEUDEC.GT.0) THEN |
| 36145 | IF(NEUDEC.EQ.1) THEN |
| 36146 | CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-2),POLARX(3), |
| 36147 | + ETL,PXL,PYL,PZL, |
| 36148 | + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN) |
| 36149 | c |
| 36150 | c Tau has decayed in muon |
| 36151 | c |
| 36152 | ENDIF |
| 36153 | IF(NEUDEC.EQ.2) THEN |
| 36154 | CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-4),POLARX(3), |
| 36155 | + ETL,PXL,PYL,PZL, |
| 36156 | + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN) |
| 36157 | c |
| 36158 | c Tau has decayed in electron |
| 36159 | c |
| 36160 | ENDIF |
| 36161 | K(4,1)=15 |
| 36162 | K(4,4) = 6 |
| 36163 | K(4,5) = 8 |
| 36164 | N=N+3 |
| 36165 | c |
| 36166 | c fill common for muon(electron) |
| 36167 | c |
| 36168 | P(6,1)=PXL |
| 36169 | P(6,2)=PYL |
| 36170 | P(6,3)=PZL |
| 36171 | P(6,4)=ETL |
| 36172 | K(6,1)=1 |
| 36173 | IF(JTYP.EQ.5) THEN |
| 36174 | IF(NEUDEC.EQ.1) THEN |
| 36175 | P(6,5)=EML(JTYP-2) |
| 36176 | K(6,2)=13 |
| 36177 | ELSEIF(NEUDEC.EQ.2) THEN |
| 36178 | P(6,5)=EML(JTYP-4) |
| 36179 | K(6,2)=11 |
| 36180 | ENDIF |
| 36181 | ELSEIF(JTYP.EQ.6) THEN |
| 36182 | IF(NEUDEC.EQ.1) THEN |
| 36183 | K(6,2)=-13 |
| 36184 | ELSEIF(NEUDEC.EQ.2) THEN |
| 36185 | K(6,2)=-11 |
| 36186 | ENDIF |
| 36187 | END IF |
| 36188 | K(6,3)=4 |
| 36189 | K(6,4)=0 |
| 36190 | K(6,5)=0 |
| 36191 | c |
| 36192 | c fill common for tau_(anti)neutrino |
| 36193 | c |
| 36194 | P(7,1)=PXB |
| 36195 | P(7,2)=PYB |
| 36196 | P(7,3)=PZB |
| 36197 | P(7,4)=ETB |
| 36198 | P(7,5)=0. |
| 36199 | K(7,1)=1 |
| 36200 | IF(JTYP.EQ.5) THEN |
| 36201 | K(7,2)=16 |
| 36202 | ELSEIF(JTYP.EQ.6) THEN |
| 36203 | K(7,2)=-16 |
| 36204 | END IF |
| 36205 | K(7,3)=4 |
| 36206 | K(7,4)=0 |
| 36207 | K(7,5)=0 |
| 36208 | c |
| 36209 | c Fill common for muon(electron)_(anti)neutrino |
| 36210 | c |
| 36211 | P(8,1)=PXN |
| 36212 | P(8,2)=PYN |
| 36213 | P(8,3)=PZN |
| 36214 | P(8,4)=ETN |
| 36215 | P(8,5)=0. |
| 36216 | K(8,1)=1 |
| 36217 | IF(JTYP.EQ.5) THEN |
| 36218 | IF(NEUDEC.EQ.1) THEN |
| 36219 | K(8,2)=-14 |
| 36220 | ELSEIF(NEUDEC.EQ.2) THEN |
| 36221 | K(8,2)=-12 |
| 36222 | ENDIF |
| 36223 | ELSEIF(JTYP.EQ.6) THEN |
| 36224 | IF(NEUDEC.EQ.1) THEN |
| 36225 | K(8,2)=14 |
| 36226 | ELSEIF(NEUDEC.EQ.2) THEN |
| 36227 | K(8,2)=12 |
| 36228 | ENDIF |
| 36229 | END IF |
| 36230 | K(8,3)=4 |
| 36231 | K(8,4)=0 |
| 36232 | K(8,5)=0 |
| 36233 | ENDIF |
| 36234 | c WRITE(*,*) |
| 36235 | c WRITE(*,*) |
| 36236 | |
| 36237 | c IF(PMODUL.GE.1.D+00) THEN |
| 36238 | c WRITE(*,*) 'Pol',(POLARX(I),I=1,3) |
| 36239 | c write(*,*) pmodul |
| 36240 | c DO I=1,3 |
| 36241 | c POL(4,I)=POL(4,I)/PMODUL |
| 36242 | c POLARX(I)=POL(4,I) |
| 36243 | c END DO |
| 36244 | c PMODUL=0. |
| 36245 | c DO I=1,3 |
| 36246 | c PMODUL=PMODUL+POL(4,I)**2 |
| 36247 | c END DO |
| 36248 | c WRITE(*,*) 'Pol',(POLARX(I),I=1,3) |
| 36249 | c |
| 36250 | c ENDIF |
| 36251 | |
| 36252 | c WRITE(*,*) 'PMODUL = ',PMODUL |
| 36253 | |
| 36254 | c WRITE(*,*) |
| 36255 | c WRITE(*,*) |
| 36256 | c WRITE(*,*) 'prepola: Now back to nucl rest frame' |
| 36257 | CALL PYROBO(1,5,0.0D0,0.0D0,-BB2(1),-BB2(2),-BB2(3)) |
| 36258 | |
| 36259 | XDC = V(4,1)+V(4,5)*P(4,1)/P(4,5) |
| 36260 | YDC = V(4,2)+V(4,5)*P(4,2)/P(4,5) |
| 36261 | ZDC = V(4,3)+V(4,5)*P(4,3)/P(4,5) |
| 36262 | DO NDC =6,8 |
| 36263 | V(NDC,1) = XDC |
| 36264 | V(NDC,2) = YDC |
| 36265 | V(NDC,3) = ZDC |
| 36266 | END DO |
| 36267 | |
| 36268 | RETURN |
| 36269 | END |
| 36270 | |
| 36271 | *$ CREATE DT_TESTROT.FOR |
| 36272 | *COPY DT_TESTROT |
| 36273 | * |
| 36274 | *===testrot============================================================* |
| 36275 | * |
| 36276 | SUBROUTINE DT_TESTROT(PI,PO,PHI,MODE) |
| 36277 | |
| 36278 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 36279 | SAVE |
| 36280 | |
| 36281 | DIMENSION ROT(3,3),PI(3),PO(3) |
| 36282 | |
| 36283 | IF (MODE.EQ.1) THEN |
| 36284 | ROT(1,1) = 1.D0 |
| 36285 | ROT(1,2) = 0.D0 |
| 36286 | ROT(1,3) = 0.D0 |
| 36287 | ROT(2,1) = 0.D0 |
| 36288 | ROT(2,2) = COS(PHI) |
| 36289 | ROT(2,3) = -SIN(PHI) |
| 36290 | ROT(3,1) = 0.D0 |
| 36291 | ROT(3,2) = SIN(PHI) |
| 36292 | ROT(3,3) = COS(PHI) |
| 36293 | ELSEIF (MODE.EQ.2) THEN |
| 36294 | ROT(1,1) = 0.D0 |
| 36295 | ROT(1,2) = 1.D0 |
| 36296 | ROT(1,3) = 0.D0 |
| 36297 | ROT(2,1) = COS(PHI) |
| 36298 | ROT(2,2) = 0.D0 |
| 36299 | ROT(2,3) = -SIN(PHI) |
| 36300 | ROT(3,1) = SIN(PHI) |
| 36301 | ROT(3,2) = 0.D0 |
| 36302 | ROT(3,3) = COS(PHI) |
| 36303 | ELSEIF (MODE.EQ.3) THEN |
| 36304 | ROT(1,1) = 0.D0 |
| 36305 | ROT(2,1) = 1.D0 |
| 36306 | ROT(3,1) = 0.D0 |
| 36307 | ROT(1,2) = COS(PHI) |
| 36308 | ROT(2,2) = 0.D0 |
| 36309 | ROT(3,2) = -SIN(PHI) |
| 36310 | ROT(1,3) = SIN(PHI) |
| 36311 | ROT(2,3) = 0.D0 |
| 36312 | ROT(3,3) = COS(PHI) |
| 36313 | ELSEIF (MODE.EQ.4) THEN |
| 36314 | ROT(1,1) = 1.D0 |
| 36315 | ROT(2,1) = 0.D0 |
| 36316 | ROT(3,1) = 0.D0 |
| 36317 | ROT(1,2) = 0.D0 |
| 36318 | ROT(2,2) = COS(PHI) |
| 36319 | ROT(3,2) = -SIN(PHI) |
| 36320 | ROT(1,3) = 0.D0 |
| 36321 | ROT(2,3) = SIN(PHI) |
| 36322 | ROT(3,3) = COS(PHI) |
| 36323 | ELSE |
| 36324 | STOP ' TESTROT: mode not supported!' |
| 36325 | ENDIF |
| 36326 | DO 1 J=1,3 |
| 36327 | PO(J) = ROT(J,1)*PI(1)+ROT(J,2)*PI(2)+ROT(J,3)*PI(3) |
| 36328 | 1 CONTINUE |
| 36329 | |
| 36330 | RETURN |
| 36331 | END |
| 36332 | |
| 36333 | *$ CREATE DT_LEPDCYP.FOR |
| 36334 | *COPY DT_LEPDCYP |
| 36335 | * |
| 36336 | *===lepdcyp============================================================* |
| 36337 | * |
| 36338 | SUBROUTINE DT_LEPDCYP(AMA,AML,POL,ETL,PXL,PYL,PZL, |
| 36339 | & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN) |
| 36340 | C |
| 36341 | C----------------------------------------------------------------- |
| 36342 | C |
| 36343 | C Author :- G. Battistoni 10-NOV-1995 |
| 36344 | C |
| 36345 | C================================================================= |
| 36346 | C |
| 36347 | C Purpose : performs decay of polarized lepton in |
| 36348 | C its rest frame: a => b + l + anti-nu |
| 36349 | C (Example: mu- => nu-mu + e- + anti-nu-e) |
| 36350 | C Polarization is assumed along Z-axis |
| 36351 | C WARNING: |
| 36352 | C 1) b AND anti-nu ARE ASSUMED TO BE NEUTRINOS |
| 36353 | C OF NEGLIGIBLE MASS |
| 36354 | C 2) RADIATIVE CORRECTIONS ARE NOT CONSIDERED |
| 36355 | C IN THIS VERSION |
| 36356 | C |
| 36357 | C Method : modifies phase space distribution obtained |
| 36358 | C by routine EXPLOD using a rejection against the |
| 36359 | C matrix element for unpolarized lepton decay |
| 36360 | C |
| 36361 | C Inputs : Mass of a : AMA |
| 36362 | C Mass of l : AML |
| 36363 | C Polar. of a: POL |
| 36364 | C (Example: fully polar. mu- decay: AMA=AMMUON, AML=AMELCT, |
| 36365 | C POL = -1) |
| 36366 | C |
| 36367 | C Outputs : kinematic variables in the rest frame of decaying lepton |
| 36368 | C ETL,PXL,PYL,PZL 4-moment of l |
| 36369 | C ETB,PXB,PYB,PZB 4-moment of b |
| 36370 | C ETN,PXN,PYN,PZN 4-moment of anti-nu |
| 36371 | C |
| 36372 | C============================================================ |
| 36373 | C + |
| 36374 | C Declarations. |
| 36375 | C - |
| 36376 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 36377 | SAVE |
| 36378 | |
| 36379 | PARAMETER ( LINP = 10 , |
| 36380 | & LOUT = 6 , |
| 36381 | & LDAT = 9 ) |
| 36382 | PARAMETER ( KALGNM = 2 ) |
| 36383 | PARAMETER ( ANGLGB = 5.0D-16 ) |
| 36384 | PARAMETER ( ANGLSQ = 2.5D-31 ) |
| 36385 | PARAMETER ( AXCSSV = 0.2D+16 ) |
| 36386 | PARAMETER ( ANDRFL = 1.0D-38 ) |
| 36387 | PARAMETER ( AVRFLW = 1.0D+38 ) |
| 36388 | PARAMETER ( AINFNT = 1.0D+30 ) |
| 36389 | PARAMETER ( AZRZRZ = 1.0D-30 ) |
| 36390 | PARAMETER ( EINFNT = +69.07755278982137 D+00 ) |
| 36391 | PARAMETER ( EZRZRZ = -69.07755278982137 D+00 ) |
| 36392 | PARAMETER ( ONEMNS = 0.999999999999999 D+00 ) |
| 36393 | PARAMETER ( ONEPLS = 1.000000000000001 D+00 ) |
| 36394 | PARAMETER ( CSNNRM = 2.0D-15 ) |
| 36395 | PARAMETER ( DMXTRN = 1.0D+08 ) |
| 36396 | PARAMETER ( ZERZER = 0.D+00 ) |
| 36397 | PARAMETER ( ONEONE = 1.D+00 ) |
| 36398 | PARAMETER ( TWOTWO = 2.D+00 ) |
| 36399 | PARAMETER ( THRTHR = 3.D+00 ) |
| 36400 | PARAMETER ( FOUFOU = 4.D+00 ) |
| 36401 | PARAMETER ( FIVFIV = 5.D+00 ) |
| 36402 | PARAMETER ( SIXSIX = 6.D+00 ) |
| 36403 | PARAMETER ( SEVSEV = 7.D+00 ) |
| 36404 | PARAMETER ( EIGEIG = 8.D+00 ) |
| 36405 | PARAMETER ( ANINEN = 9.D+00 ) |
| 36406 | PARAMETER ( TENTEN = 10.D+00 ) |
| 36407 | PARAMETER ( HLFHLF = 0.5D+00 ) |
| 36408 | PARAMETER ( ONETHI = ONEONE / THRTHR ) |
| 36409 | PARAMETER ( TWOTHI = TWOTWO / THRTHR ) |
| 36410 | PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 ) |
| 36411 | PARAMETER ( ENEPER = 2.7182818284590452354 D+00 ) |
| 36412 | PARAMETER ( SQRENT = 1.6487212707001281468 D+00 ) |
| 36413 | PARAMETER ( CLIGHT = 2.99792458 D+10 ) |
| 36414 | PARAMETER ( AVOGAD = 6.0221367 D+23 ) |
| 36415 | PARAMETER ( AMELGR = 9.1093897 D-28 ) |
| 36416 | PARAMETER ( PLCKBR = 1.05457266 D-27 ) |
| 36417 | PARAMETER ( ELCCGS = 4.8032068 D-10 ) |
| 36418 | PARAMETER ( ELCMKS = 1.60217733 D-19 ) |
| 36419 | PARAMETER ( AMUGRM = 1.6605402 D-24 ) |
| 36420 | PARAMETER ( AMMUMU = 0.113428913 D+00 ) |
| 36421 | PARAMETER ( ALPFSC = 7.2973530791728595 D-03 ) |
| 36422 | PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 ) |
| 36423 | PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 ) |
| 36424 | PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 ) |
| 36425 | PARAMETER ( PLABRC = 0.197327053 D+00 ) |
| 36426 | PARAMETER ( AMELCT = 0.51099906 D-03 ) |
| 36427 | PARAMETER ( AMUGEV = 0.93149432 D+00 ) |
| 36428 | PARAMETER ( AMMUON = 0.105658389 D+00 ) |
| 36429 | PARAMETER ( RCLSEL = 2.8179409183694872 D-13 ) |
| 36430 | PARAMETER ( GEVMEV = 1.0 D+03 ) |
| 36431 | PARAMETER ( EMVGEV = 1.0 D-03 ) |
| 36432 | PARAMETER ( ALGVMV = 6.90775527898214 D+00 ) |
| 36433 | PARAMETER ( RADDEG = 180.D+00 / PIPIPI ) |
| 36434 | PARAMETER ( DEGRAD = PIPIPI / 180.D+00 ) |
| 36435 | C + |
| 36436 | C variables for EXPLOD |
| 36437 | C - |
| 36438 | PARAMETER ( KPMX = 10 ) |
| 36439 | DIMENSION AMEXPL (KPMX), PXEXPL (KPMX), PYEXPL (KPMX), |
| 36440 | & PZEXPL (KPMX), ETEXPL (KPMX) |
| 36441 | C + |
| 36442 | C test variables |
| 36443 | C - |
| 36444 | **sr - removed (not needed) |
| 36445 | C COMMON /GBATNU/ ELERAT,NTRY |
| 36446 | ** |
| 36447 | C + |
| 36448 | C Initializes test variables |
| 36449 | C - |
| 36450 | NTRY = 0 |
| 36451 | ELERAT = 0.D+00 |
| 36452 | C + |
| 36453 | C Maximum value for matrix element |
| 36454 | C - |
| 36455 | ELEMAX = ( AMA**2 + AML**2 )**2 / AMA**2 * ( AMA**2 - AML**2 + |
| 36456 | & SQRT( AMA**4 + AML**4 - 3.D+00 * AMA**2 * AML**2 ) ) |
| 36457 | C + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + |
| 36458 | C Inputs for EXPLOD |
| 36459 | C part. no. 1 is l (e- in mu- decay) |
| 36460 | C part. no. 2 is b (nu-mu in mu- decay) |
| 36461 | C part. no. 3 is anti-nu (anti-nu-e in mu- decay) |
| 36462 | C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - |
| 36463 | NPEXPL = 3 |
| 36464 | ETOTEX = AMA |
| 36465 | AMEXPL(1) = AML |
| 36466 | AMEXPL(2) = 0.D+00 |
| 36467 | AMEXPL(3) = 0.D+00 |
| 36468 | C + |
| 36469 | C phase space distribution |
| 36470 | C - |
| 36471 | 100 CONTINUE |
| 36472 | NTRY = NTRY + 1 |
| 36473 | |
| 36474 | CALL DT_EXPLOD ( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL, |
| 36475 | & PYEXPL, PZEXPL ) |
| 36476 | |
| 36477 | C + |
| 36478 | C Calculates matrix element: |
| 36479 | C 64*GF**2{[P(a)-ama*S(a)]*P(anti-nu)}{P(l)*P(b)} |
| 36480 | C Here CTH is the cosine of the angle between anti-nu and Z axis |
| 36481 | C - |
| 36482 | CTH = PZEXPL(3) / SQRT ( PXEXPL(3)**2 + PYEXPL(3)**2 + |
| 36483 | & PZEXPL(3)**2 ) |
| 36484 | PROD1 = ETEXPL(3) * AMA * (1.D+00 - POL * CTH) |
| 36485 | PROD2 = ETEXPL(1) * ETEXPL(2) - PXEXPL(1)*PXEXPL(2) - |
| 36486 | & PYEXPL(1)*PYEXPL(2) - PZEXPL(1)*PZEXPL(2) |
| 36487 | ELEMAT = 16.D+00 * PROD1 * PROD2 |
| 36488 | IF(ELEMAT.GT.ELEMAX) THEN |
| 36489 | WRITE(LOUT,*) 'Problems in LEPDCY',ELEMAX,ELEMAT |
| 36490 | STOP |
| 36491 | ENDIF |
| 36492 | C + |
| 36493 | C Here performs the rejection |
| 36494 | C - |
| 36495 | TEST = DT_RNDM(ETOTEX) * ELEMAX |
| 36496 | IF ( TEST .GT. ELEMAT ) GO TO 100 |
| 36497 | C + |
| 36498 | C final assignment of variables |
| 36499 | C - |
| 36500 | ELERAT = ELEMAT/ELEMAX |
| 36501 | ETL = ETEXPL(1) |
| 36502 | PXL = PXEXPL(1) |
| 36503 | PYL = PYEXPL(1) |
| 36504 | PZL = PZEXPL(1) |
| 36505 | ETB = ETEXPL(2) |
| 36506 | PXB = PXEXPL(2) |
| 36507 | PYB = PYEXPL(2) |
| 36508 | PZB = PZEXPL(2) |
| 36509 | ETN = ETEXPL(3) |
| 36510 | PXN = PXEXPL(3) |
| 36511 | PYN = PYEXPL(3) |
| 36512 | PZN = PZEXPL(3) |
| 36513 | 999 RETURN |
| 36514 | END |
| 36515 | |
| 36516 | *$ CREATE DT_GEN_DELTA.FOR |
| 36517 | *COPY DT_GEN_DELTA |
| 36518 | C================================================================== |
| 36519 | C. Generation of Delta resonance events |
| 36520 | C================================================================== |
| 36521 | * |
| 36522 | *===gen_delta==========================================================* |
| 36523 | * |
| 36524 | SUBROUTINE DT_GEN_DELTA(ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25) |
| 36525 | |
| 36526 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 36527 | SAVE |
| 36528 | |
| 36529 | PARAMETER ( LINP = 10 , |
| 36530 | & LOUT = 6 , |
| 36531 | & LDAT = 9 ) |
| 36532 | C...Generate a Delta-production neutrino/antineutrino |
| 36533 | C. CC-interaction on a nucleon |
| 36534 | C |
| 36535 | C. INPUT ENU (GeV) = Neutrino Energy |
| 36536 | C. LLEP = neutrino type |
| 36537 | C. LTARG = nucleon target type 1=p, 2=n. |
| 36538 | C. JINT = 1:CC, 2::NC |
| 36539 | C. |
| 36540 | C. OUTPUT PPL(4) 4-monentum of final lepton |
| 36541 | C---------------------------------------------------- |
| 36542 | PARAMETER (MAXLND=4000) |
| 36543 | COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5) |
| 36544 | **sr - removed (not needed) |
| 36545 | C COMMON /CBAD/ LBAD, NBAD |
| 36546 | ** |
| 36547 | |
| 36548 | DIMENSION PI(3),PO(3) |
| 36549 | C REAL*4 AMD0, AMD, AMN(2), AML0(6), AML, AML2, AMDMIN |
| 36550 | DIMENSION AML0(6),AMN(2) |
| 36551 | DATA AMD0 /1.231/, GAMD /0.12/, DELD/0.169/, AMDMIN/1.084/ |
| 36552 | DATA AMN /0.93827231, 0.93956563/ |
| 36553 | DATA AML0 /2*0.51100E-03,2*0.105659, 2*1.777/ |
| 36554 | |
| 36555 | c WRITE(6,*)' GEN_DEL',ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25 |
| 36556 | LBAD = 0 |
| 36557 | C...Final lepton mass |
| 36558 | IF (JINT.EQ.1) THEN |
| 36559 | AML = AML0(LLEP) |
| 36560 | ELSE |
| 36561 | AML = 0. |
| 36562 | ENDIF |
| 36563 | AML2 = AML**2 |
| 36564 | |
| 36565 | C...Particle labels (LUND) |
| 36566 | N = 5 |
| 36567 | K(1,1) = 21 |
| 36568 | K(2,1) = 21 |
| 36569 | K(3,1) = 21 |
| 36570 | K(4,1) = 1 |
| 36571 | K(3,3) = 1 |
| 36572 | K(4,3) = 1 |
| 36573 | IF (LTARG .EQ. 1) THEN |
| 36574 | K(2,2) = 2212 |
| 36575 | ELSE |
| 36576 | K(2,2) = 2112 |
| 36577 | ENDIF |
| 36578 | K0 = (LLEP-1)/2 |
| 36579 | K1 = LLEP/2 |
| 36580 | KA = 12 + 2*K0 |
| 36581 | IS = -1 + 2*LLEP - 4*K1 |
| 36582 | LNU = 2 - LLEP + 2*K1 |
| 36583 | K(1,2) = IS*KA |
| 36584 | K(5,1) = 1 |
| 36585 | K(5,3) = 2 |
| 36586 | IF (JINT .EQ. 1) THEN ! CC interactions |
| 36587 | K(3,2) = IS*24 |
| 36588 | K(4,2) = IS*(KA-1) |
| 36589 | IF(LNU.EQ.1) THEN |
| 36590 | IF (LTARG .EQ. 1) THEN |
| 36591 | K(5,2) = 2224 |
| 36592 | ELSE |
| 36593 | K(5,2) = 2214 |
| 36594 | ENDIF |
| 36595 | ELSE |
| 36596 | IF (LTARG .EQ. 1) THEN |
| 36597 | K(5,2) = 2114 |
| 36598 | ELSE |
| 36599 | K(5,2) = 1114 |
| 36600 | ENDIF |
| 36601 | ENDIF |
| 36602 | ELSE |
| 36603 | K(3,2) = 23 ! NC (Z0) interactions |
| 36604 | K(4,2) = K(1,2) |
| 36605 | **sr 7.5.00: swop Delta's (bug), Delta+ for proton (LTARG=1), |
| 36606 | * Delta0 for neutron (LTARG=2) |
| 36607 | C IF (LTARG .EQ. 1) THEN |
| 36608 | C K(5,2) = 2114 |
| 36609 | C ELSE |
| 36610 | C K(5,2) = 2214 |
| 36611 | C ENDIF |
| 36612 | IF (LTARG .EQ. 1) THEN |
| 36613 | K(5,2) = 2214 |
| 36614 | ELSE |
| 36615 | K(5,2) = 2114 |
| 36616 | ENDIF |
| 36617 | ** |
| 36618 | ENDIF |
| 36619 | |
| 36620 | C...4-momentum initial lepton |
| 36621 | P(1,5) = 0. |
| 36622 | P(1,4) = ENU |
| 36623 | P(1,1) = 0. |
| 36624 | P(1,2) = 0. |
| 36625 | P(1,3) = ENU |
| 36626 | C...4-momentum initial nucleon |
| 36627 | P(2,5) = AMN(LTARG) |
| 36628 | C P(2,4) = P(2,5) |
| 36629 | C P(2,1) = 0. |
| 36630 | C P(2,2) = 0. |
| 36631 | C P(2,3) = 0. |
| 36632 | P(2,1) = P21 |
| 36633 | P(2,2) = P22 |
| 36634 | P(2,3) = P23 |
| 36635 | P(2,4) = P24 |
| 36636 | P(2,5) = P25 |
| 36637 | N=2 |
| 36638 | beta1=-p(2,1)/p(2,4) |
| 36639 | beta2=-p(2,2)/p(2,4) |
| 36640 | beta3=-p(2,3)/p(2,4) |
| 36641 | N=2 |
| 36642 | |
| 36643 | CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3) |
| 36644 | |
| 36645 | C print*,' nucl. rest fram ( fermi incl.) prima della rotazione' |
| 36646 | |
| 36647 | phi11=atan(p(1,2)/p(1,3)) |
| 36648 | pi(1)=p(1,1) |
| 36649 | pi(2)=p(1,2) |
| 36650 | pi(3)=p(1,3) |
| 36651 | |
| 36652 | CALL DT_TESTROT(PI,Po,PHI11,1) |
| 36653 | DO ll=1,3 |
| 36654 | IF(abs(po(ll)).LT.1.D-07) po(ll)=0. |
| 36655 | END DO |
| 36656 | p(1,1)=po(1) |
| 36657 | p(1,2)=po(2) |
| 36658 | p(1,3)=po(3) |
| 36659 | phi12=atan(p(1,1)/p(1,3)) |
| 36660 | |
| 36661 | pi(1)=p(1,1) |
| 36662 | pi(2)=p(1,2) |
| 36663 | pi(3)=p(1,3) |
| 36664 | CALL DT_TESTROT(Pi,Po,PHI12,2) |
| 36665 | DO ll=1,3 |
| 36666 | IF(abs(po(ll)).LT.1.D-07) po(ll)=0. |
| 36667 | END DO |
| 36668 | p(1,1)=po(1) |
| 36669 | p(1,2)=po(2) |
| 36670 | p(1,3)=po(3) |
| 36671 | |
| 36672 | ENUU=P(1,4) |
| 36673 | |
| 36674 | C...Generate the Mass of the Delta |
| 36675 | NTRY = 0 |
| 36676 | 100 R = PYR(0) |
| 36677 | AMD=AMD0+0.5*GAMD*TAN((2.*R-1.)*ATAN(2.*DELD/GAMD)) |
| 36678 | NTRY = NTRY + 1 |
| 36679 | IF (NTRY .GT. 1000) THEN |
| 36680 | LBAD = 1 |
| 36681 | WRITE (LOUT,1001) NBAD, ENUU,AMD,AMDMIN,AMD0,GAMD,ET |
| 36682 | RETURN |
| 36683 | ENDIF |
| 36684 | IF (AMD .LT. AMDMIN) GOTO 100 |
| 36685 | ET = ((AMD+AML)**2 - AMN(LTARG)**2)/(2.*AMN(LTARG)) |
| 36686 | IF (ENUU .LT. ET) GOTO 100 |
| 36687 | |
| 36688 | C...Kinematical limits in Q**2 |
| 36689 | S = AMN(LTARG)**2 + 2.*AMN(LTARG)*ENUU |
| 36690 | SQS = SQRT(S) |
| 36691 | PSTAR = (S - AMN(LTARG)**2)/(2.*SQS) |
| 36692 | ELF = (S - AMD**2 + AML2)/(2.*SQS) |
| 36693 | PLF = SQRT(ELF**2 - AML2) |
| 36694 | Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF) |
| 36695 | Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF) |
| 36696 | IF (Q2MIN .LT. 0.) Q2MIN = 0. |
| 36697 | |
| 36698 | DSIGMAX = DT_DSIGMA_DELTA(LNU,-Q2MIN, S, AML, AMD) |
| 36699 | 200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0) |
| 36700 | DSIG = DT_DSIGMA_DELTA(LNU,-Q2, S, AML, AMD) |
| 36701 | IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200 |
| 36702 | |
| 36703 | C...Generate the kinematics of the final particles |
| 36704 | EISTAR = (S + AMN(LTARG)**2)/(2.*SQS) |
| 36705 | GAM = EISTAR/AMN(LTARG) |
| 36706 | BET = PSTAR/EISTAR |
| 36707 | CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF) |
| 36708 | EL = GAM*(ELF + BET*PLF*CTSTAR) |
| 36709 | PLZ = GAM*(PLF*CTSTAR + BET*ELF) |
| 36710 | PL = SQRT(EL**2 - AML2) |
| 36711 | PLT = SQRT(MAX(1.D-06,(PL*PL - PLZ*PLZ))) |
| 36712 | PHI = 6.28319*PYR(0) |
| 36713 | P(4,1) = PLT*COS(PHI) |
| 36714 | P(4,2) = PLT*SIN(PHI) |
| 36715 | P(4,3) = PLZ |
| 36716 | P(4,4) = EL |
| 36717 | P(4,5) = AML |
| 36718 | |
| 36719 | C...4-momentum of Delta |
| 36720 | P(5,1) = -P(4,1) |
| 36721 | P(5,2) = -P(4,2) |
| 36722 | P(5,3) = ENUU-P(4,3) |
| 36723 | P(5,4) = ENUU+AMN(LTARG)-P(4,4) |
| 36724 | P(5,5) = AMD |
| 36725 | |
| 36726 | C...4-momentum of intermediate boson |
| 36727 | P(3,5) = -Q2 |
| 36728 | P(3,4) = P(1,4)-P(4,4) |
| 36729 | P(3,1) = P(1,1)-P(4,1) |
| 36730 | P(3,2) = P(1,2)-P(4,2) |
| 36731 | P(3,3) = P(1,3)-P(4,3) |
| 36732 | N=5 |
| 36733 | |
| 36734 | DO kw=1,5 |
| 36735 | pi(1)=p(kw,1) |
| 36736 | pi(2)=p(kw,2) |
| 36737 | pi(3)=p(kw,3) |
| 36738 | CALL DT_TESTROT(Pi,Po,PHI12,3) |
| 36739 | DO ll=1,3 |
| 36740 | IF(abs(po(ll)).LT.1.D-07) po(ll)=0. |
| 36741 | END DO |
| 36742 | p(kw,1)=po(1) |
| 36743 | p(kw,2)=po(2) |
| 36744 | p(kw,3)=po(3) |
| 36745 | END DO |
| 36746 | |
| 36747 | c******************************************** |
| 36748 | |
| 36749 | DO kw=1,5 |
| 36750 | pi(1)=p(kw,1) |
| 36751 | pi(2)=p(kw,2) |
| 36752 | pi(3)=p(kw,3) |
| 36753 | CALL DT_TESTROT(Pi,Po,PHI11,4) |
| 36754 | DO ll=1,3 |
| 36755 | IF(abs(po(ll)).LT.1.D-07) po(ll)=0. |
| 36756 | END DO |
| 36757 | p(kw,1)=po(1) |
| 36758 | p(kw,2)=po(2) |
| 36759 | p(kw,3)=po(3) |
| 36760 | END DO |
| 36761 | c******************************************** |
| 36762 | C transform back into Lab. |
| 36763 | |
| 36764 | CALL PYROBO(0,0,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3) |
| 36765 | |
| 36766 | C WRITE(6,*)' Lab fram ( fermi incl.) ' |
| 36767 | N=5 |
| 36768 | CALL PYEXEC |
| 36769 | |
| 36770 | RETURN |
| 36771 | 1001 FORMAT(2X, 'DT_GEN_DELTA : event rejected ', I5, 6G10.3) |
| 36772 | END |
| 36773 | |
| 36774 | *$ CREATE DT_DSIGMA_DELTA.FOR |
| 36775 | *COPY DT_DSIGMA_DELTA |
| 36776 | * |
| 36777 | *===dsigma_delta=======================================================* |
| 36778 | * |
| 36779 | DOUBLE PRECISION FUNCTION DT_DSIGMA_DELTA (LNU, QQ, S, AML, MD) |
| 36780 | |
| 36781 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 36782 | SAVE |
| 36783 | |
| 36784 | C...Reaction nu + N -> lepton + Delta |
| 36785 | C. returns the cross section |
| 36786 | C. dsigma/dt |
| 36787 | C. INPUT LNU = 1, 2 (neutrino-antineutrino) |
| 36788 | C. QQ = t (always negative) GeV**2 |
| 36789 | C. S = (c.m energy)**2 GeV**2 |
| 36790 | C. OUTPUT = 10**-38 cm+2/GeV**2 |
| 36791 | C----------------------------------------------------- |
| 36792 | REAL*8 MN, MN2, MN4, MD,MD2, MD4 |
| 36793 | DATA MN /0.938/ |
| 36794 | DATA PI /3.1415926/ |
| 36795 | |
| 36796 | GF = (1.1664 * 1.97) |
| 36797 | GF2 = GF*GF |
| 36798 | MN2 = MN*MN |
| 36799 | MN4 = MN2*MN2 |
| 36800 | MD2 = MD*MD |
| 36801 | MD4 = MD2*MD2 |
| 36802 | AML2 = AML*AML |
| 36803 | AML4 = AML2*AML2 |
| 36804 | VQ = (MN2 - MD2 - QQ)/2. |
| 36805 | VPI = (MN2 + MD2 - QQ)/2. |
| 36806 | VK = (S + QQ - MN2 - AML2)/2. |
| 36807 | PIK = (S - MN2)/2. |
| 36808 | QK = (AML2 - QQ)/2. |
| 36809 | PIQ = (QQ + MN2 - MD2)/2. |
| 36810 | Q = SQRT(-QQ) |
| 36811 | C3V = 2.07*SQRT(EXP(-6.3*Q)*(1.+9*Q)) |
| 36812 | C3 = SQRT(3.)*C3V/MN |
| 36813 | C4 = -C3/MD ! attenzione al segno |
| 36814 | C5A = 1.18/(1.-QQ/0.4225)**2 |
| 36815 | C32 = C3**2 |
| 36816 | C42 = C4**2 |
| 36817 | C5A2 = C5A**2 |
| 36818 | |
| 36819 | IF (LNU .EQ. 1) THEN |
| 36820 | ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ* |
| 36821 | . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42- |
| 36822 | . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ* |
| 36823 | . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32 |
| 36824 | ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK |
| 36825 | . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2* |
| 36826 | . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD* |
| 36827 | . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ* |
| 36828 | . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ |
| 36829 | . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ- |
| 36830 | . 4.*MN*C3*C5A*MD2*VK*QQ+4.*MN*C3*C5A*MD2*VQ*QK-2.*MD* |
| 36831 | . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD |
| 36832 | . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.* |
| 36833 | . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.* |
| 36834 | . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK-MD* |
| 36835 | . C3*C5A*MD2*PIK*QQ+MD*C3*C5A*MD2*QK*PIQ-3.*MD*C3*C5A |
| 36836 | . *VK*VPI*QQ+MD*C3*C5A*VK*VQ*PIQ+3.*MD*C3*C5A*VPI*VQ* |
| 36837 | . QK-MD*C3*C5A*VQ**2*PIK+C4*C5A*MD2*VK*VPI*QQ+C4*C5A* |
| 36838 | . MD2*VK*VQ*PIQ-C4*C5A*MD2*VPI*VQ*QK-C4*C5A*MD2*VQ**2 |
| 36839 | . *PIK-C4*C5A*MD4*PIK*QQ+C4*C5A*MD4*QK*PIQ-2.*MD2*VK |
| 36840 | . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK* |
| 36841 | . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK |
| 36842 | . *C42-2.*MD2*VPI*QK**2*C32+ANS3 |
| 36843 | ELSE |
| 36844 | ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ* |
| 36845 | . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42- |
| 36846 | . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ* |
| 36847 | . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32 |
| 36848 | ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK |
| 36849 | . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2* |
| 36850 | . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD* |
| 36851 | . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ* |
| 36852 | . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ |
| 36853 | . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ+ |
| 36854 | . 4.*MN*C3*C5A*MD2*VK*QQ-4.*MN*C3*C5A*MD2*VQ*QK-2.*MD* |
| 36855 | . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD |
| 36856 | . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.* |
| 36857 | . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.* |
| 36858 | . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK+MD* |
| 36859 | . C3*C5A*MD2*PIK*QQ-MD*C3*C5A*MD2*QK*PIQ+3.*MD*C3*C5A |
| 36860 | . *VK*VPI*QQ-MD*C3*C5A*VK*VQ*PIQ-3.*MD*C3*C5A*VPI*VQ* |
| 36861 | . QK+MD*C3*C5A*VQ**2*PIK-C4*C5A*MD2*VK*VPI*QQ-C4*C5A* |
| 36862 | . MD2*VK*VQ*PIQ+C4*C5A*MD2*VPI*VQ*QK+C4*C5A*MD2*VQ**2 |
| 36863 | . *PIK+C4*C5A*MD4*PIK*QQ-C4*C5A*MD4*QK*PIQ-2.*MD2*VK |
| 36864 | . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK* |
| 36865 | . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK |
| 36866 | . *C42-2.*MD2*VPI*QK**2*C32+ANS3 |
| 36867 | ENDIF |
| 36868 | ANS1=32.*ANS2 |
| 36869 | ANS=ANS1/(3.*MD2) |
| 36870 | P1CM = (S-MN2)/(2.*SQRT(S)) |
| 36871 | DT_DSIGMA_DELTA = GF2/2. * ANS/(64.*PI*S*P1CM**2) |
| 36872 | |
| 36873 | RETURN |
| 36874 | END |
| 36875 | |
| 36876 | *$ CREATE DT_QGAUS.FOR |
| 36877 | *COPY DT_QGAUS |
| 36878 | * |
| 36879 | *===qgaus==============================================================* |
| 36880 | * |
| 36881 | SUBROUTINE DT_QGAUS(A,B,SS,ENU,LTYP) |
| 36882 | |
| 36883 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 36884 | SAVE |
| 36885 | |
| 36886 | DIMENSION X(5),W(5) |
| 36887 | DATA X/.1488743389D0,.4333953941D0, |
| 36888 | & .6794095682D0,.8650633666D0,.9739065285D0 |
| 36889 | */ |
| 36890 | DATA W/.2955242247D0,.2692667193D0, |
| 36891 | & .2190863625D0,.1494513491D0,.0666713443D0 |
| 36892 | */ |
| 36893 | XM=0.5D0*(B+A) |
| 36894 | XR=0.5D0*(B-A) |
| 36895 | SS=0 |
| 36896 | DO 11 J=1,5 |
| 36897 | DX=XR*X(J) |
| 36898 | SS=SS+W(J)*(DT_DSQEL_Q2(LTYP,ENU,XM+DX)+ |
| 36899 | * DT_DSQEL_Q2(LTYP,ENU,XM-DX)) |
| 36900 | 11 CONTINUE |
| 36901 | SS=XR*SS |
| 36902 | |
| 36903 | RETURN |
| 36904 | END |
| 36905 | |
| 36906 | *$ CREATE DT_DIQBRK.FOR |
| 36907 | *COPY DT_DIQBRK |
| 36908 | * |
| 36909 | *===diqbrk=============================================================* |
| 36910 | * |
| 36911 | SUBROUTINE DT_DIQBRK |
| 36912 | |
| 36913 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 36914 | SAVE |
| 36915 | |
| 36916 | * event history |
| 36917 | PARAMETER (NMXHKK=200000) |
| 36918 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 36919 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 36920 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 36921 | * extended event history |
| 36922 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 36923 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 36924 | & IHIST(2,NMXHKK) |
| 36925 | * event flag |
| 36926 | COMMON /DTEVNO/ NEVENT,ICASCA |
| 36927 | |
| 36928 | C IF(DT_RNDM(VV).LE.0.5D0)THEN |
| 36929 | C CALL GSQBS1(NHKK) |
| 36930 | C CALL GSQBS2(NHKK) |
| 36931 | C CALL USQBS1(NHKK) |
| 36932 | C CALL USQBS2(NHKK) |
| 36933 | C CALL GSABS1(NHKK) |
| 36934 | C CALL GSABS2(NHKK) |
| 36935 | C CALL USABS1(NHKK) |
| 36936 | C CALL USABS2(NHKK) |
| 36937 | C ELSE |
| 36938 | C CALL GSQBS2(NHKK) |
| 36939 | C CALL GSQBS1(NHKK) |
| 36940 | C CALL USQBS2(NHKK) |
| 36941 | C CALL USQBS1(NHKK) |
| 36942 | C CALL GSABS2(NHKK) |
| 36943 | C CALL GSABS1(NHKK) |
| 36944 | C CALL USABS2(NHKK) |
| 36945 | C CALL USABS1(NHKK) |
| 36946 | C ENDIF |
| 36947 | |
| 36948 | IF(DT_RNDM(VV).LE.0.5D0) THEN |
| 36949 | CALL DT_DBREAK(1) |
| 36950 | CALL DT_DBREAK(2) |
| 36951 | CALL DT_DBREAK(3) |
| 36952 | CALL DT_DBREAK(4) |
| 36953 | CALL DT_DBREAK(5) |
| 36954 | CALL DT_DBREAK(6) |
| 36955 | CALL DT_DBREAK(7) |
| 36956 | CALL DT_DBREAK(8) |
| 36957 | ELSE |
| 36958 | CALL DT_DBREAK(2) |
| 36959 | CALL DT_DBREAK(1) |
| 36960 | CALL DT_DBREAK(4) |
| 36961 | CALL DT_DBREAK(3) |
| 36962 | CALL DT_DBREAK(6) |
| 36963 | CALL DT_DBREAK(5) |
| 36964 | CALL DT_DBREAK(8) |
| 36965 | CALL DT_DBREAK(7) |
| 36966 | ENDIF |
| 36967 | |
| 36968 | RETURN |
| 36969 | END |
| 36970 | |
| 36971 | *$ CREATE MUSQBS2.FOR |
| 36972 | *COPY MUSQBS2 |
| 36973 | C |
| 36974 | C |
| 36975 | C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| 36976 | SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, |
| 36977 | * IP1,IP21,IP22,IPP1,IPP2,IPIP,ISQ,IGCOUN) |
| 36978 | C |
| 36979 | C USQBS-2 diagram (split target diquark) |
| 36980 | C |
| 36981 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 36982 | SAVE |
| 36983 | |
| 36984 | PARAMETER ( LINP = 10 , |
| 36985 | & LOUT = 6 , |
| 36986 | & LDAT = 9 ) |
| 36987 | * event history |
| 36988 | PARAMETER (NMXHKK=200000) |
| 36989 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 36990 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 36991 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 36992 | * extended event history |
| 36993 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 36994 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 36995 | & IHIST(2,NMXHKK) |
| 36996 | * Lorentz-parameters of the current interaction |
| 36997 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, |
| 36998 | & UMO,PPCM,EPROJ,PPROJ |
| 36999 | * diquark-breaking mechanism |
| 37000 | COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3 |
| 37001 | |
| 37002 | C |
| 37003 | PARAMETER (NTMHKK= 300) |
| 37004 | COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT |
| 37005 | +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT |
| 37006 | +(4,NTMHKK) |
| 37007 | *KEEP,XSEADI. |
| 37008 | COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA, |
| 37009 | +SSMIMQ,VVMTHR |
| 37010 | *KEEP,DPRIN. |
| 37011 | COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR |
| 37012 | COMMON /EVFLAG/ NUMEV |
| 37013 | C |
| 37014 | C USQBS-2 diagram (split target diquark) |
| 37015 | C |
| 37016 | C |
| 37017 | C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T) |
| 37018 | C Input chain 2(NC2) sea-antiquark(NC2P)-sea-quark(NC2T) |
| 37019 | C |
| 37020 | C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T |
| 37021 | C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T |
| 37022 | C |
| 37023 | C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2) |
| 37024 | C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5) |
| 37025 | C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8) |
| 37026 | C |
| 37027 | C |
| 37028 | C Put new chains into COMMON /HKKTMP/ |
| 37029 | C |
| 37030 | IIGLU1=NC1T-NC1P-1 |
| 37031 | IIGLU2=NC2T-NC2P-1 |
| 37032 | IGCOUN=0 |
| 37033 | C WRITE(LOUT,*)'MUSQBS2: IIGLU1,IIGLU2 ',IIGLU1,IIGLU2 |
| 37034 | CVQ=1.D0 |
| 37035 | IREJ=0 |
| 37036 | IF(IPIP.EQ.2)THEN |
| 37037 | C IF(NUMEV.EQ.-324)THEN |
| 37038 | C WRITE(LOUT,*)' MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,', |
| 37039 | C * 'IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN)', |
| 37040 | C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, |
| 37041 | C * IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN |
| 37042 | ENDIF |
| 37043 | C |
| 37044 | C |
| 37045 | C |
| 37046 | C determine x-values of NC1T diquark |
| 37047 | XDIQT=PHKK(4,NC1T)*2.D0/UMO |
| 37048 | XVQP=PHKK(4,NC1P)*2.D0/UMO |
| 37049 | C |
| 37050 | C determine x-values of sea quark pair |
| 37051 | C |
| 37052 | IPCO=1 |
| 37053 | ICOU=0 |
| 37054 | 2234 CONTINUE |
| 37055 | ICOU=ICOU+1 |
| 37056 | IF(ICOU.GE.500)THEN |
| 37057 | IREJ=1 |
| 37058 | IF(ISQ.EQ.3)IREJ=3 |
| 37059 | IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 2234 ICOU. GT.500' |
| 37060 | IPCO=0 |
| 37061 | RETURN |
| 37062 | ENDIF |
| 37063 | IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS2 call XSEAPA: UMO,XDIQT,XVQP ', |
| 37064 | * UMO, XDIQT,XVQP |
| 37065 | XSQ=0.D0 |
| 37066 | XSAQ=0.D0 |
| 37067 | **NEW |
| 37068 | C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ) |
| 37069 | IF (IPIP.EQ.1) THEN |
| 37070 | XQMAX = XDIQT/2.0D0 |
| 37071 | XAQMAX = 2.D0*XVQP/3.0D0 |
| 37072 | ELSE |
| 37073 | XQMAX = 2.D0*XVQP/3.0D0 |
| 37074 | XAQMAX = XDIQT/2.0D0 |
| 37075 | ENDIF |
| 37076 | CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ) |
| 37077 | ISAQ = 6+ISQ |
| 37078 | C write(*,*) 'MUSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP |
| 37079 | ** |
| 37080 | IF(IPCO.GE.3) |
| 37081 | & WRITE(LOUT,*)'MUSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ |
| 37082 | IF(IREJ.GE.1)THEN |
| 37083 | IF(IPCO.GE.3) |
| 37084 | & WRITE(LOUT,*)'MUSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ |
| 37085 | IPCO=0 |
| 37086 | RETURN |
| 37087 | ENDIF |
| 37088 | IF(IPIP.EQ.1)THEN |
| 37089 | IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234 |
| 37090 | ELSEIF(IPIP.EQ.2)THEN |
| 37091 | IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234 |
| 37092 | ENDIF |
| 37093 | IF(IPCO.GE.3)THEN |
| 37094 | WRITE(LOUT,'(A,4E12.4)')' MUSQBS2 XDIQT,XVQP,XSQ,XSAQ ', |
| 37095 | * XDIQT,XVQP,XSQ,XSAQ |
| 37096 | ENDIF |
| 37097 | C |
| 37098 | C subtract xsq,xsaq from NC1T diquark and NC1P quark |
| 37099 | C |
| 37100 | C XSQ=0.D0 |
| 37101 | IF(IPIP.EQ.1)THEN |
| 37102 | XDIQT=XDIQT-XSQ |
| 37103 | XVQP =XVQP -XSAQ |
| 37104 | ELSEIF(IPIP.EQ.2)THEN |
| 37105 | XDIQT=XDIQT-XSAQ |
| 37106 | XVQP =XVQP -XSQ |
| 37107 | ENDIF |
| 37108 | IF(IPCO.GE.3) |
| 37109 | & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP |
| 37110 | C |
| 37111 | C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T |
| 37112 | C |
| 37113 | XVTHRO=CVQ/UMO |
| 37114 | IVTHR=0 |
| 37115 | 3466 CONTINUE |
| 37116 | IF(IVTHR.EQ.10)THEN |
| 37117 | IREJ=1 |
| 37118 | IF(ISQ.EQ.3)IREJ=3 |
| 37119 | IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 3466 reject IVTHR 10' |
| 37120 | IPCO=0 |
| 37121 | RETURN |
| 37122 | ENDIF |
| 37123 | IVTHR=IVTHR+1 |
| 37124 | XVTHR=XVTHRO/(201-IVTHR) |
| 37125 | UNOPRV=UNON |
| 37126 | 380 CONTINUE |
| 37127 | IF(XVTHR.GT.0.66D0*XDIQT)THEN |
| 37128 | IREJ=1 |
| 37129 | IF(ISQ.EQ.3)IREJ=3 |
| 37130 | IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 380 XVTHR large ', |
| 37131 | * XVTHR |
| 37132 | IPCO=0 |
| 37133 | RETURN |
| 37134 | ENDIF |
| 37135 | IF(DT_RNDM(V).LT.0.5D0)THEN |
| 37136 | XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT) |
| 37137 | XVTQII=XDIQT-XVTQI |
| 37138 | ELSE |
| 37139 | XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT) |
| 37140 | XVTQI=XDIQT-XVTQII |
| 37141 | ENDIF |
| 37142 | IF(IPCO.GE.3)THEN |
| 37143 | WRITE(LOUT,'(A,2E12.4)')' MUSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII |
| 37144 | ENDIF |
| 37145 | C |
| 37146 | C Prepare 4 momenta of new chains and chain ends |
| 37147 | C |
| 37148 | C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT |
| 37149 | C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT |
| 37150 | C +(4,NTMHKK) |
| 37151 | C |
| 37152 | C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2) |
| 37153 | C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5) |
| 37154 | C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8) |
| 37155 | C |
| 37156 | C SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, |
| 37157 | C * IP1,IP21,IP22,IPP1,IPP2) |
| 37158 | C |
| 37159 | IF(IPIP.EQ.1)THEN |
| 37160 | XSQ1=XSQ |
| 37161 | XSAQ1=XSAQ |
| 37162 | ISQ1=ISQ |
| 37163 | ISAQ1=ISAQ |
| 37164 | ELSEIF(IPIP.EQ.2)THEN |
| 37165 | XSQ1=XSAQ |
| 37166 | XSAQ1=XSQ |
| 37167 | ISQ1=ISAQ |
| 37168 | ISAQ1=ISQ |
| 37169 | ENDIF |
| 37170 | IDHKT(1) =IPP1 |
| 37171 | ISTHKT(1) =951 |
| 37172 | JMOHKT(1,1)=NC2P |
| 37173 | JMOHKT(2,1)=0 |
| 37174 | JDAHKT(1,1)=3+IIGLU1 |
| 37175 | JDAHKT(2,1)=0 |
| 37176 | C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2) |
| 37177 | PHKT(1,1) =PHKK(1,NC2P) |
| 37178 | PHKT(2,1) =PHKK(2,NC2P) |
| 37179 | PHKT(3,1) =PHKK(3,NC2P) |
| 37180 | PHKT(4,1) =PHKK(4,NC2P) |
| 37181 | C PHKT(5,1) =PHKK(5,NC2P) |
| 37182 | XMIST =(PHKT(4,1)**2- |
| 37183 | * PHKT(3,1)**2-PHKT(2,1)**2- |
| 37184 | *PHKT(1,1)**2) |
| 37185 | IF(XMIST.GT.0.D0)THEN |
| 37186 | PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2- |
| 37187 | *PHKT(1,1)**2) |
| 37188 | ELSE |
| 37189 | C WRITE(LOUT,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST |
| 37190 | PHKT(5,1)=0.D0 |
| 37191 | ENDIF |
| 37192 | VHKT(1,1) =VHKK(1,NC2P) |
| 37193 | VHKT(2,1) =VHKK(2,NC2P) |
| 37194 | VHKT(3,1) =VHKK(3,NC2P) |
| 37195 | VHKT(4,1) =VHKK(4,NC2P) |
| 37196 | WHKT(1,1) =WHKK(1,NC2P) |
| 37197 | WHKT(2,1) =WHKK(2,NC2P) |
| 37198 | WHKT(3,1) =WHKK(3,NC2P) |
| 37199 | WHKT(4,1) =WHKK(4,NC2P) |
| 37200 | C Add here IIGLU1 gluons to this chaina |
| 37201 | PG1=0.D0 |
| 37202 | PG2=0.D0 |
| 37203 | PG3=0.D0 |
| 37204 | PG4=0.D0 |
| 37205 | IF(IIGLU1.GE.1)THEN |
| 37206 | JJG=NC1P |
| 37207 | DO 61 IIG=2,2+IIGLU1-1 |
| 37208 | KKG=JJG+IIG-1 |
| 37209 | IDHKT(IIG) =IDHKK(KKG) |
| 37210 | ISTHKT(IIG) =921 |
| 37211 | JMOHKT(1,IIG)=KKG |
| 37212 | JMOHKT(2,IIG)=0 |
| 37213 | JDAHKT(1,IIG)=3+IIGLU1 |
| 37214 | JDAHKT(2,IIG)=0 |
| 37215 | PHKT(1,IIG)=PHKK(1,KKG) |
| 37216 | PG1=PG1+ PHKT(1,IIG) |
| 37217 | PHKT(2,IIG)=PHKK(2,KKG) |
| 37218 | PG2=PG2+ PHKT(2,IIG) |
| 37219 | PHKT(3,IIG)=PHKK(3,KKG) |
| 37220 | PG3=PG3+ PHKT(3,IIG) |
| 37221 | PHKT(4,IIG)=PHKK(4,KKG) |
| 37222 | PG4=PG4+ PHKT(4,IIG) |
| 37223 | PHKT(5,IIG)=PHKK(5,KKG) |
| 37224 | VHKT(1,IIG) =VHKK(1,KKG) |
| 37225 | VHKT(2,IIG) =VHKK(2,KKG) |
| 37226 | VHKT(3,IIG) =VHKK(3,KKG) |
| 37227 | VHKT(4,IIG) =VHKK(4,KKG) |
| 37228 | WHKT(1,IIG) =WHKK(1,KKG) |
| 37229 | WHKT(2,IIG) =WHKK(2,KKG) |
| 37230 | WHKT(3,IIG) =WHKK(3,KKG) |
| 37231 | WHKT(4,IIG) =WHKK(4,KKG) |
| 37232 | 61 CONTINUE |
| 37233 | ENDIF |
| 37234 | IDHKT(2+IIGLU1) =IP21 |
| 37235 | ISTHKT(2+IIGLU1) =952 |
| 37236 | JMOHKT(1,2+IIGLU1)=NC1T |
| 37237 | JMOHKT(2,2+IIGLU1)=0 |
| 37238 | JDAHKT(1,2+IIGLU1)=3+IIGLU1 |
| 37239 | JDAHKT(2,2+IIGLU1)=0 |
| 37240 | PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1) |
| 37241 | PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1) |
| 37242 | PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1) |
| 37243 | PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1) |
| 37244 | C PHKT(5,2) =PHKK(5,NC1T) |
| 37245 | XMIST =(PHKT(4,2+IIGLU1)**2- |
| 37246 | * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2- |
| 37247 | *PHKT(1,2+IIGLU1)**2) |
| 37248 | IF(XMIST.GT.0.D0)THEN |
| 37249 | PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2- |
| 37250 | * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2- |
| 37251 | *PHKT(1,2+IIGLU1)**2) |
| 37252 | ELSE |
| 37253 | C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST |
| 37254 | PHKT(5,5+IIGLU1)=0.D0 |
| 37255 | ENDIF |
| 37256 | VHKT(1,2+IIGLU1) =VHKK(1,NC1T) |
| 37257 | VHKT(2,2+IIGLU1) =VHKK(2,NC1T) |
| 37258 | VHKT(3,2+IIGLU1) =VHKK(3,NC1T) |
| 37259 | VHKT(4,2+IIGLU1) =VHKK(4,NC1T) |
| 37260 | WHKT(1,2+IIGLU1) =WHKK(1,NC1T) |
| 37261 | WHKT(2,2+IIGLU1) =WHKK(2,NC1T) |
| 37262 | WHKT(3,2+IIGLU1) =WHKK(3,NC1T) |
| 37263 | WHKT(4,2+IIGLU1) =WHKK(4,NC1T) |
| 37264 | IDHKT(3+IIGLU1) =88888 |
| 37265 | ISTHKT(3+IIGLU1) =95 |
| 37266 | JMOHKT(1,3+IIGLU1)=1 |
| 37267 | JMOHKT(2,3+IIGLU1)=2+IIGLU1 |
| 37268 | JDAHKT(1,3+IIGLU1)=0 |
| 37269 | JDAHKT(2,3+IIGLU1)=0 |
| 37270 | PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1 |
| 37271 | PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2 |
| 37272 | PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3 |
| 37273 | PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4 |
| 37274 | XMIST |
| 37275 | * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2 |
| 37276 | * -PHKT(3,3+IIGLU1)**2) |
| 37277 | IF(XMIST.GT.0.D0)THEN |
| 37278 | PHKT(5,3+IIGLU1) |
| 37279 | * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2 |
| 37280 | * -PHKT(3,3+IIGLU1)**2) |
| 37281 | ELSE |
| 37282 | C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST |
| 37283 | PHKT(5,5+IIGLU1)=0.D0 |
| 37284 | ENDIF |
| 37285 | IF(IPIP.GE.2)THEN |
| 37286 | C IF(NUMEV.EQ.-324)THEN |
| 37287 | C WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1), |
| 37288 | C * JDAHKT(1,1), |
| 37289 | C *JDAHKT(2,1),(PHKT(III,1),III=1,5) |
| 37290 | DO 71 IIG=2,2+IIGLU1-1 |
| 37291 | C WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG), |
| 37292 | C & JMOHKT(1,IIG),JMOHKT(2,IIG), |
| 37293 | C * JDAHKT(1,IIG), |
| 37294 | C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) |
| 37295 | 71 CONTINUE |
| 37296 | C WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1), |
| 37297 | C * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1), |
| 37298 | C *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5) |
| 37299 | C WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1), |
| 37300 | C * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1), |
| 37301 | C *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5) |
| 37302 | ENDIF |
| 37303 | CHAMAL=CHAM1 |
| 37304 | IF(IPIP.EQ.1)THEN |
| 37305 | IF(IPP1.LE.-3.OR.IP21.GE.3)CHAMAL=CHAM3 |
| 37306 | ELSEIF(IPIP.EQ.2)THEN |
| 37307 | IF(IPP1.GE.3.OR.IP21.LE.-3)CHAMAL=CHAM3 |
| 37308 | ENDIF |
| 37309 | IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN |
| 37310 | C IREJ=1 |
| 37311 | IPCO=0 |
| 37312 | C RETURN |
| 37313 | C WRITE(LOUT,*)' MUSQBS1 jump back from chain 3' |
| 37314 | GO TO 3466 |
| 37315 | ENDIF |
| 37316 | VHKT(1,3+IIGLU1) =VHKK(1,NC1) |
| 37317 | VHKT(2,3+IIGLU1) =VHKK(2,NC1) |
| 37318 | VHKT(3,3+IIGLU1) =VHKK(3,NC1) |
| 37319 | VHKT(4,3+IIGLU1) =VHKK(4,NC1) |
| 37320 | WHKT(1,3+IIGLU1) =WHKK(1,NC1) |
| 37321 | WHKT(2,3+IIGLU1) =WHKK(2,NC1) |
| 37322 | WHKT(3,3+IIGLU1) =WHKK(3,NC1) |
| 37323 | WHKT(4,3+IIGLU1) =WHKK(4,NC1) |
| 37324 | IF(IPIP.EQ.1)THEN |
| 37325 | IDHKT(4+IIGLU1) =-(ISAQ1-6) |
| 37326 | ELSEIF(IPIP.EQ.2)THEN |
| 37327 | IDHKT(4+IIGLU1) =ISAQ1 |
| 37328 | ENDIF |
| 37329 | ISTHKT(4+IIGLU1) =951 |
| 37330 | JMOHKT(1,4+IIGLU1)=NC1P |
| 37331 | JMOHKT(2,4+IIGLU1)=0 |
| 37332 | JDAHKT(1,4+IIGLU1)=6+IIGLU1 |
| 37333 | JDAHKT(2,4+IIGLU1)=0 |
| 37334 | C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5) |
| 37335 | PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1) |
| 37336 | PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1) |
| 37337 | PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1) |
| 37338 | PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1) |
| 37339 | C PHKT(5,4+IIGLU1) =PHKK(5,NC1P) |
| 37340 | XMIST =(PHKT(4,4+IIGLU1)**2- |
| 37341 | * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2- |
| 37342 | *PHKT(1,4+IIGLU1)**2) |
| 37343 | IF(XMIST.GT.0.D0)THEN |
| 37344 | PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2- |
| 37345 | * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2- |
| 37346 | *PHKT(1,4+IIGLU1)**2) |
| 37347 | ELSE |
| 37348 | C WRITE(LOUT,*)'MUSQBS2 parton 4 mass square LT.0 ',XMIST |
| 37349 | PHKT(5,4+IIGLU1)=0.D0 |
| 37350 | ENDIF |
| 37351 | VHKT(1,4+IIGLU1) =VHKK(1,NC1P) |
| 37352 | VHKT(2,4+IIGLU1) =VHKK(2,NC1P) |
| 37353 | VHKT(3,4+IIGLU1) =VHKK(3,NC1P) |
| 37354 | VHKT(4,4+IIGLU1) =VHKK(4,NC1P) |
| 37355 | WHKT(1,4+IIGLU1) =WHKK(1,NC1P) |
| 37356 | WHKT(2,4+IIGLU1) =WHKK(2,NC1P) |
| 37357 | WHKT(3,4+IIGLU1) =WHKK(3,NC1P) |
| 37358 | WHKT(4,4+IIGLU1) =WHKK(4,NC1P) |
| 37359 | IDHKT(5+IIGLU1) =IP22 |
| 37360 | ISTHKT(5+IIGLU1) =952 |
| 37361 | JMOHKT(1,5+IIGLU1)=NC1T |
| 37362 | JMOHKT(2,5+IIGLU1)=0 |
| 37363 | JDAHKT(1,5+IIGLU1)=6+IIGLU1 |
| 37364 | JDAHKT(2,5+IIGLU1)=0 |
| 37365 | PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1) |
| 37366 | PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1) |
| 37367 | PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1) |
| 37368 | PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1) |
| 37369 | C PHKT(5,5+IIGLU1) =PHKK(5,NC1T) |
| 37370 | XMIST =(PHKT(4,5+IIGLU1)**2- |
| 37371 | * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2- |
| 37372 | *PHKT(1,5+IIGLU1)**2) |
| 37373 | IF(XMIST.GT.0.D0)THEN |
| 37374 | PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2- |
| 37375 | * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2- |
| 37376 | *PHKT(1,5+IIGLU1)**2) |
| 37377 | ELSE |
| 37378 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST |
| 37379 | PHKT(5,5+IIGLU1)=0.D0 |
| 37380 | ENDIF |
| 37381 | VHKT(1,5+IIGLU1) =VHKK(1,NC1T) |
| 37382 | VHKT(2,5+IIGLU1) =VHKK(2,NC1T) |
| 37383 | VHKT(3,5+IIGLU1) =VHKK(3,NC1T) |
| 37384 | VHKT(4,5+IIGLU1) =VHKK(4,NC1T) |
| 37385 | WHKT(1,5+IIGLU1) =WHKK(1,NC1T) |
| 37386 | WHKT(2,5+IIGLU1) =WHKK(2,NC1T) |
| 37387 | WHKT(3,5+IIGLU1) =WHKK(3,NC1T) |
| 37388 | WHKT(4,5+IIGLU1) =WHKK(4,NC1T) |
| 37389 | IDHKT(6+IIGLU1) =88888 |
| 37390 | ISTHKT(6+IIGLU1) =95 |
| 37391 | JMOHKT(1,6+IIGLU1)=4+IIGLU1 |
| 37392 | JMOHKT(2,6+IIGLU1)=5+IIGLU1 |
| 37393 | JDAHKT(1,6+IIGLU1)=0 |
| 37394 | JDAHKT(2,6+IIGLU1)=0 |
| 37395 | PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1) |
| 37396 | PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1) |
| 37397 | PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1) |
| 37398 | PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1) |
| 37399 | XMIST |
| 37400 | * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2 |
| 37401 | * -PHKT(3,6+IIGLU1)**2) |
| 37402 | IF(XMIST.GT.0.D0)THEN |
| 37403 | PHKT(5,6+IIGLU1) |
| 37404 | * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2 |
| 37405 | * -PHKT(3,6+IIGLU1)**2) |
| 37406 | ELSE |
| 37407 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST |
| 37408 | PHKT(5,5+IIGLU1)=0.D0 |
| 37409 | ENDIF |
| 37410 | C IF(IPIP.GE.2)THEN |
| 37411 | C IF(NUMEV.EQ.-324)THEN |
| 37412 | C WRITE(6,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1), |
| 37413 | C * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1), |
| 37414 | C *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5) |
| 37415 | C WRITE(6,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1), |
| 37416 | C * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1), |
| 37417 | C *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5) |
| 37418 | C WRITE(6,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1), |
| 37419 | C * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1), |
| 37420 | C *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5) |
| 37421 | C ENDIF |
| 37422 | CHAMAL=CHAM1 |
| 37423 | IF(IPIP.EQ.1)THEN |
| 37424 | IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3 |
| 37425 | ELSEIF(IPIP.EQ.2)THEN |
| 37426 | IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3 |
| 37427 | ENDIF |
| 37428 | IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN |
| 37429 | C IREJ=1 |
| 37430 | IPCO=0 |
| 37431 | C RETURN |
| 37432 | C WRITE(6,*)' MUSQBS1 jump back from chain 6', |
| 37433 | C * CHAMAL,PHKT(5,6+IIGLU1) |
| 37434 | GO TO 3466 |
| 37435 | ENDIF |
| 37436 | VHKT(1,6+IIGLU1) =VHKK(1,NC1) |
| 37437 | VHKT(2,6+IIGLU1) =VHKK(2,NC1) |
| 37438 | VHKT(3,6+IIGLU1) =VHKK(3,NC1) |
| 37439 | VHKT(4,6+IIGLU1) =VHKK(4,NC1) |
| 37440 | WHKT(1,6+IIGLU1) =WHKK(1,NC1) |
| 37441 | WHKT(2,6+IIGLU1) =WHKK(2,NC1) |
| 37442 | WHKT(3,6+IIGLU1) =WHKK(3,NC1) |
| 37443 | WHKT(4,6+IIGLU1) =WHKK(4,NC1) |
| 37444 | C IDHKT(7) =1000*IPP1+100*ISQ+1 |
| 37445 | IDHKT(7+IIGLU1) =IP1 |
| 37446 | ISTHKT(7+IIGLU1) =951 |
| 37447 | JMOHKT(1,7+IIGLU1)=NC1P |
| 37448 | JMOHKT(2,7+IIGLU1)=0 |
| 37449 | **NEW |
| 37450 | C JDAHKT(1,7+IIGLU1)=9+IIGLU1 |
| 37451 | JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2 |
| 37452 | ** |
| 37453 | JDAHKT(2,7+IIGLU1)=0 |
| 37454 | PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1) |
| 37455 | PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1) |
| 37456 | PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1) |
| 37457 | PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1) |
| 37458 | C PHKT(5,7+IIGLU1) =PHKK(5,NC1P) |
| 37459 | XMIST =(PHKT(4,7+IIGLU1)**2- |
| 37460 | * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2- |
| 37461 | *PHKT(1,7+IIGLU1)**2) |
| 37462 | IF(XMIST.GT.0.D0)THEN |
| 37463 | PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2- |
| 37464 | * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2- |
| 37465 | *PHKT(1,7+IIGLU1)**2) |
| 37466 | ELSE |
| 37467 | C WRITE(6,*)'MUSQBS2 parton 7 mass square LT.0 ',XMIST |
| 37468 | PHKT(5,7+IIGLU1)=0.D0 |
| 37469 | ENDIF |
| 37470 | VHKT(1,7+IIGLU1) =VHKK(1,NC1P) |
| 37471 | VHKT(2,7+IIGLU1) =VHKK(2,NC1P) |
| 37472 | VHKT(3,7+IIGLU1) =VHKK(3,NC1P) |
| 37473 | VHKT(4,7+IIGLU1) =VHKK(4,NC1P) |
| 37474 | WHKT(1,7+IIGLU1) =WHKK(1,NC1P) |
| 37475 | WHKT(2,7+IIGLU1) =WHKK(2,NC1P) |
| 37476 | WHKT(3,7+IIGLU1) =WHKK(3,NC1P) |
| 37477 | WHKT(4,7+IIGLU1) =WHKK(4,NC2P) |
| 37478 | C Insert here the IIGLU2 gluons |
| 37479 | PG1=0.D0 |
| 37480 | PG2=0.D0 |
| 37481 | PG3=0.D0 |
| 37482 | PG4=0.D0 |
| 37483 | IF(IIGLU2.GE.1)THEN |
| 37484 | JJG=NC2P |
| 37485 | DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 |
| 37486 | KKG=JJG+IIG-7-IIGLU1 |
| 37487 | IDHKT(IIG) =IDHKK(KKG) |
| 37488 | ISTHKT(IIG) =921 |
| 37489 | JMOHKT(1,IIG)=KKG |
| 37490 | JMOHKT(2,IIG)=0 |
| 37491 | JDAHKT(1,IIG)=9+IIGLU1+IIGLU2 |
| 37492 | JDAHKT(2,IIG)=0 |
| 37493 | PHKT(1,IIG)=PHKK(1,KKG) |
| 37494 | PG1=PG1+ PHKT(1,IIG) |
| 37495 | PHKT(2,IIG)=PHKK(2,KKG) |
| 37496 | PG2=PG2+ PHKT(2,IIG) |
| 37497 | PHKT(3,IIG)=PHKK(3,KKG) |
| 37498 | PG3=PG3+ PHKT(3,IIG) |
| 37499 | PHKT(4,IIG)=PHKK(4,KKG) |
| 37500 | PG4=PG4+ PHKT(4,IIG) |
| 37501 | PHKT(5,IIG)=PHKK(5,KKG) |
| 37502 | VHKT(1,IIG) =VHKK(1,KKG) |
| 37503 | VHKT(2,IIG) =VHKK(2,KKG) |
| 37504 | VHKT(3,IIG) =VHKK(3,KKG) |
| 37505 | VHKT(4,IIG) =VHKK(4,KKG) |
| 37506 | WHKT(1,IIG) =WHKK(1,KKG) |
| 37507 | WHKT(2,IIG) =WHKK(2,KKG) |
| 37508 | WHKT(3,IIG) =WHKK(3,KKG) |
| 37509 | WHKT(4,IIG) =WHKK(4,KKG) |
| 37510 | 81 CONTINUE |
| 37511 | ENDIF |
| 37512 | IF(IPIP.EQ.1)THEN |
| 37513 | IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3 |
| 37514 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103 |
| 37515 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103 |
| 37516 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203 |
| 37517 | ELSEIF(IPIP.EQ.2)THEN |
| 37518 | IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3 |
| 37519 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103 |
| 37520 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103 |
| 37521 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203 |
| 37522 | ENDIF |
| 37523 | ISTHKT(8+IIGLU1+IIGLU2) =952 |
| 37524 | JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T |
| 37525 | JMOHKT(2,8+IIGLU1+IIGLU2)=0 |
| 37526 | JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2 |
| 37527 | JDAHKT(2,8+IIGLU1+IIGLU2)=0 |
| 37528 | PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC2T)+ |
| 37529 | * PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1) |
| 37530 | PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC2T)+ |
| 37531 | * PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1) |
| 37532 | PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC2T)+ |
| 37533 | * PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1) |
| 37534 | PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC2T)+ |
| 37535 | * PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1) |
| 37536 | C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)', |
| 37537 | C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7) |
| 37538 | IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN |
| 37539 | C IREJ=1 |
| 37540 | C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)' |
| 37541 | C * ,PHKT(4,8+IIGLU1+IIGLU2), PHKK(4,NC2T),NC2T |
| 37542 | IPCO=0 |
| 37543 | C RETURN |
| 37544 | GO TO 3466 |
| 37545 | ENDIF |
| 37546 | C PHKT(5,8) =PHKK(5,NC2T) |
| 37547 | XMIST =(PHKT(4,8+IIGLU1+IIGLU2)**2- |
| 37548 | * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2- |
| 37549 | *PHKT(1,8+IIGLU1+IIGLU2)**2) |
| 37550 | IF(XMIST.GT.0.D0)THEN |
| 37551 | PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2- |
| 37552 | * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2- |
| 37553 | *PHKT(1,8+IIGLU1+IIGLU2)**2) |
| 37554 | ELSE |
| 37555 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST |
| 37556 | PHKT(5,5+IIGLU1)=0.D0 |
| 37557 | ENDIF |
| 37558 | VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T) |
| 37559 | VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T) |
| 37560 | VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T) |
| 37561 | VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T) |
| 37562 | WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T) |
| 37563 | WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T) |
| 37564 | WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T) |
| 37565 | WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T) |
| 37566 | IDHKT(9+IIGLU1+IIGLU2) =88888 |
| 37567 | ISTHKT(9+IIGLU1+IIGLU2) =95 |
| 37568 | JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1 |
| 37569 | JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2 |
| 37570 | JDAHKT(1,9+IIGLU1+IIGLU2)=0 |
| 37571 | JDAHKT(2,9+IIGLU1+IIGLU2)=0 |
| 37572 | **NEW |
| 37573 | C PHKT(1,9+IIGLU1+IIGLU2) |
| 37574 | C * =PHKT(1,7+IIGLU1+IIGLU2)+PHKT(1,8+IIGLU1+IIGLU2)+PG1 |
| 37575 | C PHKT(2,9+IIGLU1+IIGLU2) |
| 37576 | C * =PHKT(2,7+IIGLU1+IIGLU2)+PHKT(2,8+IIGLU1+IIGLU2)+PG2 |
| 37577 | C PHKT(3,9+IIGLU1+IIGLU2) |
| 37578 | C * =PHKT(3,7+IIGLU1+IIGLU2)+PHKT(3,8+IIGLU1+IIGLU2)+PG3 |
| 37579 | C PHKT(4,9+IIGLU1+IIGLU2) |
| 37580 | C * =PHKT(4,7+IIGLU1+IIGLU2)+PHKT(4,8+IIGLU1+IIGLU2)+PG4 |
| 37581 | PHKT(1,9+IIGLU1+IIGLU2) |
| 37582 | * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1 |
| 37583 | PHKT(2,9+IIGLU1+IIGLU2) |
| 37584 | * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2 |
| 37585 | PHKT(3,9+IIGLU1+IIGLU2) |
| 37586 | * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3 |
| 37587 | PHKT(4,9+IIGLU1+IIGLU2) |
| 37588 | * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4 |
| 37589 | ** |
| 37590 | XMIST |
| 37591 | * =(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2 |
| 37592 | * -PHKT(2,9+IIGLU1+IIGLU2)**2 |
| 37593 | * -PHKT(3,9+IIGLU1+IIGLU2)**2) |
| 37594 | IF(XMIST.GT.0.D0)THEN |
| 37595 | PHKT(5,9+IIGLU1+IIGLU2) |
| 37596 | * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2 |
| 37597 | * -PHKT(2,9+IIGLU1+IIGLU2)**2 |
| 37598 | * -PHKT(3,9+IIGLU1+IIGLU2)**2) |
| 37599 | ELSE |
| 37600 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST |
| 37601 | PHKT(5,5+IIGLU1)=0.D0 |
| 37602 | ENDIF |
| 37603 | IF(IPIP.GE.2)THEN |
| 37604 | C IF(NUMEV.EQ.-324)THEN |
| 37605 | C WRITE(6,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1), |
| 37606 | C * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1), |
| 37607 | C *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5) |
| 37608 | C DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 |
| 37609 | C WRITE(6,*)IIG,ISTHKT(IIG),IDHKT(IIG),JMOHKT(1,IIG),JMOHKT(2,IIG), |
| 37610 | C * JDAHKT(1,IIG), |
| 37611 | C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) |
| 37612 | C 91 CONTINUE |
| 37613 | C WRITE(6,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2), |
| 37614 | C * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2), |
| 37615 | C *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2), |
| 37616 | C *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5) |
| 37617 | C WRITE(6,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2), |
| 37618 | C * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2), |
| 37619 | C *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2), |
| 37620 | C *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5) |
| 37621 | ENDIF |
| 37622 | CHAMAL=CHAB1 |
| 37623 | IF(IPIP.EQ.1)THEN |
| 37624 | IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3 |
| 37625 | ELSEIF(IPIP.EQ.2)THEN |
| 37626 | IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3 |
| 37627 | ENDIF |
| 37628 | IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN |
| 37629 | C IREJ=1 |
| 37630 | IPCO=0 |
| 37631 | C RETURN |
| 37632 | C WRITE(6,*)' MUSQBS1 jump back from chain 9', |
| 37633 | C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2) |
| 37634 | GO TO 3466 |
| 37635 | ENDIF |
| 37636 | VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1) |
| 37637 | VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1) |
| 37638 | VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1) |
| 37639 | VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1) |
| 37640 | WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1) |
| 37641 | WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1) |
| 37642 | WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1) |
| 37643 | WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1) |
| 37644 | C |
| 37645 | IPCO=0 |
| 37646 | IGCOUN=9+IIGLU1+IIGLU2 |
| 37647 | RETURN |
| 37648 | END |
| 37649 | |
| 37650 | *$ CREATE MGSQBS2.FOR |
| 37651 | *COPY MGSQBS2 |
| 37652 | C |
| 37653 | C |
| 37654 | C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| 37655 | SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, |
| 37656 | * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,ISQ,IGCOUN) |
| 37657 | C |
| 37658 | C GSQBS-2 diagram (split target diquark) |
| 37659 | C |
| 37660 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 37661 | SAVE |
| 37662 | |
| 37663 | PARAMETER ( LINP = 10 , |
| 37664 | & LOUT = 6 , |
| 37665 | & LDAT = 9 ) |
| 37666 | * event history |
| 37667 | PARAMETER (NMXHKK=200000) |
| 37668 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 37669 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 37670 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 37671 | * extended event history |
| 37672 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 37673 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 37674 | & IHIST(2,NMXHKK) |
| 37675 | * Lorentz-parameters of the current interaction |
| 37676 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, |
| 37677 | & UMO,PPCM,EPROJ,PPROJ |
| 37678 | * diquark-breaking mechanism |
| 37679 | COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3 |
| 37680 | |
| 37681 | C |
| 37682 | PARAMETER (NTMHKK= 300) |
| 37683 | COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT |
| 37684 | +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT |
| 37685 | +(4,NTMHKK) |
| 37686 | |
| 37687 | *KEEP,XSEADI. |
| 37688 | COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA, |
| 37689 | +SSMIMQ,VVMTHR |
| 37690 | *KEEP,DPRIN. |
| 37691 | COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR |
| 37692 | C |
| 37693 | C GSQBS-2 diagram (split target diquark) |
| 37694 | C |
| 37695 | C |
| 37696 | C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T) |
| 37697 | C Input chain 2(NC2) valence-diquark(NC2P)-sea-quark(NC2T) |
| 37698 | C |
| 37699 | C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T |
| 37700 | C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T |
| 37701 | C |
| 37702 | C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2) |
| 37703 | C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5) |
| 37704 | C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8) |
| 37705 | C |
| 37706 | C |
| 37707 | C |
| 37708 | C Put new chains into COMMON /HKKTMP/ |
| 37709 | C |
| 37710 | IIGLU1=NC1T-NC1P-1 |
| 37711 | IIGLU2=NC2T-NC2P-1 |
| 37712 | IGCOUN=0 |
| 37713 | C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2 |
| 37714 | CVQ=1.D0 |
| 37715 | IREJ=0 |
| 37716 | C IF(IPIP.EQ.2)THEN |
| 37717 | C WRITE(6,*)' MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,', |
| 37718 | C * 'IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN)', |
| 37719 | C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, |
| 37720 | C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN |
| 37721 | C ENDIF |
| 37722 | C |
| 37723 | C |
| 37724 | C |
| 37725 | C determine x-values of NC1T diquark |
| 37726 | XDIQT=PHKK(4,NC1T)*2.D0/UMO |
| 37727 | XVQP=PHKK(4,NC1P)*2.D0/UMO |
| 37728 | C |
| 37729 | C determine x-values of sea quark pair |
| 37730 | C |
| 37731 | IPCO=1 |
| 37732 | ICOU=0 |
| 37733 | 2234 CONTINUE |
| 37734 | ICOU=ICOU+1 |
| 37735 | IF(ICOU.GE.500)THEN |
| 37736 | IREJ=1 |
| 37737 | IF(ISQ.EQ.3)IREJ=3 |
| 37738 | IF(IPCO.GE.3) |
| 37739 | & WRITE(LOUT,*)' MGSQBS2 Rejection 2234 ICOU. GT.500' |
| 37740 | IPCO=0 |
| 37741 | RETURN |
| 37742 | ENDIF |
| 37743 | IF(IPCO.GE.3) |
| 37744 | & WRITE(LOUT,*)'MGSQBS2 call XSEAPA: UMO,XDIQT,XVQP ', |
| 37745 | * UMO, XDIQT,XVQP |
| 37746 | XSQ=0.D0 |
| 37747 | XSAQ=0.D0 |
| 37748 | **NEW |
| 37749 | C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ) |
| 37750 | IF (IPIP.EQ.1) THEN |
| 37751 | XQMAX = XDIQT/2.0D0 |
| 37752 | XAQMAX = 2.D0*XVQP/3.0D0 |
| 37753 | ELSE |
| 37754 | XQMAX = 2.D0*XVQP/3.0D0 |
| 37755 | XAQMAX = XDIQT/2.0D0 |
| 37756 | ENDIF |
| 37757 | CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ) |
| 37758 | ISAQ = 6+ISQ |
| 37759 | C write(*,*) 'MGSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP |
| 37760 | ** |
| 37761 | IF(IPCO.GE.3) |
| 37762 | & WRITE(LOUT,*)'MGSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ |
| 37763 | IF(IREJ.GE.1)THEN |
| 37764 | IF(IPCO.GE.3) |
| 37765 | & WRITE(LOUT,*)'MGSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ |
| 37766 | IPCO=0 |
| 37767 | RETURN |
| 37768 | ENDIF |
| 37769 | IF(IPIP.EQ.1)THEN |
| 37770 | IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234 |
| 37771 | ELSEIF(IPIP.EQ.2)THEN |
| 37772 | IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234 |
| 37773 | ENDIF |
| 37774 | IF(IPCO.GE.3)THEN |
| 37775 | WRITE(LOUT,'(A,4E12.4)')' MGSQBS2 XDIQT,XVQP,XSQ,XSAQ ', |
| 37776 | * XDIQT,XVQP,XSQ,XSAQ |
| 37777 | ENDIF |
| 37778 | C |
| 37779 | C subtract xsq,xsaq from NC1T diquark and NC1P quark |
| 37780 | C |
| 37781 | C XSQ=0.D0 |
| 37782 | IF(IPIP.EQ.1)THEN |
| 37783 | XDIQT=XDIQT-XSQ |
| 37784 | XVQP =XVQP -XSAQ |
| 37785 | ELSEIF(IPIP.EQ.2)THEN |
| 37786 | XDIQT=XDIQT-XSAQ |
| 37787 | XVQP =XVQP -XSQ |
| 37788 | ENDIF |
| 37789 | IF(IPCO.GE.3) |
| 37790 | & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP |
| 37791 | C |
| 37792 | C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T |
| 37793 | C |
| 37794 | XVTHRO=CVQ/UMO |
| 37795 | IVTHR=0 |
| 37796 | 3466 CONTINUE |
| 37797 | IF(IVTHR.EQ.10)THEN |
| 37798 | IREJ=1 |
| 37799 | IF(ISQ.EQ.3)IREJ=3 |
| 37800 | IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 3466 reject IVTHR 10' |
| 37801 | IPCO=0 |
| 37802 | RETURN |
| 37803 | ENDIF |
| 37804 | IVTHR=IVTHR+1 |
| 37805 | XVTHR=XVTHRO/(201-IVTHR) |
| 37806 | UNOPRV=UNON |
| 37807 | 380 CONTINUE |
| 37808 | IF(XVTHR.GT.0.66D0*XDIQT)THEN |
| 37809 | IREJ=1 |
| 37810 | IF(ISQ.EQ.3)IREJ=3 |
| 37811 | IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 Rejection 380 XVTHR large ', |
| 37812 | * XVTHR |
| 37813 | IPCO=0 |
| 37814 | RETURN |
| 37815 | ENDIF |
| 37816 | IF(DT_RNDM(V).LT.0.5D0)THEN |
| 37817 | XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT) |
| 37818 | XVTQII=XDIQT-XVTQI |
| 37819 | ELSE |
| 37820 | XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT) |
| 37821 | XVTQI=XDIQT-XVTQII |
| 37822 | ENDIF |
| 37823 | IF(IPCO.GE.3)THEN |
| 37824 | WRITE(LOUT,'(A,2E12.4)')' MGSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII |
| 37825 | ENDIF |
| 37826 | C |
| 37827 | C Prepare 4 momenta of new chains and chain ends |
| 37828 | C |
| 37829 | C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT |
| 37830 | C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT |
| 37831 | C +(4,NTMHKK) |
| 37832 | C |
| 37833 | C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2) |
| 37834 | C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5) |
| 37835 | C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8) |
| 37836 | C |
| 37837 | C SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, |
| 37838 | C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IGCOUN) |
| 37839 | C |
| 37840 | IF(IPIP.EQ.1)THEN |
| 37841 | XSQ1=XSQ |
| 37842 | XSAQ1=XSAQ |
| 37843 | ISQ1=ISQ |
| 37844 | ISAQ1=ISAQ |
| 37845 | ELSEIF(IPIP.EQ.2)THEN |
| 37846 | XSQ1=XSAQ |
| 37847 | XSAQ1=XSQ |
| 37848 | ISQ1=ISAQ |
| 37849 | ISAQ1=ISQ |
| 37850 | ENDIF |
| 37851 | KK11=IP21 |
| 37852 | C IDHKT(1) =1000*IPP11+100*IPP12+1 |
| 37853 | KK21=IPP11 |
| 37854 | KK22=IPP12 |
| 37855 | XGIVE=0.D0 |
| 37856 | IF(IPIP.EQ.1)THEN |
| 37857 | IDHKT(4+IIGLU1) =-(ISAQ1-6) |
| 37858 | ELSEIF(IPIP.EQ.2)THEN |
| 37859 | IDHKT(4+IIGLU1) =ISAQ1 |
| 37860 | ENDIF |
| 37861 | ISTHKT(4+IIGLU1) =961 |
| 37862 | JMOHKT(1,4+IIGLU1)=NC1P |
| 37863 | JMOHKT(2,4+IIGLU1)=0 |
| 37864 | JDAHKT(1,4+IIGLU1)=6+IIGLU1 |
| 37865 | JDAHKT(2,4+IIGLU1)=0 |
| 37866 | C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5) |
| 37867 | PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1) |
| 37868 | PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1) |
| 37869 | PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1) |
| 37870 | PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1) |
| 37871 | C PHKT(5,4+IIGLU1) =PHKK(5,NC1P) |
| 37872 | XXMIST=(PHKT(4,4+IIGLU1)**2- |
| 37873 | * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2- |
| 37874 | *PHKT(1,4+IIGLU1)**2) |
| 37875 | IF(XXMIST.GT.0.D0)THEN |
| 37876 | PHKT(5,4+IIGLU1) =SQRT(XXMIST) |
| 37877 | ELSE |
| 37878 | WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST |
| 37879 | XXMIST=ABS(XXMIST) |
| 37880 | PHKT(5,4+IIGLU1) =SQRT(XXMIST) |
| 37881 | ENDIF |
| 37882 | VHKT(1,4+IIGLU1) =VHKK(1,NC1P) |
| 37883 | VHKT(2,4+IIGLU1) =VHKK(2,NC1P) |
| 37884 | VHKT(3,4+IIGLU1) =VHKK(3,NC1P) |
| 37885 | VHKT(4,4+IIGLU1) =VHKK(4,NC1P) |
| 37886 | WHKT(1,4+IIGLU1) =WHKK(1,NC1P) |
| 37887 | WHKT(2,4+IIGLU1) =WHKK(2,NC1P) |
| 37888 | WHKT(3,4+IIGLU1) =WHKK(3,NC1P) |
| 37889 | WHKT(4,4+IIGLU1) =WHKK(4,NC1P) |
| 37890 | IDHKT(5+IIGLU1) =IP22 |
| 37891 | ISTHKT(5+IIGLU1) =962 |
| 37892 | JMOHKT(1,5+IIGLU1)=NC1T |
| 37893 | JMOHKT(2,5+IIGLU1)=0 |
| 37894 | JDAHKT(1,5+IIGLU1)=6+IIGLU1 |
| 37895 | JDAHKT(2,5+IIGLU1)=0 |
| 37896 | PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1) |
| 37897 | PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1) |
| 37898 | PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1) |
| 37899 | PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1) |
| 37900 | C PHKT(5,5+IIGLU1) =PHKK(5,NC1T) |
| 37901 | XXMIST=(PHKT(4,5+IIGLU1)**2- |
| 37902 | * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2- |
| 37903 | *PHKT(1,5+IIGLU1)**2) |
| 37904 | IF(XXMIST.GT.0.D0)THEN |
| 37905 | PHKT(5,5+IIGLU1) =SQRT(XXMIST) |
| 37906 | ELSE |
| 37907 | WRITE(LOUT,*)' MGSQBS2 XXMIST', XXMIST |
| 37908 | XXMIST=ABS(XXMIST) |
| 37909 | PHKT(5,5+IIGLU1) =SQRT(XXMIST) |
| 37910 | ENDIF |
| 37911 | VHKT(1,5+IIGLU1) =VHKK(1,NC1T) |
| 37912 | VHKT(2,5+IIGLU1) =VHKK(2,NC1T) |
| 37913 | VHKT(3,5+IIGLU1) =VHKK(3,NC1T) |
| 37914 | VHKT(4,5+IIGLU1) =VHKK(4,NC1T) |
| 37915 | WHKT(1,5+IIGLU1) =WHKK(1,NC1T) |
| 37916 | WHKT(2,5+IIGLU1) =WHKK(2,NC1T) |
| 37917 | WHKT(3,5+IIGLU1) =WHKK(3,NC1T) |
| 37918 | WHKT(4,5+IIGLU1) =WHKK(4,NC1T) |
| 37919 | IDHKT(6+IIGLU1) =88888 |
| 37920 | ISTHKT(6+IIGLU1) =96 |
| 37921 | JMOHKT(1,6+IIGLU1)=4+IIGLU1 |
| 37922 | JMOHKT(2,6+IIGLU1)=5+IIGLU1 |
| 37923 | JDAHKT(1,6+IIGLU1)=0 |
| 37924 | JDAHKT(2,6+IIGLU1)=0 |
| 37925 | PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1) |
| 37926 | PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1) |
| 37927 | PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1) |
| 37928 | PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1) |
| 37929 | PHKT(5,6+IIGLU1) |
| 37930 | * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2 |
| 37931 | * -PHKT(3,6+IIGLU1)**2) |
| 37932 | CHAMAL=CHAM1 |
| 37933 | IF(IPIP.EQ.1)THEN |
| 37934 | IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3 |
| 37935 | ELSEIF(IPIP.EQ.2)THEN |
| 37936 | IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3 |
| 37937 | ENDIF |
| 37938 | C--------------------------------------------------- |
| 37939 | IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN |
| 37940 | IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN |
| 37941 | C we drop chain 6 and give the energy to chain 3 |
| 37942 | IDHKT(6+IIGLU1)=22888 |
| 37943 | XGIVE=1.D0 |
| 37944 | C WRITE(6,*)' drop chain 6 xgive=1' |
| 37945 | GO TO 7788 |
| 37946 | ELSEIF(IDHKT(4+IIGLU1).EQ.-IP21)THEN |
| 37947 | C we drop chain 6 and give the energy to chain 3 |
| 37948 | C and change KK11 to IDHKT(5) |
| 37949 | IDHKT(6+IIGLU1)=22888 |
| 37950 | XGIVE=1.D0 |
| 37951 | C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(5)' |
| 37952 | KK11=IDHKT(5+IIGLU1) |
| 37953 | GO TO 7788 |
| 37954 | ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP11)THEN |
| 37955 | C we drop chain 6 and give the energy to chain 3 |
| 37956 | C and change KK21 to IDHKT(5+IIGLU1) |
| 37957 | C IDHKT(1) =1000*IPP11+100*IPP12+1 |
| 37958 | IDHKT(6+IIGLU1)=22888 |
| 37959 | XGIVE=1.D0 |
| 37960 | C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(5+IIGLU1)' |
| 37961 | KK21=IDHKT(5+IIGLU1) |
| 37962 | GO TO 7788 |
| 37963 | ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP12)THEN |
| 37964 | C we drop chain 6 and give the energy to chain 3 |
| 37965 | C and change KK22 to IDHKT(5) |
| 37966 | C IDHKT(1) =1000*IPP11+100*IPP12+1 |
| 37967 | IDHKT(6+IIGLU1)=22888 |
| 37968 | XGIVE=1.D0 |
| 37969 | C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(5+IIGLU1)' |
| 37970 | KK22=IDHKT(5+IIGLU1) |
| 37971 | GO TO 7788 |
| 37972 | ENDIF |
| 37973 | C IREJ=1 |
| 37974 | IPCO=0 |
| 37975 | C RETURN |
| 37976 | GO TO 3466 |
| 37977 | ENDIF |
| 37978 | 7788 CONTINUE |
| 37979 | C--------------------------------------------------- |
| 37980 | IF(IPIP.GE.3)THEN |
| 37981 | WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1), |
| 37982 | * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1), |
| 37983 | *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5) |
| 37984 | WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1), |
| 37985 | * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1), |
| 37986 | *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5) |
| 37987 | WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1), |
| 37988 | * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1), |
| 37989 | *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5) |
| 37990 | ENDIF |
| 37991 | VHKT(1,6+IIGLU1) =VHKK(1,NC1) |
| 37992 | VHKT(2,6+IIGLU1) =VHKK(2,NC1) |
| 37993 | VHKT(3,6+IIGLU1) =VHKK(3,NC1) |
| 37994 | VHKT(4,6+IIGLU1) =VHKK(4,NC1) |
| 37995 | WHKT(1,6+IIGLU1) =WHKK(1,NC1) |
| 37996 | WHKT(2,6+IIGLU1) =WHKK(2,NC1) |
| 37997 | WHKT(3,6+IIGLU1) =WHKK(3,NC1) |
| 37998 | WHKT(4,6+IIGLU1) =WHKK(4,NC1) |
| 37999 | C IDHKT(1) =1000*IPP11+100*IPP12+1 |
| 38000 | IF(IPIP.EQ.1)THEN |
| 38001 | IDHKT(1) =1000*KK21+100*KK22+3 |
| 38002 | IF(IDHKT(1).EQ.1203)IDHKT(1)=2103 |
| 38003 | IF(IDHKT(1).EQ.1303)IDHKT(1)=3103 |
| 38004 | IF(IDHKT(1).EQ.2303)IDHKT(1)=3203 |
| 38005 | ELSEIF(IPIP.EQ.2)THEN |
| 38006 | IDHKT(1) =1000*KK21+100*KK22-3 |
| 38007 | IF(IDHKT(1).EQ.-1203)IDHKT(1)=-2103 |
| 38008 | IF(IDHKT(1).EQ.-1303)IDHKT(1)=-3103 |
| 38009 | IF(IDHKT(1).EQ.-2303)IDHKT(1)=-3203 |
| 38010 | ENDIF |
| 38011 | ISTHKT(1) =961 |
| 38012 | JMOHKT(1,1)=NC2P |
| 38013 | JMOHKT(2,1)=0 |
| 38014 | JDAHKT(1,1)=3+IIGLU1 |
| 38015 | JDAHKT(2,1)=0 |
| 38016 | C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2) |
| 38017 | PHKT(1,1) =PHKK(1,NC2P) |
| 38018 | *+XGIVE*PHKT(1,4+IIGLU1) |
| 38019 | PHKT(2,1) =PHKK(2,NC2P) |
| 38020 | *+XGIVE*PHKT(2,4+IIGLU1) |
| 38021 | PHKT(3,1) =PHKK(3,NC2P) |
| 38022 | *+XGIVE*PHKT(3,4+IIGLU1) |
| 38023 | PHKT(4,1) =PHKK(4,NC2P) |
| 38024 | *+XGIVE*PHKT(4,4+IIGLU1) |
| 38025 | C PHKT(5,1) =PHKK(5,NC2P) |
| 38026 | XXMIST=PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2- |
| 38027 | *PHKT(1,1)**2 |
| 38028 | IF(XXMIST.GT.0.D0)THEN |
| 38029 | PHKT(5,1) =SQRT(XXMIST) |
| 38030 | ELSE |
| 38031 | WRITE(LOUT,*)'MGSQBS2',XXMIST |
| 38032 | XXMIST=ABS(XXMIST) |
| 38033 | PHKT(5,1) =SQRT(XXMIST) |
| 38034 | ENDIF |
| 38035 | VHKT(1,1) =VHKK(1,NC2P) |
| 38036 | VHKT(2,1) =VHKK(2,NC2P) |
| 38037 | VHKT(3,1) =VHKK(3,NC2P) |
| 38038 | VHKT(4,1) =VHKK(4,NC2P) |
| 38039 | WHKT(1,1) =WHKK(1,NC2P) |
| 38040 | WHKT(2,1) =WHKK(2,NC2P) |
| 38041 | WHKT(3,1) =WHKK(3,NC2P) |
| 38042 | WHKT(4,1) =WHKK(4,NC2P) |
| 38043 | C Add here IIGLU1 gluons to this chaina |
| 38044 | PG1=0.D0 |
| 38045 | PG2=0.D0 |
| 38046 | PG3=0.D0 |
| 38047 | PG4=0.D0 |
| 38048 | IF(IIGLU1.GE.1)THEN |
| 38049 | JJG=NC1P |
| 38050 | DO 61 IIG=2,2+IIGLU1-1 |
| 38051 | KKG=JJG+IIG-1 |
| 38052 | IDHKT(IIG) =IDHKK(KKG) |
| 38053 | ISTHKT(IIG) =921 |
| 38054 | JMOHKT(1,IIG)=KKG |
| 38055 | JMOHKT(2,IIG)=0 |
| 38056 | JDAHKT(1,IIG)=3+IIGLU1 |
| 38057 | JDAHKT(2,IIG)=0 |
| 38058 | PHKT(1,IIG)=PHKK(1,KKG) |
| 38059 | PG1=PG1+ PHKT(1,IIG) |
| 38060 | PHKT(2,IIG)=PHKK(2,KKG) |
| 38061 | PG2=PG2+ PHKT(2,IIG) |
| 38062 | PHKT(3,IIG)=PHKK(3,KKG) |
| 38063 | PG3=PG3+ PHKT(3,IIG) |
| 38064 | PHKT(4,IIG)=PHKK(4,KKG) |
| 38065 | PG4=PG4+ PHKT(4,IIG) |
| 38066 | PHKT(5,IIG)=PHKK(5,KKG) |
| 38067 | VHKT(1,IIG) =VHKK(1,KKG) |
| 38068 | VHKT(2,IIG) =VHKK(2,KKG) |
| 38069 | VHKT(3,IIG) =VHKK(3,KKG) |
| 38070 | VHKT(4,IIG) =VHKK(4,KKG) |
| 38071 | WHKT(1,IIG) =WHKK(1,KKG) |
| 38072 | WHKT(2,IIG) =WHKK(2,KKG) |
| 38073 | WHKT(3,IIG) =WHKK(3,KKG) |
| 38074 | WHKT(4,IIG) =WHKK(4,KKG) |
| 38075 | 61 CONTINUE |
| 38076 | ENDIF |
| 38077 | C IDHKT(2) =IP21 |
| 38078 | IDHKT(2+IIGLU1) =KK11 |
| 38079 | ISTHKT(2+IIGLU1) =962 |
| 38080 | JMOHKT(1,2+IIGLU1)=NC1T |
| 38081 | JMOHKT(2,2+IIGLU1)=0 |
| 38082 | JDAHKT(1,2+IIGLU1)=3+IIGLU1 |
| 38083 | JDAHKT(2,2+IIGLU1)=0 |
| 38084 | PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1) |
| 38085 | C * +0.5D0*PHKK(1,NC2T) |
| 38086 | *+XGIVE*PHKT(1,5+IIGLU1) |
| 38087 | PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1) |
| 38088 | C *+0.5D0*PHKK(2,NC2T) |
| 38089 | *+XGIVE*PHKT(2,5+IIGLU1) |
| 38090 | PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1) |
| 38091 | C *+0.5D0*PHKK(3,NC2T) |
| 38092 | *+XGIVE*PHKT(3,5+IIGLU1) |
| 38093 | PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1) |
| 38094 | C *+0.5D0*PHKK(4,NC2T) |
| 38095 | *+XGIVE*PHKT(4,5+IIGLU1) |
| 38096 | C PHKT(5,2) =PHKK(5,NC1T) |
| 38097 | XXMIST=(PHKT(4,2+IIGLU1)**2- |
| 38098 | * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2- |
| 38099 | *PHKT(1,2+IIGLU1)**2) |
| 38100 | IF(XXMIST.GT.0.D0)THEN |
| 38101 | PHKT(5,2+IIGLU1) =SQRT(XXMIST) |
| 38102 | ELSE |
| 38103 | WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST |
| 38104 | XXMIST=ABS(XXMIST) |
| 38105 | PHKT(5,2+IIGLU1) =SQRT(XXMIST) |
| 38106 | ENDIF |
| 38107 | VHKT(1,2+IIGLU1) =VHKK(1,NC1T) |
| 38108 | VHKT(2,2+IIGLU1) =VHKK(2,NC1T) |
| 38109 | VHKT(3,2+IIGLU1) =VHKK(3,NC1T) |
| 38110 | VHKT(4,2+IIGLU1) =VHKK(4,NC1T) |
| 38111 | WHKT(1,2+IIGLU1) =WHKK(1,NC1T) |
| 38112 | WHKT(2,2+IIGLU1) =WHKK(2,NC1T) |
| 38113 | WHKT(3,2+IIGLU1) =WHKK(3,NC1T) |
| 38114 | WHKT(4,2+IIGLU1) =WHKK(4,NC1T) |
| 38115 | IDHKT(3+IIGLU1) =88888 |
| 38116 | ISTHKT(3+IIGLU1) =96 |
| 38117 | JMOHKT(1,3+IIGLU1)=1 |
| 38118 | JMOHKT(2,3+IIGLU1)=2+IIGLU1 |
| 38119 | JDAHKT(1,3+IIGLU1)=0 |
| 38120 | JDAHKT(2,3+IIGLU1)=0 |
| 38121 | PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1 |
| 38122 | PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2 |
| 38123 | PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3 |
| 38124 | PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4 |
| 38125 | PHKT(5,3+IIGLU1) |
| 38126 | * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2 |
| 38127 | * -PHKT(3,3+IIGLU1)**2) |
| 38128 | IF(IPIP.EQ.3)THEN |
| 38129 | WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1), |
| 38130 | * JDAHKT(1,1), |
| 38131 | *JDAHKT(2,1),(PHKT(III,1),III=1,5) |
| 38132 | DO 71 IIG=2,2+IIGLU1-1 |
| 38133 | WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG), |
| 38134 | & JMOHKT(1,IIG),JMOHKT(2,IIG), |
| 38135 | * JDAHKT(1,IIG), |
| 38136 | *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) |
| 38137 | 71 CONTINUE |
| 38138 | WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1), |
| 38139 | * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1), |
| 38140 | *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5) |
| 38141 | WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1), |
| 38142 | * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1), |
| 38143 | *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5) |
| 38144 | ENDIF |
| 38145 | CHAMAL=CHAB1 |
| 38146 | IF(IPIP.EQ.1)THEN |
| 38147 | IF(IPP11.GE.3.OR.IPP12.GE.3.OR.IP21.GE.3)CHAMAL=CHAB3 |
| 38148 | ELSEIF(IPIP.EQ.2)THEN |
| 38149 | IF(IPP11.LE.-3.OR.IPP12.LE.-3.OR.IP21.LE.-3)CHAMAL=CHAB3 |
| 38150 | ENDIF |
| 38151 | IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN |
| 38152 | C IREJ=1 |
| 38153 | IPCO=0 |
| 38154 | C RETURN |
| 38155 | GO TO 3466 |
| 38156 | ENDIF |
| 38157 | VHKT(1,3+IIGLU1) =VHKK(1,NC1) |
| 38158 | VHKT(2,3+IIGLU1) =VHKK(2,NC1) |
| 38159 | VHKT(3,3+IIGLU1) =VHKK(3,NC1) |
| 38160 | VHKT(4,3+IIGLU1) =VHKK(4,NC1) |
| 38161 | WHKT(1,3+IIGLU1) =WHKK(1,NC1) |
| 38162 | WHKT(2,3+IIGLU1) =WHKK(2,NC1) |
| 38163 | WHKT(3,3+IIGLU1) =WHKK(3,NC1) |
| 38164 | WHKT(4,3+IIGLU1) =WHKK(4,NC1) |
| 38165 | C IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+1 |
| 38166 | IDHKT(7+IIGLU1) =IP1 |
| 38167 | ISTHKT(7+IIGLU1) =961 |
| 38168 | JMOHKT(1,7+IIGLU1)=NC1P |
| 38169 | JMOHKT(2,7+IIGLU1)=0 |
| 38170 | JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2 |
| 38171 | JDAHKT(2,7+IIGLU1)=0 |
| 38172 | PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1) |
| 38173 | PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1) |
| 38174 | PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1) |
| 38175 | PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1) |
| 38176 | C PHKT(5,7+IIGLU1) =PHKK(5,NC1P) |
| 38177 | XXMIST=(PHKT(4,7+IIGLU1)**2- |
| 38178 | * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2- |
| 38179 | *PHKT(1,7+IIGLU1)**2) |
| 38180 | IF(XXMIST.GT.0.D0)THEN |
| 38181 | PHKT(5,7+IIGLU1) =SQRT(XXMIST) |
| 38182 | ELSE |
| 38183 | WRITE(LOUT,*)' MGSQBS2, XXMIST',XXMIST |
| 38184 | XXMIST=ABS(XXMIST) |
| 38185 | PHKT(5,7+IIGLU1) =SQRT(XXMIST) |
| 38186 | ENDIF |
| 38187 | VHKT(1,7+IIGLU1) =VHKK(1,NC1P) |
| 38188 | VHKT(2,7+IIGLU1) =VHKK(2,NC1P) |
| 38189 | VHKT(3,7+IIGLU1) =VHKK(3,NC1P) |
| 38190 | VHKT(4,7+IIGLU1) =VHKK(4,NC1P) |
| 38191 | WHKT(1,7+IIGLU1) =WHKK(1,NC1P) |
| 38192 | WHKT(2,7+IIGLU1) =WHKK(2,NC1P) |
| 38193 | WHKT(3,7+IIGLU1) =WHKK(3,NC1P) |
| 38194 | WHKT(4,7+IIGLU1) =WHKK(4,NC2P) |
| 38195 | C IDHKT(7) =1000*IPP1+100*ISQ+1 |
| 38196 | C Insert here the IIGLU2 gluons |
| 38197 | PG1=0.D0 |
| 38198 | PG2=0.D0 |
| 38199 | PG3=0.D0 |
| 38200 | PG4=0.D0 |
| 38201 | IF(IIGLU2.GE.1)THEN |
| 38202 | JJG=NC2P |
| 38203 | DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 |
| 38204 | KKG=JJG+IIG-7-IIGLU1 |
| 38205 | IDHKT(IIG) =IDHKK(KKG) |
| 38206 | ISTHKT(IIG) =921 |
| 38207 | JMOHKT(1,IIG)=KKG |
| 38208 | JMOHKT(2,IIG)=0 |
| 38209 | JDAHKT(1,IIG)=9+IIGLU1+IIGLU2 |
| 38210 | JDAHKT(2,IIG)=0 |
| 38211 | PHKT(1,IIG)=PHKK(1,KKG) |
| 38212 | PG1=PG1+ PHKT(1,IIG) |
| 38213 | PHKT(2,IIG)=PHKK(2,KKG) |
| 38214 | PG2=PG2+ PHKT(2,IIG) |
| 38215 | PHKT(3,IIG)=PHKK(3,KKG) |
| 38216 | PG3=PG3+ PHKT(3,IIG) |
| 38217 | PHKT(4,IIG)=PHKK(4,KKG) |
| 38218 | PG4=PG4+ PHKT(4,IIG) |
| 38219 | PHKT(5,IIG)=PHKK(5,KKG) |
| 38220 | VHKT(1,IIG) =VHKK(1,KKG) |
| 38221 | VHKT(2,IIG) =VHKK(2,KKG) |
| 38222 | VHKT(3,IIG) =VHKK(3,KKG) |
| 38223 | VHKT(4,IIG) =VHKK(4,KKG) |
| 38224 | WHKT(1,IIG) =WHKK(1,KKG) |
| 38225 | WHKT(2,IIG) =WHKK(2,KKG) |
| 38226 | WHKT(3,IIG) =WHKK(3,KKG) |
| 38227 | WHKT(4,IIG) =WHKK(4,KKG) |
| 38228 | 81 CONTINUE |
| 38229 | ENDIF |
| 38230 | IF(IPIP.EQ.1)THEN |
| 38231 | IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3 |
| 38232 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103 |
| 38233 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103 |
| 38234 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203 |
| 38235 | ELSEIF(IPIP.EQ.2)THEN |
| 38236 | **NEW |
| 38237 | C IDHKT(8) =1000*IPP2+100*(-ISQ1+6)-3 |
| 38238 | IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3 |
| 38239 | ** |
| 38240 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103 |
| 38241 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103 |
| 38242 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203 |
| 38243 | ENDIF |
| 38244 | ISTHKT(8+IIGLU1+IIGLU2) =962 |
| 38245 | JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T |
| 38246 | JMOHKT(2,8+IIGLU1+IIGLU2)=0 |
| 38247 | JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2 |
| 38248 | JDAHKT(2,8+IIGLU1+IIGLU2)=0 |
| 38249 | C PHKT(1,8) =0.5D0*PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ/(XDIQT+XSQ) |
| 38250 | C PHKT(2,8) =0.5D0*PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ/(XDIQT+XSQ) |
| 38251 | C PHKT(3,8) =0.5D0*PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ/(XDIQT+XSQ) |
| 38252 | C PHKT(4,8) =0.5D0*PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ/(XDIQT+XSQ) |
| 38253 | PHKT(1,8+IIGLU1+IIGLU2) = |
| 38254 | * PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1) |
| 38255 | PHKT(2,8+IIGLU1+IIGLU2) = |
| 38256 | * PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1) |
| 38257 | PHKT(3,8+IIGLU1+IIGLU2) = |
| 38258 | * PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1) |
| 38259 | PHKT(4,8+IIGLU1+IIGLU2) = |
| 38260 | * PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1) |
| 38261 | C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)', |
| 38262 | C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7) |
| 38263 | IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN |
| 38264 | C IREJ=1 |
| 38265 | C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)' |
| 38266 | IPCO=0 |
| 38267 | C RETURN |
| 38268 | GO TO 3466 |
| 38269 | ENDIF |
| 38270 | C PHKT(5,8) =PHKK(5,NC2T) |
| 38271 | PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2- |
| 38272 | * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2- |
| 38273 | *PHKT(1,8+IIGLU1+IIGLU2)**2) |
| 38274 | VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T) |
| 38275 | VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T) |
| 38276 | VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T) |
| 38277 | VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T) |
| 38278 | WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T) |
| 38279 | WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T) |
| 38280 | WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T) |
| 38281 | WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T) |
| 38282 | IDHKT(9+IIGLU1+IIGLU2) =88888 |
| 38283 | ISTHKT(9+IIGLU1+IIGLU2) =96 |
| 38284 | JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1 |
| 38285 | JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2 |
| 38286 | JDAHKT(1,9+IIGLU1+IIGLU2)=0 |
| 38287 | JDAHKT(2,9+IIGLU1+IIGLU2)=0 |
| 38288 | PHKT(1,9+IIGLU1+IIGLU2) |
| 38289 | * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1 |
| 38290 | PHKT(2,9+IIGLU1+IIGLU2) |
| 38291 | * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2 |
| 38292 | PHKT(3,9+IIGLU1+IIGLU2) |
| 38293 | * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3 |
| 38294 | PHKT(4,9+IIGLU1+IIGLU2) |
| 38295 | * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4 |
| 38296 | PHKT(5,9+IIGLU1+IIGLU2) |
| 38297 | * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2- |
| 38298 | * PHKT(2,9+IIGLU1+IIGLU2)**2 |
| 38299 | * -PHKT(3,9+IIGLU1+IIGLU2)**2) |
| 38300 | IF(IPIP.GE.3)THEN |
| 38301 | WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1), |
| 38302 | * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1), |
| 38303 | *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5) |
| 38304 | DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 |
| 38305 | WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG), |
| 38306 | & JMOHKT(1,IIG),JMOHKT(2,IIG), |
| 38307 | * JDAHKT(1,IIG), |
| 38308 | *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) |
| 38309 | 91 CONTINUE |
| 38310 | WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2), |
| 38311 | * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2), |
| 38312 | *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2), |
| 38313 | *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5) |
| 38314 | WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2), |
| 38315 | * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2), |
| 38316 | *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2), |
| 38317 | *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5) |
| 38318 | ENDIF |
| 38319 | CHAMAL=CHAB1 |
| 38320 | IF(IPIP.EQ.1)THEN |
| 38321 | IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3 |
| 38322 | ELSEIF(IPIP.EQ.2)THEN |
| 38323 | IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3 |
| 38324 | ENDIF |
| 38325 | IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN |
| 38326 | C IREJ=1 |
| 38327 | IPCO=0 |
| 38328 | C RETURN |
| 38329 | GO TO 3466 |
| 38330 | ENDIF |
| 38331 | VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1) |
| 38332 | VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1) |
| 38333 | VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1) |
| 38334 | VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1) |
| 38335 | WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1) |
| 38336 | WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1) |
| 38337 | WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1) |
| 38338 | WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1) |
| 38339 | C |
| 38340 | IPCO=0 |
| 38341 | IGCOUN=9+IIGLU1+IIGLU2 |
| 38342 | RETURN |
| 38343 | END |
| 38344 | |
| 38345 | *$ CREATE MUSQBS1.FOR |
| 38346 | *COPY MUSQBS1 |
| 38347 | C |
| 38348 | C |
| 38349 | C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| 38350 | SUBROUTINE MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, |
| 38351 | * IP11,IP12,IP2,IPP1,IPP2,IPIP,ISQ,IGCOUN) |
| 38352 | C |
| 38353 | C USQBS-1 diagram (split projectile diquark) |
| 38354 | C |
| 38355 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 38356 | SAVE |
| 38357 | |
| 38358 | PARAMETER ( LINP = 10 , |
| 38359 | & LOUT = 6 , |
| 38360 | & LDAT = 9 ) |
| 38361 | * event history |
| 38362 | PARAMETER (NMXHKK=200000) |
| 38363 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 38364 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 38365 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 38366 | * extended event history |
| 38367 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 38368 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 38369 | & IHIST(2,NMXHKK) |
| 38370 | * Lorentz-parameters of the current interaction |
| 38371 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, |
| 38372 | & UMO,PPCM,EPROJ,PPROJ |
| 38373 | * diquark-breaking mechanism |
| 38374 | COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3 |
| 38375 | |
| 38376 | C |
| 38377 | PARAMETER (NTMHKK= 300) |
| 38378 | COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT |
| 38379 | +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT |
| 38380 | +(4,NTMHKK) |
| 38381 | *KEEP,XSEADI. |
| 38382 | COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA, |
| 38383 | +SSMIMQ,VVMTHR |
| 38384 | *KEEP,DPRIN. |
| 38385 | COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR |
| 38386 | COMMON /EVFLAG/ NUMEV |
| 38387 | C |
| 38388 | C USQBS-1 diagram (split projectile diquark) |
| 38389 | C |
| 38390 | C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T) |
| 38391 | C Input chain 2(NC2) sea-quark(NC2P)-sea-antiquark(NC2T) |
| 38392 | C |
| 38393 | C Create quark(qsP)-antiquark(aqsT) pair, energy from NC1P and NC1T |
| 38394 | C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P |
| 38395 | C |
| 38396 | C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2) |
| 38397 | C 6 valence quark(vq2P 4)-sea-quark(aqsT 5) |
| 38398 | C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8) |
| 38399 | C |
| 38400 | C Put new chains into COMMON /HKKTMP/ |
| 38401 | C |
| 38402 | IIGLU1=NC1T-NC1P-1 |
| 38403 | IIGLU2=NC2T-NC2P-1 |
| 38404 | IGCOUN=0 |
| 38405 | C WRITE(6,*)'MUSQBS1: IIGLU1,IIGLU2,IPIP ',IIGLU1,IIGLU2,IPIP |
| 38406 | CVQ=1.D0 |
| 38407 | IREJ=0 |
| 38408 | IF(IPIP.EQ.3)THEN |
| 38409 | C IF(NUMEV.EQ.-324)THEN |
| 38410 | WRITE(LOUT,*)' MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,', |
| 38411 | * ' IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN)', |
| 38412 | *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, |
| 38413 | * IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN |
| 38414 | ENDIF |
| 38415 | C |
| 38416 | C |
| 38417 | C |
| 38418 | C determine x-values of NC1P diquark |
| 38419 | XDIQP=PHKK(4,NC1P)*2.D0/UMO |
| 38420 | XVQT=PHKK(4,NC1T)*2.D0/UMO |
| 38421 | C |
| 38422 | C determine x-values of sea quark pair |
| 38423 | C |
| 38424 | IPCO=1 |
| 38425 | ICOU=0 |
| 38426 | 2234 CONTINUE |
| 38427 | ICOU=ICOU+1 |
| 38428 | IF(ICOU.GE.500)THEN |
| 38429 | IREJ=1 |
| 38430 | IF(ISQ.EQ.3)IREJ=3 |
| 38431 | IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 2234 ICOU. GT.100' |
| 38432 | IPCO=0 |
| 38433 | RETURN |
| 38434 | ENDIF |
| 38435 | IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 call XSEAPA: UMO,XDIQP,XVQT ', |
| 38436 | * UMO, XDIQP,XVQT |
| 38437 | XSQ=0.D0 |
| 38438 | XSAQ=0.D0 |
| 38439 | **NEW |
| 38440 | C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ) |
| 38441 | IF (IPIP.EQ.1) THEN |
| 38442 | XQMAX = XDIQP/2.0D0 |
| 38443 | XAQMAX = 2.D0*XVQT/3.0D0 |
| 38444 | ELSE |
| 38445 | XQMAX = 2.D0*XVQT/3.0D0 |
| 38446 | XAQMAX = XDIQP/2.0D0 |
| 38447 | ENDIF |
| 38448 | CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ) |
| 38449 | ISAQ = 6+ISQ |
| 38450 | C write(*,*) 'MUSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT |
| 38451 | ** |
| 38452 | IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ |
| 38453 | IF(IREJ.GE.1)THEN |
| 38454 | IF(IPCO.GE.3) |
| 38455 | & WRITE(LOUT,*)'MUSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ |
| 38456 | IPCO=0 |
| 38457 | RETURN |
| 38458 | ENDIF |
| 38459 | IF(IPIP.EQ.1)THEN |
| 38460 | IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234 |
| 38461 | ELSEIF(IPIP.EQ.2)THEN |
| 38462 | IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234 |
| 38463 | ENDIF |
| 38464 | IF(IPCO.GE.3)THEN |
| 38465 | WRITE(LOUT,'(A,4E12.4)')' MUSQBS1 XDIQP,XVQT,XSQ,XSAQ ', |
| 38466 | * XDIQP,XVQT,XSQ,XSAQ |
| 38467 | ENDIF |
| 38468 | C |
| 38469 | C subtract xsq,xsaq from NC1P diquark and NC1T quark |
| 38470 | C |
| 38471 | C XSQ=0.D0 |
| 38472 | IF(IPIP.EQ.1)THEN |
| 38473 | XDIQP=XDIQP-XSQ |
| 38474 | XVQT =XVQT -XSAQ |
| 38475 | ELSEIF(IPIP.EQ.2)THEN |
| 38476 | XDIQP=XDIQP-XSAQ |
| 38477 | XVQT =XVQT -XSQ |
| 38478 | ENDIF |
| 38479 | IF(IPCO.GE.3) |
| 38480 | & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT |
| 38481 | C |
| 38482 | C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P |
| 38483 | C |
| 38484 | XVTHRO=CVQ/UMO |
| 38485 | IVTHR=0 |
| 38486 | 3466 CONTINUE |
| 38487 | IF(IVTHR.EQ.10)THEN |
| 38488 | IREJ=1 |
| 38489 | IF(ISQ.EQ.3)IREJ=3 |
| 38490 | IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 3466 reject IVTHR 10' |
| 38491 | IPCO=0 |
| 38492 | RETURN |
| 38493 | ENDIF |
| 38494 | IVTHR=IVTHR+1 |
| 38495 | XVTHR=XVTHRO/(201-IVTHR) |
| 38496 | UNOPRV=UNON |
| 38497 | 380 CONTINUE |
| 38498 | IF(XVTHR.GT.0.66D0*XDIQP)THEN |
| 38499 | IREJ=1 |
| 38500 | IF(ISQ.EQ.3)IREJ=3 |
| 38501 | IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 380 XVTHR large ', |
| 38502 | * XVTHR |
| 38503 | IPCO=0 |
| 38504 | RETURN |
| 38505 | ENDIF |
| 38506 | IF(DT_RNDM(V).LT.0.5D0)THEN |
| 38507 | XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP) |
| 38508 | XVPQII=XDIQP-XVPQI |
| 38509 | ELSE |
| 38510 | XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP) |
| 38511 | XVPQI=XDIQP-XVPQII |
| 38512 | ENDIF |
| 38513 | IF(IPCO.GE.3)THEN |
| 38514 | WRITE(LOUT,'(A,2E12.4)')' MUSQBS1:XVPQI,XVPQII ',XVPQI,XVPQII |
| 38515 | ENDIF |
| 38516 | C |
| 38517 | C Prepare 4 momenta of new chains and chain ends |
| 38518 | C |
| 38519 | C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT |
| 38520 | C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT |
| 38521 | C +(4,NTMHKK) |
| 38522 | C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2) |
| 38523 | C 6 valence quark(vq2P 4)-sea-quark(aqsT 5) |
| 38524 | C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8) |
| 38525 | IF(IPIP.EQ.1)THEN |
| 38526 | XSQ1=XSQ |
| 38527 | XSAQ1=XSAQ |
| 38528 | ISQ1=ISQ |
| 38529 | ISAQ1=ISAQ |
| 38530 | ELSEIF(IPIP.EQ.2)THEN |
| 38531 | XSQ1=XSAQ |
| 38532 | XSAQ1=XSQ |
| 38533 | ISQ1=ISAQ |
| 38534 | ISAQ1=ISQ |
| 38535 | ENDIF |
| 38536 | IDHKT(1) =IP11 |
| 38537 | ISTHKT(1) =931 |
| 38538 | JMOHKT(1,1)=NC1P |
| 38539 | JMOHKT(2,1)=0 |
| 38540 | JDAHKT(1,1)=3+IIGLU1 |
| 38541 | JDAHKT(2,1)=0 |
| 38542 | C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2) |
| 38543 | PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1) |
| 38544 | PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1) |
| 38545 | PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1) |
| 38546 | PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1) |
| 38547 | C PHKT(5,1) =PHKK(5,NC1P) |
| 38548 | XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2- |
| 38549 | *PHKT(1,1)**2) |
| 38550 | IF(XMIST.GE.0.D0)THEN |
| 38551 | PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2- |
| 38552 | *PHKT(1,1)**2) |
| 38553 | ELSE |
| 38554 | C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST |
| 38555 | PHKT(5,1)=0.D0 |
| 38556 | ENDIF |
| 38557 | VHKT(1,1) =VHKK(1,NC1P) |
| 38558 | VHKT(2,1) =VHKK(2,NC1P) |
| 38559 | VHKT(3,1) =VHKK(3,NC1P) |
| 38560 | VHKT(4,1) =VHKK(4,NC1P) |
| 38561 | WHKT(1,1) =WHKK(1,NC1P) |
| 38562 | WHKT(2,1) =WHKK(2,NC1P) |
| 38563 | WHKT(3,1) =WHKK(3,NC1P) |
| 38564 | WHKT(4,1) =WHKK(4,NC1P) |
| 38565 | C Add here IIGLU1 gluons to this chaina |
| 38566 | PG1=0.D0 |
| 38567 | PG2=0.D0 |
| 38568 | PG3=0.D0 |
| 38569 | PG4=0.D0 |
| 38570 | IF(IIGLU1.GE.1)THEN |
| 38571 | JJG=NC1P |
| 38572 | DO 61 IIG=2,2+IIGLU1-1 |
| 38573 | KKG=JJG+IIG-1 |
| 38574 | IDHKT(IIG) =IDHKK(KKG) |
| 38575 | ISTHKT(IIG) =921 |
| 38576 | JMOHKT(1,IIG)=KKG |
| 38577 | JMOHKT(2,IIG)=0 |
| 38578 | JDAHKT(1,IIG)=3+IIGLU1 |
| 38579 | JDAHKT(2,IIG)=0 |
| 38580 | PHKT(1,IIG)=PHKK(1,KKG) |
| 38581 | PG1=PG1+ PHKT(1,IIG) |
| 38582 | PHKT(2,IIG)=PHKK(2,KKG) |
| 38583 | PG2=PG2+ PHKT(2,IIG) |
| 38584 | PHKT(3,IIG)=PHKK(3,KKG) |
| 38585 | PG3=PG3+ PHKT(3,IIG) |
| 38586 | PHKT(4,IIG)=PHKK(4,KKG) |
| 38587 | PG4=PG4+ PHKT(4,IIG) |
| 38588 | PHKT(5,IIG)=PHKK(5,KKG) |
| 38589 | VHKT(1,IIG) =VHKK(1,KKG) |
| 38590 | VHKT(2,IIG) =VHKK(2,KKG) |
| 38591 | VHKT(3,IIG) =VHKK(3,KKG) |
| 38592 | VHKT(4,IIG) =VHKK(4,KKG) |
| 38593 | WHKT(1,IIG) =WHKK(1,KKG) |
| 38594 | WHKT(2,IIG) =WHKK(2,KKG) |
| 38595 | WHKT(3,IIG) =WHKK(3,KKG) |
| 38596 | WHKT(4,IIG) =WHKK(4,KKG) |
| 38597 | 61 CONTINUE |
| 38598 | ENDIF |
| 38599 | IDHKT(2+IIGLU1) =IPP2 |
| 38600 | ISTHKT(2+IIGLU1) =932 |
| 38601 | JMOHKT(1,2+IIGLU1)=NC2T |
| 38602 | JMOHKT(2,2+IIGLU1)=0 |
| 38603 | JDAHKT(1,2+IIGLU1)=3+IIGLU1 |
| 38604 | JDAHKT(2,2+IIGLU1)=0 |
| 38605 | PHKT(1,2+IIGLU1) =PHKK(1,NC2T) |
| 38606 | PHKT(2,2+IIGLU1) =PHKK(2,NC2T) |
| 38607 | PHKT(3,2+IIGLU1) =PHKK(3,NC2T) |
| 38608 | PHKT(4,2+IIGLU1) =PHKK(4,NC2T) |
| 38609 | C PHKT(5,2+IIGLU1) =PHKK(5,NC2T) |
| 38610 | XMIST=(PHKT(4,2+IIGLU1)**2- |
| 38611 | * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2- |
| 38612 | *PHKT(1,2+IIGLU1)**2) |
| 38613 | IF(XMIST.GT.0.D0)THEN |
| 38614 | PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2- |
| 38615 | * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2- |
| 38616 | *PHKT(1,2+IIGLU1)**2) |
| 38617 | ELSE |
| 38618 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST |
| 38619 | PHKT(5,2+IIGLU1)=0.D0 |
| 38620 | ENDIF |
| 38621 | VHKT(1,2+IIGLU1) =VHKK(1,NC2T) |
| 38622 | VHKT(2,2+IIGLU1) =VHKK(2,NC2T) |
| 38623 | VHKT(3,2+IIGLU1) =VHKK(3,NC2T) |
| 38624 | VHKT(4,2+IIGLU1) =VHKK(4,NC2T) |
| 38625 | WHKT(1,2+IIGLU1) =WHKK(1,NC2T) |
| 38626 | WHKT(2,2+IIGLU1) =WHKK(2,NC2T) |
| 38627 | WHKT(3,2+IIGLU1) =WHKK(3,NC2T) |
| 38628 | WHKT(4,2+IIGLU1) =WHKK(4,NC2T) |
| 38629 | IDHKT(3+IIGLU1) =88888 |
| 38630 | ISTHKT(3+IIGLU1) =94 |
| 38631 | JMOHKT(1,3+IIGLU1)=1 |
| 38632 | JMOHKT(2,3+IIGLU1)=2+IIGLU1 |
| 38633 | JDAHKT(1,3+IIGLU1)=0 |
| 38634 | JDAHKT(2,3+IIGLU1)=0 |
| 38635 | PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1 |
| 38636 | PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2 |
| 38637 | PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3 |
| 38638 | PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4 |
| 38639 | XMIST |
| 38640 | * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2 |
| 38641 | * -PHKT(3,3+IIGLU1)**2) |
| 38642 | IF(XMIST.GE.0.D0)THEN |
| 38643 | PHKT(5,3+IIGLU1) |
| 38644 | * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2 |
| 38645 | * -PHKT(3,3+IIGLU1)**2) |
| 38646 | ELSE |
| 38647 | C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST |
| 38648 | PHKT(5,1)=0.D0 |
| 38649 | ENDIF |
| 38650 | IF(IPIP.GE.3)THEN |
| 38651 | C IF(NUMEV.EQ.-324)THEN |
| 38652 | WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1), |
| 38653 | * JMOHKT(2,1),JDAHKT(1,1), |
| 38654 | *JDAHKT(2,1),(PHKT(III,1),III=1,5) |
| 38655 | DO 71 IIG=2,2+IIGLU1-1 |
| 38656 | WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG), |
| 38657 | & JMOHKT(1,IIG),JMOHKT(2,IIG), |
| 38658 | * JDAHKT(1,IIG), |
| 38659 | *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) |
| 38660 | 71 CONTINUE |
| 38661 | WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1), |
| 38662 | * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1), |
| 38663 | *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5) |
| 38664 | WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1), |
| 38665 | * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1), |
| 38666 | *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5) |
| 38667 | ENDIF |
| 38668 | CHAMAL=CHAM1 |
| 38669 | IF(IPIP.EQ.1)THEN |
| 38670 | IF(IP11.GE.3.OR.IPP2.GE.3)CHAMAL=CHAM3 |
| 38671 | ELSEIF(IPIP.EQ.2)THEN |
| 38672 | IF(IP11.LE.-3.OR.IPP2.LE.-3)CHAMAL=CHAM3 |
| 38673 | ENDIF |
| 38674 | IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN |
| 38675 | C IREJ=1 |
| 38676 | IPCO=0 |
| 38677 | C RETURN |
| 38678 | C WRITE(6,*)' MUSQBS1 jump back from chain 3' |
| 38679 | GO TO 3466 |
| 38680 | ENDIF |
| 38681 | VHKT(1,3+IIGLU1) =VHKK(1,NC1) |
| 38682 | VHKT(2,3+IIGLU1) =VHKK(2,NC1) |
| 38683 | VHKT(3,3+IIGLU1) =VHKK(3,NC1) |
| 38684 | VHKT(4,3+IIGLU1) =VHKK(4,NC1) |
| 38685 | WHKT(1,3+IIGLU1) =WHKK(1,NC1) |
| 38686 | WHKT(2,3+IIGLU1) =WHKK(2,NC1) |
| 38687 | WHKT(3,3+IIGLU1) =WHKK(3,NC1) |
| 38688 | WHKT(4,3+IIGLU1) =WHKK(4,NC1) |
| 38689 | IDHKT(4+IIGLU1) =IP12 |
| 38690 | ISTHKT(4+IIGLU1) =931 |
| 38691 | JMOHKT(1,4+IIGLU1)=NC1P |
| 38692 | JMOHKT(2,4+IIGLU1)=0 |
| 38693 | JDAHKT(1,4+IIGLU1)=6+IIGLU1 |
| 38694 | JDAHKT(2,4+IIGLU1)=0 |
| 38695 | C create chain 6 valence quark(vq2P 4)-sea-quark(aqsT 5) |
| 38696 | PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1) |
| 38697 | PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1) |
| 38698 | PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1) |
| 38699 | PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1) |
| 38700 | C PHKT(5,4+IIGLU1) =PHKK(5,NC1P) |
| 38701 | XMIST =(PHKT(4,4+IIGLU1)**2- |
| 38702 | * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2- |
| 38703 | *PHKT(1,4+IIGLU1)**2) |
| 38704 | IF(XMIST.GT.0.D0)THEN |
| 38705 | PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2- |
| 38706 | * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2- |
| 38707 | *PHKT(1,4+IIGLU1)**2) |
| 38708 | ELSE |
| 38709 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST |
| 38710 | PHKT(5,4+IIGLU1)=0.D0 |
| 38711 | ENDIF |
| 38712 | VHKT(1,4+IIGLU1) =VHKK(1,NC1P) |
| 38713 | VHKT(2,4+IIGLU1) =VHKK(2,NC1P) |
| 38714 | VHKT(3,4+IIGLU1) =VHKK(3,NC1P) |
| 38715 | VHKT(4,4+IIGLU1) =VHKK(4,NC1P) |
| 38716 | WHKT(1,4+IIGLU1) =WHKK(1,NC1P) |
| 38717 | WHKT(2,4+IIGLU1) =WHKK(2,NC1P) |
| 38718 | WHKT(3,4+IIGLU1) =WHKK(3,NC1P) |
| 38719 | WHKT(4,4+IIGLU1) =WHKK(4,NC1P) |
| 38720 | IF(IPIP.EQ.1)THEN |
| 38721 | IDHKT(5+IIGLU1) =-(ISAQ1-6) |
| 38722 | ELSEIF(IPIP.EQ.2)THEN |
| 38723 | IDHKT(5+IIGLU1) =ISAQ1 |
| 38724 | ENDIF |
| 38725 | ISTHKT(5+IIGLU1) =932 |
| 38726 | JMOHKT(1,5+IIGLU1)=NC1T |
| 38727 | JMOHKT(2,5+IIGLU1)=0 |
| 38728 | JDAHKT(1,5+IIGLU1)=6+IIGLU1 |
| 38729 | JDAHKT(2,5+IIGLU1)=0 |
| 38730 | PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1) |
| 38731 | PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1) |
| 38732 | PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1) |
| 38733 | PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1) |
| 38734 | C IF( PHKT(4,5).EQ.0.D0)THEN |
| 38735 | C IREJ=1 |
| 38736 | CIPCO=0 |
| 38737 | CRETURN |
| 38738 | C ENDIF |
| 38739 | C PHKT(5,5) =PHKK(5,NC1T) |
| 38740 | XMIST=(PHKT(4,5+IIGLU1)**2- |
| 38741 | * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2- |
| 38742 | *PHKT(1,5+IIGLU1)**2) |
| 38743 | IF(XMIST.GT.0.D0)THEN |
| 38744 | PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2- |
| 38745 | * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2- |
| 38746 | *PHKT(1,5+IIGLU1)**2) |
| 38747 | ELSE |
| 38748 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST |
| 38749 | PHKT(5,5+IIGLU1)=0.D0 |
| 38750 | ENDIF |
| 38751 | VHKT(1,5+IIGLU1) =VHKK(1,NC1T) |
| 38752 | VHKT(2,5+IIGLU1) =VHKK(2,NC1T) |
| 38753 | VHKT(3,5+IIGLU1) =VHKK(3,NC1T) |
| 38754 | VHKT(4,5+IIGLU1) =VHKK(4,NC1T) |
| 38755 | WHKT(1,5+IIGLU1) =WHKK(1,NC1T) |
| 38756 | WHKT(2,5+IIGLU1) =WHKK(2,NC1T) |
| 38757 | WHKT(3,5+IIGLU1) =WHKK(3,NC1T) |
| 38758 | WHKT(4,5+IIGLU1) =WHKK(4,NC1T) |
| 38759 | IDHKT(6+IIGLU1) =88888 |
| 38760 | ISTHKT(6+IIGLU1) =94 |
| 38761 | JMOHKT(1,6+IIGLU1)=4+IIGLU1 |
| 38762 | JMOHKT(2,6+IIGLU1)=5+IIGLU1 |
| 38763 | JDAHKT(1,6+IIGLU1)=0 |
| 38764 | JDAHKT(2,6+IIGLU1)=0 |
| 38765 | PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1) |
| 38766 | PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1) |
| 38767 | PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1) |
| 38768 | PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1) |
| 38769 | XMIST |
| 38770 | * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2 |
| 38771 | * -PHKT(3,6+IIGLU1)**2) |
| 38772 | IF(XMIST.GE.0.D0)THEN |
| 38773 | PHKT(5,6+IIGLU1) |
| 38774 | * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2 |
| 38775 | * -PHKT(3,6+IIGLU1)**2) |
| 38776 | ELSE |
| 38777 | C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST |
| 38778 | PHKT(5,1)=0.D0 |
| 38779 | ENDIF |
| 38780 | C IF(IPIP.EQ.3)THEN |
| 38781 | CHAMAL=CHAM1 |
| 38782 | IF(IPIP.EQ.1)THEN |
| 38783 | IF(IP12.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3 |
| 38784 | ELSEIF(IPIP.EQ.2)THEN |
| 38785 | IF(IP12.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3 |
| 38786 | ENDIF |
| 38787 | IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN |
| 38788 | C IREJ=1 |
| 38789 | IPCO=0 |
| 38790 | C RETURN |
| 38791 | C WRITE(6,*)' MGSQBS1 jump back from chain 6', |
| 38792 | C * CHAMAL,PHKT(5,6+IIGLU1) |
| 38793 | GO TO 3466 |
| 38794 | ENDIF |
| 38795 | IF(IPIP.GE.3)THEN |
| 38796 | C IF(NUMEV.EQ.-324)THEN |
| 38797 | WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1), |
| 38798 | * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1), |
| 38799 | *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5) |
| 38800 | WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1), |
| 38801 | * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1), |
| 38802 | *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5) |
| 38803 | WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1), |
| 38804 | * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1), |
| 38805 | *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5) |
| 38806 | ENDIF |
| 38807 | VHKT(1,6+IIGLU1) =VHKK(1,NC1) |
| 38808 | VHKT(2,6+IIGLU1) =VHKK(2,NC1) |
| 38809 | VHKT(3,6+IIGLU1) =VHKK(3,NC1) |
| 38810 | VHKT(4,6+IIGLU1) =VHKK(4,NC1) |
| 38811 | WHKT(1,6+IIGLU1) =WHKK(1,NC1) |
| 38812 | WHKT(2,6+IIGLU1) =WHKK(2,NC1) |
| 38813 | WHKT(3,6+IIGLU1) =WHKK(3,NC1) |
| 38814 | WHKT(4,6+IIGLU1) =WHKK(4,NC1) |
| 38815 | IF(IPIP.EQ.1)THEN |
| 38816 | IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+3 |
| 38817 | IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103 |
| 38818 | IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103 |
| 38819 | IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203 |
| 38820 | ELSEIF(IPIP.EQ.2)THEN |
| 38821 | IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3 |
| 38822 | IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103 |
| 38823 | IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103 |
| 38824 | IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203 |
| 38825 | C WRITE(6,*)'IDHKT(7+IIGLU1),IPP1,ISQ1',IDHKT(7+IIGLU1),IPP1,ISQ1 |
| 38826 | ENDIF |
| 38827 | ISTHKT(7+IIGLU1) =931 |
| 38828 | JMOHKT(1,7+IIGLU1)=NC2P |
| 38829 | JMOHKT(2,7+IIGLU1)=0 |
| 38830 | JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2 |
| 38831 | JDAHKT(2,7+IIGLU1)=0 |
| 38832 | C create chain 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8) |
| 38833 | PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1) |
| 38834 | PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1) |
| 38835 | PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1) |
| 38836 | PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1) |
| 38837 | C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)', |
| 38838 | C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7) |
| 38839 | IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN |
| 38840 | C IREJ=1 |
| 38841 | C WRITE(6,*)'reject PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P)' |
| 38842 | IPCO=0 |
| 38843 | C RETURN |
| 38844 | GO TO 3466 |
| 38845 | ENDIF |
| 38846 | C PHKT(5,7) =PHKK(5,NC2P) |
| 38847 | PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2- |
| 38848 | * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2- |
| 38849 | *PHKT(1,7+IIGLU1)**2) |
| 38850 | VHKT(1,7+IIGLU1) =VHKK(1,NC2P) |
| 38851 | VHKT(2,7+IIGLU1) =VHKK(2,NC2P) |
| 38852 | VHKT(3,7+IIGLU1) =VHKK(3,NC2P) |
| 38853 | VHKT(4,7+IIGLU1) =VHKK(4,NC2P) |
| 38854 | WHKT(1,7+IIGLU1) =WHKK(1,NC2P) |
| 38855 | WHKT(2,7+IIGLU1) =WHKK(2,NC2P) |
| 38856 | WHKT(3,7+IIGLU1) =WHKK(3,NC2P) |
| 38857 | WHKT(4,7+IIGLU1) =WHKK(4,NC2P) |
| 38858 | C Insert here the IIGLU2 gluons |
| 38859 | PG1=0.D0 |
| 38860 | PG2=0.D0 |
| 38861 | PG3=0.D0 |
| 38862 | PG4=0.D0 |
| 38863 | IF(IIGLU2.GE.1)THEN |
| 38864 | JJG=NC2P |
| 38865 | DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 |
| 38866 | KKG=JJG+IIG-7-IIGLU1 |
| 38867 | IDHKT(IIG) =IDHKK(KKG) |
| 38868 | ISTHKT(IIG) =921 |
| 38869 | JMOHKT(1,IIG)=KKG |
| 38870 | JMOHKT(2,IIG)=0 |
| 38871 | JDAHKT(1,IIG)=9+IIGLU1+IIGLU2 |
| 38872 | JDAHKT(2,IIG)=0 |
| 38873 | PHKT(1,IIG)=PHKK(1,KKG) |
| 38874 | PG1=PG1+ PHKT(1,IIG) |
| 38875 | PHKT(2,IIG)=PHKK(2,KKG) |
| 38876 | PG2=PG2+ PHKT(2,IIG) |
| 38877 | PHKT(3,IIG)=PHKK(3,KKG) |
| 38878 | PG3=PG3+ PHKT(3,IIG) |
| 38879 | PHKT(4,IIG)=PHKK(4,KKG) |
| 38880 | PG4=PG4+ PHKT(4,IIG) |
| 38881 | PHKT(5,IIG)=PHKK(5,KKG) |
| 38882 | VHKT(1,IIG) =VHKK(1,KKG) |
| 38883 | VHKT(2,IIG) =VHKK(2,KKG) |
| 38884 | VHKT(3,IIG) =VHKK(3,KKG) |
| 38885 | VHKT(4,IIG) =VHKK(4,KKG) |
| 38886 | WHKT(1,IIG) =WHKK(1,KKG) |
| 38887 | WHKT(2,IIG) =WHKK(2,KKG) |
| 38888 | WHKT(3,IIG) =WHKK(3,KKG) |
| 38889 | WHKT(4,IIG) =WHKK(4,KKG) |
| 38890 | 81 CONTINUE |
| 38891 | ENDIF |
| 38892 | IDHKT(8+IIGLU1+IIGLU2) =IP2 |
| 38893 | ISTHKT(8+IIGLU1+IIGLU2) =932 |
| 38894 | JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T |
| 38895 | JMOHKT(2,8+IIGLU1+IIGLU2)=0 |
| 38896 | JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2 |
| 38897 | JDAHKT(2,8+IIGLU1+IIGLU2)=0 |
| 38898 | PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT) |
| 38899 | PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT) |
| 38900 | PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT) |
| 38901 | PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT) |
| 38902 | C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T) |
| 38903 | XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2- |
| 38904 | * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2- |
| 38905 | *PHKT(1,8+IIGLU1+IIGLU2)**2) |
| 38906 | IF(XMIST.GT.0.D0)THEN |
| 38907 | PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2- |
| 38908 | * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2- |
| 38909 | *PHKT(1,8+IIGLU1+IIGLU2)**2) |
| 38910 | ELSE |
| 38911 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST |
| 38912 | PHKT(5,8+IIGLU1+IIGLU2)=0.D0 |
| 38913 | ENDIF |
| 38914 | VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T) |
| 38915 | VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T) |
| 38916 | VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T) |
| 38917 | VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T) |
| 38918 | WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T) |
| 38919 | WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T) |
| 38920 | WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T) |
| 38921 | WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T) |
| 38922 | IDHKT(9+IIGLU1+IIGLU2) =88888 |
| 38923 | ISTHKT(9+IIGLU1+IIGLU2) =94 |
| 38924 | JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1 |
| 38925 | JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2 |
| 38926 | JDAHKT(1,9+IIGLU1+IIGLU2)=0 |
| 38927 | JDAHKT(2,9+IIGLU1+IIGLU2)=0 |
| 38928 | PHKT(1,9+IIGLU1+IIGLU2) |
| 38929 | * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1 |
| 38930 | PHKT(2,9+IIGLU1+IIGLU2) |
| 38931 | * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2 |
| 38932 | PHKT(3,9+IIGLU1+IIGLU2) |
| 38933 | * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3 |
| 38934 | PHKT(4,9+IIGLU1+IIGLU2) |
| 38935 | * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4 |
| 38936 | XMIST |
| 38937 | *=(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2 |
| 38938 | * -PHKT(2,9+IIGLU1+IIGLU2)**2 |
| 38939 | * -PHKT(3,9+IIGLU1+IIGLU2)**2) |
| 38940 | IF(XMIST.GE.0.D0)THEN |
| 38941 | PHKT(5,9+IIGLU1+IIGLU2) |
| 38942 | *=SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2 |
| 38943 | * -PHKT(2,9+IIGLU1+IIGLU2)**2 |
| 38944 | * -PHKT(3,9+IIGLU1+IIGLU2)**2) |
| 38945 | ELSE |
| 38946 | C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST |
| 38947 | PHKT(5,1)=0.D0 |
| 38948 | ENDIF |
| 38949 | IF(IPIP.GE.3)THEN |
| 38950 | C IF(NUMEV.EQ.-324)THEN |
| 38951 | WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1), |
| 38952 | * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1), |
| 38953 | *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5) |
| 38954 | DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 |
| 38955 | WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG), |
| 38956 | & JMOHKT(1,IIG),JMOHKT(2,IIG), |
| 38957 | * JDAHKT(1,IIG), |
| 38958 | *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) |
| 38959 | 91 CONTINUE |
| 38960 | WRITE(LOUT,*)8+IIGLU1+IIGLU2, |
| 38961 | * ISTHKT(8+IIGLU1+IIGLU2),IDHKT(8+IIGLU1+IIGLU2), |
| 38962 | * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2), |
| 38963 | *JDAHKT(1,8+IIGLU1+IIGLU2), |
| 38964 | *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5) |
| 38965 | WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2), |
| 38966 | * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2), |
| 38967 | *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2), |
| 38968 | *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5) |
| 38969 | ENDIF |
| 38970 | CHAMAL=CHAB1 |
| 38971 | IF(IPIP.EQ.1)THEN |
| 38972 | IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3 |
| 38973 | ELSEIF(IPIP.EQ.2)THEN |
| 38974 | IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3 |
| 38975 | ENDIF |
| 38976 | IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN |
| 38977 | C IREJ=1 |
| 38978 | IPCO=0 |
| 38979 | C RETURN |
| 38980 | C WRITE(6,*)' MGSQBS1 jump back from chain 9', |
| 38981 | C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2) |
| 38982 | GO TO 3466 |
| 38983 | ENDIF |
| 38984 | VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1) |
| 38985 | VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1) |
| 38986 | VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1) |
| 38987 | VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1) |
| 38988 | WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1) |
| 38989 | WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1) |
| 38990 | WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1) |
| 38991 | WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1) |
| 38992 | C |
| 38993 | IPCO=0 |
| 38994 | IGCOUN=9+IIGLU1+IIGLU2 |
| 38995 | RETURN |
| 38996 | END |
| 38997 | |
| 38998 | *$ CREATE MGSQBS1.FOR |
| 38999 | *COPY MGSQBS1 |
| 39000 | C |
| 39001 | C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| 39002 | SUBROUTINE MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, |
| 39003 | * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,ISQ,IGCOUN) |
| 39004 | C |
| 39005 | C GSQBS-1 diagram (split projectile diquark) |
| 39006 | C |
| 39007 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 39008 | SAVE |
| 39009 | |
| 39010 | PARAMETER ( LINP = 10 , |
| 39011 | & LOUT = 6 , |
| 39012 | & LDAT = 9 ) |
| 39013 | * event history |
| 39014 | PARAMETER (NMXHKK=200000) |
| 39015 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 39016 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 39017 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 39018 | * extended event history |
| 39019 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 39020 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 39021 | & IHIST(2,NMXHKK) |
| 39022 | * Lorentz-parameters of the current interaction |
| 39023 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, |
| 39024 | & UMO,PPCM,EPROJ,PPROJ |
| 39025 | * diquark-breaking mechanism |
| 39026 | COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3 |
| 39027 | |
| 39028 | C |
| 39029 | PARAMETER (NTMHKK= 300) |
| 39030 | COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT |
| 39031 | +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT |
| 39032 | +(4,NTMHKK) |
| 39033 | *KEEP,XSEADI. |
| 39034 | COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA, |
| 39035 | +SSMIMQ,VVMTHR |
| 39036 | *KEEP,DPRIN. |
| 39037 | COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR |
| 39038 | C |
| 39039 | C GSQBS-1 diagram (split projectile diquark) |
| 39040 | C |
| 39041 | C |
| 39042 | C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T) |
| 39043 | C Input chain 2(NC2) sea-quark(NC2P)-valence-diquark(NC2T) |
| 39044 | C |
| 39045 | C Create quark(qs)-antiquark(aqs) pair energy from NC1P and NC1T |
| 39046 | C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P |
| 39047 | C |
| 39048 | C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2) |
| 39049 | C 6 valence quark(vq2P 4)-sea-quark(aqsP 5) |
| 39050 | C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8) |
| 39051 | C |
| 39052 | C Put new chains into COMMON /HKKTMP/ |
| 39053 | C |
| 39054 | IIGLU1=NC1T-NC1P-1 |
| 39055 | IIGLU2=NC2T-NC2P-1 |
| 39056 | IGCOUN=0 |
| 39057 | C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2 |
| 39058 | CVQ=1.D0 |
| 39059 | NNNC1=IDHKK(NC1)/1000 |
| 39060 | MMMC1=IDHKK(NC1)-NNNC1*1000 |
| 39061 | KKKC1=ISTHKK(NC1) |
| 39062 | NNNC2=IDHKK(NC2)/1000 |
| 39063 | MMMC2=IDHKK(NC2)-NNNC2*1000 |
| 39064 | KKKC2=ISTHKK(NC2) |
| 39065 | IREJ=0 |
| 39066 | IF(IPIP.EQ.3)THEN |
| 39067 | WRITE(LOUT,*)' MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,', |
| 39068 | * ' IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN)', |
| 39069 | *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, |
| 39070 | * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN |
| 39071 | ENDIF |
| 39072 | C |
| 39073 | C |
| 39074 | C |
| 39075 | C determine x-values of NC1P diquark |
| 39076 | XDIQP=PHKK(4,NC1P)*2.D0/UMO |
| 39077 | XVQT=PHKK(4,NC1T)*2.D0/UMO |
| 39078 | C |
| 39079 | C determine x-values of sea quark pair |
| 39080 | C |
| 39081 | IPCO=1 |
| 39082 | ICOU=0 |
| 39083 | 2234 CONTINUE |
| 39084 | ICOU=ICOU+1 |
| 39085 | IF(ICOU.GE.500)THEN |
| 39086 | IREJ=1 |
| 39087 | IF(ISQ.EQ.3)IREJ=3 |
| 39088 | IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 Rejection 2234 ICOU. GT.100' |
| 39089 | IPCO=0 |
| 39090 | RETURN |
| 39091 | ENDIF |
| 39092 | IF(IPCO.GE.3)WRITE(LOUT,*)'MGSQBS1 call XSEAPA: UMO,XDIQP,XVQT ', |
| 39093 | * UMO, XDIQP,XVQT |
| 39094 | XSQ=0.D0 |
| 39095 | XSAQ=0.D0 |
| 39096 | **NEW |
| 39097 | C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ) |
| 39098 | IF (IPIP.EQ.1) THEN |
| 39099 | XQMAX = XDIQP/2.0D0 |
| 39100 | XAQMAX = 2.D0*XVQT/3.0D0 |
| 39101 | ELSE |
| 39102 | XQMAX = 2.D0*XVQT/3.0D0 |
| 39103 | XAQMAX = XDIQP/2.0D0 |
| 39104 | ENDIF |
| 39105 | CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ) |
| 39106 | ISAQ = 6+ISQ |
| 39107 | C write(*,*) 'MGSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT |
| 39108 | ** |
| 39109 | IF(IPCO.GE.3) |
| 39110 | & WRITE(LOUT,*)'MGSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ |
| 39111 | IF(IREJ.GE.1)THEN |
| 39112 | IF(IPCO.GE.3) |
| 39113 | & WRITE(LOUT,*)'MGSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ |
| 39114 | IPCO=0 |
| 39115 | RETURN |
| 39116 | ENDIF |
| 39117 | IF(IPIP.EQ.1)THEN |
| 39118 | IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234 |
| 39119 | ELSEIF(IPIP.EQ.2)THEN |
| 39120 | IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234 |
| 39121 | ENDIF |
| 39122 | IF(IPCO.GE.3)THEN |
| 39123 | WRITE(LOUT,'(A,4E12.4)')' MGSQBS1 XDIQP,XVQT,XSQ,XSAQ ', |
| 39124 | * XDIQP,XVQT,XSQ,XSAQ |
| 39125 | ENDIF |
| 39126 | C |
| 39127 | C subtract xsq,xsaq from NC1P diquark and NC1T quark |
| 39128 | C |
| 39129 | C XSQ=0.D0 |
| 39130 | IF(IPIP.EQ.1)THEN |
| 39131 | XDIQP=XDIQP-XSQ |
| 39132 | **NEW |
| 39133 | C IF (XDIQP.LT.0.0D0) WRITE(*,*) ' mgsqbs1: XDIQP<0!!',XDIQP |
| 39134 | ** |
| 39135 | XVQT =XVQT -XSAQ |
| 39136 | ELSEIF(IPIP.EQ.2)THEN |
| 39137 | XDIQP=XDIQP-XSAQ |
| 39138 | XVQT =XVQT -XSQ |
| 39139 | ENDIF |
| 39140 | IF(IPCO.GE.3) |
| 39141 | & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT |
| 39142 | C |
| 39143 | C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P |
| 39144 | C |
| 39145 | XVTHRO=CVQ/UMO |
| 39146 | IVTHR=0 |
| 39147 | 3466 CONTINUE |
| 39148 | IF(IVTHR.EQ.10)THEN |
| 39149 | IREJ=1 |
| 39150 | IF(ISQ.EQ.3)IREJ=3 |
| 39151 | IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 3466 reject IVTHR 10' |
| 39152 | IPCO=0 |
| 39153 | RETURN |
| 39154 | ENDIF |
| 39155 | IVTHR=IVTHR+1 |
| 39156 | XVTHR=XVTHRO/(201-IVTHR) |
| 39157 | UNOPRV=UNON |
| 39158 | 380 CONTINUE |
| 39159 | IF(XVTHR.GT.0.66D0*XDIQP)THEN |
| 39160 | IREJ=1 |
| 39161 | IF(ISQ.EQ.3)IREJ=3 |
| 39162 | IF(IPCO.GE.3) |
| 39163 | & WRITE(LOUT,*)' MGSQBS1 Rejection 380 XVTHR large ', |
| 39164 | * XVTHR |
| 39165 | IPCO=0 |
| 39166 | RETURN |
| 39167 | ENDIF |
| 39168 | IF(DT_RNDM(V).LT.0.5D0)THEN |
| 39169 | XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP) |
| 39170 | XVPQII=XDIQP-XVPQI |
| 39171 | ELSE |
| 39172 | XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP) |
| 39173 | XVPQI=XDIQP-XVPQII |
| 39174 | ENDIF |
| 39175 | IF(IPCO.GE.3)THEN |
| 39176 | WRITE(LOUT,'(A,4E12.4)')' MGSQBS1:XVTHR,XDIQP,XVPQI,XVPQII ', |
| 39177 | * XVTHR,XDIQP,XVPQI,XVPQII |
| 39178 | ENDIF |
| 39179 | C |
| 39180 | C Prepare 4 momenta of new chains and chain ends |
| 39181 | C |
| 39182 | C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT |
| 39183 | C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT |
| 39184 | C +(4,NTMHKK) |
| 39185 | C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2) |
| 39186 | C 6 valence quark(vq2P 4)-sea-quark(aqsP 5) |
| 39187 | C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8) |
| 39188 | IF(IPIP.EQ.1)THEN |
| 39189 | XSQ1=XSQ |
| 39190 | XSAQ1=XSAQ |
| 39191 | ISQ1=ISQ |
| 39192 | ISAQ1=ISAQ |
| 39193 | ELSEIF(IPIP.EQ.2)THEN |
| 39194 | XSQ1=XSAQ |
| 39195 | XSAQ1=XSQ |
| 39196 | ISQ1=ISAQ |
| 39197 | ISAQ1=ISQ |
| 39198 | ENDIF |
| 39199 | KK11=IP11 |
| 39200 | C IDHKT(2) =1000*IPP21+100*IPP22+1 |
| 39201 | KK21= IPP21 |
| 39202 | KK22= IPP22 |
| 39203 | XGIVE=0.D0 |
| 39204 | IDHKT(4+IIGLU1) =IP12 |
| 39205 | ISTHKT(4+IIGLU1) =921 |
| 39206 | JMOHKT(1,4+IIGLU1)=NC1P |
| 39207 | JMOHKT(2,4+IIGLU1)=0 |
| 39208 | JDAHKT(1,4+IIGLU1)=6+IIGLU1 |
| 39209 | JDAHKT(2,4+IIGLU1)=0 |
| 39210 | **NEW |
| 39211 | IF ((XDIQP.LT.0.0D0).OR.(XVPQII.LT.0.0D0).OR. |
| 39212 | & (XSQ1.LT.0.0D0)) WRITE(LOUT,*) ' mgsqbs1: ',XDIQP,XVPQII,XSQ1 |
| 39213 | ** |
| 39214 | PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1) |
| 39215 | PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1) |
| 39216 | PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1) |
| 39217 | PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1) |
| 39218 | C PHKT(5,4+IIGLU1) =PHKK(5,NC1P) |
| 39219 | XXMIST=(PHKT(4,4+IIGLU1)**2- |
| 39220 | * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2- |
| 39221 | * PHKT(1,4+IIGLU1)**2) |
| 39222 | IF(XXMIST.GT.0.D0)THEN |
| 39223 | PHKT(5,4+IIGLU1) =SQRT(XXMIST) |
| 39224 | ELSE |
| 39225 | WRITE(LOUT,*)'MGSQBS1 XXMIST',XXMIST |
| 39226 | XXMIST=ABS(XXMIST) |
| 39227 | PHKT(5,4+IIGLU1) =SQRT(XXMIST) |
| 39228 | ENDIF |
| 39229 | VHKT(1,4+IIGLU1) =VHKK(1,NC1P) |
| 39230 | VHKT(2,4+IIGLU1) =VHKK(2,NC1P) |
| 39231 | VHKT(3,4+IIGLU1) =VHKK(3,NC1P) |
| 39232 | VHKT(4,4+IIGLU1) =VHKK(4,NC1P) |
| 39233 | WHKT(1,4+IIGLU1) =WHKK(1,NC1P) |
| 39234 | WHKT(2,4+IIGLU1) =WHKK(2,NC1P) |
| 39235 | WHKT(3,4+IIGLU1) =WHKK(3,NC1P) |
| 39236 | WHKT(4,4+IIGLU1) =WHKK(4,NC1P) |
| 39237 | IF(IPIP.EQ.1)THEN |
| 39238 | IDHKT(5+IIGLU1) =-(ISAQ1-6) |
| 39239 | ELSEIF(IPIP.EQ.2)THEN |
| 39240 | IDHKT(5+IIGLU1) =ISAQ1 |
| 39241 | ENDIF |
| 39242 | ISTHKT(5+IIGLU1) =922 |
| 39243 | JMOHKT(1,5+IIGLU1)=NC1T |
| 39244 | JMOHKT(2,5+IIGLU1)=0 |
| 39245 | JDAHKT(1,5+IIGLU1)=6+IIGLU1 |
| 39246 | JDAHKT(2,5+IIGLU1)=0 |
| 39247 | **NEW |
| 39248 | IF ((XSAQ1.LT.0.0D0).OR.(XVQT .LT.0.0D0)) |
| 39249 | & WRITE(LOUT,*) ' mgsqbs2: ',XSAQ1,XVQT |
| 39250 | ** |
| 39251 | PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1) |
| 39252 | PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1) |
| 39253 | PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1) |
| 39254 | PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1) |
| 39255 | C PHKT(5,5+IIGLU1) =PHKK(5,NC1T) |
| 39256 | XMIST=(PHKT(4,5+IIGLU1)**2- |
| 39257 | * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2- |
| 39258 | *PHKT(1,5+IIGLU1)**2) |
| 39259 | IF(XMIST.GT.0.D0)THEN |
| 39260 | PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2- |
| 39261 | * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2- |
| 39262 | *PHKT(1,5+IIGLU1)**2) |
| 39263 | ELSE |
| 39264 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST |
| 39265 | PHKT(5,5+IIGLU1)=0.D0 |
| 39266 | ENDIF |
| 39267 | VHKT(1,5+IIGLU1) =VHKK(1,NC1T) |
| 39268 | VHKT(2,5+IIGLU1) =VHKK(2,NC1T) |
| 39269 | VHKT(3,5+IIGLU1) =VHKK(3,NC1T) |
| 39270 | VHKT(4,5+IIGLU1) =VHKK(4,NC1T) |
| 39271 | WHKT(1,5+IIGLU1) =WHKK(1,NC1T) |
| 39272 | WHKT(2,5+IIGLU1) =WHKK(2,NC1T) |
| 39273 | WHKT(3,5+IIGLU1) =WHKK(3,NC1T) |
| 39274 | WHKT(4,5+IIGLU1) =WHKK(4,NC1T) |
| 39275 | IDHKT(6+IIGLU1) =88888 |
| 39276 | C IDHKT(6) =1000*NNNC1+MMMC1 |
| 39277 | ISTHKT(6+IIGLU1) =93 |
| 39278 | C ISTHKT(6) =KKKC1 |
| 39279 | JMOHKT(1,6+IIGLU1)=4+IIGLU1 |
| 39280 | JMOHKT(2,6+IIGLU1)=5+IIGLU1 |
| 39281 | JDAHKT(1,6+IIGLU1)=0 |
| 39282 | JDAHKT(2,6+IIGLU1)=0 |
| 39283 | PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1) |
| 39284 | PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1) |
| 39285 | PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1) |
| 39286 | PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1) |
| 39287 | PHKT(5,6+IIGLU1) |
| 39288 | * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2 |
| 39289 | * -PHKT(3,6+IIGLU1)**2) |
| 39290 | CHAMAL=CHAM1 |
| 39291 | IF(IPIP.EQ.1)THEN |
| 39292 | IF(IP12.GE.3.OR.ISAQ.GE.9)CHAMAL=CHAM3 |
| 39293 | ELSEIF(IPIP.EQ.2)THEN |
| 39294 | IF(IP12.LE.-3.OR.ISAQ.GE.3)CHAMAL=CHAM3 |
| 39295 | ENDIF |
| 39296 | IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN |
| 39297 | IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN |
| 39298 | C we drop chain 6 and give the energy to chain 3 |
| 39299 | IDHKT(6+IIGLU1)=33888 |
| 39300 | XGIVE=1.D0 |
| 39301 | C WRITE(6,*)' drop chain 6 xgive=1' |
| 39302 | GO TO 7788 |
| 39303 | ELSEIF(IDHKT(5+IIGLU1).EQ.-IP11)THEN |
| 39304 | C we drop chain 6 and give the energy to chain 3 |
| 39305 | C and change KK11 to IDHKT(4) |
| 39306 | IDHKT(6+IIGLU1)=33888 |
| 39307 | XGIVE=1.D0 |
| 39308 | C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(4+IIGLU1)' |
| 39309 | KK11=IDHKT(4+IIGLU1) |
| 39310 | GO TO 7788 |
| 39311 | ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP21)THEN |
| 39312 | C we drop chain 6 and give the energy to chain 3 |
| 39313 | C and change KK21 to IDHKT(4) |
| 39314 | C IDHKT(2) =1000*IPP21+100*IPP22+1 |
| 39315 | IDHKT(6+IIGLU1)=33888 |
| 39316 | XGIVE=1.D0 |
| 39317 | C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(4+IIGLU1)' |
| 39318 | KK21=IDHKT(4+IIGLU1) |
| 39319 | GO TO 7788 |
| 39320 | ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP22)THEN |
| 39321 | C we drop chain 6 and give the energy to chain 3 |
| 39322 | C and change KK22 to IDHKT(4) |
| 39323 | C IDHKT(2) =1000*IPP21+100*IPP22+1 |
| 39324 | IDHKT(6+IIGLU1)=33888 |
| 39325 | XGIVE=1.D0 |
| 39326 | C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(4+IIGLU1)' |
| 39327 | KK22=IDHKT(4+IIGLU1) |
| 39328 | GO TO 7788 |
| 39329 | ENDIF |
| 39330 | C IREJ=1 |
| 39331 | IPCO=0 |
| 39332 | C RETURN |
| 39333 | C WRITE(6,*)' MGSQBS1 jump back from chain 6' |
| 39334 | GO TO 3466 |
| 39335 | ENDIF |
| 39336 | 7788 CONTINUE |
| 39337 | IF(IPIP.GE.3)THEN |
| 39338 | WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1), |
| 39339 | * JMOHKT(1,4+IIGLU1), |
| 39340 | * JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1), |
| 39341 | *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5) |
| 39342 | WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1), |
| 39343 | * JMOHKT(1,5+IIGLU1), |
| 39344 | * JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1), |
| 39345 | *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5) |
| 39346 | WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1), |
| 39347 | * JMOHKT(1,6+IIGLU1), |
| 39348 | * JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1), |
| 39349 | *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5) |
| 39350 | ENDIF |
| 39351 | VHKT(1,6+IIGLU1) =VHKK(1,NC1) |
| 39352 | VHKT(2,6+IIGLU1) =VHKK(2,NC1) |
| 39353 | VHKT(3,6+IIGLU1) =VHKK(3,NC1) |
| 39354 | VHKT(4,6+IIGLU1) =VHKK(4,NC1) |
| 39355 | WHKT(1,6+IIGLU1) =WHKK(1,NC1) |
| 39356 | WHKT(2,6+IIGLU1) =WHKK(2,NC1) |
| 39357 | WHKT(3,6+IIGLU1) =WHKK(3,NC1) |
| 39358 | WHKT(4,6+IIGLU1) =WHKK(4,NC1) |
| 39359 | C IDHKT(1) =IP11 |
| 39360 | IDHKT(1) =KK11 |
| 39361 | ISTHKT(1) =921 |
| 39362 | JMOHKT(1,1)=NC1P |
| 39363 | JMOHKT(2,1)=0 |
| 39364 | JDAHKT(1,1)=3+IIGLU1 |
| 39365 | JDAHKT(2,1)=0 |
| 39366 | PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1) |
| 39367 | C * +0.5D0*PHKK(1,NC2P) |
| 39368 | *+XGIVE*PHKT(1,4+IIGLU1) |
| 39369 | PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1) |
| 39370 | C * +0.5D0*PHKK(2,NC2P) |
| 39371 | *+XGIVE*PHKT(2,4+IIGLU1) |
| 39372 | PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1) |
| 39373 | C * +0.5D0*PHKK(3,NC2P) |
| 39374 | *+XGIVE*PHKT(3,4+IIGLU1) |
| 39375 | PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1) |
| 39376 | C * +0.5D0*PHKK(4,NC2P) |
| 39377 | *+XGIVE*PHKT(4,4+IIGLU1) |
| 39378 | C PHKT(5,1) =PHKK(5,NC1P) |
| 39379 | XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2- |
| 39380 | *PHKT(1,1)**2) |
| 39381 | IF(XMIST.GE.0.D0)THEN |
| 39382 | PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2- |
| 39383 | *PHKT(1,1)**2) |
| 39384 | ELSE |
| 39385 | C WRITE(6,*)'MGSQBS1 parton 1 mass square LT.0 ',XMIST |
| 39386 | PHKT(5,1)=0.D0 |
| 39387 | ENDIF |
| 39388 | VHKT(1,1) =VHKK(1,NC1P) |
| 39389 | VHKT(2,1) =VHKK(2,NC1P) |
| 39390 | VHKT(3,1) =VHKK(3,NC1P) |
| 39391 | VHKT(4,1) =VHKK(4,NC1P) |
| 39392 | WHKT(1,1) =WHKK(1,NC1P) |
| 39393 | WHKT(2,1) =WHKK(2,NC1P) |
| 39394 | WHKT(3,1) =WHKK(3,NC1P) |
| 39395 | WHKT(4,1) =WHKK(4,NC1P) |
| 39396 | C Add here IIGLU1 gluons to this chaina |
| 39397 | PG1=0.D0 |
| 39398 | PG2=0.D0 |
| 39399 | PG3=0.D0 |
| 39400 | PG4=0.D0 |
| 39401 | IF(IIGLU1.GE.1)THEN |
| 39402 | JJG=NC1P |
| 39403 | DO 61 IIG=2,2+IIGLU1-1 |
| 39404 | KKG=JJG+IIG-1 |
| 39405 | IDHKT(IIG) =IDHKK(KKG) |
| 39406 | ISTHKT(IIG) =921 |
| 39407 | JMOHKT(1,IIG)=KKG |
| 39408 | JMOHKT(2,IIG)=0 |
| 39409 | JDAHKT(1,IIG)=3+IIGLU1 |
| 39410 | JDAHKT(2,IIG)=0 |
| 39411 | PHKT(1,IIG)=PHKK(1,KKG) |
| 39412 | PG1=PG1+ PHKT(1,IIG) |
| 39413 | PHKT(2,IIG)=PHKK(2,KKG) |
| 39414 | PG2=PG2+ PHKT(2,IIG) |
| 39415 | PHKT(3,IIG)=PHKK(3,KKG) |
| 39416 | PG3=PG3+ PHKT(3,IIG) |
| 39417 | PHKT(4,IIG)=PHKK(4,KKG) |
| 39418 | PG4=PG4+ PHKT(4,IIG) |
| 39419 | PHKT(5,IIG)=PHKK(5,KKG) |
| 39420 | VHKT(1,IIG) =VHKK(1,KKG) |
| 39421 | VHKT(2,IIG) =VHKK(2,KKG) |
| 39422 | VHKT(3,IIG) =VHKK(3,KKG) |
| 39423 | VHKT(4,IIG) =VHKK(4,KKG) |
| 39424 | WHKT(1,IIG) =WHKK(1,KKG) |
| 39425 | WHKT(2,IIG) =WHKK(2,KKG) |
| 39426 | WHKT(3,IIG) =WHKK(3,KKG) |
| 39427 | WHKT(4,IIG) =WHKK(4,KKG) |
| 39428 | 61 CONTINUE |
| 39429 | ENDIF |
| 39430 | C IDHKT(2) =1000*IPP21+100*IPP22+1 |
| 39431 | IF(IPIP.EQ.1)THEN |
| 39432 | IDHKT(2+IIGLU1) =1000*KK21+100*KK22+3 |
| 39433 | IF(IDHKT(2+IIGLU1).EQ.1203)IDHKT(2+IIGLU1)=2103 |
| 39434 | IF(IDHKT(2+IIGLU1).EQ.1303)IDHKT(2+IIGLU1)=3103 |
| 39435 | IF(IDHKT(2+IIGLU1).EQ.2303)IDHKT(2+IIGLU1)=3203 |
| 39436 | ELSEIF(IPIP.EQ.2)THEN |
| 39437 | IDHKT(2+IIGLU1) =1000*KK21+100*KK22-3 |
| 39438 | IF(IDHKT(2+IIGLU1).EQ.-1203)IDHKT(2+IIGLU1)=-2103 |
| 39439 | IF(IDHKT(2+IIGLU1).EQ.-1303)IDHKT(2+IIGLU1)=-3103 |
| 39440 | IF(IDHKT(2+IIGLU1).EQ.-2303)IDHKT(2+IIGLU1)=-3203 |
| 39441 | ENDIF |
| 39442 | ISTHKT(2+IIGLU1) =922 |
| 39443 | JMOHKT(1,2+IIGLU1)=NC2T |
| 39444 | JMOHKT(2,2+IIGLU1)=0 |
| 39445 | JDAHKT(1,2+IIGLU1)=3+IIGLU1 |
| 39446 | JDAHKT(2,2+IIGLU1)=0 |
| 39447 | PHKT(1,2+IIGLU1) =PHKK(1,NC2T) |
| 39448 | *+XGIVE*PHKT(1,5+IIGLU1) |
| 39449 | PHKT(2,2+IIGLU1) =PHKK(2,NC2T) |
| 39450 | *+XGIVE*PHKT(2,5+IIGLU1) |
| 39451 | PHKT(3,2+IIGLU1) =PHKK(3,NC2T) |
| 39452 | *+XGIVE*PHKT(3,5+IIGLU1) |
| 39453 | PHKT(4,2+IIGLU1) =PHKK(4,NC2T) |
| 39454 | *+XGIVE*PHKT(4,5+IIGLU1) |
| 39455 | C PHKT(5,2) =PHKK(5,NC2T) |
| 39456 | XMIST=(PHKT(4,2+IIGLU1)**2- |
| 39457 | * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2- |
| 39458 | *PHKT(1,2+IIGLU1)**2) |
| 39459 | IF(XMIST.GT.0.D0)THEN |
| 39460 | PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2- |
| 39461 | * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2- |
| 39462 | *PHKT(1,2+IIGLU1)**2) |
| 39463 | ELSE |
| 39464 | C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST |
| 39465 | PHKT(5,2+IIGLU1)=0.D0 |
| 39466 | ENDIF |
| 39467 | VHKT(1,2+IIGLU1) =VHKK(1,NC2T) |
| 39468 | VHKT(2,2+IIGLU1) =VHKK(2,NC2T) |
| 39469 | VHKT(3,2+IIGLU1) =VHKK(3,NC2T) |
| 39470 | VHKT(4,2+IIGLU1) =VHKK(4,NC2T) |
| 39471 | WHKT(1,2+IIGLU1) =WHKK(1,NC2T) |
| 39472 | WHKT(2,2+IIGLU1) =WHKK(2,NC2T) |
| 39473 | WHKT(3,2+IIGLU1) =WHKK(3,NC2T) |
| 39474 | WHKT(4,2+IIGLU1) =WHKK(4,NC2T) |
| 39475 | IDHKT(3+IIGLU1) =88888 |
| 39476 | C IDHKT(3) =1000*NNNC1+MMMC1+10 |
| 39477 | ISTHKT(3+IIGLU1) =93 |
| 39478 | C ISTHKT(3) =KKKC1 |
| 39479 | JMOHKT(1,3+IIGLU1)=1 |
| 39480 | JMOHKT(2,3+IIGLU1)=2+IIGLU1 |
| 39481 | JDAHKT(1,3+IIGLU1)=0 |
| 39482 | JDAHKT(2,3+IIGLU1)=0 |
| 39483 | PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1 |
| 39484 | PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2 |
| 39485 | PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3 |
| 39486 | PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4 |
| 39487 | PHKT(5,3+IIGLU1) |
| 39488 | * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2 |
| 39489 | * -PHKT(3,3+IIGLU1)**2) |
| 39490 | IF(IPIP.GE.3)THEN |
| 39491 | WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1), |
| 39492 | * JDAHKT(1,1), |
| 39493 | *JDAHKT(2,1),(PHKT(III,1),III=1,5) |
| 39494 | DO 71 IIG=2,2+IIGLU1-1 |
| 39495 | WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG), |
| 39496 | & JMOHKT(1,IIG),JMOHKT(2,IIG), |
| 39497 | * JDAHKT(1,IIG), |
| 39498 | *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) |
| 39499 | 71 CONTINUE |
| 39500 | WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1), |
| 39501 | & IDHKT(2),JMOHKT(1,2+IIGLU1), |
| 39502 | * JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1), |
| 39503 | *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5) |
| 39504 | WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1), |
| 39505 | * JMOHKT(1,3+IIGLU1), |
| 39506 | * JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1), |
| 39507 | *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5) |
| 39508 | ENDIF |
| 39509 | CHAMAL=CHAB1 |
| 39510 | **NEW |
| 39511 | C IF(IPIP.EQ.1)THEN |
| 39512 | C IF(IPP21.GE.3.OR.IPP22.GE.3.OR.IP11.GE.3)CHAMAL=CHAB3 |
| 39513 | C ELSEIF(IPIP.EQ.2)THEN |
| 39514 | C IF(IPP21.LE.-3.OR.IPP22.LE.-3.OR.IP11.LE.-3)CHAMAL=CHAB3 |
| 39515 | C ENDIF |
| 39516 | IF(IPIP.EQ.1)THEN |
| 39517 | IF(KK21.GE.3.OR.KK22.GE.3.OR.KK11.GE.3)CHAMAL=CHAB3 |
| 39518 | ELSEIF(IPIP.EQ.2)THEN |
| 39519 | IF(KK21.LE.-3.OR.KK22.LE.-3.OR.KK11.LE.-3)CHAMAL=CHAB3 |
| 39520 | ENDIF |
| 39521 | ** |
| 39522 | IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN |
| 39523 | C IREJ=1 |
| 39524 | IPCO=0 |
| 39525 | C RETURN |
| 39526 | C WRITE(6,*)' MGSQBS1 jump back from chain 3' |
| 39527 | GO TO 3466 |
| 39528 | ENDIF |
| 39529 | VHKT(1,3+IIGLU1) =VHKK(1,NC1) |
| 39530 | VHKT(2,3+IIGLU1) =VHKK(2,NC1) |
| 39531 | VHKT(3,3+IIGLU1) =VHKK(3,NC1) |
| 39532 | VHKT(4,3+IIGLU1) =VHKK(4,NC1) |
| 39533 | WHKT(1,3+IIGLU1) =WHKK(1,NC1) |
| 39534 | WHKT(2,3+IIGLU1) =WHKK(2,NC1) |
| 39535 | WHKT(3,3+IIGLU1) =WHKK(3,NC1) |
| 39536 | WHKT(4,3+IIGLU1) =WHKK(4,NC1) |
| 39537 | IF(IPIP.EQ.1)THEN |
| 39538 | IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ1+3 |
| 39539 | IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103 |
| 39540 | IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103 |
| 39541 | IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203 |
| 39542 | ELSEIF(IPIP.EQ.2)THEN |
| 39543 | IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3 |
| 39544 | IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103 |
| 39545 | IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103 |
| 39546 | IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203 |
| 39547 | C WRITE(6,*)'IDHKT(7),IPP1,ISQ1',IDHKT(7),IPP1,ISQ1 |
| 39548 | ENDIF |
| 39549 | ISTHKT(7+IIGLU1) =921 |
| 39550 | JMOHKT(1,7+IIGLU1)=NC2P |
| 39551 | JMOHKT(2,7+IIGLU1)=0 |
| 39552 | JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2 |
| 39553 | JDAHKT(2,7+IIGLU1)=0 |
| 39554 | C PHKT(1,7) =0.5D0*PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ/(XDIQP+XSQ) |
| 39555 | C PHKT(2,7) =0.5D0*PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ/(XDIQP+XSQ) |
| 39556 | C PHKT(3,7) =0.5D0*PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ/(XDIQP+XSQ) |
| 39557 | C PHKT(4,7+IIGLU1) =0.5D0*PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ/(XDIQP+XSQ) |
| 39558 | **NEW |
| 39559 | IF ((XSQ1 .LT.0.0D0).OR.(XDIQP .LT.0.0D0)) |
| 39560 | & WRITE(LOUT,*) ' mgsqbs3: ',XSQ1,XDIQP |
| 39561 | ** |
| 39562 | PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1) |
| 39563 | PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1) |
| 39564 | PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1) |
| 39565 | PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1) |
| 39566 | C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)', |
| 39567 | C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7) |
| 39568 | IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN |
| 39569 | C IREJ=1 |
| 39570 | C WRITE(6,*)'reject PHKT(4,7).GE. PHKK(4,NC1P)' |
| 39571 | IPCO=0 |
| 39572 | C RETURN |
| 39573 | GO TO 3466 |
| 39574 | ENDIF |
| 39575 | C PHKT(5,7) =PHKK(5,NC2P) |
| 39576 | PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2- |
| 39577 | * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2- |
| 39578 | *PHKT(1,7+IIGLU1)**2) |
| 39579 | VHKT(1,7+IIGLU1) =VHKK(1,NC2P) |
| 39580 | VHKT(2,7+IIGLU1) =VHKK(2,NC2P) |
| 39581 | VHKT(3,7+IIGLU1) =VHKK(3,NC2P) |
| 39582 | VHKT(4,7+IIGLU1) =VHKK(4,NC2P) |
| 39583 | WHKT(1,7+IIGLU1) =WHKK(1,NC2P) |
| 39584 | WHKT(2,7+IIGLU1) =WHKK(2,NC2P) |
| 39585 | WHKT(3,7+IIGLU1) =WHKK(3,NC2P) |
| 39586 | WHKT(4,7+IIGLU1) =WHKK(4,NC2P) |
| 39587 | C Insert here the IIGLU2 gluons |
| 39588 | PG1=0.D0 |
| 39589 | PG2=0.D0 |
| 39590 | PG3=0.D0 |
| 39591 | PG4=0.D0 |
| 39592 | IF(IIGLU2.GE.1)THEN |
| 39593 | JJG=NC2P |
| 39594 | DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 |
| 39595 | KKG=JJG+IIG-7-IIGLU1 |
| 39596 | IDHKT(IIG) =IDHKK(KKG) |
| 39597 | ISTHKT(IIG) =921 |
| 39598 | JMOHKT(1,IIG)=KKG |
| 39599 | JMOHKT(2,IIG)=0 |
| 39600 | JDAHKT(1,IIG)=9+IIGLU1+IIGLU2 |
| 39601 | JDAHKT(2,IIG)=0 |
| 39602 | PHKT(1,IIG)=PHKK(1,KKG) |
| 39603 | PG1=PG1+ PHKT(1,IIG) |
| 39604 | PHKT(2,IIG)=PHKK(2,KKG) |
| 39605 | PG2=PG2+ PHKT(2,IIG) |
| 39606 | PHKT(3,IIG)=PHKK(3,KKG) |
| 39607 | PG3=PG3+ PHKT(3,IIG) |
| 39608 | PHKT(4,IIG)=PHKK(4,KKG) |
| 39609 | PG4=PG4+ PHKT(4,IIG) |
| 39610 | PHKT(5,IIG)=PHKK(5,KKG) |
| 39611 | VHKT(1,IIG) =VHKK(1,KKG) |
| 39612 | VHKT(2,IIG) =VHKK(2,KKG) |
| 39613 | VHKT(3,IIG) =VHKK(3,KKG) |
| 39614 | VHKT(4,IIG) =VHKK(4,KKG) |
| 39615 | WHKT(1,IIG) =WHKK(1,KKG) |
| 39616 | WHKT(2,IIG) =WHKK(2,KKG) |
| 39617 | WHKT(3,IIG) =WHKK(3,KKG) |
| 39618 | WHKT(4,IIG) =WHKK(4,KKG) |
| 39619 | 81 CONTINUE |
| 39620 | ENDIF |
| 39621 | IDHKT(8+IIGLU1+IIGLU2) =IP2 |
| 39622 | ISTHKT(8+IIGLU1+IIGLU2) =922 |
| 39623 | JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T |
| 39624 | JMOHKT(2,8+IIGLU1+IIGLU2)=0 |
| 39625 | JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2 |
| 39626 | JDAHKT(2,8+IIGLU1+IIGLU2)=0 |
| 39627 | **NEW |
| 39628 | IF ((XVQT.LT.0.0D0).OR.(XSAQ1 .LT.0.0D0)) |
| 39629 | & WRITE(LOUT,*) ' mgsqbs4: ',XVQT,XSAQ1 |
| 39630 | ** |
| 39631 | PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT) |
| 39632 | PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT) |
| 39633 | PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT) |
| 39634 | PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT) |
| 39635 | C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T) |
| 39636 | XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2- |
| 39637 | * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2- |
| 39638 | *PHKT(1,8+IIGLU1+IIGLU2)**2) |
| 39639 | IF(XMIST.GT.0.D0)THEN |
| 39640 | PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2- |
| 39641 | * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2- |
| 39642 | *PHKT(1,8+IIGLU1+IIGLU2)**2) |
| 39643 | ELSE |
| 39644 | C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST |
| 39645 | PHKT(5,8+IIGLU1+IIGLU2)=0.D0 |
| 39646 | ENDIF |
| 39647 | VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T) |
| 39648 | VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T) |
| 39649 | VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T) |
| 39650 | VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T) |
| 39651 | WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T) |
| 39652 | WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T) |
| 39653 | WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T) |
| 39654 | WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T) |
| 39655 | IDHKT(9+IIGLU1+IIGLU2) =88888 |
| 39656 | C IDHKT(9) =1000*NNNC2+MMMC2+10 |
| 39657 | ISTHKT(9+IIGLU1+IIGLU2) =93 |
| 39658 | C ISTHKT(9) =KKKC2 |
| 39659 | JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1 |
| 39660 | JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2 |
| 39661 | JDAHKT(1,9+IIGLU1+IIGLU2)=0 |
| 39662 | JDAHKT(2,9+IIGLU1+IIGLU2)=0 |
| 39663 | PHKT(1,9+IIGLU1+IIGLU2) =PHKT(1,7+IIGLU1) |
| 39664 | * +PHKT(1,8+IIGLU1+IIGLU2)+PG1 |
| 39665 | PHKT(2,9+IIGLU1+IIGLU2) =PHKT(2,7+IIGLU1) |
| 39666 | * +PHKT(2,8+IIGLU1+IIGLU2)+PG2 |
| 39667 | PHKT(3,9+IIGLU1+IIGLU2) =PHKT(3,7+IIGLU1) |
| 39668 | * +PHKT(3,8+IIGLU1+IIGLU2)+PG3 |
| 39669 | PHKT(4,9+IIGLU1+IIGLU2) =PHKT(4,7+IIGLU1) |
| 39670 | * +PHKT(4,8+IIGLU1+IIGLU2)+PG4 |
| 39671 | PHKT(5,9+IIGLU1+IIGLU2) |
| 39672 | * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2- |
| 39673 | * PHKT(2,9+IIGLU1+IIGLU2)**2 |
| 39674 | * -PHKT(3,9+IIGLU1+IIGLU2)**2) |
| 39675 | IF(IPIP.GE.3)THEN |
| 39676 | WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1), |
| 39677 | * JMOHKT(1,7+IIGLU1), |
| 39678 | * JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1), |
| 39679 | *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5) |
| 39680 | DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 |
| 39681 | WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG), |
| 39682 | & JMOHKT(1,IIG),JMOHKT(2,IIG), |
| 39683 | * JDAHKT(1,IIG), |
| 39684 | *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) |
| 39685 | 91 CONTINUE |
| 39686 | WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2), |
| 39687 | * IDHKT(8+IIGLU1+IIGLU2), |
| 39688 | * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2), |
| 39689 | * JDAHKT(1,8+IIGLU1+IIGLU2), |
| 39690 | *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5) |
| 39691 | WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2), |
| 39692 | * IDHKT(9+IIGLU1+IIGLU2), |
| 39693 | * JMOHKT(1,9+IIGLU1+IIGLU2),JMOHKT(2,9+IIGLU1+IIGLU2), |
| 39694 | * JDAHKT(1,9+IIGLU1+IIGLU2), |
| 39695 | *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5) |
| 39696 | ENDIF |
| 39697 | CHAMAL=CHAB1 |
| 39698 | IF(IPIP.EQ.1)THEN |
| 39699 | IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3 |
| 39700 | ELSEIF(IPIP.EQ.2)THEN |
| 39701 | IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3 |
| 39702 | ENDIF |
| 39703 | IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN |
| 39704 | C IREJ=1 |
| 39705 | IPCO=0 |
| 39706 | C RETURN |
| 39707 | C WRITE(6,*)' MGSQBS1 jump back from chain 9', |
| 39708 | C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2) |
| 39709 | GO TO 3466 |
| 39710 | ENDIF |
| 39711 | VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1) |
| 39712 | VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1) |
| 39713 | VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1) |
| 39714 | VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1) |
| 39715 | WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1) |
| 39716 | WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1) |
| 39717 | WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1) |
| 39718 | WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1) |
| 39719 | C |
| 39720 | IGCOUN=9+IIGLU1+IIGLU2 |
| 39721 | IPCO=0 |
| 39722 | RETURN |
| 39723 | END |
| 39724 | |
| 39725 | *$ CREATE HKKHKT.FOR |
| 39726 | *COPY HKKHKT |
| 39727 | C |
| 39728 | C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| 39729 | C |
| 39730 | SUBROUTINE HKKHKT(I,J) |
| 39731 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 39732 | SAVE |
| 39733 | |
| 39734 | * event history |
| 39735 | PARAMETER (NMXHKK=200000) |
| 39736 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 39737 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 39738 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 39739 | * extended event history |
| 39740 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 39741 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 39742 | & IHIST(2,NMXHKK) |
| 39743 | |
| 39744 | PARAMETER (NTMHKK= 300) |
| 39745 | COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT |
| 39746 | +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT |
| 39747 | +(4,NTMHKK) |
| 39748 | C |
| 39749 | ISTHKK(I) =ISTHKT(J) |
| 39750 | IDHKK(I) =IDHKT(J) |
| 39751 | C IF(J.EQ.3.OR.J.EQ.6.OR.J.EQ.9)THEN |
| 39752 | IF(IDHKK(I).EQ.88888)THEN |
| 39753 | C JMOHKK(1,I)=I-2 |
| 39754 | C JMOHKK(2,I)=I-1 |
| 39755 | JMOHKK(1,I)=I-(J-JMOHKT(1,J)) |
| 39756 | JMOHKK(2,I)=I-(J-JMOHKT(2,J)) |
| 39757 | ELSE |
| 39758 | JMOHKK(1,I)=JMOHKT(1,J) |
| 39759 | JMOHKK(2,I)=JMOHKT(2,J) |
| 39760 | ENDIF |
| 39761 | JDAHKK(1,I)=JDAHKT(1,J) |
| 39762 | JDAHKK(2,I)=JDAHKT(2,J) |
| 39763 | C IF(J.EQ.1.OR.J.EQ.4.OR.J.EQ.7)THEN |
| 39764 | C JDAHKK(1,I)=I+2 |
| 39765 | C ELSEIF(J.EQ.2.OR.J.EQ.5.OR.J.EQ.8)THEN |
| 39766 | C JDAHKK(1,I)=I+1 |
| 39767 | C ENDIF |
| 39768 | IF(JDAHKT(1,J).GT.0)THEN |
| 39769 | JDAHKK(1,I)=I+(JDAHKT(1,J)-J) |
| 39770 | ENDIF |
| 39771 | PHKK(1,I) =PHKT(1,J) |
| 39772 | PHKK(2,I) =PHKT(2,J) |
| 39773 | PHKK(3,I) =PHKT(3,J) |
| 39774 | PHKK(4,I) =PHKT(4,J) |
| 39775 | PHKK(5,I) =PHKT(5,J) |
| 39776 | VHKK(1,I) =VHKT(1,J) |
| 39777 | VHKK(2,I) =VHKT(2,J) |
| 39778 | VHKK(3,I) =VHKT(3,J) |
| 39779 | VHKK(4,I) =VHKT(4,J) |
| 39780 | WHKK(1,I) =WHKT(1,J) |
| 39781 | WHKK(2,I) =WHKT(2,J) |
| 39782 | WHKK(3,I) =WHKT(3,J) |
| 39783 | WHKK(4,I) =WHKT(4,J) |
| 39784 | RETURN |
| 39785 | END |
| 39786 | |
| 39787 | *$ CREATE DT_DBREAK.FOR |
| 39788 | *COPY DT_DBREAK |
| 39789 | * |
| 39790 | *===dbreak=============================================================* |
| 39791 | * |
| 39792 | SUBROUTINE DT_DBREAK(MODE) |
| 39793 | |
| 39794 | ************************************************************************ |
| 39795 | * This is the steering subroutine for the different diquark breaking * |
| 39796 | * mechanisms. * |
| 39797 | * * |
| 39798 | * MODE = 1 breaking of projectile diquark in qq-q chain using * |
| 39799 | * a sea quark (q-qq chain) of the same projectile * |
| 39800 | * = 2 breaking of target diquark in q-qq chain using * |
| 39801 | * a sea quark (qq-q chain) of the same target * |
| 39802 | * = 3 breaking of projectile diquark in qq-q chain using * |
| 39803 | * a sea quark (q-aq chain) of the same projectile * |
| 39804 | * = 4 breaking of target diquark in q-qq chain using * |
| 39805 | * a sea quark (aq-q chain) of the same target * |
| 39806 | * = 5 breaking of projectile anti-diquark in aqaq-aq chain using * |
| 39807 | * a sea anti-quark (aq-aqaq chain) of the same projectile * |
| 39808 | * = 6 breaking of target anti-diquark in aq-aqaq chain using * |
| 39809 | * a sea anti-quark (aqaq-aq chain) of the same target * |
| 39810 | * = 7 breaking of projectile anti-diquark in aqaq-aq chain using * |
| 39811 | * a sea anti-quark (aq-q chain) of the same projectile * |
| 39812 | * = 8 breaking of target anti-diquark in aq-aqaq chain using * |
| 39813 | * a sea anti-quark (q-aq chain) of the same target * |
| 39814 | * * |
| 39815 | * Original version by J. Ranft. * |
| 39816 | * This version dated 17.5.00 is written by S. Roesler. * |
| 39817 | ************************************************************************ |
| 39818 | |
| 39819 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 39820 | SAVE |
| 39821 | PARAMETER ( LINP = 10 , |
| 39822 | & LOUT = 6 , |
| 39823 | & LDAT = 9 ) |
| 39824 | |
| 39825 | * event history |
| 39826 | PARAMETER (NMXHKK=200000) |
| 39827 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 39828 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 39829 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 39830 | * extended event history |
| 39831 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 39832 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 39833 | & IHIST(2,NMXHKK) |
| 39834 | * flags for input different options |
| 39835 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 39836 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 39837 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 39838 | * pointer to chains in hkkevt common (used by qq-breaking mechanisms) |
| 39839 | PARAMETER (MAXCHN=10000) |
| 39840 | COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN |
| 39841 | * diquark-breaking mechanism |
| 39842 | COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3 |
| 39843 | * flags for particle decays |
| 39844 | COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20), |
| 39845 | & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20), |
| 39846 | & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0 |
| 39847 | |
| 39848 | * |
| 39849 | * chain identifiers |
| 39850 | * ( 1 = q-aq, 2 = aq-q, 3 = q-qq, 4 = qq-q, |
| 39851 | * 5 = aq-adq, 6 = adq-aq, 7 = dq-adq, 8 = adq-dq ) |
| 39852 | DIMENSION IDCHN1(8),IDCHN2(8) |
| 39853 | DATA IDCHN1 / 4, 3, 4, 3, 6, 5, 6, 5/ |
| 39854 | DATA IDCHN2 / 3, 4, 1, 2, 5, 6, 2, 1/ |
| 39855 | * |
| 39856 | * parton identifiers |
| 39857 | * ( +-21/22 = valence, +-31/32 = Glauber-sea, +-41/42 = Pomeron (diff), |
| 39858 | * +-51/52 = unitarity-sea, +-61/62 = gluons ) |
| 39859 | DIMENSION ISP1P(8,3),ISP1T(8,3),ISP2P(8,3),ISP2T(8,3) |
| 39860 | DATA ISP1P / 21, 21, 21, 21, 21, 21, 21, 21, |
| 39861 | & 31, 31, 31, 31, 31, 31, 31, 31, |
| 39862 | & 41, 41, 41, 41, 51, 51, 51, 51/ |
| 39863 | DATA ISP1T / 22, 22, 22, 22, 22, 22, 22, 22, |
| 39864 | & 32, 32, 32, 32, 32, 32, 32, 32, |
| 39865 | & 42, 42, 42, 42, 52, 52, 52, 52/ |
| 39866 | DATA ISP2P / 31, 21, 31, 31, 21, 21, 21, 21, |
| 39867 | & 51, 31, 41, 41, 31, 31, 31, 31, |
| 39868 | & 0, 41, 51, 51, 51, 51, 51, 51/ |
| 39869 | DATA ISP2T / 22, 32, 32, 32, 22, 22, 22, 22, |
| 39870 | & 32, 52, 42, 42, 32, 32, 32, 32, |
| 39871 | & 42, 0, 52, 52, 52, 52, 52, 52/ |
| 39872 | |
| 39873 | IF (NCHAIN.LE.0) RETURN |
| 39874 | DO 1 I=1,NCHAIN |
| 39875 | IDX1 = IDXCHN(1,I) |
| 39876 | IS1P = ABS(ISTHKK(JMOHKK(1,IDX1))) |
| 39877 | IS1T = ABS(ISTHKK(JMOHKK(2,IDX1))) |
| 39878 | IF ( (IDXCHN(2,I).EQ.IDCHN1(MODE)) |
| 39879 | & .AND. |
| 39880 | & ((IS1P.EQ.ISP1P(MODE,1)).OR.(IS1P.EQ.ISP1P(MODE,2)).OR. |
| 39881 | & (IS1P.EQ.ISP1P(MODE,3))) |
| 39882 | & .AND. |
| 39883 | & ((IS1T.EQ.ISP1T(MODE,1)).OR.(IS1T.EQ.ISP1T(MODE,2)).OR. |
| 39884 | & (IS1T.EQ.ISP1T(MODE,3))) |
| 39885 | & ) THEN |
| 39886 | DO 2 J=1,NCHAIN |
| 39887 | IDX2 = IDXCHN(1,J) |
| 39888 | IS2P = ABS(ISTHKK(JMOHKK(1,IDX2))) |
| 39889 | IS2T = ABS(ISTHKK(JMOHKK(2,IDX2))) |
| 39890 | IF ( (IDXCHN(2,J).EQ.IDCHN2(MODE)) |
| 39891 | & .AND. |
| 39892 | & ((IS2P.EQ.ISP2P(MODE,1)).OR.(IS2P.EQ.ISP2P(MODE,2)) |
| 39893 | & .OR.(IS2P.EQ.ISP2P(MODE,3))) |
| 39894 | & .AND. |
| 39895 | & ((IS2T.EQ.ISP2T(MODE,1)).OR.(IS2T.EQ.ISP2T(MODE,2)) |
| 39896 | & .OR.(IS2T.EQ.ISP2T(MODE,3))) |
| 39897 | & ) THEN |
| 39898 | * find mother nucleons of the diquark to be splitted and of the |
| 39899 | * sea-quark and reject this combination if it is not the same |
| 39900 | IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR. |
| 39901 | & (MODE.EQ.5).OR.(MODE.EQ.7)) THEN |
| 39902 | IANCES = 1 |
| 39903 | ELSE |
| 39904 | IANCES = 2 |
| 39905 | ENDIF |
| 39906 | IDXMO1 = JMOHKK(IANCES,IDX1) |
| 39907 | 4 CONTINUE |
| 39908 | IF ((JMOHKK(1,IDXMO1).NE.0).AND. |
| 39909 | & (JMOHKK(2,IDXMO1).NE.0)) THEN |
| 39910 | IANC = IANCES |
| 39911 | ELSE |
| 39912 | IANC = 1 |
| 39913 | ENDIF |
| 39914 | IF (JMOHKK(IANC,IDXMO1).NE.0) THEN |
| 39915 | IDXMO1 = JMOHKK(IANC,IDXMO1) |
| 39916 | GOTO 4 |
| 39917 | ENDIF |
| 39918 | IDXMO2 = JMOHKK(IANCES,IDX2) |
| 39919 | 5 CONTINUE |
| 39920 | IF ((JMOHKK(1,IDXMO2).NE.0).AND. |
| 39921 | & (JMOHKK(2,IDXMO2).NE.0)) THEN |
| 39922 | IANC = IANCES |
| 39923 | ELSE |
| 39924 | IANC = 1 |
| 39925 | ENDIF |
| 39926 | IF (JMOHKK(IANC,IDXMO2).NE.0) THEN |
| 39927 | IDXMO2 = JMOHKK(IANC,IDXMO2) |
| 39928 | GOTO 5 |
| 39929 | ENDIF |
| 39930 | IF (IDXMO1.NE.IDXMO2) GOTO 2 |
| 39931 | * quark content of projectile parton |
| 39932 | IP1 = IDHKK(JMOHKK(1,IDX1)) |
| 39933 | IP11 = IP1/1000 |
| 39934 | IP12 = (IP1-1000*IP11)/100 |
| 39935 | IP2 = IDHKK(JMOHKK(2,IDX1)) |
| 39936 | IP21 = IP2/1000 |
| 39937 | IP22 = (IP2-1000*IP21)/100 |
| 39938 | * quark content of target parton |
| 39939 | IT1 = IDHKK(JMOHKK(1,IDX2)) |
| 39940 | IT11 = IT1/1000 |
| 39941 | IT12 = (IT1-1000*IT11)/100 |
| 39942 | IT2 = IDHKK(JMOHKK(2,IDX2)) |
| 39943 | IT21 = IT2/1000 |
| 39944 | IT22 = (IT2-1000*IT21)/100 |
| 39945 | * split diquark and form new chains |
| 39946 | IF (MODE.EQ.1) THEN |
| 39947 | IF (IT1.EQ.4) GOTO 2 |
| 39948 | CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), |
| 39949 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, |
| 39950 | & IP11,IP12,IP2,IT1,IT21,IT22,1,IPQ,IGCOUN) |
| 39951 | ELSEIF (MODE.EQ.2) THEN |
| 39952 | IF (IT2.EQ.4) GOTO 2 |
| 39953 | CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), |
| 39954 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, |
| 39955 | & IP1,IP21,IP22,IT11,IT12,IT2,1,IPQ,IGCOUN) |
| 39956 | ELSEIF (MODE.EQ.3) THEN |
| 39957 | IF (IT1.EQ.4) GOTO 2 |
| 39958 | CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), |
| 39959 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, |
| 39960 | & IP11,IP12,IP2,IT1,IT2,1,IPQ,IGCOUN) |
| 39961 | ELSEIF (MODE.EQ.4) THEN |
| 39962 | IF (IT2.EQ.4) GOTO 2 |
| 39963 | CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), |
| 39964 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, |
| 39965 | & IP1,IP21,IP22,IT1,IT2,1,IPQ,IGCOUN) |
| 39966 | ELSEIF (MODE.EQ.5) THEN |
| 39967 | CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), |
| 39968 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, |
| 39969 | & IP11,IP12,IP2,IT1,IT21,IT22,2,IPQ,IGCOUN) |
| 39970 | ELSEIF (MODE.EQ.6) THEN |
| 39971 | CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), |
| 39972 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, |
| 39973 | & IP1,IP21,IP22,IT11,IT12,IT2,2,IPQ,IGCOUN) |
| 39974 | ELSEIF (MODE.EQ.7) THEN |
| 39975 | CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), |
| 39976 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, |
| 39977 | & IP11,IP12,IP2,IT1,IT2,2,IPQ,IGCOUN) |
| 39978 | ELSEIF (MODE.EQ.8) THEN |
| 39979 | CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), |
| 39980 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, |
| 39981 | & IP1,IP21,IP22,IT1,IT2,2,IPQ,IGCOUN) |
| 39982 | ENDIF |
| 39983 | IF (IREJ.GE.1) THEN |
| 39984 | if ((ipq.lt.0).or.(ipq.ge.4)) |
| 39985 | & write(LOUT,*) 'ipq !!!',ipq,mode |
| 39986 | DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0 |
| 39987 | * accept or reject new chains corresponding to PDBSEA |
| 39988 | ELSE |
| 39989 | IF ((IPQ.EQ.1).OR.(IPQ.EQ.2)) THEN |
| 39990 | ACC = DBRKA(1,MODE)+DBRKA(2,MODE) |
| 39991 | REJ = DBRKR(1,MODE)+DBRKR(2,MODE) |
| 39992 | ELSEIF (IPQ.EQ.3) THEN |
| 39993 | ACC = DBRKA(3,MODE) |
| 39994 | REJ = DBRKR(3,MODE) |
| 39995 | ELSE |
| 39996 | WRITE(LOUT,*) ' inconsistent IPQ ! ',IPQ |
| 39997 | STOP |
| 39998 | ENDIF |
| 39999 | IF (ACC/(ACC+REJ).LE.PDBSEA(IPQ)) THEN |
| 40000 | DBRKA(IPQ,MODE) = DBRKA(IPQ,MODE)+1.0D0 |
| 40001 | IACC = 1 |
| 40002 | ELSE |
| 40003 | DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0 |
| 40004 | IACC = 0 |
| 40005 | ENDIF |
| 40006 | * new chains have been accepted and are now copied into HKKEVT |
| 40007 | IF (IACC.EQ.1) THEN |
| 40008 | IF (LEMCCK) THEN |
| 40009 | CALL DT_EVTEMC(PHKK(1,IDX1),PHKK(2,IDX1), |
| 40010 | & PHKK(3,IDX1),PHKK(4,IDX1), |
| 40011 | & 1,IDUM1,IDUM2) |
| 40012 | CALL DT_EVTEMC(PHKK(1,IDX2),PHKK(2,IDX2), |
| 40013 | & PHKK(3,IDX2),PHKK(4,IDX2), |
| 40014 | & 2,IDUM1,IDUM2) |
| 40015 | ENDIF |
| 40016 | IDHKK(IDX1) = 99888 |
| 40017 | IDHKK(IDX2) = 99888 |
| 40018 | IDXCHN(2,I) = -1 |
| 40019 | IDXCHN(2,J) = -1 |
| 40020 | DO 3 K=1,IGCOUN |
| 40021 | NHKK = NHKK+1 |
| 40022 | CALL HKKHKT(NHKK,K) |
| 40023 | IF ((LEMCCK).AND.(IDHKK(NHKK).EQ.88888))THEN |
| 40024 | PX = -PHKK(1,NHKK) |
| 40025 | PY = -PHKK(2,NHKK) |
| 40026 | PZ = -PHKK(3,NHKK) |
| 40027 | PE = -PHKK(4,NHKK) |
| 40028 | CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2) |
| 40029 | ENDIF |
| 40030 | 3 CONTINUE |
| 40031 | IF (LEMCCK) THEN |
| 40032 | CHKLEV = 0.1D0 |
| 40033 | CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,9000, |
| 40034 | & IREJ) |
| 40035 | IF (IREJ.NE.0) CALL DT_EVTOUT(4) |
| 40036 | ENDIF |
| 40037 | GOTO 1 |
| 40038 | ENDIF |
| 40039 | ENDIF |
| 40040 | ENDIF |
| 40041 | 2 CONTINUE |
| 40042 | ENDIF |
| 40043 | 1 CONTINUE |
| 40044 | RETURN |
| 40045 | END |
| 40046 | |
| 40047 | *$ CREATE DT_CQPAIR.FOR |
| 40048 | *COPY DT_CQPAIR |
| 40049 | * |
| 40050 | *===cqpair=============================================================* |
| 40051 | * |
| 40052 | SUBROUTINE DT_CQPAIR(XQMAX,XAQMAX,XQ,XAQ,IFLV,IREJ) |
| 40053 | |
| 40054 | ************************************************************************ |
| 40055 | * This subroutine Creates a Quark-antiquark PAIR from the sea. * |
| 40056 | * * |
| 40057 | * XQMAX maxium energy fraction of quark (input) * |
| 40058 | * XAQMAX maxium energy fraction of antiquark (input) * |
| 40059 | * XQ energy fraction of quark (output) * |
| 40060 | * XAQ energy fraction of antiquark (output) * |
| 40061 | * IFLV quark flavour (- antiquark flavor) (output) * |
| 40062 | * * |
| 40063 | * This version dated 14.5.00 is written by S. Roesler. * |
| 40064 | ************************************************************************ |
| 40065 | |
| 40066 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 40067 | SAVE |
| 40068 | PARAMETER ( LINP = 10 , |
| 40069 | & LOUT = 6 , |
| 40070 | & LDAT = 9 ) |
| 40071 | |
| 40072 | * Lorentz-parameters of the current interaction |
| 40073 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, |
| 40074 | & UMO,PPCM,EPROJ,PPROJ |
| 40075 | |
| 40076 | * |
| 40077 | IREJ = 0 |
| 40078 | XQ = 0.0D0 |
| 40079 | XAQ = 0.0D0 |
| 40080 | * |
| 40081 | * sample quark flavour |
| 40082 | * |
| 40083 | * set seasq here (the one from DTCHAI should be used in the future) |
| 40084 | SEASQ = 0.5D0 |
| 40085 | IFLV = INT(1.0D0+DT_RNDM(XQMAX)*(2.0D0+SEASQ)) |
| 40086 | * |
| 40087 | * sample energy fractions of sea pair |
| 40088 | * we first sample the energy fraction of a gluon and then split the gluon |
| 40089 | * |
| 40090 | * maximum energy fraction of the gluon forced via input |
| 40091 | XGMAXI = XQMAX+XAQMAX |
| 40092 | * minimum energy fraction of the gluon |
| 40093 | XTHR1 = 4.0D0 /UMO**2 |
| 40094 | XTHR2 = 0.54D0/UMO**1.5D0 |
| 40095 | XGMIN = MAX(XTHR1,XTHR2) |
| 40096 | * maximum energy fraction of the gluon |
| 40097 | XGMAX = 0.3D0 |
| 40098 | XGMAX = MIN(XGMAXI,XGMAX) |
| 40099 | IF (XGMIN.GE.XGMAX) THEN |
| 40100 | IREJ = 1 |
| 40101 | RETURN |
| 40102 | ENDIF |
| 40103 | * |
| 40104 | * sample energy fraction of the gluon |
| 40105 | NLOOP = 0 |
| 40106 | 1 CONTINUE |
| 40107 | NLOOP = NLOOP+1 |
| 40108 | IF (NLOOP.GE.50) THEN |
| 40109 | IREJ = 1 |
| 40110 | RETURN |
| 40111 | ENDIF |
| 40112 | XGLUON = DT_SAMSQX(XGMIN,XGMAX) |
| 40113 | EGLUON = XGLUON*UMO/2.0D0 |
| 40114 | * |
| 40115 | * split gluon into q-aq pair (we follow PHOJET's subroutine PHO_GLU2QU) |
| 40116 | ZMIN = MIN(0.1D0,0.5D0/EGLUON) |
| 40117 | ZMAX = 1.0D0-ZMIN |
| 40118 | RZ = DT_RNDM(ZMAX) |
| 40119 | XHLP = ((1.0D0-RZ)*ZMIN**3+RZ*ZMAX**3)**0.33333 |
| 40120 | RQ = DT_RNDM(ZMAX) |
| 40121 | IF (RQ.LT.0.5D0) THEN |
| 40122 | XQ = XGLUON*XHLP |
| 40123 | XAQ = XGLUON-XQ |
| 40124 | ELSE |
| 40125 | XAQ = XGLUON*XHLP |
| 40126 | XQ = XGLUON-XAQ |
| 40127 | ENDIF |
| 40128 | IF ((XQ.GT.XQMAX).OR.(XAQ.GT.XAQMAX)) GOTO 1 |
| 40129 | |
| 40130 | RETURN |
| 40131 | END |
git://git.uio.no / u / mrichter / AliRoot.git / blame