| d30b8254 |
1 | * |
| 2 | * +-------------------------------------------------------------+ |
| 3 | * | | |
| 4 | * | | |
| 5 | * | DPMJET 3.0 | |
| 6 | * | | |
| 7 | * | | |
| 8 | * | S. Roesler+), R. Engel#), J. Ranft*) | |
| 9 | * | | |
| 10 | * | +) CERN, TIS-RP | |
| 11 | * | CH-1211 Geneva 23, Switzerland | |
| 12 | * | Email: Stefan.Roesler@cern.ch | |
| 13 | * | | |
| 14 | * | #) University of Delaware, BRI | |
| 15 | * | Newark, DE 19716, USA | |
| 16 | * | | |
| 17 | * | *) University of Siegen, Dept. of Physics | |
| 18 | * | D-57068 Siegen, Germany | |
| 19 | * | | |
| 20 | * | | |
| 21 | * | http://home.cern.ch/sroesler/dpmjet3.html | |
| 22 | * | | |
| 23 | * | | |
| 24 | * | Monte Carlo models used for event generation: | |
| 25 | * | PHOJET 1.12, JETSET 7.4 and LEPTO 6.5.1 | |
| 26 | * | | |
| 27 | * +-------------------------------------------------------------+ |
| 28 | * |
| 29 | * |
| 30 | *===init===============================================================* |
| 31 | * |
| 32 | CDECK ID>, DT_INIT |
| 33 | SUBROUTINE DT_INIT(NCASES,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR, |
| 34 | & IDP,IGLAU) |
| 35 | |
| 36 | ************************************************************************ |
| 37 | * Initialization of event generation * |
| 38 | * This version dated 7.4.98 is written by S. Roesler. * |
| 39 | ************************************************************************ |
| 40 | |
| 41 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 42 | SAVE |
| 43 | |
| 44 | PARAMETER ( LINP = 5 , |
| 45 | & LOUT = 6 , |
| 46 | & LDAT = 9 ) |
| 47 | |
| 48 | PARAMETER (ZERO=0.0D0,ONE=1.0D0) |
| 49 | |
| 50 | * particle properties (BAMJET index convention) |
| 51 | CHARACTER*8 ANAME |
| 52 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 53 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 54 | * names of hadrons used in input-cards |
| 55 | CHARACTER*8 BTYPE |
| 56 | COMMON /DTPAIN/ BTYPE(30) |
| 57 | |
| 58 | INCLUDE './flukapro/(DIMPAR)' |
| 59 | INCLUDE './flukapro/(PAREVT)' |
| 60 | INCLUDE './flukapro/(EVAPAR)' |
| 61 | INCLUDE './flukapro/(FRBKCM)' |
| 62 | |
| 63 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 64 | |
| 65 | * emulsion treatment |
| 66 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), |
| 67 | & NCOMPO,IEMUL |
| 68 | * Glauber formalism: parameters |
| 69 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), |
| 70 | & BMAX(NCOMPX),BSTEP(NCOMPX), |
| 71 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), |
| 72 | & NSITEB,NSTATB |
| 73 | * Glauber formalism: cross sections |
| 74 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, |
| 75 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), |
| 76 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), |
| 77 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), |
| 78 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), |
| 79 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), |
| 80 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), |
| 81 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), |
| 82 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), |
| 83 | & BSLOPE,NEBINI,NQBINI |
| 84 | * interface HADRIN-DPM |
| 85 | COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA |
| 86 | * central particle production, impact parameter biasing |
| 87 | COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR |
| 88 | * parameter for intranuclear cascade |
| 89 | LOGICAL LPAULI |
| 90 | COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI |
| 91 | * various options for treatment of partons (DTUNUC 1.x) |
| 92 | * (chain recombination, Cronin,..) |
| 93 | LOGICAL LCO2CR,LINTPT |
| 94 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, |
| 95 | & LCO2CR,LINTPT |
| 96 | * threshold values for x-sampling (DTUNUC 1.x) |
| 97 | COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA, |
| 98 | & SSMIMQ,VVMTHR |
| 99 | * flags for input different options |
| 100 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 101 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 102 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 103 | * nuclear potential |
| 104 | LOGICAL LFERMI |
| 105 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, |
| 106 | & EBINDP(2),EBINDN(2),EPOT(2,210), |
| 107 | & ETACOU(2),ICOUL,LFERMI |
| 108 | * n-n cross section fluctuations |
| 109 | PARAMETER (NBINS = 1000) |
| 110 | COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT |
| 111 | * flags for particle decays |
| 112 | COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20), |
| 113 | & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20), |
| 114 | & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0 |
| 115 | * diquark-breaking mechanism |
| 116 | COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3 |
| 117 | * nucleon-nucleon event-generator |
| 118 | CHARACTER*8 CMODEL |
| 119 | LOGICAL LPHOIN |
| 120 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN |
| 121 | * properties of interacting particles |
| 122 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG |
| 123 | * properties of photon/lepton projectiles |
| 124 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC |
| 125 | * flags for diffractive interactions (DTUNUC 1.x) |
| 126 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF |
| 127 | * parameters for hA-diffraction |
| 128 | COMMON /DTDIHA/ DIBETA,DIALPH |
| 129 | * Lorentz-parameters of the current interaction |
| 130 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, |
| 131 | & UMO,PPCM,EPROJ,PPROJ |
| 132 | * kinematical cuts for lepton-nucleus interactions |
| 133 | COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX, |
| 134 | & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI |
| 135 | * VDM parameter for photon-nucleus interactions |
| 136 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) |
| 137 | * Glauber formalism: flags and parameters for statistics |
| 138 | LOGICAL LPROD |
| 139 | CHARACTER*8 CGLB |
| 140 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD |
| 141 | * cuts for variable energy runs |
| 142 | COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI |
| 143 | * flags for activated histograms |
| 144 | COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL |
| 145 | |
| 146 | COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) |
| 147 | |
| 148 | COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5) |
| 149 | |
| 150 | * LEPTO |
| 151 | **LUND single / double precision |
| 152 | REAL CUT,PARL,TMPX,TMPY,TMPW2,TMPQ2,TMPU |
| 153 | COMMON /LEPTOU/ CUT(14),LST(40),PARL(30), |
| 154 | & TMPX,TMPY,TMPW2,TMPQ2,TMPU |
| 155 | * LEPTO |
| 156 | REAL RPPN |
| 157 | COMMON /LEPTOI/ RPPN,LEPIN,INTER |
| 158 | * steering flags for qel neutrino scattering modules |
| 159 | COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC |
| 160 | * event flag |
| 161 | COMMON /DTEVNO/ NEVENT,ICASCA |
| 162 | |
| 163 | INTEGER PYCOMP |
| 164 | |
| 165 | C DIMENSION XPARA(5) |
| 166 | DIMENSION XDUMB(40),IPRANG(5) |
| 167 | |
| 168 | PARAMETER (MXCARD=58) |
| 169 | CHARACTER*78 CLINE,CTITLE |
| 170 | CHARACTER*60 CWHAT |
| 171 | CHARACTER*8 BLANK,SDUM |
| 172 | CHARACTER*10 CODE,CODEWD |
| 173 | CHARACTER*72 HEADER |
| 174 | LOGICAL LSTART,LEINP,LXSTAB |
| 175 | DIMENSION WHAT(6),CODE(MXCARD) |
| 176 | DATA CODE/ |
| 177 | & 'TITLE ','PROJPAR ','TARPAR ','ENERGY ', |
| 178 | & 'MOMENTUM ','CMENERGY ','EMULSION ','FERMI ', |
| 179 | & 'TAUFOR ','PAULI ','COULOMB ','HADRIN ', |
| 180 | & 'EVAP ','EMCCHECK ','MODEL ','PHOINPUT ', |
| 181 | & 'GLAUBERI ','FLUCTUAT ','CENTRAL ','RECOMBIN ', |
| 182 | & 'COMBIJET ','XCUTS ','INTPT ','CRONINPT ', |
| 183 | & 'SEADISTR ','SEASU3 ','DIQUARKS ','RESONANC ', |
| 184 | & 'DIFFRACT ','SINGLECH ','NOFRAGME ','HADRONIZE ', |
| 185 | & 'POPCORN ','PARDECAY ','BEAM ','LUND-MSTU ', |
| 186 | & 'LUND-MSTJ ','LUND-MDCY ','LUND-PARJ ','LUND-PARU ', |
| 187 | & 'OUTLEVEL ','FRAME ','L-TAG ','L-ETAG ', |
| 188 | & 'ECMS-CUT ','VDM-PAR1 ','HISTOGRAM ','XS-TABLE ', |
| 189 | & 'GLAUB-PAR ','GLAUB-INI ','VDM-PAR2 ','XS-QELPRO ', |
| 190 | & 'RNDMINIT ','LEPTO-CUT ','LEPTO-LST ','LEPTO-PARL', |
| 191 | & 'START ','STOP '/ |
| 192 | DATA BLANK /' '/ |
| 193 | |
| 194 | DATA LSTART,LXSTAB,IFIRST /.TRUE.,.FALSE.,1/ |
| 195 | DATA CMEOLD /0.0D0/ |
| 196 | |
| 197 | * --- Added by Chiara |
| 198 | |
| 199 | CHARACTER*100 ALIROOT |
| 200 | CHARACTER*100 FILNAM |
| 201 | INTEGER*4 LNROOT |
| 202 | LOGICAL EXISTS |
| 203 | ALIROOT=' ' |
| 204 | |
| 205 | *--------------------------------------------------------------------- |
| 206 | * at the first call of INIT: initialize event generation |
| 207 | EPNSAV = EPN |
| 208 | IF (LSTART) THEN |
| 209 | CALL DT_TITLE |
| 210 | * initialization and test of the random number generator |
| 211 | IF (ITRSPT.NE.1) THEN |
| 212 | |
| 213 | CALL FL48UT (ISRM48,ISEED1,ISEED2) |
| 214 | CALL FL48IN (54217137,ISEED1,ISEED2) |
| 215 | |
| 216 | ENDIF |
| 217 | * initialization of BAMJET, DECAY and HADRIN |
| 218 | CALL DT_DDATAR |
| 219 | CALL DT_DHADDE |
| 220 | CALL DT_DCHANT |
| 221 | CALL DT_DCHANH |
| 222 | * set default values for input variables |
| 223 | CALL DT_DEFAUL(EPN,PPN) |
| 224 | IGLAU = 0 |
| 225 | IXSQEL = 0 |
| 226 | * flag for collision energy input |
| 227 | LEINP = .FALSE. |
| 228 | LSTART = .FALSE. |
| 229 | ENDIF |
| 230 | |
| 231 | *--------------------------------------------------------------------- |
| 232 | 10 CONTINUE |
| 233 | |
| 234 | * bypass reading input cards (e.g. for use with Fluka) |
| 235 | * in this case Epn is expected to carry the beam momentum |
| 236 | IF (NCASES.EQ.-1) THEN |
| 237 | IP = NPMASS |
| 238 | IPZ = NPCHAR |
| 239 | PPN = EPNSAV |
| 240 | EPN = ZERO |
| 241 | CMENER = ZERO |
| 242 | LEINP = .TRUE. |
| 243 | MKCRON = 0 |
| 244 | WHAT(1) = 1 |
| 245 | WHAT(2) = 0 |
| 246 | CODEWD = 'START ' |
| 247 | GOTO 900 |
| 248 | ENDIF |
| 249 | |
| 250 | * read control card from input-unit LINP |
| 251 | C READ(LINP,'(A78)',END=9999) CLINE |
| 252 | * ### Read control card from specified file |
| 253 | * ### Changed by Chiara (original version LINP=5) |
| 254 | * OPEN(UNIT=7, |
| 255 | * + FILE='/home/oppedisa/AliRoot/new/DPMJET/inp/PbPbLHC.inp', |
| 256 | * + STATUS='OLD') |
| 257 | |
| 258 | CALL GETENVF('ALICE_ROOT',ALIROOT) |
| 259 | LNROOT = LNBLNK(ALIROOT) |
| 260 | |
| 261 | FILNAM=ALIROOT(1:LNROOT)//'/DPMJET/inp/PbPbLHC.inp' |
| 262 | OPEN(UNIT=7,FILE=FILNAM,STATUS='OLD') |
| 263 | |
| 264 | |
| 265 | READ(7,'(A78)',END=9999) CLINE |
| 266 | |
| 267 | IF (CLINE(1:1).EQ.'*') THEN |
| 268 | * comment-line |
| 269 | C WRITE(LOUT,'(A78)') CLINE |
| 270 | GOTO 10 |
| 271 | ENDIF |
| 272 | C READ(CLINE,1000,END=9999) CODEWD,(WHAT(I),I=1,6),SDUM |
| 273 | C1000 FORMAT(A10,6E10.0,A8) |
| 274 | DO 1008 I=1,6 |
| 275 | WHAT(I) = ZERO |
| 276 | 1008 CONTINUE |
| 277 | READ(CLINE,1006,END=9999) CODEWD,CWHAT,SDUM |
| 278 | 1006 FORMAT(A10,A60,A8) |
| 279 | READ(CWHAT,*,END=1007) (WHAT(I),I=1,6) |
| 280 | 1007 CONTINUE |
| 281 | WRITE(LOUT,1001) CODEWD,(WHAT(I),I=1,6),SDUM |
| 282 | 1001 FORMAT(A10,6G10.3,A8) |
| 283 | |
| 284 | 900 CONTINUE |
| 285 | |
| 286 | * check for valid control card and get card index |
| 287 | ICW = 0 |
| 288 | DO 11 I=1,MXCARD |
| 289 | IF (CODEWD.EQ.CODE(I)) ICW = I |
| 290 | 11 CONTINUE |
| 291 | IF (ICW.EQ.0) THEN |
| 292 | WRITE(LOUT,1002) CODEWD |
| 293 | 1002 FORMAT(/,1X,'---> ',A10,': invalid control-card !',/) |
| 294 | GOTO 10 |
| 295 | ENDIF |
| 296 | |
| 297 | GOTO( |
| 298 | *------------------------------------------------------------ |
| 299 | * TITLE , PROJPAR , TARPAR , ENERGY , MOMENTUM, |
| 300 | & 100 , 110 , 120 , 130 , 140 , |
| 301 | * |
| 302 | *------------------------------------------------------------ |
| 303 | * CMENERGY, EMULSION, FERMI , TAUFOR , PAULI , |
| 304 | & 150 , 160 , 170 , 180 , 190 , |
| 305 | * |
| 306 | *------------------------------------------------------------ |
| 307 | * COULOMB , HADRIN , EVAP , EMCCHECK, MODEL , |
| 308 | & 200 , 210 , 220 , 230 , 240 , |
| 309 | * |
| 310 | *------------------------------------------------------------ |
| 311 | * PHOINPUT, GLAUBERI, FLUCTUAT, CENTRAL , RECOMBIN, |
| 312 | & 250 , 260 , 270 , 280 , 290 , |
| 313 | * |
| 314 | *------------------------------------------------------------ |
| 315 | * COMBIJET, XCUTS , INTPT , CRONINPT, SEADISTR, |
| 316 | & 300 , 310 , 320 , 330 , 340 , |
| 317 | * |
| 318 | *------------------------------------------------------------ |
| 319 | * SEASU3 , DIQUARKS, RESONANC, DIFFRACT, SINGLECH, |
| 320 | & 350 , 360 , 370 , 380 , 390 , |
| 321 | * |
| 322 | *------------------------------------------------------------ |
| 323 | * NOFRAGME, HADRONIZE, POPCORN , PARDECAY, BEAM , |
| 324 | & 400 , 410 , 420 , 430 , 440 , |
| 325 | * |
| 326 | *------------------------------------------------------------ |
| 327 | * LUND-MSTU, LUND-MSTJ, LUND-MDCY, LUND-PARJ, LUND-PARU, |
| 328 | & 450 , 451 , 452 , 460 , 470 , |
| 329 | * |
| 330 | *------------------------------------------------------------ |
| 331 | * OUTLEVEL, FRAME , L-TAG , L-ETAG , ECMS-CUT, |
| 332 | & 480 , 490 , 500 , 510 , 520 , |
| 333 | * |
| 334 | *------------------------------------------------------------ |
| 335 | * VDM-PAR1, HISTOGRAM, XS-TABLE , GLAUB-PAR, GLAUB-INI, |
| 336 | & 530 , 540 , 550 , 560 , 565 , |
| 337 | * |
| 338 | *------------------------------------------------------------ |
| 339 | * , , VDM-PAR2, XS-QELPRO, RNDMINIT , |
| 340 | & 570 , 580 , 590 , |
| 341 | * |
| 342 | *------------------------------------------------------------ |
| 343 | * LEPTO-CUT, LEPTO-LST,LEPTO-PARL, START , STOP ) |
| 344 | & 600 , 610 , 620 , 630 , 640 ) , ICW |
| 345 | * |
| 346 | *------------------------------------------------------------ |
| 347 | |
| 348 | GOTO 10 |
| 349 | |
| 350 | ********************************************************************* |
| 351 | * * |
| 352 | * control card: codewd = TITLE * |
| 353 | * * |
| 354 | * what (1..6), sdum no meaning * |
| 355 | * * |
| 356 | * Note: The control-card following this must consist of * |
| 357 | * a string of characters usually giving the title of * |
| 358 | * the run. * |
| 359 | * * |
| 360 | ********************************************************************* |
| 361 | |
| 362 | 100 CONTINUE |
| 363 | C READ(LINP,'(A78)') CTITLE |
| 364 | * ### Read control card from specified file |
| 365 | * ### Changed by Chiara (original version LINP=5) |
| 366 | READ(7,'(A78)') CTITLE |
| 367 | |
| 368 | WRITE(LOUT,'(//,5X,A78,//)') CTITLE |
| 369 | GOTO 10 |
| 370 | |
| 371 | ********************************************************************* |
| 372 | * * |
| 373 | * control card: codewd = PROJPAR * |
| 374 | * * |
| 375 | * what (1) = mass number of projectile nucleus default: 1 * |
| 376 | * what (2) = charge of projectile nucleus default: 1 * |
| 377 | * what (3..6) no meaning * |
| 378 | * sdum projectile particle code word * |
| 379 | * * |
| 380 | * Note: If sdum is defined what (1..2) have no meaning. * |
| 381 | * * |
| 382 | ********************************************************************* |
| 383 | |
| 384 | 110 CONTINUE |
| 385 | IF (SDUM.EQ.BLANK) THEN |
| 386 | IP = INT(WHAT(1)) |
| 387 | IPZ = INT(WHAT(2)) |
| 388 | IJPROJ = 1 |
| 389 | IBPROJ = 1 |
| 390 | ELSE |
| 391 | IJPROJ = 0 |
| 392 | DO 111 II=1,30 |
| 393 | IF (SDUM.EQ.BTYPE(II)) THEN |
| 394 | IP = 1 |
| 395 | IPZ = 1 |
| 396 | IF (II.EQ.26) THEN |
| 397 | IJPROJ = 135 |
| 398 | ELSEIF (II.EQ.27) THEN |
| 399 | IJPROJ = 136 |
| 400 | ELSEIF (II.EQ.28) THEN |
| 401 | IJPROJ = 133 |
| 402 | ELSEIF (II.EQ.29) THEN |
| 403 | IJPROJ = 134 |
| 404 | ELSE |
| 405 | IJPROJ = II |
| 406 | ENDIF |
| 407 | IBPROJ = IIBAR(IJPROJ) |
| 408 | * photon |
| 409 | IF ((IJPROJ.EQ.7).AND.(WHAT(1).GT.ZERO)) VIRT = WHAT(1) |
| 410 | * lepton |
| 411 | IF (((IJPROJ.EQ. 3).OR.(IJPROJ.EQ. 4).OR. |
| 412 | & (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11)).AND. |
| 413 | & (WHAT(1).GT.ZERO)) Q2HI = WHAT(1) |
| 414 | ENDIF |
| 415 | 111 CONTINUE |
| 416 | IF (IJPROJ.EQ.0) THEN |
| 417 | WRITE(LOUT,1110) |
| 418 | 1110 FORMAT(/,1X,'invalid PROJPAR card !',/) |
| 419 | GOTO 9999 |
| 420 | ENDIF |
| 421 | ENDIF |
| 422 | GOTO 10 |
| 423 | |
| 424 | ********************************************************************* |
| 425 | * * |
| 426 | * control card: codewd = TARPAR * |
| 427 | * * |
| 428 | * what (1) = mass number of target nucleus default: 1 * |
| 429 | * what (2) = charge of target nucleus default: 1 * |
| 430 | * what (3..6) no meaning * |
| 431 | * sdum target particle code word * |
| 432 | * * |
| 433 | * Note: If sdum is defined what (1..2) have no meaning. * |
| 434 | * * |
| 435 | ********************************************************************* |
| 436 | |
| 437 | 120 CONTINUE |
| 438 | IF (SDUM.EQ.BLANK) THEN |
| 439 | IT = INT(WHAT(1)) |
| 440 | ITZ = INT(WHAT(2)) |
| 441 | IJTARG = 1 |
| 442 | IBTARG = 1 |
| 443 | ELSE |
| 444 | IJTARG = 0 |
| 445 | DO 121 II=1,30 |
| 446 | IF (SDUM.EQ.BTYPE(II)) THEN |
| 447 | IT = 1 |
| 448 | ITZ = 1 |
| 449 | IJTARG = II |
| 450 | IBTARG = IIBAR(IJTARG) |
| 451 | ENDIF |
| 452 | 121 CONTINUE |
| 453 | IF (IJTARG.EQ.0) THEN |
| 454 | WRITE(LOUT,1120) |
| 455 | 1120 FORMAT(/,1X,'invalid TARPAR card !',/) |
| 456 | GOTO 9999 |
| 457 | ENDIF |
| 458 | ENDIF |
| 459 | GOTO 10 |
| 460 | |
| 461 | ********************************************************************* |
| 462 | * * |
| 463 | * control card: codewd = ENERGY * |
| 464 | * * |
| 465 | * what (1) = energy (GeV) of projectile in Lab. * |
| 466 | * if what(1) < 0: |what(1)| = kinetic energy * |
| 467 | * default: 200 GeV * |
| 468 | * if |what(2)| > 0: min. energy for variable * |
| 469 | * energy runs * |
| 470 | * what (2) = max. energy for variable energy runs * |
| 471 | * if what(2) < 0: |what(2)| = kinetic energy * |
| 472 | * * |
| 473 | ********************************************************************* |
| 474 | |
| 475 | 130 CONTINUE |
| 476 | EPN = WHAT(1) |
| 477 | PPN = ZERO |
| 478 | CMENER = ZERO |
| 479 | IF ((ABS(WHAT(2)).GT.ZERO).AND. |
| 480 | & (ABS(WHAT(2)).GT.ABS(WHAT(1)))) THEN |
| 481 | VARELO = WHAT(1) |
| 482 | VAREHI = WHAT(2) |
| 483 | EPN = VAREHI |
| 484 | ENDIF |
| 485 | LEINP = .TRUE. |
| 486 | GOTO 10 |
| 487 | |
| 488 | ********************************************************************* |
| 489 | * * |
| 490 | * control card: codewd = MOMENTUM * |
| 491 | * * |
| 492 | * what (1) = momentum (GeV/c) of projectile in Lab. * |
| 493 | * default: 200 GeV/c * |
| 494 | * what (2..6), sdum no meaning * |
| 495 | * * |
| 496 | ********************************************************************* |
| 497 | |
| 498 | 140 CONTINUE |
| 499 | EPN = ZERO |
| 500 | PPN = WHAT(1) |
| 501 | CMENER = ZERO |
| 502 | LEINP = .TRUE. |
| 503 | GOTO 10 |
| 504 | |
| 505 | ********************************************************************* |
| 506 | * * |
| 507 | * control card: codewd = CMENERGY * |
| 508 | * * |
| 509 | * what (1) = energy in nucleon-nucleon cms. * |
| 510 | * default: none * |
| 511 | * what (2..6), sdum no meaning * |
| 512 | * * |
| 513 | ********************************************************************* |
| 514 | |
| 515 | 150 CONTINUE |
| 516 | EPN = ZERO |
| 517 | PPN = ZERO |
| 518 | CMENER = WHAT(1) |
| 519 | LEINP = .TRUE. |
| 520 | GOTO 10 |
| 521 | |
| 522 | ********************************************************************* |
| 523 | * * |
| 524 | * control card: codewd = EMULSION * |
| 525 | * * |
| 526 | * definition of nuclear emulsions * |
| 527 | * * |
| 528 | * what(1) mass number of emulsion component * |
| 529 | * what(2) charge of emulsion component * |
| 530 | * what(3) fraction of events in which a scattering on a * |
| 531 | * nucleus of this properties is performed * |
| 532 | * what(4,5,6) as what(1,2,3) but for another component * |
| 533 | * default: no emulsion * |
| 534 | * sdum no meaning * |
| 535 | * * |
| 536 | * Note: If this input-card is once used with valid parameters * |
| 537 | * TARPAR is obsolete. * |
| 538 | * Not the absolute values of the fractions are important * |
| 539 | * but only the ratios of fractions of different comp. * |
| 540 | * This control card can be repeatedly used to define * |
| 541 | * emulsions consisting of up to 10 elements. * |
| 542 | * * |
| 543 | ********************************************************************* |
| 544 | |
| 545 | 160 CONTINUE |
| 546 | IF ((WHAT(1).GT.ZERO).AND.(WHAT(2).GT.ZERO) |
| 547 | & .AND.(ABS(WHAT(3)).GT.ZERO)) THEN |
| 548 | NCOMPO = NCOMPO+1 |
| 549 | IF (NCOMPO.GT.NCOMPX) THEN |
| 550 | WRITE(LOUT,1600) |
| 551 | STOP |
| 552 | ENDIF |
| 553 | IEMUMA(NCOMPO) = INT(WHAT(1)) |
| 554 | IEMUCH(NCOMPO) = INT(WHAT(2)) |
| 555 | EMUFRA(NCOMPO) = WHAT(3) |
| 556 | IEMUL = 1 |
| 557 | C CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO)) |
| 558 | ENDIF |
| 559 | IF ((WHAT(4).GT.ZERO).AND.(WHAT(5).GT.ZERO) |
| 560 | & .AND.(ABS(WHAT(6)).GT.ZERO)) THEN |
| 561 | NCOMPO = NCOMPO+1 |
| 562 | IF (NCOMPO.GT.NCOMPX) THEN |
| 563 | WRITE(LOUT,1001) |
| 564 | STOP |
| 565 | ENDIF |
| 566 | IEMUMA(NCOMPO) = INT(WHAT(4)) |
| 567 | IEMUCH(NCOMPO) = INT(WHAT(5)) |
| 568 | EMUFRA(NCOMPO) = WHAT(6) |
| 569 | C CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO)) |
| 570 | ENDIF |
| 571 | 1600 FORMAT(1X,'too many emulsion components - program stopped') |
| 572 | GOTO 10 |
| 573 | |
| 574 | ********************************************************************* |
| 575 | * * |
| 576 | * control card: codewd = FERMI * |
| 577 | * * |
| 578 | * what (1) = -1 Fermi-motion of nucleons not treated * |
| 579 | * default: 1 * |
| 580 | * what (2) = scale factor for Fermi-momentum * |
| 581 | * default: 0.75 * |
| 582 | * what (3..6), sdum no meaning * |
| 583 | * * |
| 584 | ********************************************************************* |
| 585 | |
| 586 | 170 CONTINUE |
| 587 | IF (WHAT(1).EQ.-1.0D0) THEN |
| 588 | LFERMI = .FALSE. |
| 589 | ELSE |
| 590 | LFERMI = .TRUE. |
| 591 | ENDIF |
| 592 | XMOD = WHAT(2) |
| 593 | IF (XMOD.GE.ZERO) FERMOD = XMOD |
| 594 | GOTO 10 |
| 595 | |
| 596 | ********************************************************************* |
| 597 | * * |
| 598 | * control card: codewd = TAUFOR * |
| 599 | * * |
| 600 | * formation time supressed intranuclear cascade * |
| 601 | * * |
| 602 | * what (1) formation time (in fm/c) * |
| 603 | * note: what(1)=10. corresponds roughly to an * |
| 604 | * average formation time of 1 fm/c * |
| 605 | * default: 5. fm/c * |
| 606 | * what (2) number of generations followed * |
| 607 | * default: 25 * |
| 608 | * what (3) = 1. p_t-dependent formation zone * |
| 609 | * = 2. constant formation zone * |
| 610 | * default: 1 * |
| 611 | * what (4) modus of selection of nucleus where the * |
| 612 | * cascade if followed first * |
| 613 | * = 1. proj./target-nucleus with probab. 1/2 * |
| 614 | * = 2. nucleus with highest mass * |
| 615 | * = 3. proj. nucleus if particle is moving in pos. z * |
| 616 | * targ. nucleus if particle is moving in neg. z * |
| 617 | * default: 1 * |
| 618 | * what (5..6), sdum no meaning * |
| 619 | * * |
| 620 | ********************************************************************* |
| 621 | |
| 622 | 180 CONTINUE |
| 623 | TAUFOR = WHAT(1) |
| 624 | KTAUGE = INT(WHAT(2)) |
| 625 | INCMOD = 1 |
| 626 | IF ((WHAT(3).GE.1.0D0).AND.(WHAT(3).LE.2.0D0)) |
| 627 | & ITAUVE = INT(WHAT(3)) |
| 628 | IF ((WHAT(4).GE.1.0D0).AND.(WHAT(4).LE.3.0D0)) |
| 629 | & INCMOD = INT(WHAT(4)) |
| 630 | GOTO 10 |
| 631 | |
| 632 | ********************************************************************* |
| 633 | * * |
| 634 | * control card: codewd = PAULI * |
| 635 | * * |
| 636 | * what (1) = -1 Pauli's principle for secondary * |
| 637 | * interactions not treated * |
| 638 | * default: 1 * |
| 639 | * what (2..6), sdum no meaning * |
| 640 | * * |
| 641 | ********************************************************************* |
| 642 | |
| 643 | 190 CONTINUE |
| 644 | IF (WHAT(1).EQ.-1.0D0) THEN |
| 645 | LPAULI = .FALSE. |
| 646 | ELSE |
| 647 | LPAULI = .TRUE. |
| 648 | ENDIF |
| 649 | GOTO 10 |
| 650 | |
| 651 | ********************************************************************* |
| 652 | * * |
| 653 | * control card: codewd = COULOMB * |
| 654 | * * |
| 655 | * what (1) = -1. Coulomb-energy treatment switched off * |
| 656 | * default: 1 * |
| 657 | * what (2..6), sdum no meaning * |
| 658 | * * |
| 659 | ********************************************************************* |
| 660 | |
| 661 | 200 CONTINUE |
| 662 | ICOUL = 1 |
| 663 | IF (WHAT(1).EQ.-1.0D0) THEN |
| 664 | ICOUL = 0 |
| 665 | ELSE |
| 666 | ICOUL = 1 |
| 667 | ENDIF |
| 668 | GOTO 10 |
| 669 | |
| 670 | ********************************************************************* |
| 671 | * * |
| 672 | * control card: codewd = HADRIN * |
| 673 | * * |
| 674 | * HADRIN module * |
| 675 | * * |
| 676 | * what (1) = 0. elastic/inelastic interactions with probab. * |
| 677 | * as defined by cross-sections * |
| 678 | * = 1. inelastic interactions forced * |
| 679 | * = 2. elastic interactions forced * |
| 680 | * default: 1 * |
| 681 | * what (2) upper threshold in total energy (GeV) below * |
| 682 | * which interactions are sampled by HADRIN * |
| 683 | * default: 5. GeV * |
| 684 | * what (3..6), sdum no meaning * |
| 685 | * * |
| 686 | ********************************************************************* |
| 687 | |
| 688 | 210 CONTINUE |
| 689 | IWHAT = INT(WHAT(1)) |
| 690 | IF ((IWHAT.GE.0).AND.(IWHAT.LE.2)) INTHAD = IWHAT |
| 691 | IF ((WHAT(2).GT.ZERO).AND.(WHAT(2).LT.15.0D0)) EHADTH = WHAT(2) |
| 692 | GOTO 10 |
| 693 | |
| 694 | ********************************************************************* |
| 695 | * * |
| 696 | * control card: codewd = EVAP * |
| 697 | * * |
| 698 | * evaporation module * |
| 699 | * * |
| 700 | * what (1) =< -1 ==> evaporation is switched off * |
| 701 | * >= 1 ==> evaporation is performed * |
| 702 | * * |
| 703 | * what (1) = i1 + i2*10 + i3*100 + i4*10000 * |
| 704 | * (i1, i2, i3, i4 >= 0 ) * |
| 705 | * * |
| 706 | * i1 is the flag for selecting the T=0 level density option used * |
| 707 | * = 1: standard EVAP level densities with Cook pairing * |
| 708 | * energies * |
| 709 | * = 2: Z,N-dependent Gilbert & Cameron level densities * |
| 710 | * (default) * |
| 711 | * = 3: Julich A-dependent level densities * |
| 712 | * = 4: Z,N-dependent Brancazio & Cameron level densities * |
| 713 | * * |
| 714 | * i2 >= 1: high energy fission activated * |
| 715 | * (default high energy fission activated) * |
| 716 | * * |
| 717 | * i3 = 0: No energy dependence for level densities * |
| 718 | * = 1: Standard Ignyatuk (1975, 1st) energy dependence * |
| 719 | * for level densities (default) * |
| 720 | * = 2: Standard Ignyatuk (1975, 1st) energy dependence * |
| 721 | * for level densities with NOT used set of parameters * |
| 722 | * = 3: Standard Ignyatuk (1975, 1st) energy dependence * |
| 723 | * for level densities with NOT used set of parameters * |
| 724 | * = 4: Second Ignyatuk (1975, 2nd) energy dependence * |
| 725 | * for level densities * |
| 726 | * = 5: Second Ignyatuk (1975, 2nd) energy dependence * |
| 727 | * for level densities with fit 1 Iljinov & Mebel set of * |
| 728 | * parameters * |
| 729 | * = 6: Second Ignyatuk (1975, 2nd) energy dependence * |
| 730 | * for level densities with fit 2 Iljinov & Mebel set of * |
| 731 | * parameters * |
| 732 | * = 7: Second Ignyatuk (1975, 2nd) energy dependence * |
| 733 | * for level densities with fit 3 Iljinov & Mebel set of * |
| 734 | * parameters * |
| 735 | * = 8: Second Ignyatuk (1975, 2nd) energy dependence * |
| 736 | * for level densities with fit 4 Iljinov & Mebel set of * |
| 737 | * parameters * |
| 738 | * * |
| 739 | * i4 >= 1: Original Gilbert and Cameron pairing energies used * |
| 740 | * (default Cook's modified pairing energies) * |
| 741 | * * |
| 742 | * what (2) = ig + 10 * if (ig and if must have the same sign) * |
| 743 | * * |
| 744 | * ig =< -1 ==> deexcitation gammas are not produced * |
| 745 | * (if the evaporation step is not performed * |
| 746 | * they are never produced) * |
| 747 | * if =< -1 ==> Fermi Break Up is not invoked * |
| 748 | * (if the evaporation step is not performed * |
| 749 | * it is never invoked) * |
| 750 | * The default is: deexcitation gamma produced and Fermi break up * |
| 751 | * activated for the new preequilibrium, not * |
| 752 | * activated otherwise. * |
| 753 | * what (3..6), sdum no meaning * |
| 754 | * * |
| 755 | ********************************************************************* |
| 756 | |
| 757 | 220 CONTINUE |
| 758 | |
| 759 | IF (WHAT(1).LE.-1.0D0) THEN |
| 760 | LEVPRT = .FALSE. |
| 761 | LDEEXG = .FALSE. |
| 762 | LHEAVY = .FALSE. |
| 763 | GOTO 10 |
| 764 | ENDIF |
| 765 | WHTSAV = WHAT (1) |
| 766 | IF ( NINT (WHAT (1)) .GE. 10000 ) THEN |
| 767 | LLVMOD = .FALSE. |
| 768 | JLVHLP = NINT (WHAT (1)) / 10000 |
| 769 | WHAT (1) = WHAT (1) - 10000.D+00 * JLVHLP |
| 770 | END IF |
| 771 | IF ( NINT (WHAT (1)) .GE. 100 ) THEN |
| 772 | JLVMOD = NINT (WHAT (1)) / 100 |
| 773 | WHAT (1) = WHAT (1) - 100.D+00 * JLVMOD |
| 774 | END IF |
| 775 | IF ( NINT (WHAT (1)) .GE. 10 ) THEN |
| 776 | IFISS = 1 |
| 777 | JLVHLP = NINT (WHAT (1)) / 10 |
| 778 | WHAT (1) = WHAT (1) - 10.D+00 * JLVHLP |
| 779 | ELSE IF ( NINT (WHTSAV) .NE. 0 ) THEN |
| 780 | IFISS = 0 |
| 781 | END IF |
| 782 | IF ( NINT (WHAT (1)) .GE. 0 ) THEN |
| 783 | LEVPRT = .TRUE. |
| 784 | ILVMOD = NINT (WHAT(1)) |
| 785 | IF ( ABS (NINT (WHAT (2))) .GE. 10 ) THEN |
| 786 | LFRMBK = .TRUE. |
| 787 | JLVHLP = NINT (WHAT (2)) / 10 |
| 788 | WHAT (2) = WHAT (2) - 10.D+00 * JLVHLP |
| 789 | ELSE IF ( NINT (WHAT (2)) .NE. 0 ) THEN |
| 790 | LFRMBK = .FALSE. |
| 791 | END IF |
| 792 | IF ( NINT (WHAT (2)) .GE. 0 ) THEN |
| 793 | LDEEXG = .TRUE. |
| 794 | ELSE |
| 795 | LDEEXG = .FALSE. |
| 796 | END IF |
| 797 | **sr heavies are always put to /FKFHVY/ |
| 798 | C IF ( NINT (WHAT(3)) .GE. 1 ) THEN |
| 799 | C LHEAVY = .TRUE. |
| 800 | C ELSE |
| 801 | C LHEAVY = .FALSE. |
| 802 | C END IF |
| 803 | LHEAVY = .TRUE. |
| 804 | ELSE |
| 805 | LEVPRT = .FALSE. |
| 806 | LDEEXG = .FALSE. |
| 807 | LHEAVY = .FALSE. |
| 808 | END IF |
| 809 | |
| 810 | LOLDEV = .FALSE. |
| 811 | |
| 812 | GOTO 10 |
| 813 | |
| 814 | ********************************************************************* |
| 815 | * * |
| 816 | * control card: codewd = EMCCHECK * |
| 817 | * * |
| 818 | * extended energy-momentum / quantum-number conservation check * |
| 819 | * * |
| 820 | * what (1) = -1 extended check not performed * |
| 821 | * default: 1. * |
| 822 | * what (2..6), sdum no meaning * |
| 823 | * * |
| 824 | ********************************************************************* |
| 825 | |
| 826 | 230 CONTINUE |
| 827 | IF (WHAT(1).EQ.-1) THEN |
| 828 | LEMCCK = .FALSE. |
| 829 | ELSE |
| 830 | LEMCCK = .TRUE. |
| 831 | ENDIF |
| 832 | GOTO 10 |
| 833 | |
| 834 | ********************************************************************* |
| 835 | * * |
| 836 | * control card: codewd = MODEL * |
| 837 | * * |
| 838 | * Model to be used to treat nucleon-nucleon interactions * |
| 839 | * * |
| 840 | * sdum = DTUNUC two-chain model * |
| 841 | * = PHOJET multiple chains including minijets * |
| 842 | * = LEPTO DIS * |
| 843 | * = QNEUTRIN quasi-elastic neutrino scattering * |
| 844 | * default: PHOJET * |
| 845 | * * |
| 846 | * if sdum = LEPTO: * |
| 847 | * what (1) (variable INTER) * |
| 848 | * = 1 gamma exchange * |
| 849 | * = 2 W+- exchange * |
| 850 | * = 3 Z0 exchange * |
| 851 | * = 4 gamma/Z0 exchange * |
| 852 | * * |
| 853 | * if sdum = QNEUTRIN: * |
| 854 | * what (1) = 0 elastic scattering on nucleon and * |
| 855 | * tau does not decay (default) * |
| 856 | * = 1 decay of tau into mu.. * |
| 857 | * = 2 decay of tau into e.. * |
| 858 | * = 10 CC events on p and n * |
| 859 | * = 11 NC events on p and n * |
| 860 | * * |
| 861 | * what (2..6) no meaning * |
| 862 | * * |
| 863 | ********************************************************************* |
| 864 | |
| 865 | 240 CONTINUE |
| 866 | IF (SDUM.EQ.CMODEL(1)) THEN |
| 867 | MCGENE = 1 |
| 868 | ELSEIF (SDUM.EQ.CMODEL(2)) THEN |
| 869 | MCGENE = 2 |
| 870 | ELSEIF (SDUM.EQ.CMODEL(3)) THEN |
| 871 | MCGENE = 3 |
| 872 | IF ((WHAT(1).GE.1.0D0).AND.(WHAT(1).LE.4.0D0)) |
| 873 | & INTER = INT(WHAT(1)) |
| 874 | ELSEIF (SDUM.EQ.CMODEL(4)) THEN |
| 875 | MCGENE = 4 |
| 876 | IWHAT = INT(WHAT(1)) |
| 877 | IF ((IWHAT.EQ.1 ).OR.(IWHAT.EQ.2 ).OR. |
| 878 | & (IWHAT.EQ.10).OR.(IWHAT.EQ.11)) |
| 879 | & NEUDEC = IWHAT |
| 880 | ELSE |
| 881 | STOP ' Unknown model !' |
| 882 | ENDIF |
| 883 | GOTO 10 |
| 884 | |
| 885 | ********************************************************************* |
| 886 | * * |
| 887 | * control card: codewd = PHOINPUT * |
| 888 | * * |
| 889 | * Start of input-section for PHOJET-specific input-cards * |
| 890 | * Note: This section will not be finished before giving * |
| 891 | * ENDINPUT-card * |
| 892 | * what (1..6), sdum no meaning * |
| 893 | * * |
| 894 | ********************************************************************* |
| 895 | |
| 896 | 250 CONTINUE |
| 897 | IF (LPHOIN) THEN |
| 898 | |
| 899 | C CALL PHO_INIT(LINP,IREJ1) |
| 900 | * ### Read control card from specified file |
| 901 | * ### Changed by Chiara (original version LINP=5) |
| 902 | CALL PHO_INIT(7,IREJ1) |
| 903 | |
| 904 | IF (IREJ1.NE.0) THEN |
| 905 | WRITE(LOUT,'(1X,A)')'INIT: reading PHOJET-input failed' |
| 906 | STOP |
| 907 | ENDIF |
| 908 | LPHOIN = .FALSE. |
| 909 | ENDIF |
| 910 | GOTO 10 |
| 911 | |
| 912 | ********************************************************************* |
| 913 | * * |
| 914 | * control card: codewd = GLAUBERI * |
| 915 | * * |
| 916 | * Pre-initialization of impact parameter selection * |
| 917 | * * |
| 918 | * what (1..6), sdum no meaning * |
| 919 | * * |
| 920 | ********************************************************************* |
| 921 | |
| 922 | 260 CONTINUE |
| 923 | IF (IFIRST.NE.99) THEN |
| 924 | CALL DT_RNDMST(12,34,56,78) |
| 925 | CALL DT_RNDMTE(1) |
| 926 | OPEN(40,FILE='shm.out',STATUS='UNKNOWN') |
| 927 | C OPEN(11,FILE='shm.dbg',STATUS='UNKNOWN') |
| 928 | IFIRST = 99 |
| 929 | ENDIF |
| 930 | |
| 931 | IPPN = 8 |
| 932 | PLOW = 10.0D0 |
| 933 | C IPPN = 1 |
| 934 | C PLOW = 100.0D0 |
| 935 | PHI = 1.0D5 |
| 936 | APLOW = LOG10(PLOW) |
| 937 | APHI = LOG10(PHI) |
| 938 | ADP = (APHI-APLOW)/DBLE(IPPN) |
| 939 | |
| 940 | IPLOW = 1 |
| 941 | IDIP = 1 |
| 942 | IIP = 5 |
| 943 | C IPLOW = 1 |
| 944 | C IDIP = 1 |
| 945 | C IIP = 1 |
| 946 | IPRANG(1) = 1 |
| 947 | IPRANG(2) = 2 |
| 948 | IPRANG(3) = 5 |
| 949 | IPRANG(4) = 10 |
| 950 | IPRANG(5) = 20 |
| 951 | |
| 952 | ITLOW = 30 |
| 953 | IDIT = 3 |
| 954 | IIT = 60 |
| 955 | C IDIT = 10 |
| 956 | C IIT = 21 |
| 957 | |
| 958 | DO 473 NCIT=1,IIT |
| 959 | IT = ITLOW+(NCIT-1)*IDIT |
| 960 | C IPHI = IT |
| 961 | C IDIP = 10 |
| 962 | C IIP = (IPHI-IPLOW)/IDIP |
| 963 | C IF (IIP.EQ.0) IIP = 1 |
| 964 | C IF (IT.EQ.IPLOW) IIP = 0 |
| 965 | |
| 966 | DO 472 NCIP=1,IIP |
| 967 | IP = IPRANG(NCIP) |
| 968 | CC IF (NCIP.LE.IIP) THEN |
| 969 | C IP = IPLOW+(NCIP-1)*IDIP |
| 970 | CC ELSE |
| 971 | CC IP = IT |
| 972 | CC ENDIF |
| 973 | IF (IP.GT.IT) GOTO 472 |
| 974 | |
| 975 | DO 471 NCP=1,IPPN+1 |
| 976 | APPN = APLOW+DBLE(NCP-1)*ADP |
| 977 | PPN = 10**APPN |
| 978 | |
| 979 | OPEN(12,FILE='shm.sta',STATUS='UNKNOWN') |
| 980 | WRITE(12,'(1X,2I5,E15.3)') IP,IT,PPN |
| 981 | CLOSE(12) |
| 982 | |
| 983 | XLIM1 = 0.0D0 |
| 984 | XLIM2 = 50.0D0 |
| 985 | XLIM3 = ZERO |
| 986 | IBIN = 50 |
| 987 | CALL DT_NEWHGR(XDUM,XDUM,XDUM,XDUMB,-1,IHDUM) |
| 988 | CALL DT_NEWHGR(XLIM1,XLIM2,XLIM3,XDUMB,IBIN,IHSHMA) |
| 989 | |
| 990 | NEVFIT = 5 |
| 991 | C IF ((IP.GT.10).OR.(IT.GT.10)) THEN |
| 992 | C NEVFIT = 5 |
| 993 | C ELSE |
| 994 | C NEVFIT = 10 |
| 995 | C ENDIF |
| 996 | SIGAV = 0.0D0 |
| 997 | |
| 998 | DO 478 I=1,NEVFIT |
| 999 | CALL DT_SHMAKI(IP,IDUM1,IT,IDUM1,IJPROJ,PPN,99) |
| 1000 | SIGAV = SIGAV+XSPRO(1,1,1) |
| 1001 | DO 479 J=1,50 |
| 1002 | XC = DBLE(J) |
| 1003 | CALL DT_FILHGR(XC,BSITE(1,1,1,J),IHSHMA,I) |
| 1004 | 479 CONTINUE |
| 1005 | 478 CONTINUE |
| 1006 | |
| 1007 | CALL DT_EVTHIS(IDUM) |
| 1008 | HEADER = ' BSITE' |
| 1009 | C CALL OUTGEN(IHSHMA,0,0,0,0,0,HEADER,0,NEVFIT,ONE,0,1,-1) |
| 1010 | |
| 1011 | C CALL GENFIT(XPARA) |
| 1012 | C WRITE(40,'(2I4,E11.3,F6.0,5E11.3)') |
| 1013 | C & IP,IT,PPN,SIGAV/DBLE(NEVFIT),XPARA |
| 1014 | |
| 1015 | 471 CONTINUE |
| 1016 | |
| 1017 | 472 CONTINUE |
| 1018 | |
| 1019 | 473 CONTINUE |
| 1020 | |
| 1021 | STOP |
| 1022 | |
| 1023 | ********************************************************************* |
| 1024 | * * |
| 1025 | * control card: codewd = FLUCTUAT * |
| 1026 | * * |
| 1027 | * Treatment of cross section fluctuations * |
| 1028 | * * |
| 1029 | * what (1) = 1 treat cross section fluctuations * |
| 1030 | * default: 0. * |
| 1031 | * what (1..6), sdum no meaning * |
| 1032 | * * |
| 1033 | ********************************************************************* |
| 1034 | |
| 1035 | 270 CONTINUE |
| 1036 | IFLUCT = 0 |
| 1037 | IF (WHAT(1).EQ.ONE) THEN |
| 1038 | IFLUCT = 1 |
| 1039 | CALL DT_FLUINI |
| 1040 | ENDIF |
| 1041 | GOTO 10 |
| 1042 | |
| 1043 | ********************************************************************* |
| 1044 | * * |
| 1045 | * control card: codewd = CENTRAL * |
| 1046 | * * |
| 1047 | * what (1) = 1. central production forced default: 0 * |
| 1048 | * if what (1) < 0 and > -100 * |
| 1049 | * what (2) = min. impact parameter default: 0 * |
| 1050 | * what (3) = max. impact parameter default: b_max * |
| 1051 | * if what (1) < -99 * |
| 1052 | * what (2) = fraction of cross section default: 1 * |
| 1053 | * if what (1) = -1 : evaporation/fzc suppressed * |
| 1054 | * if what (1) < -1 : evaporation/fzc allowed * |
| 1055 | * * |
| 1056 | * what (4..6), sdum no meaning * |
| 1057 | * * |
| 1058 | ********************************************************************* |
| 1059 | |
| 1060 | 280 CONTINUE |
| 1061 | ICENTR = INT(WHAT(1)) |
| 1062 | IF (ICENTR.LT.0) THEN |
| 1063 | IF (ICENTR.GT.-100) THEN |
| 1064 | BIMIN = WHAT(2) |
| 1065 | BIMAX = WHAT(3) |
| 1066 | ELSE |
| 1067 | XSFRAC = WHAT(2) |
| 1068 | ENDIF |
| 1069 | ENDIF |
| 1070 | GOTO 10 |
| 1071 | |
| 1072 | ********************************************************************* |
| 1073 | * * |
| 1074 | * control card: codewd = RECOMBIN * |
| 1075 | * * |
| 1076 | * Chain recombination * |
| 1077 | * (recombine S-S and V-V chains to V-S chains) * |
| 1078 | * * |
| 1079 | * what (1) = -1. recombination switched off default: 1 * |
| 1080 | * what (2..6), sdum no meaning * |
| 1081 | * * |
| 1082 | ********************************************************************* |
| 1083 | |
| 1084 | 290 CONTINUE |
| 1085 | IRECOM = 1 |
| 1086 | IF (WHAT(1).EQ.-1.0D0) IRECOM = 0 |
| 1087 | GOTO 10 |
| 1088 | |
| 1089 | ********************************************************************* |
| 1090 | * * |
| 1091 | * control card: codewd = COMBIJET * |
| 1092 | * * |
| 1093 | * chain fusion (2 q-aq --> qq-aqaq) * |
| 1094 | * * |
| 1095 | * what (1) = 1 fusion treated * |
| 1096 | * default: 0. * |
| 1097 | * what (2) minimum number of uncombined chains from * |
| 1098 | * single projectile or target nucleons * |
| 1099 | * default: 0. * |
| 1100 | * what (3..6), sdum no meaning * |
| 1101 | * * |
| 1102 | ********************************************************************* |
| 1103 | |
| 1104 | 300 CONTINUE |
| 1105 | LCO2CR = .FALSE. |
| 1106 | IF (INT(WHAT(1)).EQ.1) LCO2CR = .TRUE. |
| 1107 | IF (WHAT(2).GE.ZERO) CUTOF = WHAT(2) |
| 1108 | GOTO 10 |
| 1109 | |
| 1110 | ********************************************************************* |
| 1111 | * * |
| 1112 | * control card: codewd = XCUTS * |
| 1113 | * * |
| 1114 | * thresholds for x-sampling * |
| 1115 | * * |
| 1116 | * what (1) defines lower threshold for val.-q x-value (CVQ) * |
| 1117 | * default: 1. * |
| 1118 | * what (2) defines lower threshold for val.-qq x-value (CDQ) * |
| 1119 | * default: 2. * |
| 1120 | * what (3) defines lower threshold for sea-q x-value (CSEA) * |
| 1121 | * default: 0.2 * |
| 1122 | * what (4) sea-q x-values in S-S chains (SSMIMA) * |
| 1123 | * default: 0.14 * |
| 1124 | * what (5) not used * |
| 1125 | * default: 2. * |
| 1126 | * what (6), sdum no meaning * |
| 1127 | * * |
| 1128 | * Note: Lower thresholds (what(1..3)) are def. as x_thr=CXXX/ECM * |
| 1129 | * * |
| 1130 | ********************************************************************* |
| 1131 | |
| 1132 | 310 CONTINUE |
| 1133 | IF (WHAT(1).GE.0.5D0) CVQ = WHAT(1) |
| 1134 | IF (WHAT(2).GE.ONE) CDQ = WHAT(2) |
| 1135 | IF (WHAT(3).GE.0.1D0) CSEA = WHAT(3) |
| 1136 | IF (WHAT(4).GE.ZERO) THEN |
| 1137 | SSMIMA = WHAT(4) |
| 1138 | SSMIMQ = SSMIMA**2 |
| 1139 | ENDIF |
| 1140 | IF (WHAT(5).GT.2.0D0) VVMTHR = WHAT(5) |
| 1141 | GOTO 10 |
| 1142 | |
| 1143 | ********************************************************************* |
| 1144 | * * |
| 1145 | * control card: codewd = INTPT * |
| 1146 | * * |
| 1147 | * what (1) = -1 intrinsic transverse momenta of partons * |
| 1148 | * not treated default: 1 * |
| 1149 | * what (2..6), sdum no meaning * |
| 1150 | * * |
| 1151 | ********************************************************************* |
| 1152 | |
| 1153 | 320 CONTINUE |
| 1154 | IF (WHAT(1).EQ.-1.0D0) THEN |
| 1155 | LINTPT = .FALSE. |
| 1156 | ELSE |
| 1157 | LINTPT = .TRUE. |
| 1158 | ENDIF |
| 1159 | GOTO 10 |
| 1160 | |
| 1161 | ********************************************************************* |
| 1162 | * * |
| 1163 | * control card: codewd = CRONINPT * |
| 1164 | * * |
| 1165 | * Cronin effect (multiple scattering of partons at chain ends) * |
| 1166 | * * |
| 1167 | * what (1) = -1 Cronin effect not treated default: 1 * |
| 1168 | * what (2) = 0 scattering parameter default: 0.64 * |
| 1169 | * what (3..6), sdum no meaning * |
| 1170 | * * |
| 1171 | ********************************************************************* |
| 1172 | |
| 1173 | 330 CONTINUE |
| 1174 | IF (WHAT(1).EQ.-1.0D0) THEN |
| 1175 | MKCRON = 0 |
| 1176 | ELSE |
| 1177 | MKCRON = 1 |
| 1178 | ENDIF |
| 1179 | CRONCO = WHAT(2) |
| 1180 | GOTO 10 |
| 1181 | |
| 1182 | ********************************************************************* |
| 1183 | * * |
| 1184 | * control card: codewd = SEADISTR * |
| 1185 | * * |
| 1186 | * what (1) (XSEACO) sea(x) prop. 1/x**what (1) default: 1. * |
| 1187 | * what (2) (UNON) default: 2. * |
| 1188 | * what (3) (UNOM) default: 1.5 * |
| 1189 | * what (4) (UNOSEA) default: 5. * |
| 1190 | * qdis(x) prop. (1-x)**what (1) etc. * |
| 1191 | * what (5..6), sdum no meaning * |
| 1192 | * * |
| 1193 | ********************************************************************* |
| 1194 | |
| 1195 | 340 CONTINUE |
| 1196 | XSEACO = WHAT(1) |
| 1197 | XSEACU = 1.05D0-XSEACO |
| 1198 | UNON = WHAT(2) |
| 1199 | IF (UNON.LT.0.1D0) UNON = 2.0D0 |
| 1200 | UNOM = WHAT(3) |
| 1201 | IF (UNOM.LT.0.1D0) UNOM = 1.5D0 |
| 1202 | UNOSEA = WHAT(4) |
| 1203 | IF (UNOSEA.LT.0.1D0) UNOSEA = 5.0D0 |
| 1204 | GOTO 10 |
| 1205 | |
| 1206 | ********************************************************************* |
| 1207 | * * |
| 1208 | * control card: codewd = SEASU3 * |
| 1209 | * * |
| 1210 | * Treatment of strange-quarks at chain ends * |
| 1211 | * * |
| 1212 | * what (1) (SEASQ) strange-quark supression factor * |
| 1213 | * iflav = 1.+rndm*(2.+SEASQ) * |
| 1214 | * default: 1. * |
| 1215 | * what (2..6), sdum no meaning * |
| 1216 | * * |
| 1217 | ********************************************************************* |
| 1218 | |
| 1219 | 350 CONTINUE |
| 1220 | SEASQ = WHAT(1) |
| 1221 | GOTO 10 |
| 1222 | |
| 1223 | ********************************************************************* |
| 1224 | * * |
| 1225 | * control card: codewd = DIQUARKS * |
| 1226 | * * |
| 1227 | * what (1) = -1. sea-diquark/antidiquark-pairs not treated * |
| 1228 | * default: 1. * |
| 1229 | * what (2..6), sdum no meaning * |
| 1230 | * * |
| 1231 | ********************************************************************* |
| 1232 | |
| 1233 | 360 CONTINUE |
| 1234 | IF (WHAT(1).EQ.-1.0D0) THEN |
| 1235 | LSEADI = .FALSE. |
| 1236 | ELSE |
| 1237 | LSEADI = .TRUE. |
| 1238 | ENDIF |
| 1239 | GOTO 10 |
| 1240 | |
| 1241 | ********************************************************************* |
| 1242 | * * |
| 1243 | * control card: codewd = RESONANC * |
| 1244 | * * |
| 1245 | * treatment of low mass chains * |
| 1246 | * * |
| 1247 | * what (1) = -1 low chain masses are not corrected for resonance * |
| 1248 | * masses (obsolete for BAMJET-fragmentation) * |
| 1249 | * default: 1. * |
| 1250 | * what (2) = -1 massless partons default: 1. (massive) * |
| 1251 | * default: 1. (massive) * |
| 1252 | * what (3) = -1 chain-system containing chain of too small * |
| 1253 | * mass is rejected (note: this does not fully * |
| 1254 | * apply to S-S chains) default: 0. * |
| 1255 | * what (4..6), sdum no meaning * |
| 1256 | * * |
| 1257 | ********************************************************************* |
| 1258 | |
| 1259 | 370 CONTINUE |
| 1260 | IRESCO = 1 |
| 1261 | IMSHL = 1 |
| 1262 | IRESRJ = 0 |
| 1263 | IF (WHAT(1).EQ.-ONE) IRESCO = 0 |
| 1264 | IF (WHAT(2).EQ.-ONE) IMSHL = 0 |
| 1265 | IF (WHAT(3).EQ.-ONE) IRESRJ = 1 |
| 1266 | GOTO 10 |
| 1267 | |
| 1268 | ********************************************************************* |
| 1269 | * * |
| 1270 | * control card: codewd = DIFFRACT * |
| 1271 | * * |
| 1272 | * Treatment of diffractive events * |
| 1273 | * * |
| 1274 | * what (1) = (ISINGD) 0 no single diffraction * |
| 1275 | * 1 single diffraction included * |
| 1276 | * +-2 single diffractive events only * |
| 1277 | * +-3 projectile single diffraction only * |
| 1278 | * +-4 target single diffraction only * |
| 1279 | * -5 double pomeron exchange only * |
| 1280 | * (neg. sign applies to PHOJET events) * |
| 1281 | * default: 0. * |
| 1282 | * * |
| 1283 | * what (2) = (IDOUBD) 0 no double diffraction * |
| 1284 | * 1 double diffraction included * |
| 1285 | * 2 double diffractive events only * |
| 1286 | * default: 0. * |
| 1287 | * what (3) = 1 projectile diffraction treated (2-channel form.) * |
| 1288 | * default: 0. * |
| 1289 | * what (4) = alpha-parameter in projectile diffraction * |
| 1290 | * default: 0. * |
| 1291 | * what (5..6), sdum no meaning * |
| 1292 | * * |
| 1293 | ********************************************************************* |
| 1294 | |
| 1295 | 380 CONTINUE |
| 1296 | IF (ABS(WHAT(1)).GT.ZERO) ISINGD = INT(WHAT(1)) |
| 1297 | IF (ABS(WHAT(2)).GT.ZERO) IDOUBD = INT(WHAT(2)) |
| 1298 | IF ((ISINGD.GT.1).AND.(IDOUBD.GT.1)) THEN |
| 1299 | WRITE(LOUT,1380) |
| 1300 | 1380 FORMAT(1X,'INIT: inconsistent DIFFRACT - input !',/, |
| 1301 | & 11X,'IDOUBD is reset to zero') |
| 1302 | IDOUBD = 0 |
| 1303 | ENDIF |
| 1304 | IF (WHAT(3).GT.ZERO) DIBETA = WHAT(3) |
| 1305 | IF (WHAT(4).GT.ZERO) DIALPH = WHAT(4) |
| 1306 | GOTO 10 |
| 1307 | |
| 1308 | ********************************************************************* |
| 1309 | * * |
| 1310 | * control card: codewd = SINGLECH * |
| 1311 | * * |
| 1312 | * what (1) = 1. Regge contribution (one chain) included * |
| 1313 | * default: 0. * |
| 1314 | * what (2..6), sdum no meaning * |
| 1315 | * * |
| 1316 | ********************************************************************* |
| 1317 | |
| 1318 | 390 CONTINUE |
| 1319 | ISICHA = 0 |
| 1320 | IF (WHAT(1).EQ.ONE) ISICHA = 1 |
| 1321 | GOTO 10 |
| 1322 | |
| 1323 | ********************************************************************* |
| 1324 | * * |
| 1325 | * control card: codewd = NOFRAGME * |
| 1326 | * * |
| 1327 | * biased chain hadronization * |
| 1328 | * * |
| 1329 | * what (1..6) = -1 no of hadronizsation of S-S chains * |
| 1330 | * = -2 no of hadronizsation of D-S chains * |
| 1331 | * = -3 no of hadronizsation of S-D chains * |
| 1332 | * = -4 no of hadronizsation of S-V chains * |
| 1333 | * = -5 no of hadronizsation of D-V chains * |
| 1334 | * = -6 no of hadronizsation of V-S chains * |
| 1335 | * = -7 no of hadronizsation of V-D chains * |
| 1336 | * = -8 no of hadronizsation of V-V chains * |
| 1337 | * = -9 no of hadronizsation of comb. chains * |
| 1338 | * default: complete hadronization * |
| 1339 | * sdum no meaning * |
| 1340 | * * |
| 1341 | ********************************************************************* |
| 1342 | |
| 1343 | 400 CONTINUE |
| 1344 | DO 401 I=1,6 |
| 1345 | ICHAIN = INT(WHAT(I)) |
| 1346 | IF ((ICHAIN.LE.-1).AND.(ICHAIN.GE.-9)) |
| 1347 | & LHADRO(ABS(ICHAIN)) = .FALSE. |
| 1348 | 401 CONTINUE |
| 1349 | GOTO 10 |
| 1350 | |
| 1351 | ********************************************************************* |
| 1352 | * * |
| 1353 | * control card: codewd = HADRONIZE * |
| 1354 | * * |
| 1355 | * hadronization model and parameter switch * |
| 1356 | * * |
| 1357 | * what (1) = 1 hadronization via BAMJET * |
| 1358 | * = 2 hadronization via JETSET * |
| 1359 | * default: 2 * |
| 1360 | * what (2) = 1..3 parameter set to be used * |
| 1361 | * JETSET: 3 sets available * |
| 1362 | * ( = 3 default JETSET-parameters) * |
| 1363 | * BAMJET: 1 set available * |
| 1364 | * default: 1 * |
| 1365 | * what (3..6), sdum no meaning * |
| 1366 | * * |
| 1367 | ********************************************************************* |
| 1368 | |
| 1369 | 410 CONTINUE |
| 1370 | IWHAT1 = INT(WHAT(1)) |
| 1371 | IWHAT2 = INT(WHAT(2)) |
| 1372 | IF ((IWHAT1.EQ.1).OR.(IWHAT1.EQ.2)) IFRAG(1) = IWHAT1 |
| 1373 | IF ((IWHAT1.EQ.2).AND.(IWHAT2.GE.1).AND.(IWHAT2.LE.3)) |
| 1374 | & IFRAG(2) = IWHAT2 |
| 1375 | GOTO 10 |
| 1376 | |
| 1377 | ********************************************************************* |
| 1378 | * * |
| 1379 | * control card: codewd = POPCORN * |
| 1380 | * * |
| 1381 | * "Popcorn-effect" in fragmentation and diquark breaking diagrams * |
| 1382 | * * |
| 1383 | * what (1) = (PDB) frac. of diquark fragmenting directly into * |
| 1384 | * baryons (PYTHIA/JETSET fragmentation) * |
| 1385 | * (JETSET: = 0. Popcorn mechanism switched off) * |
| 1386 | * default: 0.5 * |
| 1387 | * what (2) = probability for accepting a diquark breaking * |
| 1388 | * diagram involving the generation of a u/d quark- * |
| 1389 | * antiquark pair default: 0.0 * |
| 1390 | * what (3) = same a what (2), here for s quark-antiquark pair * |
| 1391 | * default: 0.0 * |
| 1392 | * what (4..6), sdum no meaning * |
| 1393 | * * |
| 1394 | ********************************************************************* |
| 1395 | |
| 1396 | 420 CONTINUE |
| 1397 | IF (WHAT(1).GE.0.0D0) PDB = WHAT(1) |
| 1398 | IF (WHAT(2).GE.0.0D0) THEN |
| 1399 | PDBSEA(1) = WHAT(2) |
| 1400 | PDBSEA(2) = WHAT(2) |
| 1401 | ENDIF |
| 1402 | IF (WHAT(3).GE.0.0D0) PDBSEA(3) = WHAT(3) |
| 1403 | DO 421 I=1,8 |
| 1404 | DBRKA(1,I) = DBRKR(1,I)*PDBSEA(1)/(1.D0-PDBSEA(1)) |
| 1405 | DBRKA(2,I) = DBRKR(2,I)*PDBSEA(2)/(1.D0-PDBSEA(2)) |
| 1406 | DBRKA(3,I) = DBRKR(3,I)*PDBSEA(3)/(1.D0-PDBSEA(3)) |
| 1407 | 421 CONTINUE |
| 1408 | GOTO 10 |
| 1409 | |
| 1410 | ********************************************************************* |
| 1411 | * * |
| 1412 | * control card: codewd = PARDECAY * |
| 1413 | * * |
| 1414 | * what (1) = 1. Sigma0/Asigma0 are decaying within JETSET * |
| 1415 | * = 2. pion^0 decay after intranucl. cascade * |
| 1416 | * default: no decay * |
| 1417 | * what (2..6), sdum no meaning * |
| 1418 | * * |
| 1419 | ********************************************************************* |
| 1420 | |
| 1421 | 430 CONTINUE |
| 1422 | IF (WHAT(1).EQ.ONE) ISIG0 = 1 |
| 1423 | IF (WHAT(1).EQ.2.0D0) IPI0 = 1 |
| 1424 | GOTO 10 |
| 1425 | |
| 1426 | ********************************************************************* |
| 1427 | * * |
| 1428 | * control card: codewd = BEAM * |
| 1429 | * * |
| 1430 | * definition of beam parameters * |
| 1431 | * * |
| 1432 | * what (1/2) > 0 : energy of beam 1/2 (GeV) * |
| 1433 | * < 0 : abs(what(1/2)) energy per charge of * |
| 1434 | * beam 1/2 (GeV) * |
| 1435 | * (beam 1 is directed into positive z-direction) * |
| 1436 | * what (3) beam crossing angle, defined as 2x angle between * |
| 1437 | * one beam and the z-axis (micro rad) * |
| 1438 | * what (4) angle with x-axis defining the collision plane * |
| 1439 | * what (5..6), sdum no meaning * |
| 1440 | * * |
| 1441 | * Note: this card requires previously defined projectile and * |
| 1442 | * target identities (PROJPAR, TARPAR) * |
| 1443 | * * |
| 1444 | ********************************************************************* |
| 1445 | |
| 1446 | 440 CONTINUE |
| 1447 | CALL DT_BEAMPR(WHAT,PPN,1) |
| 1448 | EPN = ZERO |
| 1449 | CMENER = ZERO |
| 1450 | LEINP = .TRUE. |
| 1451 | GOTO 10 |
| 1452 | |
| 1453 | ********************************************************************* |
| 1454 | * * |
| 1455 | * control card: codewd = LUND-MSTU * |
| 1456 | * * |
| 1457 | * set parameter MSTU in JETSET-common /LUDAT1/ * |
| 1458 | * * |
| 1459 | * what (1) = index according to LUND-common block * |
| 1460 | * what (2) = new value of MSTU( int(what(1)) ) * |
| 1461 | * what (3), what(4) and what (5), what(6) further * |
| 1462 | * parameter in the same way as what (1) and * |
| 1463 | * what (2) * |
| 1464 | * default: default-Lund or corresponding to * |
| 1465 | * the set given in HADRONIZE * |
| 1466 | * * |
| 1467 | ********************************************************************* |
| 1468 | |
| 1469 | 450 CONTINUE |
| 1470 | IF (WHAT(1).GT.ZERO) THEN |
| 1471 | NMSTU = NMSTU+1 |
| 1472 | IMSTU(NMSTU) = INT(WHAT(1)) |
| 1473 | MSTUX(NMSTU) = INT(WHAT(2)) |
| 1474 | ENDIF |
| 1475 | IF (WHAT(3).GT.ZERO) THEN |
| 1476 | NMSTU = NMSTU+1 |
| 1477 | IMSTU(NMSTU) = INT(WHAT(3)) |
| 1478 | MSTUX(NMSTU) = INT(WHAT(4)) |
| 1479 | ENDIF |
| 1480 | IF (WHAT(5).GT.ZERO) THEN |
| 1481 | NMSTU = NMSTU+1 |
| 1482 | IMSTU(NMSTU) = INT(WHAT(5)) |
| 1483 | MSTUX(NMSTU) = INT(WHAT(6)) |
| 1484 | ENDIF |
| 1485 | GOTO 10 |
| 1486 | |
| 1487 | ********************************************************************* |
| 1488 | * * |
| 1489 | * control card: codewd = LUND-MSTJ * |
| 1490 | * * |
| 1491 | * set parameter MSTJ in JETSET-common /LUDAT1/ * |
| 1492 | * * |
| 1493 | * what (1) = index according to LUND-common block * |
| 1494 | * what (2) = new value of MSTJ( int(what(1)) ) * |
| 1495 | * what (3), what(4) and what (5), what(6) further * |
| 1496 | * parameter in the same way as what (1) and * |
| 1497 | * what (2) * |
| 1498 | * default: default-Lund or corresponding to * |
| 1499 | * the set given in HADRONIZE * |
| 1500 | * * |
| 1501 | ********************************************************************* |
| 1502 | |
| 1503 | 451 CONTINUE |
| 1504 | IF (WHAT(1).GT.ZERO) THEN |
| 1505 | NMSTJ = NMSTJ+1 |
| 1506 | IMSTJ(NMSTJ) = INT(WHAT(1)) |
| 1507 | MSTJX(NMSTJ) = INT(WHAT(2)) |
| 1508 | ENDIF |
| 1509 | IF (WHAT(3).GT.ZERO) THEN |
| 1510 | NMSTJ = NMSTJ+1 |
| 1511 | IMSTJ(NMSTJ) = INT(WHAT(3)) |
| 1512 | MSTJX(NMSTJ) = INT(WHAT(4)) |
| 1513 | ENDIF |
| 1514 | IF (WHAT(5).GT.ZERO) THEN |
| 1515 | NMSTJ = NMSTJ+1 |
| 1516 | IMSTJ(NMSTJ) = INT(WHAT(5)) |
| 1517 | MSTJX(NMSTJ) = INT(WHAT(6)) |
| 1518 | ENDIF |
| 1519 | GOTO 10 |
| 1520 | |
| 1521 | ********************************************************************* |
| 1522 | * * |
| 1523 | * control card: codewd = LUND-MDCY * |
| 1524 | * * |
| 1525 | * set parameter MDCY(I,1) for particle decays in JETSET-common * |
| 1526 | * /LUDAT3/ * |
| 1527 | * * |
| 1528 | * what (1-6) = PDG particle index of particle which should * |
| 1529 | * not decay * |
| 1530 | * default: default-Lund or forced in * |
| 1531 | * DT_INITJS * |
| 1532 | * * |
| 1533 | ********************************************************************* |
| 1534 | |
| 1535 | 452 CONTINUE |
| 1536 | DO 4521 I=1,6 |
| 1537 | IF (WHAT(I).NE.ZERO) THEN |
| 1538 | |
| 1539 | KC = PYCOMP(INT(WHAT(I))) |
| 1540 | |
| 1541 | MDCY(KC,1) = 0 |
| 1542 | ENDIF |
| 1543 | 4521 CONTINUE |
| 1544 | GOTO 10 |
| 1545 | |
| 1546 | ********************************************************************* |
| 1547 | * * |
| 1548 | * control card: codewd = LUND-PARJ * |
| 1549 | * * |
| 1550 | * set parameter PARJ in JETSET-common /LUDAT1/ * |
| 1551 | * * |
| 1552 | * what (1) = index according to LUND-common block * |
| 1553 | * what (2) = new value of PARJ( int(what(1)) ) * |
| 1554 | * what (3), what(4) and what (5), what(6) further * |
| 1555 | * parameter in the same way as what (1) and * |
| 1556 | * what (2) * |
| 1557 | * default: default-Lund or corresponding to * |
| 1558 | * the set given in HADRONIZE * |
| 1559 | * * |
| 1560 | ********************************************************************* |
| 1561 | |
| 1562 | 460 CONTINUE |
| 1563 | IF (WHAT(1).NE.ZERO) THEN |
| 1564 | NPARJ = NPARJ+1 |
| 1565 | IPARJ(NPARJ) = INT(WHAT(1)) |
| 1566 | PARJX(NPARJ) = WHAT(2) |
| 1567 | ENDIF |
| 1568 | IF (WHAT(3).NE.ZERO) THEN |
| 1569 | NPARJ = NPARJ+1 |
| 1570 | IPARJ(NPARJ) = INT(WHAT(3)) |
| 1571 | PARJX(NPARJ) = WHAT(4) |
| 1572 | ENDIF |
| 1573 | IF (WHAT(5).NE.ZERO) THEN |
| 1574 | NPARJ = NPARJ+1 |
| 1575 | IPARJ(NPARJ) = INT(WHAT(5)) |
| 1576 | PARJX(NPARJ) = WHAT(6) |
| 1577 | ENDIF |
| 1578 | GOTO 10 |
| 1579 | |
| 1580 | ********************************************************************* |
| 1581 | * * |
| 1582 | * control card: codewd = LUND-PARU * |
| 1583 | * * |
| 1584 | * set parameter PARJ in JETSET-common /LUDAT1/ * |
| 1585 | * * |
| 1586 | * what (1) = index according to LUND-common block * |
| 1587 | * what (2) = new value of PARU( int(what(1)) ) * |
| 1588 | * what (3), what(4) and what (5), what(6) further * |
| 1589 | * parameter in the same way as what (1) and * |
| 1590 | * what (2) * |
| 1591 | * default: default-Lund or corresponding to * |
| 1592 | * the set given in HADRONIZE * |
| 1593 | * * |
| 1594 | ********************************************************************* |
| 1595 | |
| 1596 | 470 CONTINUE |
| 1597 | IF (WHAT(1).GT.ZERO) THEN |
| 1598 | NPARU = NPARU+1 |
| 1599 | IPARU(NPARU) = INT(WHAT(1)) |
| 1600 | PARUX(NPARU) = WHAT(2) |
| 1601 | ENDIF |
| 1602 | IF (WHAT(3).GT.ZERO) THEN |
| 1603 | NPARU = NPARU+1 |
| 1604 | IPARU(NPARU) = INT(WHAT(3)) |
| 1605 | PARUX(NPARU) = WHAT(4) |
| 1606 | ENDIF |
| 1607 | IF (WHAT(5).GT.ZERO) THEN |
| 1608 | NPARU = NPARU+1 |
| 1609 | IPARU(NPARU) = INT(WHAT(5)) |
| 1610 | PARUX(NPARU) = WHAT(6) |
| 1611 | ENDIF |
| 1612 | GOTO 10 |
| 1613 | |
| 1614 | ********************************************************************* |
| 1615 | * * |
| 1616 | * control card: codewd = OUTLEVEL * |
| 1617 | * * |
| 1618 | * output control switches * |
| 1619 | * * |
| 1620 | * what (1) = internal rejection informations default: 0 * |
| 1621 | * what (2) = energy-momentum conservation check output * |
| 1622 | * default: 0 * |
| 1623 | * what (3) = internal warning messages default: 0 * |
| 1624 | * what (4..6), sdum not yet used * |
| 1625 | * * |
| 1626 | ********************************************************************* |
| 1627 | |
| 1628 | 480 CONTINUE |
| 1629 | DO 481 K=1,6 |
| 1630 | IOULEV(K) = INT(WHAT(K)) |
| 1631 | 481 CONTINUE |
| 1632 | GOTO 10 |
| 1633 | |
| 1634 | ********************************************************************* |
| 1635 | * * |
| 1636 | * control card: codewd = FRAME * |
| 1637 | * * |
| 1638 | * frame in which final state is given in DTEVT1 * |
| 1639 | * * |
| 1640 | * what (1) = 1 target rest frame (laboratory) * |
| 1641 | * = 2 nucleon-nucleon cms * |
| 1642 | * default: 1 * |
| 1643 | * * |
| 1644 | ********************************************************************* |
| 1645 | |
| 1646 | 490 CONTINUE |
| 1647 | KFRAME = INT(WHAT(1)) |
| 1648 | IF ((KFRAME.GE.1).AND.(KFRAME.LE.2)) IFRAME = KFRAME |
| 1649 | GOTO 10 |
| 1650 | |
| 1651 | ********************************************************************* |
| 1652 | * * |
| 1653 | * control card: codewd = L-TAG * |
| 1654 | * * |
| 1655 | * lepton tagger: * |
| 1656 | * definition of kinematical cuts for radiated photon and * |
| 1657 | * outgoing lepton detection in lepton-nucleus interactions * |
| 1658 | * * |
| 1659 | * what (1) = y_min * |
| 1660 | * what (2) = y_max * |
| 1661 | * what (3) = Q^2_min * |
| 1662 | * what (4) = Q^2_max * |
| 1663 | * what (5) = theta_min (Lab) * |
| 1664 | * what (6) = theta_max (Lab) * |
| 1665 | * default: no cuts * |
| 1666 | * sdum no meaning * |
| 1667 | * * |
| 1668 | ********************************************************************* |
| 1669 | |
| 1670 | 500 CONTINUE |
| 1671 | YMIN = WHAT(1) |
| 1672 | YMAX = WHAT(2) |
| 1673 | Q2MIN = WHAT(3) |
| 1674 | Q2MAX = WHAT(4) |
| 1675 | THMIN = WHAT(5) |
| 1676 | THMAX = WHAT(6) |
| 1677 | GOTO 10 |
| 1678 | |
| 1679 | ********************************************************************* |
| 1680 | * * |
| 1681 | * control card: codewd = L-ETAG * |
| 1682 | * * |
| 1683 | * lepton tagger: * |
| 1684 | * what (1) = min. outgoing lepton energy (in Lab) * |
| 1685 | * what (2) = min. photon energy (in Lab) * |
| 1686 | * what (3) = max. photon energy (in Lab) * |
| 1687 | * default: no cuts * |
| 1688 | * what (2..6), sdum no meaning * |
| 1689 | * * |
| 1690 | ********************************************************************* |
| 1691 | |
| 1692 | 510 CONTINUE |
| 1693 | ELMIN = MAX(WHAT(1),ZERO) |
| 1694 | EGMIN = MAX(WHAT(2),ZERO) |
| 1695 | EGMAX = MAX(WHAT(3),ZERO) |
| 1696 | GOTO 10 |
| 1697 | |
| 1698 | ********************************************************************* |
| 1699 | * * |
| 1700 | * control card: codewd = ECMS-CUT * |
| 1701 | * * |
| 1702 | * what (1) = min. c.m. energy to be sampled * |
| 1703 | * what (2) = max. c.m. energy to be sampled * |
| 1704 | * what (3) = min x_Bj to be sampled * |
| 1705 | * default: no cuts * |
| 1706 | * what (3..6), sdum no meaning * |
| 1707 | * * |
| 1708 | ********************************************************************* |
| 1709 | |
| 1710 | 520 CONTINUE |
| 1711 | ECMIN = WHAT(1) |
| 1712 | ECMAX = WHAT(2) |
| 1713 | IF (ECMIN.GT.ECMAX) ECMIN = ECMAX |
| 1714 | XBJMIN = MAX(WHAT(3),ZERO) |
| 1715 | GOTO 10 |
| 1716 | |
| 1717 | ********************************************************************* |
| 1718 | * * |
| 1719 | * control card: codewd = VDM-PAR1 * |
| 1720 | * * |
| 1721 | * parameters in gamma-nucleus cross section calculation * |
| 1722 | * * |
| 1723 | * what (1) = Lambda^2 default: 2. * |
| 1724 | * what (2) lower limit in M^2 integration * |
| 1725 | * = 1 (3m_pi)^2 * |
| 1726 | * = 2 (m_rho0)^2 * |
| 1727 | * = 3 (m_phi)^2 default: 1 * |
| 1728 | * what (3) upper limit in M^2 integration * |
| 1729 | * = 1 s/2 * |
| 1730 | * = 2 s/4 * |
| 1731 | * = 3 s default: 3 * |
| 1732 | * what (4) CKMT F_2 structure function * |
| 1733 | * = 2212 proton * |
| 1734 | * = 100 deuteron default: 2212 * |
| 1735 | * what (5) calculation of gamma-nucleon xsections * |
| 1736 | * = 1 according to CKMT-parametrization of F_2 * |
| 1737 | * = 2 integrating SIGVP over M^2 * |
| 1738 | * = 3 using SIGGA * |
| 1739 | * = 4 PHOJET cross sections default: 4 * |
| 1740 | * * |
| 1741 | * what (6), sdum no meaning * |
| 1742 | * * |
| 1743 | ********************************************************************* |
| 1744 | |
| 1745 | 530 CONTINUE |
| 1746 | IF (WHAT(1).GE.ZERO) RL2 = WHAT(1) |
| 1747 | IF ((WHAT(2).GE.1).AND.(WHAT(2).LE.3)) INTRGE(1) = INT(WHAT(2)) |
| 1748 | IF ((WHAT(3).GE.1).AND.(WHAT(3).LE.3)) INTRGE(2) = INT(WHAT(3)) |
| 1749 | IF ((WHAT(4).EQ.2212).OR.(WHAT(4).EQ.100)) IDPDF = INT(WHAT(4)) |
| 1750 | IF ((WHAT(5).GE.1).AND.(WHAT(5).LE.4)) MODEGA = INT(WHAT(5)) |
| 1751 | GOTO 10 |
| 1752 | |
| 1753 | ********************************************************************* |
| 1754 | * * |
| 1755 | * control card: codewd = HISTOGRAM * |
| 1756 | * * |
| 1757 | * activate different classes of histograms * |
| 1758 | * * |
| 1759 | * default: no histograms * |
| 1760 | * * |
| 1761 | ********************************************************************* |
| 1762 | |
| 1763 | 540 CONTINUE |
| 1764 | DO 541 J=1,6 |
| 1765 | IF ((WHAT(J).GE.100).AND.(WHAT(J).LE.150)) THEN |
| 1766 | IHISPP(INT(WHAT(J))-100) = 1 |
| 1767 | ELSEIF ((ABS(WHAT(J)).GE.200).AND.(ABS(WHAT(J)).LE.250)) THEN |
| 1768 | IHISXS(INT(ABS(WHAT(J)))-200) = 1 |
| 1769 | IF (WHAT(J).LT.ZERO) IXSTBL = 1 |
| 1770 | ENDIF |
| 1771 | 541 CONTINUE |
| 1772 | GOTO 10 |
| 1773 | |
| 1774 | ********************************************************************* |
| 1775 | * * |
| 1776 | * control card: codewd = XS-TABLE * |
| 1777 | * * |
| 1778 | * output of cross section table for requested interaction * |
| 1779 | * - particle production deactivated ! - * |
| 1780 | * * |
| 1781 | * what (1) lower energy limit for tabulation * |
| 1782 | * > 0 Lab. frame * |
| 1783 | * < 0 nucleon-nucleon cms * |
| 1784 | * what (2) upper energy limit for tabulation * |
| 1785 | * > 0 Lab. frame * |
| 1786 | * < 0 nucleon-nucleon cms * |
| 1787 | * what (3) > 0 # of equidistant lin. bins in E * |
| 1788 | * < 0 # of equidistant log. bins in E * |
| 1789 | * what (4) lower limit of particle virtuality (photons) * |
| 1790 | * what (5) upper limit of particle virtuality (photons) * |
| 1791 | * what (6) > 0 # of equidistant lin. bins in Q^2 * |
| 1792 | * < 0 # of equidistant log. bins in Q^2 * |
| 1793 | * * |
| 1794 | ********************************************************************* |
| 1795 | |
| 1796 | 550 CONTINUE |
| 1797 | IF (WHAT(1).EQ.99999.0D0) THEN |
| 1798 | IRATIO = INT(WHAT(2)) |
| 1799 | GOTO 10 |
| 1800 | ENDIF |
| 1801 | CMENER = ABS(WHAT(2)) |
| 1802 | IF (.NOT.LXSTAB) THEN |
| 1803 | |
| 1804 | CALL BERTTP |
| 1805 | CALL INCINI |
| 1806 | |
| 1807 | ENDIF |
| 1808 | IF ((.NOT.LXSTAB).OR.(CMENER.NE.CMEOLD)) THEN |
| 1809 | CMEOLD = CMENER |
| 1810 | IF (WHAT(2).GT.ZERO) |
| 1811 | & CMENER = SQRT(2.0D0*AAM(1)**2+2.0D0*WHAT(2)*AAM(1)) |
| 1812 | EPN = ZERO |
| 1813 | PPN = ZERO |
| 1814 | C WRITE(LOUT,*) 'CMENER = ',CMENER |
| 1815 | CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,CMENER,1) |
| 1816 | CALL DT_PHOINI |
| 1817 | ENDIF |
| 1818 | CALL DT_XSTABL(WHAT,IXSQEL,IRATIO) |
| 1819 | IXSQEL = 0 |
| 1820 | LXSTAB = .TRUE. |
| 1821 | GOTO 10 |
| 1822 | |
| 1823 | ********************************************************************* |
| 1824 | * * |
| 1825 | * control card: codewd = GLAUB-PAR * |
| 1826 | * * |
| 1827 | * parameters in Glauber-formalism * |
| 1828 | * * |
| 1829 | * what (1) # of nucleon configurations sampled in integration * |
| 1830 | * over nuclear desity default: 1000 * |
| 1831 | * what (2) # of bins for integration over impact-parameter and * |
| 1832 | * for profile-function calculation default: 49 * |
| 1833 | * what (3) = 1 calculation of tot., el. and qel. cross sections * |
| 1834 | * default: 0 * |
| 1835 | * what (4) = 1 read pre-calculated impact-parameter distrib. * |
| 1836 | * from "sdum".glb * |
| 1837 | * =-1 dump pre-calculated impact-parameter distrib. * |
| 1838 | * into "sdum".glb * |
| 1839 | * = 100 read pre-calculated impact-parameter distrib. * |
| 1840 | * for variable projectile/target/energy runs * |
| 1841 | * from "sdum".glb * |
| 1842 | * default: 0 * |
| 1843 | * what (5..6) no meaning * |
| 1844 | * sdum if |what (4)| = 1 name of in/output-file (sdum.glb) * |
| 1845 | * * |
| 1846 | ********************************************************************* |
| 1847 | |
| 1848 | 560 CONTINUE |
| 1849 | IF (WHAT(1).GT.ZERO) JSTATB = INT(WHAT(1)) |
| 1850 | IF (WHAT(2).GT.ZERO) JBINSB = INT(WHAT(2)) |
| 1851 | IF (WHAT(3).EQ.ONE) LPROD = .FALSE. |
| 1852 | IF ((ABS(WHAT(4)).EQ.ONE).OR.(WHAT(4).EQ.100)) THEN |
| 1853 | IOGLB = INT(WHAT(4)) |
| 1854 | CGLB = SDUM |
| 1855 | ENDIF |
| 1856 | GOTO 10 |
| 1857 | |
| 1858 | ********************************************************************* |
| 1859 | * * |
| 1860 | * control card: codewd = GLAUB-INI * |
| 1861 | * * |
| 1862 | * pre-initialization of profile function * |
| 1863 | * * |
| 1864 | * what (1) lower energy limit for initialization * |
| 1865 | * > 0 Lab. frame * |
| 1866 | * < 0 nucleon-nucleon cms * |
| 1867 | * what (2) upper energy limit for initialization * |
| 1868 | * > 0 Lab. frame * |
| 1869 | * < 0 nucleon-nucleon cms * |
| 1870 | * what (3) > 0 # of equidistant lin. bins in E * |
| 1871 | * < 0 # of equidistant log. bins in E * |
| 1872 | * what (4) maximum projectile mass number for which the * |
| 1873 | * Glauber data are initialized for each * |
| 1874 | * projectile mass number * |
| 1875 | * (if <= mass given with the PROJPAR-card) * |
| 1876 | * default: 18 * |
| 1877 | * what (5) steps in mass number starting from what (4) * |
| 1878 | * up to mass number defined with PROJPAR-card * |
| 1879 | * for which Glauber data are initialized * |
| 1880 | * default: 5 * |
| 1881 | * what (6) no meaning * |
| 1882 | * sdum no meaning * |
| 1883 | * * |
| 1884 | ********************************************************************* |
| 1885 | |
| 1886 | 565 CONTINUE |
| 1887 | IOGLB = -100 |
| 1888 | CALL DT_GLBINI(WHAT) |
| 1889 | GOTO 10 |
| 1890 | |
| 1891 | ********************************************************************* |
| 1892 | * * |
| 1893 | * control card: codewd = VDM-PAR2 * |
| 1894 | * * |
| 1895 | * parameters in gamma-nucleus cross section calculation * |
| 1896 | * * |
| 1897 | * what (1) = 0 no suppression of shadowing by direct photon * |
| 1898 | * processes * |
| 1899 | * = 1 suppression .. default: 1 * |
| 1900 | * what (2) = 0 no suppression of shadowing by anomalous * |
| 1901 | * component if photon-F_2 * |
| 1902 | * = 1 suppression .. default: 1 * |
| 1903 | * what (3) = 0 no suppression of shadowing by coherence * |
| 1904 | * length of the photon * |
| 1905 | * = 1 suppression .. default: 1 * |
| 1906 | * what (4) = 1 longitudinal polarized photons are taken into * |
| 1907 | * account * |
| 1908 | * eps*R*Q^2/M^2 = what(4)*Q^2/M^2 default: 0 * |
| 1909 | * what (5..6), sdum no meaning * |
| 1910 | * * |
| 1911 | ********************************************************************* |
| 1912 | |
| 1913 | 570 CONTINUE |
| 1914 | IF ((WHAT(1).EQ.ZERO).OR.(WHAT(1).EQ.ONE)) ISHAD(1) = INT(WHAT(1)) |
| 1915 | IF ((WHAT(2).EQ.ZERO).OR.(WHAT(2).EQ.ONE)) ISHAD(2) = INT(WHAT(2)) |
| 1916 | IF ((WHAT(3).EQ.ZERO).OR.(WHAT(3).EQ.ONE)) ISHAD(3) = INT(WHAT(3)) |
| 1917 | EPSPOL = WHAT(4) |
| 1918 | GOTO 10 |
| 1919 | |
| 1920 | ********************************************************************* |
| 1921 | * * |
| 1922 | * control card: XS-QELPRO * |
| 1923 | * * |
| 1924 | * what (1..6), sdum no meaning * |
| 1925 | * * |
| 1926 | ********************************************************************* |
| 1927 | |
| 1928 | 580 CONTINUE |
| 1929 | IXSQEL = ABS(WHAT(1)) |
| 1930 | GOTO 10 |
| 1931 | |
| 1932 | ********************************************************************* |
| 1933 | * * |
| 1934 | * control card: RNDMINIT * |
| 1935 | * * |
| 1936 | * initialization of random number generator * |
| 1937 | * * |
| 1938 | * what (1..4) values for initialization (= 1..168) * |
| 1939 | * what (5..6), sdum no meaning * |
| 1940 | * * |
| 1941 | ********************************************************************* |
| 1942 | |
| 1943 | 590 CONTINUE |
| 1944 | IF ((WHAT(1).LT.1.0D0).OR.(WHAT(1).GT.168.0D0)) THEN |
| 1945 | NA1 = 22 |
| 1946 | ELSE |
| 1947 | NA1 = WHAT(1) |
| 1948 | ENDIF |
| 1949 | IF ((WHAT(2).LT.1.0D0).OR.(WHAT(2).GT.168.0D0)) THEN |
| 1950 | NA2 = 54 |
| 1951 | ELSE |
| 1952 | NA2 = WHAT(2) |
| 1953 | ENDIF |
| 1954 | IF ((WHAT(3).LT.1.0D0).OR.(WHAT(3).GT.168.0D0)) THEN |
| 1955 | NA3 = 76 |
| 1956 | ELSE |
| 1957 | NA3 = WHAT(3) |
| 1958 | ENDIF |
| 1959 | IF ((WHAT(4).LT.1.0D0).OR.(WHAT(4).GT.168.0D0)) THEN |
| 1960 | NA4 = 92 |
| 1961 | ELSE |
| 1962 | NA4 = WHAT(4) |
| 1963 | ENDIF |
| 1964 | CALL DT_RNDMST(NA1,NA2,NA3,NA4) |
| 1965 | GOTO 10 |
| 1966 | |
| 1967 | ********************************************************************* |
| 1968 | * * |
| 1969 | * control card: codewd = LEPTO-CUT * |
| 1970 | * * |
| 1971 | * set parameter CUT in LEPTO-common /LEPTOU/ * |
| 1972 | * * |
| 1973 | * what (1) = index in CUT-array * |
| 1974 | * what (2) = new value of CUT( int(what(1)) ) * |
| 1975 | * what (3), what(4) and what (5), what(6) further * |
| 1976 | * parameter in the same way as what (1) and * |
| 1977 | * what (2) * |
| 1978 | * default: default-LEPTO parameters * |
| 1979 | * * |
| 1980 | ********************************************************************* |
| 1981 | |
| 1982 | 600 CONTINUE |
| 1983 | IF (WHAT(1).GT.ZERO) CUT(INT(WHAT(1))) = WHAT(2) |
| 1984 | IF (WHAT(3).GT.ZERO) CUT(INT(WHAT(3))) = WHAT(4) |
| 1985 | IF (WHAT(5).GT.ZERO) CUT(INT(WHAT(5))) = WHAT(6) |
| 1986 | GOTO 10 |
| 1987 | |
| 1988 | ********************************************************************* |
| 1989 | * * |
| 1990 | * control card: codewd = LEPTO-LST * |
| 1991 | * * |
| 1992 | * set parameter LST in LEPTO-common /LEPTOU/ * |
| 1993 | * * |
| 1994 | * what (1) = index in LST-array * |
| 1995 | * what (2) = new value of LST( int(what(1)) ) * |
| 1996 | * what (3), what(4) and what (5), what(6) further * |
| 1997 | * parameter in the same way as what (1) and * |
| 1998 | * what (2) * |
| 1999 | * default: default-LEPTO parameters * |
| 2000 | * * |
| 2001 | ********************************************************************* |
| 2002 | |
| 2003 | 610 CONTINUE |
| 2004 | IF (WHAT(1).GT.ZERO) LST(INT(WHAT(1))) = INT(WHAT(2)) |
| 2005 | IF (WHAT(3).GT.ZERO) LST(INT(WHAT(3))) = INT(WHAT(4)) |
| 2006 | IF (WHAT(5).GT.ZERO) LST(INT(WHAT(5))) = INT(WHAT(6)) |
| 2007 | GOTO 10 |
| 2008 | |
| 2009 | ********************************************************************* |
| 2010 | * * |
| 2011 | * control card: codewd = LEPTO-PARL * |
| 2012 | * * |
| 2013 | * set parameter PARL in LEPTO-common /LEPTOU/ * |
| 2014 | * * |
| 2015 | * what (1) = index in PARL-array * |
| 2016 | * what (2) = new value of PARL( int(what(1)) ) * |
| 2017 | * what (3), what(4) and what (5), what(6) further * |
| 2018 | * parameter in the same way as what (1) and * |
| 2019 | * what (2) * |
| 2020 | * default: default-LEPTO parameters * |
| 2021 | * * |
| 2022 | ********************************************************************* |
| 2023 | |
| 2024 | 620 CONTINUE |
| 2025 | IF (WHAT(1).GT.ZERO) PARL(INT(WHAT(1))) = WHAT(2) |
| 2026 | IF (WHAT(3).GT.ZERO) PARL(INT(WHAT(3))) = WHAT(4) |
| 2027 | IF (WHAT(5).GT.ZERO) PARL(INT(WHAT(5))) = WHAT(6) |
| 2028 | GOTO 10 |
| 2029 | |
| 2030 | ********************************************************************* |
| 2031 | * * |
| 2032 | * control card: codewd = START * |
| 2033 | * * |
| 2034 | * what (1) = number of events default: 100. * |
| 2035 | * what (2) = 0 Glauber initialization follows * |
| 2036 | * = 1 Glauber initialization supressed, fitted * |
| 2037 | * results are used instead * |
| 2038 | * (this does not apply if emulsion-treatment * |
| 2039 | * is requested) * |
| 2040 | * = 2 Glauber initialization is written to * |
| 2041 | * output-file shmakov.out * |
| 2042 | * = 3 Glauber initialization is read from input-file * |
| 2043 | * shmakov.out default: 0 * |
| 2044 | * what (3..6) no meaning * |
| 2045 | * what (3..6) no meaning * |
| 2046 | * * |
| 2047 | ********************************************************************* |
| 2048 | |
| 2049 | 630 CONTINUE |
| 2050 | |
| 2051 | * check for cross-section table output only |
| 2052 | IF (LXSTAB) STOP |
| 2053 | |
| 2054 | NCASES = INT(WHAT(1)) |
| 2055 | IF (NCASES.LE.0) NCASES = 100 |
| 2056 | IGLAU = INT(WHAT(2)) |
| 2057 | IF ((IGLAU.NE.1).AND.(IGLAU.NE.2).AND.(IGLAU.NE.3)) |
| 2058 | & IGLAU = 0 |
| 2059 | |
| 2060 | NPMASS = IP |
| 2061 | NPCHAR = IPZ |
| 2062 | NTMASS = IT |
| 2063 | NTCHAR = ITZ |
| 2064 | IDP = IJPROJ |
| 2065 | IDT = IJTARG |
| 2066 | IF (IDP.LE.0) IDP = 1 |
| 2067 | * muon neutrinos: temporary (missing index) |
| 2068 | * (new patch in projpar: therefore the following this is probably not |
| 2069 | * necessary anymore..) |
| 2070 | C IF (IDP.EQ.26) IDP = 5 |
| 2071 | C IF (IDP.EQ.27) IDP = 6 |
| 2072 | |
| 2073 | * redefine collision energy |
| 2074 | IF (LEINP) THEN |
| 2075 | IF (ABS(VAREHI).GT.ZERO) THEN |
| 2076 | PDUM = ZERO |
| 2077 | IF (VARELO.LT.EHADLO) VARELO = EHADLO |
| 2078 | CALL DT_LTINI(IDP,IDT,VARELO,PDUM,VARCLO,1) |
| 2079 | PDUM = ZERO |
| 2080 | CALL DT_LTINI(IDP,IDT,VAREHI,PDUM,VARCHI,1) |
| 2081 | ENDIF |
| 2082 | CALL DT_LTINI(IDP,IDT,EPN,PPN,CMENER,1) |
| 2083 | ELSE |
| 2084 | WRITE(LOUT,1003) |
| 2085 | 1003 FORMAT(1X,'INIT: collision energy not defined!',/, |
| 2086 | & 1X,' -program stopped- ') |
| 2087 | STOP |
| 2088 | ENDIF |
| 2089 | |
| 2090 | * switch off evaporation (even if requested) if central coll. requ. |
| 2091 | IF ((ICENTR.EQ.-1).OR.(ICENTR.GT.0).OR.(XSFRAC.LT.0.5D0)) THEN |
| 2092 | IF (LEVPRT) THEN |
| 2093 | WRITE(LOUT,1004) |
| 2094 | 1004 FORMAT(1X,/,'Warning! Evaporation request rejected since', |
| 2095 | & ' central collisions forced.') |
| 2096 | LEVPRT = .FALSE. |
| 2097 | LDEEXG = .FALSE. |
| 2098 | LHEAVY = .FALSE. |
| 2099 | ENDIF |
| 2100 | ENDIF |
| 2101 | |
| 2102 | * initialization of evaporation-module |
| 2103 | |
| 2104 | * initialize evaporation if the code is not used as Fluka event generator |
| 2105 | IF (ITRSPT.NE.1) THEN |
| 2106 | CALL BERTTP |
| 2107 | CALL INCINI |
| 2108 | ENDIF |
| 2109 | IF (LEVPRT) LHEAVY = .TRUE. |
| 2110 | |
| 2111 | |
| 2112 | * save the default JETSET-parameter |
| 2113 | CALL DT_JSPARA(0) |
| 2114 | |
| 2115 | * force use of phojet for g-A |
| 2116 | IF ((IDP.EQ.7).AND.(MCGENE.NE.3)) MCGENE = 2 |
| 2117 | * initialization of nucleon-nucleon event generator |
| 2118 | IF (MCGENE.EQ.2) CALL DT_PHOINI |
| 2119 | * initialization of LEPTO event generator |
| 2120 | IF (MCGENE.EQ.3) THEN |
| 2121 | |
| 2122 | STOP ' This version does not contain LEPTO !' |
| 2123 | |
| 2124 | ENDIF |
| 2125 | |
| 2126 | * initialization of quasi-elastic neutrino scattering |
| 2127 | IF (MCGENE.EQ.4) THEN |
| 2128 | IF (IJPROJ.EQ.5) THEN |
| 2129 | NEUTYP = 1 |
| 2130 | ELSEIF (IJPROJ.EQ.6) THEN |
| 2131 | NEUTYP = 2 |
| 2132 | ELSEIF (IJPROJ.EQ.135) THEN |
| 2133 | NEUTYP = 3 |
| 2134 | ELSEIF (IJPROJ.EQ.136) THEN |
| 2135 | NEUTYP = 4 |
| 2136 | ELSEIF (IJPROJ.EQ.133) THEN |
| 2137 | NEUTYP = 5 |
| 2138 | ELSEIF (IJPROJ.EQ.134) THEN |
| 2139 | NEUTYP = 6 |
| 2140 | ENDIF |
| 2141 | ENDIF |
| 2142 | |
| 2143 | * normalize fractions of emulsion components |
| 2144 | IF (NCOMPO.GT.0) THEN |
| 2145 | SUMFRA = ZERO |
| 2146 | DO 491 I=1,NCOMPO |
| 2147 | SUMFRA = SUMFRA+EMUFRA(I) |
| 2148 | 491 CONTINUE |
| 2149 | IF (SUMFRA.GT.ZERO) THEN |
| 2150 | DO 492 I=1,NCOMPO |
| 2151 | EMUFRA(I) = EMUFRA(I)/SUMFRA |
| 2152 | 492 CONTINUE |
| 2153 | ENDIF |
| 2154 | ENDIF |
| 2155 | |
| 2156 | * disallow Cronin's multiple scattering for nucleus-nucleus interactions |
| 2157 | IF ((IP.GT.1).AND.(MKCRON.GT.0)) THEN |
| 2158 | WRITE(LOUT,1005) |
| 2159 | 1005 FORMAT(/,1X,'INIT: multiple scattering disallowed',/) |
| 2160 | MKCRON = 0 |
| 2161 | ENDIF |
| 2162 | |
| 2163 | * initialization of Glauber-formalism (moved to xAEVT, sr 26.3.96) |
| 2164 | C IF (NCOMPO.LE.0) THEN |
| 2165 | C CALL DT_SHMAKI(IP,IPZ,IT,ITZ,IDP,PPN,IGLAU) |
| 2166 | C ELSE |
| 2167 | C DO 493 I=1,NCOMPO |
| 2168 | C CALL DT_SHMAKI(IP,IPZ,IEMUMA(I),IEMUCH(I),IDP,PPN,0) |
| 2169 | C 493 CONTINUE |
| 2170 | C ENDIF |
| 2171 | |
| 2172 | * pre-tabulation of elastic cross-sections |
| 2173 | CALL DT_SIGTBL(JDUM,JDUM,DUM,DUM,-1) |
| 2174 | |
| 2175 | CALL DT_XTIME |
| 2176 | |
| 2177 | RETURN |
| 2178 | |
| 2179 | ********************************************************************* |
| 2180 | * * |
| 2181 | * control card: codewd = STOP * |
| 2182 | * * |
| 2183 | * stop of the event generation * |
| 2184 | * * |
| 2185 | * what (1..6) no meaning * |
| 2186 | * * |
| 2187 | ********************************************************************* |
| 2188 | |
| 2189 | 9999 CONTINUE |
| 2190 | WRITE(LOUT,9000) |
| 2191 | 9000 FORMAT(1X,'---> unexpected end of input !') |
| 2192 | |
| 2193 | 640 CONTINUE |
| 2194 | STOP |
| 2195 | |
| 2196 | END |
| 2197 | * |
| 2198 | *===kkinc==============================================================* |
| 2199 | * |
| 2200 | CDECK ID>, DT_KKINC |
| 2201 | SUBROUTINE DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT, |
| 2202 | & IREJ) |
| 2203 | |
| 2204 | ************************************************************************ |
| 2205 | * Treatment of complete nucleus-nucleus or hadron-nucleus scattering * |
| 2206 | * This subroutine is an update of the previous version written * |
| 2207 | * by J. Ranft/ H.-J. Moehring. * |
| 2208 | * This version dated 19.11.95 is written by S. Roesler * |
| 2209 | ************************************************************************ |
| 2210 | |
| 2211 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 2212 | SAVE |
| 2213 | |
| 2214 | PARAMETER ( LINP = 5 , |
| 2215 | & LOUT = 6 , |
| 2216 | & LDAT = 9 ) |
| 2217 | |
| 2218 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY5=1.0D-5, |
| 2219 | & TINY2=1.0D-2,TINY3=1.0D-3) |
| 2220 | |
| 2221 | LOGICAL LFZC |
| 2222 | |
| 2223 | * event history |
| 2224 | |
| 2225 | PARAMETER (NMXHKK=200000) |
| 2226 | |
| 2227 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 2228 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 2229 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 2230 | * extended event history |
| 2231 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 2232 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 2233 | & IHIST(2,NMXHKK) |
| 2234 | * particle properties (BAMJET index convention) |
| 2235 | CHARACTER*8 ANAME |
| 2236 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 2237 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 2238 | * properties of interacting particles |
| 2239 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG |
| 2240 | * Lorentz-parameters of the current interaction |
| 2241 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, |
| 2242 | & UMO,PPCM,EPROJ,PPROJ |
| 2243 | * flags for input different options |
| 2244 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 2245 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 2246 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 2247 | * flags for particle decays |
| 2248 | COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20), |
| 2249 | & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20), |
| 2250 | & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0 |
| 2251 | * cuts for variable energy runs |
| 2252 | COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI |
| 2253 | * Glauber formalism: flags and parameters for statistics |
| 2254 | LOGICAL LPROD |
| 2255 | CHARACTER*8 CGLB |
| 2256 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD |
| 2257 | |
| 2258 | DIMENSION WHAT(6) |
| 2259 | |
| 2260 | IREJ = 0 |
| 2261 | ILOOP = 0 |
| 2262 | 100 CONTINUE |
| 2263 | IF (ILOOP.EQ.4) THEN |
| 2264 | WRITE(LOUT,1000) NEVHKK |
| 2265 | 1000 FORMAT(1X,'KKINC: event ',I8,' rejected!') |
| 2266 | GOTO 9999 |
| 2267 | ENDIF |
| 2268 | ILOOP = ILOOP+1 |
| 2269 | |
| 2270 | * variable energy-runs, recalculate parameters for LT's |
| 2271 | IF ((ABS(VAREHI).GT.ZERO).OR.(IOGLB.EQ.100)) THEN |
| 2272 | PDUM = ZERO |
| 2273 | CDUM = ZERO |
| 2274 | CALL DT_LTINI(IDP,1,EPN,PDUM,CDUM,1) |
| 2275 | ENDIF |
| 2276 | IF (EPN.GT.EPROJ) THEN |
| 2277 | WRITE(LOUT,'(A,E9.3,2A,E9.3,A)') |
| 2278 | & ' Requested energy (',EPN,'GeV) exceeds', |
| 2279 | & ' initialization energy (',EPROJ,'GeV) !' |
| 2280 | STOP |
| 2281 | ENDIF |
| 2282 | |
| 2283 | * re-initialize /DTPRTA/ |
| 2284 | IP = NPMASS |
| 2285 | IPZ = NPCHAR |
| 2286 | IT = NTMASS |
| 2287 | ITZ = NTCHAR |
| 2288 | IJPROJ = IDP |
| 2289 | IBPROJ = IIBAR(IJPROJ) |
| 2290 | |
| 2291 | * calculate nuclear potentials (common /DTNPOT/) |
| 2292 | CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0) |
| 2293 | |
| 2294 | * initialize treatment for residual nuclei |
| 2295 | CALL DT_RESNCL(EPN,NLOOP,1) |
| 2296 | |
| 2297 | * sample hadron/nucleus-nucleus interaction |
| 2298 | CALL DT_KKEVNT(KKMAT,IREJ1) |
| 2299 | IF (IREJ1.GT.0) THEN |
| 2300 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKINC' |
| 2301 | GOTO 9999 |
| 2302 | ENDIF |
| 2303 | |
| 2304 | IF ((NPMASS.GT.1).OR.(NTMASS.GT.1)) THEN |
| 2305 | |
| 2306 | * intranuclear cascade of final state particles for KTAUGE generations |
| 2307 | * of secondaries |
| 2308 | CALL DT_FOZOCA(LFZC,IREJ1) |
| 2309 | IF (IREJ1.GT.0) THEN |
| 2310 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKINC' |
| 2311 | GOTO 9999 |
| 2312 | ENDIF |
| 2313 | |
| 2314 | * baryons unable to escape the nuclear potential are treated as |
| 2315 | * excited nucleons (ISTHKK=15,16) |
| 2316 | CALL DT_SCN4BA |
| 2317 | |
| 2318 | * decay of resonances produced in intranuclear cascade processes |
| 2319 | **sr 15-11-95 should be obsolete |
| 2320 | C IF (LFZC) CALL DT_DECAY1 |
| 2321 | |
| 2322 | 101 CONTINUE |
| 2323 | * treatment of residual nuclei |
| 2324 | CALL DT_RESNCL(EPN,NLOOP,2) |
| 2325 | |
| 2326 | * evaporation / fission / fragmentation |
| 2327 | * (if intranuclear cascade was sampled only) |
| 2328 | IF (LFZC) THEN |
| 2329 | CALL DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ1) |
| 2330 | IF (IREJ1.GT.1) GOTO 101 |
| 2331 | IF (IREJ1.EQ.1) GOTO 100 |
| 2332 | ENDIF |
| 2333 | |
| 2334 | ENDIF |
| 2335 | |
| 2336 | * transform finale state into Lab. |
| 2337 | IFLAG = 2 |
| 2338 | CALL DT_BEAMPR(WHAT,DUM,IFLAG) |
| 2339 | IF ((IFRAME.EQ.1).AND.(IFLAG.EQ.-1)) CALL DT_LT2LAB |
| 2340 | |
| 2341 | IF (IPI0.EQ.1) CALL DT_DECPI0 |
| 2342 | |
| 2343 | C IF (NEVHKK.EQ.5) CALL DT_EVTOUT(4) |
| 2344 | |
| 2345 | RETURN |
| 2346 | 9999 CONTINUE |
| 2347 | IREJ = 1 |
| 2348 | RETURN |
| 2349 | END |
| 2350 | * |
| 2351 | *===defaul=============================================================* |
| 2352 | * |
| 2353 | CDECK ID>, DT_DEFAUL |
| 2354 | SUBROUTINE DT_DEFAUL(EPN,PPN) |
| 2355 | |
| 2356 | ************************************************************************ |
| 2357 | * Variables are set to default values. * |
| 2358 | * This version dated 8.5.95 is written by S. Roesler. * |
| 2359 | ************************************************************************ |
| 2360 | |
| 2361 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 2362 | SAVE |
| 2363 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10) |
| 2364 | PARAMETER (TWOPI = 6.283185307179586454D+00) |
| 2365 | |
| 2366 | * particle properties (BAMJET index convention) |
| 2367 | CHARACTER*8 ANAME |
| 2368 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 2369 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 2370 | * nuclear potential |
| 2371 | LOGICAL LFERMI |
| 2372 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, |
| 2373 | & EBINDP(2),EBINDN(2),EPOT(2,210), |
| 2374 | & ETACOU(2),ICOUL,LFERMI |
| 2375 | * interface HADRIN-DPM |
| 2376 | COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA |
| 2377 | * central particle production, impact parameter biasing |
| 2378 | COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR |
| 2379 | * properties of interacting particles |
| 2380 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG |
| 2381 | * properties of photon/lepton projectiles |
| 2382 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC |
| 2383 | |
| 2384 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 2385 | |
| 2386 | * emulsion treatment |
| 2387 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), |
| 2388 | & NCOMPO,IEMUL |
| 2389 | * parameter for intranuclear cascade |
| 2390 | LOGICAL LPAULI |
| 2391 | COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI |
| 2392 | * various options for treatment of partons (DTUNUC 1.x) |
| 2393 | * (chain recombination, Cronin,..) |
| 2394 | LOGICAL LCO2CR,LINTPT |
| 2395 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, |
| 2396 | & LCO2CR,LINTPT |
| 2397 | * threshold values for x-sampling (DTUNUC 1.x) |
| 2398 | COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA, |
| 2399 | & SSMIMQ,VVMTHR |
| 2400 | * flags for input different options |
| 2401 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 2402 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 2403 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 2404 | * n-n cross section fluctuations |
| 2405 | PARAMETER (NBINS = 1000) |
| 2406 | COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT |
| 2407 | * flags for particle decays |
| 2408 | COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20), |
| 2409 | & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20), |
| 2410 | & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0 |
| 2411 | * diquark-breaking mechanism |
| 2412 | COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3 |
| 2413 | * nucleon-nucleon event-generator |
| 2414 | CHARACTER*8 CMODEL |
| 2415 | LOGICAL LPHOIN |
| 2416 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN |
| 2417 | * flags for diffractive interactions (DTUNUC 1.x) |
| 2418 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF |
| 2419 | * VDM parameter for photon-nucleus interactions |
| 2420 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) |
| 2421 | * Glauber formalism: flags and parameters for statistics |
| 2422 | LOGICAL LPROD |
| 2423 | CHARACTER*8 CGLB |
| 2424 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD |
| 2425 | * kinematical cuts for lepton-nucleus interactions |
| 2426 | COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX, |
| 2427 | & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI |
| 2428 | * flags for activated histograms |
| 2429 | COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL |
| 2430 | * cuts for variable energy runs |
| 2431 | COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI |
| 2432 | * parameters for hA-diffraction |
| 2433 | COMMON /DTDIHA/ DIBETA,DIALPH |
| 2434 | * LEPTO |
| 2435 | REAL RPPN |
| 2436 | COMMON /LEPTOI/ RPPN,LEPIN,INTER |
| 2437 | * steering flags for qel neutrino scattering modules |
| 2438 | COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC |
| 2439 | * event flag |
| 2440 | COMMON /DTEVNO/ NEVENT,ICASCA |
| 2441 | |
| 2442 | DATA POTMES /0.002D0/ |
| 2443 | |
| 2444 | * common /DTNPOT/ |
| 2445 | DO 10 I=1,2 |
| 2446 | PFERMP(I) = ZERO |
| 2447 | PFERMN(I) = ZERO |
| 2448 | EBINDP(I) = ZERO |
| 2449 | EBINDN(I) = ZERO |
| 2450 | DO 11 J=1,210 |
| 2451 | EPOT(I,J) = ZERO |
| 2452 | 11 CONTINUE |
| 2453 | * nucleus independent meson potential |
| 2454 | EPOT(I,13) = POTMES |
| 2455 | EPOT(I,14) = POTMES |
| 2456 | EPOT(I,15) = POTMES |
| 2457 | EPOT(I,16) = POTMES |
| 2458 | EPOT(I,23) = POTMES |
| 2459 | EPOT(I,24) = POTMES |
| 2460 | EPOT(I,25) = POTMES |
| 2461 | 10 CONTINUE |
| 2462 | **sr 7.4.98: changed after corrected B-sampling |
| 2463 | C FERMOD = 0.55D0 |
| 2464 | FERMOD = 0.68D0 |
| 2465 | ETACOU(1) = ZERO |
| 2466 | ETACOU(2) = ZERO |
| 2467 | ICOUL = 1 |
| 2468 | LFERMI = .TRUE. |
| 2469 | |
| 2470 | * common /HNTHRE/ |
| 2471 | EHADTH = -99.0D0 |
| 2472 | EHADLO = 4.06D0 |
| 2473 | EHADHI = 6.0D0 |
| 2474 | INTHAD = 1 |
| 2475 | IDXTA = 2 |
| 2476 | |
| 2477 | * common /DTIMPA/ |
| 2478 | ICENTR = 0 |
| 2479 | BIMIN = ZERO |
| 2480 | BIMAX = 1.0D10 |
| 2481 | XSFRAC = 1.0D0 |
| 2482 | |
| 2483 | * common /DTPRTA/ |
| 2484 | IP = 1 |
| 2485 | IPZ = 1 |
| 2486 | IT = 1 |
| 2487 | ITZ = 1 |
| 2488 | IJPROJ = 1 |
| 2489 | IBPROJ = 1 |
| 2490 | IJTARG = 1 |
| 2491 | IBTARG = 1 |
| 2492 | * common /DTGPRO/ |
| 2493 | VIRT = ZERO |
| 2494 | DO 14 I=1,4 |
| 2495 | PGAMM(I) = ZERO |
| 2496 | PLEPT0(I) = ZERO |
| 2497 | PLEPT1(I) = ZERO |
| 2498 | PNUCL(I) = ZERO |
| 2499 | 14 CONTINUE |
| 2500 | IDIREC = 0 |
| 2501 | |
| 2502 | * common /DTFOTI/ |
| 2503 | **sr 7.4.98: changed after corrected B-sampling |
| 2504 | C TAUFOR = 4.4D0 |
| 2505 | TAUFOR = 3.1D0 |
| 2506 | KTAUGE = 25 |
| 2507 | ITAUVE = 1 |
| 2508 | INCMOD = 1 |
| 2509 | LPAULI = .TRUE. |
| 2510 | |
| 2511 | * common /DTCHAI/ |
| 2512 | SEASQ = ONE |
| 2513 | MKCRON = 1 |
| 2514 | CRONCO = 0.64D0 |
| 2515 | ISICHA = 0 |
| 2516 | CUTOF = 100.0D0 |
| 2517 | LCO2CR = .FALSE. |
| 2518 | IRECOM = 1 |
| 2519 | LINTPT = .TRUE. |
| 2520 | |
| 2521 | * common /DTXCUT/ |
| 2522 | * definition of soft quark distributions |
| 2523 | XSEACU = 0.05D0 |
| 2524 | UNON = 2.0D0 |
| 2525 | UNOM = 1.5D0 |
| 2526 | UNOSEA = 5.0D0 |
| 2527 | * cutoff parameters for x-sampling |
| 2528 | CVQ = 1.0D0 |
| 2529 | CDQ = 2.0D0 |
| 2530 | C CSEA = 0.3D0 |
| 2531 | CSEA = 0.1D0 |
| 2532 | SSMIMA = 1.2D0 |
| 2533 | SSMIMQ = SSMIMA**2 |
| 2534 | VVMTHR = 2.0D0 |
| 2535 | |
| 2536 | * common /DTXSFL/ |
| 2537 | IFLUCT = 0 |
| 2538 | |
| 2539 | * common /DTFRPA/ |
| 2540 | PDB = 0.15D0 |
| 2541 | PDBSEA(1) = 0.0D0 |
| 2542 | PDBSEA(2) = 0.0D0 |
| 2543 | PDBSEA(3) = 0.0D0 |
| 2544 | ISIG0 = 0 |
| 2545 | IPI0 = 0 |
| 2546 | NMSTU = 0 |
| 2547 | NPARU = 0 |
| 2548 | NMSTJ = 0 |
| 2549 | NPARJ = 0 |
| 2550 | |
| 2551 | * common /DTDIQB/ |
| 2552 | DO 15 I=1,8 |
| 2553 | DBRKR(1,I) = 5.0D0 |
| 2554 | DBRKR(2,I) = 5.0D0 |
| 2555 | DBRKR(3,I) = 10.0D0 |
| 2556 | DBRKA(1,I) = ZERO |
| 2557 | DBRKA(2,I) = ZERO |
| 2558 | DBRKA(3,I) = ZERO |
| 2559 | 15 CONTINUE |
| 2560 | CHAM1 = 0.2D0 |
| 2561 | CHAM3 = 0.5D0 |
| 2562 | CHAB1 = 0.7D0 |
| 2563 | CHAB3 = 1.0D0 |
| 2564 | |
| 2565 | * common /DTFLG3/ |
| 2566 | ISINGD = 0 |
| 2567 | IDOUBD = 0 |
| 2568 | IFLAGD = 0 |
| 2569 | IDIFF = 0 |
| 2570 | |
| 2571 | * common /DTMODL/ |
| 2572 | MCGENE = 2 |
| 2573 | CMODEL(1) = 'DTUNUC ' |
| 2574 | CMODEL(2) = 'PHOJET ' |
| 2575 | CMODEL(3) = 'LEPTO ' |
| 2576 | CMODEL(4) = 'QNEUTRIN' |
| 2577 | LPHOIN = .TRUE. |
| 2578 | ELOJET = 5.0D0 |
| 2579 | |
| 2580 | * common /DTLCUT/ |
| 2581 | ECMIN = 3.5D0 |
| 2582 | ECMAX = 1.0D10 |
| 2583 | XBJMIN = ZERO |
| 2584 | ELMIN = ZERO |
| 2585 | EGMIN = ZERO |
| 2586 | EGMAX = 1.0D10 |
| 2587 | YMIN = TINY10 |
| 2588 | YMAX = 0.999D0 |
| 2589 | Q2MIN = TINY10 |
| 2590 | Q2MAX = 10.0D0 |
| 2591 | THMIN = ZERO |
| 2592 | THMAX = TWOPI |
| 2593 | Q2LI = ZERO |
| 2594 | Q2HI = 1.0D10 |
| 2595 | ECMLI = ZERO |
| 2596 | ECMHI = 1.0D10 |
| 2597 | |
| 2598 | * common /DTVDMP/ |
| 2599 | RL2 = 2.0D0 |
| 2600 | INTRGE(1) = 1 |
| 2601 | INTRGE(2) = 3 |
| 2602 | IDPDF = 2212 |
| 2603 | MODEGA = 4 |
| 2604 | ISHAD(1) = 1 |
| 2605 | ISHAD(2) = 1 |
| 2606 | ISHAD(3) = 1 |
| 2607 | EPSPOL = ZERO |
| 2608 | |
| 2609 | * common /DTGLGP/ |
| 2610 | JSTATB = 1000 |
| 2611 | JBINSB = 49 |
| 2612 | CGLB = ' ' |
| 2613 | IF (ITRSPT.EQ.1) THEN |
| 2614 | IOGLB = 100 |
| 2615 | ELSE |
| 2616 | IOGLB = 0 |
| 2617 | ENDIF |
| 2618 | LPROD = .TRUE. |
| 2619 | |
| 2620 | * common /DTHIS3/ |
| 2621 | DO 16 I=1,50 |
| 2622 | IHISPP(I) = 0 |
| 2623 | IHISXS(I) = 0 |
| 2624 | 16 CONTINUE |
| 2625 | IXSTBL = 0 |
| 2626 | |
| 2627 | * common /DTVARE/ |
| 2628 | VARELO = ZERO |
| 2629 | VAREHI = ZERO |
| 2630 | VARCLO = ZERO |
| 2631 | VARCHI = ZERO |
| 2632 | |
| 2633 | * common /DTDIHA/ |
| 2634 | DIBETA = -1.0D0 |
| 2635 | DIALPH = ZERO |
| 2636 | |
| 2637 | * common /LEPTOI/ |
| 2638 | RPPN = 0.0 |
| 2639 | LEPIN = 0 |
| 2640 | INTER = 0 |
| 2641 | |
| 2642 | * common /QNEUTO/ |
| 2643 | NEUTYP = 1 |
| 2644 | NEUDEC = 0 |
| 2645 | |
| 2646 | * common /DTEVNO/ |
| 2647 | NEVENT = 1 |
| 2648 | IF (ITRSPT.EQ.1) THEN |
| 2649 | ICASCA = 1 |
| 2650 | ELSE |
| 2651 | ICASCA = 0 |
| 2652 | ENDIF |
| 2653 | |
| 2654 | * default Lab.-energy |
| 2655 | EPN = 200.0D0 |
| 2656 | PPN = SQRT((EPN-AAM(IJPROJ))*(EPN+AAM(IJPROJ))) |
| 2657 | |
| 2658 | RETURN |
| 2659 | END |
| 2660 | * |
| 2661 | *===aaevt==============================================================* |
| 2662 | * |
| 2663 | CDECK ID>, DT_AAEVT |
| 2664 | SUBROUTINE DT_AAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR, |
| 2665 | & IDP,IGLAU) |
| 2666 | |
| 2667 | ************************************************************************ |
| 2668 | * This version dated 22.03.96 is written by S. Roesler. * |
| 2669 | ************************************************************************ |
| 2670 | |
| 2671 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 2672 | SAVE |
| 2673 | |
| 2674 | PARAMETER ( LINP = 5 , |
| 2675 | & LOUT = 6 , |
| 2676 | & LDAT = 9 ) |
| 2677 | |
| 2678 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 2679 | |
| 2680 | * emulsion treatment |
| 2681 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), |
| 2682 | & NCOMPO,IEMUL |
| 2683 | * event flag |
| 2684 | COMMON /DTEVNO/ NEVENT,ICASCA |
| 2685 | |
| 2686 | CHARACTER*8 DATE,HHMMSS |
| 2687 | DIMENSION IDMNYR(3) |
| 2688 | |
| 2689 | KKMAT = 1 |
| 2690 | NMSG = MAX(NEVTS/100,1) |
| 2691 | |
| 2692 | * initialization of run-statistics and histograms |
| 2693 | CALL DT_STATIS(1) |
| 2694 | |
| 2695 | CALL PHO_PHIST(1000,DUM) |
| 2696 | |
| 2697 | * initialization of Glauber-formalism |
| 2698 | IF (NCOMPO.LE.0) THEN |
| 2699 | CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU) |
| 2700 | ELSE |
| 2701 | DO 1 I=1,NCOMPO |
| 2702 | CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0) |
| 2703 | 1 CONTINUE |
| 2704 | ENDIF |
| 2705 | CALL DT_SIGEMU |
| 2706 | |
| 2707 | CALL IDATE(IDMNYR) |
| 2708 | WRITE(DATE,'(I2,''/'',I2,''/'',I2)') |
| 2709 | & IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100) |
| 2710 | CALL ITIME(IDMNYR) |
| 2711 | WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)') |
| 2712 | & IDMNYR(1),IDMNYR(2),IDMNYR(3) |
| 2713 | WRITE(LOUT,1001) DATE,HHMMSS |
| 2714 | 1001 FORMAT(/,' DT_AAEVT: Initialisation finished. ( Date: ',A8, |
| 2715 | & ' Time: ',A8,' )') |
| 2716 | |
| 2717 | * generate NEVTS events |
| 2718 | DO 2 IEVT=1,NEVTS |
| 2719 | |
| 2720 | * print run-status message |
| 2721 | IF (MOD(IEVT,NMSG).EQ.0) THEN |
| 2722 | CALL IDATE(IDMNYR) |
| 2723 | WRITE(DATE,'(I2,''/'',I2,''/'',I2)') |
| 2724 | & IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100) |
| 2725 | CALL ITIME(IDMNYR) |
| 2726 | WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)') |
| 2727 | & IDMNYR(1),IDMNYR(2),IDMNYR(3) |
| 2728 | WRITE(LOUT,1000) IEVT-1,NEVTS,DATE,HHMMSS |
| 2729 | 1000 FORMAT(/,1X,I8,' out of ',I8,' events sampled ( Date: ',A, |
| 2730 | & ' Time: ',A,' )',/) |
| 2731 | C WRITE(LOUT,1000) IEVT-1 |
| 2732 | C1000 FORMAT(1X,I8,' events sampled') |
| 2733 | ENDIF |
| 2734 | NEVENT = IEVT |
| 2735 | * treat nuclear emulsions |
| 2736 | IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0) |
| 2737 | * composite targets only |
| 2738 | KKMAT = -KKMAT |
| 2739 | * sample this event |
| 2740 | CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,IREJ) |
| 2741 | |
| 2742 | CALL PHO_PHIST(2000,DUM) |
| 2743 | |
| 2744 | 2 CONTINUE |
| 2745 | |
| 2746 | * print run-statistics and histograms to output-unit 6 |
| 2747 | |
| 2748 | CALL PHO_PHIST(3000,DUM) |
| 2749 | |
| 2750 | CALL DT_STATIS(2) |
| 2751 | |
| 2752 | RETURN |
| 2753 | END |
| 2754 | * |
| 2755 | *===laevt==============================================================* |
| 2756 | * |
| 2757 | CDECK ID>, DT_LAEVT |
| 2758 | SUBROUTINE DT_LAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR, |
| 2759 | & IDP,IGLAU) |
| 2760 | |
| 2761 | ************************************************************************ |
| 2762 | * Interface to run DPMJET for lepton-nucleus interactions. * |
| 2763 | * Kinematics is sampled using the equivalent photon approximation * |
| 2764 | * Based on GPHERA-routine by R. Engel. * |
| 2765 | * This version dated 23.03.96 is written by S. Roesler. * |
| 2766 | ************************************************************************ |
| 2767 | |
| 2768 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 2769 | SAVE |
| 2770 | |
| 2771 | PARAMETER ( LINP = 5 , |
| 2772 | & LOUT = 6 , |
| 2773 | & LDAT = 9 ) |
| 2774 | |
| 2775 | PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4, |
| 2776 | & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0) |
| 2777 | PARAMETER (TWOPI = 6.283185307179586454D+00, |
| 2778 | & PI = TWOPI/TWO, |
| 2779 | & ALPHEM = ONE/137.0D0) |
| 2780 | |
| 2781 | C CHARACTER*72 HEADER |
| 2782 | |
| 2783 | * particle properties (BAMJET index convention) |
| 2784 | CHARACTER*8 ANAME |
| 2785 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 2786 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 2787 | * event history |
| 2788 | |
| 2789 | PARAMETER (NMXHKK=200000) |
| 2790 | |
| 2791 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 2792 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 2793 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 2794 | * extended event history |
| 2795 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 2796 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 2797 | & IHIST(2,NMXHKK) |
| 2798 | * kinematical cuts for lepton-nucleus interactions |
| 2799 | COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX, |
| 2800 | & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI |
| 2801 | * properties of interacting particles |
| 2802 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG |
| 2803 | * properties of photon/lepton projectiles |
| 2804 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC |
| 2805 | * kinematics at lepton-gamma vertex |
| 2806 | COMMON /DTLGVX/ PPL0(4),PPL1(4),PPG(4),PPA(4) |
| 2807 | * flags for activated histograms |
| 2808 | COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL |
| 2809 | |
| 2810 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 2811 | |
| 2812 | * emulsion treatment |
| 2813 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), |
| 2814 | & NCOMPO,IEMUL |
| 2815 | * Glauber formalism: cross sections |
| 2816 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, |
| 2817 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), |
| 2818 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), |
| 2819 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), |
| 2820 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), |
| 2821 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), |
| 2822 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), |
| 2823 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), |
| 2824 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), |
| 2825 | & BSLOPE,NEBINI,NQBINI |
| 2826 | * nucleon-nucleon event-generator |
| 2827 | CHARACTER*8 CMODEL |
| 2828 | LOGICAL LPHOIN |
| 2829 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN |
| 2830 | * flags for input different options |
| 2831 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 2832 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 2833 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 2834 | * event flag |
| 2835 | COMMON /DTEVNO/ NEVENT,ICASCA |
| 2836 | |
| 2837 | DIMENSION XDUMB(40),BGTA(4) |
| 2838 | |
| 2839 | * LEPTO |
| 2840 | IF (MCGENE.EQ.3) THEN |
| 2841 | |
| 2842 | STOP ' This version does not contain LEPTO !' |
| 2843 | |
| 2844 | ENDIF |
| 2845 | |
| 2846 | KKMAT = 1 |
| 2847 | NMSG = MAX(NEVTS/10,1) |
| 2848 | |
| 2849 | * mass of incident lepton |
| 2850 | AMLPT = AAM(IDP) |
| 2851 | AMLPT2 = AMLPT**2 |
| 2852 | IDPPDG = IDT_IPDGHA(IDP) |
| 2853 | |
| 2854 | * consistency of kinematical limits |
| 2855 | Q2MIN = MAX(Q2MIN,TINY10) |
| 2856 | Q2MAX = MAX(Q2MAX,TINY10) |
| 2857 | YMIN = MIN(MAX(YMIN,TINY10),0.999D0) |
| 2858 | YMAX = MIN(MAX(YMAX,TINY10),0.999D0) |
| 2859 | |
| 2860 | * total energy of the lepton-nucleon system |
| 2861 | PTOTLN = SQRT( (PLEPT0(1)+PNUCL(1))**2+(PLEPT0(2)+PNUCL(2))**2 |
| 2862 | & +(PLEPT0(3)+PNUCL(3))**2 ) |
| 2863 | ETOTLN = PLEPT0(4)+PNUCL(4) |
| 2864 | ECMLN = SQRT((ETOTLN-PTOTLN)*(ETOTLN+PTOTLN)) |
| 2865 | ECMAX = MIN(ECMAX,ECMLN) |
| 2866 | WRITE(LOUT,1003) ECMIN,ECMAX,YMIN,YMAX,Q2MIN,Q2MAX,EGMIN, |
| 2867 | & THMIN,THMAX,ELMIN |
| 2868 | 1003 FORMAT(1X,'LAEVT:',16X,'kinematical cuts',/,22X, |
| 2869 | & '------------------',/,9X,'W (min) =', |
| 2870 | & F7.1,' GeV (max) =',F7.1,' GeV',/,9X,'y (min) =', |
| 2871 | & F7.3,8X,'(max) =',F7.3,/,9X,'Q^2 (min) =',F7.1, |
| 2872 | & ' GeV^2 (max) =',F7.1,' GeV^2',/,' (Lab) E_g (min) =' |
| 2873 | & ,F7.1,' GeV',/,' (Lab) theta (min) =',F7.4,8X,'(max) =', |
| 2874 | & F7.4,' for E_lpt >',F7.1,' GeV',/) |
| 2875 | |
| 2876 | * Lorentz-parameter for transf. into Lab |
| 2877 | BGTA(1) = PNUCL(1)/AAM(1) |
| 2878 | BGTA(2) = PNUCL(2)/AAM(1) |
| 2879 | BGTA(3) = PNUCL(3)/AAM(1) |
| 2880 | BGTA(4) = PNUCL(4)/AAM(1) |
| 2881 | * LT of incident lepton into Lab and dump it in DTEVT1 |
| 2882 | CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3), |
| 2883 | & PLEPT0(1),PLEPT0(2),PLEPT0(3),PLEPT0(4), |
| 2884 | & PLTOT,PPL0(1),PPL0(2),PPL0(3),PPL0(4)) |
| 2885 | CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3), |
| 2886 | & PNUCL(1),PNUCL(2),PNUCL(3),PNUCL(4), |
| 2887 | & PLTOT,PPA(1),PPA(2),PPA(3),PPA(4)) |
| 2888 | * maximum energy of photon nucleon system |
| 2889 | PTOTGN = SQRT((YMAX*PPL0(1)+PPA(1))**2+(YMAX*PPL0(2)+PPA(2))**2 |
| 2890 | & +(YMAX*PPL0(3)+PPA(3))**2) |
| 2891 | ETOTGN = YMAX*PPL0(4)+PPA(4) |
| 2892 | EGNMAX = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN)) |
| 2893 | EGNMAX = MIN(EGNMAX,ECMAX) |
| 2894 | * minimum energy of photon nucleon system |
| 2895 | PTOTGN = SQRT((YMIN*PPL0(1)+PPA(1))**2+(YMIN*PPL0(2)+PPA(2))**2 |
| 2896 | & +(YMIN*PPL0(3)+PPA(3))**2) |
| 2897 | ETOTGN = YMIN*PPL0(4)+PPA(4) |
| 2898 | EGNMIN = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN)) |
| 2899 | EGNMIN = MAX(EGNMIN,ECMIN) |
| 2900 | |
| 2901 | * limits for Glauber-initialization |
| 2902 | Q2LI = Q2MIN |
| 2903 | Q2HI = MAX(Q2LI,MIN(Q2HI,Q2MAX)) |
| 2904 | ECMLI = MAX(EGNMIN,THREE) |
| 2905 | ECMHI = EGNMAX |
| 2906 | WRITE(LOUT,1004) EGNMIN,EGNMAX,ECMLI,ECMHI,Q2LI,Q2HI |
| 2907 | 1004 FORMAT(1X,'resulting limits:',/,9X,'W (min) =',F7.1, |
| 2908 | & ' GeV (max) =',F7.1,' GeV',/,/,' limits for ', |
| 2909 | & 'Glauber-initialization:',/,9X,'W (min) =',F7.1, |
| 2910 | & ' GeV (max) =',F7.1,' GeV',/,9X,'Q^2 (min) =',F7.1, |
| 2911 | & ' GeV^2 (max) =',F7.1,' GeV^2',/) |
| 2912 | * initialization of Glauber-formalism |
| 2913 | IF (NCOMPO.LE.0) THEN |
| 2914 | CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU) |
| 2915 | ELSE |
| 2916 | DO 9 I=1,NCOMPO |
| 2917 | CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0) |
| 2918 | 9 CONTINUE |
| 2919 | ENDIF |
| 2920 | CALL DT_SIGEMU |
| 2921 | |
| 2922 | * initialization of run-statistics and histograms |
| 2923 | CALL DT_STATIS(1) |
| 2924 | |
| 2925 | CALL PHO_PHIST(1000,DUM) |
| 2926 | |
| 2927 | * maximum photon-nucleus cross section |
| 2928 | I1 = 1 |
| 2929 | I2 = 1 |
| 2930 | RAT = ONE |
| 2931 | IF (EGNMAX.GE.ECMNN(NEBINI)) THEN |
| 2932 | I1 = NEBINI |
| 2933 | I2 = NEBINI |
| 2934 | RAT = ONE |
| 2935 | ELSEIF (EGNMAX.GT.ECMNN(1)) THEN |
| 2936 | DO 5 I=2,NEBINI |
| 2937 | IF (EGNMAX.LT.ECMNN(I)) THEN |
| 2938 | I1 = I-1 |
| 2939 | I2 = I |
| 2940 | RAT = (EGNMAX-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1)) |
| 2941 | GOTO 6 |
| 2942 | ENDIF |
| 2943 | 5 CONTINUE |
| 2944 | 6 CONTINUE |
| 2945 | ENDIF |
| 2946 | SIGMAX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1)) |
| 2947 | EGNXX = EGNMAX |
| 2948 | I1 = 1 |
| 2949 | I2 = 1 |
| 2950 | RAT = ONE |
| 2951 | IF (EGNMIN.GE.ECMNN(NEBINI)) THEN |
| 2952 | I1 = NEBINI |
| 2953 | I2 = NEBINI |
| 2954 | RAT = ONE |
| 2955 | ELSEIF (EGNMIN.GT.ECMNN(1)) THEN |
| 2956 | DO 7 I=2,NEBINI |
| 2957 | IF (EGNMIN.LT.ECMNN(I)) THEN |
| 2958 | I1 = I-1 |
| 2959 | I2 = I |
| 2960 | RAT = (EGNMIN-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1)) |
| 2961 | GOTO 8 |
| 2962 | ENDIF |
| 2963 | 7 CONTINUE |
| 2964 | 8 CONTINUE |
| 2965 | ENDIF |
| 2966 | SIGXX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1)) |
| 2967 | IF (SIGXX.GT.SIGMAX) EGNXX = EGNMIN |
| 2968 | SIGMAX = MAX(SIGMAX,SIGXX) |
| 2969 | WRITE(LOUT,'(9X,A,F8.3,A)') 'Sigma_tot (max) =',SIGMAX,' mb' |
| 2970 | |
| 2971 | * plot photon flux table |
| 2972 | AYMIN = LOG(YMIN) |
| 2973 | AYMAX = LOG(YMAX) |
| 2974 | AYRGE = AYMAX-AYMIN |
| 2975 | MAXTAB = 50 |
| 2976 | ADY = LOG(YMAX/YMIN)/DBLE(MAXTAB-1) |
| 2977 | C WRITE(LOUT,'(/,1X,A)') 'LAEVT: photon flux ' |
| 2978 | DO 1 I=1,MAXTAB |
| 2979 | Y = EXP(AYMIN+ADY*DBLE(I-1)) |
| 2980 | Q2LOW = MAX(Q2MIN,AMLPT2*Y**2/(ONE-Y)) |
| 2981 | FF1 = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW) |
| 2982 | & -TWO*AMLPT2*Y*(ONE/Q2LOW-ONE/Q2MAX)) |
| 2983 | FF2 = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW) |
| 2984 | & -TWO*(ONE-Y)/Y*(ONE-Q2LOW/Q2MAX)) |
| 2985 | C WRITE(LOUT,'(5X,3E15.4)') Y,FF1,FF2 |
| 2986 | 1 CONTINUE |
| 2987 | |
| 2988 | * maximum residual weight for flux sampling (dy/y) |
| 2989 | YY = YMIN |
| 2990 | Q2LOW = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY)) |
| 2991 | WGHMAX = (ONE+(ONE-YY)**2)*LOG(Q2MAX/Q2LOW) |
| 2992 | & -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY |
| 2993 | |
| 2994 | CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY0) |
| 2995 | CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY1) |
| 2996 | CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY2) |
| 2997 | CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ0) |
| 2998 | CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ1) |
| 2999 | CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ2) |
| 3000 | CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE0) |
| 3001 | CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE1) |
| 3002 | CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE2) |
| 3003 | CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU0) |
| 3004 | CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU1) |
| 3005 | CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU2) |
| 3006 | XBLOW = 0.001D0 |
| 3007 | CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX0) |
| 3008 | CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX1) |
| 3009 | CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX2) |
| 3010 | |
| 3011 | ITRY = 0 |
| 3012 | ITRW = 0 |
| 3013 | NC0 = 0 |
| 3014 | NC1 = 0 |
| 3015 | |
| 3016 | * generate events |
| 3017 | DO 2 IEVT=1,NEVTS |
| 3018 | IF (MOD(IEVT,NMSG).EQ.0) THEN |
| 3019 | C OPEN(LDAT,FILE='/scrtch3/hr/sroesler/statusd5.out', |
| 3020 | C & STATUS='UNKNOWN') |
| 3021 | WRITE(LOUT,'(1X,I8,A)') IEVT-1,' events sampled' |
| 3022 | C CLOSE(LDAT) |
| 3023 | ENDIF |
| 3024 | NEVENT = IEVT |
| 3025 | |
| 3026 | 100 CONTINUE |
| 3027 | ITRY = ITRY+1 |
| 3028 | |
| 3029 | * sample y |
| 3030 | 101 CONTINUE |
| 3031 | ITRW = ITRW+1 |
| 3032 | YY = EXP(AYRGE*DT_RNDM(RAT)+AYMIN) |
| 3033 | Q2LOW = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY)) |
| 3034 | Q2LOG = LOG(Q2MAX/Q2LOW) |
| 3035 | WGH = (ONE+(ONE-YY)**2)*Q2LOG |
| 3036 | & -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY |
| 3037 | IF (WGHMAX.LT.WGH) WRITE(LOUT,1000) YY,WGHMAX,WGH |
| 3038 | 1000 FORMAT(1X,'LAEVT: weight error!',3E12.5) |
| 3039 | IF (DT_RNDM(YY)*WGHMAX.GT.WGH) GOTO 101 |
| 3040 | |
| 3041 | * sample Q2 |
| 3042 | YEFF = ONE+(ONE-YY)**2 |
| 3043 | 102 CONTINUE |
| 3044 | Q2 = Q2LOW*EXP(Q2LOG*DT_RNDM(YY)) |
| 3045 | WGH = (YEFF-TWO*(ONE-YY)*Q2LOW/Q2)/YEFF |
| 3046 | IF (WGH.LT.DT_RNDM(Q2)) GOTO 102 |
| 3047 | |
| 3048 | c NC0 = NC0+1 |
| 3049 | c CALL DT_FILHGR(YY,ONE,IHFLY0,NC0) |
| 3050 | c CALL DT_FILHGR(Q2,ONE,IHFLQ0,NC0) |
| 3051 | |
| 3052 | * kinematics at lepton-photon vertex |
| 3053 | * scattered electron |
| 3054 | YQ2 = SQRT((ONE-YY)*Q2) |
| 3055 | Q2E = Q2/(4.0D0*PLEPT0(4)) |
| 3056 | E1Y = (ONE-YY)*PLEPT0(4) |
| 3057 | CALL DT_DSFECF(SIF,COF) |
| 3058 | PLEPT1(1) = YQ2*COF |
| 3059 | PLEPT1(2) = YQ2*SIF |
| 3060 | PLEPT1(3) = E1Y-Q2E |
| 3061 | PLEPT1(4) = E1Y+Q2E |
| 3062 | C THETA = ACOS( (E1Y-Q2E)/(E1Y+Q2E) ) |
| 3063 | * radiated photon |
| 3064 | PGAMM(1) = -PLEPT1(1) |
| 3065 | PGAMM(2) = -PLEPT1(2) |
| 3066 | PGAMM(3) = PLEPT0(3)-PLEPT1(3) |
| 3067 | PGAMM(4) = PLEPT0(4)-PLEPT1(4) |
| 3068 | * E_cm cut |
| 3069 | PTOTGN = SQRT( (PGAMM(1)+PNUCL(1))**2+(PGAMM(2)+PNUCL(2))**2 |
| 3070 | & +(PGAMM(3)+PNUCL(3))**2 ) |
| 3071 | ETOTGN = PGAMM(4)+PNUCL(4) |
| 3072 | ECMGN = (ETOTGN-PTOTGN)*(ETOTGN+PTOTGN) |
| 3073 | IF (ECMGN.LT.0.1D0) GOTO 101 |
| 3074 | ECMGN = SQRT(ECMGN) |
| 3075 | IF ((ECMGN.LT.ECMIN).OR.(ECMGN.GT.ECMAX)) GOTO 101 |
| 3076 | |
| 3077 | * Lorentz-transformation into nucleon-rest system |
| 3078 | CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3), |
| 3079 | & PGAMM(1),PGAMM(2),PGAMM(3),PGAMM(4), |
| 3080 | & PGTOT,PPG(1),PPG(2),PPG(3),PPG(4)) |
| 3081 | CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3), |
| 3082 | & PLEPT1(1),PLEPT1(2),PLEPT1(3),PLEPT1(4), |
| 3083 | & PLTOT,PPL1(1),PPL1(2),PPL1(3),PPL1(4)) |
| 3084 | * temporary checks.. |
| 3085 | Q2TMP = ABS(PPG(4)**2-PGTOT**2) |
| 3086 | IF (ABS(Q2-Q2TMP).GT.0.01D0) WRITE(LOUT,1001) Q2,Q2TMP |
| 3087 | 1001 FORMAT(1X,'LAEVT: inconsistent kinematics (Q2,Q2TMP) ', |
| 3088 | & 2F10.4) |
| 3089 | ECMTMP = SQRT((PPG(4)+AAM(1)-PGTOT)*(PPG(4)+AAM(1)+PGTOT)) |
| 3090 | IF (ABS(ECMGN-ECMTMP).GT.TINY10) WRITE(LOUT,1002) ECMGN,ECMTMP |
| 3091 | 1002 FORMAT(1X,'LAEVT: inconsistent kinematics (ECMGN,ECMTMP) ', |
| 3092 | & 2F10.2) |
| 3093 | YYTMP = PPG(4)/PPL0(4) |
| 3094 | IF (ABS(YY-YYTMP).GT.0.01D0) WRITE(LOUT,1005) YY,YYTMP |
| 3095 | 1005 FORMAT(1X,'LAEVT: inconsistent kinematics (YY,YYTMP) ', |
| 3096 | & 2F10.4) |
| 3097 | |
| 3098 | * lepton tagger (Lab) |
| 3099 | THETA = ACOS( PPL1(3)/PLTOT ) |
| 3100 | IF (PPL1(4).GT.ELMIN) THEN |
| 3101 | IF ((THETA.LT.THMIN).OR.(THETA.GT.THMAX)) GOTO 101 |
| 3102 | ENDIF |
| 3103 | * photon energy-cut (Lab) |
| 3104 | IF (PPG(4).LT.EGMIN) GOTO 101 |
| 3105 | IF (PPG(4).GT.EGMAX) GOTO 101 |
| 3106 | * x_Bj cut |
| 3107 | XBJ = ABS(Q2/(1.876D0*PPG(4))) |
| 3108 | IF (XBJ.LT.XBJMIN) GOTO 101 |
| 3109 | |
| 3110 | NC0 = NC0+1 |
| 3111 | CALL DT_FILHGR( Q2,ONE,IHFLQ0,NC0) |
| 3112 | CALL DT_FILHGR( YY,ONE,IHFLY0,NC0) |
| 3113 | CALL DT_FILHGR( XBJ,ONE,IHFLX0,NC0) |
| 3114 | CALL DT_FILHGR(PPG(4),ONE,IHFLU0,NC0) |
| 3115 | CALL DT_FILHGR( ECMGN,ONE,IHFLE0,NC0) |
| 3116 | |
| 3117 | * rotation angles against z-axis |
| 3118 | COD = PPG(3)/PGTOT |
| 3119 | C SID = SQRT((ONE-COD)*(ONE+COD)) |
| 3120 | PPT = SQRT(PPG(1)**2+PPG(2)**2) |
| 3121 | SID = PPT/PGTOT |
| 3122 | COF = ONE |
| 3123 | SIF = ZERO |
| 3124 | IF (PGTOT*SID.GT.TINY10) THEN |
| 3125 | COF = PPG(1)/(SID*PGTOT) |
| 3126 | SIF = PPG(2)/(SID*PGTOT) |
| 3127 | ANORF = SQRT(COF*COF+SIF*SIF) |
| 3128 | COF = COF/ANORF |
| 3129 | SIF = SIF/ANORF |
| 3130 | ENDIF |
| 3131 | |
| 3132 | IF (IXSTBL.EQ.0) THEN |
| 3133 | * change to photon projectile |
| 3134 | IJPROJ = 7 |
| 3135 | * set virtuality |
| 3136 | VIRT = Q2 |
| 3137 | * re-initialize LTs with new kinematics |
| 3138 | * !!PGAMM ist set in cms (ECMGN) along z |
| 3139 | EPN = ZERO |
| 3140 | PPN = ZERO |
| 3141 | CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,ECMGN,0) |
| 3142 | * Introduced by Chiara -> force CMS-system |
| 3143 | * IFRAME = 2 |
| 3144 | * to force Lab-system |
| 3145 | IFRAME = 1 |
| 3146 | * get emulsion component if requested |
| 3147 | IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0) |
| 3148 | * convolute with cross section |
| 3149 | CALL DT_SIGGAT(Q2LOW,EGNXX,STOTX,KKMAT) |
| 3150 | CALL DT_SIGGAT(Q2,ECMGN,STOT,KKMAT) |
| 3151 | IF (STOTX.LT.STOT) WRITE(LOUT,'(1X,A,/,6E12.3)') |
| 3152 | & 'LAEVT: warning STOTX<STOT ! ',Q2LOW,EGNMAX,STOTX, |
| 3153 | & Q2,ECMGN,STOT |
| 3154 | IF (DT_RNDM(Q2)*STOTX.GT.STOT) GOTO 100 |
| 3155 | NC1 = NC1+1 |
| 3156 | CALL DT_FILHGR( Q2,ONE,IHFLQ1,NC1) |
| 3157 | CALL DT_FILHGR( YY,ONE,IHFLY1,NC1) |
| 3158 | CALL DT_FILHGR( XBJ,ONE,IHFLX1,NC1) |
| 3159 | CALL DT_FILHGR(PPG(4),ONE,IHFLU1,NC1) |
| 3160 | CALL DT_FILHGR( ECMGN,ONE,IHFLE1,NC1) |
| 3161 | * composite targets only |
| 3162 | KKMAT = -KKMAT |
| 3163 | * sample this event |
| 3164 | CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IJPROJ,EPN,KKMAT, |
| 3165 | & IREJ) |
| 3166 | * rotate momenta of final state particles back in photon-nucleon syst. |
| 3167 | DO 4 I=NPOINT(4),NHKK |
| 3168 | IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR. |
| 3169 | & (ISTHKK(I).EQ.1001)) THEN |
| 3170 | PX = PHKK(1,I) |
| 3171 | PY = PHKK(2,I) |
| 3172 | PZ = PHKK(3,I) |
| 3173 | CALL DT_MYTRAN(1,PX,PY,PZ,COD,SID,COF,SIF, |
| 3174 | & PHKK(1,I),PHKK(2,I),PHKK(3,I)) |
| 3175 | ENDIF |
| 3176 | 4 CONTINUE |
| 3177 | ENDIF |
| 3178 | |
| 3179 | CALL DT_FILHGR( Q2,ONE,IHFLQ2,NC1) |
| 3180 | CALL DT_FILHGR( YY,ONE,IHFLY2,NC1) |
| 3181 | CALL DT_FILHGR( XBJ,ONE,IHFLX2,NC1) |
| 3182 | CALL DT_FILHGR(PPG(4),ONE,IHFLU2,NC1) |
| 3183 | CALL DT_FILHGR( ECMGN,ONE,IHFLE2,NC1) |
| 3184 | |
| 3185 | * dump this event to histograms |
| 3186 | |
| 3187 | CALL PHO_PHIST(2000,DUM) |
| 3188 | |
| 3189 | 2 CONTINUE |
| 3190 | |
| 3191 | WGY = ALPHEM/TWOPI*WGHMAX*DBLE(ITRY)/DBLE(ITRW) |
| 3192 | WGY = WGY*LOG(YMAX/YMIN) |
| 3193 | WEIGHT = WGY*SIGMAX*DBLE(NEVTS)/DBLE(ITRY) |
| 3194 | |
| 3195 | C HEADER = ' LAEVT: Q^2 distribution 0' |
| 3196 | C CALL DT_OUTHGR(IHFLQ0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) |
| 3197 | C HEADER = ' LAEVT: Q^2 distribution 1' |
| 3198 | C CALL DT_OUTHGR(IHFLQ1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) |
| 3199 | C HEADER = ' LAEVT: Q^2 distribution 2' |
| 3200 | C CALL DT_OUTHGR(IHFLQ2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) |
| 3201 | C HEADER = ' LAEVT: y distribution 0' |
| 3202 | C CALL DT_OUTHGR(IHFLY0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) |
| 3203 | C HEADER = ' LAEVT: y distribution 1' |
| 3204 | C CALL DT_OUTHGR(IHFLY1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) |
| 3205 | C HEADER = ' LAEVT: y distribution 2' |
| 3206 | C CALL DT_OUTHGR(IHFLY2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) |
| 3207 | C HEADER = ' LAEVT: x distribution 0' |
| 3208 | C CALL DT_OUTHGR(IHFLX0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) |
| 3209 | C HEADER = ' LAEVT: x distribution 1' |
| 3210 | C CALL DT_OUTHGR(IHFLX1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) |
| 3211 | C HEADER = ' LAEVT: x distribution 2' |
| 3212 | C CALL DT_OUTHGR(IHFLX2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) |
| 3213 | C HEADER = ' LAEVT: E_g distribution 0' |
| 3214 | C CALL DT_OUTHGR(IHFLU0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) |
| 3215 | C HEADER = ' LAEVT: E_g distribution 1' |
| 3216 | C CALL DT_OUTHGR(IHFLU1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) |
| 3217 | C HEADER = ' LAEVT: E_g distribution 2' |
| 3218 | C CALL DT_OUTHGR(IHFLU2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) |
| 3219 | C HEADER = ' LAEVT: E_c distribution 0' |
| 3220 | C CALL DT_OUTHGR(IHFLE0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) |
| 3221 | C HEADER = ' LAEVT: E_c distribution 1' |
| 3222 | C CALL DT_OUTHGR(IHFLE1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) |
| 3223 | C HEADER = ' LAEVT: E_c distribution 2' |
| 3224 | C CALL DT_OUTHGR(IHFLE2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) |
| 3225 | |
| 3226 | * print run-statistics and histograms to output-unit 6 |
| 3227 | |
| 3228 | CALL PHO_PHIST(3000,DUM) |
| 3229 | |
| 3230 | IF (IXSTBL.EQ.0) CALL DT_STATIS(2) |
| 3231 | |
| 3232 | RETURN |
| 3233 | END |
| 3234 | * |
| 3235 | *===dtuini=============================================================* |
| 3236 | * |
| 3237 | CDECK ID>, DT_DTUINI |
| 3238 | SUBROUTINE DT_DTUINI(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR, |
| 3239 | & IDP,IEMU) |
| 3240 | |
| 3241 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 3242 | SAVE |
| 3243 | |
| 3244 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 3245 | |
| 3246 | * emulsion treatment |
| 3247 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), |
| 3248 | & NCOMPO,IEMUL |
| 3249 | * Glauber formalism: flags and parameters for statistics |
| 3250 | LOGICAL LPROD |
| 3251 | CHARACTER*8 CGLB |
| 3252 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD |
| 3253 | |
| 3254 | CALL DT_INIT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,IGLAU) |
| 3255 | CALL DT_STATIS(1) |
| 3256 | |
| 3257 | CALL PHO_PHIST(1000,DUM) |
| 3258 | |
| 3259 | IF (NCOMPO.LE.0) THEN |
| 3260 | CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU) |
| 3261 | ELSE |
| 3262 | DO 1 I=1,NCOMPO |
| 3263 | CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0) |
| 3264 | 1 CONTINUE |
| 3265 | ENDIF |
| 3266 | IF (IOGLB.NE.100) CALL DT_SIGEMU |
| 3267 | IEMU = IEMUL |
| 3268 | |
| 3269 | RETURN |
| 3270 | END |
| 3271 | * |
| 3272 | *===dtuout=============================================================* |
| 3273 | * |
| 3274 | CDECK ID>, DT_DTUOUT |
| 3275 | SUBROUTINE DT_DTUOUT |
| 3276 | |
| 3277 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 3278 | SAVE |
| 3279 | |
| 3280 | CALL PHO_PHIST(3000,DUM) |
| 3281 | |
| 3282 | CALL DT_STATIS(2) |
| 3283 | |
| 3284 | RETURN |
| 3285 | END |
| 3286 | * |
| 3287 | *===beam===============================================================* |
| 3288 | * |
| 3289 | CDECK ID>, DT_BEAMPR |
| 3290 | SUBROUTINE DT_BEAMPR(WHAT,PLAB,MODE) |
| 3291 | |
| 3292 | ************************************************************************ |
| 3293 | * Initialization of event generation * |
| 3294 | * This version dated 7.4.98 is written by S. Roesler. * |
| 3295 | ************************************************************************ |
| 3296 | |
| 3297 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 3298 | SAVE |
| 3299 | |
| 3300 | PARAMETER ( LINP = 5 , |
| 3301 | & LOUT = 6 , |
| 3302 | & LDAT = 9 ) |
| 3303 | |
| 3304 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10) |
| 3305 | PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0) |
| 3306 | |
| 3307 | LOGICAL LBEAM |
| 3308 | |
| 3309 | * event history |
| 3310 | |
| 3311 | PARAMETER (NMXHKK=200000) |
| 3312 | |
| 3313 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 3314 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 3315 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 3316 | * extended event history |
| 3317 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 3318 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 3319 | & IHIST(2,NMXHKK) |
| 3320 | * properties of interacting particles |
| 3321 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG |
| 3322 | * particle properties (BAMJET index convention) |
| 3323 | CHARACTER*8 ANAME |
| 3324 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 3325 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 3326 | * beam momenta |
| 3327 | COMMON /DTBEAM/ P1(4),P2(4) |
| 3328 | |
| 3329 | C DIMENSION WHAT(6),P1(4),P2(4),P1CMS(4),P2CMS(4) |
| 3330 | DIMENSION WHAT(6),P1CMS(4),P2CMS(4) |
| 3331 | |
| 3332 | DATA LBEAM /.FALSE./ |
| 3333 | |
| 3334 | GOTO (1,2) MODE |
| 3335 | |
| 3336 | 1 CONTINUE |
| 3337 | |
| 3338 | E1 = WHAT(1) |
| 3339 | IF (E1.LT.ZERO) E1 = DBLE(IPZ)/DBLE(IP)*ABS(WHAT(1)) |
| 3340 | E2 = WHAT(2) |
| 3341 | IF (E2.LT.ZERO) E2 = DBLE(ITZ)/DBLE(IT)*ABS(WHAT(2)) |
| 3342 | PP1 = SQRT( (E1+AAM(IJPROJ))*(E1-AAM(IJPROJ)) ) |
| 3343 | PP2 = SQRT( (E2+AAM(IJTARG))*(E2-AAM(IJTARG)) ) |
| 3344 | TH = 1.D-6*WHAT(3)/2.D0 |
| 3345 | PH = WHAT(4)*BOG |
| 3346 | P1(1) = PP1*SIN(TH)*COS(PH) |
| 3347 | P1(2) = PP1*SIN(TH)*SIN(PH) |
| 3348 | P1(3) = PP1*COS(TH) |
| 3349 | P1(4) = E1 |
| 3350 | P2(1) = PP2*SIN(TH)*COS(PH) |
| 3351 | P2(2) = PP2*SIN(TH)*SIN(PH) |
| 3352 | P2(3) = -PP2*COS(TH) |
| 3353 | P2(4) = E2 |
| 3354 | ECM = SQRT( (P1(4)+P2(4))**2-(P1(1)+P2(1))**2-(P1(2)+P2(2))**2 |
| 3355 | & -(P1(3)+P2(3))**2 ) |
| 3356 | ELAB = (ECM**2-AAM(IJPROJ)**2-AAM(IJTARG)**2)/(2.0D0*AAM(IJTARG)) |
| 3357 | PLAB = SQRT( (ELAB+AAM(IJPROJ))*(ELAB-AAM(IJPROJ)) ) |
| 3358 | BGX = (P1(1)+P2(1))/ECM |
| 3359 | BGY = (P1(2)+P2(2))/ECM |
| 3360 | BGZ = (P1(3)+P2(3))/ECM |
| 3361 | BGE = (P1(4)+P2(4))/ECM |
| 3362 | CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P1(1),P1(2),P1(3),P1(4), |
| 3363 | & P1TOT,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4)) |
| 3364 | CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P2(1),P2(2),P2(3),P2(4), |
| 3365 | & P2TOT,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4)) |
| 3366 | COD = P1CMS(3)/P1TOT |
| 3367 | C SID = SQRT((ONE-COD)*(ONE+COD)) |
| 3368 | PPT = SQRT(P1CMS(1)**2+P1CMS(2)**2) |
| 3369 | SID = PPT/P1TOT |
| 3370 | COF = ONE |
| 3371 | SIF = ZERO |
| 3372 | IF (P1TOT*SID.GT.TINY10) THEN |
| 3373 | COF = P1CMS(1)/(SID*P1TOT) |
| 3374 | SIF = P1CMS(2)/(SID*P1TOT) |
| 3375 | ANORF = SQRT(COF*COF+SIF*SIF) |
| 3376 | COF = COF/ANORF |
| 3377 | SIF = SIF/ANORF |
| 3378 | ENDIF |
| 3379 | **check |
| 3380 | C WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4) |
| 3381 | C WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4) |
| 3382 | C WRITE(LOUT,'(5E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),P1TOT |
| 3383 | C WRITE(LOUT,'(5E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),P2TOT |
| 3384 | C PAX = ZERO |
| 3385 | C PAY = ZERO |
| 3386 | C PAZ = P1TOT |
| 3387 | C PAE = SQRT(AAM(IJPROJ)**2+PAZ**2) |
| 3388 | C PBX = ZERO |
| 3389 | C PBY = ZERO |
| 3390 | C PBZ = -P2TOT |
| 3391 | C PBE = SQRT(AAM(IJTARG)**2+PBZ**2) |
| 3392 | C WRITE(LOUT,'(4E15.4)') PAX,PAY,PAZ,PAE |
| 3393 | C WRITE(LOUT,'(4E15.4)') PBX,PBY,PBZ,PBE |
| 3394 | C CALL DT_MYTRAN(1,PAX,PAY,PAZ,COD,SID,COF,SIF, |
| 3395 | C & P1CMS(1),P1CMS(2),P1CMS(3)) |
| 3396 | C CALL DT_MYTRAN(1,PBX,PBY,PBZ,COD,SID,COF,SIF, |
| 3397 | C & P2CMS(1),P2CMS(2),P2CMS(3)) |
| 3398 | C WRITE(LOUT,'(4E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4) |
| 3399 | C WRITE(LOUT,'(4E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4) |
| 3400 | C CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4), |
| 3401 | C & P1TOT,P1(1),P1(2),P1(3),P1(4)) |
| 3402 | C CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4), |
| 3403 | C & P2TOT,P2(1),P2(2),P2(3),P2(4)) |
| 3404 | C WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4) |
| 3405 | C WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4) |
| 3406 | C STOP |
| 3407 | ** |
| 3408 | |
| 3409 | LBEAM = .TRUE. |
| 3410 | |
| 3411 | RETURN |
| 3412 | |
| 3413 | 2 CONTINUE |
| 3414 | |
| 3415 | IF (LBEAM) THEN |
| 3416 | IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN |
| 3417 | DO 20 I=NPOINT(4),NHKK |
| 3418 | IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR. |
| 3419 | & (ISTHKK(I).EQ.1001)) THEN |
| 3420 | CALL DT_MYTRAN(1,PHKK(1,I),PHKK(2,I),PHKK(3,I), |
| 3421 | & COD,SID,COF,SIF,PXCMS,PYCMS,PZCMS) |
| 3422 | PECMS = PHKK(4,I) |
| 3423 | CALL DT_DALTRA(BGE,BGX,BGY,BGZ,PXCMS,PYCMS,PZCMS,PECMS, |
| 3424 | & PTOT,PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I)) |
| 3425 | ENDIF |
| 3426 | 20 CONTINUE |
| 3427 | ELSE |
| 3428 | MODE = -1 |
| 3429 | ENDIF |
| 3430 | |
| 3431 | RETURN |
| 3432 | END |
| 3433 | * |
| 3434 | *===eventb=============================================================* |
| 3435 | * |
| 3436 | CDECK ID>, DT_EVENTB |
| 3437 | SUBROUTINE DT_EVENTB(NCSY,IREJ) |
| 3438 | |
| 3439 | ************************************************************************ |
| 3440 | * Treatment of nucleon-nucleon interactions with full two-component * |
| 3441 | * Dual Parton Model. * |
| 3442 | * NCSY number of nucleon-nucleon interactions * |
| 3443 | * IREJ rejection flag * |
| 3444 | * This version dated 14.01.2000 is written by S. Roesler * |
| 3445 | ************************************************************************ |
| 3446 | |
| 3447 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 3448 | SAVE |
| 3449 | |
| 3450 | PARAMETER ( LINP = 5 , |
| 3451 | & LOUT = 6 , |
| 3452 | & LDAT = 9 ) |
| 3453 | |
| 3454 | PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0) |
| 3455 | |
| 3456 | * event history |
| 3457 | |
| 3458 | PARAMETER (NMXHKK=200000) |
| 3459 | |
| 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 | |
| 3667 | CALL PHO_SETPAR(1,22,0,VIRT) |
| 3668 | |
| 3669 | ELSE |
| 3670 | |
| 3671 | CALL PHO_SETPAR(1,IDHKK(MOP),0,ZERO) |
| 3672 | |
| 3673 | ENDIF |
| 3674 | |
| 3675 | CALL PHO_SETPAR(2,IDHKK(MOT),0,ZERO) |
| 3676 | |
| 3677 | * |
| 3678 | * initialize rejection loop counter for anomalous processes |
| 3679 | IRJANO = 0 |
| 3680 | 800 CONTINUE |
| 3681 | IRJANO = IRJANO+1 |
| 3682 | * |
| 3683 | * temporary fix for ifano problem |
| 3684 | IFANO(1) = 0 |
| 3685 | IFANO(2) = 0 |
| 3686 | * |
| 3687 | * generate complete hadron/nucleon/photon-nucleon event with PHOJET |
| 3688 | |
| 3689 | CALL PHO_EVENT(2,PPNN,PTNN,DUM,IREJ1) |
| 3690 | |
| 3691 | * |
| 3692 | * for photons: special consistency check for anomalous interactions |
| 3693 | IF (IJPROJ.EQ.7) THEN |
| 3694 | IF (IRJANO.LT.30) THEN |
| 3695 | IF (IFANO(1).NE.0) THEN |
| 3696 | * here, an anomalous interaction was generated. Check if it |
| 3697 | * was also requested. Otherwise reject this event. |
| 3698 | IF (IDIREC.EQ.0) GOTO 800 |
| 3699 | ELSE |
| 3700 | * here, an anomalous interaction was not generated. Check if it |
| 3701 | * was requested in which case we need to reject this event. |
| 3702 | IF (IDIREC.EQ.2) GOTO 800 |
| 3703 | ENDIF |
| 3704 | ELSE |
| 3705 | WRITE(LOUT,*) ' DT_EVENTB: Warning! IRJANO > 30 ', |
| 3706 | & IRJANO,IDIREC,NEVHKK |
| 3707 | ENDIF |
| 3708 | ENDIF |
| 3709 | * |
| 3710 | * copy back original settings of PHOJET process and min. bias flags |
| 3711 | DO 10 K=1,11 |
| 3712 | IPRON(K,1) = KPRON(K) |
| 3713 | 10 CONTINUE |
| 3714 | ISWMDL(2) = ISWSAV |
| 3715 | * |
| 3716 | * check if PHOJET has rejected this event |
| 3717 | IF (IREJ1.NE.0) THEN |
| 3718 | C IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)') |
| 3719 | WRITE(LOUT,'(1X,A,I4)') |
| 3720 | & 'EVENTB: chain system rejected',IDIREC |
| 3721 | |
| 3722 | CALL PHO_PREVNT(0) |
| 3723 | |
| 3724 | GOTO 9999 |
| 3725 | ENDIF |
| 3726 | * |
| 3727 | * copy partons and strings from PHOJET common back into DTEVT for |
| 3728 | * external fragmentation |
| 3729 | MO1 = NC |
| 3730 | MO2 = NC+3 |
| 3731 | *! uncomment this line for internal phojet-fragmentation |
| 3732 | C CALL DT_GETFSP(MO1,MO2,PPNN,PTNN,-1) |
| 3733 | NPHOSC = NPHOSC+1 |
| 3734 | CALL DT_GETPJE(MO1,MO2,PPNN,PTNN,-1,NPHOSC,IREJ1) |
| 3735 | IF (IREJ1.NE.0) THEN |
| 3736 | IF (IOULEV(1).GT.0) |
| 3737 | & WRITE(LOUT,'(1X,A,I4)') 'EVENTB: chain system rejected 1' |
| 3738 | GOTO 9999 |
| 3739 | ENDIF |
| 3740 | * |
| 3741 | * update statistics counter |
| 3742 | ICEVTG(IDCH(NC),29) = ICEVTG(IDCH(NC),29)+1 |
| 3743 | * |
| 3744 | *----------------------------------------------------------------------- |
| 3745 | * this interaction involves "remnants" |
| 3746 | * |
| 3747 | ELSE |
| 3748 | * |
| 3749 | * total mass of this system |
| 3750 | PPTOT = SQRT(PTOT(1)**2+PTOT(2)**2+PTOT(3)**2) |
| 3751 | AMTOT2 = (PTOT(4)-PPTOT)*(PTOT(4)+PPTOT) |
| 3752 | IF (AMTOT2.LT.ZERO) THEN |
| 3753 | AMTOT = ZERO |
| 3754 | ELSE |
| 3755 | AMTOT = SQRT(AMTOT2) |
| 3756 | ENDIF |
| 3757 | * |
| 3758 | * systems with masses larger than elojet are treated with PHOJET |
| 3759 | IF (AMTOT.GT.ELOJET) THEN |
| 3760 | * |
| 3761 | * initialize PHOJET-variables for remnant/valence-partons |
| 3762 | * projectile parton flavors and valence flag |
| 3763 | IHFLD(1,1) = IDHKK(NC) |
| 3764 | IHFLD(1,2) = IDHKK(NC+2) |
| 3765 | IHFLS(1) = 0 |
| 3766 | IF ((IDCH(NC).EQ.6).OR.(IDCH(NC).EQ.7) |
| 3767 | & .OR.(IDCH(NC).EQ.8)) IHFLS(1) = 1 |
| 3768 | * target parton flavors and valence flag |
| 3769 | IHFLD(2,1) = IDHKK(NC+1) |
| 3770 | IHFLD(2,2) = IDHKK(NC+3) |
| 3771 | IHFLS(2) = 0 |
| 3772 | IF ((IDCH(NC).EQ.4).OR.(IDCH(NC).EQ.5) |
| 3773 | & .OR.(IDCH(NC).EQ.8)) IHFLS(2) = 1 |
| 3774 | * flag signalizing PHOJET how to treat the remnant: |
| 3775 | * iremn = -1 sea-quark remnant: PHOJET takes flavors from ihfld |
| 3776 | * iremn > -1 valence remnant: PHOJET assumes flavors according |
| 3777 | * to mother particle |
| 3778 | IREMN1 = IHFLS(1)-1 |
| 3779 | IREMN2 = IHFLS(2)-1 |
| 3780 | * |
| 3781 | * initialize the incoming particles in PHOJET |
| 3782 | IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN |
| 3783 | |
| 3784 | CALL PHO_SETPAR(1,22,IREMN1,VIRT) |
| 3785 | |
| 3786 | ELSE |
| 3787 | |
| 3788 | CALL PHO_SETPAR(1,IDHKK(MOP),IREMN1,ZERO) |
| 3789 | |
| 3790 | ENDIF |
| 3791 | |
| 3792 | CALL PHO_SETPAR(2,IDHKK(MOT),IREMN2,ZERO) |
| 3793 | |
| 3794 | * |
| 3795 | * calculate Lorentz parameter of the nucleon-nucleon cm-system |
| 3796 | PPTOTN = SQRT(PTOTNN(1)**2+PTOTNN(2)**2+PTOTNN(3)**2) |
| 3797 | AMNN = SQRT( (PTOTNN(4)-PPTOTN)*(PTOTNN(4)+PPTOTN) ) |
| 3798 | BGX = PTOTNN(1)/AMNN |
| 3799 | BGY = PTOTNN(2)/AMNN |
| 3800 | BGZ = PTOTNN(3)/AMNN |
| 3801 | GAM = PTOTNN(4)/AMNN |
| 3802 | * transform interacting nucleons into nucleon-nucleon cm-system |
| 3803 | CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ, |
| 3804 | & PPNN(1),PPNN(2),PPNN(3),PPNN(4),PPCMS, |
| 3805 | & PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4)) |
| 3806 | CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ, |
| 3807 | & PTNN(1),PTNN(2),PTNN(3),PTNN(4),PTCMS, |
| 3808 | & PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4)) |
| 3809 | * transform (total) momenta of the proj and targ partons into |
| 3810 | * nucleon-nucleon cm-system |
| 3811 | CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ, |
| 3812 | & PP(1),PP(2),PP(3),PP(4), |
| 3813 | & PPTSUB,PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4)) |
| 3814 | CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ, |
| 3815 | & PT(1),PT(2),PT(3),PT(4), |
| 3816 | & PTTSUB,PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4)) |
| 3817 | * energy fractions of the proj and targ partons |
| 3818 | XPSUB = MIN(PPSUB(4)/PPTCMS(4),ONE) |
| 3819 | XTSUB = MIN(PTSUB(4)/PTTCMS(4),ONE) |
| 3820 | *** |
| 3821 | * testprint |
| 3822 | c PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 + |
| 3823 | c & (PPTCMS(2)+PTTCMS(2))**2 + |
| 3824 | c & (PPTCMS(3)+PTTCMS(3))**2 ) |
| 3825 | c EOLDCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) * |
| 3826 | c & (PPTCMS(4)+PTTCMS(4)+PTOTCM) ) |
| 3827 | c PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 + |
| 3828 | c & (PPSUB(2)+PTSUB(2))**2 + |
| 3829 | c & (PPSUB(3)+PTSUB(3))**2 ) |
| 3830 | c EOLDSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) * |
| 3831 | c & (PPSUB(4)+PTSUB(4)+PTOTSU) ) |
| 3832 | *** |
| 3833 | * |
| 3834 | * save current settings of PHOJET process and min. bias flags |
| 3835 | DO 7 K=1,11 |
| 3836 | KPRON(K) = IPRON(K,1) |
| 3837 | 7 CONTINUE |
| 3838 | * disallow direct photon int. (does not make sense here anyway) |
| 3839 | IPRON(8,1) = 0 |
| 3840 | * disallow double pomeron processes (due to technical problems |
| 3841 | * in PHOJET, needs to be solved sometime) |
| 3842 | IPRON(4,1) = 0 |
| 3843 | * disallow diffraction for sea-diquarks |
| 3844 | IF ((IABS(IHFLD(1,1)).GT.1100).AND. |
| 3845 | & (IABS(IHFLD(1,2)).GT.1100)) THEN |
| 3846 | IPRON(3,1) = 0 |
| 3847 | IPRON(6,1) = 0 |
| 3848 | ENDIF |
| 3849 | IF ((IABS(IHFLD(2,1)).GT.1100).AND. |
| 3850 | & (IABS(IHFLD(2,2)).GT.1100)) THEN |
| 3851 | IPRON(3,1) = 0 |
| 3852 | IPRON(5,1) = 0 |
| 3853 | ENDIF |
| 3854 | * |
| 3855 | * we need massless partons: transform them on mass shell |
| 3856 | XMP = ZERO |
| 3857 | XMT = ZERO |
| 3858 | DO 6 K=1,4 |
| 3859 | PPTMP(K) = PPSUB(K) |
| 3860 | PTTMP(K) = PTSUB(K) |
| 3861 | 6 CONTINUE |
| 3862 | CALL DT_MASHEL(PPTMP,PTTMP,XMP,XMT,PPSUB,PTSUB,IREJ1) |
| 3863 | PPSUTO = SQRT(PPSUB(1)**2+PPSUB(2)**2+PPSUB(3)**2) |
| 3864 | PTSUTO = SQRT(PTSUB(1)**2+PTSUB(2)**2+PTSUB(3)**2) |
| 3865 | PSUTOT = SQRT((PPSUB(1)+PTSUB(1))**2+ |
| 3866 | & (PPSUB(2)+PTSUB(2))**2+(PPSUB(3)+PTSUB(3))**2) |
| 3867 | * total energy of the subsysten after mass transformation |
| 3868 | * (should be the same as before..) |
| 3869 | SECM = SQRT( (PPSUB(4)+PTSUB(4)-PSUTOT)* |
| 3870 | & (PPSUB(4)+PTSUB(4)+PSUTOT) ) |
| 3871 | * |
| 3872 | * after mass shell transformation the x_sub - relation has to be |
| 3873 | * corrected. We therefore create "pseudo-momenta" of mother-nucleons. |
| 3874 | * |
| 3875 | * The old version was to scale based on the original x_sub and the |
| 3876 | * 4-momenta of the subsystem. At very high energy this could lead to |
| 3877 | * "pseudo-cm energies" of the parent system considerably exceeding |
| 3878 | * the true cm energy. Now we keep the true cm energy and calculate |
| 3879 | * new x_sub instead. |
| 3880 | C old version PPTCMS(4) = PPSUB(4)/XPSUB |
| 3881 | PPTCMS(4) = MAX(PPTCMS(4),PPSUB(4)) |
| 3882 | XPSUB = PPSUB(4)/PPTCMS(4) |
| 3883 | IF (IJPROJ.EQ.7) THEN |
| 3884 | AMP2 = PHKK(5,MOT)**2 |
| 3885 | PTOT1 = SQRT(PPTCMS(4)**2-AMP2) |
| 3886 | ELSE |
| 3887 | *??????? |
| 3888 | PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOP)) |
| 3889 | & *(PPTCMS(4)+PHKK(5,MOP))) |
| 3890 | C PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOT)) |
| 3891 | C & *(PPTCMS(4)+PHKK(5,MOT))) |
| 3892 | ENDIF |
| 3893 | C old version PTTCMS(4) = PTSUB(4)/XTSUB |
| 3894 | PTTCMS(4) = MAX(PTTCMS(4),PTSUB(4)) |
| 3895 | XTSUB = PTSUB(4)/PTTCMS(4) |
| 3896 | PTOT2 = SQRT((PTTCMS(4)-PHKK(5,MOT)) |
| 3897 | & *(PTTCMS(4)+PHKK(5,MOT))) |
| 3898 | DO 4 K=1,3 |
| 3899 | PPTCMS(K) = PTOT1*PPSUB(K)/PPSUTO |
| 3900 | PTTCMS(K) = PTOT2*PTSUB(K)/PTSUTO |
| 3901 | 4 CONTINUE |
| 3902 | *** |
| 3903 | * testprint |
| 3904 | * |
| 3905 | * ppnn / ptnn - momenta of the int. nucleons (cms, negl. Fermi) |
| 3906 | * ptotnn - total momentum of the int. nucleons (cms, negl. Fermi) |
| 3907 | * pptcms/ pttcms - momenta of the interacting nucleons (cms) |
| 3908 | * pp1,2 / pt1,2 - momenta of the four partons |
| 3909 | * |
| 3910 | * pp / pt - total momenta of the pr/ta partons (cms, negl. Fermi) |
| 3911 | * ptot - total momentum of the four partons (cms, negl. Fermi) |
| 3912 | * ppsub / ptsub - total momenta of the proj / targ partons (cms) |
| 3913 | * |
| 3914 | c PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 + |
| 3915 | c & (PPTCMS(2)+PTTCMS(2))**2 + |
| 3916 | c & (PPTCMS(3)+PTTCMS(3))**2 ) |
| 3917 | c ENEWCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) * |
| 3918 | c & (PPTCMS(4)+PTTCMS(4)+PTOTCM) ) |
| 3919 | c PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 + |
| 3920 | c & (PPSUB(2)+PTSUB(2))**2 + |
| 3921 | c & (PPSUB(3)+PTSUB(3))**2 ) |
| 3922 | c ENEWSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) * |
| 3923 | c & (PPSUB(4)+PTSUB(4)+PTOTSU) ) |
| 3924 | c IF (ENEWCM/EOLDCM.GT.1.1D0) THEN |
| 3925 | c WRITE(*,*) ' EOLDCM, ENEWCM : ',EOLDCM,ENEWCM |
| 3926 | c WRITE(*,*) ' EOLDSU, ENEWSU : ',EOLDSU,ENEWSU |
| 3927 | c WRITE(*,*) ' XPSUB, XTSUB : ',XPSUB,XTSUB |
| 3928 | c ENDIF |
| 3929 | c BBGX = (PPTCMS(1)+PTTCMS(1))/ENEWCM |
| 3930 | c BBGY = (PPTCMS(2)+PTTCMS(2))/ENEWCM |
| 3931 | c BBGZ = (PPTCMS(3)+PTTCMS(3))/ENEWCM |
| 3932 | c BGAM = (PPTCMS(4)+PTTCMS(4))/ENEWCM |
| 3933 | * transform interacting nucleons into nucleon-nucleon cm-system |
| 3934 | c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ, |
| 3935 | c & PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4),PPTOT, |
| 3936 | c & PPNEW1,PPNEW2,PPNEW3,PPNEW4) |
| 3937 | c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ, |
| 3938 | c & PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4),PTTOT, |
| 3939 | c & PTNEW1,PTNEW2,PTNEW3,PTNEW4) |
| 3940 | c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ, |
| 3941 | c & PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4),PPTOT, |
| 3942 | c & PPSUB1,PPSUB2,PPSUB3,PPSUB4) |
| 3943 | c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ, |
| 3944 | c & PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4),PTTOT, |
| 3945 | c & PTSUB1,PTSUB2,PTSUB3,PTSUB4) |
| 3946 | c PTSTCM = SQRT( (PPNEW1+PTNEW1)**2 + |
| 3947 | c & (PPNEW2+PTNEW2)**2 + |
| 3948 | c & (PPNEW3+PTNEW3)**2 ) |
| 3949 | c ETSTCM = SQRT( (PPNEW4+PTNEW4-PTSTCM) * |
| 3950 | c & (PPNEW4+PTNEW4+PTSTCM) ) |
| 3951 | c PTSTSU = SQRT( (PPSUB1+PTSUB1)**2 + |
| 3952 | c & (PPSUB2+PTSUB2)**2 + |
| 3953 | c & (PPSUB3+PTSUB3)**2 ) |
| 3954 | c ETSTSU = SQRT( (PPSUB4+PTSUB4-PTSTSU) * |
| 3955 | c & (PPSUB4+PTSUB4+PTSTSU) ) |
| 3956 | C WRITE(*,*) ' mother cmE :' |
| 3957 | C WRITE(*,*) ETSTCM,ENEWCM |
| 3958 | C WRITE(*,*) ' subsystem cmE :' |
| 3959 | C WRITE(*,*) ETSTSU,ENEWSU |
| 3960 | C WRITE(*,*) ' projectile mother :' |
| 3961 | C WRITE(*,*) PPNEW1,PPNEW2,PPNEW3,PPNEW4 |
| 3962 | C WRITE(*,*) ' target mother :' |
| 3963 | C WRITE(*,*) PTNEW1,PTNEW2,PTNEW3,PTNEW4 |
| 3964 | C WRITE(*,*) ' projectile subsystem:' |
| 3965 | C WRITE(*,*) PPSUB1,PPSUB2,PPSUB3,PPSUB4 |
| 3966 | C WRITE(*,*) ' target subsystem:' |
| 3967 | C WRITE(*,*) PTSUB1,PTSUB2,PTSUB3,PTSUB4 |
| 3968 | C WRITE(*,*) ' projectile subsystem should be:' |
| 3969 | C WRITE(*,*) ZERO,ZERO,XPSUB*ETSTCM/2.0D0, |
| 3970 | C & XPSUB*ETSTCM/2.0D0 |
| 3971 | C WRITE(*,*) ' target subsystem should be:' |
| 3972 | C WRITE(*,*) ZERO,ZERO,-XTSUB*ETSTCM/2.0D0, |
| 3973 | C & XTSUB*ETSTCM/2.0D0 |
| 3974 | C WRITE(*,*) ' subsystem cmE should be: ' |
| 3975 | C WRITE(*,*) SQRT(XPSUB*XTSUB)*ETSTCM,XPSUB,XTSUB |
| 3976 | *** |
| 3977 | * |
| 3978 | * generate complete remnant - nucleon/remnant event with PHOJET |
| 3979 | |
| 3980 | CALL PHO_EVENT(3,PPTCMS,PTTCMS,DUM,IREJ1) |
| 3981 | |
| 3982 | * |
| 3983 | * copy back original settings of PHOJET process flags |
| 3984 | DO 11 K=1,11 |
| 3985 | IPRON(K,1) = KPRON(K) |
| 3986 | 11 CONTINUE |
| 3987 | * |
| 3988 | * check if PHOJET has rejected this event |
| 3989 | IF (IREJ1.NE.0) THEN |
| 3990 | IF (IOULEV(1).GT.0) |
| 3991 | & WRITE(LOUT,'(1X,A)') 'EVENTB: chain system rejected' |
| 3992 | WRITE(LOUT,*) |
| 3993 | & 'XPSUB,XTSUB,SECM ',XPSUB,XTSUB,SECM,AMTOT |
| 3994 | |
| 3995 | CALL PHO_PREVNT(0) |
| 3996 | |
| 3997 | GOTO 9999 |
| 3998 | ENDIF |
| 3999 | * |
| 4000 | * copy partons and strings from PHOJET common back into DTEVT for |
| 4001 | * external fragmentation |
| 4002 | MO1 = NC |
| 4003 | MO2 = NC+3 |
| 4004 | *! uncomment this line for internal phojet-fragmentation |
| 4005 | C CALL DT_GETFSP(MO1,MO2,PP,PT,1) |
| 4006 | NPHOSC = NPHOSC+1 |
| 4007 | CALL DT_GETPJE(MO1,MO2,PP,PT,1,NPHOSC,IREJ1) |
| 4008 | IF (IREJ1.NE.0) THEN |
| 4009 | IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)') |
| 4010 | & 'EVENTB: chain system rejected 2' |
| 4011 | GOTO 9999 |
| 4012 | ENDIF |
| 4013 | * |
| 4014 | * update statistics counter |
| 4015 | ICEVTG(IDCH(NC),2) = ICEVTG(IDCH(NC),2)+1 |
| 4016 | * |
| 4017 | *----------------------------------------------------------------------- |
| 4018 | * two-chain approx. for smaller systems |
| 4019 | * |
| 4020 | ELSE |
| 4021 | * |
| 4022 | NDTUSC = NDTUSC+1 |
| 4023 | * special flag for double-Pomeron statistics |
| 4024 | IPOPO = 0 |
| 4025 | * |
| 4026 | * pick up flavors at the ends of the two chains |
| 4027 | IFP1 = IDHKK(NC) |
| 4028 | IFT1 = IDHKK(NC+1) |
| 4029 | IFP2 = IDHKK(NC+2) |
| 4030 | IFT2 = IDHKK(NC+3) |
| 4031 | * ..and the indices of the mothers |
| 4032 | MOP1 = NC |
| 4033 | MOT1 = NC+1 |
| 4034 | MOP2 = NC+2 |
| 4035 | MOT2 = NC+3 |
| 4036 | CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2, |
| 4037 | & IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1) |
| 4038 | * |
| 4039 | * check if this chain system was rejected |
| 4040 | IF (IREJ1.GT.0) THEN |
| 4041 | IF (IOULEV(1).GT.0) THEN |
| 4042 | WRITE(LOUT,*) 'rejected 1 in EVENTB' |
| 4043 | WRITE(LOUT,'(1X,4(I6,4E12.3,/),E12.3)') |
| 4044 | & IFP1,PP1,IFT1,PT1,IFP2,PP2,IFT2,PT2,AMTOT |
| 4045 | ENDIF |
| 4046 | IRHHA = IRHHA+1 |
| 4047 | GOTO 9999 |
| 4048 | ENDIF |
| 4049 | * the following lines are for sea-sea chains rejected in GETCSY |
| 4050 | IF (IREJ1.EQ.-1) NDTUSC = NDTUSC-1 |
| 4051 | ICEVTG(IDCH(NC),1) = ICEVTG(IDCH(NC),1)+1 |
| 4052 | ENDIF |
| 4053 | * |
| 4054 | ENDIF |
| 4055 | * |
| 4056 | * update statistics counter |
| 4057 | ICEVTG(IDCH(NC),0) = ICEVTG(IDCH(NC),0)+1 |
| 4058 | * |
| 4059 | NC = NC+4 |
| 4060 | * |
| 4061 | 2 CONTINUE |
| 4062 | * |
| 4063 | *----------------------------------------------------------------------- |
| 4064 | * treatment of low-mass chains (if there are any) |
| 4065 | * |
| 4066 | IF (NDTUSC.GT.0) THEN |
| 4067 | * |
| 4068 | * correct chains of very low masses for possible resonances |
| 4069 | IF (IRESCO.EQ.1) THEN |
| 4070 | CALL DT_EVTRES(IREJ1) |
| 4071 | IF (IREJ1.GT.0) THEN |
| 4072 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2a in EVENTB' |
| 4073 | IRRES(1) = IRRES(1)+1 |
| 4074 | GOTO 9999 |
| 4075 | ENDIF |
| 4076 | ENDIF |
| 4077 | * fragmentation of low-mass chains |
| 4078 | *! uncomment this line for internal phojet-fragmentation |
| 4079 | * (of course it will still be fragmented by DPMJET-routines but it |
| 4080 | * has to be done here instead of further below) |
| 4081 | C CALL DT_EVTFRA(IREJ1) |
| 4082 | C IF (IREJ1.GT.0) THEN |
| 4083 | C IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2b in EVENTB' |
| 4084 | C IRFRAG = IRFRAG+1 |
| 4085 | C GOTO 9999 |
| 4086 | C ENDIF |
| 4087 | ELSE |
| 4088 | *! uncomment this line for internal phojet-fragmentation |
| 4089 | C NPOINT(4) = NHKK+1 |
| 4090 | IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1 |
| 4091 | ENDIF |
| 4092 | * |
| 4093 | *----------------------------------------------------------------------- |
| 4094 | * new di-quark breaking mechanisms |
| 4095 | * |
| 4096 | MXLEFT = 2 |
| 4097 | CALL DT_CHASTA(0) |
| 4098 | IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0) |
| 4099 | & .OR.(PDBSEA(3).GT.0.0D0)) THEN |
| 4100 | CALL DT_DIQBRK |
| 4101 | MXLEFT = 4 |
| 4102 | ENDIF |
| 4103 | * |
| 4104 | *----------------------------------------------------------------------- |
| 4105 | * hadronize this event |
| 4106 | * |
| 4107 | * hadronize PHOJET chain systems |
| 4108 | NPYMAX = 0 |
| 4109 | NPJE = NPHOSC/MXPHFR |
| 4110 | IF (MXPHFR.LT.MXLEFT) MXLEFT = 2 |
| 4111 | IF (NPJE.GT.1) THEN |
| 4112 | NLEFT = NPHOSC-NPJE*MXPHFR |
| 4113 | DO 20 JFRG=1,NPJE |
| 4114 | NFRG = JFRG*MXPHFR |
| 4115 | IF ((JFRG.EQ.NPJE).AND.(NLEFT.LE.MXLEFT)) THEN |
| 4116 | CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1) |
| 4117 | IF (IREJ1.GT.0) GOTO 22 |
| 4118 | NLEFT = 0 |
| 4119 | ELSE |
| 4120 | CALL DT_EVTFRG(1,NFRG,NPYMEM,IREJ1) |
| 4121 | IF (IREJ1.GT.0) GOTO 22 |
| 4122 | ENDIF |
| 4123 | IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM |
| 4124 | 20 CONTINUE |
| 4125 | IF (NLEFT.GT.0) THEN |
| 4126 | CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1) |
| 4127 | IF (IREJ1.GT.0) GOTO 22 |
| 4128 | IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM |
| 4129 | ENDIF |
| 4130 | ELSE |
| 4131 | CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1) |
| 4132 | IF (IREJ1.GT.0) GOTO 22 |
| 4133 | IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM |
| 4134 | ENDIF |
| 4135 | * |
| 4136 | * check max. filling level of jetset common and |
| 4137 | * reduce mxphfr if necessary |
| 4138 | IF (NPYMAX.GT.3000) THEN |
| 4139 | IF (NPYMAX.GT.3500) THEN |
| 4140 | MXPHFR = MAX(1,MXPHFR-2) |
| 4141 | ELSE |
| 4142 | MXPHFR = MAX(1,MXPHFR-1) |
| 4143 | ENDIF |
| 4144 | C WRITE(LOUT,*) ' EVENTB: Mxphfr reduced to ',MXPHFR |
| 4145 | ENDIF |
| 4146 | * |
| 4147 | * hadronize DTUNUC chain systems |
| 4148 | 23 CONTINUE |
| 4149 | IBACK = MXDTFR |
| 4150 | CALL DT_EVTFRG(2,IBACK,NPYMEM,IREJ2) |
| 4151 | IF (IREJ2.GT.0) GOTO 22 |
| 4152 | * |
| 4153 | * check max. filling level of jetset common and |
| 4154 | * reduce mxdtfr if necessary |
| 4155 | IF (NPYMEM.GT.3000) THEN |
| 4156 | IF (NPYMEM.GT.3500) THEN |
| 4157 | MXDTFR = MAX(1,MXDTFR-20) |
| 4158 | ELSE |
| 4159 | MXDTFR = MAX(1,MXDTFR-10) |
| 4160 | ENDIF |
| 4161 | C WRITE(LOUT,*) ' EVENTB: Mxdtfr reduced to ',MXDTFR |
| 4162 | ENDIF |
| 4163 | * |
| 4164 | IF (IBACK.EQ.-1) GOTO 23 |
| 4165 | * |
| 4166 | 22 CONTINUE |
| 4167 | C CALL DT_EVTFRG(1,IREJ1) |
| 4168 | C CALL DT_EVTFRG(2,IREJ2) |
| 4169 | IF ((IREJ1.GT.0).OR.(IREJ2.GT.0)) THEN |
| 4170 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTB' |
| 4171 | IRFRAG = IRFRAG+1 |
| 4172 | GOTO 9999 |
| 4173 | ENDIF |
| 4174 | * |
| 4175 | * get final state particles from /DTEVTP/ |
| 4176 | *! uncomment this line for internal phojet-fragmentation |
| 4177 | C CALL DT_GETFSP(IDUM,IDUM,PP,PT,2) |
| 4178 | |
| 4179 | IF (IJPROJ.NE.7) |
| 4180 | & CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,88,IREJ3) |
| 4181 | C IF (IREJ3.NE.0) GOTO 9999 |
| 4182 | |
| 4183 | RETURN |
| 4184 | |
| 4185 | 9999 CONTINUE |
| 4186 | IREVT = IREVT+1 |
| 4187 | IREJ = 1 |
| 4188 | RETURN |
| 4189 | END |
| 4190 | * |
| 4191 | *===getpje=============================================================* |
| 4192 | * |
| 4193 | CDECK ID>, DT_GETPJE |
| 4194 | SUBROUTINE DT_GETPJE(MO1,MO2,PP,PT,MODE,IPJE,IREJ) |
| 4195 | |
| 4196 | ************************************************************************ |
| 4197 | * This subroutine copies PHOJET partons and strings from POEVT1 into * |
| 4198 | * DTEVT1. * |
| 4199 | * MO1,MO2 indices of first and last mother-parton in DTEVT1 * |
| 4200 | * PP,PT 4-momenta of projectile/target being handled by * |
| 4201 | * PHOJET * |
| 4202 | * This version dated 11.12.99 is written by S. Roesler * |
| 4203 | ************************************************************************ |
| 4204 | |
| 4205 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 4206 | SAVE |
| 4207 | |
| 4208 | PARAMETER ( LINP = 5 , |
| 4209 | & LOUT = 6 , |
| 4210 | & LDAT = 9 ) |
| 4211 | |
| 4212 | PARAMETER (TINY10=1.0D-10,TINY1=1.0D-1, |
| 4213 | & ZERO=0.0D0,ONE=1.0D0,OHALF=0.5D0) |
| 4214 | |
| 4215 | LOGICAL LFLIP |
| 4216 | |
| 4217 | * event history |
| 4218 | |
| 4219 | PARAMETER (NMXHKK=200000) |
| 4220 | |
| 4221 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 4222 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 4223 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 4224 | * extended event history |
| 4225 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 4226 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 4227 | & IHIST(2,NMXHKK) |
| 4228 | * Lorentz-parameters of the current interaction |
| 4229 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, |
| 4230 | & UMO,PPCM,EPROJ,PPROJ |
| 4231 | * DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem |
| 4232 | COMMON /DTLTSU/ BGX,BGY,BGZ,GAM |
| 4233 | * flags for input different options |
| 4234 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 4235 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 4236 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 4237 | * statistics: double-Pomeron exchange |
| 4238 | COMMON /DTFLG2/ INTFLG,IPOPO |
| 4239 | * statistics |
| 4240 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, |
| 4241 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), |
| 4242 | & ICEVTG(8,0:30) |
| 4243 | * rejection counter |
| 4244 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, |
| 4245 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, |
| 4246 | & IREXCI(3),IRDIFF(2),IRINC |
| 4247 | |
| 4248 | C standard particle data interface |
| 4249 | INTEGER NMXHEP |
| 4250 | |
| 4251 | PARAMETER (NMXHEP=4000) |
| 4252 | |
| 4253 | INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP |
| 4254 | DOUBLE PRECISION PHEP,VHEP |
| 4255 | COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP), |
| 4256 | & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP), |
| 4257 | & VHEP(4,NMXHEP) |
| 4258 | C extension to standard particle data interface (PHOJET specific) |
| 4259 | INTEGER IMPART,IPHIST,ICOLOR |
| 4260 | COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP) |
| 4261 | |
| 4262 | C color string configurations including collapsed strings and hadrons |
| 4263 | INTEGER MSTR |
| 4264 | PARAMETER (MSTR=500) |
| 4265 | INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD |
| 4266 | COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR), |
| 4267 | & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR), |
| 4268 | & NNCH(MSTR),IBHAD(MSTR),ISTR |
| 4269 | C general process information |
| 4270 | INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON |
| 4271 | COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4) |
| 4272 | C model switches and parameters |
| 4273 | CHARACTER*8 MDLNA |
| 4274 | INTEGER ISWMDL,IPAMDL |
| 4275 | DOUBLE PRECISION PARMDL |
| 4276 | COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400) |
| 4277 | C event debugging information |
| 4278 | INTEGER NMAXD |
| 4279 | PARAMETER (NMAXD=100) |
| 4280 | INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO, |
| 4281 | & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD |
| 4282 | COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG, |
| 4283 | & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD |
| 4284 | |
| 4285 | DIMENSION PP(4),PT(4) |
| 4286 | DATA MAXLOP /10000/ |
| 4287 | |
| 4288 | INHKK = NHKK |
| 4289 | LFLIP = .TRUE. |
| 4290 | 1 CONTINUE |
| 4291 | NPVAL = 0 |
| 4292 | NTVAL = 0 |
| 4293 | IREJ = 0 |
| 4294 | |
| 4295 | * store initial momenta for energy-momentum conservation check |
| 4296 | IF (LEMCCK) THEN |
| 4297 | CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM1,IDUM2) |
| 4298 | CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM1,IDUM2) |
| 4299 | ENDIF |
| 4300 | * copy partons and strings from POEVT1 into DTEVT1 |
| 4301 | DO 11 I=1,ISTR |
| 4302 | C IF ((NCODE(I).EQ.-99).AND.(IPAMDL(17).EQ.0)) THEN |
| 4303 | IF (NCODE(I).EQ.-99) THEN |
| 4304 | IDXSTG = NPOS(1,I) |
| 4305 | IDSTG = IDHEP(IDXSTG) |
| 4306 | PX = PHEP(1,IDXSTG) |
| 4307 | PY = PHEP(2,IDXSTG) |
| 4308 | PZ = PHEP(3,IDXSTG) |
| 4309 | PE = PHEP(4,IDXSTG) |
| 4310 | IF (MODE.LT.0) THEN |
| 4311 | ISTAT = 70000+IPJE |
| 4312 | CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PX,PY,PZ,PE, |
| 4313 | & 11,IDSTG,0) |
| 4314 | IF (LEMCCK) THEN |
| 4315 | PX = -PX |
| 4316 | PY = -PY |
| 4317 | PZ = -PZ |
| 4318 | PE = -PE |
| 4319 | CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2) |
| 4320 | ENDIF |
| 4321 | ELSE |
| 4322 | CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP, |
| 4323 | & PPX,PPY,PPZ,PPE) |
| 4324 | ISTAT = 70000+IPJE |
| 4325 | CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PPX,PPY,PPZ,PPE, |
| 4326 | & 11,IDSTG,0) |
| 4327 | IF (LEMCCK) THEN |
| 4328 | PX = -PPX |
| 4329 | PY = -PPY |
| 4330 | PZ = -PPZ |
| 4331 | PE = -PPE |
| 4332 | CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2) |
| 4333 | ENDIF |
| 4334 | ENDIF |
| 4335 | NOBAM(NHKK) = 0 |
| 4336 | IHIST(1,NHKK) = IPHIST(1,IDXSTG) |
| 4337 | IHIST(2,NHKK) = 0 |
| 4338 | ELSEIF (NCODE(I).GE.0) THEN |
| 4339 | * indices of partons and string in POEVT1 |
| 4340 | IDX1 = ABS(JMOHEP(1,NPOS(1,I))) |
| 4341 | IDX2 = ABS(JMOHEP(2,NPOS(1,I))) |
| 4342 | IF ((IDX1.GT.IDX2).OR.(JMOHEP(2,NPOS(1,I)).GT.0)) THEN |
| 4343 | WRITE(LOUT,*) ' GETPJE: IDX1.GT.IDX2 ',IDX1,IDX2, |
| 4344 | & ' or JMOHEP(2,NPOS(1,I)).GT.0 ',JMOHEP(2,NPOS(1,I)),' ! ' |
| 4345 | STOP ' GETPJE 1' |
| 4346 | ENDIF |
| 4347 | IDXSTG = NPOS(1,I) |
| 4348 | * find "mother" string of the string |
| 4349 | IDXMS1 = ABS(JMOHEP(1,IDX1)) |
| 4350 | IDXMS2 = ABS(JMOHEP(1,IDX2)) |
| 4351 | IF (IDXMS1.NE.IDXMS2) THEN |
| 4352 | IDXMS1 = IDXSTG |
| 4353 | IDXMS2 = IDXSTG |
| 4354 | C STOP ' GETPJE: IDXMS1.NE.IDXMS2 !' |
| 4355 | ENDIF |
| 4356 | * search POEVT1 for the original hadron of the parton |
| 4357 | ILOOP = 0 |
| 4358 | IPOM1 = 0 |
| 4359 | 14 CONTINUE |
| 4360 | ILOOP = ILOOP+1 |
| 4361 | |
| 4362 | IF (IDHEP(IDXMS1).EQ.990) IPOM1 = 1 |
| 4363 | |
| 4364 | IDXMS1 = ABS(JMOHEP(1,IDXMS1)) |
| 4365 | IF ((IDXMS1.NE.1).AND.(IDXMS1.NE.2).AND. |
| 4366 | & (ILOOP.LT.MAXLOP)) GOTO 14 |
| 4367 | IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 1 ! ' |
| 4368 | IPOM2 = 0 |
| 4369 | ILOOP = 0 |
| 4370 | 15 CONTINUE |
| 4371 | ILOOP = ILOOP+1 |
| 4372 | |
| 4373 | IF (IDHEP(IDXMS2).EQ.990) IPOM2 = 1 |
| 4374 | |
| 4375 | IF ((ILOOP.EQ.1).OR.(IDHEP(IDXMS2).GE.7777)) THEN |
| 4376 | IDXMS2 = ABS(JMOHEP(2,IDXMS2)) |
| 4377 | ELSE |
| 4378 | IDXMS2 = ABS(JMOHEP(1,IDXMS2)) |
| 4379 | ENDIF |
| 4380 | IF ((IDXMS2.NE.1).AND.(IDXMS2.NE.2).AND. |
| 4381 | & (ILOOP.LT.MAXLOP)) GOTO 15 |
| 4382 | IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 5 ! ' |
| 4383 | * parton 1 |
| 4384 | IF (IDXMS1.EQ.1) THEN |
| 4385 | ISPTN1 = ISTHKK(MO1) |
| 4386 | M1PTN1 = MO1 |
| 4387 | M2PTN1 = MO1+2 |
| 4388 | ELSE |
| 4389 | ISPTN1 = ISTHKK(MO2) |
| 4390 | M1PTN1 = MO2-2 |
| 4391 | M2PTN1 = MO2 |
| 4392 | ENDIF |
| 4393 | * parton 2 |
| 4394 | IF (IDXMS2.EQ.1) THEN |
| 4395 | ISPTN2 = ISTHKK(MO1) |
| 4396 | M1PTN2 = MO1 |
| 4397 | M2PTN2 = MO1+2 |
| 4398 | ELSE |
| 4399 | ISPTN2 = ISTHKK(MO2) |
| 4400 | M1PTN2 = MO2-2 |
| 4401 | M2PTN2 = MO2 |
| 4402 | ENDIF |
| 4403 | * check for mis-identified mothers and switch mother indices if necessary |
| 4404 | IF ((IDXMS1.EQ.IDXMS2).AND.(IPROCE.NE.5).AND.(IPROCE.NE.6) |
| 4405 | & .AND.((IDHEP(IDX1).NE.21).OR.(IDHEP(IDX2).NE.21)).AND. |
| 4406 | & (LFLIP)) THEN |
| 4407 | IF (PHEP(3,IDX1).GT.PHEP(3,IDX2)) THEN |
| 4408 | ISPTN1 = ISTHKK(MO1) |
| 4409 | M1PTN1 = MO1 |
| 4410 | M2PTN1 = MO1+2 |
| 4411 | ISPTN2 = ISTHKK(MO2) |
| 4412 | M1PTN2 = MO2-2 |
| 4413 | M2PTN2 = MO2 |
| 4414 | ELSE |
| 4415 | ISPTN1 = ISTHKK(MO2) |
| 4416 | M1PTN1 = MO2-2 |
| 4417 | M2PTN1 = MO2 |
| 4418 | ISPTN2 = ISTHKK(MO1) |
| 4419 | M1PTN2 = MO1 |
| 4420 | M2PTN2 = MO1+2 |
| 4421 | ENDIF |
| 4422 | ENDIF |
| 4423 | * register partons in temporary common |
| 4424 | * parton at chain end |
| 4425 | PX = PHEP(1,IDX1) |
| 4426 | PY = PHEP(2,IDX1) |
| 4427 | PZ = PHEP(3,IDX1) |
| 4428 | PE = PHEP(4,IDX1) |
| 4429 | * flag only partons coming from Pomeron with 41/42 |
| 4430 | C IF ((IPOM1.NE.0).OR.(NPOS(4,I).GE.4)) THEN |
| 4431 | IF (IPOM1.NE.0) THEN |
| 4432 | ISTX = ABS(ISPTN1)/10 |
| 4433 | IMO = ABS(ISPTN1)-10*ISTX |
| 4434 | ISPTN1 = -(40+IMO) |
| 4435 | ELSE |
| 4436 | IF ((ICOLOR(2,IDX1).EQ.0).OR.(IDHEP(IDX1).EQ.21)) THEN |
| 4437 | ISTX = ABS(ISPTN1)/10 |
| 4438 | IMO = ABS(ISPTN1)-10*ISTX |
| 4439 | IF ((IDHEP(IDX1).EQ.21).OR. |
| 4440 | & (ABS(IPHIST(1,IDX1)).GE.100)) THEN |
| 4441 | ISPTN1 = -(60+IMO) |
| 4442 | ELSE |
| 4443 | ISPTN1 = -(50+IMO) |
| 4444 | ENDIF |
| 4445 | ENDIF |
| 4446 | ENDIF |
| 4447 | IF (ISPTN1.EQ.-21) NPVAL = NPVAL+1 |
| 4448 | IF (ISPTN1.EQ.-22) NTVAL = NTVAL+1 |
| 4449 | IF (MODE.LT.0) THEN |
| 4450 | CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PX,PY, |
| 4451 | & PZ,PE,0,0,0) |
| 4452 | ELSE |
| 4453 | CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP, |
| 4454 | & PPX,PPY,PPZ,PPE) |
| 4455 | CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PPX,PPY, |
| 4456 | & PPZ,PPE,0,0,0) |
| 4457 | ENDIF |
| 4458 | IHIST(1,NHKK) = IPHIST(1,IDX1) |
| 4459 | IHIST(2,NHKK) = 0 |
| 4460 | DO 19 KK=1,4 |
| 4461 | VHKK(KK,NHKK) = VHKK(KK,M2PTN1) |
| 4462 | WHKK(KK,NHKK) = WHKK(KK,M1PTN1) |
| 4463 | 19 CONTINUE |
| 4464 | VHKK(4,NHKK) = VHKK(3,M2PTN1)/BLAB-VHKK(3,M1PTN1)/BGLAB |
| 4465 | WHKK(4,NHKK) = -WHKK(3,M1PTN1)/BLAB+WHKK(3,M2PTN1)/BGLAB |
| 4466 | M1STRG = NHKK |
| 4467 | * gluon kinks |
| 4468 | NGLUON = IDX2-IDX1-1 |
| 4469 | IF (NGLUON.GT.0) THEN |
| 4470 | DO 17 IGLUON=1,NGLUON |
| 4471 | IDX = IDX1+IGLUON |
| 4472 | IDXMS = ABS(JMOHEP(1,IDX)) |
| 4473 | IF ((IDXMS.NE.1).AND.(IDXMS.NE.2)) THEN |
| 4474 | ILOOP = 0 |
| 4475 | 16 CONTINUE |
| 4476 | ILOOP = ILOOP+1 |
| 4477 | IDXMS = ABS(JMOHEP(1,IDXMS)) |
| 4478 | IF ((IDXMS.NE.1).AND.(IDXMS.NE.2).AND. |
| 4479 | & (ILOOP.LT.MAXLOP)) GOTO 16 |
| 4480 | IF (ILOOP.EQ.MAXLOP) |
| 4481 | & WRITE(LOUT,*) ' GETPJE: MAXLOP in 3 ! ' |
| 4482 | ENDIF |
| 4483 | IF (IDXMS.EQ.1) THEN |
| 4484 | ISPTN = ISTHKK(MO1) |
| 4485 | M1PTN = MO1 |
| 4486 | M2PTN = MO1+2 |
| 4487 | ELSE |
| 4488 | ISPTN = ISTHKK(MO2) |
| 4489 | M1PTN = MO2-2 |
| 4490 | M2PTN = MO2 |
| 4491 | ENDIF |
| 4492 | PX = PHEP(1,IDX) |
| 4493 | PY = PHEP(2,IDX) |
| 4494 | PZ = PHEP(3,IDX) |
| 4495 | PE = PHEP(4,IDX) |
| 4496 | IF ((ICOLOR(2,IDX).EQ.0).OR.(IDHEP(IDX).EQ.21)) THEN |
| 4497 | ISTX = ABS(ISPTN)/10 |
| 4498 | IMO = ABS(ISPTN)-10*ISTX |
| 4499 | IF ((IDHEP(IDX).EQ.21).OR. |
| 4500 | & (ABS(IPHIST(1,IDX)).GE.100)) THEN |
| 4501 | ISPTN = -(60+IMO) |
| 4502 | ELSE |
| 4503 | ISPTN = -(50+IMO) |
| 4504 | ENDIF |
| 4505 | ENDIF |
| 4506 | IF (ISPTN.EQ.-21) NPVAL = NPVAL+1 |
| 4507 | IF (ISPTN.EQ.-22) NTVAL = NTVAL+1 |
| 4508 | IF (MODE.LT.0) THEN |
| 4509 | CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN, |
| 4510 | & PX,PY,PZ,PE,0,0,0) |
| 4511 | ELSE |
| 4512 | CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP, |
| 4513 | & PPX,PPY,PPZ,PPE) |
| 4514 | CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN, |
| 4515 | & PPX,PPY,PPZ,PPE,0,0,0) |
| 4516 | ENDIF |
| 4517 | IHIST(1,NHKK) = IPHIST(1,IDX) |
| 4518 | IHIST(2,NHKK) = 0 |
| 4519 | DO 20 KK=1,4 |
| 4520 | VHKK(KK,NHKK) = VHKK(KK,M2PTN) |
| 4521 | WHKK(KK,NHKK) = WHKK(KK,M1PTN) |
| 4522 | 20 CONTINUE |
| 4523 | VHKK(4,NHKK)= VHKK(3,M2PTN)/BLAB-VHKK(3,M1PTN)/BGLAB |
| 4524 | WHKK(4,NHKK)= -WHKK(3,M1PTN)/BLAB+WHKK(3,M2PTN)/BGLAB |
| 4525 | 17 CONTINUE |
| 4526 | ENDIF |
| 4527 | * parton at chain end |
| 4528 | PX = PHEP(1,IDX2) |
| 4529 | PY = PHEP(2,IDX2) |
| 4530 | PZ = PHEP(3,IDX2) |
| 4531 | PE = PHEP(4,IDX2) |
| 4532 | * flag only partons coming from Pomeron with 41/42 |
| 4533 | C IF ((IPOM2.NE.0).OR.(NPOS(4,I).GE.4)) THEN |
| 4534 | IF (IPOM2.NE.0) THEN |
| 4535 | ISTX = ABS(ISPTN2)/10 |
| 4536 | IMO = ABS(ISPTN2)-10*ISTX |
| 4537 | ISPTN2 = -(40+IMO) |
| 4538 | ELSE |
| 4539 | IF ((ICOLOR(2,IDX2).EQ.0).OR.(IDHEP(IDX2).EQ.21)) THEN |
| 4540 | ISTX = ABS(ISPTN2)/10 |
| 4541 | IMO = ABS(ISPTN2)-10*ISTX |
| 4542 | IF ((IDHEP(IDX2).EQ.21).OR. |
| 4543 | & (ABS(IPHIST(1,IDX2)).GE.100)) THEN |
| 4544 | ISPTN2 = -(60+IMO) |
| 4545 | ELSE |
| 4546 | ISPTN2 = -(50+IMO) |
| 4547 | ENDIF |
| 4548 | ENDIF |
| 4549 | ENDIF |
| 4550 | IF (ISPTN2.EQ.-21) NPVAL = NPVAL+1 |
| 4551 | IF (ISPTN2.EQ.-22) NTVAL = NTVAL+1 |
| 4552 | IF (MODE.LT.0) THEN |
| 4553 | CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2, |
| 4554 | & PX,PY,PZ,PE,0,0,0) |
| 4555 | ELSE |
| 4556 | CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP, |
| 4557 | & PPX,PPY,PPZ,PPE) |
| 4558 | CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2, |
| 4559 | & PPX,PPY,PPZ,PPE,0,0,0) |
| 4560 | ENDIF |
| 4561 | IHIST(1,NHKK) = IPHIST(1,IDX2) |
| 4562 | IHIST(2,NHKK) = 0 |
| 4563 | DO 21 KK=1,4 |
| 4564 | VHKK(KK,NHKK) = VHKK(KK,M2PTN2) |
| 4565 | WHKK(KK,NHKK) = WHKK(KK,M1PTN2) |
| 4566 | 21 CONTINUE |
| 4567 | VHKK(4,NHKK) = VHKK(3,M2PTN2)/BLAB-VHKK(3,M1PTN2)/BGLAB |
| 4568 | WHKK(4,NHKK) = -WHKK(3,M1PTN2)/BLAB+WHKK(3,M2PTN2)/BGLAB |
| 4569 | M2STRG = NHKK |
| 4570 | * register string |
| 4571 | JSTRG = 100*IPROCE+NCODE(I) |
| 4572 | PX = PHEP(1,IDXSTG) |
| 4573 | PY = PHEP(2,IDXSTG) |
| 4574 | PZ = PHEP(3,IDXSTG) |
| 4575 | PE = PHEP(4,IDXSTG) |
| 4576 | IF (MODE.LT.0) THEN |
| 4577 | ISTAT = 70000+IPJE |
| 4578 | CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG, |
| 4579 | & PX,PY,PZ,PE,0,0,0) |
| 4580 | IF (LEMCCK) THEN |
| 4581 | PX = -PX |
| 4582 | PY = -PY |
| 4583 | PZ = -PZ |
| 4584 | PE = -PE |
| 4585 | CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2) |
| 4586 | ENDIF |
| 4587 | ELSE |
| 4588 | CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP, |
| 4589 | & PPX,PPY,PPZ,PPE) |
| 4590 | ISTAT = 70000+IPJE |
| 4591 | CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG, |
| 4592 | & PPX,PPY,PPZ,PPE,0,0,0) |
| 4593 | IF (LEMCCK) THEN |
| 4594 | PX = -PPX |
| 4595 | PY = -PPY |
| 4596 | PZ = -PPZ |
| 4597 | PE = -PPE |
| 4598 | CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2) |
| 4599 | ENDIF |
| 4600 | ENDIF |
| 4601 | NOBAM(NHKK) = 0 |
| 4602 | IHIST(1,NHKK) = 0 |
| 4603 | IHIST(2,NHKK) = 0 |
| 4604 | DO 18 KK=1,4 |
| 4605 | VHKK(KK,NHKK) = VHKK(KK,MO2) |
| 4606 | WHKK(KK,NHKK) = WHKK(KK,MO1) |
| 4607 | 18 CONTINUE |
| 4608 | VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB |
| 4609 | WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB |
| 4610 | ENDIF |
| 4611 | 11 CONTINUE |
| 4612 | |
| 4613 | IF ( ((NPVAL.GT.2).OR.(NTVAL.GT.2)).AND.(LFLIP) ) THEN |
| 4614 | NHKK = INHKK |
| 4615 | LFLIP = .FALSE. |
| 4616 | GOTO 1 |
| 4617 | ENDIF |
| 4618 | |
| 4619 | IF (LEMCCK) THEN |
| 4620 | IF (UMO.GT.1.0D5) THEN |
| 4621 | CHKLEV = 1.0D0 |
| 4622 | ELSE |
| 4623 | CHKLEV = TINY1 |
| 4624 | ENDIF |
| 4625 | CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,1000,IREJ2) |
| 4626 | |
| 4627 | IF (IREJ2.GT.ZERO) CALL PHO_PREVNT(0) |
| 4628 | |
| 4629 | ENDIF |
| 4630 | |
| 4631 | * internal statistics |
| 4632 | * dble-Po statistics. |
| 4633 | IF (IPROCE.NE.4) IPOPO = 0 |
| 4634 | |
| 4635 | INTFLG = IPROCE |
| 4636 | IDCHSY = IDCH(MO1) |
| 4637 | IF ((IPROCE.GE.1).AND.(IPROCE.LE.8)) THEN |
| 4638 | ICEVTG(IDCHSY,IPROCE+2) = ICEVTG(IDCHSY,IPROCE+2)+1 |
| 4639 | ELSE |
| 4640 | WRITE(LOUT,1000) IPROCE,NEVHKK,MO1 |
| 4641 | 1000 FORMAT(1X,'GETFSP: warning! incons. process id. (',I2, |
| 4642 | & ') at evt(chain) ',I6,'(',I2,')') |
| 4643 | ENDIF |
| 4644 | IF (IPROCE.EQ.5) THEN |
| 4645 | IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3)) THEN |
| 4646 | ICEVTG(IDCHSY,18+IDIFR1) = ICEVTG(IDCHSY,18+IDIFR1)+1 |
| 4647 | ELSE |
| 4648 | C WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2 |
| 4649 | 1001 FORMAT(1X,'GETFSP: warning! incons. diffrac. id. ', |
| 4650 | & '(IPROCE,IDIFR1,IDIFR2=',3I3,')') |
| 4651 | ENDIF |
| 4652 | ELSEIF (IPROCE.EQ.6) THEN |
| 4653 | IF ((IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN |
| 4654 | ICEVTG(IDCHSY,21+IDIFR2) = ICEVTG(IDCHSY,21+IDIFR2)+1 |
| 4655 | ELSE |
| 4656 | C WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2 |
| 4657 | ENDIF |
| 4658 | ELSEIF (IPROCE.EQ.7) THEN |
| 4659 | IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3).AND. |
| 4660 | & (IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN |
| 4661 | IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.1)) |
| 4662 | & ICEVTG(IDCHSY,25) = ICEVTG(IDCHSY,25)+1 |
| 4663 | IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.2)) |
| 4664 | & ICEVTG(IDCHSY,26) = ICEVTG(IDCHSY,26)+1 |
| 4665 | IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.2)) |
| 4666 | & ICEVTG(IDCHSY,27) = ICEVTG(IDCHSY,27)+1 |
| 4667 | IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.1)) |
| 4668 | & ICEVTG(IDCHSY,28) = ICEVTG(IDCHSY,28)+1 |
| 4669 | ELSE |
| 4670 | WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2 |
| 4671 | ENDIF |
| 4672 | ENDIF |
| 4673 | IF ((IDIFR1+IDIFR2.EQ.0).AND.(KHDIR.GE.1).AND.(KHDIR.LE.3)) |
| 4674 | & THEN |
| 4675 | ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1 |
| 4676 | ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1 |
| 4677 | ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1 |
| 4678 | ENDIF |
| 4679 | ICEVTG(IDCHSY,14) = ICEVTG(IDCHSY,14)+KSPOM |
| 4680 | ICEVTG(IDCHSY,15) = ICEVTG(IDCHSY,15)+KHPOM |
| 4681 | ICEVTG(IDCHSY,16) = ICEVTG(IDCHSY,16)+KSREG |
| 4682 | ICEVTG(IDCHSY,17) = ICEVTG(IDCHSY,17)+(KSTRG+KHTRG) |
| 4683 | ICEVTG(IDCHSY,18) = ICEVTG(IDCHSY,18)+(KSLOO+KHLOO) |
| 4684 | |
| 4685 | RETURN |
| 4686 | |
| 4687 | 9999 CONTINUE |
| 4688 | IREJ = 1 |
| 4689 | RETURN |
| 4690 | END |
| 4691 | * |
| 4692 | *===phoini=============================================================* |
| 4693 | * |
| 4694 | CDECK ID>, DT_PHOINI |
| 4695 | SUBROUTINE DT_PHOINI |
| 4696 | |
| 4697 | ************************************************************************ |
| 4698 | * Initialization PHOJET-event generator for nucleon-nucleon interact. * |
| 4699 | * This version dated 16.11.95 is written by S. Roesler * |
| 4700 | * Last change: s.r. 21.01.01 * |
| 4701 | ************************************************************************ |
| 4702 | |
| 4703 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 4704 | SAVE |
| 4705 | |
| 4706 | PARAMETER ( LINP = 5 , |
| 4707 | & LOUT = 6 , |
| 4708 | & LDAT = 9 ) |
| 4709 | |
| 4710 | PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0) |
| 4711 | |
| 4712 | * nucleon-nucleon event-generator |
| 4713 | CHARACTER*8 CMODEL |
| 4714 | LOGICAL LPHOIN |
| 4715 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN |
| 4716 | * particle properties (BAMJET index convention) |
| 4717 | CHARACTER*8 ANAME |
| 4718 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 4719 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 4720 | * Lorentz-parameters of the current interaction |
| 4721 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, |
| 4722 | & UMO,PPCM,EPROJ,PPROJ |
| 4723 | * properties of interacting particles |
| 4724 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG |
| 4725 | * properties of photon/lepton projectiles |
| 4726 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC |
| 4727 | |
| 4728 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 4729 | |
| 4730 | * emulsion treatment |
| 4731 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), |
| 4732 | & NCOMPO,IEMUL |
| 4733 | * VDM parameter for photon-nucleus interactions |
| 4734 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) |
| 4735 | * nuclear potential |
| 4736 | LOGICAL LFERMI |
| 4737 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, |
| 4738 | & EBINDP(2),EBINDN(2),EPOT(2,210), |
| 4739 | & ETACOU(2),ICOUL,LFERMI |
| 4740 | * Glauber formalism: flags and parameters for statistics |
| 4741 | LOGICAL LPROD |
| 4742 | CHARACTER*8 CGLB |
| 4743 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD |
| 4744 | * |
| 4745 | * parameters for cascade calculations: |
| 4746 | * maximum mumber of PDF's which can be defined in phojet (limited |
| 4747 | * by the dimension of ipdfs in pho_setpdf) |
| 4748 | PARAMETER (MAXPDF = 20) |
| 4749 | * PDF parametrization and number of set for the first 30 hadrons in |
| 4750 | * the bamjet-code list |
| 4751 | * negative numbers mean that the PDF is set in phojet, |
| 4752 | * zero stands for "not a hadron" |
| 4753 | DIMENSION IPARPD(30),ISETPD(30) |
| 4754 | * PDF parametrization |
| 4755 | DATA IPARPD / |
| 4756 | & -5,-5, 0, 0, 0, 0,-5,-5,-5, 0, 0, 5,-5,-5, 5, 5, 5, 5, 5, 5, |
| 4757 | & 5, 5,-5, 5, 5, 0, 0, 0, 0, 0/ |
| 4758 | * number of set |
| 4759 | DATA ISETPD / |
| 4760 | & -6,-6, 0, 0, 0, 0,-3,-6,-6, 0, 0, 2,-2,-2, 2, 2, 6, 6, 2, 6, |
| 4761 | & 6, 6,-2, 2, 2, 0, 0, 0, 0, 0/ |
| 4762 | |
| 4763 | **PHOJET105a |
| 4764 | C COMMON /GLOCMS/ XECM,XPCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2) |
| 4765 | C PARAMETER ( MAXPRO = 16 ) |
| 4766 | C PARAMETER ( MAXTAB = 20 ) |
| 4767 | C COMMON /HAXSEC/ XSECTA(4,-1:MAXPRO,4,MAXTAB),XSECT(6,-1:MAXPRO), |
| 4768 | C & MXSECT(0:4,-1:MAXPRO,4),ECMSH(4,MAXTAB),ISTTAB |
| 4769 | C CHARACTER*8 MDLNA |
| 4770 | C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100) |
| 4771 | C COMMON /PROCES/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15) |
| 4772 | **PHOJET110 |
| 4773 | C global event kinematics and particle IDs |
| 4774 | INTEGER IFPAP,IFPAB |
| 4775 | DOUBLE PRECISION ECM,PCM,PMASS,PVIRT |
| 4776 | COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2) |
| 4777 | C hard cross sections and MC selection weights |
| 4778 | INTEGER Max_pro_2 |
| 4779 | PARAMETER ( Max_pro_2 = 16 ) |
| 4780 | INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried, |
| 4781 | & MH_acc_1,MH_acc_2 |
| 4782 | DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last |
| 4783 | COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2), |
| 4784 | & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2), |
| 4785 | & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last, |
| 4786 | & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4), |
| 4787 | & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4) |
| 4788 | C model switches and parameters |
| 4789 | CHARACTER*8 MDLNA |
| 4790 | INTEGER ISWMDL,IPAMDL |
| 4791 | DOUBLE PRECISION PARMDL |
| 4792 | COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400) |
| 4793 | C general process information |
| 4794 | INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON |
| 4795 | COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4) |
| 4796 | ** |
| 4797 | DIMENSION PP(4),PT(4) |
| 4798 | |
| 4799 | LOGICAL LSTART |
| 4800 | DATA LSTART /.TRUE./ |
| 4801 | |
| 4802 | IJP = IJPROJ |
| 4803 | IJT = IJTARG |
| 4804 | Q2 = VIRT |
| 4805 | * lepton-projectiles: initialize real photon instead |
| 4806 | IF ((IJP.EQ.3).OR.(IJP.EQ.4).OR.(IJP.EQ.10).OR.(IJP.EQ.11)) THEN |
| 4807 | IJP = 7 |
| 4808 | Q2 = ZERO |
| 4809 | ENDIF |
| 4810 | |
| 4811 | IF (LPHOIN) CALL PHO_INIT(-1,IDUM) |
| 4812 | |
| 4813 | * switch Reggeon off |
| 4814 | C IPAMDL(3)= 0 |
| 4815 | IF (IP.EQ.1) THEN |
| 4816 | IFPAP(1) = IDT_IPDGHA(IJP) |
| 4817 | IFPAB(1) = IJP |
| 4818 | ELSE |
| 4819 | IFPAP(1) = 2212 |
| 4820 | IFPAB(1) = IDT_ICIHAD(IFPAP(1)) |
| 4821 | ENDIF |
| 4822 | PMASS(1) = AAM(IFPAB(1))-SQRT(Q2) |
| 4823 | PVIRT(1) = PMASS(1)**2 |
| 4824 | IF (IT.EQ.1) THEN |
| 4825 | IFPAP(2) = IDT_IPDGHA(IJT) |
| 4826 | IFPAB(2) = IJT |
| 4827 | ELSE |
| 4828 | IFPAP(2) = 2212 |
| 4829 | IFPAB(2) = IDT_ICIHAD(IFPAP(2)) |
| 4830 | ENDIF |
| 4831 | PMASS(2) = AAM(IFPAB(2)) |
| 4832 | PVIRT(2) = ZERO |
| 4833 | DO 1 K=1,4 |
| 4834 | PP(K) = ZERO |
| 4835 | PT(K) = ZERO |
| 4836 | 1 CONTINUE |
| 4837 | * get max. possible momenta of incoming particles to be used for PHOJET ini. |
| 4838 | PPF = ZERO |
| 4839 | PTF = ZERO |
| 4840 | SCPF= 1.5D0 |
| 4841 | IF (UMO.GE.1.E5) THEN |
| 4842 | SCPF= 5.0D0 |
| 4843 | ENDIF |
| 4844 | IF (NCOMPO.GT.0) THEN |
| 4845 | DO 2 I=1,NCOMPO |
| 4846 | IF (IT.GT.1) THEN |
| 4847 | CALL DT_NCLPOT(IEMUCH(I),IEMUMA(I),ITZ,IT,ZERO,ZERO,0) |
| 4848 | ELSE |
| 4849 | CALL DT_NCLPOT(IPZ,IP,IEMUCH(I),IEMUMA(I),ZERO,ZERO,0) |
| 4850 | ENDIF |
| 4851 | PPFTMP = MAX(PFERMP(1),PFERMN(1)) |
| 4852 | PTFTMP = MAX(PFERMP(2),PFERMN(2)) |
| 4853 | IF (PPFTMP.GT.PPF) PPF = PPFTMP |
| 4854 | IF (PTFTMP.GT.PTF) PTF = PTFTMP |
| 4855 | 2 CONTINUE |
| 4856 | ELSE |
| 4857 | CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0) |
| 4858 | PPF = MAX(PFERMP(1),PFERMN(1)) |
| 4859 | PTF = MAX(PFERMP(2),PFERMN(2)) |
| 4860 | ENDIF |
| 4861 | PTF = -PTF |
| 4862 | PPF = SCPF*PPF |
| 4863 | PTF = SCPF*PTF |
| 4864 | IF (IJP.EQ.7) THEN |
| 4865 | AMP2 = SIGN(PMASS(1)**2,PMASS(1)) |
| 4866 | PP(3) = PPCM |
| 4867 | PP(4) = SQRT(AMP2+PP(3)**2) |
| 4868 | ELSE |
| 4869 | EPF = SQRT(PPF**2+PMASS(1)**2) |
| 4870 | CALL DT_LTNUC(PPF,EPF,PP(3),PP(4),2) |
| 4871 | ENDIF |
| 4872 | ETF = SQRT(PTF**2+PMASS(2)**2) |
| 4873 | CALL DT_LTNUC(PTF,ETF,PT(3),PT(4),3) |
| 4874 | ECMINI = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2- |
| 4875 | & (PP(2)+PT(2))**2-(PP(3)+PT(3))**2) |
| 4876 | IF (LSTART) THEN |
| 4877 | C *** Commented by Chiara |
| 4878 | C WRITE(LOUT,1001) IP,IPZ,SCPF,PPF,PP |
| 4879 | 1001 FORMAT( |
| 4880 | & ' DT_PHOINI: PHOJET initialized for projectile A,Z = ', |
| 4881 | & I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3) |
| 4882 | C *** Commented by Chiara |
| 4883 | C IF (NCOMPO.GT.0) THEN |
| 4884 | C WRITE(LOUT,1002) SCPF,PTF,PT |
| 4885 | C ELSE |
| 4886 | C WRITE(LOUT,1003) IT,ITZ,SCPF,PTF,PT |
| 4887 | C ENDIF |
| 4888 | 1002 FORMAT( |
| 4889 | & ' DT_PHOINI: PHOJET initialized for target emulsion ', |
| 4890 | & /,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3) |
| 4891 | 1003 FORMAT( |
| 4892 | & ' DT_PHOINI: PHOJET initialized for target A,Z = ', |
| 4893 | & I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3) |
| 4894 | C *** Commented by Chiara |
| 4895 | C WRITE(LOUT,1004) ECMINI |
| 4896 | 1004 FORMAT(' E_cm = ',E10.3) |
| 4897 | IF (IJP.EQ.8) WRITE(LOUT,1005) |
| 4898 | 1005 FORMAT( |
| 4899 | & ' DT_PHOINI: warning! proton parameters used for neutron', |
| 4900 | & ' projectile') |
| 4901 | LSTART = .FALSE. |
| 4902 | ENDIF |
| 4903 | * switch off new diffractive cross sections at low energies for nuclei |
| 4904 | * (temporary solution) |
| 4905 | IF ((ISWMDL(30).NE.0).AND.((IP.GT.1).OR.(IT.GT.1))) THEN |
| 4906 | WRITE(LOUT,'(1X,A)') |
| 4907 | & ' DT_PHOINI: model-switch 30 for nuclei re-set !' |
| 4908 | CALL PHO_SETMDL(30,0,1) |
| 4909 | ENDIF |
| 4910 | * |
| 4911 | C IF (IJP.EQ.7) THEN |
| 4912 | C AMP2 = SIGN(PMASS(1)**2,PMASS(1)) |
| 4913 | C PP(3) = PPCM |
| 4914 | C PP(4) = SQRT(AMP2+PP(3)**2) |
| 4915 | C ELSE |
| 4916 | C PFERMX = ZERO |
| 4917 | C IF (IP.GT.1) PFERMX = 0.5D0 |
| 4918 | C EFERMX = SQRT(PFERMX**2+PMASS(1)**2) |
| 4919 | C CALL DT_LTNUC(PFERMX,EFERMX,PP(3),PP(4),2) |
| 4920 | C ENDIF |
| 4921 | C PFERMX = ZERO |
| 4922 | C IF ((IT.GT.1).OR.(NCOMPO.GT.0)) PFERMX = -0.5D0 |
| 4923 | C EFERMX = SQRT(PFERMX**2+PMASS(2)**2) |
| 4924 | C CALL DT_LTNUC(PFERMX,EFERMX,PT(3),PT(4),3) |
| 4925 | **sr 26.10.96 |
| 4926 | ISAV = IPAMDL(13) |
| 4927 | IF ((ISHAD(2).EQ.1).AND. |
| 4928 | & ((IJPROJ.EQ. 7).OR.(IJPROJ.EQ.3).OR.(IJPROJ.EQ.4).OR. |
| 4929 | & (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11))) IPAMDL(13) = 1 |
| 4930 | ** |
| 4931 | |
| 4932 | CALL PHO_EVENT(-1,PP,PT,SIGMAX,IREJ1) |
| 4933 | |
| 4934 | **sr 26.10.96 |
| 4935 | IPAMDL(13) = ISAV |
| 4936 | ** |
| 4937 | * |
| 4938 | * patch for cascade calculations: |
| 4939 | * define parton distribution functions for other hadrons, i.e. other |
| 4940 | * then defined already in phojet |
| 4941 | IF (IOGLB.EQ.100) THEN |
| 4942 | WRITE(LOUT,1006) |
| 4943 | 1006 FORMAT(/,1X,'PHOINI: additional parton distribution functions', |
| 4944 | & ' assiged (ID,IPAR,ISET)',/) |
| 4945 | NPDF = 0 |
| 4946 | DO 3 I=1,30 |
| 4947 | IF (IPARPD(I).NE.0) THEN |
| 4948 | NPDF = NPDF+1 |
| 4949 | IF (NPDF.GT.MAXPDF) STOP ' PHOINI: npdf > maxpdf !' |
| 4950 | IF ((IPARPD(I).GT.0).AND.(ISETPD(I).GT.0)) THEN |
| 4951 | IDPDG = IDT_IPDGHA(I) |
| 4952 | IPAR = IPARPD(I) |
| 4953 | ISET = ISETPD(I) |
| 4954 | WRITE(LOUT,'(13X,A8,3I6)') ANAME(I),IDPDG,IPAR,ISET |
| 4955 | CALL PHO_SETPDF(IDPDG,IDUM,IPAR,ISET,0,0,-1) |
| 4956 | ENDIF |
| 4957 | ENDIF |
| 4958 | 3 CONTINUE |
| 4959 | ENDIF |
| 4960 | |
| 4961 | C CALL PHO_PHIST(-1,SIGMAX) |
| 4962 | |
| 4963 | IF (IREJ1.NE.0) THEN |
| 4964 | WRITE(LOUT,1000) |
| 4965 | 1000 FORMAT(1X,'PHOINI: PHOJET event-initialization failed!') |
| 4966 | STOP |
| 4967 | ENDIF |
| 4968 | |
| 4969 | RETURN |
| 4970 | END |
| 4971 | |
| 4972 | * |
| 4973 | *===eventd=============================================================* |
| 4974 | * |
| 4975 | CDECK ID>, DT_EVENTD |
| 4976 | SUBROUTINE DT_EVENTD(IREJ) |
| 4977 | |
| 4978 | ************************************************************************ |
| 4979 | * Quasi-elastic neutrino nucleus scattering. * |
| 4980 | * This version dated 29.04.00 is written by S. Roesler. * |
| 4981 | ************************************************************************ |
| 4982 | |
| 4983 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 4984 | SAVE |
| 4985 | |
| 4986 | PARAMETER ( LINP = 5 , |
| 4987 | & LOUT = 6 , |
| 4988 | & LDAT = 9 ) |
| 4989 | |
| 4990 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY5=1.0D-5) |
| 4991 | PARAMETER (SQTINF=1.0D+15) |
| 4992 | |
| 4993 | LOGICAL LFIRST |
| 4994 | |
| 4995 | * event history |
| 4996 | |
| 4997 | PARAMETER (NMXHKK=200000) |
| 4998 | |
| 4999 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 5000 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 5001 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 5002 | * extended event history |
| 5003 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 5004 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 5005 | & IHIST(2,NMXHKK) |
| 5006 | * flags for input different options |
| 5007 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 5008 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 5009 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 5010 | |
| 5011 | PARAMETER (MAXLND=4000) |
| 5012 | COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5) |
| 5013 | |
| 5014 | * properties of interacting particles |
| 5015 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG |
| 5016 | * Lorentz-parameters of the current interaction |
| 5017 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, |
| 5018 | & UMO,PPCM,EPROJ,PPROJ |
| 5019 | * nuclear potential |
| 5020 | LOGICAL LFERMI |
| 5021 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, |
| 5022 | & EBINDP(2),EBINDN(2),EPOT(2,210), |
| 5023 | & ETACOU(2),ICOUL,LFERMI |
| 5024 | * steering flags for qel neutrino scattering modules |
| 5025 | COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC |
| 5026 | COMMON /QNPOL/ POLARX(4),PMODUL |
| 5027 | |
| 5028 | INTEGER PYK |
| 5029 | |
| 5030 | DATA LFIRST /.TRUE./ |
| 5031 | |
| 5032 | IREJ = 0 |
| 5033 | |
| 5034 | IF (LFIRST) THEN |
| 5035 | LFIRST = .FALSE. |
| 5036 | CALL DT_MASS_INI |
| 5037 | ENDIF |
| 5038 | |
| 5039 | * JETSET parameter |
| 5040 | CALL DT_INITJS(0) |
| 5041 | |
| 5042 | * interacting target nucleon |
| 5043 | LTYP = NEUTYP |
| 5044 | IF (NEUDEC.LE.9) THEN |
| 5045 | IF ((LTYP.EQ.1).OR.(LTYP.EQ.3).OR.(LTYP.EQ.5)) THEN |
| 5046 | NUCTYP = 2112 |
| 5047 | NUCTOP = 2 |
| 5048 | ELSE |
| 5049 | NUCTYP = 2212 |
| 5050 | NUCTOP = 1 |
| 5051 | ENDIF |
| 5052 | ELSE |
| 5053 | RTYP = DT_RNDM(RTYP) |
| 5054 | ZFRAC = DBLE(ITZ)/DBLE(IT) |
| 5055 | IF (RTYP.LE.ZFRAC) THEN |
| 5056 | NUCTYP = 2212 |
| 5057 | NUCTOP = 1 |
| 5058 | ELSE |
| 5059 | NUCTYP = 2112 |
| 5060 | NUCTOP = 2 |
| 5061 | ENDIF |
| 5062 | ENDIF |
| 5063 | |
| 5064 | * select first nucleon in list with matching id and reset all other |
| 5065 | * nucleons which have been marked as "wounded" by ININUC |
| 5066 | IFOUND = 0 |
| 5067 | DO 1 I=1,NHKK |
| 5068 | IF ((IDHKK(I).EQ.NUCTYP).AND.(IFOUND.EQ.0)) THEN |
| 5069 | ISTHKK(I) = 12 |
| 5070 | IFOUND = 1 |
| 5071 | IDX = I |
| 5072 | ELSE |
| 5073 | IF (ISTHKK(I).EQ.12) ISTHKK(I) = 14 |
| 5074 | ENDIF |
| 5075 | 1 CONTINUE |
| 5076 | IF (IFOUND.EQ.0) |
| 5077 | & STOP ' EVENTD: interacting target nucleon not found! ' |
| 5078 | |
| 5079 | * correct position of proj. lepton: assume position of target nucleon |
| 5080 | DO 3 I=1,4 |
| 5081 | VHKK(I,1) = VHKK(I,IDX) |
| 5082 | WHKK(I,1) = WHKK(I,IDX) |
| 5083 | 3 CONTINUE |
| 5084 | |
| 5085 | * load initial momenta for conservation check |
| 5086 | IF (LEMCCK) THEN |
| 5087 | CALL DT_EVTEMC(ZERO,ZERO,PPROJ,EPROJ,1,IDUM,IDUM) |
| 5088 | CALL DT_EVTEMC(PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),PHKK(4,IDX), |
| 5089 | & 2,IDUM,IDUM) |
| 5090 | ENDIF |
| 5091 | |
| 5092 | * quasi-elastic scattering |
| 5093 | IF (NEUDEC.LT.9) THEN |
| 5094 | CALL DT_QEL_POL(EPROJ,LTYP,PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX), |
| 5095 | & PHKK(4,IDX),PHKK(5,IDX)) |
| 5096 | * CC event on p or n |
| 5097 | ELSEIF (NEUDEC.EQ.10) THEN |
| 5098 | CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,1,PHKK(1,IDX),PHKK(2,IDX), |
| 5099 | & PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX)) |
| 5100 | * NC event on p or n |
| 5101 | ELSEIF (NEUDEC.EQ.11) THEN |
| 5102 | CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,2,PHKK(1,IDX),PHKK(2,IDX), |
| 5103 | & PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX)) |
| 5104 | ENDIF |
| 5105 | |
| 5106 | * get final state particles from Lund-common and write them into HKKEVT |
| 5107 | NPOINT(1) = NHKK+1 |
| 5108 | NPOINT(4) = NHKK+1 |
| 5109 | |
| 5110 | NLINES = PYK(0,1) |
| 5111 | |
| 5112 | NHKK0 = NHKK+1 |
| 5113 | DO 4 I=4,NLINES |
| 5114 | IF (K(I,1).EQ.1) THEN |
| 5115 | ID = K(I,2) |
| 5116 | PX = P(I,1) |
| 5117 | PY = P(I,2) |
| 5118 | PZ = P(I,3) |
| 5119 | PE = P(I,4) |
| 5120 | CALL DT_EVTPUT(1,ID,1,IDX,PX,PY,PZ,PE,0,0,0) |
| 5121 | IDBJ = IDT_ICIHAD(ID) |
| 5122 | EKIN = PHKK(4,NHKK)-PHKK(5,NHKK) |
| 5123 | IF ((IDBJ.EQ.1).OR.(IDBJ.EQ.8)) THEN |
| 5124 | IF (EKIN.LE.EPOT(2,IDBJ)) ISTHKK(NHKK) = 16 |
| 5125 | ENDIF |
| 5126 | VHKK(1,NHKK) = VHKK(1,IDX) |
| 5127 | VHKK(2,NHKK) = VHKK(2,IDX) |
| 5128 | VHKK(3,NHKK) = VHKK(3,IDX) |
| 5129 | VHKK(4,NHKK) = VHKK(4,IDX) |
| 5130 | C IF (I.EQ.4) THEN |
| 5131 | C WHKK(1,NHKK) = POLARX(1) |
| 5132 | C WHKK(2,NHKK) = POLARX(2) |
| 5133 | C WHKK(3,NHKK) = POLARX(3) |
| 5134 | C WHKK(4,NHKK) = POLARX(4) |
| 5135 | C ELSE |
| 5136 | WHKK(1,NHKK) = WHKK(1,IDX) |
| 5137 | WHKK(2,NHKK) = WHKK(2,IDX) |
| 5138 | WHKK(3,NHKK) = WHKK(3,IDX) |
| 5139 | WHKK(4,NHKK) = WHKK(4,IDX) |
| 5140 | C ENDIF |
| 5141 | IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM) |
| 5142 | ENDIF |
| 5143 | 4 CONTINUE |
| 5144 | |
| 5145 | IF (LEMCCK) THEN |
| 5146 | CHKLEV = TINY5 |
| 5147 | CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,778,IREJ1) |
| 5148 | IF (IREJ1.NE.0) CALL DT_EVTOUT(4) |
| 5149 | ENDIF |
| 5150 | |
| 5151 | * transform momenta into cms (as required for inc etc.) |
| 5152 | DO 5 I=NHKK0,NHKK |
| 5153 | IF (ISTHKK(I).EQ.1) THEN |
| 5154 | CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,3) |
| 5155 | PHKK(3,I) = PZ |
| 5156 | PHKK(4,I) = PE |
| 5157 | ENDIF |
| 5158 | 5 CONTINUE |
| 5159 | |
| 5160 | RETURN |
| 5161 | END |
| 5162 | * |
| 5163 | *===kkevnt=============================================================* |
| 5164 | * |
| 5165 | CDECK ID>, DT_KKEVNT |
| 5166 | SUBROUTINE DT_KKEVNT(KKMAT,IREJ) |
| 5167 | |
| 5168 | ************************************************************************ |
| 5169 | * Treatment of complete nucleus-nucleus or hadron-nucleus scattering * |
| 5170 | * without nuclear effects (one event). * |
| 5171 | * This subroutine is an update of the previous version (KKEVT) written * |
| 5172 | * by J. Ranft/ H.-J. Moehring. * |
| 5173 | * This version dated 20.04.95 is written by S. Roesler * |
| 5174 | ************************************************************************ |
| 5175 | |
| 5176 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 5177 | SAVE |
| 5178 | |
| 5179 | PARAMETER ( LINP = 5 , |
| 5180 | & LOUT = 6 , |
| 5181 | & LDAT = 9 ) |
| 5182 | |
| 5183 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10) |
| 5184 | |
| 5185 | PARAMETER ( MAXNCL = 260, |
| 5186 | |
| 5187 | & MAXVQU = MAXNCL, |
| 5188 | & MAXSQU = 20*MAXVQU, |
| 5189 | & MAXINT = MAXVQU+MAXSQU) |
| 5190 | * event history |
| 5191 | |
| 5192 | PARAMETER (NMXHKK=200000) |
| 5193 | |
| 5194 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 5195 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 5196 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 5197 | * extended event history |
| 5198 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 5199 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 5200 | & IHIST(2,NMXHKK) |
| 5201 | * flags for input different options |
| 5202 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 5203 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 5204 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 5205 | * rejection counter |
| 5206 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, |
| 5207 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, |
| 5208 | & IREXCI(3),IRDIFF(2),IRINC |
| 5209 | * statistics |
| 5210 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, |
| 5211 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), |
| 5212 | & ICEVTG(8,0:30) |
| 5213 | * properties of interacting particles |
| 5214 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG |
| 5215 | * Lorentz-parameters of the current interaction |
| 5216 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, |
| 5217 | & UMO,PPCM,EPROJ,PPROJ |
| 5218 | * flags for diffractive interactions (DTUNUC 1.x) |
| 5219 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF |
| 5220 | * interface HADRIN-DPM |
| 5221 | COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA |
| 5222 | * nucleon-nucleon event-generator |
| 5223 | CHARACTER*8 CMODEL |
| 5224 | LOGICAL LPHOIN |
| 5225 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN |
| 5226 | * coordinates of nucleons |
| 5227 | COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL) |
| 5228 | * interface between Glauber formalism and DPM |
| 5229 | COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL), |
| 5230 | & INTER1(MAXINT),INTER2(MAXINT) |
| 5231 | * Glauber formalism: collision properties |
| 5232 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, |
| 5233 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC |
| 5234 | * central particle production, impact parameter biasing |
| 5235 | COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR |
| 5236 | **temporary |
| 5237 | * statistics: Glauber-formalism |
| 5238 | COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB |
| 5239 | ** |
| 5240 | |
| 5241 | DATA NEVOLD,IPOLD,ITOLD,JJPOLD,EPROLD /4*0,0.0D0/ |
| 5242 | |
| 5243 | IREJ = 0 |
| 5244 | ICREQU = ICREQU+1 |
| 5245 | NC = 0 |
| 5246 | |
| 5247 | 1 CONTINUE |
| 5248 | ICSAMP = ICSAMP+1 |
| 5249 | NC = NC+1 |
| 5250 | IF (MOD(NC,10).EQ.0) THEN |
| 5251 | WRITE(LOUT,1000) NEVHKK |
| 5252 | 1000 FORMAT(1X,'KKEVNT: event ',I8,' rejected!') |
| 5253 | GOTO 9999 |
| 5254 | ENDIF |
| 5255 | |
| 5256 | * initialize DTEVT1/DTEVT2 |
| 5257 | CALL DT_EVTINI |
| 5258 | |
| 5259 | * We need the following only in order to sample nucleon coordinates. |
| 5260 | * However we don't have parameters (cross sections, slope etc.) |
| 5261 | * for neutrinos available. Therefore switch projectile to proton |
| 5262 | * in this case. |
| 5263 | IF (MCGENE.EQ.4) THEN |
| 5264 | JJPROJ = 1 |
| 5265 | ELSE |
| 5266 | JJPROJ = IJPROJ |
| 5267 | ENDIF |
| 5268 | |
| 5269 | 10 CONTINUE |
| 5270 | IF ( (NEVHKK.NE.NEVOLD).OR.(ICENTR.GT.0).OR. |
| 5271 | * make sure that Glauber-formalism is called each time the interaction |
| 5272 | * configuration changed |
| 5273 | & (IP.NE.IPOLD).OR.(IT.NE.ITOLD).OR.(JJPROJ.NE.JJPOLD).OR. |
| 5274 | & (ABS(EPROJ-EPROLD).GT.TINY10) ) THEN |
| 5275 | * sample number of nucleon-nucleon coll. according to Glauber-form. |
| 5276 | CALL DT_GLAUBE(IP,IT,JJPROJ,BIMPAC,NN,NP,NT,JSSH,JTSH,KKMAT) |
| 5277 | * --- Added by Chiara to monit impact parameter generation |
| 5278 | * PRINT *,' Impact parameter generation : b = ', BIMPAC, 'fm' |
| 5279 | NWTSAM = NN |
| 5280 | NWASAM = NP |
| 5281 | NWBSAM = NT |
| 5282 | NEVOLD = NEVHKK |
| 5283 | IPOLD = IP |
| 5284 | ITOLD = IT |
| 5285 | JJPOLD = JJPROJ |
| 5286 | EPROLD = EPROJ |
| 5287 | ENDIF |
| 5288 | |
| 5289 | * force diffractive particle production in h-K interactions |
| 5290 | IF (((ABS(ISINGD).GT.1).OR.(ABS(IDOUBD).GT.1)).AND. |
| 5291 | & (IP.EQ.1).AND.(NN.NE.1)) THEN |
| 5292 | NEVOLD = 0 |
| 5293 | GOTO 10 |
| 5294 | ENDIF |
| 5295 | |
| 5296 | * check number of involved proj. nucl. (NP) if central prod.is requested |
| 5297 | IF (ICENTR.GT.0) THEN |
| 5298 | CALL DT_CHKCEN(IP,IT,NP,NT,IBACK) |
| 5299 | IF (IBACK.GT.0) GOTO 10 |
| 5300 | ENDIF |
| 5301 | |
| 5302 | * get initial nucleon-configuration in projectile and target |
| 5303 | * rest-system (including Fermi-momenta if requested) |
| 5304 | CALL DT_ININUC(IJPROJ,IP,IPZ,PKOO,JSSH,1) |
| 5305 | MODE = 2 |
| 5306 | IF (EPROJ.LE.EHADTH) MODE = 3 |
| 5307 | CALL DT_ININUC(IJTARG,IT,ITZ,TKOO,JTSH,MODE) |
| 5308 | |
| 5309 | IF ((MCGENE.NE.3).AND.(MCGENE.NE.4)) THEN |
| 5310 | |
| 5311 | * activate HADRIN at low energies (implemented for h-N scattering only) |
| 5312 | IF (EPROJ.LE.EHADHI) THEN |
| 5313 | IF (EHADTH.LT.ZERO) THEN |
| 5314 | * smooth transition btwn. DPM and HADRIN |
| 5315 | FRAC = (EPROJ-EHADLO)/(EHADHI-EHADLO) |
| 5316 | RR = DT_RNDM(FRAC) |
| 5317 | IF (RR.GT.FRAC) THEN |
| 5318 | IF (IP.EQ.1) THEN |
| 5319 | CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1) |
| 5320 | IF (IREJ1.GT.0) GOTO 1 |
| 5321 | RETURN |
| 5322 | ELSE |
| 5323 | WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH |
| 5324 | ENDIF |
| 5325 | ENDIF |
| 5326 | ELSE |
| 5327 | * fixed threshold for onset of production via HADRIN |
| 5328 | IF (EPROJ.LE.EHADTH) THEN |
| 5329 | IF (IP.EQ.1) THEN |
| 5330 | CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1) |
| 5331 | IF (IREJ1.GT.0) GOTO 1 |
| 5332 | RETURN |
| 5333 | ELSE |
| 5334 | WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH |
| 5335 | ENDIF |
| 5336 | ENDIF |
| 5337 | ENDIF |
| 5338 | ENDIF |
| 5339 | 1001 FORMAT(1X,'KKEVNT: warning! interaction of proj. (m=', |
| 5340 | & I3,') with target (m=',I3,')',/,11X, |
| 5341 | & 'at E_lab=',F5.1,'GeV (threshold-energy: ',F3.1, |
| 5342 | & 'GeV) cannot be handled') |
| 5343 | |
| 5344 | * sampling of momentum-x fractions & flavors of chain ends |
| 5345 | CALL DT_SPLPTN(NN) |
| 5346 | |
| 5347 | * Lorentz-transformation of wounded nucleons into nucl.-nucl. cms |
| 5348 | CALL DT_NUC2CM |
| 5349 | |
| 5350 | * collect momenta of chain ends and put them into DTEVT1 |
| 5351 | CALL DT_GETPTN(IP,NN,NCSY,IREJ1) |
| 5352 | IF (IREJ1.NE.0) GOTO 1 |
| 5353 | |
| 5354 | ENDIF |
| 5355 | |
| 5356 | * handle chains including fragmentation (two-chain approximation) |
| 5357 | IF (MCGENE.EQ.1) THEN |
| 5358 | * two-chain approximation |
| 5359 | CALL DT_EVENTA(IJPROJ,IP,IT,NCSY,IREJ1) |
| 5360 | IF (IREJ1.NE.0) THEN |
| 5361 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKEVNT' |
| 5362 | GOTO 1 |
| 5363 | ENDIF |
| 5364 | ELSEIF (MCGENE.EQ.2) THEN |
| 5365 | * multiple-Po exchange including minijets |
| 5366 | CALL DT_EVENTB(NCSY,IREJ1) |
| 5367 | IF (IREJ1.NE.0) THEN |
| 5368 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKEVNT' |
| 5369 | GOTO 1 |
| 5370 | ENDIF |
| 5371 | ELSEIF (MCGENE.EQ.3) THEN |
| 5372 | |
| 5373 | STOP ' This version does not contain LEPTO !' |
| 5374 | |
| 5375 | ELSEIF (MCGENE.EQ.4) THEN |
| 5376 | * quasi-elastic neutrino scattering |
| 5377 | CALL DT_EVENTD(IREJ1) |
| 5378 | IF (IREJ1.NE.0) THEN |
| 5379 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 4 in KKEVNT' |
| 5380 | GOTO 1 |
| 5381 | ENDIF |
| 5382 | ELSE |
| 5383 | WRITE(LOUT,1002) MCGENE |
| 5384 | 1002 FORMAT(1X,'KKEVNT: warning! event-generator',I4, |
| 5385 | & ' not available - program stopped') |
| 5386 | STOP |
| 5387 | ENDIF |
| 5388 | |
| 5389 | RETURN |
| 5390 | |
| 5391 | 9999 CONTINUE |
| 5392 | IREJ = 1 |
| 5393 | RETURN |
| 5394 | END |
| 5395 | * |
| 5396 | *===chkcen=============================================================* |
| 5397 | * |
| 5398 | CDECK ID>, DT_CHKCEN |
| 5399 | SUBROUTINE DT_CHKCEN(IP,IT,NP,NT,IBACK) |
| 5400 | |
| 5401 | ************************************************************************ |
| 5402 | * Check of number of involved projectile nucleons if central production* |
| 5403 | * is requested. * |
| 5404 | * Adopted from a part of the old KKEVT routine which was written by * |
| 5405 | * J. Ranft/H.-J.Moehring. * |
| 5406 | * This version dated 13.01.95 is written by S. Roesler * |
| 5407 | ************************************************************************ |
| 5408 | |
| 5409 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 5410 | SAVE |
| 5411 | |
| 5412 | PARAMETER ( LINP = 5 , |
| 5413 | & LOUT = 6 , |
| 5414 | & LDAT = 9 ) |
| 5415 | |
| 5416 | * statistics |
| 5417 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, |
| 5418 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), |
| 5419 | & ICEVTG(8,0:30) |
| 5420 | * central particle production, impact parameter biasing |
| 5421 | COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR |
| 5422 | |
| 5423 | IBACK = 0 |
| 5424 | |
| 5425 | * old version |
| 5426 | IF (ICENTR.EQ.2) THEN |
| 5427 | IF (IP.LT.IT) THEN |
| 5428 | IF (IP.LE.8) THEN |
| 5429 | IF (NP.LT.IP-1) IBACK = 1 |
| 5430 | ELSEIF (IP.LE.16) THEN |
| 5431 | IF (NP.LT.IP-2) IBACK = 1 |
| 5432 | ELSEIF (IP.LE.32) THEN |
| 5433 | IF (NP.LT.IP-3) IBACK = 1 |
| 5434 | ELSEIF (IP.GE.33) THEN |
| 5435 | IF (NP.LT.IP-5) IBACK = 1 |
| 5436 | ENDIF |
| 5437 | ELSEIF (IP.EQ.IT) THEN |
| 5438 | IF (IP.EQ.32) THEN |
| 5439 | IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1 |
| 5440 | ELSE |
| 5441 | IF (NP.LT.IP-IP/8) IBACK = 1 |
| 5442 | ENDIF |
| 5443 | ELSEIF (ABS(IP-IT).LT.3) THEN |
| 5444 | IF (NP.LT.IP-IP/8) IBACK = 1 |
| 5445 | ENDIF |
| 5446 | ELSE |
| 5447 | * new version (DPMJET, 5.6.99) |
| 5448 | IF (IP.LT.IT) THEN |
| 5449 | IF (IP.LE.8) THEN |
| 5450 | IF (NP.LT.IP-1) IBACK = 1 |
| 5451 | ELSEIF (IP.LE.16) THEN |
| 5452 | IF (NP.LT.IP-2) IBACK = 1 |
| 5453 | ELSEIF (IP.LT.32) THEN |
| 5454 | IF (NP.LT.IP-3) IBACK = 1 |
| 5455 | ELSEIF (IP.GE.32) THEN |
| 5456 | IF (IT.LE.150) THEN |
| 5457 | * Example: S-Ag |
| 5458 | IF (NP.LT.IP-1) IBACK = 1 |
| 5459 | ELSE |
| 5460 | * Example: S-Au |
| 5461 | IF (NP.LT.IP) IBACK = 1 |
| 5462 | ENDIF |
| 5463 | ENDIF |
| 5464 | ELSEIF (IP.EQ.IT) THEN |
| 5465 | * Example: S-S |
| 5466 | IF (IP.EQ.32) THEN |
| 5467 | IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1 |
| 5468 | * Example: Pb-Pb |
| 5469 | ELSE |
| 5470 | IF (NP.LT.IP-IP/4) IBACK = 1 |
| 5471 | ENDIF |
| 5472 | ELSEIF (ABS(IP-IT).LT.3) THEN |
| 5473 | IF (NP.LT.IP-IP/8) IBACK = 1 |
| 5474 | ENDIF |
| 5475 | ENDIF |
| 5476 | |
| 5477 | ICCPRO = ICCPRO+1 |
| 5478 | |
| 5479 | RETURN |
| 5480 | END |
| 5481 | * |
| 5482 | *===ininuc=============================================================* |
| 5483 | * |
| 5484 | CDECK ID>, DT_ININUC |
| 5485 | SUBROUTINE DT_ININUC(ID,NMASS,NCH,COORD,JS,IMODE) |
| 5486 | |
| 5487 | ************************************************************************ |
| 5488 | * Samples initial configuration of nucleons in nucleus with mass NMASS * |
| 5489 | * including Fermi-momenta (if reqested). * |
| 5490 | * ID BAMJET-code for hadrons (instead of nuclei) * |
| 5491 | * NMASS mass number of nucleus (number of nucleons) * |
| 5492 | * NCH charge of nucleus * |
| 5493 | * COORD(3,NMASS) coordinates of nucleons inside nucleus in fm * |
| 5494 | * JS(NMASS) > 0 nucleon undergoes nucleon-nucleon interact. * |
| 5495 | * IMODE = 1 projectile nucleus * |
| 5496 | * = 2 target nucleus * |
| 5497 | * = 3 target nucleus (E_lab<E_thr for HADRIN) * |
| 5498 | * Adopted from a part of the old KKEVT routine which was written by * |
| 5499 | * J. Ranft/H.-J.Moehring. * |
| 5500 | * This version dated 13.01.95 is written by S. Roesler * |
| 5501 | ************************************************************************ |
| 5502 | |
| 5503 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 5504 | SAVE |
| 5505 | |
| 5506 | PARAMETER ( LINP = 5 , |
| 5507 | & LOUT = 6 , |
| 5508 | & LDAT = 9 ) |
| 5509 | |
| 5510 | PARAMETER (FM2MM=1.0D-12) |
| 5511 | |
| 5512 | PARAMETER ( MAXNCL = 260, |
| 5513 | |
| 5514 | & MAXVQU = MAXNCL, |
| 5515 | & MAXSQU = 20*MAXVQU, |
| 5516 | & MAXINT = MAXVQU+MAXSQU) |
| 5517 | * event history |
| 5518 | |
| 5519 | PARAMETER (NMXHKK=200000) |
| 5520 | |
| 5521 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 5522 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 5523 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 5524 | * extended event history |
| 5525 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 5526 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 5527 | & IHIST(2,NMXHKK) |
| 5528 | * flags for input different options |
| 5529 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 5530 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 5531 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 5532 | * auxiliary common for chain system storage (DTUNUC 1.x) |
| 5533 | COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL) |
| 5534 | * nuclear potential |
| 5535 | LOGICAL LFERMI |
| 5536 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, |
| 5537 | & EBINDP(2),EBINDN(2),EPOT(2,210), |
| 5538 | & ETACOU(2),ICOUL,LFERMI |
| 5539 | * properties of photon/lepton projectiles |
| 5540 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC |
| 5541 | * particle properties (BAMJET index convention) |
| 5542 | CHARACTER*8 ANAME |
| 5543 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 5544 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 5545 | * Glauber formalism: collision properties |
| 5546 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, |
| 5547 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC |
| 5548 | * flavors of partons (DTUNUC 1.x) |
| 5549 | COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU), |
| 5550 | & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU), |
| 5551 | & IPSQ(MAXSQU),IPSQ2(MAXSQU), |
| 5552 | & IPSAQ(MAXSQU),IPSAQ2(MAXSQU), |
| 5553 | & ITSQ(MAXSQU),ITSQ2(MAXSQU), |
| 5554 | & ITSAQ(MAXSQU),ITSAQ2(MAXSQU), |
| 5555 | & KKPROJ(MAXVQU),KKTARG(MAXVQU) |
| 5556 | * interface HADRIN-DPM |
| 5557 | COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA |
| 5558 | |
| 5559 | DIMENSION PF(4),PFTOT(4),COORD(3,MAXNCL),JS(MAXNCL) |
| 5560 | |
| 5561 | * number of neutrons |
| 5562 | NNEU = NMASS-NCH |
| 5563 | * initializations |
| 5564 | NP = 0 |
| 5565 | NN = 0 |
| 5566 | DO 1 K=1,4 |
| 5567 | PFTOT(K) = 0.0D0 |
| 5568 | 1 CONTINUE |
| 5569 | MODE = IMODE |
| 5570 | IF (IMODE.GT.2) MODE = 2 |
| 5571 | **sr 29.5. new NPOINT(1)-definition |
| 5572 | C IF (IMODE.GE.2) NPOINT(1) = NHKK+1 |
| 5573 | ** |
| 5574 | NHADRI = 0 |
| 5575 | NC = NHKK |
| 5576 | |
| 5577 | * get initial configuration |
| 5578 | DO 2 I=1,NMASS |
| 5579 | NHKK = NHKK+1 |
| 5580 | IF (JS(I).GT.0) THEN |
| 5581 | ISTHKK(NHKK) = 10+MODE |
| 5582 | IF (IMODE.EQ.3) THEN |
| 5583 | * additional treatment if HADRIN-generator is requested |
| 5584 | NHADRI = NHADRI+1 |
| 5585 | IF (NHADRI.EQ.1) IDXTA = NHKK |
| 5586 | IF (NHADRI.GT.1) ISTHKK(NHKK) = 14 |
| 5587 | ENDIF |
| 5588 | ELSE |
| 5589 | ISTHKK(NHKK) = 12+MODE |
| 5590 | ENDIF |
| 5591 | IF (NMASS.GE.2) THEN |
| 5592 | * treatment for nuclei |
| 5593 | FRAC = 1.0D0-DBLE(NCH)/DBLE(NMASS) |
| 5594 | RR = DT_RNDM(FRAC) |
| 5595 | IF ((RR.LT.FRAC).AND.(NN.LT.NNEU)) THEN |
| 5596 | IDX = 8 |
| 5597 | NN = NN+1 |
| 5598 | ELSEIF ((RR.GE.FRAC).AND.(NP.LT.NCH)) THEN |
| 5599 | IDX = 1 |
| 5600 | NP = NP+1 |
| 5601 | ELSEIF (NN.LT.NNEU) THEN |
| 5602 | IDX = 8 |
| 5603 | NN = NN+1 |
| 5604 | ELSEIF (NP.LT.NCH) THEN |
| 5605 | IDX = 1 |
| 5606 | NP = NP+1 |
| 5607 | ENDIF |
| 5608 | IDHKK(NHKK) = IDT_IPDGHA(IDX) |
| 5609 | IDBAM(NHKK) = IDX |
| 5610 | IF (MODE.EQ.1) THEN |
| 5611 | IPOSP(I) = NHKK |
| 5612 | KKPROJ(I) = IDX |
| 5613 | ELSE |
| 5614 | IPOST(I) = NHKK |
| 5615 | KKTARG(I) = IDX |
| 5616 | ENDIF |
| 5617 | IF (IDX.EQ.1) THEN |
| 5618 | PFER = PFERMP(MODE) |
| 5619 | PBIN = SQRT(2.0D0*EBINDP(MODE)*AAM(1)) |
| 5620 | ELSE |
| 5621 | PFER = PFERMN(MODE) |
| 5622 | PBIN = SQRT(2.0D0*EBINDN(MODE)*AAM(8)) |
| 5623 | ENDIF |
| 5624 | CALL DT_FER4M(PFER,PBIN,PF(1),PF(2),PF(3),PF(4),IDX) |
| 5625 | DO 3 K=1,4 |
| 5626 | PFTOT(K) = PFTOT(K)+PF(K) |
| 5627 | PHKK(K,NHKK) = PF(K) |
| 5628 | 3 CONTINUE |
| 5629 | PHKK(5,NHKK) = AAM(IDX) |
| 5630 | ELSE |
| 5631 | * treatment for hadrons |
| 5632 | IDHKK(NHKK) = IDT_IPDGHA(ID) |
| 5633 | IDBAM(NHKK) = ID |
| 5634 | PHKK(4,NHKK) = AAM(ID) |
| 5635 | PHKK(5,NHKK) = AAM(ID) |
| 5636 | C* VDM assumption |
| 5637 | C IF (IDHKK(NHKK).EQ.22) THEN |
| 5638 | C PHKK(4,NHKK) = AAM(33) |
| 5639 | C PHKK(5,NHKK) = AAM(33) |
| 5640 | C ENDIF |
| 5641 | IF (MODE.EQ.1) THEN |
| 5642 | IPOSP(I) = NHKK |
| 5643 | KKPROJ(I) = ID |
| 5644 | PHKK(5,NHKK) = PHKK(5,NHKK)-SQRT(VIRT) |
| 5645 | ELSE |
| 5646 | IPOST(I) = NHKK |
| 5647 | KKTARG(I) = ID |
| 5648 | ENDIF |
| 5649 | ENDIF |
| 5650 | DO 4 K=1,3 |
| 5651 | VHKK(K,NHKK) = COORD(K,I)*FM2MM |
| 5652 | WHKK(K,NHKK) = COORD(K,I)*FM2MM |
| 5653 | 4 CONTINUE |
| 5654 | IF (MODE.EQ.2) VHKK(1,NHKK) = VHKK(1,NHKK)+BIMPAC*FM2MM |
| 5655 | IF (MODE.EQ.2) WHKK(1,NHKK) = WHKK(1,NHKK)+BIMPAC*FM2MM |
| 5656 | VHKK(4,NHKK) = 0.0D0 |
| 5657 | WHKK(4,NHKK) = 0.0D0 |
| 5658 | 2 CONTINUE |
| 5659 | |
| 5660 | * balance Fermi-momenta |
| 5661 | IF (NMASS.GE.2) THEN |
| 5662 | DO 5 I=1,NMASS |
| 5663 | NC = NC+1 |
| 5664 | DO 6 K=1,3 |
| 5665 | PHKK(K,NC) = PHKK(K,NC)-PFTOT(K)/DBLE(NMASS) |
| 5666 | 6 CONTINUE |
| 5667 | PHKK(4,NC) = SQRT(PHKK(5,NC)**2+PHKK(1,NC)**2+ |
| 5668 | & PHKK(2,NC)**2+PHKK(3,NC)**2) |
| 5669 | 5 CONTINUE |
| 5670 | ENDIF |
| 5671 | |
| 5672 | RETURN |
| 5673 | END |
| 5674 | * |
| 5675 | *===fer4m==============================================================* |
| 5676 | * |
| 5677 | CDECK ID>, DT_FER4M |
| 5678 | SUBROUTINE DT_FER4M(PFERM,PBIND,PXT,PYT,PZT,ET,KT) |
| 5679 | |
| 5680 | ************************************************************************ |
| 5681 | * Sampling of nucleon Fermi-momenta from distributions at T=0. * |
| 5682 | * processed by S. Roesler, 17.10.95 * |
| 5683 | ************************************************************************ |
| 5684 | |
| 5685 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 5686 | SAVE |
| 5687 | |
| 5688 | PARAMETER ( LINP = 5 , |
| 5689 | & LOUT = 6 , |
| 5690 | & LDAT = 9 ) |
| 5691 | |
| 5692 | LOGICAL LSTART |
| 5693 | |
| 5694 | * particle properties (BAMJET index convention) |
| 5695 | CHARACTER*8 ANAME |
| 5696 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 5697 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 5698 | * nuclear potential |
| 5699 | LOGICAL LFERMI |
| 5700 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, |
| 5701 | & EBINDP(2),EBINDN(2),EPOT(2,210), |
| 5702 | & ETACOU(2),ICOUL,LFERMI |
| 5703 | |
| 5704 | DATA LSTART /.TRUE./ |
| 5705 | |
| 5706 | ILOOP = 0 |
| 5707 | IF (LFERMI) THEN |
| 5708 | IF (LSTART) THEN |
| 5709 | WRITE(LOUT,1000) |
| 5710 | 1000 FORMAT(/,1X,'FER4M: sampling of Fermi-momenta activated') |
| 5711 | LSTART = .FALSE. |
| 5712 | ENDIF |
| 5713 | 1 CONTINUE |
| 5714 | CALL DT_DFERMI(PABS) |
| 5715 | PABS = PFERM*PABS |
| 5716 | C IF (PABS.GE.PBIND) THEN |
| 5717 | C ILOOP = ILOOP+1 |
| 5718 | C IF (MOD(ILOOP,500).EQ.0) THEN |
| 5719 | C WRITE(LOUT,1001) PABS,PBIND,ILOOP |
| 5720 | C1001 FORMAT(1X,'FER4M: Fermi-mom. corr. for binding', |
| 5721 | C & ' energy ',2E12.3,I6) |
| 5722 | C ENDIF |
| 5723 | C GOTO 1 |
| 5724 | C ENDIF |
| 5725 | CALL DT_DPOLI(POLC,POLS) |
| 5726 | CALL DT_DSFECF(SFE,CFE) |
| 5727 | CXTA = POLS*CFE |
| 5728 | CYTA = POLS*SFE |
| 5729 | CZTA = POLC |
| 5730 | ET = SQRT(PABS*PABS+AAM(KT)**2) |
| 5731 | PXT = CXTA*PABS |
| 5732 | PYT = CYTA*PABS |
| 5733 | PZT = CZTA*PABS |
| 5734 | ELSE |
| 5735 | ET = AAM(KT) |
| 5736 | PXT = 0.0D0 |
| 5737 | PYT = 0.0D0 |
| 5738 | PZT = 0.0D0 |
| 5739 | ENDIF |
| 5740 | |
| 5741 | RETURN |
| 5742 | END |
| 5743 | * |
| 5744 | *===nuc2cm=============================================================* |
| 5745 | * |
| 5746 | CDECK ID>, DT_NUC2CM |
| 5747 | SUBROUTINE DT_NUC2CM |
| 5748 | |
| 5749 | ************************************************************************ |
| 5750 | * Lorentz-transformation of all wounded nucleons from Lab. to nucl.- * |
| 5751 | * nucl. cms. (This subroutine replaces NUCMOM.) * |
| 5752 | * This version dated 15.01.95 is written by S. Roesler * |
| 5753 | ************************************************************************ |
| 5754 | |
| 5755 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 5756 | SAVE |
| 5757 | |
| 5758 | PARAMETER ( LINP = 5 , |
| 5759 | & LOUT = 6 , |
| 5760 | & LDAT = 9 ) |
| 5761 | |
| 5762 | PARAMETER (ZERO=0.0D0,TINY3=1.0D-3) |
| 5763 | |
| 5764 | * event history |
| 5765 | |
| 5766 | PARAMETER (NMXHKK=200000) |
| 5767 | |
| 5768 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 5769 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 5770 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 5771 | * extended event history |
| 5772 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 5773 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 5774 | & IHIST(2,NMXHKK) |
| 5775 | * statistics |
| 5776 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, |
| 5777 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), |
| 5778 | & ICEVTG(8,0:30) |
| 5779 | * properties of photon/lepton projectiles |
| 5780 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC |
| 5781 | * particle properties (BAMJET index convention) |
| 5782 | CHARACTER*8 ANAME |
| 5783 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 5784 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 5785 | * Glauber formalism: collision properties |
| 5786 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, |
| 5787 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC |
| 5788 | **temporary |
| 5789 | * statistics: Glauber-formalism |
| 5790 | COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB |
| 5791 | ** |
| 5792 | |
| 5793 | ICWP = 0 |
| 5794 | ICWT = 0 |
| 5795 | NWTACC = 0 |
| 5796 | NWAACC = 0 |
| 5797 | NWBACC = 0 |
| 5798 | |
| 5799 | NPOINT(1) = NHKK+1 |
| 5800 | NEND = NHKK |
| 5801 | DO 1 I=1,NEND |
| 5802 | IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.12)) THEN |
| 5803 | IF (ISTHKK(I).EQ.11) NWAACC = NWAACC+1 |
| 5804 | IF (ISTHKK(I).EQ.12) NWBACC = NWBACC+1 |
| 5805 | MODE = ISTHKK(I)-9 |
| 5806 | C IF (IDHKK(I).EQ.22) THEN |
| 5807 | C* VDM assumption |
| 5808 | C PEIN = AAM(33) |
| 5809 | C IDB = 33 |
| 5810 | C ELSE |
| 5811 | C PEIN = PHKK(4,I) |
| 5812 | C IDB = IDBAM(I) |
| 5813 | C ENDIF |
| 5814 | C CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PEIN, |
| 5815 | C & PX,PY,PZ,PE,IDB,MODE) |
| 5816 | IF (PHKK(5,I).GT.ZERO) THEN |
| 5817 | CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I), |
| 5818 | & PX,PY,PZ,PE,IDBAM(I),MODE) |
| 5819 | ELSE |
| 5820 | PX = PGAMM(1) |
| 5821 | PY = PGAMM(2) |
| 5822 | PZ = PGAMM(3) |
| 5823 | PE = PGAMM(4) |
| 5824 | ENDIF |
| 5825 | IST = ISTHKK(I)-2 |
| 5826 | ID = IDHKK(I) |
| 5827 | C* VDM assumption |
| 5828 | C IF (ID.EQ.22) ID = 113 |
| 5829 | CALL DT_EVTPUT(IST,ID,I,0,PX,PY,PZ,PE,0,0,0) |
| 5830 | IF (ISTHKK(I).EQ.11) ICWP = ICWP+1 |
| 5831 | IF (ISTHKK(I).EQ.12) ICWT = ICWT+1 |
| 5832 | ENDIF |
| 5833 | 1 CONTINUE |
| 5834 | |
| 5835 | NWTACC = MAX(NWAACC,NWBACC) |
| 5836 | ICDPR = ICDPR+ICWP |
| 5837 | ICDTA = ICDTA+ICWT |
| 5838 | **temporary |
| 5839 | IF ((ICWP.EQ.0).OR.(ICWT.EQ.0)) THEN |
| 5840 | CALL DT_EVTOUT(4) |
| 5841 | STOP |
| 5842 | ENDIF |
| 5843 | |
| 5844 | RETURN |
| 5845 | END |
| 5846 | * |
| 5847 | *===splptn=============================================================* |
| 5848 | * |
| 5849 | CDECK ID>, DT_SPLPTN |
| 5850 | SUBROUTINE DT_SPLPTN(NN) |
| 5851 | |
| 5852 | ************************************************************************ |
| 5853 | * SamPLing of ParToN momenta and flavors. * |
| 5854 | * This version dated 15.01.95 is written by S. Roesler * |
| 5855 | ************************************************************************ |
| 5856 | |
| 5857 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 5858 | SAVE |
| 5859 | |
| 5860 | PARAMETER ( LINP = 5 , |
| 5861 | & LOUT = 6 , |
| 5862 | & LDAT = 9 ) |
| 5863 | |
| 5864 | * Lorentz-parameters of the current interaction |
| 5865 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, |
| 5866 | & UMO,PPCM,EPROJ,PPROJ |
| 5867 | |
| 5868 | * sample flavors of sea-quarks |
| 5869 | CALL DT_SPLFLA(NN,1) |
| 5870 | |
| 5871 | * sample x-values of partons at chain ends |
| 5872 | ECM = UMO |
| 5873 | CALL DT_XKSAMP(NN,ECM) |
| 5874 | |
| 5875 | * samle flavors |
| 5876 | CALL DT_SPLFLA(NN,2) |
| 5877 | |
| 5878 | RETURN |
| 5879 | END |
| 5880 | * |
| 5881 | *===splfla=============================================================* |
| 5882 | * |
| 5883 | CDECK ID>, DT_SPLFLA |
| 5884 | SUBROUTINE DT_SPLFLA(NN,MODE) |
| 5885 | |
| 5886 | ************************************************************************ |
| 5887 | * SamPLing of FLAvors of partons at chain ends. * |
| 5888 | * This subroutine replaces FLKSAA/FLKSAM. * |
| 5889 | * NN number of nucleon-nucleon interactions * |
| 5890 | * MODE = 1 sea-flavors * |
| 5891 | * = 2 valence-flavors * |
| 5892 | * Based on the original version written by J. Ranft/H.-J. Moehring. * |
| 5893 | * This version dated 16.01.95 is written by S. Roesler * |
| 5894 | ************************************************************************ |
| 5895 | |
| 5896 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 5897 | SAVE |
| 5898 | |
| 5899 | PARAMETER ( LINP = 5 , |
| 5900 | & LOUT = 6 , |
| 5901 | & LDAT = 9 ) |
| 5902 | |
| 5903 | PARAMETER ( MAXNCL = 260, |
| 5904 | |
| 5905 | & MAXVQU = MAXNCL, |
| 5906 | & MAXSQU = 20*MAXVQU, |
| 5907 | & MAXINT = MAXVQU+MAXSQU) |
| 5908 | * flavors of partons (DTUNUC 1.x) |
| 5909 | COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU), |
| 5910 | & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU), |
| 5911 | & IPSQ(MAXSQU),IPSQ2(MAXSQU), |
| 5912 | & IPSAQ(MAXSQU),IPSAQ2(MAXSQU), |
| 5913 | & ITSQ(MAXSQU),ITSQ2(MAXSQU), |
| 5914 | & ITSAQ(MAXSQU),ITSAQ2(MAXSQU), |
| 5915 | & KKPROJ(MAXVQU),KKTARG(MAXVQU) |
| 5916 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) |
| 5917 | COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD, |
| 5918 | & IXPV,IXPS,IXTV,IXTS, |
| 5919 | & INTVV1(MAXVQU),INTVV2(MAXVQU), |
| 5920 | & INTSV1(MAXVQU),INTSV2(MAXVQU), |
| 5921 | & INTVS1(MAXVQU),INTVS2(MAXVQU), |
| 5922 | & INTSS1(MAXSQU),INTSS2(MAXSQU), |
| 5923 | & INTDV1(MAXVQU),INTDV2(MAXVQU), |
| 5924 | & INTVD1(MAXVQU),INTVD2(MAXVQU), |
| 5925 | & INTDS1(MAXSQU),INTDS2(MAXSQU), |
| 5926 | & INTSD1(MAXSQU),INTSD2(MAXSQU) |
| 5927 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) |
| 5928 | COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU), |
| 5929 | & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU) |
| 5930 | * particle properties (BAMJET index convention) |
| 5931 | CHARACTER*8 ANAME |
| 5932 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 5933 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 5934 | * various options for treatment of partons (DTUNUC 1.x) |
| 5935 | * (chain recombination, Cronin,..) |
| 5936 | LOGICAL LCO2CR,LINTPT |
| 5937 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, |
| 5938 | & LCO2CR,LINTPT |
| 5939 | |
| 5940 | IF (MODE.EQ.1) THEN |
| 5941 | * sea-flavors |
| 5942 | DO 1 I=1,NN |
| 5943 | IPSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ)) |
| 5944 | IPSAQ(I) = -IPSQ(I) |
| 5945 | 1 CONTINUE |
| 5946 | DO 2 I=1,NN |
| 5947 | ITSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ)) |
| 5948 | ITSAQ(I)= -ITSQ(I) |
| 5949 | 2 CONTINUE |
| 5950 | ELSEIF (MODE.EQ.2) THEN |
| 5951 | * valence flavors |
| 5952 | DO 3 I=1,IXPV |
| 5953 | CALL DT_FLAHAD(KKPROJ(IFROVP(I)),IPVQ(I),IPPV1(I),IPPV2(I)) |
| 5954 | 3 CONTINUE |
| 5955 | DO 4 I=1,IXTV |
| 5956 | CALL DT_FLAHAD(KKTARG(IFROVT(I)),ITVQ(I),ITTV1(I),ITTV2(I)) |
| 5957 | 4 CONTINUE |
| 5958 | ENDIF |
| 5959 | |
| 5960 | RETURN |
| 5961 | END |
| 5962 | * |
| 5963 | *===getptn=============================================================* |
| 5964 | * |
| 5965 | CDECK ID>, DT_GETPTN |
| 5966 | SUBROUTINE DT_GETPTN(IP,NN,NCSY,IREJ) |
| 5967 | |
| 5968 | ************************************************************************ |
| 5969 | * This subroutine collects partons at chain ends from temporary * |
| 5970 | * commons and puts them into DTEVT1. * |
| 5971 | * This version dated 15.01.95 is written by S. Roesler * |
| 5972 | ************************************************************************ |
| 5973 | |
| 5974 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 5975 | SAVE |
| 5976 | |
| 5977 | PARAMETER ( LINP = 5 , |
| 5978 | & LOUT = 6 , |
| 5979 | & LDAT = 9 ) |
| 5980 | |
| 5981 | PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0) |
| 5982 | |
| 5983 | LOGICAL LCHK |
| 5984 | |
| 5985 | PARAMETER ( MAXNCL = 260, |
| 5986 | |
| 5987 | & MAXVQU = MAXNCL, |
| 5988 | & MAXSQU = 20*MAXVQU, |
| 5989 | & MAXINT = MAXVQU+MAXSQU) |
| 5990 | * event history |
| 5991 | |
| 5992 | PARAMETER (NMXHKK=200000) |
| 5993 | |
| 5994 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 5995 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 5996 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 5997 | * extended event history |
| 5998 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 5999 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 6000 | & IHIST(2,NMXHKK) |
| 6001 | * flags for input different options |
| 6002 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 6003 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 6004 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 6005 | * auxiliary common for chain system storage (DTUNUC 1.x) |
| 6006 | COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL) |
| 6007 | * statistics |
| 6008 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, |
| 6009 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), |
| 6010 | & ICEVTG(8,0:30) |
| 6011 | * flags for diffractive interactions (DTUNUC 1.x) |
| 6012 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF |
| 6013 | * x-values of partons (DTUNUC 1.x) |
| 6014 | COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU), |
| 6015 | & XTVQ(MAXVQU),XTVD(MAXVQU), |
| 6016 | & XPSQ(MAXSQU),XPSAQ(MAXSQU), |
| 6017 | & XTSQ(MAXSQU),XTSAQ(MAXSQU) |
| 6018 | * flavors of partons (DTUNUC 1.x) |
| 6019 | COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU), |
| 6020 | & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU), |
| 6021 | & IPSQ(MAXSQU),IPSQ2(MAXSQU), |
| 6022 | & IPSAQ(MAXSQU),IPSAQ2(MAXSQU), |
| 6023 | & ITSQ(MAXSQU),ITSQ2(MAXSQU), |
| 6024 | & ITSAQ(MAXSQU),ITSAQ2(MAXSQU), |
| 6025 | & KKPROJ(MAXVQU),KKTARG(MAXVQU) |
| 6026 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) |
| 6027 | COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD, |
| 6028 | & IXPV,IXPS,IXTV,IXTS, |
| 6029 | & INTVV1(MAXVQU),INTVV2(MAXVQU), |
| 6030 | & INTSV1(MAXVQU),INTSV2(MAXVQU), |
| 6031 | & INTVS1(MAXVQU),INTVS2(MAXVQU), |
| 6032 | & INTSS1(MAXSQU),INTSS2(MAXSQU), |
| 6033 | & INTDV1(MAXVQU),INTDV2(MAXVQU), |
| 6034 | & INTVD1(MAXVQU),INTVD2(MAXVQU), |
| 6035 | & INTDS1(MAXSQU),INTDS2(MAXSQU), |
| 6036 | & INTSD1(MAXSQU),INTSD2(MAXSQU) |
| 6037 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) |
| 6038 | COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU), |
| 6039 | & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU) |
| 6040 | |
| 6041 | DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PP(4),PT(4) |
| 6042 | |
| 6043 | DATA AMSS,AMVS,AMDS,AMVD,AMVV/0.4D0,2.0D0,2.0D0,2.5D0,2.0D0/ |
| 6044 | |
| 6045 | IREJ = 0 |
| 6046 | NCSY = 0 |
| 6047 | NPOINT(2) = NHKK+1 |
| 6048 | |
| 6049 | * sea-sea chains |
| 6050 | DO 10 I=1,NSS |
| 6051 | IF (ISKPCH(1,I).EQ.99) GOTO 10 |
| 6052 | ICCHAI(1,1) = ICCHAI(1,1)+2 |
| 6053 | IDXP = INTSS1(I) |
| 6054 | IDXT = INTSS2(I) |
| 6055 | MOP = JDAHKK(1,IPOSP(IFROSP(IDXP))) |
| 6056 | MOT = JDAHKK(1,IPOST(IFROST(IDXT))) |
| 6057 | DO 11 K=1,4 |
| 6058 | PP1(K) = XPSQ(IDXP) *PHKK(K,MOP) |
| 6059 | PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP) |
| 6060 | PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT) |
| 6061 | PT2(K) = XTSQ(IDXT) *PHKK(K,MOT) |
| 6062 | 11 CONTINUE |
| 6063 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 |
| 6064 | & +(PP1(3)+PT1(3))**2) |
| 6065 | ECH = PP1(4)+PT1(4) |
| 6066 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) |
| 6067 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 |
| 6068 | & +(PP2(3)+PT2(3))**2) |
| 6069 | ECH = PP2(4)+PT2(4) |
| 6070 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) |
| 6071 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN |
| 6072 | AM1 = SQRT(AM1) |
| 6073 | AM2 = SQRT(AM2) |
| 6074 | IF ((AM1.LT.AMSS).OR.(AM2.LT.AMSS)) THEN |
| 6075 | C WRITE(LOUT,5000) NEVHKK,I,AM1,AM2 |
| 6076 | 5000 FORMAT(1X,'incon. chain mass SS: ',2I5,2E10.3) |
| 6077 | ENDIF |
| 6078 | ELSE |
| 6079 | WRITE(LOUT,5000) NEVHKK,I,AM1,AM2 |
| 6080 | ENDIF |
| 6081 | IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2) |
| 6082 | IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2) |
| 6083 | IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2) |
| 6084 | IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2) |
| 6085 | CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), |
| 6086 | & 0,0,1) |
| 6087 | CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), |
| 6088 | & 0,0,1) |
| 6089 | CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), |
| 6090 | & 0,0,1) |
| 6091 | CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), |
| 6092 | & 0,0,1) |
| 6093 | NCSY = NCSY+1 |
| 6094 | 10 CONTINUE |
| 6095 | |
| 6096 | * disea-sea chains |
| 6097 | DO 20 I=1,NDS |
| 6098 | IF (ISKPCH(2,I).EQ.99) GOTO 20 |
| 6099 | ICCHAI(1,2) = ICCHAI(1,2)+2 |
| 6100 | IDXP = INTDS1(I) |
| 6101 | IDXT = INTDS2(I) |
| 6102 | MOP = JDAHKK(1,IPOSP(IFROSP(IDXP))) |
| 6103 | MOT = JDAHKK(1,IPOST(IFROST(IDXT))) |
| 6104 | DO 21 K=1,4 |
| 6105 | PP1(K) = XPSQ(IDXP) *PHKK(K,MOP) |
| 6106 | PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP) |
| 6107 | PT1(K) = XTSQ(IDXT) *PHKK(K,MOT) |
| 6108 | PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT) |
| 6109 | 21 CONTINUE |
| 6110 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 |
| 6111 | & +(PP1(3)+PT1(3))**2) |
| 6112 | ECH = PP1(4)+PT1(4) |
| 6113 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) |
| 6114 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 |
| 6115 | & +(PP2(3)+PT2(3))**2) |
| 6116 | ECH = PP2(4)+PT2(4) |
| 6117 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) |
| 6118 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN |
| 6119 | AM1 = SQRT(AM1) |
| 6120 | AM2 = SQRT(AM2) |
| 6121 | IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN |
| 6122 | C WRITE(LOUT,5001) NEVHKK,I,AM1,AM2 |
| 6123 | 5001 FORMAT(1X,'incon. chain mass DS: ',2I5,2E10.3) |
| 6124 | ENDIF |
| 6125 | ELSE |
| 6126 | WRITE(LOUT,5001) NEVHKK,I,AM1,AM2 |
| 6127 | ENDIF |
| 6128 | IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2) |
| 6129 | IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2) |
| 6130 | IFT1 = IDT_IB2PDG(ITSQ(IDXT),0,2) |
| 6131 | IFT2 = IDT_IB2PDG(ITSAQ(IDXT),0,2) |
| 6132 | CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), |
| 6133 | & 0,0,2) |
| 6134 | CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), |
| 6135 | & 0,0,2) |
| 6136 | CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), |
| 6137 | & 0,0,2) |
| 6138 | CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), |
| 6139 | & 0,0,2) |
| 6140 | NCSY = NCSY+1 |
| 6141 | 20 CONTINUE |
| 6142 | |
| 6143 | * sea-disea chains |
| 6144 | DO 30 I=1,NSD |
| 6145 | IF (ISKPCH(3,I).EQ.99) GOTO 30 |
| 6146 | ICCHAI(1,3) = ICCHAI(1,3)+2 |
| 6147 | IDXP = INTSD1(I) |
| 6148 | IDXT = INTSD2(I) |
| 6149 | MOP = JDAHKK(1,IPOSP(IFROSP(IDXP))) |
| 6150 | MOT = JDAHKK(1,IPOST(IFROST(IDXT))) |
| 6151 | DO 31 K=1,4 |
| 6152 | PP1(K) = XPSQ(IDXP) *PHKK(K,MOP) |
| 6153 | PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP) |
| 6154 | PT1(K) = XTSQ(IDXT) *PHKK(K,MOT) |
| 6155 | PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT) |
| 6156 | 31 CONTINUE |
| 6157 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 |
| 6158 | & +(PP1(3)+PT1(3))**2) |
| 6159 | ECH = PP1(4)+PT1(4) |
| 6160 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) |
| 6161 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 |
| 6162 | & +(PP2(3)+PT2(3))**2) |
| 6163 | ECH = PP2(4)+PT2(4) |
| 6164 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) |
| 6165 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN |
| 6166 | AM1 = SQRT(AM1) |
| 6167 | AM2 = SQRT(AM2) |
| 6168 | IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN |
| 6169 | C WRITE(LOUT,5002) NEVHKK,I,AM1,AM2 |
| 6170 | 5002 FORMAT(1X,'incon. chain mass SD: ',2I5,2E10.3) |
| 6171 | ENDIF |
| 6172 | ELSE |
| 6173 | WRITE(LOUT,5002) NEVHKK,I,AM1,AM2 |
| 6174 | ENDIF |
| 6175 | IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2) |
| 6176 | IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2) |
| 6177 | IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2) |
| 6178 | IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2) |
| 6179 | CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), |
| 6180 | & 0,0,3) |
| 6181 | CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), |
| 6182 | & 0,0,3) |
| 6183 | CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), |
| 6184 | & 0,0,3) |
| 6185 | CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), |
| 6186 | & 0,0,3) |
| 6187 | NCSY = NCSY+1 |
| 6188 | 30 CONTINUE |
| 6189 | |
| 6190 | * disea-valence chains |
| 6191 | DO 50 I=1,NDV |
| 6192 | IF (ISKPCH(5,I).EQ.99) GOTO 50 |
| 6193 | ICCHAI(1,5) = ICCHAI(1,5)+2 |
| 6194 | IDXP = INTDV1(I) |
| 6195 | IDXT = INTDV2(I) |
| 6196 | MOP = JDAHKK(1,IPOSP(IFROSP(IDXP))) |
| 6197 | MOT = JDAHKK(1,IPOST(IFROVT(IDXT))) |
| 6198 | DO 51 K=1,4 |
| 6199 | PP1(K) = XPSQ(IDXP) *PHKK(K,MOP) |
| 6200 | PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP) |
| 6201 | PT1(K) = XTVQ(IDXT) *PHKK(K,MOT) |
| 6202 | PT2(K) = XTVD(IDXT) *PHKK(K,MOT) |
| 6203 | 51 CONTINUE |
| 6204 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 |
| 6205 | & +(PP1(3)+PT1(3))**2) |
| 6206 | ECH = PP1(4)+PT1(4) |
| 6207 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) |
| 6208 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 |
| 6209 | & +(PP2(3)+PT2(3))**2) |
| 6210 | ECH = PP2(4)+PT2(4) |
| 6211 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) |
| 6212 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN |
| 6213 | AM1 = SQRT(AM1) |
| 6214 | AM2 = SQRT(AM2) |
| 6215 | IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN |
| 6216 | C WRITE(LOUT,5003) NEVHKK,I,AM1,AM2 |
| 6217 | 5003 FORMAT(1X,'incon. chain mass DV: ',2I5,2E10.3) |
| 6218 | ENDIF |
| 6219 | ELSE |
| 6220 | WRITE(LOUT,5003) NEVHKK,I,AM1,AM2 |
| 6221 | ENDIF |
| 6222 | IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2) |
| 6223 | IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2) |
| 6224 | IFT1 = IDT_IB2PDG(ITVQ(IDXT),0,2) |
| 6225 | IFT2 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2) |
| 6226 | CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), |
| 6227 | & 0,0,5) |
| 6228 | CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), |
| 6229 | & 0,0,5) |
| 6230 | CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), |
| 6231 | & 0,0,5) |
| 6232 | CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), |
| 6233 | & 0,0,5) |
| 6234 | NCSY = NCSY+1 |
| 6235 | 50 CONTINUE |
| 6236 | |
| 6237 | * valence-sea chains |
| 6238 | DO 60 I=1,NVS |
| 6239 | IF (ISKPCH(6,I).EQ.99) GOTO 60 |
| 6240 | ICCHAI(1,6) = ICCHAI(1,6)+2 |
| 6241 | IDXP = INTVS1(I) |
| 6242 | IDXT = INTVS2(I) |
| 6243 | MOP = JDAHKK(1,IPOSP(IFROVP(IDXP))) |
| 6244 | MOT = JDAHKK(1,IPOST(IFROST(IDXT))) |
| 6245 | DO 61 K=1,4 |
| 6246 | PP1(K) = XPVQ(IDXP) *PHKK(K,MOP) |
| 6247 | PP2(K) = XPVD(IDXP) *PHKK(K,MOP) |
| 6248 | PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT) |
| 6249 | PT2(K) = XTSQ(IDXT) *PHKK(K,MOT) |
| 6250 | 61 CONTINUE |
| 6251 | IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2) |
| 6252 | IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2) |
| 6253 | IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2) |
| 6254 | IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2) |
| 6255 | CALL DT_CHKCSY(IFP1,IFT1,LCHK) |
| 6256 | IF (LCHK) THEN |
| 6257 | CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), |
| 6258 | & 0,0,6) |
| 6259 | CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), |
| 6260 | & 0,0,6) |
| 6261 | CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), |
| 6262 | & 0,0,6) |
| 6263 | CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), |
| 6264 | & 0,0,6) |
| 6265 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 |
| 6266 | & +(PP1(3)+PT1(3))**2) |
| 6267 | ECH = PP1(4)+PT1(4) |
| 6268 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) |
| 6269 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 |
| 6270 | & +(PP2(3)+PT2(3))**2) |
| 6271 | ECH = PP2(4)+PT2(4) |
| 6272 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) |
| 6273 | ELSE |
| 6274 | CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), |
| 6275 | & 0,0,6) |
| 6276 | CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), |
| 6277 | & 0,0,6) |
| 6278 | CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), |
| 6279 | & 0,0,6) |
| 6280 | CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), |
| 6281 | & 0,0,6) |
| 6282 | PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2 |
| 6283 | & +(PP1(3)+PT2(3))**2) |
| 6284 | ECH = PP1(4)+PT2(4) |
| 6285 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) |
| 6286 | PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2 |
| 6287 | & +(PP2(3)+PT1(3))**2) |
| 6288 | ECH = PP2(4)+PT1(4) |
| 6289 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) |
| 6290 | ENDIF |
| 6291 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN |
| 6292 | AM1 = SQRT(AM1) |
| 6293 | AM2 = SQRT(AM2) |
| 6294 | IF ((AM1.LT.AMSS).OR.(AM2.LT.AMVS)) THEN |
| 6295 | C WRITE(LOUT,5004) NEVHKK,I,AM1,AM2 |
| 6296 | 5004 FORMAT(1X,'incon. chain mass VS: ',2I5,2E10.3) |
| 6297 | ENDIF |
| 6298 | ELSE |
| 6299 | WRITE(LOUT,5004) NEVHKK,I,AM1,AM2 |
| 6300 | ENDIF |
| 6301 | NCSY = NCSY+1 |
| 6302 | 60 CONTINUE |
| 6303 | |
| 6304 | * sea-valence chains |
| 6305 | DO 40 I=1,NSV |
| 6306 | IF (ISKPCH(4,I).EQ.99) GOTO 40 |
| 6307 | ICCHAI(1,4) = ICCHAI(1,4)+2 |
| 6308 | IDXP = INTSV1(I) |
| 6309 | IDXT = INTSV2(I) |
| 6310 | MOP = JDAHKK(1,IPOSP(IFROSP(IDXP))) |
| 6311 | MOT = JDAHKK(1,IPOST(IFROVT(IDXT))) |
| 6312 | DO 41 K=1,4 |
| 6313 | PP1(K) = XPSQ(IDXP) *PHKK(K,MOP) |
| 6314 | PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP) |
| 6315 | PT1(K) = XTVD(IDXT) *PHKK(K,MOT) |
| 6316 | PT2(K) = XTVQ(IDXT) *PHKK(K,MOT) |
| 6317 | 41 CONTINUE |
| 6318 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 |
| 6319 | & +(PP1(3)+PT1(3))**2) |
| 6320 | ECH = PP1(4)+PT1(4) |
| 6321 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) |
| 6322 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 |
| 6323 | & +(PP2(3)+PT2(3))**2) |
| 6324 | ECH = PP2(4)+PT2(4) |
| 6325 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) |
| 6326 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN |
| 6327 | AM1 = SQRT(AM1) |
| 6328 | AM2 = SQRT(AM2) |
| 6329 | IF ((AM1.LT.AMVS).OR.(AM2.LT.AMSS)) THEN |
| 6330 | C WRITE(LOUT,5005) NEVHKK,I,AM1,AM2 |
| 6331 | 5005 FORMAT(1X,'incon. chain mass SV: ',2I5,2E10.3) |
| 6332 | ENDIF |
| 6333 | ELSE |
| 6334 | WRITE(LOUT,5005) NEVHKK,I,AM1,AM2 |
| 6335 | ENDIF |
| 6336 | IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2) |
| 6337 | IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2) |
| 6338 | IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2) |
| 6339 | IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2) |
| 6340 | CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), |
| 6341 | & 0,0,4) |
| 6342 | CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), |
| 6343 | & 0,0,4) |
| 6344 | CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), |
| 6345 | & 0,0,4) |
| 6346 | CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), |
| 6347 | & 0,0,4) |
| 6348 | NCSY = NCSY+1 |
| 6349 | 40 CONTINUE |
| 6350 | |
| 6351 | * valence-disea chains |
| 6352 | DO 70 I=1,NVD |
| 6353 | IF (ISKPCH(7,I).EQ.99) GOTO 70 |
| 6354 | ICCHAI(1,7) = ICCHAI(1,7)+2 |
| 6355 | IDXP = INTVD1(I) |
| 6356 | IDXT = INTVD2(I) |
| 6357 | MOP = JDAHKK(1,IPOSP(IFROVP(IDXP))) |
| 6358 | MOT = JDAHKK(1,IPOST(IFROST(IDXT))) |
| 6359 | DO 71 K=1,4 |
| 6360 | PP1(K) = XPVQ(IDXP) *PHKK(K,MOP) |
| 6361 | PP2(K) = XPVD(IDXP) *PHKK(K,MOP) |
| 6362 | PT1(K) = XTSQ(IDXT) *PHKK(K,MOT) |
| 6363 | PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT) |
| 6364 | 71 CONTINUE |
| 6365 | IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2) |
| 6366 | IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2) |
| 6367 | IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2) |
| 6368 | IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2) |
| 6369 | CALL DT_CHKCSY(IFP1,IFT1,LCHK) |
| 6370 | IF (LCHK) THEN |
| 6371 | CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), |
| 6372 | & 0,0,7) |
| 6373 | CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), |
| 6374 | & 0,0,7) |
| 6375 | CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), |
| 6376 | & 0,0,7) |
| 6377 | CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), |
| 6378 | & 0,0,7) |
| 6379 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 |
| 6380 | & +(PP1(3)+PT1(3))**2) |
| 6381 | ECH = PP1(4)+PT1(4) |
| 6382 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) |
| 6383 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 |
| 6384 | & +(PP2(3)+PT2(3))**2) |
| 6385 | ECH = PP2(4)+PT2(4) |
| 6386 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) |
| 6387 | ELSE |
| 6388 | CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), |
| 6389 | & 0,0,7) |
| 6390 | CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), |
| 6391 | & 0,0,7) |
| 6392 | CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), |
| 6393 | & 0,0,7) |
| 6394 | CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), |
| 6395 | & 0,0,7) |
| 6396 | PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2 |
| 6397 | & +(PP1(3)+PT2(3))**2) |
| 6398 | ECH = PP1(4)+PT2(4) |
| 6399 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) |
| 6400 | PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2 |
| 6401 | & +(PP2(3)+PT1(3))**2) |
| 6402 | ECH = PP2(4)+PT1(4) |
| 6403 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) |
| 6404 | ENDIF |
| 6405 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN |
| 6406 | AM1 = SQRT(AM1) |
| 6407 | AM2 = SQRT(AM2) |
| 6408 | IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN |
| 6409 | C WRITE(LOUT,5006) NEVHKK,I,AM1,AM2 |
| 6410 | 5006 FORMAT(1X,'incon. chain mass VD: ',2I5,2E10.3) |
| 6411 | ENDIF |
| 6412 | ELSE |
| 6413 | WRITE(LOUT,5006) NEVHKK,I,AM1,AM2 |
| 6414 | ENDIF |
| 6415 | NCSY = NCSY+1 |
| 6416 | 70 CONTINUE |
| 6417 | |
| 6418 | * valence-valence chains |
| 6419 | DO 80 I=1,NVV |
| 6420 | IF (ISKPCH(8,I).EQ.99) GOTO 80 |
| 6421 | ICCHAI(1,8) = ICCHAI(1,8)+2 |
| 6422 | IDXP = INTVV1(I) |
| 6423 | IDXT = INTVV2(I) |
| 6424 | MOP = JDAHKK(1,IPOSP(IFROVP(IDXP))) |
| 6425 | MOT = JDAHKK(1,IPOST(IFROVT(IDXT))) |
| 6426 | DO 81 K=1,4 |
| 6427 | PP1(K) = XPVQ(IDXP)*PHKK(K,MOP) |
| 6428 | PP2(K) = XPVD(IDXP)*PHKK(K,MOP) |
| 6429 | PT1(K) = XTVD(IDXT)*PHKK(K,MOT) |
| 6430 | PT2(K) = XTVQ(IDXT)*PHKK(K,MOT) |
| 6431 | 81 CONTINUE |
| 6432 | IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2) |
| 6433 | IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2) |
| 6434 | IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2) |
| 6435 | IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2) |
| 6436 | |
| 6437 | * check for diffractive event |
| 6438 | IDIFF = 0 |
| 6439 | IF (((ISINGD.GT.0).OR.(IDOUBD.GT.0)).AND. |
| 6440 | & (IP.EQ.1).AND.(NN.EQ.1)) THEN |
| 6441 | DO 800 K=1,4 |
| 6442 | PP(K) = PP1(K)+PP2(K) |
| 6443 | PT(K) = PT1(K)+PT2(K) |
| 6444 | 800 CONTINUE |
| 6445 | ISTCK = NHKK |
| 6446 | CALL DT_DIFEVT(IFP1,IFP2,PP,MOP, |
| 6447 | & IFT1,IFT2,PT,MOT,IDIFF,NCSY,IREJ1) |
| 6448 | C IF (IREJ1.NE.0) GOTO 9999 |
| 6449 | IF (IREJ1.NE.0) THEN |
| 6450 | IDIFF = 0 |
| 6451 | NHKK = ISTCK |
| 6452 | ENDIF |
| 6453 | ELSE |
| 6454 | IDIFF = 0 |
| 6455 | ENDIF |
| 6456 | |
| 6457 | IF (IDIFF.EQ.0) THEN |
| 6458 | * valence-valence chain system |
| 6459 | CALL DT_CHKCSY(IFP1,IFT1,LCHK) |
| 6460 | IF (LCHK) THEN |
| 6461 | * baryon-baryon |
| 6462 | CALL DT_EVTPUT(-21,IFP1,MOP,0, |
| 6463 | & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8) |
| 6464 | CALL DT_EVTPUT(-22,IFT1,MOT,0, |
| 6465 | & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8) |
| 6466 | CALL DT_EVTPUT(-21,IFP2,MOP,0, |
| 6467 | & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8) |
| 6468 | CALL DT_EVTPUT(-22,IFT2,MOT,0, |
| 6469 | & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8) |
| 6470 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 |
| 6471 | & +(PP1(3)+PT1(3))**2) |
| 6472 | ECH = PP1(4)+PT1(4) |
| 6473 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) |
| 6474 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 |
| 6475 | & +(PP2(3)+PT2(3))**2) |
| 6476 | ECH = PP2(4)+PT2(4) |
| 6477 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) |
| 6478 | ELSE |
| 6479 | * antibaryon-baryon |
| 6480 | CALL DT_EVTPUT(-21,IFP1,MOP,0, |
| 6481 | & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8) |
| 6482 | CALL DT_EVTPUT(-22,IFT2,MOT,0, |
| 6483 | & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8) |
| 6484 | CALL DT_EVTPUT(-21,IFP2,MOP,0, |
| 6485 | & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8) |
| 6486 | CALL DT_EVTPUT(-22,IFT1,MOT,0, |
| 6487 | & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8) |
| 6488 | PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2 |
| 6489 | & +(PP1(3)+PT2(3))**2) |
| 6490 | ECH = PP1(4)+PT2(4) |
| 6491 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) |
| 6492 | PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2 |
| 6493 | & +(PP2(3)+PT1(3))**2) |
| 6494 | ECH = PP2(4)+PT1(4) |
| 6495 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) |
| 6496 | ENDIF |
| 6497 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN |
| 6498 | AM1 = SQRT(AM1) |
| 6499 | AM2 = SQRT(AM2) |
| 6500 | IF ((AM1.LT.AMVV).OR.(AM2.LT.AMVV)) THEN |
| 6501 | C WRITE(LOUT,5007) NEVHKK,I,AM1,AM2 |
| 6502 | 5007 FORMAT(1X,'incon. chain mass VV: ',2I5,2E10.3) |
| 6503 | ENDIF |
| 6504 | ELSE |
| 6505 | WRITE(LOUT,5007) NEVHKK,I,AM1,AM2 |
| 6506 | ENDIF |
| 6507 | NCSY = NCSY+1 |
| 6508 | ENDIF |
| 6509 | 80 CONTINUE |
| 6510 | IF (ISTHKK(NPOINT(2)).EQ.1) NPOINT(2) = NPOINT(2)+1 |
| 6511 | |
| 6512 | * energy-momentum & flavor conservation check |
| 6513 | IF (ABS(IDIFF).NE.1) THEN |
| 6514 | IF (IDIFF.NE.0) THEN |
| 6515 | IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-41,1,0, |
| 6516 | & 1,3,10,IREJ) |
| 6517 | ELSE |
| 6518 | IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-31,-32,0, |
| 6519 | & 1,3,10,IREJ) |
| 6520 | ENDIF |
| 6521 | IF (IREJ.NE.0) THEN |
| 6522 | CALL DT_EVTOUT(4) |
| 6523 | STOP |
| 6524 | ENDIF |
| 6525 | ENDIF |
| 6526 | |
| 6527 | RETURN |
| 6528 | |
| 6529 | 9999 CONTINUE |
| 6530 | IREJ = 1 |
| 6531 | RETURN |
| 6532 | END |
| 6533 | * |
| 6534 | *===chkcsy=============================================================* |
| 6535 | * |
| 6536 | CDECK ID>, DT_CHKCSY |
| 6537 | SUBROUTINE DT_CHKCSY(ID1,ID2,LCHK) |
| 6538 | |
| 6539 | ************************************************************************ |
| 6540 | * CHeCk Chain SYstem for consistency of partons at chain ends. * |
| 6541 | * ID1,ID2 PDG-numbers of partons at chain ends * |
| 6542 | * LCHK = .true. consistent chain * |
| 6543 | * = .false. inconsistent chain * |
| 6544 | * This version dated 18.01.95 is written by S. Roesler * |
| 6545 | ************************************************************************ |
| 6546 | |
| 6547 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 6548 | SAVE |
| 6549 | |
| 6550 | PARAMETER ( LINP = 5 , |
| 6551 | & LOUT = 6 , |
| 6552 | & LDAT = 9 ) |
| 6553 | |
| 6554 | LOGICAL LCHK |
| 6555 | |
| 6556 | LCHK = .TRUE. |
| 6557 | |
| 6558 | * q-aq chain |
| 6559 | IF ((ABS(ID1).LE.6).AND.(ABS(ID2).LE.6)) THEN |
| 6560 | IF (ID1*ID2.GT.0) LCHK = .FALSE. |
| 6561 | * q-qq, aq-aqaq chain |
| 6562 | ELSEIF (((ABS(ID1).LE.6).AND.(ABS(ID2).GT.6)).OR. |
| 6563 | & ((ABS(ID1).GT.6).AND.(ABS(ID2).LE.6))) THEN |
| 6564 | IF (ID1*ID2.LT.0) LCHK = .FALSE. |
| 6565 | * qq-aqaq chain |
| 6566 | ELSEIF ((ABS(ID1).GT.6).AND.(ABS(ID2).GT.6)) THEN |
| 6567 | IF (ID1*ID2.GT.0) LCHK = .FALSE. |
| 6568 | ENDIF |
| 6569 | |
| 6570 | RETURN |
| 6571 | END |
| 6572 | * |
| 6573 | *===eventa=============================================================* |
| 6574 | * |
| 6575 | CDECK ID>, DT_EVENTA |
| 6576 | SUBROUTINE DT_EVENTA(ID,IP,IT,NCSY,IREJ) |
| 6577 | |
| 6578 | ************************************************************************ |
| 6579 | * Treatment of nucleon-nucleon interactions in a two-chain * |
| 6580 | * approximation. * |
| 6581 | * (input) ID BAMJET-index of projectile hadron (in case of * |
| 6582 | * h-K scattering) * |
| 6583 | * IP/IT mass number of projectile/target nucleus * |
| 6584 | * NCSY number of two chain systems * |
| 6585 | * IREJ rejection flag * |
| 6586 | * This version dated 15.01.95 is written by S. Roesler * |
| 6587 | ************************************************************************ |
| 6588 | |
| 6589 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 6590 | SAVE |
| 6591 | |
| 6592 | PARAMETER ( LINP = 5 , |
| 6593 | & LOUT = 6 , |
| 6594 | & LDAT = 9 ) |
| 6595 | |
| 6596 | PARAMETER (TINY10=1.0D-10) |
| 6597 | |
| 6598 | * event history |
| 6599 | |
| 6600 | PARAMETER (NMXHKK=200000) |
| 6601 | |
| 6602 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 6603 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 6604 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 6605 | * extended event history |
| 6606 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 6607 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 6608 | & IHIST(2,NMXHKK) |
| 6609 | * rejection counter |
| 6610 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, |
| 6611 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, |
| 6612 | & IREXCI(3),IRDIFF(2),IRINC |
| 6613 | * flags for diffractive interactions (DTUNUC 1.x) |
| 6614 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF |
| 6615 | * particle properties (BAMJET index convention) |
| 6616 | CHARACTER*8 ANAME |
| 6617 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 6618 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 6619 | * flags for input different options |
| 6620 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 6621 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 6622 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 6623 | * various options for treatment of partons (DTUNUC 1.x) |
| 6624 | * (chain recombination, Cronin,..) |
| 6625 | LOGICAL LCO2CR,LINTPT |
| 6626 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, |
| 6627 | & LCO2CR,LINTPT |
| 6628 | |
| 6629 | DIMENSION PP1(4),PP2(4),PT1(4),PT2(4) |
| 6630 | |
| 6631 | IREJ = 0 |
| 6632 | NPOINT(3) = NHKK+1 |
| 6633 | |
| 6634 | * skip following treatment for low-mass diffraction |
| 6635 | IF (ABS(IFLAGD).EQ.1) THEN |
| 6636 | NPOINT(3) = NPOINT(2) |
| 6637 | GOTO 5 |
| 6638 | ENDIF |
| 6639 | |
| 6640 | * multiple scattering of chain ends |
| 6641 | IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1) |
| 6642 | IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2) |
| 6643 | |
| 6644 | NC = NPOINT(2) |
| 6645 | * get a two-chain system from DTEVT1 |
| 6646 | DO 3 I=1,NCSY |
| 6647 | IFP1 = IDHKK(NC) |
| 6648 | IFT1 = IDHKK(NC+1) |
| 6649 | IFP2 = IDHKK(NC+2) |
| 6650 | IFT2 = IDHKK(NC+3) |
| 6651 | DO 4 K=1,4 |
| 6652 | PP1(K) = PHKK(K,NC) |
| 6653 | PT1(K) = PHKK(K,NC+1) |
| 6654 | PP2(K) = PHKK(K,NC+2) |
| 6655 | PT2(K) = PHKK(K,NC+3) |
| 6656 | 4 CONTINUE |
| 6657 | MOP1 = NC |
| 6658 | MOT1 = NC+1 |
| 6659 | MOP2 = NC+2 |
| 6660 | MOT2 = NC+3 |
| 6661 | CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2, |
| 6662 | & IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1) |
| 6663 | IF (IREJ1.GT.0) THEN |
| 6664 | IRHHA = IRHHA+1 |
| 6665 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTA' |
| 6666 | GOTO 9999 |
| 6667 | ENDIF |
| 6668 | NC = NC+4 |
| 6669 | 3 CONTINUE |
| 6670 | |
| 6671 | * meson/antibaryon projectile: |
| 6672 | * sample single-chain valence-valence systems (Reggeon contrib.) |
| 6673 | IF ((IP.EQ.1).AND.(ISICHA.EQ.1)) THEN |
| 6674 | IF (IIBAR(ID).LE.0) CALL DT_VV2SCH |
| 6675 | ENDIF |
| 6676 | |
| 6677 | IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN |
| 6678 | * check DTEVT1 for remaining resonance mass corrections |
| 6679 | CALL DT_EVTRES(IREJ1) |
| 6680 | IF (IREJ1.GT.0) THEN |
| 6681 | IRRES(1) = IRRES(1)+1 |
| 6682 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in EVENTA' |
| 6683 | GOTO 9999 |
| 6684 | ENDIF |
| 6685 | ENDIF |
| 6686 | |
| 6687 | * assign p_t to two-"chain" systems consisting of two resonances only |
| 6688 | * since only entries for chains will be affected, this is obsolete |
| 6689 | * in case of JETSET-fragmetation |
| 6690 | CALL DT_RESPT |
| 6691 | |
| 6692 | * combine q-aq chains to color ropes (qq-aqaq) (chain fusion) |
| 6693 | IF (LCO2CR) CALL DT_COM2CR |
| 6694 | |
| 6695 | 5 CONTINUE |
| 6696 | |
| 6697 | * fragmentation of the complete event |
| 6698 | **uncomment for internal phojet-fragmentation |
| 6699 | C CALL DT_EVTFRA(IREJ1) |
| 6700 | CALL DT_EVTFRG(2,IDUM,NPYMEM,IREJ1) |
| 6701 | IF (IREJ1.GT.0) THEN |
| 6702 | IRFRAG = IRFRAG+1 |
| 6703 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 3 in EVENTA' |
| 6704 | GOTO 9999 |
| 6705 | ENDIF |
| 6706 | |
| 6707 | * decay of possible resonances (should be obsolete) |
| 6708 | CALL DT_DECAY1 |
| 6709 | |
| 6710 | RETURN |
| 6711 | |
| 6712 | 9999 CONTINUE |
| 6713 | IREVT = IREVT+1 |
| 6714 | IREJ = 1 |
| 6715 | RETURN |
| 6716 | END |
| 6717 | * |
| 6718 | *===getcsy=============================================================* |
| 6719 | * |
| 6720 | CDECK ID>, DT_GETCSY |
| 6721 | SUBROUTINE DT_GETCSY(IFPR1,PP1,MOP1,IFPR2,PP2,MOP2, |
| 6722 | & IFTA1,PT1,MOT1,IFTA2,PT2,MOT2,IREJ) |
| 6723 | |
| 6724 | ************************************************************************ |
| 6725 | * This version dated 15.01.95 is written by S. Roesler * |
| 6726 | ************************************************************************ |
| 6727 | |
| 6728 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 6729 | SAVE |
| 6730 | |
| 6731 | PARAMETER ( LINP = 5 , |
| 6732 | & LOUT = 6 , |
| 6733 | & LDAT = 9 ) |
| 6734 | |
| 6735 | PARAMETER (TINY10=1.0D-10) |
| 6736 | |
| 6737 | * event history |
| 6738 | |
| 6739 | PARAMETER (NMXHKK=200000) |
| 6740 | |
| 6741 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 6742 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 6743 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 6744 | * extended event history |
| 6745 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 6746 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 6747 | & IHIST(2,NMXHKK) |
| 6748 | * rejection counter |
| 6749 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, |
| 6750 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, |
| 6751 | & IREXCI(3),IRDIFF(2),IRINC |
| 6752 | * flags for input different options |
| 6753 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 6754 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 6755 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 6756 | * flags for diffractive interactions (DTUNUC 1.x) |
| 6757 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF |
| 6758 | |
| 6759 | DIMENSION PP1(4),PP2(4),PT1(4),PT2(4), |
| 6760 | & IFP1(2),IFP2(2),IFT1(2),IFT2(2),PCH1(4),PCH2(4) |
| 6761 | |
| 6762 | IREJ = 0 |
| 6763 | |
| 6764 | * get quark content of partons |
| 6765 | DO 1 I=1,2 |
| 6766 | IFP1(I) = 0 |
| 6767 | IFP2(I) = 0 |
| 6768 | IFT1(I) = 0 |
| 6769 | IFT2(I) = 0 |
| 6770 | 1 CONTINUE |
| 6771 | IFP1(1) = IDT_IPDG2B(IFPR1,1,2) |
| 6772 | IF (ABS(IFPR1).GE.1000) IFP1(2) = IDT_IPDG2B(IFPR1,2,2) |
| 6773 | IFP2(1) = IDT_IPDG2B(IFPR2,1,2) |
| 6774 | IF (ABS(IFPR2).GE.1000) IFP2(2) = IDT_IPDG2B(IFPR2,2,2) |
| 6775 | IFT1(1) = IDT_IPDG2B(IFTA1,1,2) |
| 6776 | IF (ABS(IFTA1).GE.1000) IFT1(2) = IDT_IPDG2B(IFTA1,2,2) |
| 6777 | IFT2(1) = IDT_IPDG2B(IFTA2,1,2) |
| 6778 | IF (ABS(IFTA2).GE.1000) IFT2(2) = IDT_IPDG2B(IFTA2,2,2) |
| 6779 | |
| 6780 | * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq, 3 - qq-aqaq) |
| 6781 | IDCH1 = 2 |
| 6782 | IF ((IFP1(2).EQ.0).AND.(IFT1(2).EQ.0)) IDCH1 = 1 |
| 6783 | IF ((IFP1(2).NE.0).AND.(IFT1(2).NE.0)) IDCH1 = 3 |
| 6784 | IDCH2 = 2 |
| 6785 | IF ((IFP2(2).EQ.0).AND.(IFT2(2).EQ.0)) IDCH2 = 1 |
| 6786 | IF ((IFP2(2).NE.0).AND.(IFT2(2).NE.0)) IDCH2 = 3 |
| 6787 | |
| 6788 | * store initial configuration for energy-momentum cons. check |
| 6789 | IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IDUM) |
| 6790 | |
| 6791 | * sample intrinsic p_t at chain-ends |
| 6792 | CALL DT_GETSPT(PP1,IFPR1,IFP1,PP2,IFPR2,IFP2, |
| 6793 | & PT1,IFTA1,IFT1,PT2,IFTA2,IFT2, |
| 6794 | & AMCH1,IDCH1,AMCH2,IDCH2,IDCH(MOP1),IREJ1) |
| 6795 | IF (IREJ1.NE.0) THEN |
| 6796 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in GETCSY' |
| 6797 | IRPT = IRPT+1 |
| 6798 | GOTO 9999 |
| 6799 | ENDIF |
| 6800 | |
| 6801 | C IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN |
| 6802 | C IF ((IDCH1.EQ.3).OR.((IDCH1.GT.1).AND.(IDCH2.EQ.1))) THEN |
| 6803 | C* check second chain for resonance |
| 6804 | C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2, |
| 6805 | C & AMCH2,AMCH2N,IDCH2,IREJ1) |
| 6806 | C IF (IREJ1.NE.0) GOTO 9999 |
| 6807 | C IF (IDR2.NE.0) THEN |
| 6808 | C CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1, |
| 6809 | C & AMCH2,AMCH2N,AMCH1,IREJ1) |
| 6810 | C IF (IREJ1.NE.0) GOTO 9999 |
| 6811 | C ENDIF |
| 6812 | C* check first chain for resonance |
| 6813 | C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1, |
| 6814 | C & AMCH1,AMCH1N,IDCH1,IREJ1) |
| 6815 | C IF (IREJ1.NE.0) GOTO 9999 |
| 6816 | C IF (IDR1.NE.0) IDR1 = 100*IDR1 |
| 6817 | C ELSE |
| 6818 | C* check first chain for resonance |
| 6819 | C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1, |
| 6820 | C & AMCH1,AMCH1N,IDCH1,IREJ1) |
| 6821 | C IF (IREJ1.NE.0) GOTO 9999 |
| 6822 | C IF (IDR1.NE.0) THEN |
| 6823 | C CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2, |
| 6824 | C & AMCH1,AMCH1N,AMCH2,IREJ1) |
| 6825 | C IF (IREJ1.NE.0) GOTO 9999 |
| 6826 | C ENDIF |
| 6827 | C* check second chain for resonance |
| 6828 | C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2, |
| 6829 | C & AMCH2,AMCH2N,IDCH2,IREJ1) |
| 6830 | C IF (IREJ1.NE.0) GOTO 9999 |
| 6831 | C IF (IDR2.NE.0) IDR2 = 100*IDR2 |
| 6832 | C ENDIF |
| 6833 | C ENDIF |
| 6834 | |
| 6835 | IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN |
| 6836 | * check chains for resonances |
| 6837 | CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1, |
| 6838 | & AMCH1,AMCH1N,IDCH1,IREJ1) |
| 6839 | IF (IREJ1.NE.0) GOTO 9999 |
| 6840 | CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2, |
| 6841 | & AMCH2,AMCH2N,IDCH2,IREJ1) |
| 6842 | IF (IREJ1.NE.0) GOTO 9999 |
| 6843 | * change kinematics corresponding to resonance-masses |
| 6844 | IF ( (IDR1.NE.0).AND.(IDR2.EQ.0) ) THEN |
| 6845 | CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2, |
| 6846 | & AMCH1,AMCH1N,AMCH2,IREJ1) |
| 6847 | IF (IREJ1.GT.0) GOTO 9999 |
| 6848 | IF (IREJ1.EQ.-1) IDR1 = 100*IDR1 |
| 6849 | CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2, |
| 6850 | & AMCH2,AMCH2N,IDCH2,IREJ1) |
| 6851 | IF (IREJ1.NE.0) GOTO 9999 |
| 6852 | IF (IDR2.NE.0) IDR2 = 100*IDR2 |
| 6853 | ELSEIF ( (IDR1.EQ.0).AND.(IDR2.NE.0) ) THEN |
| 6854 | CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1, |
| 6855 | & AMCH2,AMCH2N,AMCH1,IREJ1) |
| 6856 | IF (IREJ1.GT.0) GOTO 9999 |
| 6857 | IF (IREJ1.EQ.-1) IDR2 = 100*IDR2 |
| 6858 | CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1, |
| 6859 | & AMCH1,AMCH1N,IDCH1,IREJ1) |
| 6860 | IF (IREJ1.NE.0) GOTO 9999 |
| 6861 | IF (IDR1.NE.0) IDR1 = 100*IDR1 |
| 6862 | ELSEIF ( (IDR1.NE.0).AND.(IDR2.NE.0) ) THEN |
| 6863 | AMDIF1 = ABS(AMCH1-AMCH1N) |
| 6864 | AMDIF2 = ABS(AMCH2-AMCH2N) |
| 6865 | IF (AMDIF2.LT.AMDIF1) THEN |
| 6866 | CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1, |
| 6867 | & AMCH2,AMCH2N,AMCH1,IREJ1) |
| 6868 | IF (IREJ1.GT.0) GOTO 9999 |
| 6869 | IF (IREJ1.EQ.-1) IDR2 = 100*IDR2 |
| 6870 | CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2), |
| 6871 | & IDR1,IDXR1,AMCH1,AMCH1N,IDCH1,IREJ1) |
| 6872 | IF (IREJ1.NE.0) GOTO 9999 |
| 6873 | IF (IDR1.NE.0) IDR1 = 100*IDR1 |
| 6874 | ELSE |
| 6875 | CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2, |
| 6876 | & AMCH1,AMCH1N,AMCH2,IREJ1) |
| 6877 | IF (IREJ1.GT.0) GOTO 9999 |
| 6878 | IF (IREJ1.EQ.-1) IDR1 = 100*IDR1 |
| 6879 | CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2), |
| 6880 | & IDR2,IDXR2,AMCH2,AMCH2N,IDCH2,IREJ1) |
| 6881 | IF (IREJ1.NE.0) GOTO 9999 |
| 6882 | IF (IDR2.NE.0) IDR2 = 100*IDR2 |
| 6883 | ENDIF |
| 6884 | ENDIF |
| 6885 | ENDIF |
| 6886 | |
| 6887 | * store final configuration for energy-momentum cons. check |
| 6888 | IF (LEMCCK) THEN |
| 6889 | CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IDUM) |
| 6890 | CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1) |
| 6891 | IF (IREJ1.NE.0) GOTO 9999 |
| 6892 | ENDIF |
| 6893 | |
| 6894 | * put partons and chains into DTEVT1 |
| 6895 | DO 10 I=1,4 |
| 6896 | PCH1(I) = PP1(I)+PT1(I) |
| 6897 | PCH2(I) = PP2(I)+PT2(I) |
| 6898 | 10 CONTINUE |
| 6899 | CALL DT_EVTPUT(-ISTHKK(MOP1),IFPR1,MOP1,0,PP1(1),PP1(2), |
| 6900 | & PP1(3),PP1(4),0,0,0) |
| 6901 | CALL DT_EVTPUT(-ISTHKK(MOT1),IFTA1,MOT1,0,PT1(1),PT1(2), |
| 6902 | & PT1(3),PT1(4),0,0,0) |
| 6903 | KCH = 100+IDCH(MOP1)*10+1 |
| 6904 | CALL DT_EVTPUT(KCH,88888,-2,-1, |
| 6905 | & PCH1(1),PCH1(2),PCH1(3),PCH1(4),IDR1,IDXR1,IDCH(MOP1)) |
| 6906 | CALL DT_EVTPUT(-ISTHKK(MOP2),IFPR2,MOP2,0,PP2(1),PP2(2), |
| 6907 | & PP2(3),PP2(4),0,0,0) |
| 6908 | CALL DT_EVTPUT(-ISTHKK(MOT2),IFTA2,MOT2,0,PT2(1),PT2(2), |
| 6909 | & PT2(3),PT2(4),0,0,0) |
| 6910 | KCH = KCH+1 |
| 6911 | CALL DT_EVTPUT(KCH,88888,-2,-1, |
| 6912 | & PCH2(1),PCH2(2),PCH2(3),PCH2(4),IDR2,IDXR2,IDCH(MOP2)) |
| 6913 | |
| 6914 | RETURN |
| 6915 | |
| 6916 | 9999 CONTINUE |
| 6917 | IF ((IDCH(MOP1).LE.3).AND.(IDCH(MOP2).LE.3)) THEN |
| 6918 | * "cancel" sea-sea chains |
| 6919 | CALL DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ1) |
| 6920 | IF (IREJ1.NE.0) GOTO 9998 |
| 6921 | **sr 16.5. flag for EVENTB |
| 6922 | IREJ = -1 |
| 6923 | RETURN |
| 6924 | ENDIF |
| 6925 | 9998 CONTINUE |
| 6926 | IREJ = 1 |
| 6927 | RETURN |
| 6928 | END |
| 6929 | * |
| 6930 | *===chkine=============================================================* |
| 6931 | * |
| 6932 | CDECK ID>, DT_CHKINE |
| 6933 | SUBROUTINE DT_CHKINE(PP1I,IFP1,PP2I,IFP2,PT1I,IFT1,PT2I,IFT2, |
| 6934 | & AMCH1,AMCH1N,AMCH2,IREJ) |
| 6935 | |
| 6936 | ************************************************************************ |
| 6937 | * This subroutine replaces CORMOM. * |
| 6938 | * This version dated 05.01.95 is written by S. Roesler * |
| 6939 | ************************************************************************ |
| 6940 | |
| 6941 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 6942 | SAVE |
| 6943 | |
| 6944 | PARAMETER ( LINP = 5 , |
| 6945 | & LOUT = 6 , |
| 6946 | & LDAT = 9 ) |
| 6947 | |
| 6948 | PARAMETER (TINY10=1.0D-10) |
| 6949 | |
| 6950 | * flags for input different options |
| 6951 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 6952 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 6953 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 6954 | * rejection counter |
| 6955 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, |
| 6956 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, |
| 6957 | & IREXCI(3),IRDIFF(2),IRINC |
| 6958 | |
| 6959 | DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),P1(4),P2(4), |
| 6960 | & PP1I(4),PP2I(4),PT1I(4),PT2I(4) |
| 6961 | |
| 6962 | IREJ = 0 |
| 6963 | JMSHL = IMSHL |
| 6964 | |
| 6965 | SCALE = AMCH1N/MAX(AMCH1,TINY10) |
| 6966 | DO 10 I=1,4 |
| 6967 | PP1(I) = PP1I(I) |
| 6968 | PP2(I) = PP2I(I) |
| 6969 | PT1(I) = PT1I(I) |
| 6970 | PT2(I) = PT2I(I) |
| 6971 | PP2(I) = PP2(I)+(1.0D0-SCALE)*PP1(I) |
| 6972 | PT2(I) = PT2(I)+(1.0D0-SCALE)*PT1(I) |
| 6973 | PP1(I) = SCALE*PP1(I) |
| 6974 | PT1(I) = SCALE*PT1(I) |
| 6975 | 10 CONTINUE |
| 6976 | IF ((PP1(4).LT.0.0D0).OR.(PP2(4).LT.0.0D0).OR. |
| 6977 | & (PT1(4).LT.0.0D0).OR.(PT2(4).LT.0.0D0)) GOTO 9997 |
| 6978 | |
| 6979 | ECH = PP2(4)+PT2(4) |
| 6980 | PCH = SQRT( (PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2+ |
| 6981 | & (PP2(3)+PT2(3))**2 ) |
| 6982 | AMCH22 = (ECH-PCH)*(ECH+PCH) |
| 6983 | IF (AMCH22.LT.0.0D0) THEN |
| 6984 | IF (IOULEV(1).GT.0) |
| 6985 | & WRITE(LOUT,'(1X,A)') 'CHKINE: inconsistent treatment!' |
| 6986 | GOTO 9997 |
| 6987 | ENDIF |
| 6988 | |
| 6989 | AMCH1 = AMCH1N |
| 6990 | AMCH2 = SQRT(AMCH22) |
| 6991 | |
| 6992 | * put partons again on mass shell |
| 6993 | 13 CONTINUE |
| 6994 | XM1 = 0.0D0 |
| 6995 | XM2 = 0.0D0 |
| 6996 | IF (JMSHL.EQ.1) THEN |
| 6997 | |
| 6998 | XM1 = PYMASS(IFP1) |
| 6999 | XM2 = PYMASS(IFT1) |
| 7000 | |
| 7001 | ENDIF |
| 7002 | CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1) |
| 7003 | IF (IREJ1.NE.0) THEN |
| 7004 | IF (JMSHL.EQ.0) GOTO 9998 |
| 7005 | JMSHL = 0 |
| 7006 | GOTO 13 |
| 7007 | ENDIF |
| 7008 | JMSHL = IMSHL |
| 7009 | DO 11 I=1,4 |
| 7010 | PP1(I) = P1(I) |
| 7011 | PT1(I) = P2(I) |
| 7012 | 11 CONTINUE |
| 7013 | 14 CONTINUE |
| 7014 | XM1 = 0.0D0 |
| 7015 | XM2 = 0.0D0 |
| 7016 | IF (JMSHL.EQ.1) THEN |
| 7017 | |
| 7018 | XM1 = PYMASS(IFP2) |
| 7019 | XM2 = PYMASS(IFT2) |
| 7020 | |
| 7021 | ENDIF |
| 7022 | CALL DT_MASHEL(PP2,PT2,XM1,XM2,P1,P2,IREJ1) |
| 7023 | IF (IREJ1.NE.0) THEN |
| 7024 | IF (JMSHL.EQ.0) GOTO 9998 |
| 7025 | JMSHL = 0 |
| 7026 | GOTO 14 |
| 7027 | ENDIF |
| 7028 | DO 12 I=1,4 |
| 7029 | PP2(I) = P1(I) |
| 7030 | PT2(I) = P2(I) |
| 7031 | 12 CONTINUE |
| 7032 | DO 15 I=1,4 |
| 7033 | PP1I(I) = PP1(I) |
| 7034 | PP2I(I) = PP2(I) |
| 7035 | PT1I(I) = PT1(I) |
| 7036 | PT2I(I) = PT2(I) |
| 7037 | 15 CONTINUE |
| 7038 | RETURN |
| 7039 | |
| 7040 | 9997 IRCHKI(1) = IRCHKI(1)+1 |
| 7041 | **sr |
| 7042 | C GOTO 9999 |
| 7043 | IREJ = -1 |
| 7044 | RETURN |
| 7045 | ** |
| 7046 | 9998 IRCHKI(2) = IRCHKI(2)+1 |
| 7047 | |
| 7048 | 9999 CONTINUE |
| 7049 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in CHKINE' |
| 7050 | IREJ = 1 |
| 7051 | RETURN |
| 7052 | END |
| 7053 | * |
| 7054 | *===ch2res=============================================================* |
| 7055 | * |
| 7056 | CDECK ID>, DT_CH2RES |
| 7057 | SUBROUTINE DT_CH2RES(IF1,IF2,IF3,IF4,IDR,IDXR, |
| 7058 | & AM,AMN,IMODE,IREJ) |
| 7059 | |
| 7060 | ************************************************************************ |
| 7061 | * Check chains for resonance production. * |
| 7062 | * This subroutine replaces COMCMA/COBCMA/COMCM2 * |
| 7063 | * input: * |
| 7064 | * IF1,2,3,4 input flavors (q,aq in any order) * |
| 7065 | * AM chain mass * |
| 7066 | * MODE = 1 check q-aq chain for meson-resonance * |
| 7067 | * = 2 check q-qq, aq-aqaq chain for baryon-resonance * |
| 7068 | * = 3 check qq-aqaq chain for lower mass cut * |
| 7069 | * output: * |
| 7070 | * IDR = 0 no resonances found * |
| 7071 | * = -1 pseudoscalar meson/octet baryon * |
| 7072 | * = 1 vector-meson/decuplet baryon * |
| 7073 | * IDXR BAMJET-index of corresponding resonance * |
| 7074 | * AMN mass of corresponding resonance * |
| 7075 | * * |
| 7076 | * IREJ rejection flag * |
| 7077 | * This version dated 06.01.95 is written by S. Roesler * |
| 7078 | ************************************************************************ |
| 7079 | |
| 7080 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 7081 | SAVE |
| 7082 | |
| 7083 | PARAMETER ( LINP = 5 , |
| 7084 | & LOUT = 6 , |
| 7085 | & LDAT = 9 ) |
| 7086 | |
| 7087 | * particle properties (BAMJET index convention) |
| 7088 | CHARACTER*8 ANAME |
| 7089 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 7090 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 7091 | * quark-content to particle index conversion (DTUNUC 1.x) |
| 7092 | COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21), |
| 7093 | & IA08(6,21),IA10(6,21) |
| 7094 | * rejection counter |
| 7095 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, |
| 7096 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, |
| 7097 | & IREXCI(3),IRDIFF(2),IRINC |
| 7098 | * flags for input different options |
| 7099 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 7100 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 7101 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 7102 | |
| 7103 | DIMENSION IF(4),JF(4) |
| 7104 | |
| 7105 | **sr 4.7. test |
| 7106 | C DATA AMLOM,AMLOB /0.08D0,0.2D0/ |
| 7107 | DATA AMLOM,AMLOB /0.1D0,0.7D0/ |
| 7108 | ** |
| 7109 | C DATA AMLOM,AMLOB /0.001D0,0.001D0/ |
| 7110 | |
| 7111 | MODE = ABS(IMODE) |
| 7112 | |
| 7113 | IF ((MODE.LT.1).OR.(MODE.GT.3)) THEN |
| 7114 | WRITE(LOUT,1000) MODE |
| 7115 | 1000 FORMAT(1X,'CH2RES: MODE ',I4,' not supported!',/, |
| 7116 | & 1X,' program stopped') |
| 7117 | STOP |
| 7118 | ENDIF |
| 7119 | |
| 7120 | AMX = AM |
| 7121 | IREJ = 0 |
| 7122 | IDR = 0 |
| 7123 | IDXR = 0 |
| 7124 | AMN = AMX |
| 7125 | IF ((AM.LE.0.0D0).AND.(MODE.EQ.1)) AMX = AMLOM |
| 7126 | IF ((AM.LE.0.0D0).AND.(MODE.EQ.2)) AMX = AMLOB |
| 7127 | |
| 7128 | IF(1) = IF1 |
| 7129 | IF(2) = IF2 |
| 7130 | IF(3) = IF3 |
| 7131 | IF(4) = IF4 |
| 7132 | NF = 0 |
| 7133 | DO 100 I=1,4 |
| 7134 | IF (IF(I).NE.0) THEN |
| 7135 | NF = NF+1 |
| 7136 | JF(NF) = IF(I) |
| 7137 | ENDIF |
| 7138 | 100 CONTINUE |
| 7139 | IF (NF.LE.MODE) THEN |
| 7140 | WRITE(LOUT,1001) MODE,IF |
| 7141 | 1001 FORMAT(1X,'CH2RES: inconsistent input flavors in MODE ', |
| 7142 | & I4,' IF1 = ',I4,' IF2 = ',I4,' IF3 = ',I4,' IF4 = ',I4) |
| 7143 | GOTO 9999 |
| 7144 | ENDIF |
| 7145 | |
| 7146 | GOTO (1,2,3) MODE |
| 7147 | |
| 7148 | * check for meson resonance |
| 7149 | 1 CONTINUE |
| 7150 | IFQ = JF(1) |
| 7151 | IFAQ = ABS(JF(2)) |
| 7152 | IF (JF(2).GT.0) THEN |
| 7153 | IFQ = JF(2) |
| 7154 | IFAQ = ABS(JF(1)) |
| 7155 | ENDIF |
| 7156 | IFPS = IMPS(IFAQ,IFQ) |
| 7157 | IFV = IMVE(IFAQ,IFQ) |
| 7158 | AMPS = AAM(IFPS) |
| 7159 | AMV = AAM(IFV) |
| 7160 | AMHI = AMV+0.3D0 |
| 7161 | IF (AMX.LT.AMV) THEN |
| 7162 | IF (AMX.LT.AMPS) THEN |
| 7163 | IF (IMODE.GT.0) THEN |
| 7164 | IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOM)) GOTO 9999 |
| 7165 | ELSE |
| 7166 | IF (AMX.LT.0.8D0*AMPS) GOTO 9999 |
| 7167 | ENDIF |
| 7168 | LOMRES = LOMRES+1 |
| 7169 | ENDIF |
| 7170 | * replace chain by pseudoscalar meson |
| 7171 | IDR = -1 |
| 7172 | IDXR = IFPS |
| 7173 | AMN = AMPS |
| 7174 | ELSEIF (AMX.LT.AMHI) THEN |
| 7175 | * replace chain by vector-meson |
| 7176 | IDR = 1 |
| 7177 | IDXR = IFV |
| 7178 | AMN = AMV |
| 7179 | ENDIF |
| 7180 | RETURN |
| 7181 | |
| 7182 | * check for baryon resonance |
| 7183 | 2 CONTINUE |
| 7184 | CALL DT_DBKLAS(JF(1),JF(2),JF(3),JB8,JB10) |
| 7185 | AM8 = AAM(JB8) |
| 7186 | AM10 = AAM(JB10) |
| 7187 | AMHI = AM10+0.3D0 |
| 7188 | IF (AMX.LT.AM10) THEN |
| 7189 | IF (AMX.LT.AM8) THEN |
| 7190 | IF (IMODE.GT.0) THEN |
| 7191 | IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOB)) GOTO 9999 |
| 7192 | ELSE |
| 7193 | IF (AMX.LT.0.8D0*AM8) GOTO 9999 |
| 7194 | ENDIF |
| 7195 | LOBRES = LOBRES+1 |
| 7196 | ENDIF |
| 7197 | * replace chain by oktet baryon |
| 7198 | IDR = -1 |
| 7199 | IDXR = JB8 |
| 7200 | AMN = AM8 |
| 7201 | ELSEIF (AMX.LT.AMHI) THEN |
| 7202 | IDR = 1 |
| 7203 | IDXR = JB10 |
| 7204 | AMN = AM10 |
| 7205 | ENDIF |
| 7206 | RETURN |
| 7207 | |
| 7208 | * check qq-aqaq for lower mass cut |
| 7209 | 3 CONTINUE |
| 7210 | * empirical definition of AMHI to allow for (b-antib)-pair prod. |
| 7211 | AMHI = 2.5D0 |
| 7212 | IF (AMX.LT.AMHI) GOTO 9999 |
| 7213 | RETURN |
| 7214 | |
| 7215 | 9999 CONTINUE |
| 7216 | IF ((IOULEV(1).GT.0).AND.(IMODE.GT.0)) |
| 7217 | & WRITE(LOUT,*) 'rejected 1 in CH2RES',IMODE |
| 7218 | IREJ = 1 |
| 7219 | IRRES(2) = IRRES(2)+1 |
| 7220 | RETURN |
| 7221 | END |
| 7222 | * |
| 7223 | *===rjseac=============================================================* |
| 7224 | * |
| 7225 | CDECK ID>, DT_RJSEAC |
| 7226 | SUBROUTINE DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ) |
| 7227 | |
| 7228 | ************************************************************************ |
| 7229 | * ReJection of SEA-sea Chains. * |
| 7230 | * MOP1/2 entries of projectile sea-partons in DTEVT1 * |
| 7231 | * MOT1/2 entries of projectile sea-partons in DTEVT1 * |
| 7232 | * This version dated 16.01.95 is written by S. Roesler * |
| 7233 | ************************************************************************ |
| 7234 | |
| 7235 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 7236 | SAVE |
| 7237 | |
| 7238 | PARAMETER ( LINP = 5 , |
| 7239 | & LOUT = 6 , |
| 7240 | & LDAT = 9 ) |
| 7241 | |
| 7242 | PARAMETER (TINY10=1.0D-10,ZERO=0.0D0) |
| 7243 | |
| 7244 | * event history |
| 7245 | |
| 7246 | PARAMETER (NMXHKK=200000) |
| 7247 | |
| 7248 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 7249 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 7250 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 7251 | * extended event history |
| 7252 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 7253 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 7254 | & IHIST(2,NMXHKK) |
| 7255 | * statistics |
| 7256 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, |
| 7257 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), |
| 7258 | & ICEVTG(8,0:30) |
| 7259 | |
| 7260 | DIMENSION IDXSEA(2,2),IDXNUC(2),ISTVAL(2) |
| 7261 | |
| 7262 | IREJ = 0 |
| 7263 | |
| 7264 | * projectile sea q-aq-pair |
| 7265 | * indices of sea-pair |
| 7266 | IDXSEA(1,1) = MOP1 |
| 7267 | IDXSEA(1,2) = MOP2 |
| 7268 | * index of mother-nucleon |
| 7269 | IDXNUC(1) = JMOHKK(1,MOP1) |
| 7270 | * status of valence quarks to be corrected |
| 7271 | ISTVAL(1) = -21 |
| 7272 | |
| 7273 | * target sea q-aq-pair |
| 7274 | * indices of sea-pair |
| 7275 | IDXSEA(2,1) = MOT1 |
| 7276 | IDXSEA(2,2) = MOT2 |
| 7277 | * index of mother-nucleon |
| 7278 | IDXNUC(2) = JMOHKK(1,MOT1) |
| 7279 | * status of valence quarks to be corrected |
| 7280 | ISTVAL(2) = -22 |
| 7281 | |
| 7282 | DO 1 N=1,2 |
| 7283 | IDONE = 0 |
| 7284 | DO 2 I=NPOINT(2),NHKK |
| 7285 | IF ((ISTHKK(I).EQ.ISTVAL(N)).AND. |
| 7286 | & (JMOHKK(1,I).EQ.IDXNUC(N))) THEN |
| 7287 | * valence parton found |
| 7288 | * inrease 4-momentum by sea 4-momentum |
| 7289 | DO 3 K=1,4 |
| 7290 | PHKK(K,I) = PHKK(K,I)+PHKK(K,IDXSEA(N,1))+ |
| 7291 | & PHKK(K,IDXSEA(N,2)) |
| 7292 | 3 CONTINUE |
| 7293 | PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2- |
| 7294 | & PHKK(2,I)**2-PHKK(3,I)**2)) |
| 7295 | * "cancel" sea-pair |
| 7296 | DO 4 J=1,2 |
| 7297 | ISTHKK(IDXSEA(N,J)) = 100 |
| 7298 | IDHKK(IDXSEA(N,J)) = 0 |
| 7299 | JMOHKK(1,IDXSEA(N,J)) = 0 |
| 7300 | JMOHKK(2,IDXSEA(N,J)) = 0 |
| 7301 | JDAHKK(1,IDXSEA(N,J)) = 0 |
| 7302 | JDAHKK(2,IDXSEA(N,J)) = 0 |
| 7303 | DO 5 K=1,4 |
| 7304 | PHKK(K,IDXSEA(N,J)) = ZERO |
| 7305 | VHKK(K,IDXSEA(N,J)) = ZERO |
| 7306 | WHKK(K,IDXSEA(N,J)) = ZERO |
| 7307 | 5 CONTINUE |
| 7308 | PHKK(5,IDXSEA(N,J)) = ZERO |
| 7309 | 4 CONTINUE |
| 7310 | IDONE = 1 |
| 7311 | ENDIF |
| 7312 | 2 CONTINUE |
| 7313 | IF (IDONE.NE.1) THEN |
| 7314 | WRITE(LOUT,1000) NEVHKK,MOP1,MOP2,MOT1,MOT2 |
| 7315 | 1000 FORMAT(1X,'RJSEAC: event ',I8,': inconsistent event', |
| 7316 | & '-record!',/,1X,' sea-quark pairs ', |
| 7317 | & 2I5,4X,2I5,' could not be canceled!') |
| 7318 | GOTO 9999 |
| 7319 | ENDIF |
| 7320 | 1 CONTINUE |
| 7321 | ICRJSS = ICRJSS+1 |
| 7322 | RETURN |
| 7323 | |
| 7324 | 9999 CONTINUE |
| 7325 | IREJ = 1 |
| 7326 | RETURN |
| 7327 | END |
| 7328 | * |
| 7329 | *===vv2sch=============================================================* |
| 7330 | * |
| 7331 | CDECK ID>, DT_VV2SCH |
| 7332 | SUBROUTINE DT_VV2SCH |
| 7333 | |
| 7334 | ************************************************************************ |
| 7335 | * Change Valence-Valence chain systems to Single CHain systems for * |
| 7336 | * hadron-nucleus collisions with meson or antibaryon projectile. * |
| 7337 | * (Reggeon contribution) * |
| 7338 | * The single chain system is approximately treated as one chain and a * |
| 7339 | * meson at rest. * |
| 7340 | * This version dated 18.01.95 is written by S. Roesler * |
| 7341 | ************************************************************************ |
| 7342 | |
| 7343 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 7344 | SAVE |
| 7345 | |
| 7346 | PARAMETER ( LINP = 5 , |
| 7347 | & LOUT = 6 , |
| 7348 | & LDAT = 9 ) |
| 7349 | |
| 7350 | PARAMETER (ZERO=0.0D0,TINY7=1.0D-7,TINY3=1.0D-3) |
| 7351 | |
| 7352 | LOGICAL LSTART |
| 7353 | |
| 7354 | * event history |
| 7355 | |
| 7356 | PARAMETER (NMXHKK=200000) |
| 7357 | |
| 7358 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 7359 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 7360 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 7361 | * extended event history |
| 7362 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 7363 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 7364 | & IHIST(2,NMXHKK) |
| 7365 | * flags for input different options |
| 7366 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 7367 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 7368 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 7369 | * statistics |
| 7370 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, |
| 7371 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), |
| 7372 | & ICEVTG(8,0:30) |
| 7373 | |
| 7374 | DIMENSION IF(4,2),MO(4),PP1(4),PP2(4),PT1(4),PT2(4),PCH1(4), |
| 7375 | & PCH2(4) |
| 7376 | |
| 7377 | DATA LSTART /.TRUE./ |
| 7378 | |
| 7379 | IFSC = 0 |
| 7380 | IF (LSTART) THEN |
| 7381 | WRITE(LOUT,1000) |
| 7382 | 1000 FORMAT(/,1X,'VV2SCH: Reggeon contribution to valance-', |
| 7383 | & 'valence chains treated') |
| 7384 | LSTART = .FALSE. |
| 7385 | ENDIF |
| 7386 | |
| 7387 | NSTOP = NHKK |
| 7388 | |
| 7389 | * get index of first chain |
| 7390 | DO 1 I=NPOINT(3),NHKK |
| 7391 | IF (IDHKK(I).EQ.88888) THEN |
| 7392 | NC = I |
| 7393 | GOTO 2 |
| 7394 | ENDIF |
| 7395 | 1 CONTINUE |
| 7396 | |
| 7397 | 2 CONTINUE |
| 7398 | IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888) |
| 7399 | & .AND.(NC.LT.NSTOP)) THEN |
| 7400 | * get valence-valence chains |
| 7401 | IF ((IDCH(NC).EQ.8).AND.(IDCH(NC+3).EQ.8)) THEN |
| 7402 | * get "mother"-hadron indices |
| 7403 | MO1 = JMOHKK(1,JMOHKK(1,JMOHKK(1,NC))) |
| 7404 | MO2 = JMOHKK(1,JMOHKK(1,JMOHKK(2,NC))) |
| 7405 | KPROJ = IDT_ICIHAD(IDHKK(MO1)) |
| 7406 | KTARG = IDT_ICIHAD(IDHKK(MO2)) |
| 7407 | * Lab momentum of projectile hadron |
| 7408 | CALL DT_LTNUC(PHKK(3,MO1),PHKK(4,MO1),PPZ,PPE,-3) |
| 7409 | PTOT = SQRT(PHKK(1,MO1)**2+PHKK(2,MO1)**2+ |
| 7410 | & PHKK(3,MO1)**2) |
| 7411 | |
| 7412 | SICHAP = DT_PHNSCH(KPROJ,KTARG,PTOT) |
| 7413 | IF (DT_RNDM(PTOT).LE.SICHAP) THEN |
| 7414 | ICVV2S = ICVV2S+1 |
| 7415 | * single chain requested |
| 7416 | * get flavors of chain-end partons |
| 7417 | MO(1) = JMOHKK(1,NC) |
| 7418 | MO(2) = JMOHKK(2,NC) |
| 7419 | MO(3) = JMOHKK(1,NC+3) |
| 7420 | MO(4) = JMOHKK(2,NC+3) |
| 7421 | DO 3 I=1,4 |
| 7422 | IF(I,1) = IDT_IPDG2B(IDHKK(MO(I)),1,2) |
| 7423 | IF(I,2) = 0 |
| 7424 | IF (ABS(IDHKK(MO(I))).GE.1000) |
| 7425 | & IF(I,2) = IDT_IPDG2B(IDHKK(MO(I)),2,2) |
| 7426 | 3 CONTINUE |
| 7427 | * which one is the q-aq chain? |
| 7428 | * N1,N1+1 - DTEVT1-entries for q-aq system |
| 7429 | * N2,N2+1 - DTEVT1-entries for the other chain |
| 7430 | IF ((IF(1,2).EQ.0).AND.(IF(2,2).EQ.0)) THEN |
| 7431 | K1 = 1 |
| 7432 | K2 = 3 |
| 7433 | N1 = NC-2 |
| 7434 | N2 = NC+1 |
| 7435 | ELSEIF ((IF(3,2).EQ.0).AND.(IF(4,2).EQ.0)) THEN |
| 7436 | K1 = 3 |
| 7437 | K2 = 1 |
| 7438 | N1 = NC+1 |
| 7439 | N2 = NC-2 |
| 7440 | ELSE |
| 7441 | GOTO 10 |
| 7442 | ENDIF |
| 7443 | DO 4 K=1,4 |
| 7444 | PP1(K) = PHKK(K,N1) |
| 7445 | PT1(K) = PHKK(K,N1+1) |
| 7446 | PP2(K) = PHKK(K,N2) |
| 7447 | PT2(K) = PHKK(K,N2+1) |
| 7448 | 4 CONTINUE |
| 7449 | AMCH1 = PHKK(5,N1+2) |
| 7450 | AMCH2 = PHKK(5,N2+2) |
| 7451 | * get meson-identity corresponding to flavors of q-aq chain |
| 7452 | ITMP = IRESRJ |
| 7453 | IRESRJ = 0 |
| 7454 | CALL DT_CH2RES(IF(K1,1),IF(K1+1,1),0,0,IDR1,IDXR1, |
| 7455 | & ZERO,AMCH1N,1,IDUM) |
| 7456 | IRESRJ = ITMP |
| 7457 | * change kinematics of chains |
| 7458 | CALL DT_CHKINE(PP1,IDHKK(N1), PP2,IDHKK(N2), |
| 7459 | & PT1,IDHKK(N1+1),PT2,IDHKK(N2+1), |
| 7460 | & AMCH1,AMCH1N,AMCH2,IREJ1) |
| 7461 | IF (IREJ1.NE.0) GOTO 10 |
| 7462 | * check second chain for resonance |
| 7463 | IDCHAI = 2 |
| 7464 | IF ((IF(K2,2).NE.0).AND.(IF(K2+1,2).NE.0)) IDCHAI = 3 |
| 7465 | CALL DT_CH2RES(IF(K2,1),IF(K2,2),IF(K2+1,1),IF(K2+1,2), |
| 7466 | & IDR2,IDXR2,AMCH2,AMCH2N,IDCHAI,IREJ1) |
| 7467 | IF (IREJ1.NE.0) GOTO 10 |
| 7468 | IF (IDR2.NE.0) IDR2 = 100*IDR2 |
| 7469 | * add partons and chains to DTEVT1 |
| 7470 | DO 5 K=1,4 |
| 7471 | PCH1(K) = PP1(K)+PT1(K) |
| 7472 | PCH2(K) = PP2(K)+PT2(K) |
| 7473 | 5 CONTINUE |
| 7474 | CALL DT_EVTPUT(ISTHKK(N1),IDHKK(N1),N1,0,PP1(1),PP1(2), |
| 7475 | & PP1(3),PP1(4),0,0,0) |
| 7476 | CALL DT_EVTPUT(ISTHKK(N1+1),IDHKK(N1+1),N1+1,0,PT1(1), |
| 7477 | & PT1(2),PT1(3),PT1(4),0,0,0) |
| 7478 | KCH = ISTHKK(N1+2)+100 |
| 7479 | CALL DT_EVTPUT(KCH,88888,-2,-1,PCH1(1),PCH1(2),PCH1(3), |
| 7480 | & PCH1(4),IDR1,IDXR1,IDCH(N1+2)) |
| 7481 | IDHKK(N1+2) = 22222 |
| 7482 | CALL DT_EVTPUT(ISTHKK(N2),IDHKK(N2),N2,0,PP2(1),PP2(2), |
| 7483 | & PP2(3),PP2(4),0,0,0) |
| 7484 | CALL DT_EVTPUT(ISTHKK(N2+1),IDHKK(N2+1),N2+1,0,PT2(1), |
| 7485 | & PT2(2),PT2(3),PT2(4),0,0,0) |
| 7486 | KCH = ISTHKK(N2+2)+100 |
| 7487 | CALL DT_EVTPUT(KCH,88888,-2,-1,PCH2(1),PCH2(2),PCH2(3), |
| 7488 | & PCH2(4),IDR2,IDXR2,IDCH(N2+2)) |
| 7489 | IDHKK(N2+2) = 22222 |
| 7490 | ENDIF |
| 7491 | ENDIF |
| 7492 | ELSE |
| 7493 | GOTO 11 |
| 7494 | ENDIF |
| 7495 | 10 CONTINUE |
| 7496 | NC = NC+6 |
| 7497 | GOTO 2 |
| 7498 | |
| 7499 | 11 CONTINUE |
| 7500 | |
| 7501 | RETURN |
| 7502 | END |
| 7503 | * |
| 7504 | *=== phnsch ===========================================================* |
| 7505 | * |
| 7506 | CDECK ID>, DT_PHNSCH |
| 7507 | DOUBLE PRECISION FUNCTION DT_PHNSCH( KP, KTARG, PLAB ) |
| 7508 | |
| 7509 | *----------------------------------------------------------------------* |
| 7510 | * * |
| 7511 | * Probability for Hadron Nucleon Single CHain interactions: * |
| 7512 | * * |
| 7513 | * Created on 30 december 1993 by Alfredo Ferrari & Paola Sala * |
| 7514 | * Infn - Milan * |
| 7515 | * * |
| 7516 | * Last change on 04-jan-94 by Alfredo Ferrari * |
| 7517 | * * |
| 7518 | * modified by J.R.for use in DTUNUC 6.1.94 * |
| 7519 | * * |
| 7520 | * Input variables: * |
| 7521 | * Kp = hadron projectile index (Part numbering * |
| 7522 | * scheme) * |
| 7523 | * Ktarg = target nucleon index (1=proton, 8=neutron) * |
| 7524 | * Plab = projectile laboratory momentum (GeV/c) * |
| 7525 | * Output variable: * |
| 7526 | * Phnsch = probability per single chain (particle * |
| 7527 | * exchange) interactions * |
| 7528 | * * |
| 7529 | *----------------------------------------------------------------------* |
| 7530 | |
| 7531 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 7532 | SAVE |
| 7533 | |
| 7534 | PARAMETER ( LUNOUT = 6 ) |
| 7535 | PARAMETER ( LUNERR = 6 ) |
| 7536 | PARAMETER ( ONEPLS = 1.000000000000001 D+00 ) |
| 7537 | PARAMETER ( ZERZER = 0.D+00 ) |
| 7538 | PARAMETER ( ONEONE = 1.D+00 ) |
| 7539 | PARAMETER ( TWOTWO = 2.D+00 ) |
| 7540 | PARAMETER ( FIVFIV = 5.D+00 ) |
| 7541 | PARAMETER ( HLFHLF = 0.5D+00 ) |
| 7542 | |
| 7543 | PARAMETER ( NALLWP = 39 ) |
| 7544 | PARAMETER ( IDMAXP = 210 ) |
| 7545 | |
| 7546 | DIMENSION ICHRGE(39),AM(39) |
| 7547 | |
| 7548 | * particle properties (BAMJET index convention) |
| 7549 | CHARACTER*8 ANAME |
| 7550 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 7551 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 7552 | |
| 7553 | DIMENSION KPTOIP(210) |
| 7554 | * auxiliary common for reggeon exchange (DTUNUC 1.x) |
| 7555 | COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6), |
| 7556 | & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6), |
| 7557 | & IQTCHR(-6:6),MQUARK(3,39) |
| 7558 | |
| 7559 | DIMENSION SGTCOE (5,33), IHLP (NALLWP) |
| 7560 | DIMENSION SGTCO1(5,10),SGTCO2(5,8),SGTCO3(5,15) |
| 7561 | SAVE SGTCOE, IHLP |
| 7562 | SAVE IQFSC1, IQFSC2, IQBSC1, IQBSC2 |
| 7563 | EQUIVALENCE (SGTCO1(1,1),SGTCOE(1,1)) |
| 7564 | EQUIVALENCE (SGTCO2(1,1),SGTCOE(1,11)) |
| 7565 | EQUIVALENCE (SGTCO3(1,1),SGTCOE(1,19)) |
| 7566 | |
| 7567 | * Conversion from part to paprop numbering |
| 7568 | DATA KPTOIP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, |
| 7569 | & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 66*0, |
| 7570 | & 34, 36, 31, 32, 33, 35, 37, 5*0, 38, 5*0, 39, 19*0, 27, 28, 74*0/ |
| 7571 | |
| 7572 | * 1=baryon, 2=pion, 3=kaon, 4=antibaryon: |
| 7573 | DATA IHLP/1,4,5*0,1,4,2*0,3,2*2,2*3,1,4,3,3*1,2, |
| 7574 | & 2*3, 2, 4*0, 3*4, 1, 4, 1, 4, 1, 4 / |
| 7575 | C DATA ( ( SGTCOE (J,I), J=1,5 ), I=1,10 ) / |
| 7576 | DATA SGTCO1 / |
| 7577 | * 1st reaction: gamma p total |
| 7578 | &0.147 D+00, ZERZER , ZERZER , 0.0022D+00, -0.0170D+00, |
| 7579 | * 2nd reaction: gamma d total |
| 7580 | &0.300 D+00, ZERZER , ZERZER , 0.0095D+00, -0.057 D+00, |
| 7581 | * 3rd reaction: pi+ p total |
| 7582 | &16.4 D+00, 19.3D+00, -0.42D+00, 0.19 D+00, ZERZER , |
| 7583 | * 4th reaction: pi- p total |
| 7584 | &33.0 D+00, 14.0D+00, -1.36D+00, 0.456 D+00, -4.03 D+00, |
| 7585 | * 5th reaction: pi+/- d total |
| 7586 | &56.8 D+00, 42.2D+00, -1.45D+00, 0.65 D+00, -5.39 D+00, |
| 7587 | * 6th reaction: K+ p total |
| 7588 | &18.1 D+00, ZERZER , ZERZER , 0.26 D+00, -1.0 D+00, |
| 7589 | * 7th reaction: K+ n total |
| 7590 | &18.7 D+00, ZERZER , ZERZER , 0.21 D+00, -0.89 D+00, |
| 7591 | * 8th reaction: K+ d total |
| 7592 | &34.2 D+00, 7.9 D+00, -2.1 D+00, 0.346 D+00, -0.99 D+00, |
| 7593 | * 9th reaction: K- p total |
| 7594 | &32.1 D+00, ZERZER , ZERZER , 0.66 D+00, -5.6 D+00, |
| 7595 | * 10th reaction: K- n total |
| 7596 | &25.2 D+00, ZERZER , ZERZER , 0.38 D+00, -2.9 D+00/ |
| 7597 | C DATA ( ( SGTCOE (J,I), J=1,5 ), I=11,18 ) / |
| 7598 | DATA SGTCO2 / |
| 7599 | * 11th reaction: K- d total |
| 7600 | &57.6 D+00, ZERZER , ZERZER , 1.17 D+00, -9.5 D+00, |
| 7601 | * 12th reaction: p p total |
| 7602 | &48.0 D+00, ZERZER , ZERZER , 0.522 D+00, -4.51 D+00, |
| 7603 | * 13th reaction: p n total |
| 7604 | &47.30 D+00, ZERZER , ZERZER , 0.513 D+00, -4.27 D+00, |
| 7605 | * 14th reaction: p d total |
| 7606 | &91.3 D+00, ZERZER , ZERZER , 1.05 D+00, -8.8 D+00, |
| 7607 | * 15th reaction: pbar p total |
| 7608 | &38.4 D+00, 77.6D+00, -0.64D+00, 0.26 D+00, -1.2 D+00, |
| 7609 | * 16th reaction: pbar n total |
| 7610 | &ZERZER ,133.6D+00, -0.70D+00, -1.22 D+00, 13.7 D+00, |
| 7611 | * 17th reaction: pbar d total |
| 7612 | &112. D+00, 125.D+00, -1.08D+00, 1.14 D+00, -12.4 D+00, |
| 7613 | * 18th reaction: Lamda p total |
| 7614 | &30.4 D+00, ZERZER , ZERZER , ZERZER , 1.6 D+00/ |
| 7615 | C DATA ( ( SGTCOE (J,I), J=1,5 ), I=19,33 ) / |
| 7616 | DATA SGTCO3 / |
| 7617 | * 19th reaction: pi+ p elastic |
| 7618 | &ZERZER , 11.4D+00, -0.4 D+00, 0.079 D+00, ZERZER , |
| 7619 | * 20th reaction: pi- p elastic |
| 7620 | &1.76 D+00, 11.2D+00, -0.64D+00, 0.043 D+00, ZERZER , |
| 7621 | * 21st reaction: K+ p elastic |
| 7622 | &5.0 D+00, 8.1 D+00, -1.8 D+00, 0.16 D+00, -1.3 D+00, |
| 7623 | * 22nd reaction: K- p elastic |
| 7624 | &7.3 D+00, ZERZER , ZERZER , 0.29 D+00, -2.40 D+00, |
| 7625 | * 23rd reaction: p p elastic |
| 7626 | &11.9 D+00, 26.9D+00, -1.21D+00, 0.169 D+00, -1.85 D+00, |
| 7627 | * 24th reaction: p d elastic |
| 7628 | &16.1 D+00, ZERZER , ZERZER , 0.32 D+00, -3.4 D+00, |
| 7629 | * 25th reaction: pbar p elastic |
| 7630 | &10.2 D+00, 52.7D+00, -1.16D+00, 0.125 D+00, -1.28 D+00, |
| 7631 | * 26th reaction: pbar p elastic bis |
| 7632 | &10.6 D+00, 53.1D+00, -1.19D+00, 0.136 D+00, -1.41 D+00, |
| 7633 | * 27th reaction: pbar n elastic |
| 7634 | &36.5 D+00, ZERZER , ZERZER , ZERZER , -11.9 D+00, |
| 7635 | * 28th reaction: Lamda p elastic |
| 7636 | &12.3 D+00, ZERZER , ZERZER , ZERZER , -2.4 D+00, |
| 7637 | * 29th reaction: K- p ela bis |
| 7638 | &7.24 D+00, 46.0D+00, -4.71D+00, 0.279 D+00, -2.35 D+00, |
| 7639 | * 30th reaction: pi- p cx |
| 7640 | &ZERZER ,0.912D+00, -1.22D+00, ZERZER , ZERZER , |
| 7641 | * 31st reaction: K- p cx |
| 7642 | &ZERZER , 3.39D+00, -1.75D+00, ZERZER , ZERZER , |
| 7643 | * 32nd reaction: K+ n cx |
| 7644 | &ZERZER , 7.18D+00, -2.01D+00, ZERZER , ZERZER , |
| 7645 | * 33rd reaction: pbar p cx |
| 7646 | &ZERZER , 18.8D+00, -2.01D+00, ZERZER , ZERZER / |
| 7647 | * |
| 7648 | * +-------------------------------------------------------------------* |
| 7649 | ICHRGE(KTARG)=IICH(KTARG) |
| 7650 | AM (KTARG)=AAM (KTARG) |
| 7651 | * | Check for pi0 (d-dbar) |
| 7652 | IF ( KP .NE. 26 ) THEN |
| 7653 | IP = KPTOIP (KP) |
| 7654 | IF(IP.EQ.0)IP=1 |
| 7655 | ICHRGE(IP)=IICH(KP) |
| 7656 | AM (IP)=AAM (KP) |
| 7657 | * | |
| 7658 | * +-------------------------------------------------------------------* |
| 7659 | * | |
| 7660 | ELSE |
| 7661 | IP = 23 |
| 7662 | ICHRGE(IP)=0 |
| 7663 | END IF |
| 7664 | * | |
| 7665 | * +-------------------------------------------------------------------* |
| 7666 | * +-------------------------------------------------------------------* |
| 7667 | * | No such interactions for baryon-baryon |
| 7668 | IF ( IIBAR (KP) .GT. 0 ) THEN |
| 7669 | DT_PHNSCH = ZERZER |
| 7670 | RETURN |
| 7671 | * | |
| 7672 | * +-------------------------------------------------------------------* |
| 7673 | * | No "annihilation" diagram possible for K+ p/n |
| 7674 | ELSE IF ( IP .EQ. 15 ) THEN |
| 7675 | DT_PHNSCH = ZERZER |
| 7676 | RETURN |
| 7677 | * | |
| 7678 | * +-------------------------------------------------------------------* |
| 7679 | * | No "annihilation" diagram possible for K0 p/n |
| 7680 | ELSE IF ( IP .EQ. 24 ) THEN |
| 7681 | DT_PHNSCH = ZERZER |
| 7682 | RETURN |
| 7683 | * | |
| 7684 | * +-------------------------------------------------------------------* |
| 7685 | * | No "annihilation" diagram possible for Omebar p/n |
| 7686 | ELSE IF ( IP .GE. 38 ) THEN |
| 7687 | DT_PHNSCH = ZERZER |
| 7688 | RETURN |
| 7689 | END IF |
| 7690 | * | |
| 7691 | * +-------------------------------------------------------------------* |
| 7692 | * +-------------------------------------------------------------------* |
| 7693 | * | If the momentum is larger than 50 GeV/c, compute the single |
| 7694 | * | chain probability at 50 GeV/c and extrapolate to the present |
| 7695 | * | momentum according to 1/sqrt(s) |
| 7696 | * | sigma = sigma_sch (50) * sqrt (s(50)/s) + sigma_dch |
| 7697 | * | P_sch (50) = sigma_sch (50) / ( sigma_dch + sigma_sch (50) ) |
| 7698 | * | sigma_dch / sigma_sch (50) = 1 / P_sch (50) - 1 |
| 7699 | * | sigma_dch / sigma_sch = 1 / P_sch - 1 = ( 1 / P_sch (50) - 1 ) |
| 7700 | * | x sqrt(s/s(50)) |
| 7701 | * | P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ] |
| 7702 | IF ( PLAB .GT. 50.D+00 ) THEN |
| 7703 | PLA = 50.D+00 |
| 7704 | AMPSQ = AM (IP)**2 |
| 7705 | AMTSQ = AM (KTARG)**2 |
| 7706 | EPROJ = SQRT ( PLAB**2 + AMPSQ ) |
| 7707 | UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ |
| 7708 | EPROJ = SQRT ( PLA**2 + AMPSQ ) |
| 7709 | UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ |
| 7710 | UMORAT = SQRT ( UMOSQ / UMO50 ) |
| 7711 | * | |
| 7712 | * +-------------------------------------------------------------------* |
| 7713 | * | P < 3 GeV/c |
| 7714 | ELSE IF ( PLAB .LT. 3.D+00 ) THEN |
| 7715 | PLA = 3.D+00 |
| 7716 | AMPSQ = AM (IP)**2 |
| 7717 | AMTSQ = AM (KTARG)**2 |
| 7718 | EPROJ = SQRT ( PLAB**2 + AMPSQ ) |
| 7719 | UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ |
| 7720 | EPROJ = SQRT ( PLA**2 + AMPSQ ) |
| 7721 | UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ |
| 7722 | UMORAT = SQRT ( UMOSQ / UMO50 ) |
| 7723 | * | |
| 7724 | * +-------------------------------------------------------------------* |
| 7725 | * | P < 50 GeV/c |
| 7726 | ELSE |
| 7727 | PLA = PLAB |
| 7728 | UMORAT = ONEONE |
| 7729 | END IF |
| 7730 | * | |
| 7731 | * +-------------------------------------------------------------------* |
| 7732 | ALGPLA = LOG (PLA) |
| 7733 | * +-------------------------------------------------------------------* |
| 7734 | * | Pions: |
| 7735 | IF ( IHLP (IP) .EQ. 2 ) THEN |
| 7736 | ACOF = SGTCOE (1,3) |
| 7737 | BCOF = SGTCOE (2,3) |
| 7738 | ENNE = SGTCOE (3,3) |
| 7739 | CCOF = SGTCOE (4,3) |
| 7740 | DCOF = SGTCOE (5,3) |
| 7741 | * | Compute the pi+ p total cross section: |
| 7742 | SPPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 |
| 7743 | & + DCOF * ALGPLA |
| 7744 | ACOF = SGTCOE (1,19) |
| 7745 | BCOF = SGTCOE (2,19) |
| 7746 | ENNE = SGTCOE (3,19) |
| 7747 | CCOF = SGTCOE (4,19) |
| 7748 | DCOF = SGTCOE (5,19) |
| 7749 | * | Compute the pi+ p elastic cross section: |
| 7750 | SPPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 |
| 7751 | & + DCOF * ALGPLA |
| 7752 | * | Compute the pi+ p inelastic cross section: |
| 7753 | SPPPIN = SPPPTT - SPPPEL |
| 7754 | ACOF = SGTCOE (1,4) |
| 7755 | BCOF = SGTCOE (2,4) |
| 7756 | ENNE = SGTCOE (3,4) |
| 7757 | CCOF = SGTCOE (4,4) |
| 7758 | DCOF = SGTCOE (5,4) |
| 7759 | * | Compute the pi- p total cross section: |
| 7760 | SPMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 |
| 7761 | & + DCOF * ALGPLA |
| 7762 | ACOF = SGTCOE (1,20) |
| 7763 | BCOF = SGTCOE (2,20) |
| 7764 | ENNE = SGTCOE (3,20) |
| 7765 | CCOF = SGTCOE (4,20) |
| 7766 | DCOF = SGTCOE (5,20) |
| 7767 | * | Compute the pi- p elastic cross section: |
| 7768 | SPMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 |
| 7769 | & + DCOF * ALGPLA |
| 7770 | * | Compute the pi- p inelastic cross section: |
| 7771 | SPMPIN = SPMPTT - SPMPEL |
| 7772 | SIGDIA = SPMPIN - SPPPIN |
| 7773 | * | +----------------------------------------------------------------* |
| 7774 | * | | Charged pions: besides isospin consideration it is supposed |
| 7775 | * | | that (pi+ n)el is almost equal to (pi- p)el |
| 7776 | * | | and (pi+ p)el " " " " (pi- n)el |
| 7777 | * | | and all are almost equal among each others |
| 7778 | * | | (reasonable above 5 GeV/c) |
| 7779 | IF ( ICHRGE (IP) .NE. 0 ) THEN |
| 7780 | KHELP = KTARG / 8 |
| 7781 | JREAC = 3 + IP - 13 + ICHRGE (IP) * KHELP |
| 7782 | ACOF = SGTCOE (1,JREAC) |
| 7783 | BCOF = SGTCOE (2,JREAC) |
| 7784 | ENNE = SGTCOE (3,JREAC) |
| 7785 | CCOF = SGTCOE (4,JREAC) |
| 7786 | DCOF = SGTCOE (5,JREAC) |
| 7787 | * | | Compute the total cross section: |
| 7788 | SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 |
| 7789 | & + DCOF * ALGPLA |
| 7790 | JREAC = 19 + IP - 13 + ICHRGE (IP) * KHELP |
| 7791 | ACOF = SGTCOE (1,JREAC) |
| 7792 | BCOF = SGTCOE (2,JREAC) |
| 7793 | ENNE = SGTCOE (3,JREAC) |
| 7794 | CCOF = SGTCOE (4,JREAC) |
| 7795 | DCOF = SGTCOE (5,JREAC) |
| 7796 | * | | Compute the elastic cross section: |
| 7797 | SHNCEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 |
| 7798 | & + DCOF * ALGPLA |
| 7799 | * | | Compute the inelastic cross section: |
| 7800 | SHNCIN = SHNCTT - SHNCEL |
| 7801 | * | | Number of diagrams: |
| 7802 | NDIAGR = 1 + IP - 13 + ICHRGE (IP) * KHELP |
| 7803 | * | | Now compute the chain end (anti)quark-(anti)diquark |
| 7804 | IQFSC1 = 1 + IP - 13 |
| 7805 | IQFSC2 = 0 |
| 7806 | IQBSC1 = 1 + KHELP |
| 7807 | IQBSC2 = 1 + IP - 13 |
| 7808 | * | | |
| 7809 | * | +----------------------------------------------------------------* |
| 7810 | * | | pi0: besides isospin consideration it is supposed that the |
| 7811 | * | | elastic cross section is not very different from |
| 7812 | * | | pi+ p and/or pi- p (reasonable above 5 GeV/c) |
| 7813 | ELSE |
| 7814 | KHELP = KTARG / 8 |
| 7815 | K2HLP = ( KP - 23 ) / 3 |
| 7816 | * | | Number of diagrams: |
| 7817 | * | | For u ubar (k2hlp=0): |
| 7818 | * NDIAGR = 2 - KHELP |
| 7819 | * | | For d dbar (k2hlp=1): |
| 7820 | * NDIAGR = 2 + KHELP - K2HLP |
| 7821 | NDIAGR = 2 + KHELP * ( 2 * K2HLP - 1 ) - K2HLP |
| 7822 | SHNCIN = HLFHLF * ( SPPPIN + SPMPIN ) |
| 7823 | * | | Now compute the chain end (anti)quark-(anti)diquark |
| 7824 | IQFSC1 = 1 + K2HLP |
| 7825 | IQFSC2 = 0 |
| 7826 | IQBSC1 = 1 + KHELP |
| 7827 | IQBSC2 = 2 - K2HLP |
| 7828 | END IF |
| 7829 | * | | |
| 7830 | * | +----------------------------------------------------------------* |
| 7831 | * | end pi's |
| 7832 | * +-------------------------------------------------------------------* |
| 7833 | * | Kaons: |
| 7834 | ELSE IF ( IHLP (IP) .EQ. 3 ) THEN |
| 7835 | ACOF = SGTCOE (1,6) |
| 7836 | BCOF = SGTCOE (2,6) |
| 7837 | ENNE = SGTCOE (3,6) |
| 7838 | CCOF = SGTCOE (4,6) |
| 7839 | DCOF = SGTCOE (5,6) |
| 7840 | * | Compute the K+ p total cross section: |
| 7841 | SKPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 |
| 7842 | & + DCOF * ALGPLA |
| 7843 | ACOF = SGTCOE (1,21) |
| 7844 | BCOF = SGTCOE (2,21) |
| 7845 | ENNE = SGTCOE (3,21) |
| 7846 | CCOF = SGTCOE (4,21) |
| 7847 | DCOF = SGTCOE (5,21) |
| 7848 | * | Compute the K+ p elastic cross section: |
| 7849 | SKPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 |
| 7850 | & + DCOF * ALGPLA |
| 7851 | * | Compute the K+ p inelastic cross section: |
| 7852 | SKPPIN = SKPPTT - SKPPEL |
| 7853 | ACOF = SGTCOE (1,9) |
| 7854 | BCOF = SGTCOE (2,9) |
| 7855 | ENNE = SGTCOE (3,9) |
| 7856 | CCOF = SGTCOE (4,9) |
| 7857 | DCOF = SGTCOE (5,9) |
| 7858 | * | Compute the K- p total cross section: |
| 7859 | SKMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 |
| 7860 | & + DCOF * ALGPLA |
| 7861 | ACOF = SGTCOE (1,22) |
| 7862 | BCOF = SGTCOE (2,22) |
| 7863 | ENNE = SGTCOE (3,22) |
| 7864 | CCOF = SGTCOE (4,22) |
| 7865 | DCOF = SGTCOE (5,22) |
| 7866 | * | Compute the K- p elastic cross section: |
| 7867 | SKMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 |
| 7868 | & + DCOF * ALGPLA |
| 7869 | * | Compute the K- p inelastic cross section: |
| 7870 | SKMPIN = SKMPTT - SKMPEL |
| 7871 | SIGDIA = HLFHLF * ( SKMPIN - SKPPIN ) |
| 7872 | * | +----------------------------------------------------------------* |
| 7873 | * | | Charged Kaons: actually only K- |
| 7874 | IF ( ICHRGE (IP) .NE. 0 ) THEN |
| 7875 | KHELP = KTARG / 8 |
| 7876 | * | | +-------------------------------------------------------------* |
| 7877 | * | | | Proton target: |
| 7878 | IF ( KHELP .EQ. 0 ) THEN |
| 7879 | SHNCIN = SKMPIN |
| 7880 | * | | | Number of diagrams: |
| 7881 | NDIAGR = 2 |
| 7882 | * | | | |
| 7883 | * | | +-------------------------------------------------------------* |
| 7884 | * | | | Neutron target: besides isospin consideration it is supposed |
| 7885 | * | | | that (K- n)el is almost equal to (K- p)el |
| 7886 | * | | | (reasonable above 5 GeV/c) |
| 7887 | ELSE |
| 7888 | ACOF = SGTCOE (1,10) |
| 7889 | BCOF = SGTCOE (2,10) |
| 7890 | ENNE = SGTCOE (3,10) |
| 7891 | CCOF = SGTCOE (4,10) |
| 7892 | DCOF = SGTCOE (5,10) |
| 7893 | * | | | Compute the total cross section: |
| 7894 | SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 |
| 7895 | & + DCOF * ALGPLA |
| 7896 | * | | | Compute the elastic cross section: |
| 7897 | SHNCEL = SKMPEL |
| 7898 | * | | | Compute the inelastic cross section: |
| 7899 | SHNCIN = SHNCTT - SHNCEL |
| 7900 | * | | | Number of diagrams: |
| 7901 | NDIAGR = 1 |
| 7902 | END IF |
| 7903 | * | | | |
| 7904 | * | | +-------------------------------------------------------------* |
| 7905 | * | | Now compute the chain end (anti)quark-(anti)diquark |
| 7906 | IQFSC1 = 3 |
| 7907 | IQFSC2 = 0 |
| 7908 | IQBSC1 = 1 + KHELP |
| 7909 | IQBSC2 = 2 |
| 7910 | * | | |
| 7911 | * | +----------------------------------------------------------------* |
| 7912 | * | | K0's: (actually only K0bar) |
| 7913 | ELSE |
| 7914 | KHELP = KTARG / 8 |
| 7915 | * | | +-------------------------------------------------------------* |
| 7916 | * | | | Proton target: (K0bar p)in supposed to be given by |
| 7917 | * | | | (K- p)in - Sig_diagr |
| 7918 | IF ( KHELP .EQ. 0 ) THEN |
| 7919 | SHNCIN = SKMPIN - SIGDIA |
| 7920 | * | | | Number of diagrams: |
| 7921 | NDIAGR = 1 |
| 7922 | * | | | |
| 7923 | * | | +-------------------------------------------------------------* |
| 7924 | * | | | Neutron target: (K0bar n)in supposed to be given by |
| 7925 | * | | | (K- n)in + Sig_diagr |
| 7926 | * | | | besides isospin consideration it is supposed |
| 7927 | * | | | that (K- n)el is almost equal to (K- p)el |
| 7928 | * | | | (reasonable above 5 GeV/c) |
| 7929 | ELSE |
| 7930 | ACOF = SGTCOE (1,10) |
| 7931 | BCOF = SGTCOE (2,10) |
| 7932 | ENNE = SGTCOE (3,10) |
| 7933 | CCOF = SGTCOE (4,10) |
| 7934 | DCOF = SGTCOE (5,10) |
| 7935 | * | | | Compute the total cross section: |
| 7936 | SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 |
| 7937 | & + DCOF * ALGPLA |
| 7938 | * | | | Compute the elastic cross section: |
| 7939 | SHNCEL = SKMPEL |
| 7940 | * | | | Compute the inelastic cross section: |
| 7941 | SHNCIN = SHNCTT - SHNCEL + SIGDIA |
| 7942 | * | | | Number of diagrams: |
| 7943 | NDIAGR = 2 |
| 7944 | END IF |
| 7945 | * | | | |
| 7946 | * | | +-------------------------------------------------------------* |
| 7947 | * | | Now compute the chain end (anti)quark-(anti)diquark |
| 7948 | IQFSC1 = 3 |
| 7949 | IQFSC2 = 0 |
| 7950 | IQBSC1 = 1 |
| 7951 | IQBSC2 = 1 + KHELP |
| 7952 | END IF |
| 7953 | * | | |
| 7954 | * | +----------------------------------------------------------------* |
| 7955 | * | end Kaon's |
| 7956 | * +-------------------------------------------------------------------* |
| 7957 | * | Antinucleons: |
| 7958 | ELSE IF ( IHLP (IP) .EQ. 4 .AND. IP .LE. 9 ) THEN |
| 7959 | * | For momenta between 3 and 5 GeV/c the use of tabulated data |
| 7960 | * | should be implemented! |
| 7961 | ACOF = SGTCOE (1,15) |
| 7962 | BCOF = SGTCOE (2,15) |
| 7963 | ENNE = SGTCOE (3,15) |
| 7964 | CCOF = SGTCOE (4,15) |
| 7965 | DCOF = SGTCOE (5,15) |
| 7966 | * | Compute the pbar p total cross section: |
| 7967 | SAPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 |
| 7968 | & + DCOF * ALGPLA |
| 7969 | IF ( PLA .LT. FIVFIV ) THEN |
| 7970 | JREAC = 26 |
| 7971 | ELSE |
| 7972 | JREAC = 25 |
| 7973 | END IF |
| 7974 | ACOF = SGTCOE (1,JREAC) |
| 7975 | BCOF = SGTCOE (2,JREAC) |
| 7976 | ENNE = SGTCOE (3,JREAC) |
| 7977 | CCOF = SGTCOE (4,JREAC) |
| 7978 | DCOF = SGTCOE (5,JREAC) |
| 7979 | * | Compute the pbar p elastic cross section: |
| 7980 | SAPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 |
| 7981 | & + DCOF * ALGPLA |
| 7982 | * | Compute the pbar p inelastic cross section: |
| 7983 | SAPPIN = SAPPTT - SAPPEL |
| 7984 | ACOF = SGTCOE (1,12) |
| 7985 | BCOF = SGTCOE (2,12) |
| 7986 | ENNE = SGTCOE (3,12) |
| 7987 | CCOF = SGTCOE (4,12) |
| 7988 | DCOF = SGTCOE (5,12) |
| 7989 | * | Compute the p p total cross section: |
| 7990 | SPPTOT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 |
| 7991 | & + DCOF * ALGPLA |
| 7992 | ACOF = SGTCOE (1,23) |
| 7993 | BCOF = SGTCOE (2,23) |
| 7994 | ENNE = SGTCOE (3,23) |
| 7995 | CCOF = SGTCOE (4,23) |
| 7996 | DCOF = SGTCOE (5,23) |
| 7997 | * | Compute the p p elastic cross section: |
| 7998 | SPPELA = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 |
| 7999 | & + DCOF * ALGPLA |
| 8000 | * | Compute the K- p inelastic cross section: |
| 8001 | SPPINE = SPPTOT - SPPELA |
| 8002 | SIGDIA = ( SAPPIN - SPPINE ) / FIVFIV |
| 8003 | KHELP = KTARG / 8 |
| 8004 | * | +----------------------------------------------------------------* |
| 8005 | * | | Pbar: |
| 8006 | IF ( ICHRGE (IP) .NE. 0 ) THEN |
| 8007 | NDIAGR = 5 - KHELP |
| 8008 | * | | +-------------------------------------------------------------* |
| 8009 | * | | | Proton target: |
| 8010 | IF ( KHELP .EQ. 0 ) THEN |
| 8011 | * | | | Number of diagrams: |
| 8012 | SHNCIN = SAPPIN |
| 8013 | PUUBAR = 0.8D+00 |
| 8014 | * | | | |
| 8015 | * | | +-------------------------------------------------------------* |
| 8016 | * | | | Neutron target: it is supposed that (ap n)el is almost equal |
| 8017 | * | | | to (ap p)el (reasonable above 5 GeV/c) |
| 8018 | ELSE |
| 8019 | ACOF = SGTCOE (1,16) |
| 8020 | BCOF = SGTCOE (2,16) |
| 8021 | ENNE = SGTCOE (3,16) |
| 8022 | CCOF = SGTCOE (4,16) |
| 8023 | DCOF = SGTCOE (5,16) |
| 8024 | * | | | Compute the total cross section: |
| 8025 | SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 |
| 8026 | & + DCOF * ALGPLA |
| 8027 | * | | | Compute the elastic cross section: |
| 8028 | SHNCEL = SAPPEL |
| 8029 | * | | | Compute the inelastic cross section: |
| 8030 | SHNCIN = SHNCTT - SHNCEL |
| 8031 | PUUBAR = HLFHLF |
| 8032 | END IF |
| 8033 | * | | | |
| 8034 | * | | +-------------------------------------------------------------* |
| 8035 | * | | Now compute the chain end (anti)quark-(anti)diquark |
| 8036 | * | | there are different possibilities, make a random choiche: |
| 8037 | IQFSC1 = -1 |
| 8038 | RNCHEN = DT_RNDM(PUUBAR) |
| 8039 | IF ( RNCHEN .LT. PUUBAR ) THEN |
| 8040 | IQFSC2 = -2 |
| 8041 | ELSE |
| 8042 | IQFSC2 = -1 |
| 8043 | END IF |
| 8044 | IQBSC1 = -IQFSC1 + KHELP |
| 8045 | IQBSC2 = -IQFSC2 |
| 8046 | * | | |
| 8047 | * | +----------------------------------------------------------------* |
| 8048 | * | | nbar: |
| 8049 | ELSE |
| 8050 | NDIAGR = 4 + KHELP |
| 8051 | * | | +-------------------------------------------------------------* |
| 8052 | * | | | Proton target: (nbar p)in supposed to be given by |
| 8053 | * | | | (pbar p)in - Sig_diagr |
| 8054 | IF ( KHELP .EQ. 0 ) THEN |
| 8055 | SHNCIN = SAPPIN - SIGDIA |
| 8056 | PDDBAR = HLFHLF |
| 8057 | * | | | |
| 8058 | * | | +-------------------------------------------------------------* |
| 8059 | * | | | Neutron target: (nbar n)el is supposed to be equal to |
| 8060 | * | | | (pbar p)el (reasonable above 5 GeV/c) |
| 8061 | ELSE |
| 8062 | * | | | Compute the total cross section: |
| 8063 | SHNCTT = SAPPTT |
| 8064 | * | | | Compute the elastic cross section: |
| 8065 | SHNCEL = SAPPEL |
| 8066 | * | | | Compute the inelastic cross section: |
| 8067 | SHNCIN = SHNCTT - SHNCEL |
| 8068 | PDDBAR = 0.8D+00 |
| 8069 | END IF |
| 8070 | * | | | |
| 8071 | * | | +-------------------------------------------------------------* |
| 8072 | * | | Now compute the chain end (anti)quark-(anti)diquark |
| 8073 | * | | there are different possibilities, make a random choiche: |
| 8074 | IQFSC1 = -2 |
| 8075 | RNCHEN = DT_RNDM(RNCHEN) |
| 8076 | IF ( RNCHEN .LT. PDDBAR ) THEN |
| 8077 | IQFSC2 = -1 |
| 8078 | ELSE |
| 8079 | IQFSC2 = -2 |
| 8080 | END IF |
| 8081 | IQBSC1 = -IQFSC1 + KHELP - 1 |
| 8082 | IQBSC2 = -IQFSC2 |
| 8083 | END IF |
| 8084 | * | | |
| 8085 | * | +----------------------------------------------------------------* |
| 8086 | * | |
| 8087 | * +-------------------------------------------------------------------* |
| 8088 | * | Others: not yet implemented |
| 8089 | ELSE |
| 8090 | SIGDIA = ZERZER |
| 8091 | SHNCIN = ONEONE |
| 8092 | NDIAGR = 0 |
| 8093 | DT_PHNSCH = ZERZER |
| 8094 | RETURN |
| 8095 | END IF |
| 8096 | * | end others |
| 8097 | * +-------------------------------------------------------------------* |
| 8098 | DT_PHNSCH = NDIAGR * SIGDIA / SHNCIN |
| 8099 | IQECHC = IQECHR (IQFSC1) + IQECHR (IQFSC2) + IQECHR (IQBSC1) |
| 8100 | & + IQECHR (IQBSC2) |
| 8101 | IQBCHC = IQBCHR (IQFSC1) + IQBCHR (IQFSC2) + IQBCHR (IQBSC1) |
| 8102 | & + IQBCHR (IQBSC2) |
| 8103 | IQECHC = IQECHC / 3 |
| 8104 | IQBCHC = IQBCHC / 3 |
| 8105 | IQSCHC = IQSCHR (IQFSC1) + IQSCHR (IQFSC2) + IQSCHR (IQBSC1) |
| 8106 | & + IQSCHR (IQBSC2) |
| 8107 | IQSPRO = IQSCHR (MQUARK(1,IP)) + IQSCHR (MQUARK(2,IP)) |
| 8108 | & + IQSCHR (MQUARK(3,IP)) |
| 8109 | * +-------------------------------------------------------------------* |
| 8110 | * | Consistency check: |
| 8111 | IF ( DT_PHNSCH .LE. ZERZER .OR. DT_PHNSCH .GT. ONEONE ) THEN |
| 8112 | WRITE (LUNOUT,*)' *** Phnsch,kp,ktarg,pla', |
| 8113 | & DT_PHNSCH,KP,KTARG,PLA,' ****' |
| 8114 | WRITE (LUNERR,*)' *** Phnsch,kp,ktarg,pla', |
| 8115 | & DT_PHNSCH,KP,KTARG,PLA,' ****' |
| 8116 | DT_PHNSCH = MAX ( DT_PHNSCH, ZERZER ) |
| 8117 | DT_PHNSCH = MIN ( DT_PHNSCH, ONEONE ) |
| 8118 | END IF |
| 8119 | * | |
| 8120 | * +-------------------------------------------------------------------* |
| 8121 | * +-------------------------------------------------------------------* |
| 8122 | * | Consistency check: |
| 8123 | IF ( IQSPRO .NE. IQSCHC .OR. ICHRGE (IP) + ICHRGE (KTARG) |
| 8124 | & .NE. IQECHC .OR. IIBAR (KP) + IIBAR (KTARG) .NE. IQBCHC) THEN |
| 8125 | WRITE (LUNOUT,*) |
| 8126 | &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg', |
| 8127 | & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG |
| 8128 | WRITE (LUNERR,*) |
| 8129 | &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg', |
| 8130 | & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG |
| 8131 | END IF |
| 8132 | * | |
| 8133 | * +-------------------------------------------------------------------* |
| 8134 | * P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ] |
| 8135 | IF ( UMORAT .GT. ONEPLS ) |
| 8136 | & DT_PHNSCH = ONEONE / ( ( ONEONE / DT_PHNSCH |
| 8137 | & - ONEONE ) * UMORAT + ONEONE ) |
| 8138 | RETURN |
| 8139 | * |
| 8140 | ENTRY DT_SCHQUA ( JQFSC1, JQFSC2, JQBSC1, JQBSC2 ) |
| 8141 | DT_SCHQUA = ONEONE |
| 8142 | JQFSC1 = IQFSC1 |
| 8143 | JQFSC2 = IQFSC2 |
| 8144 | JQBSC1 = IQBSC1 |
| 8145 | JQBSC2 = IQBSC2 |
| 8146 | *=== End of function Phnsch ===========================================* |
| 8147 | RETURN |
| 8148 | END |
| 8149 | * |
| 8150 | *===respt==============================================================* |
| 8151 | * |
| 8152 | CDECK ID>, DT_RESPT |
| 8153 | SUBROUTINE DT_RESPT |
| 8154 | |
| 8155 | ************************************************************************ |
| 8156 | * Check DTEVT1 for two-resonance systems and sample intrinsic p_t. * |
| 8157 | * This version dated 18.01.95 is written by S. Roesler * |
| 8158 | ************************************************************************ |
| 8159 | |
| 8160 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 8161 | SAVE |
| 8162 | |
| 8163 | PARAMETER ( LINP = 5 , |
| 8164 | & LOUT = 6 , |
| 8165 | & LDAT = 9 ) |
| 8166 | |
| 8167 | PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3) |
| 8168 | |
| 8169 | * event history |
| 8170 | |
| 8171 | PARAMETER (NMXHKK=200000) |
| 8172 | |
| 8173 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 8174 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 8175 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 8176 | * extended event history |
| 8177 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 8178 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 8179 | & IHIST(2,NMXHKK) |
| 8180 | |
| 8181 | * get index of first chain |
| 8182 | DO 1 I=NPOINT(3),NHKK |
| 8183 | IF (IDHKK(I).EQ.88888) THEN |
| 8184 | NC = I |
| 8185 | GOTO 2 |
| 8186 | ENDIF |
| 8187 | 1 CONTINUE |
| 8188 | |
| 8189 | 2 CONTINUE |
| 8190 | IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)) THEN |
| 8191 | C WRITE(LOUT,*)NC,NC+3,IDRES(NC),IDRES(NC+3) |
| 8192 | * skip VV-,SS- systems |
| 8193 | IF ((IDCH(NC ).NE.1).AND.(IDCH(NC ).NE.8).AND. |
| 8194 | & (IDCH(NC+3).NE.1).AND.(IDCH(NC+3).NE.8)) THEN |
| 8195 | * check if both "chains" are resonances |
| 8196 | IF ((IDRES(NC).NE.0).AND.(IDRES(NC+3).NE.0)) THEN |
| 8197 | CALL DT_SAPTRE(NC,NC+3) |
| 8198 | ENDIF |
| 8199 | ENDIF |
| 8200 | ELSE |
| 8201 | GOTO 3 |
| 8202 | ENDIF |
| 8203 | NC = NC+6 |
| 8204 | GOTO 2 |
| 8205 | |
| 8206 | 3 CONTINUE |
| 8207 | |
| 8208 | RETURN |
| 8209 | END |
| 8210 | * |
| 8211 | *===evtres=============================================================* |
| 8212 | * |
| 8213 | CDECK ID>, DT_EVTRES |
| 8214 | SUBROUTINE DT_EVTRES(IREJ) |
| 8215 | |
| 8216 | ************************************************************************ |
| 8217 | * This version dated 14.12.94 is written by S. Roesler * |
| 8218 | ************************************************************************ |
| 8219 | |
| 8220 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 8221 | SAVE |
| 8222 | |
| 8223 | PARAMETER ( LINP = 5 , |
| 8224 | & LOUT = 6 , |
| 8225 | & LDAT = 9 ) |
| 8226 | |
| 8227 | PARAMETER (TINY5=1.0D-5,TINY10=1.0D-10) |
| 8228 | |
| 8229 | * event history |
| 8230 | |
| 8231 | PARAMETER (NMXHKK=200000) |
| 8232 | |
| 8233 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 8234 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 8235 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 8236 | * extended event history |
| 8237 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 8238 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 8239 | & IHIST(2,NMXHKK) |
| 8240 | * flags for input different options |
| 8241 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 8242 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 8243 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 8244 | * particle properties (BAMJET index convention) |
| 8245 | CHARACTER*8 ANAME |
| 8246 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 8247 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 8248 | |
| 8249 | DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),IFP(2),IFT(2) |
| 8250 | |
| 8251 | IREJ = 0 |
| 8252 | |
| 8253 | DO 1 I=NPOINT(3),NHKK |
| 8254 | IF (ABS(IDRES(I)).GE.100) THEN |
| 8255 | AMMX = 0.0D0 |
| 8256 | DO 2 J=NPOINT(3),NHKK |
| 8257 | IF (IDHKK(J).EQ.88888) THEN |
| 8258 | IF (PHKK(5,J).GT.AMMX) THEN |
| 8259 | AMMX = PHKK(5,J) |
| 8260 | IMMX = J |
| 8261 | ENDIF |
| 8262 | ENDIF |
| 8263 | 2 CONTINUE |
| 8264 | IF (IDRES(IMMX).NE.0) THEN |
| 8265 | IF (IOULEV(3).GT.0) THEN |
| 8266 | WRITE(LOUT,'(1X,A)') |
| 8267 | & 'EVTRES: no chain for correc. found' |
| 8268 | C GOTO 6 |
| 8269 | GOTO 9999 |
| 8270 | ELSE |
| 8271 | GOTO 9999 |
| 8272 | ENDIF |
| 8273 | ENDIF |
| 8274 | IMO11 = JMOHKK(1,I) |
| 8275 | IMO12 = JMOHKK(2,I) |
| 8276 | IF (PHKK(3,IMO11).LT.0.0D0) THEN |
| 8277 | IMO11 = JMOHKK(2,I) |
| 8278 | IMO12 = JMOHKK(1,I) |
| 8279 | ENDIF |
| 8280 | IMO21 = JMOHKK(1,IMMX) |
| 8281 | IMO22 = JMOHKK(2,IMMX) |
| 8282 | IF (PHKK(3,IMO21).LT.0.0D0) THEN |
| 8283 | IMO21 = JMOHKK(2,IMMX) |
| 8284 | IMO22 = JMOHKK(1,IMMX) |
| 8285 | ENDIF |
| 8286 | AMCH1 = PHKK(5,I) |
| 8287 | AMCH1N = AAM(IDXRES(I)) |
| 8288 | |
| 8289 | IFPR1 = IDHKK(IMO11) |
| 8290 | IFPR2 = IDHKK(IMO21) |
| 8291 | IFTA1 = IDHKK(IMO12) |
| 8292 | IFTA2 = IDHKK(IMO22) |
| 8293 | DO 4 J=1,4 |
| 8294 | PP1(J) = PHKK(J,IMO11) |
| 8295 | PP2(J) = PHKK(J,IMO21) |
| 8296 | PT1(J) = PHKK(J,IMO12) |
| 8297 | PT2(J) = PHKK(J,IMO22) |
| 8298 | 4 CONTINUE |
| 8299 | * store initial configuration for energy-momentum cons. check |
| 8300 | IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IREJ1) |
| 8301 | * correct kinematics of second chain |
| 8302 | CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2, |
| 8303 | & AMCH1,AMCH1N,AMCH2,IREJ1) |
| 8304 | IF (IREJ1.NE.0) GOTO 9999 |
| 8305 | * check now this chain for resonance mass |
| 8306 | IFP(1) = IDT_IPDG2B(IFPR2,1,2) |
| 8307 | IFP(2) = 0 |
| 8308 | IF (ABS(IFPR2).GE.1000) IFP(2) = IDT_IPDG2B(IFPR2,2,2) |
| 8309 | IFT(1) = IDT_IPDG2B(IFTA2,1,2) |
| 8310 | IFT(2) = 0 |
| 8311 | IF (ABS(IFTA2).GE.1000) IFT(2) = IDT_IPDG2B(IFTA2,2,2) |
| 8312 | IDCH2 = 2 |
| 8313 | IF ((IFP(2).EQ.0).AND.(IFT(2).EQ.0)) IDCH2 = 1 |
| 8314 | IF ((IFP(2).NE.0).AND.(IFT(2).NE.0)) IDCH2 = 3 |
| 8315 | CALL DT_CH2RES(IFP(1),IFP(2),IFT(1),IFT(2),IDR2,IDXR2, |
| 8316 | & AMCH2,AMCH2N,IDCH2,IREJ1) |
| 8317 | IF ((IREJ1.NE.0).OR.(IDR2.NE.0)) THEN |
| 8318 | IF (IOULEV(1).GT.0) |
| 8319 | & WRITE(LOUT,*) ' correction for resonance not poss.' |
| 8320 | **sr test |
| 8321 | C GOTO 1 |
| 8322 | C GOTO 9999 |
| 8323 | ** |
| 8324 | ENDIF |
| 8325 | * store final configuration for energy-momentum cons. check |
| 8326 | IF (LEMCCK) THEN |
| 8327 | CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IREJ1) |
| 8328 | CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1) |
| 8329 | IF (IREJ1.NE.0) GOTO 9999 |
| 8330 | ENDIF |
| 8331 | DO 5 J=1,4 |
| 8332 | PHKK(J,IMO11) = PP1(J) |
| 8333 | PHKK(J,IMO21) = PP2(J) |
| 8334 | PHKK(J,IMO12) = PT1(J) |
| 8335 | PHKK(J,IMO22) = PT2(J) |
| 8336 | 5 CONTINUE |
| 8337 | * correct entries of chains |
| 8338 | DO 3 K=1,4 |
| 8339 | PHKK(K,I) = PHKK(K,IMO11)+PHKK(K,IMO12) |
| 8340 | PHKK(K,IMMX) = PHKK(K,IMO21)+PHKK(K,IMO22) |
| 8341 | 3 CONTINUE |
| 8342 | AM1 = PHKK(4,I)**2-PHKK(1,I)**2-PHKK(2,I)**2-PHKK(3,I)**2 |
| 8343 | AM2 = PHKK(4,IMMX)**2-PHKK(1,IMMX)**2-PHKK(2,IMMX)**2- |
| 8344 | & PHKK(3,IMMX)**2 |
| 8345 | * ?? the following should now be obsolete |
| 8346 | **sr test |
| 8347 | C IF ((AM1.LT.0.0D0).OR.(AM2.LT.1.0D0)) THEN |
| 8348 | IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN |
| 8349 | ** |
| 8350 | WRITE(LOUT,'(1X,A,4G10.3)') |
| 8351 | & 'EVTRES: inonsistent mass-corr.',AM1,AM2 |
| 8352 | C GOTO 9999 |
| 8353 | GOTO 1 |
| 8354 | ENDIF |
| 8355 | PHKK(5,I) = SQRT(AM1) |
| 8356 | PHKK(5,IMMX) = SQRT(AM2) |
| 8357 | IDRES(I) = IDRES(I)/100 |
| 8358 | IF ((ABS(PHKK(5,I)-AMCH1N).GT.TINY5).OR. |
| 8359 | & (ABS(PHKK(5,IMMX)-AMCH2).GT.TINY5)) THEN |
| 8360 | WRITE(LOUT,'(1X,A,4G10.3)') |
| 8361 | & 'EVTRES: inconsistent chain-masses', |
| 8362 | & PHKK(5,I),AMCH1N,PHKK(5,IMMX),AMCH2 |
| 8363 | GOTO 9999 |
| 8364 | ENDIF |
| 8365 | ENDIF |
| 8366 | 1 CONTINUE |
| 8367 | 6 CONTINUE |
| 8368 | RETURN |
| 8369 | |
| 8370 | 9999 CONTINUE |
| 8371 | IREJ = 1 |
| 8372 | RETURN |
| 8373 | END |
| 8374 | * |
| 8375 | *===getspt=============================================================* |
| 8376 | * |
| 8377 | CDECK ID>, DT_GETSPT |
| 8378 | SUBROUTINE DT_GETSPT(PP1I,IFPR1,IFP1,PP2I,IFPR2,IFP2, |
| 8379 | & PT1I,IFTA1,IFT1,PT2I,IFTA2,IFT2, |
| 8380 | & AM1,IDCH1,AM2,IDCH2,IDCHAI,IREJ) |
| 8381 | |
| 8382 | ************************************************************************ |
| 8383 | * This version dated 12.12.94 is written by S. Roesler * |
| 8384 | ************************************************************************ |
| 8385 | |
| 8386 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 8387 | SAVE |
| 8388 | |
| 8389 | PARAMETER ( LINP = 5 , |
| 8390 | & LOUT = 6 , |
| 8391 | & LDAT = 9 ) |
| 8392 | |
| 8393 | PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,ZERO=0.0D0) |
| 8394 | |
| 8395 | * various options for treatment of partons (DTUNUC 1.x) |
| 8396 | * (chain recombination, Cronin,..) |
| 8397 | LOGICAL LCO2CR,LINTPT |
| 8398 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, |
| 8399 | & LCO2CR,LINTPT |
| 8400 | * flags for input different options |
| 8401 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 8402 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 8403 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 8404 | * flags for diffractive interactions (DTUNUC 1.x) |
| 8405 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF |
| 8406 | |
| 8407 | DIMENSION PP1(4),PP1I(4),PP2(4),PP2I(4),PT1(4),PT1I(4), |
| 8408 | & PT2(4),PT2I(4),P1(4),P2(4), |
| 8409 | & IFP1(2),IFP2(2),IFT1(2),IFT2(2), |
| 8410 | & PTOTI(4),PTOTF(4),DIFF(4) |
| 8411 | |
| 8412 | IC = 0 |
| 8413 | IREJ = 0 |
| 8414 | C B33P = 4.0D0 |
| 8415 | C B33T = 4.0D0 |
| 8416 | C IF ((IDCHAI.EQ.6).OR.(IDCHAI.EQ.7).OR.(IDCHAI.EQ.8)) B33P = 2.0D0 |
| 8417 | C IF ((IDCHAI.EQ.4).OR.(IDCHAI.EQ.5).OR.(IDCHAI.EQ.8)) B33T = 2.0D0 |
| 8418 | REDU = 1.0D0 |
| 8419 | C B33P = 3.5D0 |
| 8420 | C B33T = 3.5D0 |
| 8421 | B33P = 4.0D0 |
| 8422 | B33T = 4.0D0 |
| 8423 | IF (IDIFF.NE.0) THEN |
| 8424 | B33P = 16.0D0 |
| 8425 | B33T = 16.0D0 |
| 8426 | ENDIF |
| 8427 | |
| 8428 | DO 1 I=1,4 |
| 8429 | PTOTI(I) = PP1I(I)+PP2I(I)+PT1I(I)+PT2I(I) |
| 8430 | PP1(I) = PP1I(I) |
| 8431 | PP2(I) = PP2I(I) |
| 8432 | PT1(I) = PT1I(I) |
| 8433 | PT2(I) = PT2I(I) |
| 8434 | 1 CONTINUE |
| 8435 | * get initial chain masses |
| 8436 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 |
| 8437 | & +(PP1(3)+PT1(3))**2) |
| 8438 | ECH = PP1(4)+PT1(4) |
| 8439 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) |
| 8440 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 |
| 8441 | & +(PP2(3)+PT2(3))**2) |
| 8442 | ECH = PP2(4)+PT2(4) |
| 8443 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) |
| 8444 | IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN |
| 8445 | IF (IOULEV(1).GT.0) |
| 8446 | & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 1', |
| 8447 | & AM1,AM2 |
| 8448 | GOTO 9999 |
| 8449 | ENDIF |
| 8450 | AM1 = SQRT(AM1) |
| 8451 | AM2 = SQRT(AM2) |
| 8452 | AM1N = ZERO |
| 8453 | AM2N = ZERO |
| 8454 | |
| 8455 | MODE = 0 |
| 8456 | C IF ((AM1.GE.3.0D0).AND.(AM2.GE.3.0D0)) THEN |
| 8457 | C MODE = 0 |
| 8458 | C ELSE |
| 8459 | C MODE = 1 |
| 8460 | C IF (AM1.LT.0.6) THEN |
| 8461 | C B33P = 10.0D0 |
| 8462 | C ELSEIF ((AM1.GE.1.2).AND.(AM1.LT.3.0D0)) THEN |
| 8463 | CC B33P = 4.0D0 |
| 8464 | C ENDIF |
| 8465 | C IF (AM2.LT.0.6) THEN |
| 8466 | C B33T = 10.0D0 |
| 8467 | C ELSEIF ((AM2.GE.1.2).AND.(AM2.LT.3.0D0)) THEN |
| 8468 | CC B33T = 4.0D0 |
| 8469 | C ENDIF |
| 8470 | C ENDIF |
| 8471 | |
| 8472 | * check chain masses for very low mass chains |
| 8473 | C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM, |
| 8474 | C & AM1,DUM,-IDCH1,IREJ1) |
| 8475 | C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM, |
| 8476 | C & AM2,DUM,-IDCH2,IREJ2) |
| 8477 | C IF ((IREJ1.NE.0).OR.(IREJ2.NE.0)) THEN |
| 8478 | C B33P = 20.0D0 |
| 8479 | C B33T = 20.0D0 |
| 8480 | C ENDIF |
| 8481 | |
| 8482 | JMSHL = IMSHL |
| 8483 | |
| 8484 | 2 CONTINUE |
| 8485 | IC = IC+1 |
| 8486 | IF (MOD(IC,15).EQ.0) B33P = 2.0D0*B33P |
| 8487 | IF (MOD(IC,15).EQ.0) B33T = 2.0D0*B33T |
| 8488 | IF (MOD(IC,18).EQ.0) REDU = 0.0D0 |
| 8489 | C IF (MOD(IC,19).EQ.0) JMSHL = 0 |
| 8490 | IF (MOD(IC,20).EQ.0) GOTO 7 |
| 8491 | C WRITE(LOUT,'(1X,A)') 'GETSPT: rejection ' |
| 8492 | C RETURN |
| 8493 | C GOTO 9999 |
| 8494 | C ENDIF |
| 8495 | |
| 8496 | * get transverse momentum |
| 8497 | IF (LINTPT) THEN |
| 8498 | ES = -2.0D0/(B33P**2) |
| 8499 | & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10) |
| 8500 | HPSP = SQRT(ES*ES+2.0D0*ES*0.94D0) |
| 8501 | HPSP = HPSP*REDU |
| 8502 | ES = -2.0D0/(B33T**2) |
| 8503 | & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10) |
| 8504 | HPST = SQRT(ES*ES+2.0D0*ES*0.94D0) |
| 8505 | HPST = HPST*REDU |
| 8506 | ELSE |
| 8507 | HPSP = ZERO |
| 8508 | HPST = ZERO |
| 8509 | ENDIF |
| 8510 | CALL DT_DSFECF(SFE1,CFE1) |
| 8511 | CALL DT_DSFECF(SFE2,CFE2) |
| 8512 | IF (MODE.EQ.0) THEN |
| 8513 | PP1(1) = PP1I(1)+HPSP*CFE1 |
| 8514 | PP1(2) = PP1I(2)+HPSP*SFE1 |
| 8515 | PP2(1) = PP2I(1)-HPSP*CFE1 |
| 8516 | PP2(2) = PP2I(2)-HPSP*SFE1 |
| 8517 | PT1(1) = PT1I(1)+HPST*CFE2 |
| 8518 | PT1(2) = PT1I(2)+HPST*SFE2 |
| 8519 | PT2(1) = PT2I(1)-HPST*CFE2 |
| 8520 | PT2(2) = PT2I(2)-HPST*SFE2 |
| 8521 | ELSE |
| 8522 | PP1(1) = PP1I(1)+HPSP*CFE1 |
| 8523 | PP1(2) = PP1I(2)+HPSP*SFE1 |
| 8524 | PT1(1) = PT1I(1)-HPSP*CFE1 |
| 8525 | PT1(2) = PT1I(2)-HPSP*SFE1 |
| 8526 | PP2(1) = PP2I(1)+HPST*CFE2 |
| 8527 | PP2(2) = PP2I(2)+HPST*SFE2 |
| 8528 | PT2(1) = PT2I(1)-HPST*CFE2 |
| 8529 | PT2(2) = PT2I(2)-HPST*SFE2 |
| 8530 | ENDIF |
| 8531 | |
| 8532 | * put partons on mass shell |
| 8533 | XMP1 = 0.0D0 |
| 8534 | XMT1 = 0.0D0 |
| 8535 | IF (JMSHL.EQ.1) THEN |
| 8536 | |
| 8537 | XMP1 = PYMASS(IFPR1) |
| 8538 | XMT1 = PYMASS(IFTA1) |
| 8539 | |
| 8540 | ENDIF |
| 8541 | CALL DT_MASHEL(PP1,PT1,XMP1,XMT1,P1,P2,IREJ1) |
| 8542 | IF (IREJ1.NE.0) GOTO 2 |
| 8543 | DO 3 I=1,4 |
| 8544 | PTOTF(I) = P1(I)+P2(I) |
| 8545 | PP1(I) = P1(I) |
| 8546 | PT1(I) = P2(I) |
| 8547 | 3 CONTINUE |
| 8548 | XMP2 = 0.0D0 |
| 8549 | XMT2 = 0.0D0 |
| 8550 | IF (JMSHL.EQ.1) THEN |
| 8551 | |
| 8552 | XMP2 = PYMASS(IFPR2) |
| 8553 | XMT2 = PYMASS(IFTA2) |
| 8554 | |
| 8555 | ENDIF |
| 8556 | CALL DT_MASHEL(PP2,PT2,XMP2,XMT2,P1,P2,IREJ1) |
| 8557 | IF (IREJ1.NE.0) GOTO 2 |
| 8558 | DO 4 I=1,4 |
| 8559 | PTOTF(I) = PTOTF(I)+P1(I)+P2(I) |
| 8560 | PP2(I) = P1(I) |
| 8561 | PT2(I) = P2(I) |
| 8562 | 4 CONTINUE |
| 8563 | |
| 8564 | * check consistency |
| 8565 | DO 5 I=1,4 |
| 8566 | DIFF(I) = PTOTI(I)-PTOTF(I) |
| 8567 | 5 CONTINUE |
| 8568 | IF ((ABS(DIFF(1)).GT.TINY5).OR.(ABS(DIFF(2)).GT.TINY5).OR. |
| 8569 | & (ABS(DIFF(3)).GT.TINY5).OR.(ABS(DIFF(4)).GT.TINY5)) THEN |
| 8570 | WRITE(LOUT,'(1X,A,4G10.3)') 'GETSPT: inconsistencies ',DIFF |
| 8571 | GOTO 9999 |
| 8572 | ENDIF |
| 8573 | PTOTP1 = SQRT(PP1(1)**2+PP1(2)**2+PP1(3)**2) |
| 8574 | AMP1 = SQRT(ABS( (PP1(4)-PTOTP1)*(PP1(4)+PTOTP1) )) |
| 8575 | PTOTP2 = SQRT(PP2(1)**2+PP2(2)**2+PP2(3)**2) |
| 8576 | AMP2 = SQRT(ABS( (PP2(4)-PTOTP2)*(PP2(4)+PTOTP2) )) |
| 8577 | PTOTT1 = SQRT(PT1(1)**2+PT1(2)**2+PT1(3)**2) |
| 8578 | AMT1 = SQRT(ABS( (PT1(4)-PTOTT1)*(PT1(4)+PTOTT1) )) |
| 8579 | PTOTT2 = SQRT(PT2(1)**2+PT2(2)**2+PT2(3)**2) |
| 8580 | AMT2 = SQRT(ABS( (PT2(4)-PTOTT2)*(PT2(4)+PTOTT2) )) |
| 8581 | IF ((ABS(AMP1-XMP1).GT.TINY3).OR.(ABS(AMP2-XMP2).GT.TINY3).OR. |
| 8582 | & (ABS(AMT1-XMT1).GT.TINY3).OR.(ABS(AMT2-XMT2).GT.TINY3)) |
| 8583 | & THEN |
| 8584 | WRITE(LOUT,'(1X,A,2(4G10.3,/))') |
| 8585 | & 'GETSPT: inconsistent masses', |
| 8586 | & AMP1,XMP1,AMP2,XMP2,AMT1,XMT1,AMT2,XMT2 |
| 8587 | * sr 22.11.00: commented. It should only have inconsistent masses for |
| 8588 | * ultrahigh energies due to rounding problems |
| 8589 | C GOTO 9999 |
| 8590 | ENDIF |
| 8591 | |
| 8592 | * get chain masses |
| 8593 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 |
| 8594 | & +(PP1(3)+PT1(3))**2) |
| 8595 | ECH = PP1(4)+PT1(4) |
| 8596 | AM1N = (ECH+PTOCH)*(ECH-PTOCH) |
| 8597 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 |
| 8598 | & +(PP2(3)+PT2(3))**2) |
| 8599 | ECH = PP2(4)+PT2(4) |
| 8600 | AM2N = (ECH+PTOCH)*(ECH-PTOCH) |
| 8601 | IF ((AM1N.LT.0.0D0).OR.(AM2N.LT.0.0D0)) THEN |
| 8602 | IF (IOULEV(1).GT.0) |
| 8603 | & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 2', |
| 8604 | & AM1N,AM2N |
| 8605 | GOTO 2 |
| 8606 | ENDIF |
| 8607 | AM1N = SQRT(AM1N) |
| 8608 | AM2N = SQRT(AM2N) |
| 8609 | |
| 8610 | * check chain masses for very low mass chains |
| 8611 | CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM, |
| 8612 | & AM1N,DUM,-IDCH1,IREJ1) |
| 8613 | IF (IREJ1.NE.0) GOTO 2 |
| 8614 | CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM, |
| 8615 | & AM2N,DUM,-IDCH2,IREJ2) |
| 8616 | IF (IREJ2.NE.0) GOTO 2 |
| 8617 | |
| 8618 | 7 CONTINUE |
| 8619 | IF (AM1N.GT.ZERO) THEN |
| 8620 | AM1 = AM1N |
| 8621 | AM2 = AM2N |
| 8622 | ENDIF |
| 8623 | DO 6 I=1,4 |
| 8624 | PP1I(I) = PP1(I) |
| 8625 | PP2I(I) = PP2(I) |
| 8626 | PT1I(I) = PT1(I) |
| 8627 | PT2I(I) = PT2(I) |
| 8628 | 6 CONTINUE |
| 8629 | |
| 8630 | RETURN |
| 8631 | |
| 8632 | 9999 CONTINUE |
| 8633 | IREJ = 1 |
| 8634 | RETURN |
| 8635 | END |
| 8636 | * |
| 8637 | *===saptre=============================================================* |
| 8638 | * |
| 8639 | CDECK ID>, DT_SAPTRE |
| 8640 | SUBROUTINE DT_SAPTRE(IDX1,IDX2) |
| 8641 | |
| 8642 | ************************************************************************ |
| 8643 | * p-t sampling for two-resonance systems. ("BAMJET-like" method) * |
| 8644 | * IDX1,IDX2 indices of resonances ("chains") in DTEVT1 * |
| 8645 | * Adopted from the original SAPTRE written by J. Ranft. * |
| 8646 | * This version dated 18.01.95 is written by S. Roesler * |
| 8647 | ************************************************************************ |
| 8648 | |
| 8649 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 8650 | SAVE |
| 8651 | |
| 8652 | PARAMETER ( LINP = 5 , |
| 8653 | & LOUT = 6 , |
| 8654 | & LDAT = 9 ) |
| 8655 | |
| 8656 | PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3) |
| 8657 | |
| 8658 | * event history |
| 8659 | |
| 8660 | PARAMETER (NMXHKK=200000) |
| 8661 | |
| 8662 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 8663 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 8664 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 8665 | * extended event history |
| 8666 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 8667 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 8668 | & IHIST(2,NMXHKK) |
| 8669 | * flags for input different options |
| 8670 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 8671 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 8672 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 8673 | |
| 8674 | DIMENSION PA1(4),PA2(4),P1(4),P2(4) |
| 8675 | |
| 8676 | DATA B3 /4.0D0/ |
| 8677 | |
| 8678 | ESMAX1 = PHKK(4,IDX1)-PHKK(5,IDX1) |
| 8679 | ESMAX2 = PHKK(4,IDX2)-PHKK(5,IDX2) |
| 8680 | ESMAX = MIN(ESMAX1,ESMAX2) |
| 8681 | IF (ESMAX.LE.0.05D0) RETURN |
| 8682 | |
| 8683 | HMA = PHKK(5,IDX1) |
| 8684 | DO 1 K=1,4 |
| 8685 | PA1(K) = PHKK(K,IDX1) |
| 8686 | PA2(K) = PHKK(K,IDX2) |
| 8687 | 1 CONTINUE |
| 8688 | |
| 8689 | IF (LEMCCK) THEN |
| 8690 | CALL DT_EVTEMC(PA1(1),PA1(2),PA1(3),PA1(4),1,IDUM,IDUM) |
| 8691 | CALL DT_EVTEMC(PA2(1),PA2(2),PA2(3),PA2(4),2,IDUM,IDUM) |
| 8692 | ENDIF |
| 8693 | |
| 8694 | EXEB = 0.0D0 |
| 8695 | IF (B3*ESMAX.LE.60.0D0) EXEB = EXP(-B3*ESMAX) |
| 8696 | BEXP = HMA*(1.0D0-EXEB)/B3 |
| 8697 | AXEXP = (1.0D0-(B3*ESMAX-1.0D0)*EXEB)/B3**2 |
| 8698 | WA = AXEXP/(BEXP+AXEXP) |
| 8699 | XAB = DT_RNDM(WA) |
| 8700 | 10 CONTINUE |
| 8701 | * ES is the transverse kinetic energy |
| 8702 | IF (XAB.LT.WA)THEN |
| 8703 | X = DT_RNDM(WA) |
| 8704 | Y = DT_RNDM(WA) |
| 8705 | ES = -2.0D0/(B3**2)*LOG(X*Y+TINY7) |
| 8706 | ELSE |
| 8707 | X = DT_RNDM(Y) |
| 8708 | ES = ABS(-LOG(X+TINY7)/B3) |
| 8709 | ENDIF |
| 8710 | IF (ES.GT.ESMAX) GOTO 10 |
| 8711 | ES = ES+HMA |
| 8712 | * transverse momentum |
| 8713 | HPS = SQRT((ES-HMA)*(ES+HMA)) |
| 8714 | |
| 8715 | CALL DT_DSFECF(SFE,CFE) |
| 8716 | HPX = HPS*CFE |
| 8717 | HPY = HPS*SFE |
| 8718 | PZ1NSQ = PA1(3)**2-HPS**2-2.0D0*PA1(1)*HPX-2.0D0*PA1(2)*HPY |
| 8719 | PZ2NSQ = PA2(3)**2-HPS**2+2.0D0*PA2(1)*HPX+2.0D0*PA2(2)*HPY |
| 8720 | IF ((PZ1NSQ.LT.TINY3).OR.(PZ2NSQ.LT.TINY3)) RETURN |
| 8721 | |
| 8722 | C PA1(3) = SIGN(SQRT(PZ1NSQ),PA1(3)) |
| 8723 | C PA2(3) = SIGN(SQRT(PZ2NSQ),PA2(3)) |
| 8724 | PA1(1) = PA1(1)+HPX |
| 8725 | PA1(2) = PA1(2)+HPY |
| 8726 | PA2(1) = PA2(1)-HPX |
| 8727 | PA2(2) = PA2(2)-HPY |
| 8728 | |
| 8729 | * put resonances on mass-shell again |
| 8730 | XM1 = PHKK(5,IDX1) |
| 8731 | XM2 = PHKK(5,IDX2) |
| 8732 | CALL DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ1) |
| 8733 | IF (IREJ1.NE.0) RETURN |
| 8734 | |
| 8735 | IF (LEMCCK) THEN |
| 8736 | CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,IDUM,IDUM) |
| 8737 | CALL DT_EVTEMC(-P2(1),-P2(2),-P2(3),-P2(4),2,IDUM,IDUM) |
| 8738 | CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,12,IREJ1) |
| 8739 | IF (IREJ1.NE.0) RETURN |
| 8740 | ENDIF |
| 8741 | |
| 8742 | DO 2 K=1,4 |
| 8743 | PHKK(K,IDX1) = P1(K) |
| 8744 | PHKK(K,IDX2) = P2(K) |
| 8745 | 2 CONTINUE |
| 8746 | |
| 8747 | RETURN |
| 8748 | END |
| 8749 | * |
| 8750 | *===cronin=============================================================* |
| 8751 | * |
| 8752 | CDECK ID>, DT_CRONIN |
| 8753 | SUBROUTINE DT_CRONIN(INCL) |
| 8754 | |
| 8755 | ************************************************************************ |
| 8756 | * Cronin-Effect. Multiple scattering of partons at chain ends. * |
| 8757 | * INCL = 1 multiple sc. in projectile * |
| 8758 | * = 2 multiple sc. in target * |
| 8759 | * This version dated 05.01.96 is written by S. Roesler. * |
| 8760 | ************************************************************************ |
| 8761 | |
| 8762 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 8763 | SAVE |
| 8764 | |
| 8765 | PARAMETER ( LINP = 5 , |
| 8766 | & LOUT = 6 , |
| 8767 | & LDAT = 9 ) |
| 8768 | |
| 8769 | PARAMETER (ZERO=0.0D0,TINY3=1.0D-3) |
| 8770 | |
| 8771 | * event history |
| 8772 | |
| 8773 | PARAMETER (NMXHKK=200000) |
| 8774 | |
| 8775 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 8776 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 8777 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 8778 | * extended event history |
| 8779 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 8780 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 8781 | & IHIST(2,NMXHKK) |
| 8782 | * rejection counter |
| 8783 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, |
| 8784 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, |
| 8785 | & IREXCI(3),IRDIFF(2),IRINC |
| 8786 | * Glauber formalism: collision properties |
| 8787 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, |
| 8788 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC |
| 8789 | |
| 8790 | DIMENSION R(3),PIN(4),POUT(4),DEV(4) |
| 8791 | |
| 8792 | DO 1 K=1,4 |
| 8793 | DEV(K) = ZERO |
| 8794 | 1 CONTINUE |
| 8795 | |
| 8796 | DO 2 I=NPOINT(2),NHKK |
| 8797 | IF (ISTHKK(I).LT.0) THEN |
| 8798 | * get z-position of the chain |
| 8799 | R(1) = VHKK(1,I)*1.0D12 |
| 8800 | IF (INCL.EQ.2) R(1) = VHKK(1,I)*1.0D12-BIMPAC |
| 8801 | R(2) = VHKK(2,I)*1.0D12 |
| 8802 | IDXNU = JMOHKK(1,I) |
| 8803 | IF ( (INCL.EQ.1).AND.(ISTHKK(IDXNU).EQ.10) ) |
| 8804 | & IDXNU = JMOHKK(1,I-1) |
| 8805 | IF ( (INCL.EQ.2).AND.(ISTHKK(IDXNU).EQ. 9) ) |
| 8806 | & IDXNU = JMOHKK(1,I+1) |
| 8807 | R(3) = VHKK(3,IDXNU)*1.0D12 |
| 8808 | * position of target parton the chain is connected to |
| 8809 | DO 3 K=1,4 |
| 8810 | PIN(K) = PHKK(K,I) |
| 8811 | 3 CONTINUE |
| 8812 | * multiple scattering of parton with DTEVT1-index I |
| 8813 | CALL DT_CROMSC(PIN,R,POUT,INCL) |
| 8814 | **testprint |
| 8815 | C IF (NEVHKK.EQ.5) THEN |
| 8816 | C AMIN = PIN(4)**2-PIN(1)**2-PIN(2)**2-PIN(3)**2 |
| 8817 | C AMOU = POUT(4)**2-POUT(1)**2-POUT(2)**2-POUT(3)**2 |
| 8818 | C AMIN = SIGN(SQRT(ABS(AMIN)),AMIN) |
| 8819 | C AMOU = SIGN(SQRT(ABS(AMOU)),AMOU) |
| 8820 | C WRITE(6,'(A,I4,2E15.5)')'I,AMIN,AMOU: ',I,AMIN,AMOU |
| 8821 | C WRITE(6,'(A,4E15.5)')'PIN: ',PIN |
| 8822 | C WRITE(6,'(A,4E15.5)')'POUT: ',POUT |
| 8823 | C ENDIF |
| 8824 | ** |
| 8825 | * increase accumulator by energy-momentum difference |
| 8826 | DO 4 K=1,4 |
| 8827 | DEV(K) = DEV(K)+POUT(K)-PIN(K) |
| 8828 | PHKK(K,I) = POUT(K) |
| 8829 | 4 CONTINUE |
| 8830 | PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2- |
| 8831 | & PHKK(2,I)**2-PHKK(3,I)**2)) |
| 8832 | ENDIF |
| 8833 | 2 CONTINUE |
| 8834 | |
| 8835 | * dump accumulator to momenta of valence partons |
| 8836 | NVAL = 0 |
| 8837 | ETOT = 0.0D0 |
| 8838 | DO 5 I=NPOINT(2),NHKK |
| 8839 | IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN |
| 8840 | NVAL = NVAL+1 |
| 8841 | ETOT = ETOT+PHKK(4,I) |
| 8842 | ENDIF |
| 8843 | 5 CONTINUE |
| 8844 | C WRITE(LOUT,1000) NVAL,(DEV(K)/DBLE(NVAL),K=1,4) |
| 8845 | 1000 FORMAT(1X,'CRONIN : number of val. partons ',I4,/, |
| 8846 | & 9X,4E12.4) |
| 8847 | DO 6 I=NPOINT(2),NHKK |
| 8848 | IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN |
| 8849 | E = PHKK(4,I) |
| 8850 | DO 7 K=1,4 |
| 8851 | C PHKK(K,I) = PHKK(K,I)-DEV(K)/DBLE(NVAL) |
| 8852 | PHKK(K,I) = PHKK(K,I)-DEV(K)*E/ETOT |
| 8853 | 7 CONTINUE |
| 8854 | PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2- |
| 8855 | & PHKK(2,I)**2-PHKK(3,I)**2)) |
| 8856 | ENDIF |
| 8857 | 6 CONTINUE |
| 8858 | |
| 8859 | RETURN |
| 8860 | END |
| 8861 | * |
| 8862 | *===cromsc=============================================================* |
| 8863 | * |
| 8864 | CDECK ID>, DT_CROMSC |
| 8865 | SUBROUTINE DT_CROMSC(PIN,R,POUT,INCL) |
| 8866 | |
| 8867 | ************************************************************************ |
| 8868 | * Cronin-Effect. Multiple scattering of one parton passing through * |
| 8869 | * nuclear matter. * |
| 8870 | * PIN(4) input 4-momentum of parton * |
| 8871 | * POUT(4) 4-momentum of parton after mult. scatt. * |
| 8872 | * R(3) spatial position of parton in target nucleus * |
| 8873 | * INCL = 1 multiple sc. in projectile * |
| 8874 | * = 2 multiple sc. in target * |
| 8875 | * This is a revised version of the original version written by J. Ranft* |
| 8876 | * This version dated 17.01.95 is written by S. Roesler. * |
| 8877 | ************************************************************************ |
| 8878 | |
| 8879 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 8880 | SAVE |
| 8881 | |
| 8882 | PARAMETER ( LINP = 5 , |
| 8883 | & LOUT = 6 , |
| 8884 | & LDAT = 9 ) |
| 8885 | |
| 8886 | PARAMETER (ZERO=0.0D0,TINY3=1.0D-3) |
| 8887 | |
| 8888 | LOGICAL LSTART |
| 8889 | |
| 8890 | * rejection counter |
| 8891 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, |
| 8892 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, |
| 8893 | & IREXCI(3),IRDIFF(2),IRINC |
| 8894 | * Glauber formalism: collision properties |
| 8895 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, |
| 8896 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC |
| 8897 | * various options for treatment of partons (DTUNUC 1.x) |
| 8898 | * (chain recombination, Cronin,..) |
| 8899 | LOGICAL LCO2CR,LINTPT |
| 8900 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, |
| 8901 | & LCO2CR,LINTPT |
| 8902 | |
| 8903 | DIMENSION PIN(4),POUT(4),R(3) |
| 8904 | |
| 8905 | DATA LSTART /.TRUE./ |
| 8906 | |
| 8907 | IRCRON(1) = IRCRON(1)+1 |
| 8908 | |
| 8909 | IF (LSTART) THEN |
| 8910 | WRITE(LOUT,1000) CRONCO |
| 8911 | 1000 FORMAT(/,1X,'CROMSC: multiple scattering of chain ends', |
| 8912 | & ' treated',/,10X,'with parameter CRONCO = ',F5.2) |
| 8913 | LSTART = .FALSE. |
| 8914 | ENDIF |
| 8915 | |
| 8916 | NCBACK = 0 |
| 8917 | RNCL = RPROJ |
| 8918 | IF (INCL.EQ.2) RNCL = RTARG |
| 8919 | |
| 8920 | * Lorentz-transformation into Lab. |
| 8921 | MODE = -(INCL+1) |
| 8922 | CALL DT_LTNUC(PIN(3),PIN(4),PZ,PE,MODE) |
| 8923 | |
| 8924 | PTOT = SQRT(PIN(1)**2+PIN(2)**2+PZ**2) |
| 8925 | IF (PTOT.LE.8.0D0) GOTO 9997 |
| 8926 | |
| 8927 | * direction cosines of parton before mult. scattering |
| 8928 | COSX = PIN(1)/PTOT |
| 8929 | COSY = PIN(2)/PTOT |
| 8930 | COSZ = PZ/PTOT |
| 8931 | |
| 8932 | RTESQ = R(1)**2+R(2)**2+R(3)**2-RNCL**2 |
| 8933 | IF (RTESQ.GE.-TINY3) GOTO 9999 |
| 8934 | |
| 8935 | * calculate distance (DIST) from R to surface of nucleus (radius RNCL) |
| 8936 | * in the direction of particle motion |
| 8937 | |
| 8938 | A = COSX*R(1)+COSY*R(2)+COSZ*R(3) |
| 8939 | TMP = A**2-RTESQ |
| 8940 | IF (TMP.LT.ZERO) GOTO 9998 |
| 8941 | DIST = -A+SQRT(TMP) |
| 8942 | |
| 8943 | * multiple scattering angle |
| 8944 | THETO = CRONCO*SQRT(DIST)/PTOT |
| 8945 | IF (THETO.GT.0.1D0) THETO=0.1D0 |
| 8946 | |
| 8947 | 1 CONTINUE |
| 8948 | * Gaussian sampling of spatial angle |
| 8949 | CALL DT_RANNOR(R1,R2) |
| 8950 | THETA = ABS(R1*THETO) |
| 8951 | IF (THETA.GT.0.3D0) GOTO 9997 |
| 8952 | CALL DT_DSFECF(SFE,CFE) |
| 8953 | COSTH = COS(THETA) |
| 8954 | SINTH = SIN(THETA) |
| 8955 | |
| 8956 | * new direction cosines |
| 8957 | CALL DT_MYTRAN(1,COSX,COSY,COSZ,COSTH,SINTH,SFE,CFE, |
| 8958 | & COSXN,COSYN,COSZN) |
| 8959 | |
| 8960 | POUT(1) = COSXN*PTOT |
| 8961 | POUT(2) = COSYN*PTOT |
| 8962 | PZ = COSZN*PTOT |
| 8963 | * Lorentz-transformation into nucl.-nucl. cms |
| 8964 | MODE = INCL+1 |
| 8965 | CALL DT_LTNUC(PZ,PE,POUT(3),POUT(4),MODE) |
| 8966 | |
| 8967 | C IF (ABS(PIN(4)-POUT(4)).GT.0.2D0) THEN |
| 8968 | C IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.1D0 ) THEN |
| 8969 | IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.05D0 ) THEN |
| 8970 | THETO = THETO/2.0D0 |
| 8971 | NCBACK = NCBACK+1 |
| 8972 | IF (MOD(NCBACK,200).EQ.0) THEN |
| 8973 | WRITE(LOUT,1001) THETO,PIN,POUT |
| 8974 | 1001 FORMAT(1X,'CROMSC: inconsistent scattering angle ', |
| 8975 | & E12.4,/,1X,' PIN :',4E12.4,/, |
| 8976 | & 1X,' POUT:',4E12.4) |
| 8977 | GOTO 9997 |
| 8978 | ENDIF |
| 8979 | GOTO 1 |
| 8980 | ENDIF |
| 8981 | |
| 8982 | RETURN |
| 8983 | |
| 8984 | 9997 IRCRON(2) = IRCRON(2)+1 |
| 8985 | GOTO 9999 |
| 8986 | 9998 IRCRON(3) = IRCRON(3)+1 |
| 8987 | |
| 8988 | 9999 CONTINUE |
| 8989 | DO 100 K=1,4 |
| 8990 | POUT(K) = PIN(K) |
| 8991 | 100 CONTINUE |
| 8992 | RETURN |
| 8993 | END |
| 8994 | * |
| 8995 | *===com2sr=============================================================* |
| 8996 | * |
| 8997 | CDECK ID>, DT_COM2CR |
| 8998 | SUBROUTINE DT_COM2CR |
| 8999 | |
| 9000 | ************************************************************************ |
| 9001 | * COMbine q-aq chains to Color Ropes (qq-aqaq). * |
| 9002 | * CUTOF parameter determining minimum number of not * |
| 9003 | * combined q-aq chains * |
| 9004 | * This subroutine replaces KKEVCC etc. * |
| 9005 | * This version dated 11.01.95 is written by S. Roesler. * |
| 9006 | ************************************************************************ |
| 9007 | |
| 9008 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 9009 | SAVE |
| 9010 | |
| 9011 | PARAMETER ( LINP = 5 , |
| 9012 | & LOUT = 6 , |
| 9013 | & LDAT = 9 ) |
| 9014 | |
| 9015 | * event history |
| 9016 | |
| 9017 | PARAMETER (NMXHKK=200000) |
| 9018 | |
| 9019 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 9020 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 9021 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 9022 | * extended event history |
| 9023 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 9024 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 9025 | & IHIST(2,NMXHKK) |
| 9026 | * statistics |
| 9027 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, |
| 9028 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), |
| 9029 | & ICEVTG(8,0:30) |
| 9030 | * various options for treatment of partons (DTUNUC 1.x) |
| 9031 | * (chain recombination, Cronin,..) |
| 9032 | LOGICAL LCO2CR,LINTPT |
| 9033 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, |
| 9034 | & LCO2CR,LINTPT |
| 9035 | |
| 9036 | DIMENSION IDXQA(248),IDXAQ(248) |
| 9037 | |
| 9038 | ICCHAI(1,9) = ICCHAI(1,9)+1 |
| 9039 | NQA = 0 |
| 9040 | NAQ = 0 |
| 9041 | * scan DTEVT1 for q-aq, aq-q chains |
| 9042 | DO 10 I=NPOINT(3),NHKK |
| 9043 | * skip "chains" which are resonances |
| 9044 | IF ((IDHKK(I).EQ.88888).AND.(IDRES(I).EQ.0)) THEN |
| 9045 | MO1 = JMOHKK(1,I) |
| 9046 | MO2 = JMOHKK(2,I) |
| 9047 | IF ((ABS(IDHKK(MO1)).LE.6).AND.(ABS(IDHKK(MO2)).LE.6)) THEN |
| 9048 | * q-aq, aq-q chain found, keep index |
| 9049 | IF (IDHKK(MO1).GT.0) THEN |
| 9050 | NQA = NQA+1 |
| 9051 | IDXQA(NQA) = I |
| 9052 | ELSE |
| 9053 | NAQ = NAQ+1 |
| 9054 | IDXAQ(NAQ) = I |
| 9055 | ENDIF |
| 9056 | ENDIF |
| 9057 | ENDIF |
| 9058 | 10 CONTINUE |
| 9059 | |
| 9060 | * minimum number of q-aq chains requested for the same projectile/ |
| 9061 | * target |
| 9062 | NCHMIN = IDT_NPOISS(CUTOF) |
| 9063 | |
| 9064 | * combine q-aq chains of the same projectile |
| 9065 | CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,1) |
| 9066 | * combine q-aq chains of the same target |
| 9067 | CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,2) |
| 9068 | * combine aq-q chains of the same projectile |
| 9069 | CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,1) |
| 9070 | * combine aq-q chains of the same target |
| 9071 | CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,2) |
| 9072 | |
| 9073 | RETURN |
| 9074 | END |
| 9075 | * |
| 9076 | *===scn4cr=============================================================* |
| 9077 | * |
| 9078 | CDECK ID>, DT_SCN4CR |
| 9079 | SUBROUTINE DT_SCN4CR(NCH,IDXCH,NCHMIN,MODE) |
| 9080 | |
| 9081 | ************************************************************************ |
| 9082 | * SCan q-aq chains for Color Ropes. * |
| 9083 | * This version dated 11.01.95 is written by S. Roesler. * |
| 9084 | ************************************************************************ |
| 9085 | |
| 9086 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 9087 | SAVE |
| 9088 | |
| 9089 | PARAMETER ( LINP = 5 , |
| 9090 | & LOUT = 6 , |
| 9091 | & LDAT = 9 ) |
| 9092 | |
| 9093 | * event history |
| 9094 | |
| 9095 | PARAMETER (NMXHKK=200000) |
| 9096 | |
| 9097 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 9098 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 9099 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 9100 | * extended event history |
| 9101 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 9102 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 9103 | & IHIST(2,NMXHKK) |
| 9104 | |
| 9105 | DIMENSION IDXCH(248),IDXJN(248) |
| 9106 | |
| 9107 | DO 1 I=1,NCH |
| 9108 | IF (IDXCH(I).GT.0) THEN |
| 9109 | NJOIN = 1 |
| 9110 | IDXMO = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(I)))) |
| 9111 | IDXJN(NJOIN) = I |
| 9112 | IF (I.LT.NCH) THEN |
| 9113 | DO 2 J=I+1,NCH |
| 9114 | IF (IDXCH(J).GT.0) THEN |
| 9115 | IDXMO1 = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(J)))) |
| 9116 | IF (IDXMO.EQ.IDXMO1) THEN |
| 9117 | NJOIN = NJOIN+1 |
| 9118 | IDXJN(NJOIN) = J |
| 9119 | ENDIF |
| 9120 | ENDIF |
| 9121 | 2 CONTINUE |
| 9122 | ENDIF |
| 9123 | IF (NJOIN.GE.NCHMIN+2) THEN |
| 9124 | NJ = INT(DBLE(NJOIN-NCHMIN)/2.0D0) |
| 9125 | DO 3 J=1,2*NJ,2 |
| 9126 | CALL DT_JOIN(IDXCH(IDXJN(J)),IDXCH(IDXJN(J+1)),IREJ1) |
| 9127 | IF (IREJ1.NE.0) GOTO 3 |
| 9128 | IDXCH(IDXJN(J)) = 0 |
| 9129 | IDXCH(IDXJN(J+1)) = 0 |
| 9130 | 3 CONTINUE |
| 9131 | ENDIF |
| 9132 | ENDIF |
| 9133 | 1 CONTINUE |
| 9134 | |
| 9135 | RETURN |
| 9136 | END |
| 9137 | * |
| 9138 | *===join===============================================================* |
| 9139 | * |
| 9140 | CDECK ID>, DT_JOIN |
| 9141 | SUBROUTINE DT_JOIN(IDX1,IDX2,IREJ) |
| 9142 | |
| 9143 | ************************************************************************ |
| 9144 | * This subroutine joins two q-aq chains to one qq-aqaq chain. * |
| 9145 | * IDX1, IDX2 DTEVT1 indices of chains to be joined * |
| 9146 | * This version dated 11.01.95 is written by S. Roesler. * |
| 9147 | ************************************************************************ |
| 9148 | |
| 9149 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 9150 | SAVE |
| 9151 | |
| 9152 | PARAMETER ( LINP = 5 , |
| 9153 | & LOUT = 6 , |
| 9154 | & LDAT = 9 ) |
| 9155 | |
| 9156 | * event history |
| 9157 | |
| 9158 | PARAMETER (NMXHKK=200000) |
| 9159 | |
| 9160 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 9161 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 9162 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 9163 | * extended event history |
| 9164 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 9165 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 9166 | & IHIST(2,NMXHKK) |
| 9167 | * flags for input different options |
| 9168 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 9169 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 9170 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 9171 | * statistics |
| 9172 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, |
| 9173 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), |
| 9174 | & ICEVTG(8,0:30) |
| 9175 | |
| 9176 | DIMENSION MO(2,2),ID(2,2),IDX(2),PCH(4),PP(4),PT(4),P1(4),P2(4) |
| 9177 | |
| 9178 | IREJ = 0 |
| 9179 | |
| 9180 | IDX(1) = IDX1 |
| 9181 | IDX(2) = IDX2 |
| 9182 | DO 1 I=1,2 |
| 9183 | DO 2 J=1,2 |
| 9184 | MO(I,J) = JMOHKK(J,IDX(I)) |
| 9185 | ID(I,J) = IDT_IPDG2B(IDHKK(MO(I,J)),1,2) |
| 9186 | 2 CONTINUE |
| 9187 | 1 CONTINUE |
| 9188 | |
| 9189 | * check consistency |
| 9190 | IF ((ABS(ID(1,1)).GT.6).OR.(ABS(ID(1,2)).GT.6).OR. |
| 9191 | & (ABS(ID(2,1)).GT.6).OR.(ABS(ID(2,2)).GT.6).OR. |
| 9192 | & ((ID(1,1)*ID(2,1)).LT.0).OR. |
| 9193 | & ((ID(1,2)*ID(2,2)).LT.0)) THEN |
| 9194 | WRITE(LOUT,1000) IDX(1),MO(1,1),MO(1,2),IDX(2),MO(2,1), |
| 9195 | & MO(2,2) |
| 9196 | 1000 FORMAT(1X,'JOIN: incons. chain system! chain ',I4,':', |
| 9197 | & 2I5,' chain ',I4,':',2I5) |
| 9198 | ENDIF |
| 9199 | |
| 9200 | * join chains |
| 9201 | DO 3 K=1,4 |
| 9202 | PP(K) = PHKK(K,MO(1,1))+PHKK(K,MO(2,1)) |
| 9203 | PT(K) = PHKK(K,MO(1,2))+PHKK(K,MO(2,2)) |
| 9204 | 3 CONTINUE |
| 9205 | IF1 = IDT_IB2PDG(ID(1,1),ID(2,1),2) |
| 9206 | IF2 = IDT_IB2PDG(ID(1,2),ID(2,2),2) |
| 9207 | IST1 = ISTHKK(MO(1,1)) |
| 9208 | IST2 = ISTHKK(MO(1,2)) |
| 9209 | |
| 9210 | * put partons again on mass shell |
| 9211 | XM1 = 0.0D0 |
| 9212 | XM2 = 0.0D0 |
| 9213 | IF (IMSHL.EQ.1) THEN |
| 9214 | |
| 9215 | XM1 = PYMASS(IF1) |
| 9216 | XM2 = PYMASS(IF2) |
| 9217 | |
| 9218 | ENDIF |
| 9219 | CALL DT_MASHEL(PP,PT,XM1,XM2,P1,P2,IREJ1) |
| 9220 | IF (IREJ1.NE.0) GOTO 9999 |
| 9221 | DO 4 I=1,4 |
| 9222 | PP(I) = P1(I) |
| 9223 | PT(I) = P2(I) |
| 9224 | 4 CONTINUE |
| 9225 | |
| 9226 | * store new partons in DTEVT1 |
| 9227 | CALL DT_EVTPUT(IST1,IF1,MO(1,1),MO(2,1),PP(1),PP(2),PP(3),PP(4), |
| 9228 | & 0,0,0) |
| 9229 | CALL DT_EVTPUT(IST2,IF2,MO(1,2),MO(2,2),PT(1),PT(2),PT(3),PT(4), |
| 9230 | & 0,0,0) |
| 9231 | DO 5 K=1,4 |
| 9232 | PCH(K) = PP(K)+PT(K) |
| 9233 | 5 CONTINUE |
| 9234 | |
| 9235 | * check new chain for lower mass limit |
| 9236 | IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN |
| 9237 | AMCH = SQRT(ABS(PCH(4)**2-PCH(1)**2-PCH(2)**2-PCH(3)**2)) |
| 9238 | CALL DT_CH2RES(ID(1,1),ID(2,1),ID(1,2),ID(2,2),IDUM,IDUM, |
| 9239 | & AMCH,AMCHN,3,IREJ1) |
| 9240 | IF (IREJ1.NE.0) THEN |
| 9241 | NHKK = NHKK-2 |
| 9242 | GOTO 9999 |
| 9243 | ENDIF |
| 9244 | ENDIF |
| 9245 | |
| 9246 | ICCHAI(2,9) = ICCHAI(2,9)+1 |
| 9247 | * store new chain in DTEVT1 |
| 9248 | KCH = 191 |
| 9249 | CALL DT_EVTPUT(KCH,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),0,0,9) |
| 9250 | IDHKK(IDX(1)) = 22222 |
| 9251 | IDHKK(IDX(2)) = 22222 |
| 9252 | * special treatment for space-time coordinates |
| 9253 | DO 6 K=1,4 |
| 9254 | VHKK(K,NHKK) = (VHKK(K,IDX(1))+VHKK(K,IDX(2)))/2.0D0 |
| 9255 | WHKK(K,NHKK) = (WHKK(K,IDX(1))+WHKK(K,IDX(2)))/2.0D0 |
| 9256 | 6 CONTINUE |
| 9257 | RETURN |
| 9258 | |
| 9259 | 9999 CONTINUE |
| 9260 | IREJ = 1 |
| 9261 | RETURN |
| 9262 | END |
| 9263 | * |
| 9264 | *===xsglau=============================================================* |
| 9265 | * |
| 9266 | CDECK ID>, DT_XSGLAU |
| 9267 | SUBROUTINE DT_XSGLAU(NA,NB,JJPROJ,XI,Q2I,ECMI,IE,IQ,NIDX) |
| 9268 | |
| 9269 | ************************************************************************ |
| 9270 | * Total, elastic, quasi-elastic, inelastic cross sections according to * |
| 9271 | * Glauber's approach. * |
| 9272 | * NA / NB mass numbers of proj./target nuclei * |
| 9273 | * JJPROJ bamjet-index of projectile (=1 in case of proj.nucleus) * |
| 9274 | * XI,Q2I,ECMI kinematical variables x, Q^2, E_cm * |
| 9275 | * IE,IQ indices of energy and virtuality (the latter for gamma * |
| 9276 | * projectiles only) * |
| 9277 | * NIDX index of projectile/target nucleus * |
| 9278 | * This version dated 17.3.98 is written by S. Roesler * |
| 9279 | ************************************************************************ |
| 9280 | |
| 9281 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 9282 | SAVE |
| 9283 | |
| 9284 | PARAMETER ( LINP = 5 , |
| 9285 | & LOUT = 6 , |
| 9286 | & LDAT = 9 ) |
| 9287 | |
| 9288 | COMPLEX*16 CZERO,CONE,CTWO |
| 9289 | CHARACTER*12 CFILE |
| 9290 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0, |
| 9291 | & ONETHI=ONE/THREE,TINY25=1.0D-25) |
| 9292 | PARAMETER (TWOPI = 6.283185307179586454D+00, |
| 9293 | & PI = TWOPI/TWO, |
| 9294 | & GEV2MB = 0.38938D0, |
| 9295 | & GEV2FM = 0.1972D0, |
| 9296 | & ALPHEM = ONE/137.0D0, |
| 9297 | * proton mass |
| 9298 | & AMP = 0.938D0, |
| 9299 | & AMP2 = AMP**2, |
| 9300 | * approx. nucleon radius |
| 9301 | & RNUCLE = 1.12D0) |
| 9302 | |
| 9303 | * particle properties (BAMJET index convention) |
| 9304 | CHARACTER*8 ANAME |
| 9305 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 9306 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 9307 | |
| 9308 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 9309 | |
| 9310 | PARAMETER ( MAXNCL = 260, |
| 9311 | |
| 9312 | & MAXVQU = MAXNCL, |
| 9313 | & MAXSQU = 20*MAXVQU, |
| 9314 | & MAXINT = MAXVQU+MAXSQU) |
| 9315 | * Glauber formalism: parameters |
| 9316 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), |
| 9317 | & BMAX(NCOMPX),BSTEP(NCOMPX), |
| 9318 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), |
| 9319 | & NSITEB,NSTATB |
| 9320 | * Glauber formalism: cross sections |
| 9321 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, |
| 9322 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), |
| 9323 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), |
| 9324 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), |
| 9325 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), |
| 9326 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), |
| 9327 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), |
| 9328 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), |
| 9329 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), |
| 9330 | & BSLOPE,NEBINI,NQBINI |
| 9331 | * Glauber formalism: flags and parameters for statistics |
| 9332 | LOGICAL LPROD |
| 9333 | CHARACTER*8 CGLB |
| 9334 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD |
| 9335 | * nucleon-nucleon event-generator |
| 9336 | CHARACTER*8 CMODEL |
| 9337 | LOGICAL LPHOIN |
| 9338 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN |
| 9339 | * VDM parameter for photon-nucleus interactions |
| 9340 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) |
| 9341 | * parameters for hA-diffraction |
| 9342 | COMMON /DTDIHA/ DIBETA,DIALPH |
| 9343 | |
| 9344 | COMPLEX*16 PP11(MAXNCL),PP12(MAXNCL),PP21(MAXNCL),PP22(MAXNCL), |
| 9345 | & OMPP11,OMPP12,OMPP21,OMPP22, |
| 9346 | & DIPP11,DIPP12,DIPP21,DIPP22,AVDIPP, |
| 9347 | & PPTMP1,PPTMP2 |
| 9348 | COMPLEX*16 C,CA,CI |
| 9349 | DIMENSION COOP1(3,MAXNCL),COOT1(3,MAXNCL), |
| 9350 | & COOP2(3,MAXNCL),COOT2(3,MAXNCL), |
| 9351 | & BPROD(KSITEB) |
| 9352 | |
| 9353 | PARAMETER (NPOINT=16) |
| 9354 | DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT) |
| 9355 | |
| 9356 | LOGICAL LFIRST,LOPEN |
| 9357 | DATA LFIRST,LOPEN /.TRUE.,.FALSE./ |
| 9358 | |
| 9359 | NTARG = ABS(NIDX) |
| 9360 | * for quasi-elastic neutrino scattering set projectile to proton |
| 9361 | * it should not have an effect since the whole Glauber-formalism is |
| 9362 | * not needed for these interactions.. |
| 9363 | IF (MCGENE.EQ.4) THEN |
| 9364 | IJPROJ = 1 |
| 9365 | ELSE |
| 9366 | IJPROJ = JJPROJ |
| 9367 | ENDIF |
| 9368 | |
| 9369 | IF ((ABS(IOGLB).EQ.1).AND.(.NOT.LOPEN)) THEN |
| 9370 | I = INDEX(CGLB,' ') |
| 9371 | IF (I.EQ.0) THEN |
| 9372 | CFILE = CGLB//'.glb' |
| 9373 | OPEN(LDAT,FILE=CGLB//'.glb',STATUS='UNKNOWN') |
| 9374 | ELSEIF (I.GT.1) THEN |
| 9375 | CFILE = CGLB(1:I-1)//'.glb' |
| 9376 | OPEN(LDAT,FILE=CGLB(1:I-1)//'.glb',STATUS='UNKNOWN') |
| 9377 | ELSE |
| 9378 | STOP 'XSGLAU 1' |
| 9379 | ENDIF |
| 9380 | LOPEN = .TRUE. |
| 9381 | ENDIF |
| 9382 | |
| 9383 | CZERO = DCMPLX(ZERO,ZERO) |
| 9384 | CONE = DCMPLX(ONE,ZERO) |
| 9385 | CTWO = DCMPLX(TWO,ZERO) |
| 9386 | NEBINI = IE |
| 9387 | NQBINI = IQ |
| 9388 | |
| 9389 | * re-define kinematics |
| 9390 | S = ECMI**2 |
| 9391 | Q2 = Q2I |
| 9392 | X = XI |
| 9393 | * g(Q2=0)-A, h-A, A-A scattering |
| 9394 | IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN |
| 9395 | Q2 = 0.0001D0 |
| 9396 | X = Q2/(S+Q2-AMP2) |
| 9397 | * g(Q2>0)-A scattering |
| 9398 | ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(S.GT.ZERO)) THEN |
| 9399 | X = Q2/(S+Q2-AMP2) |
| 9400 | ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN |
| 9401 | Q2 = (S-AMP2)*X/(ONE-X) |
| 9402 | ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN |
| 9403 | S = Q2*(ONE-X)/X+AMP2 |
| 9404 | ELSE |
| 9405 | WRITE(LOUT,*) 'XSGLAU: inconsistent input ',S,Q2,X |
| 9406 | STOP |
| 9407 | ENDIF |
| 9408 | ECMNN(IE) = SQRT(S) |
| 9409 | Q2G(IQ) = Q2 |
| 9410 | XNU = (S+Q2-AMP2)/(TWO*AMP) |
| 9411 | |
| 9412 | * parameters determining statistics in evaluating Glauber-xsection |
| 9413 | NSTATB = JSTATB |
| 9414 | NSITEB = JBINSB |
| 9415 | IF (NSITEB.GT.KSITEB) NSITEB = KSITEB |
| 9416 | |
| 9417 | * set up interaction geometry (common /DTGLAM/) |
| 9418 | * projectile/target radii |
| 9419 | RPRNCL = DT_RNCLUS(NA) |
| 9420 | RTANCL = DT_RNCLUS(NB) |
| 9421 | IF (IJPROJ.EQ.7) THEN |
| 9422 | RASH(1) = ZERO |
| 9423 | RBSH(NTARG) = RTANCL |
| 9424 | BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG)) |
| 9425 | ELSE |
| 9426 | IF (NIDX.LE.-1) THEN |
| 9427 | RASH(1) = RPRNCL |
| 9428 | RBSH(NTARG) = RTANCL |
| 9429 | BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG)) |
| 9430 | ELSE |
| 9431 | RASH(NTARG) = RPRNCL |
| 9432 | RBSH(1) = RTANCL |
| 9433 | BMAX(NTARG) = 2.0D0*(RASH(NTARG)+RBSH(1)) |
| 9434 | ENDIF |
| 9435 | ENDIF |
| 9436 | * maximum impact-parameter |
| 9437 | BSTEP(NTARG)= BMAX(NTARG)/DBLE(NSITEB-1) |
| 9438 | |
| 9439 | * slope, rho ( Re(f(0))/Im(f(0)) ) |
| 9440 | IF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN |
| 9441 | IF (MCGENE.EQ.2) THEN |
| 9442 | ZERO1 = ZERO |
| 9443 | CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,SDUM1,SDUM2,SDUM3, |
| 9444 | & BSLOPE,0) |
| 9445 | ELSE |
| 9446 | BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S)) |
| 9447 | ENDIF |
| 9448 | IF (ECMNN(IE).LE.3.0D0) THEN |
| 9449 | ROSH = -0.43D0 |
| 9450 | ELSEIF ((ECMNN(IE).GT.3.0D0).AND.(ECMNN(IE).LE.50.D0)) THEN |
| 9451 | ROSH = -0.63D0+0.175D0*LOG(ECMNN(IE)) |
| 9452 | ELSEIF (ECMNN(IE).GT.50.0D0) THEN |
| 9453 | ROSH = 0.1D0 |
| 9454 | ENDIF |
| 9455 | ELSEIF (IJPROJ.EQ.7) THEN |
| 9456 | ROSH = 0.1D0 |
| 9457 | ELSE |
| 9458 | BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S)) |
| 9459 | ROSH = 0.01D0 |
| 9460 | ENDIF |
| 9461 | |
| 9462 | * projectile-nucleon xsection (in fm) |
| 9463 | IF (IJPROJ.EQ.7) THEN |
| 9464 | SIGSH = DT_SIGVP(X,Q2)/10.0D0 |
| 9465 | ELSE |
| 9466 | ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP) |
| 9467 | PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) ) |
| 9468 | C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0 |
| 9469 | DUMZER = ZERO |
| 9470 | CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL) |
| 9471 | SIGSH = SIGSH/10.0D0 |
| 9472 | ENDIF |
| 9473 | |
| 9474 | * parameters for projectile diffraction (hA scattering only) |
| 9475 | IF ((MCGENE.EQ.2).AND.(NA.EQ.1).AND.(NB.GT.1).AND.(IJPROJ.NE.7) |
| 9476 | & .AND.(DIBETA.GE.ZERO)) THEN |
| 9477 | ZERO1 = ZERO |
| 9478 | CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,STOT,SDUM2,SDIF1,BDUM,0) |
| 9479 | C DIBETA = SDIF1/STOT |
| 9480 | DIBETA = 0.2D0 |
| 9481 | DIGAMM = SQRT(DIALPH**2+DIBETA**2) |
| 9482 | IF (DIBETA.LE.ZERO) THEN |
| 9483 | ALPGAM = ONE |
| 9484 | ELSE |
| 9485 | ALPGAM = DIALPH/DIGAMM |
| 9486 | ENDIF |
| 9487 | FACDI1 = ONE-ALPGAM |
| 9488 | FACDI2 = ONE+ALPGAM |
| 9489 | FACDI = SQRT(FACDI1*FACDI2) |
| 9490 | WRITE(LOUT,*)'DIBETA,DIALPH,DIGAMM: ',DIBETA,DIALPH,DIGAMM |
| 9491 | ELSE |
| 9492 | DIBETA = -1.0D0 |
| 9493 | DIALPH = ZERO |
| 9494 | DIGAMM = ZERO |
| 9495 | FACDI1 = ZERO |
| 9496 | FACDI2 = 2.0D0 |
| 9497 | FACDI = ZERO |
| 9498 | ENDIF |
| 9499 | |
| 9500 | * initializations |
| 9501 | DO 10 I=1,NSITEB |
| 9502 | BSITE( 0,IQ,NTARG,I) = ZERO |
| 9503 | BSITE(IE,IQ,NTARG,I) = ZERO |
| 9504 | BPROD(I) = ZERO |
| 9505 | 10 CONTINUE |
| 9506 | STOT = ZERO |
| 9507 | STOT2 = ZERO |
| 9508 | SELA = ZERO |
| 9509 | SELA2 = ZERO |
| 9510 | SQEP = ZERO |
| 9511 | SQEP2 = ZERO |
| 9512 | SQET = ZERO |
| 9513 | SQET2 = ZERO |
| 9514 | SQE2 = ZERO |
| 9515 | SQE22 = ZERO |
| 9516 | SPRO = ZERO |
| 9517 | SPRO2 = ZERO |
| 9518 | SDEL = ZERO |
| 9519 | SDEL2 = ZERO |
| 9520 | SDQE = ZERO |
| 9521 | SDQE2 = ZERO |
| 9522 | FACN = ONE/DBLE(NSTATB) |
| 9523 | |
| 9524 | IPNT = 0 |
| 9525 | RPNT = ZERO |
| 9526 | |
| 9527 | * initialize Gauss-integration for photon-proj. |
| 9528 | JPOINT = 1 |
| 9529 | IF (IJPROJ.EQ.7) THEN |
| 9530 | IF (INTRGE(1).EQ.1) THEN |
| 9531 | AMLO2 = (3.0D0*AAM(13))**2 |
| 9532 | ELSEIF (INTRGE(1).EQ.2) THEN |
| 9533 | AMLO2 = AAM(33)**2 |
| 9534 | ELSE |
| 9535 | AMLO2 = AAM(96)**2 |
| 9536 | ENDIF |
| 9537 | IF (INTRGE(2).EQ.1) THEN |
| 9538 | AMHI2 = S/TWO |
| 9539 | ELSEIF (INTRGE(2).EQ.2) THEN |
| 9540 | AMHI2 = S/4.0D0 |
| 9541 | ELSE |
| 9542 | AMHI2 = S |
| 9543 | ENDIF |
| 9544 | AMHI20 = (ECMNN(IE)-AMP)**2 |
| 9545 | IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20 |
| 9546 | XAMLO = LOG( AMLO2+Q2 ) |
| 9547 | XAMHI = LOG( AMHI2+Q2 ) |
| 9548 | **PHOJET105a |
| 9549 | C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT) |
| 9550 | **PHOJET112 |
| 9551 | |
| 9552 | CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT) |
| 9553 | |
| 9554 | ** |
| 9555 | JPOINT = NPOINT |
| 9556 | * ratio direct/total photon-nucleon xsection |
| 9557 | CALL DT_POILIK(NB,NTARG,ECMNN(IE),Q2,IPNT,RPNT,1) |
| 9558 | ENDIF |
| 9559 | |
| 9560 | * read pre-initialized profile-function from file |
| 9561 | IF (IOGLB.EQ.1) THEN |
| 9562 | READ(LDAT,'(5I10,E15.5)') KJPROJ,IA,IB,ISTATB,ISITEB,DUM |
| 9563 | IF ((IA.NE.NA).OR.(IB.NE.NB)) THEN |
| 9564 | WRITE(LOUT,1000) CFILE,IA,IB,ISTATB,ISITEB, |
| 9565 | & NA,NB,NSTATB,NSITEB |
| 9566 | 1000 FORMAT(' XSGLAU: inconsistent input data in file ',A12,/, |
| 9567 | & ' (IA,IB,ISTATB,ISITEB) ',4I10,/, |
| 9568 | & ' (NA,NB,NSTATB,NSITEB) ',4I10) |
| 9569 | STOP |
| 9570 | ENDIF |
| 9571 | IF (LFIRST) WRITE(LOUT,1001) CFILE |
| 9572 | 1001 FORMAT(/,' XSGLAU: impact parameter distribution read from ', |
| 9573 | & 'file ',A12,/) |
| 9574 | READ(LDAT,'(6E12.5)') XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG), |
| 9575 | & XSQEP(IE,IQ,NTARG),XSQET(IE,IQ,NTARG), |
| 9576 | & XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG) |
| 9577 | READ(LDAT,'(6E12.5)') XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG), |
| 9578 | & XEQEP(IE,IQ,NTARG),XEQET(IE,IQ,NTARG), |
| 9579 | & XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG) |
| 9580 | NLINES = INT(DBLE(NSITEB)/7.0D0) |
| 9581 | IF (NLINES.GT.0) THEN |
| 9582 | DO 21 I=1,NLINES |
| 9583 | ISTART = 7*I-6 |
| 9584 | READ(LDAT,'(7E11.4)') |
| 9585 | & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6) |
| 9586 | 21 CONTINUE |
| 9587 | ENDIF |
| 9588 | ISTART = 7*NLINES+1 |
| 9589 | IF (ISTART.LE.NSITEB) THEN |
| 9590 | READ(LDAT,'(7E11.4)') |
| 9591 | & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB) |
| 9592 | ENDIF |
| 9593 | LFIRST = .FALSE. |
| 9594 | GOTO 100 |
| 9595 | * variable projectile/target/energy runs: |
| 9596 | * read pre-initialized profile-functions from file |
| 9597 | ELSEIF (IOGLB.EQ.100) THEN |
| 9598 | CALL DT_GLBSET(IJPROJ,IINA,IINB,RRELAB,0) |
| 9599 | GOTO 100 |
| 9600 | ENDIF |
| 9601 | |
| 9602 | * cross sections averaged over NSTATB nucleon configurations |
| 9603 | DO 11 IS=1,NSTATB |
| 9604 | C IF ((NA.EQ.207).AND.(NB.EQ.207)) WRITE(LOUT,*) 'conf. ',IS |
| 9605 | STOTN = ZERO |
| 9606 | SELAN = ZERO |
| 9607 | SQEPN = ZERO |
| 9608 | SQETN = ZERO |
| 9609 | SQE2N = ZERO |
| 9610 | SPRON = ZERO |
| 9611 | SDELN = ZERO |
| 9612 | SDQEN = ZERO |
| 9613 | |
| 9614 | IF (NIDX.LE.-1) THEN |
| 9615 | CALL DT_CONUCL(COOP1,NA,RASH(1),0) |
| 9616 | CALL DT_CONUCL(COOT1,NB,RBSH(NTARG),1) |
| 9617 | IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN |
| 9618 | CALL DT_CONUCL(COOP2,NA,RASH(1),0) |
| 9619 | CALL DT_CONUCL(COOT2,NB,RBSH(NTARG),1) |
| 9620 | ENDIF |
| 9621 | ELSE |
| 9622 | CALL DT_CONUCL(COOP1,NA,RASH(NTARG),0) |
| 9623 | CALL DT_CONUCL(COOT1,NB,RBSH(1),1) |
| 9624 | IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN |
| 9625 | CALL DT_CONUCL(COOP2,NA,RASH(NTARG),0) |
| 9626 | CALL DT_CONUCL(COOT2,NB,RBSH(1),1) |
| 9627 | ENDIF |
| 9628 | ENDIF |
| 9629 | |
| 9630 | * integration over impact parameter B |
| 9631 | DO 12 IB=1,NSITEB-1 |
| 9632 | STOTB = ZERO |
| 9633 | SELAB = ZERO |
| 9634 | SQEPB = ZERO |
| 9635 | SQETB = ZERO |
| 9636 | SQE2B = ZERO |
| 9637 | SPROB = ZERO |
| 9638 | SDIR = ZERO |
| 9639 | SDELB = ZERO |
| 9640 | SDQEB = ZERO |
| 9641 | B = DBLE(IB)*BSTEP(NTARG) |
| 9642 | FACB = 10.0D0*TWOPI*B*BSTEP(NTARG) |
| 9643 | |
| 9644 | * integration over M_V^2 for photon-proj. |
| 9645 | DO 14 IM=1,JPOINT |
| 9646 | PP11(1) = CONE |
| 9647 | PP12(1) = CONE |
| 9648 | PP21(1) = CONE |
| 9649 | PP22(1) = CONE |
| 9650 | IF (IJPROJ.EQ.7) THEN |
| 9651 | DO 13 K=2,NB |
| 9652 | PP11(K) = CONE |
| 9653 | PP12(K) = CONE |
| 9654 | PP21(K) = CONE |
| 9655 | PP22(K) = CONE |
| 9656 | 13 CONTINUE |
| 9657 | ENDIF |
| 9658 | SHI = ZERO |
| 9659 | FACM = ONE |
| 9660 | DCOH = 1.0D10 |
| 9661 | |
| 9662 | IF (IJPROJ.EQ.7) THEN |
| 9663 | AMV2 = EXP(ABSZX(IM))-Q2 |
| 9664 | AMV = SQRT(AMV2) |
| 9665 | IF (AMV2.LT.16.0D0) THEN |
| 9666 | R = TWO |
| 9667 | ELSEIF ((AMV2.GE.16.0D0).AND.(AMV2.LT.121.0D0)) THEN |
| 9668 | R = 10.0D0/3.0D0 |
| 9669 | ELSE |
| 9670 | R = 11.0D0/3.0D0 |
| 9671 | ENDIF |
| 9672 | * define M_V dependent properties of nucleon scattering amplitude |
| 9673 | * V_M-nucleon xsection |
| 9674 | SIGMVD = RPNT*SIGSH/(AMV2+Q2+RL2)*10.0D0 |
| 9675 | SIGMV = (ONE-RPNT)*SIGSH/(AMV2+Q2+RL2) |
| 9676 | * slope-parametrisation a la Kaidalov |
| 9677 | BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2) |
| 9678 | & +0.25D0*LOG(S/(AMV2+Q2))) |
| 9679 | * coherence length |
| 9680 | IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+Q2)*GEV2FM |
| 9681 | * integration weight factor |
| 9682 | FACM = ALPHEM/(3.0D0*PI*(ONE-X))* |
| 9683 | & R*AMV2/(AMV2+Q2)*(ONE+EPSPOL*Q2/AMV2)*WEIGHT(IM) |
| 9684 | ENDIF |
| 9685 | GSH = 10.0D0/(TWO*BSLOPE*GEV2MB) |
| 9686 | GAM = GSH |
| 9687 | IF (IJPROJ.EQ.7) THEN |
| 9688 | RCA = GAM*SIGMV/TWOPI |
| 9689 | ELSE |
| 9690 | RCA = GAM*SIGSH/TWOPI |
| 9691 | ENDIF |
| 9692 | FCA = -ROSH*RCA |
| 9693 | CA = DCMPLX(RCA,FCA) |
| 9694 | CI = CONE |
| 9695 | |
| 9696 | DO 15 INA=1,NA |
| 9697 | KK1 = 1 |
| 9698 | INT1 = 1 |
| 9699 | KK2 = 1 |
| 9700 | INT2 = 1 |
| 9701 | DO 16 INB=1,NB |
| 9702 | * photon-projectile: check for supression by coherence length |
| 9703 | IF (IJPROJ.EQ.7) THEN |
| 9704 | IF (ABS(COOT1(3,INB)-COOT1(3,KK1)).GT.DCOH)THEN |
| 9705 | KK1 = INB |
| 9706 | INT1 = INT1+1 |
| 9707 | ENDIF |
| 9708 | IF (ABS(COOT2(3,INB)-COOT2(3,KK2)).GT.DCOH)THEN |
| 9709 | KK2 = INB |
| 9710 | INT2 = INT2+1 |
| 9711 | ENDIF |
| 9712 | ENDIF |
| 9713 | |
| 9714 | X11 = B+COOT1(1,INB)-COOP1(1,INA) |
| 9715 | Y11 = COOT1(2,INB)-COOP1(2,INA) |
| 9716 | XY11 = GAM*(X11*X11+Y11*Y11) |
| 9717 | IF (XY11.LE.15.0D0) THEN |
| 9718 | C = CONE-CA*EXP(-XY11) |
| 9719 | AR = DBLE(PP11(INT1)) |
| 9720 | AI = DIMAG(PP11(INT1)) |
| 9721 | IF (ABS(AR).LT.TINY25) AR = ZERO |
| 9722 | IF (ABS(AI).LT.TINY25) AI = ZERO |
| 9723 | PP11(INT1) = DCMPLX(AR,AI) |
| 9724 | PP11(INT1) = PP11(INT1)*C |
| 9725 | AR = DBLE(C) |
| 9726 | AI = DIMAG(C) |
| 9727 | SHI = SHI+LOG(AR*AR+AI*AI) |
| 9728 | ENDIF |
| 9729 | IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN |
| 9730 | X12 = B+COOT2(1,INB)-COOP1(1,INA) |
| 9731 | Y12 = COOT2(2,INB)-COOP1(2,INA) |
| 9732 | XY12 = GAM*(X12*X12+Y12*Y12) |
| 9733 | IF (XY12.LE.15.0D0) THEN |
| 9734 | C = CONE-CA*EXP(-XY12) |
| 9735 | AR = DBLE(PP12(INT2)) |
| 9736 | AI = DIMAG(PP12(INT2)) |
| 9737 | IF (ABS(AR).LT.TINY25) AR = ZERO |
| 9738 | IF (ABS(AI).LT.TINY25) AI = ZERO |
| 9739 | PP12(INT2) = DCMPLX(AR,AI) |
| 9740 | PP12(INT2) = PP12(INT2)*C |
| 9741 | ENDIF |
| 9742 | X21 = B+COOT1(1,INB)-COOP2(1,INA) |
| 9743 | Y21 = COOT1(2,INB)-COOP2(2,INA) |
| 9744 | XY21 = GAM*(X21*X21+Y21*Y21) |
| 9745 | IF (XY21.LE.15.0D0) THEN |
| 9746 | C = CONE-CA*EXP(-XY21) |
| 9747 | AR = DBLE(PP21(INT1)) |
| 9748 | AI = DIMAG(PP21(INT1)) |
| 9749 | IF (ABS(AR).LT.TINY25) AR = ZERO |
| 9750 | IF (ABS(AI).LT.TINY25) AI = ZERO |
| 9751 | PP21(INT1) = DCMPLX(AR,AI) |
| 9752 | PP21(INT1) = PP21(INT1)*C |
| 9753 | ENDIF |
| 9754 | X22 = B+COOT2(1,INB)-COOP2(1,INA) |
| 9755 | Y22 = COOT2(2,INB)-COOP2(2,INA) |
| 9756 | XY22 = GAM*(X22*X22+Y22*Y22) |
| 9757 | IF (XY22.LE.15.0D0) THEN |
| 9758 | C = CONE-CA*EXP(-XY22) |
| 9759 | AR = DBLE(PP22(INT2)) |
| 9760 | AI = DIMAG(PP22(INT2)) |
| 9761 | IF (ABS(AR).LT.TINY25) AR = ZERO |
| 9762 | IF (ABS(AI).LT.TINY25) AI = ZERO |
| 9763 | PP22(INT2) = DCMPLX(AR,AI) |
| 9764 | PP22(INT2) = PP22(INT2)*C |
| 9765 | ENDIF |
| 9766 | ENDIF |
| 9767 | 16 CONTINUE |
| 9768 | 15 CONTINUE |
| 9769 | |
| 9770 | OMPP11 = CZERO |
| 9771 | OMPP21 = CZERO |
| 9772 | DIPP11 = CZERO |
| 9773 | DIPP21 = CZERO |
| 9774 | DO 17 K=1,INT1 |
| 9775 | IF (PP11(K).EQ.CZERO) THEN |
| 9776 | PPTMP1 = CZERO |
| 9777 | PPTMP2 = CZERO |
| 9778 | ELSE |
| 9779 | PPTMP1 = PP11(K)**(ONE-DIALPH-DIGAMM) |
| 9780 | PPTMP2 = PP11(K)**(ONE-DIALPH+DIGAMM) |
| 9781 | ENDIF |
| 9782 | AVDIPP = 0.5D0* |
| 9783 | & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) ) |
| 9784 | OMPP11 = OMPP11+AVDIPP |
| 9785 | C OMPP11 = OMPP11+(CONE-PP11(K)) |
| 9786 | AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 ) |
| 9787 | DIPP11 = DIPP11+AVDIPP |
| 9788 | IF (PP21(K).EQ.CZERO) THEN |
| 9789 | PPTMP1 = CZERO |
| 9790 | PPTMP2 = CZERO |
| 9791 | ELSE |
| 9792 | PPTMP1 = PP21(K)**(ONE-DIALPH-DIGAMM) |
| 9793 | PPTMP2 = PP21(K)**(ONE-DIALPH+DIGAMM) |
| 9794 | ENDIF |
| 9795 | AVDIPP = 0.5D0* |
| 9796 | & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) ) |
| 9797 | OMPP21 = OMPP21+AVDIPP |
| 9798 | C OMPP21 = OMPP21+(CONE-PP21(K)) |
| 9799 | AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 ) |
| 9800 | DIPP21 = DIPP21+AVDIPP |
| 9801 | 17 CONTINUE |
| 9802 | OMPP12 = CZERO |
| 9803 | OMPP22 = CZERO |
| 9804 | DIPP12 = CZERO |
| 9805 | DIPP22 = CZERO |
| 9806 | DO 18 K=1,INT2 |
| 9807 | IF (PP12(K).EQ.CZERO) THEN |
| 9808 | PPTMP1 = CZERO |
| 9809 | PPTMP2 = CZERO |
| 9810 | ELSE |
| 9811 | PPTMP1 = PP12(K)**(ONE-DIALPH-DIGAMM) |
| 9812 | PPTMP2 = PP12(K)**(ONE-DIALPH+DIGAMM) |
| 9813 | ENDIF |
| 9814 | AVDIPP = 0.5D0* |
| 9815 | & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) ) |
| 9816 | OMPP12 = OMPP12+AVDIPP |
| 9817 | C OMPP12 = OMPP12+(CONE-PP12(K)) |
| 9818 | AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 ) |
| 9819 | DIPP12 = DIPP12+AVDIPP |
| 9820 | IF (PP22(K).EQ.CZERO) THEN |
| 9821 | PPTMP1 = CZERO |
| 9822 | PPTMP2 = CZERO |
| 9823 | ELSE |
| 9824 | PPTMP1 = PP22(K)**(ONE-DIALPH-DIGAMM) |
| 9825 | PPTMP2 = PP22(K)**(ONE-DIALPH+DIGAMM) |
| 9826 | ENDIF |
| 9827 | AVDIPP = 0.5D0* |
| 9828 | & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) ) |
| 9829 | OMPP22 = OMPP22+AVDIPP |
| 9830 | C OMPP22 = OMPP22+(CONE-PP22(K)) |
| 9831 | AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 ) |
| 9832 | DIPP22 = DIPP22+AVDIPP |
| 9833 | 18 CONTINUE |
| 9834 | |
| 9835 | SPROM = ONE-EXP(SHI) |
| 9836 | SPROB = SPROB+FACM*SPROM |
| 9837 | IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN |
| 9838 | STOTM = DBLE(OMPP11+OMPP22) |
| 9839 | SELAM = DBLE(OMPP11*DCONJG(OMPP22)) |
| 9840 | SQEPM = DBLE(OMPP11*DCONJG(OMPP21))-SELAM |
| 9841 | SQETM = DBLE(OMPP11*DCONJG(OMPP12))-SELAM |
| 9842 | SQE2M = DBLE(OMPP11*DCONJG(OMPP11))-SELAM-SQEPM-SQETM |
| 9843 | SDELM = DBLE(DIPP11*DCONJG(DIPP22)) |
| 9844 | SDQEM = DBLE(DIPP11*DCONJG(DIPP21))-SDELM |
| 9845 | STOTB = STOTB+FACM*STOTM |
| 9846 | SELAB = SELAB+FACM*SELAM |
| 9847 | SDELB = SDELB+FACM*SDELM |
| 9848 | IF (NB.GT.1) THEN |
| 9849 | SQEPB = SQEPB+FACM*SQEPM |
| 9850 | SDQEB = SDQEB+FACM*SDQEM |
| 9851 | ENDIF |
| 9852 | IF (NA.GT.1) SQETB = SQETB+FACM*SQETM |
| 9853 | IF ((NA.GT.1).AND.(NB.GT.1)) SQE2B = SQE2B+FACM*SQE2M |
| 9854 | IF (IJPROJ.EQ.7) SDIR = SDIR+FACM*SIGMVD |
| 9855 | ENDIF |
| 9856 | |
| 9857 | 14 CONTINUE |
| 9858 | |
| 9859 | STOTN = STOTN+FACB*STOTB |
| 9860 | SELAN = SELAN+FACB*SELAB |
| 9861 | SQEPN = SQEPN+FACB*SQEPB |
| 9862 | SQETN = SQETN+FACB*SQETB |
| 9863 | SQE2N = SQE2N+FACB*SQE2B |
| 9864 | SPRON = SPRON+FACB*SPROB |
| 9865 | SDELN = SDELN+FACB*SDELB |
| 9866 | SDQEN = SDQEN+FACB*SDQEB |
| 9867 | |
| 9868 | IF (IJPROJ.EQ.7) THEN |
| 9869 | BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*(STOTB-SELAB-SQEPB) |
| 9870 | ELSE |
| 9871 | IF (DIBETA.GT.ZERO) THEN |
| 9872 | BPROD(IB+1)= BPROD(IB+1) |
| 9873 | & +FACN*FACB*(STOTB-SELAB-SQEPB-SQETB-SQE2B) |
| 9874 | ELSE |
| 9875 | BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*SPROB |
| 9876 | ENDIF |
| 9877 | ENDIF |
| 9878 | |
| 9879 | 12 CONTINUE |
| 9880 | |
| 9881 | STOT = STOT +FACN*STOTN |
| 9882 | STOT2 = STOT2+FACN*STOTN**2 |
| 9883 | SELA = SELA +FACN*SELAN |
| 9884 | SELA2 = SELA2+FACN*SELAN**2 |
| 9885 | SQEP = SQEP +FACN*SQEPN |
| 9886 | SQEP2 = SQEP2+FACN*SQEPN**2 |
| 9887 | SQET = SQET +FACN*SQETN |
| 9888 | SQET2 = SQET2+FACN*SQETN**2 |
| 9889 | SQE2 = SQE2 +FACN*SQE2N |
| 9890 | SQE22 = SQE22+FACN*SQE2N**2 |
| 9891 | SPRO = SPRO +FACN*SPRON |
| 9892 | SPRO2 = SPRO2+FACN*SPRON**2 |
| 9893 | SDEL = SDEL +FACN*SDELN |
| 9894 | SDEL2 = SDEL2+FACN*SDELN**2 |
| 9895 | SDQE = SDQE +FACN*SDQEN |
| 9896 | SDQE2 = SDQE2+FACN*SDQEN**2 |
| 9897 | |
| 9898 | 11 CONTINUE |
| 9899 | |
| 9900 | * final cross sections |
| 9901 | * 1) total |
| 9902 | XSTOT(IE,IQ,NTARG) = STOT |
| 9903 | IF (IJPROJ.EQ.7) |
| 9904 | & XSTOT(IE,IQ,NTARG) = XSTOT(IE,IQ,NTARG)+DBLE(NB)*SDIR |
| 9905 | * 2) elastic |
| 9906 | XSELA(IE,IQ,NTARG) = SELA |
| 9907 | * 3) quasi-el.: A+B-->A+X (excluding 2) |
| 9908 | XSQEP(IE,IQ,NTARG) = SQEP |
| 9909 | * 4) quasi-el.: A+B-->X+B (excluding 2) |
| 9910 | XSQET(IE,IQ,NTARG) = SQET |
| 9911 | * 5) quasi-el.: A+B-->X (excluding 2-4) |
| 9912 | XSQE2(IE,IQ,NTARG) = SQE2 |
| 9913 | * 6) production (= STOT-SELA-SQEP-SQET-SQE2!) |
| 9914 | IF (SDEL.GT.ZERO) THEN |
| 9915 | XSPRO(IE,IQ,NTARG) = STOT-SELA-SQEP-SQET-SQE2 |
| 9916 | ELSE |
| 9917 | XSPRO(IE,IQ,NTARG) = SPRO |
| 9918 | ENDIF |
| 9919 | * 7) projectile diffraction (el. scatt. off target) |
| 9920 | XSDEL(IE,IQ,NTARG) = SDEL |
| 9921 | * 8) projectile diffraction (quasi-el. scatt. off target) |
| 9922 | XSDQE(IE,IQ,NTARG) = SDQE |
| 9923 | * stat. errors |
| 9924 | XETOT(IE,IQ,NTARG) = SQRT(ABS(STOT2-STOT**2)/DBLE(NSTATB-1)) |
| 9925 | XEELA(IE,IQ,NTARG) = SQRT(ABS(SELA2-SELA**2)/DBLE(NSTATB-1)) |
| 9926 | XEQEP(IE,IQ,NTARG) = SQRT(ABS(SQEP2-SQEP**2)/DBLE(NSTATB-1)) |
| 9927 | XEQET(IE,IQ,NTARG) = SQRT(ABS(SQET2-SQET**2)/DBLE(NSTATB-1)) |
| 9928 | XEQE2(IE,IQ,NTARG) = SQRT(ABS(SQE22-SQE2**2)/DBLE(NSTATB-1)) |
| 9929 | XEPRO(IE,IQ,NTARG) = SQRT(ABS(SPRO2-SPRO**2)/DBLE(NSTATB-1)) |
| 9930 | XEDEL(IE,IQ,NTARG) = SQRT(ABS(SDEL2-SDEL**2)/DBLE(NSTATB-1)) |
| 9931 | XEDQE(IE,IQ,NTARG) = SQRT(ABS(SDQE2-SDQE**2)/DBLE(NSTATB-1)) |
| 9932 | |
| 9933 | IF (IJPROJ.EQ.7) THEN |
| 9934 | BNORM = XSTOT(IE,IQ,NTARG)-XSELA(IE,IQ,NTARG) |
| 9935 | & -XSQEP(IE,IQ,NTARG) |
| 9936 | ELSE |
| 9937 | BNORM = XSPRO(IE,IQ,NTARG) |
| 9938 | ENDIF |
| 9939 | DO 19 I=2,NSITEB |
| 9940 | BSITE(IE,IQ,NTARG,I) = BPROD(I)/BNORM+BSITE(IE,IQ,NTARG,I-1) |
| 9941 | IF ((IE.EQ.1).AND.(IQ.EQ.1)) |
| 9942 | & BSITE(0,1,NTARG,I) = BPROD(I)/BNORM+BSITE(0,1,NTARG,I-1) |
| 9943 | 19 CONTINUE |
| 9944 | |
| 9945 | * write profile function data into file |
| 9946 | IF ((IOGLB.EQ.-1).OR.(IOGLB.EQ.-100)) THEN |
| 9947 | WRITE(LDAT,'(5I10,1P,E15.5)') |
| 9948 | & IJPROJ,NA,NB,NSTATB,NSITEB,ECMNN(IE) |
| 9949 | WRITE(LDAT,'(1P,6E12.5)') |
| 9950 | & XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),XSQEP(IE,IQ,NTARG), |
| 9951 | & XSQET(IE,IQ,NTARG),XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG) |
| 9952 | WRITE(LDAT,'(1P,6E12.5)') |
| 9953 | & XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),XEQEP(IE,IQ,NTARG), |
| 9954 | & XEQET(IE,IQ,NTARG),XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG) |
| 9955 | NLINES = INT(DBLE(NSITEB)/7.0D0) |
| 9956 | IF (NLINES.GT.0) THEN |
| 9957 | DO 20 I=1,NLINES |
| 9958 | ISTART = 7*I-6 |
| 9959 | WRITE(LDAT,'(1P,7E11.4)') |
| 9960 | & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6) |
| 9961 | 20 CONTINUE |
| 9962 | ENDIF |
| 9963 | ISTART = 7*NLINES+1 |
| 9964 | IF (ISTART.LE.NSITEB) THEN |
| 9965 | WRITE(LDAT,'(1P,7E11.4)') |
| 9966 | & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB) |
| 9967 | ENDIF |
| 9968 | ENDIF |
| 9969 | |
| 9970 | 100 CONTINUE |
| 9971 | |
| 9972 | C IF (ABS(IOGLB).EQ.1) CLOSE(LDAT) |
| 9973 | |
| 9974 | RETURN |
| 9975 | END |
| 9976 | * |
| 9977 | *===getbxs=============================================================* |
| 9978 | * |
| 9979 | CDECK ID>, DT_GETBXS |
| 9980 | SUBROUTINE DT_GETBXS(XSFRAC,BLO,BHI,NIDX) |
| 9981 | |
| 9982 | ************************************************************************ |
| 9983 | * Biasing in impact parameter space. * |
| 9984 | * XSFRAC = 0 : BLO - minimum impact parameter (input) * |
| 9985 | * BHI - maximum impact parameter (input) * |
| 9986 | * XSFRAC - fraction of cross section corresponding * |
| 9987 | * to impact parameter range (BLO,BHI) * |
| 9988 | * (output) * |
| 9989 | * XSFRAC > 0 : XSFRAC - fraction of cross section (input) * |
| 9990 | * BHI - maximum impact parameter giving requested * |
| 9991 | * fraction of cross section in impact * |
| 9992 | * parameter range (0,BMAX) (output) * |
| 9993 | * This version dated 17.03.00 is written by S. Roesler * |
| 9994 | ************************************************************************ |
| 9995 | |
| 9996 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 9997 | SAVE |
| 9998 | |
| 9999 | PARAMETER ( LINP = 5 , |
| 10000 | & LOUT = 6 , |
| 10001 | & LDAT = 9 ) |
| 10002 | |
| 10003 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 10004 | |
| 10005 | * Glauber formalism: parameters |
| 10006 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), |
| 10007 | & BMAX(NCOMPX),BSTEP(NCOMPX), |
| 10008 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), |
| 10009 | & NSITEB,NSTATB |
| 10010 | |
| 10011 | NTARG = ABS(NIDX) |
| 10012 | IF (XSFRAC.LE.0.0D0) THEN |
| 10013 | ILO = MIN(NSITEB-1,INT(BLO/BSTEP(NTARG))) |
| 10014 | IHI = MIN(NSITEB-1,INT(BHI/BSTEP(NTARG))) |
| 10015 | IF (ILO.GE.IHI) THEN |
| 10016 | XSFRAC = 0.0D0 |
| 10017 | RETURN |
| 10018 | ENDIF |
| 10019 | IF (ILO.EQ.NSITEB-1) THEN |
| 10020 | FRCLO = BSITE(0,1,NTARG,NSITEB) |
| 10021 | ELSE |
| 10022 | FRCLO = BSITE(0,1,NTARG,ILO+1) |
| 10023 | & +(BLO-ILO*BSTEP(NTARG))/BSTEP(NTARG) |
| 10024 | & *(BSITE(0,1,NTARG,ILO+2)-BSITE(0,1,NTARG,ILO+1)) |
| 10025 | ENDIF |
| 10026 | IF (IHI.EQ.NSITEB-1) THEN |
| 10027 | FRCHI = BSITE(0,1,NTARG,NSITEB) |
| 10028 | ELSE |
| 10029 | FRCHI = BSITE(0,1,NTARG,IHI+1) |
| 10030 | & +(BHI-IHI*BSTEP(NTARG))/BSTEP(NTARG) |
| 10031 | & *(BSITE(0,1,NTARG,IHI+2)-BSITE(0,1,NTARG,IHI+1)) |
| 10032 | ENDIF |
| 10033 | XSFRAC = FRCHI-FRCLO |
| 10034 | ELSE |
| 10035 | BLO = 0.0D0 |
| 10036 | BHI = BMAX(NTARG) |
| 10037 | DO 1 I=1,NSITEB-1 |
| 10038 | IF (XSFRAC.LT.BSITE(0,1,NTARG,I+1)) THEN |
| 10039 | FAC = (XSFRAC -BSITE(0,1,NTARG,I))/ |
| 10040 | & (BSITE(0,1,NTARG,I+1)-BSITE(0,1,NTARG,I)) |
| 10041 | BHI = DBLE(I-1)*BSTEP(NTARG)+BSTEP(NTARG)*FAC |
| 10042 | GOTO 2 |
| 10043 | ENDIF |
| 10044 | 1 CONTINUE |
| 10045 | 2 CONTINUE |
| 10046 | ENDIF |
| 10047 | |
| 10048 | RETURN |
| 10049 | END |
| 10050 | * |
| 10051 | *===conucl=============================================================* |
| 10052 | * |
| 10053 | CDECK ID>, DT_CONUCL |
| 10054 | SUBROUTINE DT_CONUCL(X,N,R,MODE) |
| 10055 | |
| 10056 | ************************************************************************ |
| 10057 | * Calculation of coordinates of nucleons within nuclei. * |
| 10058 | * X(3,N) spatial coordinates of nucleons (in fm) (output) * |
| 10059 | * N / R number of nucleons / radius of nucleus (input) * |
| 10060 | * MODE = 0 coordinates not sorted * |
| 10061 | * = 1 coordinates sorted with increasing X(3,i) * |
| 10062 | * = 2 coordinates sorted with decreasing X(3,i) * |
| 10063 | * This version dated 26.10.95 is revised by S. Roesler * |
| 10064 | ************************************************************************ |
| 10065 | |
| 10066 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 10067 | SAVE |
| 10068 | |
| 10069 | PARAMETER ( LINP = 5 , |
| 10070 | & LOUT = 6 , |
| 10071 | & LDAT = 9 ) |
| 10072 | |
| 10073 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0, |
| 10074 | & ONETHI=ONE/THREE,SQRTWO=1.414213562D0) |
| 10075 | |
| 10076 | PARAMETER (TWOPI = 6.283185307179586454D+00 ) |
| 10077 | |
| 10078 | PARAMETER (NSRT=10) |
| 10079 | DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT) |
| 10080 | DIMENSION X(3,N),XTMP(3,260) |
| 10081 | |
| 10082 | CALL DT_COORDI(XTMP,IDXSRT,ICSRT,N,R) |
| 10083 | |
| 10084 | IF ((MODE.NE.0).AND.((N.EQ.3).OR.(N.GT.4))) THEN |
| 10085 | K = 0 |
| 10086 | DO 1 I=1,NSRT |
| 10087 | IF (MODE.EQ.2) THEN |
| 10088 | ISRT = NSRT+1-I |
| 10089 | ELSE |
| 10090 | ISRT = I |
| 10091 | ENDIF |
| 10092 | K1 = K |
| 10093 | DO 2 J=1,ICSRT(ISRT) |
| 10094 | K = K+1 |
| 10095 | X(1,K) = XTMP(1,IDXSRT(ISRT,J)) |
| 10096 | X(2,K) = XTMP(2,IDXSRT(ISRT,J)) |
| 10097 | X(3,K) = XTMP(3,IDXSRT(ISRT,J)) |
| 10098 | 2 CONTINUE |
| 10099 | IF (ICSRT(ISRT).GT.1) THEN |
| 10100 | I0 = K1+1 |
| 10101 | I1 = K |
| 10102 | CALL DT_SORT(X,N,I0,I1,MODE) |
| 10103 | ENDIF |
| 10104 | 1 CONTINUE |
| 10105 | ELSEIF ((MODE.NE.0).AND.((N.EQ.2).OR.(N.EQ.4))) THEN |
| 10106 | DO 3 I=1,N |
| 10107 | X(1,I) = XTMP(1,I) |
| 10108 | X(2,I) = XTMP(2,I) |
| 10109 | X(3,I) = XTMP(3,I) |
| 10110 | 3 CONTINUE |
| 10111 | CALL DT_SORT(X,N,1,N,MODE) |
| 10112 | ELSE |
| 10113 | DO 4 I=1,N |
| 10114 | X(1,I) = XTMP(1,I) |
| 10115 | X(2,I) = XTMP(2,I) |
| 10116 | X(3,I) = XTMP(3,I) |
| 10117 | 4 CONTINUE |
| 10118 | ENDIF |
| 10119 | |
| 10120 | RETURN |
| 10121 | END |
| 10122 | * |
| 10123 | *===coordi=============================================================* |
| 10124 | * |
| 10125 | CDECK ID>, DT_COORDI |
| 10126 | SUBROUTINE DT_COORDI(X,IDXSRT,ICSRT,N,R) |
| 10127 | |
| 10128 | ************************************************************************ |
| 10129 | * Calculation of coordinates of nucleons within nuclei. * |
| 10130 | * X(3,N) spatial coordinates of nucleons (in fm) (output) * |
| 10131 | * N / R number of nucleons / radius of nucleus (input) * |
| 10132 | * Based on the original version by Shmakov et al. * |
| 10133 | * This version dated 26.10.95 is revised by S. Roesler * |
| 10134 | ************************************************************************ |
| 10135 | |
| 10136 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 10137 | SAVE |
| 10138 | |
| 10139 | PARAMETER ( LINP = 5 , |
| 10140 | & LOUT = 6 , |
| 10141 | & LDAT = 9 ) |
| 10142 | |
| 10143 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0, |
| 10144 | & ONETHI=ONE/THREE,SQRTWO=1.414213562D0) |
| 10145 | |
| 10146 | PARAMETER (TWOPI = 6.283185307179586454D+00 ) |
| 10147 | |
| 10148 | LOGICAL LSTART |
| 10149 | |
| 10150 | PARAMETER (NSRT=10) |
| 10151 | DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT) |
| 10152 | DIMENSION X(3,260),WD(4),RD(3) |
| 10153 | |
| 10154 | DATA PDIF/0.545D0/,R2MIN/0.16D0/ |
| 10155 | DATA WD / 0.0D0, 0.178D0, 0.465D0, 1.0D0/ |
| 10156 | DATA RD /2.09D0, 0.935D0, 0.697D0/ |
| 10157 | |
| 10158 | X1SUM = ZERO |
| 10159 | X2SUM = ZERO |
| 10160 | X3SUM = ZERO |
| 10161 | |
| 10162 | IF (N.EQ.1) THEN |
| 10163 | X(1,1) = ZERO |
| 10164 | X(2,1) = ZERO |
| 10165 | X(3,1) = ZERO |
| 10166 | ELSEIF (N.EQ.2) THEN |
| 10167 | EPS = DT_RNDM(RD(1)) |
| 10168 | DO 30 I=1,3 |
| 10169 | IF ((EPS.GE.WD(I)).AND.(EPS.LE.WD(I+1))) GOTO 40 |
| 10170 | 30 CONTINUE |
| 10171 | 40 CONTINUE |
| 10172 | DO 50 J=1,3 |
| 10173 | CALL DT_RANNOR(X1,X2) |
| 10174 | X(J,1) = RD(I)*X1 |
| 10175 | X(J,2) = -X(J,1) |
| 10176 | 50 CONTINUE |
| 10177 | ELSEIF ((N.EQ.3).OR.(N.EQ.4)) THEN |
| 10178 | SIGMA = R/SQRTWO |
| 10179 | LSTART = .TRUE. |
| 10180 | CALL DT_RANNOR(X3,X4) |
| 10181 | DO 100 I=1,N |
| 10182 | CALL DT_RANNOR(X1,X2) |
| 10183 | X(1,I) = SIGMA*X1 |
| 10184 | X(2,I) = SIGMA*X2 |
| 10185 | IF (LSTART) GOTO 80 |
| 10186 | X(3,I) = SIGMA*X4 |
| 10187 | CALL DT_RANNOR(X3,X4) |
| 10188 | GOTO 90 |
| 10189 | 80 CONTINUE |
| 10190 | X(3,I) = SIGMA*X3 |
| 10191 | 90 CONTINUE |
| 10192 | LSTART = .NOT.LSTART |
| 10193 | X1SUM = X1SUM+X(1,I) |
| 10194 | X2SUM = X2SUM+X(2,I) |
| 10195 | X3SUM = X3SUM+X(3,I) |
| 10196 | 100 CONTINUE |
| 10197 | X1SUM = X1SUM/DBLE(N) |
| 10198 | X2SUM = X2SUM/DBLE(N) |
| 10199 | X3SUM = X3SUM/DBLE(N) |
| 10200 | DO 101 I=1,N |
| 10201 | X(1,I) = X(1,I)-X1SUM |
| 10202 | X(2,I) = X(2,I)-X2SUM |
| 10203 | X(3,I) = X(3,I)-X3SUM |
| 10204 | 101 CONTINUE |
| 10205 | ELSE |
| 10206 | |
| 10207 | * maximum nuclear radius for coordinate sampling |
| 10208 | RMAX = R+4.605D0*PDIF |
| 10209 | |
| 10210 | * initialize pre-sorting |
| 10211 | DO 121 I=1,NSRT |
| 10212 | ICSRT(I) = 0 |
| 10213 | 121 CONTINUE |
| 10214 | DR = TWO*RMAX/DBLE(NSRT) |
| 10215 | |
| 10216 | * sample coordinates for N nucleons |
| 10217 | DO 140 I=1,N |
| 10218 | 120 CONTINUE |
| 10219 | RAD = RMAX*(DT_RNDM(DR))**ONETHI |
| 10220 | F = DT_DENSIT(N,RAD,R) |
| 10221 | IF (DT_RNDM(RAD).GT.F) GOTO 120 |
| 10222 | * theta, phi uniformly distributed |
| 10223 | CT = ONE-TWO*DT_RNDM(F) |
| 10224 | ST = SQRT((ONE-CT)*(ONE+CT)) |
| 10225 | CALL DT_DSFECF(SFE,CFE) |
| 10226 | X(1,I) = RAD*ST*CFE |
| 10227 | X(2,I) = RAD*ST*SFE |
| 10228 | X(3,I) = RAD*CT |
| 10229 | * ensure that distance between two nucleons is greater than R2MIN |
| 10230 | IF (I.LT.2) GOTO 122 |
| 10231 | I1 = I-1 |
| 10232 | DO 130 I2=1,I1 |
| 10233 | DIST2 = (X(1,I)-X(1,I2))**2+(X(2,I)-X(2,I2))**2+ |
| 10234 | & (X(3,I)-X(3,I2))**2 |
| 10235 | IF (DIST2.LE.R2MIN) GOTO 120 |
| 10236 | 130 CONTINUE |
| 10237 | 122 CONTINUE |
| 10238 | * save index according to z-bin |
| 10239 | IDXZ = INT( (X(3,I)+RMAX)/DR )+1 |
| 10240 | ICSRT(IDXZ) = ICSRT(IDXZ)+1 |
| 10241 | IDXSRT(IDXZ,ICSRT(IDXZ)) = I |
| 10242 | X1SUM = X1SUM+X(1,I) |
| 10243 | X2SUM = X2SUM+X(2,I) |
| 10244 | X3SUM = X3SUM+X(3,I) |
| 10245 | 140 CONTINUE |
| 10246 | X1SUM = X1SUM/DBLE(N) |
| 10247 | X2SUM = X2SUM/DBLE(N) |
| 10248 | X3SUM = X3SUM/DBLE(N) |
| 10249 | DO 141 I=1,N |
| 10250 | X(1,I) = X(1,I)-X1SUM |
| 10251 | X(2,I) = X(2,I)-X2SUM |
| 10252 | X(3,I) = X(3,I)-X3SUM |
| 10253 | 141 CONTINUE |
| 10254 | |
| 10255 | ENDIF |
| 10256 | |
| 10257 | RETURN |
| 10258 | END |
| 10259 | * |
| 10260 | *===densit=============================================================* |
| 10261 | * |
| 10262 | CDECK ID>, DT_DENSIT |
| 10263 | DOUBLE PRECISION FUNCTION DT_DENSIT(NA,R,RA) |
| 10264 | |
| 10265 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 10266 | SAVE |
| 10267 | |
| 10268 | PARAMETER ( LINP = 5 , |
| 10269 | & LOUT = 6 , |
| 10270 | & LDAT = 9 ) |
| 10271 | |
| 10272 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) |
| 10273 | PARAMETER (TWOPI = 6.283185307179586476925286766559D+00, |
| 10274 | & PI = TWOPI/TWO) |
| 10275 | |
| 10276 | DIMENSION R0(18),FNORM(18) |
| 10277 | DATA R0 / ZERO, ZERO, ZERO, ZERO, 2.12D0, |
| 10278 | & 2.56D0, 2.41D0, 2.46D0, 2.52D0, 2.45D0, |
| 10279 | & 2.37D0, 2.46D0, 2.44D0, 2.54D0, 2.58D0, |
| 10280 | & 2.72D0, 2.66D0, 2.79D0/ |
| 10281 | DATA FNORM /.1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01, |
| 10282 | & .1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01, |
| 10283 | & .1012D+01,.1039D+01,.1075D+01,.1118D+01,.1164D+01, |
| 10284 | & .1214D+01,.1265D+01,.1318D+01/ |
| 10285 | DATA PDIF /0.545D0/ |
| 10286 | |
| 10287 | DT_DENSIT = ZERO |
| 10288 | * shell model |
| 10289 | IF (NA.LE.4) THEN |
| 10290 | STOP 'DT_DENSIT-0' |
| 10291 | ELSEIF ((NA.GT.4).AND.(NA.LE.18)) THEN |
| 10292 | R1 = R0(NA)/SQRT(2.5D0-4.0D0/DBLE(NA)) |
| 10293 | DT_DENSIT = (ONE+(DBLE(NA)-4.0D0)/6.0D0*(R/R1)**2) |
| 10294 | & *EXP(-(R/R1)**2)/FNORM(NA) |
| 10295 | * Woods-Saxon |
| 10296 | ELSEIF (NA.GT.18) THEN |
| 10297 | DT_DENSIT = ONE/(ONE+EXP((R-RA)/PDIF)) |
| 10298 | ENDIF |
| 10299 | |
| 10300 | RETURN |
| 10301 | END |
| 10302 | * |
| 10303 | *===rnclus=============================================================* |
| 10304 | * |
| 10305 | CDECK ID>, DT_RNCLUS |
| 10306 | DOUBLE PRECISION FUNCTION DT_RNCLUS(N) |
| 10307 | |
| 10308 | ************************************************************************ |
| 10309 | * Nuclear radius for nucleus with mass number N. * |
| 10310 | * This version dated 26.9.00 is written by S. Roesler * |
| 10311 | ************************************************************************ |
| 10312 | |
| 10313 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 10314 | SAVE |
| 10315 | |
| 10316 | PARAMETER (ONE=1.0D0,THREE=3.0D0,ONETHI=ONE/THREE) |
| 10317 | |
| 10318 | * nucleon radius |
| 10319 | PARAMETER (RNUCLE = 1.12D0) |
| 10320 | |
| 10321 | * nuclear radii for selected nuclei |
| 10322 | DIMENSION RADNUC(18) |
| 10323 | DATA RADNUC / 8*0.0D0,2.52D0,2.45D0,2.37D0,2.45D0,2.44D0,2.55D0, |
| 10324 | & 2.58D0,2.71D0,2.66D0,2.71D0/ |
| 10325 | |
| 10326 | IF (N.LE.18) THEN |
| 10327 | IF (RADNUC(N).GT.0.0D0) THEN |
| 10328 | DT_RNCLUS = RADNUC(N) |
| 10329 | ELSE |
| 10330 | DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI |
| 10331 | ENDIF |
| 10332 | ELSE |
| 10333 | DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI |
| 10334 | ENDIF |
| 10335 | |
| 10336 | RETURN |
| 10337 | END |
| 10338 | * |
| 10339 | *===dentst=============================================================* |
| 10340 | * |
| 10341 | C PROGRAM DT_DENTST |
| 10342 | CDECK ID>, DT_DENTST |
| 10343 | SUBROUTINE DT_DENTST |
| 10344 | |
| 10345 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 10346 | SAVE |
| 10347 | |
| 10348 | OPEN(40,FILE='dentst.out',STATUS='UNKNOWN') |
| 10349 | OPEN(41,FILE='denmax.out',STATUS='UNKNOWN') |
| 10350 | |
| 10351 | RMIN = 0.0D0 |
| 10352 | RMAX = 8.0D0 |
| 10353 | NBINS = 500.0D0 |
| 10354 | DR = (RMAX-RMIN)/DBLE(NBINS) |
| 10355 | DO 1 IA=5,18 |
| 10356 | FMAX = 0.0D0 |
| 10357 | DO 2 IR=1,NBINS+1 |
| 10358 | R = RMIN+DBLE(IR-1)*DR |
| 10359 | F = DT_DENSIT(IA,R,R) |
| 10360 | IF (F.GT.FMAX) FMAX = F |
| 10361 | WRITE(40,'(1X,I3,2E15.5)') IA,R,F |
| 10362 | 2 CONTINUE |
| 10363 | WRITE(41,'(1X,I3,E15.5)') IA,FMAX |
| 10364 | 1 CONTINUE |
| 10365 | |
| 10366 | CLOSE(40) |
| 10367 | CLOSE(41) |
| 10368 | |
| 10369 | END |
| 10370 | * |
| 10371 | *===shmaki=============================================================* |
| 10372 | * |
| 10373 | CDECK ID>, DT_SHMAKI |
| 10374 | SUBROUTINE DT_SHMAKI(NA,NCA,NB,NCB,IJP,PPN,MODE) |
| 10375 | |
| 10376 | ************************************************************************ |
| 10377 | * Initialisation of Glauber formalism. This subroutine has to be * |
| 10378 | * called once (in case of target emulsions as often as many different * |
| 10379 | * target nuclei are considered) before events are sampled. * |
| 10380 | * NA / NCA mass number/charge of projectile nucleus * |
| 10381 | * NB / NCB mass number/charge of target nucleus * |
| 10382 | * IJP identity of projectile (hadrons/leptons/photons) * |
| 10383 | * PPN projectile momentum (for projectile nuclei: * |
| 10384 | * momentum per nucleon) in target rest system * |
| 10385 | * MODE = 0 Glauber formalism invoked * |
| 10386 | * = 1 fitted results are loaded from data-file * |
| 10387 | * = 99 NTARG is forced to be 1 * |
| 10388 | * (used in connection with GLAUBERI-card only) * |
| 10389 | * This version dated 22.03.96 is based on the original SHMAKI-routine * |
| 10390 | * and revised by S. Roesler. * |
| 10391 | ************************************************************************ |
| 10392 | |
| 10393 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 10394 | SAVE |
| 10395 | |
| 10396 | PARAMETER ( LINP = 5 , |
| 10397 | & LOUT = 6 , |
| 10398 | & LDAT = 9 ) |
| 10399 | |
| 10400 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0, |
| 10401 | & THREE=3.0D0) |
| 10402 | |
| 10403 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 10404 | |
| 10405 | * Glauber formalism: parameters |
| 10406 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), |
| 10407 | & BMAX(NCOMPX),BSTEP(NCOMPX), |
| 10408 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), |
| 10409 | & NSITEB,NSTATB |
| 10410 | * Lorentz-parameters of the current interaction |
| 10411 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, |
| 10412 | & UMO,PPCM,EPROJ,PPROJ |
| 10413 | * properties of photon/lepton projectiles |
| 10414 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC |
| 10415 | * kinematical cuts for lepton-nucleus interactions |
| 10416 | COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX, |
| 10417 | & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI |
| 10418 | * Glauber formalism: cross sections |
| 10419 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, |
| 10420 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), |
| 10421 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), |
| 10422 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), |
| 10423 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), |
| 10424 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), |
| 10425 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), |
| 10426 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), |
| 10427 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), |
| 10428 | & BSLOPE,NEBINI,NQBINI |
| 10429 | * cuts for variable energy runs |
| 10430 | COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI |
| 10431 | * nucleon-nucleon event-generator |
| 10432 | CHARACTER*8 CMODEL |
| 10433 | LOGICAL LPHOIN |
| 10434 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN |
| 10435 | * Glauber formalism: flags and parameters for statistics |
| 10436 | LOGICAL LPROD |
| 10437 | CHARACTER*8 CGLB |
| 10438 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD |
| 10439 | |
| 10440 | DATA NTARG,ICOUT,IVEOUT /0,0,0/ |
| 10441 | |
| 10442 | C CALL DT_HISHAD |
| 10443 | C STOP |
| 10444 | |
| 10445 | NTARG = NTARG+1 |
| 10446 | IF (MODE.EQ.99) NTARG = 1 |
| 10447 | NIDX = -NTARG |
| 10448 | IF (MODE.EQ.-1) NIDX = NTARG |
| 10449 | |
| 10450 | IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) ICOUT = ICOUT+1 |
| 10451 | IF (ICOUT.EQ.1) WRITE(LOUT,1000) |
| 10452 | 1000 FORMAT(//,1X,'SHMAKI: Glauber formalism (Shmakov et. al) -', |
| 10453 | & ' initialization',/,12X,'--------------------------', |
| 10454 | & '-------------------------',/) |
| 10455 | |
| 10456 | IF (MODE.EQ.2) THEN |
| 10457 | CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX) |
| 10458 | CALL DT_SHFAST(MODE,PPN,IBACK) |
| 10459 | STOP ' Glauber pre-initialization done' |
| 10460 | ENDIF |
| 10461 | IF (MODE.EQ.1) THEN |
| 10462 | CALL DT_PROFBI(NA,NB,PPN,NTARG) |
| 10463 | ELSE |
| 10464 | IBACK = 1 |
| 10465 | IF (MODE.EQ.3) CALL DT_SHFAST(MODE,PPN,IBACK) |
| 10466 | IF (IBACK.EQ.1) THEN |
| 10467 | * lepton-nucleus (variable energy runs) |
| 10468 | IF ((IJP.EQ. 3).OR.(IJP.EQ. 4).OR. |
| 10469 | & (IJP.EQ.10).OR.(IJP.EQ.11)) THEN |
| 10470 | IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) |
| 10471 | & WRITE(LOUT,1002) NB,NCB |
| 10472 | 1002 FORMAT(1X,'variable energy run: projectile-id: 7', |
| 10473 | & ' target A/Z: ',I3,' /',I3,/,/,8X, |
| 10474 | & 'E_cm (GeV) Q^2 (GeV^2)', |
| 10475 | & ' Sigma_tot (mb) Sigma_in (mb)',/,7X, |
| 10476 | & '--------------------------------', |
| 10477 | & '------------------------------') |
| 10478 | AECMLO = LOG10(MIN(UMO,ECMLI)) |
| 10479 | AECMHI = LOG10(MIN(UMO,ECMHI)) |
| 10480 | IESTEP = NEB-1 |
| 10481 | DAECM = (AECMHI-AECMLO)/DBLE(IESTEP) |
| 10482 | IF (AECMLO.EQ.AECMHI) IESTEP = 0 |
| 10483 | DO 1 I=1,IESTEP+1 |
| 10484 | ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM) |
| 10485 | IF (Q2HI.GT.0.1D0) THEN |
| 10486 | IF (Q2LI.LT.0.01D0) THEN |
| 10487 | CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX) |
| 10488 | IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) |
| 10489 | & WRITE(LOUT,1003) |
| 10490 | & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG) |
| 10491 | Q2LI = 0.01D0 |
| 10492 | IBIN = 2 |
| 10493 | ELSE |
| 10494 | IBIN = 1 |
| 10495 | ENDIF |
| 10496 | IQSTEP = NQB-IBIN |
| 10497 | AQ2LO = LOG10(Q2LI) |
| 10498 | AQ2HI = LOG10(Q2HI) |
| 10499 | DAQ2 = (AQ2HI-AQ2LO)/MAX(DBLE(IQSTEP),ONE) |
| 10500 | DO 2 J=IBIN,IQSTEP+IBIN |
| 10501 | Q2 = 10.0D0**(AQ2LO+DBLE(J-IBIN)*DAQ2) |
| 10502 | CALL DT_XSGLAU(NA,NB,7,ZERO,Q2,ECM,I,J,NIDX) |
| 10503 | IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) |
| 10504 | & WRITE(LOUT,1003) ECMNN(I), |
| 10505 | & Q2G(J),XSTOT(I,J,NTARG),XSPRO(I,J,NTARG) |
| 10506 | 2 CONTINUE |
| 10507 | ELSE |
| 10508 | CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX) |
| 10509 | IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) |
| 10510 | & WRITE(LOUT,1003) |
| 10511 | & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG) |
| 10512 | ENDIF |
| 10513 | 1003 FORMAT(9X,F6.1,9X,F6.2,8X,F8.3,11X,F8.3) |
| 10514 | 1 CONTINUE |
| 10515 | IVEOUT = 1 |
| 10516 | ELSE |
| 10517 | * hadron/photon/nucleus-nucleus |
| 10518 | IF ((ABS(VAREHI).GT.ZERO).AND. |
| 10519 | & (ABS(VAREHI).GT.ABS(VARELO))) THEN |
| 10520 | IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) THEN |
| 10521 | WRITE(LOUT,1004) NA,NB,NCB |
| 10522 | 1004 FORMAT(1X,'variable energy run: projectile-id:', |
| 10523 | & I3,' target A/Z: ',I3,' /',I3,/) |
| 10524 | WRITE(LOUT,1005) |
| 10525 | 1005 FORMAT(' E_cm (GeV) E_Lab (GeV) sig_tot^pp (mb)' |
| 10526 | & ,' Sigma_tot (mb) Sigma_prod (mb)',/, |
| 10527 | & ' -------------------------------------', |
| 10528 | & '--------------------------------------') |
| 10529 | ENDIF |
| 10530 | AECMLO = LOG10(VARCLO) |
| 10531 | AECMHI = LOG10(VARCHI) |
| 10532 | IESTEP = NEB-1 |
| 10533 | DAECM = (AECMHI-AECMLO)/DBLE(IESTEP) |
| 10534 | IF (AECMLO.EQ.AECMHI) IESTEP = 0 |
| 10535 | DO 3 I=1,IESTEP+1 |
| 10536 | ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM) |
| 10537 | AMP = 0.938D0 |
| 10538 | AMT = 0.938D0 |
| 10539 | AMP2 = AMP**2 |
| 10540 | AMT2 = AMT**2 |
| 10541 | ELAB = (ECM**2-AMP2-AMT2)/(TWO*AMT) |
| 10542 | PLAB = SQRT((ELAB+AMP)*(ELAB-AMP)) |
| 10543 | CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,ECM,I,1,NIDX) |
| 10544 | IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) |
| 10545 | & WRITE(LOUT,1006) |
| 10546 | & ECM,PLAB,SIGSH,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG) |
| 10547 | 1006 FORMAT(1X,F9.1,1X,E11.3,1X,F12.2,8X,F10.3,8X,F8.3) |
| 10548 | 3 CONTINUE |
| 10549 | IVEOUT = 1 |
| 10550 | ELSE |
| 10551 | CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX) |
| 10552 | ENDIF |
| 10553 | ENDIF |
| 10554 | ENDIF |
| 10555 | ENDIF |
| 10556 | |
| 10557 | IF ((ICOUT.LT.15).AND.(IVEOUT.EQ.0).AND.(MCGENE.NE.4).AND. |
| 10558 | & (IOGLB.NE.100)) THEN |
| 10559 | WRITE(LOUT,1001) NA,NCA,NB,NCB,ECMNN(1),SIGSH*10.0D0,ROSH, |
| 10560 | & BSLOPE,NSITEB,NSTATB,XSPRO(1,1,NTARG) |
| 10561 | 1001 FORMAT(38X,'projectile', |
| 10562 | & ' target',/,1X,'Mass number / charge', |
| 10563 | & 17X,I3,' /',I3,6X,I3,' /',I3,/,/,1X, |
| 10564 | & 'Nucleon-nucleon c.m. energy',9X,F10.2,' GeV',/,/,1X, |
| 10565 | & 'Parameters of elastic scattering amplitude:',/,5X, |
| 10566 | & 'sigma =',F7.2,' mb',6X,'rho = ',F9.4,6X,'slope = ', |
| 10567 | & F4.1,' GeV^-2',/,/,1X,'Number of b-steps',4X,I3,8X, |
| 10568 | & 'statistics at each b-step',4X,I5,/,/,1X, |
| 10569 | & 'Prod. cross section ',5X,F10.4,' mb',/) |
| 10570 | ENDIF |
| 10571 | |
| 10572 | RETURN |
| 10573 | END |
| 10574 | * |
| 10575 | *===profbi=============================================================* |
| 10576 | * |
| 10577 | CDECK ID>, DT_PROFBI |
| 10578 | SUBROUTINE DT_PROFBI(NA,NB,PPN,NTARG) |
| 10579 | |
| 10580 | ************************************************************************ |
| 10581 | * Integral over profile function (to be used for impact-parameter * |
| 10582 | * sampling during event generation). * |
| 10583 | * Fitted results are used. * |
| 10584 | * NA / NB mass numbers of proj./target nuclei * |
| 10585 | * PPN projectile momentum (for projectile nuclei: * |
| 10586 | * momentum per nucleon) in target rest system * |
| 10587 | * NTARG index of target material (i.e. kind of nucleus) * |
| 10588 | * This version dated 31.05.95 is revised by S. Roesler * |
| 10589 | ************************************************************************ |
| 10590 | |
| 10591 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 10592 | SAVE |
| 10593 | |
| 10594 | PARAMETER ( LINP = 5 , |
| 10595 | & LOUT = 6 , |
| 10596 | & LDAT = 9 ) |
| 10597 | |
| 10598 | SAVE |
| 10599 | |
| 10600 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0) |
| 10601 | |
| 10602 | LOGICAL LSTART |
| 10603 | CHARACTER CNAME*80 |
| 10604 | |
| 10605 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 10606 | |
| 10607 | * Glauber formalism: parameters |
| 10608 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), |
| 10609 | & BMAX(NCOMPX),BSTEP(NCOMPX), |
| 10610 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), |
| 10611 | & NSITEB,NSTATB |
| 10612 | * Glauber formalism: cross sections |
| 10613 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, |
| 10614 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), |
| 10615 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), |
| 10616 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), |
| 10617 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), |
| 10618 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), |
| 10619 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), |
| 10620 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), |
| 10621 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), |
| 10622 | & BSLOPE,NEBINI,NQBINI |
| 10623 | |
| 10624 | PARAMETER (NGLMAX=8000) |
| 10625 | DIMENSION NGLIT(NGLMAX),NGLIP(NGLMAX),GLAPPN(NGLMAX), |
| 10626 | & GLASIG(NGLMAX),GLAFIT(5,NGLMAX) |
| 10627 | |
| 10628 | DATA LSTART /.TRUE./ |
| 10629 | |
| 10630 | IF (LSTART) THEN |
| 10631 | * read fit-parameters from file |
| 10632 | OPEN(47,FILE='inpdata/glpara.dat',STATUS='UNKNOWN') |
| 10633 | I = 0 |
| 10634 | 1 CONTINUE |
| 10635 | READ(47,'(A80)') CNAME |
| 10636 | IF (CNAME.EQ.'STOP') GOTO 2 |
| 10637 | I = I+1 |
| 10638 | READ(CNAME,*) NGLIP(I),NGLIT(I),GLAPPN(I),GLASIG(I), |
| 10639 | & GLAFIT(1,I),GLAFIT(2,I),GLAFIT(3,I), |
| 10640 | & GLAFIT(4,I),GLAFIT(5,I) |
| 10641 | IF (I+1.GT.NGLMAX) THEN |
| 10642 | WRITE(LOUT,1000) |
| 10643 | 1000 FORMAT(1X,'PROFBI: warning! array size exceeded - ', |
| 10644 | & 'program stopped') |
| 10645 | STOP |
| 10646 | ENDIF |
| 10647 | GOTO 1 |
| 10648 | 2 CONTINUE |
| 10649 | NGLPAR = I |
| 10650 | LSTART = .FALSE. |
| 10651 | ENDIF |
| 10652 | |
| 10653 | NNA = NA |
| 10654 | NNB = NB |
| 10655 | IF (NA.GT.NB) THEN |
| 10656 | NNA = NB |
| 10657 | NNB = NA |
| 10658 | ENDIF |
| 10659 | IDXGLA = 0 |
| 10660 | DO 3 J=1,NGLPAR |
| 10661 | IF ((NNB.LT.NGLIT(J)).OR.(J.EQ.NGLPAR)) THEN |
| 10662 | IF (NNB.NE.NGLIT(J-1)) NNB = NGLIT(J-1) |
| 10663 | DO 4 K=1,J-1 |
| 10664 | IPOINT = J-K |
| 10665 | IF (J.EQ.NGLPAR) IPOINT = J+1-K |
| 10666 | IF ((NNA.GT.NGLIP(IPOINT)).OR. |
| 10667 | & (NNB.NE.NGLIT(IPOINT)).OR.(IPOINT.EQ.1)) THEN |
| 10668 | IF (IPOINT.EQ.1) IPOINT = 0 |
| 10669 | NATMP = NGLIP(IPOINT+1) |
| 10670 | IF (PPN.LT.GLAPPN(IPOINT+1)) THEN |
| 10671 | IDXGLA = IPOINT+1 |
| 10672 | GOTO 6 |
| 10673 | ELSE |
| 10674 | J1BEG = IPOINT+1 |
| 10675 | J1END = J |
| 10676 | C IF (J.EQ.NGLPAR) THEN |
| 10677 | C J1BEG = IPOINT |
| 10678 | C J1END = J |
| 10679 | C ENDIF |
| 10680 | DO 5 J1=J1BEG,J1END |
| 10681 | IF (NGLIP(J1).EQ.NATMP) THEN |
| 10682 | IF (PPN.LT.GLAPPN(J1)) THEN |
| 10683 | IDXGLA = J1 |
| 10684 | GOTO 6 |
| 10685 | ENDIF |
| 10686 | ELSE |
| 10687 | IDXGLA = J1-1 |
| 10688 | GOTO 6 |
| 10689 | ENDIF |
| 10690 | 5 CONTINUE |
| 10691 | IF ((J.EQ.NGLPAR).AND.(PPN.GT.GLAPPN(NGLPAR))) |
| 10692 | & IDXGLA = NGLPAR |
| 10693 | ENDIF |
| 10694 | ENDIF |
| 10695 | 4 CONTINUE |
| 10696 | ENDIF |
| 10697 | 3 CONTINUE |
| 10698 | |
| 10699 | 6 CONTINUE |
| 10700 | IF (IDXGLA.EQ.0) THEN |
| 10701 | WRITE(LOUT,1001) NNA,NNB,PPN |
| 10702 | 1001 FORMAT(1X,'PROFBI: configuration (NA,NB,PPN = ', |
| 10703 | & 2I4,F6.0,') not found ') |
| 10704 | STOP |
| 10705 | ENDIF |
| 10706 | |
| 10707 | * no interpolation yet available |
| 10708 | XSPRO(1,1,NTARG) = GLASIG(IDXGLA) |
| 10709 | |
| 10710 | BSITE(1,1,NTARG,1) = ZERO |
| 10711 | DO 10 I=2,NSITEB |
| 10712 | XX = DBLE(I) |
| 10713 | POLY = GLAFIT(1,IDXGLA)+GLAFIT(2,IDXGLA)*XX+ |
| 10714 | & GLAFIT(3,IDXGLA)*XX**2+GLAFIT(4,IDXGLA)*XX**3+ |
| 10715 | & GLAFIT(5,IDXGLA)*XX**4 |
| 10716 | IF (ABS(POLY).GT.35.0D0) POLY = SIGN(35.0D0,POLY) |
| 10717 | BSITE(1,1,NTARG,I) = (1.0D0-EXP(-POLY)) |
| 10718 | IF (BSITE(1,1,NTARG,I).LT.ZERO) BSITE(1,1,NTARG,I) = ZERO |
| 10719 | 10 CONTINUE |
| 10720 | |
| 10721 | RETURN |
| 10722 | END |
| 10723 | * |
| 10724 | *===glaube=============================================================* |
| 10725 | * |
| 10726 | CDECK ID>, DT_GLAUBE |
| 10727 | SUBROUTINE DT_GLAUBE(NA,NB,IJPROJ,B,INTT,INTA,INTB,JS,JT,NIDX) |
| 10728 | |
| 10729 | ************************************************************************ |
| 10730 | * Calculation of configuartion of interacting nucleons for one event. * |
| 10731 | * NA / NB mass numbers of proj./target nuclei (input) * |
| 10732 | * B impact parameter (output) * |
| 10733 | * INTT total number of wounded nucleons " * |
| 10734 | * INTA / INTB number of wounded nucleons in proj. / target " * |
| 10735 | * JS / JT(i) number of collisions proj. / target nucleon i is * |
| 10736 | * involved (output) * |
| 10737 | * NIDX index of projectile/target material (input)* |
| 10738 | * This is an update of the original routine SHMAKO by J.Ranft/HJM * |
| 10739 | * This version dated 22.03.96 is revised by S. Roesler * |
| 10740 | ************************************************************************ |
| 10741 | |
| 10742 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 10743 | SAVE |
| 10744 | |
| 10745 | PARAMETER ( LINP = 5 , |
| 10746 | & LOUT = 6 , |
| 10747 | & LDAT = 9 ) |
| 10748 | |
| 10749 | PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14, |
| 10750 | & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0) |
| 10751 | |
| 10752 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 10753 | |
| 10754 | PARAMETER ( MAXNCL = 260, |
| 10755 | |
| 10756 | & MAXVQU = MAXNCL, |
| 10757 | & MAXSQU = 20*MAXVQU, |
| 10758 | & MAXINT = MAXVQU+MAXSQU) |
| 10759 | * Glauber formalism: parameters |
| 10760 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), |
| 10761 | & BMAX(NCOMPX),BSTEP(NCOMPX), |
| 10762 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), |
| 10763 | & NSITEB,NSTATB |
| 10764 | * Glauber formalism: cross sections |
| 10765 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, |
| 10766 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), |
| 10767 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), |
| 10768 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), |
| 10769 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), |
| 10770 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), |
| 10771 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), |
| 10772 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), |
| 10773 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), |
| 10774 | & BSLOPE,NEBINI,NQBINI |
| 10775 | * Lorentz-parameters of the current interaction |
| 10776 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, |
| 10777 | & UMO,PPCM,EPROJ,PPROJ |
| 10778 | * properties of photon/lepton projectiles |
| 10779 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC |
| 10780 | * Glauber formalism: collision properties |
| 10781 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, |
| 10782 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC |
| 10783 | * Glauber formalism: flags and parameters for statistics |
| 10784 | LOGICAL LPROD |
| 10785 | CHARACTER*8 CGLB |
| 10786 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD |
| 10787 | |
| 10788 | DIMENSION JS(MAXNCL),JT(MAXNCL) |
| 10789 | |
| 10790 | NTARG = ABS(NIDX) |
| 10791 | |
| 10792 | * get actual energy from /DTLTRA/ |
| 10793 | ECMNOW = UMO |
| 10794 | Q2 = VIRT |
| 10795 | * |
| 10796 | * new patch for pre-initialized variable projectile/target/energy runs |
| 10797 | IF (IOGLB.EQ.100) THEN |
| 10798 | CALL DT_GLBSET(IJPROJ,NA,NB,EPROJ,1) |
| 10799 | * |
| 10800 | * variable energy run, interpolate profile function |
| 10801 | ELSE |
| 10802 | I1 = 1 |
| 10803 | I2 = 1 |
| 10804 | RATE = ONE |
| 10805 | IF (NEBINI.GT.1) THEN |
| 10806 | IF (ECMNOW.GE.ECMNN(NEBINI)) THEN |
| 10807 | I1 = NEBINI |
| 10808 | I2 = NEBINI |
| 10809 | RATE = ONE |
| 10810 | ELSEIF (ECMNOW.GT.ECMNN(1)) THEN |
| 10811 | DO 1 I=2,NEBINI |
| 10812 | IF (ECMNOW.LT.ECMNN(I)) THEN |
| 10813 | I1 = I-1 |
| 10814 | I2 = I |
| 10815 | RATE = (ECMNOW-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1)) |
| 10816 | GOTO 2 |
| 10817 | ENDIF |
| 10818 | 1 CONTINUE |
| 10819 | 2 CONTINUE |
| 10820 | ENDIF |
| 10821 | ENDIF |
| 10822 | J1 = 1 |
| 10823 | J2 = 1 |
| 10824 | RATQ = ONE |
| 10825 | IF (NQBINI.GT.1) THEN |
| 10826 | IF (Q2.GE.Q2G(NQBINI)) THEN |
| 10827 | J1 = NQBINI |
| 10828 | J2 = NQBINI |
| 10829 | RATQ = ONE |
| 10830 | ELSEIF (Q2.GT.Q2G(1)) THEN |
| 10831 | DO 3 I=2,NQBINI |
| 10832 | IF (Q2.LT.Q2G(I)) THEN |
| 10833 | J1 = I-1 |
| 10834 | J2 = I |
| 10835 | RATQ = LOG10( Q2/MAX(Q2G(J1),TINY14))/ |
| 10836 | & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14)) |
| 10837 | C RATQ = (Q2-Q2G(J1))/(Q2G(J2)-Q2G(J1)) |
| 10838 | GOTO 4 |
| 10839 | ENDIF |
| 10840 | 3 CONTINUE |
| 10841 | 4 CONTINUE |
| 10842 | ENDIF |
| 10843 | ENDIF |
| 10844 | |
| 10845 | DO 5 I=1,KSITEB |
| 10846 | BSITE(0,1,NTARG,I) = BSITE(I1,J1,NTARG,I)+ |
| 10847 | & RATE*(BSITE(I2,J1,NTARG,I)-BSITE(I1,J1,NTARG,I))+ |
| 10848 | & RATQ*(BSITE(I1,J2,NTARG,I)-BSITE(I1,J1,NTARG,I))+ |
| 10849 | & RATE*RATQ*(BSITE(I2,J2,NTARG,I)-BSITE(I1,J2,NTARG,I)+ |
| 10850 | & BSITE(I1,J1,NTARG,I)-BSITE(I2,J1,NTARG,I)) |
| 10851 | 5 CONTINUE |
| 10852 | ENDIF |
| 10853 | |
| 10854 | CALL DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,INTT,INTA,INTB,IDIREC,NIDX) |
| 10855 | IF (NIDX.LE.-1) THEN |
| 10856 | RPROJ = RASH(1) |
| 10857 | RTARG = RBSH(NTARG) |
| 10858 | ELSE |
| 10859 | RPROJ = RASH(NTARG) |
| 10860 | RTARG = RBSH(1) |
| 10861 | ENDIF |
| 10862 | |
| 10863 | RETURN |
| 10864 | END |
| 10865 | * |
| 10866 | *===diagr==============================================================* |
| 10867 | * |
| 10868 | CDECK ID>, DT_DIAGR |
| 10869 | SUBROUTINE DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,JNT,INTA,INTB,IDIREC, |
| 10870 | & NIDX) |
| 10871 | |
| 10872 | ************************************************************************ |
| 10873 | * Based on the original version by Shmakov et al. * |
| 10874 | * This version dated 21.04.95 is revised by S. Roesler * |
| 10875 | ************************************************************************ |
| 10876 | |
| 10877 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 10878 | SAVE |
| 10879 | |
| 10880 | PARAMETER ( LINP = 5 , |
| 10881 | & LOUT = 6 , |
| 10882 | & LDAT = 9 ) |
| 10883 | |
| 10884 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) |
| 10885 | PARAMETER (TWOPI = 6.283185307179586454D+00, |
| 10886 | & PI = TWOPI/TWO, |
| 10887 | & GEV2MB = 0.38938D0, |
| 10888 | & GEV2FM = 0.1972D0, |
| 10889 | & ALPHEM = ONE/137.0D0, |
| 10890 | * proton mass |
| 10891 | & AMP = 0.938D0, |
| 10892 | & AMP2 = AMP**2, |
| 10893 | * rho0 mass |
| 10894 | & AMRHO0 = 0.77D0) |
| 10895 | |
| 10896 | COMPLEX*16 C,CA,CI |
| 10897 | |
| 10898 | PARAMETER ( MAXNCL = 260, |
| 10899 | |
| 10900 | & MAXVQU = MAXNCL, |
| 10901 | & MAXSQU = 20*MAXVQU, |
| 10902 | & MAXINT = MAXVQU+MAXSQU) |
| 10903 | * particle properties (BAMJET index convention) |
| 10904 | CHARACTER*8 ANAME |
| 10905 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 10906 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 10907 | |
| 10908 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 10909 | |
| 10910 | * emulsion treatment |
| 10911 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), |
| 10912 | & NCOMPO,IEMUL |
| 10913 | * Glauber formalism: parameters |
| 10914 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), |
| 10915 | & BMAX(NCOMPX),BSTEP(NCOMPX), |
| 10916 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), |
| 10917 | & NSITEB,NSTATB |
| 10918 | * Glauber formalism: cross sections |
| 10919 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, |
| 10920 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), |
| 10921 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), |
| 10922 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), |
| 10923 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), |
| 10924 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), |
| 10925 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), |
| 10926 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), |
| 10927 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), |
| 10928 | & BSLOPE,NEBINI,NQBINI |
| 10929 | * VDM parameter for photon-nucleus interactions |
| 10930 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) |
| 10931 | * nucleon-nucleon event-generator |
| 10932 | CHARACTER*8 CMODEL |
| 10933 | LOGICAL LPHOIN |
| 10934 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN |
| 10935 | **PHOJET105a |
| 10936 | C COMMON /CUTOFF/ PTCUT(4),CUTMU(4),FPS(4),FPH(4),PSOMIN,XSOMIN |
| 10937 | **PHOJET112 |
| 10938 | C obsolete cut-off information |
| 10939 | DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN |
| 10940 | COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN |
| 10941 | ** |
| 10942 | * coordinates of nucleons |
| 10943 | COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL) |
| 10944 | * interface between Glauber formalism and DPM |
| 10945 | COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL), |
| 10946 | & INTER1(MAXINT),INTER2(MAXINT) |
| 10947 | * statistics: Glauber-formalism |
| 10948 | COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB |
| 10949 | * n-n cross section fluctuations |
| 10950 | PARAMETER (NBINS = 1000) |
| 10951 | COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT |
| 10952 | |
| 10953 | DIMENSION JS(MAXNCL),JT(MAXNCL), |
| 10954 | & JS0(MAXNCL),JT0(MAXNCL,MAXNCL), |
| 10955 | & JI1(MAXNCL,MAXNCL),JI2(MAXNCL,MAXNCL),JNT0(MAXNCL) |
| 10956 | DIMENSION NWA(0:210),NWB(0:210) |
| 10957 | |
| 10958 | LOGICAL LFIRST |
| 10959 | DATA LFIRST /.TRUE./ |
| 10960 | |
| 10961 | DATA NTARGO,ICNT /0,0/ |
| 10962 | |
| 10963 | NTARG = ABS(NIDX) |
| 10964 | |
| 10965 | IF (LFIRST) THEN |
| 10966 | LFIRST = .FALSE. |
| 10967 | IF (NCOMPO.EQ.0) THEN |
| 10968 | NCALL = 0 |
| 10969 | NWAMAX = NA |
| 10970 | NWBMAX = NB |
| 10971 | DO 17 I=0,210 |
| 10972 | NWA(I) = 0 |
| 10973 | NWB(I) = 0 |
| 10974 | 17 CONTINUE |
| 10975 | ENDIF |
| 10976 | ENDIF |
| 10977 | IF (NTARG.EQ.-1) THEN |
| 10978 | IF (NCOMPO.EQ.0) THEN |
| 10979 | WRITE(LOUT,*) ' DIAGR: distribution of wounded nucleons' |
| 10980 | WRITE(LOUT,'(8X,A,3I7)') 'NCALL,NWAMAX,NWBMAX = ', |
| 10981 | & NCALL,NWAMAX,NWBMAX |
| 10982 | DO 18 I=1,MAX(NWAMAX,NWBMAX) |
| 10983 | WRITE(LOUT,'(8X,2I7,E12.4,I7,E12.4)') |
| 10984 | & I,NWA(I),DBLE(NWA(I))/DBLE(NCALL), |
| 10985 | & NWB(I),DBLE(NWB(I))/DBLE(NCALL) |
| 10986 | 18 CONTINUE |
| 10987 | ENDIF |
| 10988 | RETURN |
| 10989 | ENDIF |
| 10990 | |
| 10991 | DCOH = 1.0D10 |
| 10992 | IPNT = 0 |
| 10993 | |
| 10994 | SQ2 = Q2 |
| 10995 | IF (SQ2.LE.ZERO) SQ2 = 0.0001D0 |
| 10996 | S = ECMNOW**2 |
| 10997 | X = SQ2/(S+SQ2-AMP2) |
| 10998 | XNU = (S+SQ2-AMP2)/(TWO*AMP) |
| 10999 | * photon projectiles: recalculate photon-nucleon amplitude |
| 11000 | IF (IJPROJ.EQ.7) THEN |
| 11001 | 15 CONTINUE |
| 11002 | * VDM assumption: mass of V-meson |
| 11003 | AMV2 = DT_SAM2(SQ2,ECMNOW) |
| 11004 | AMV = SQRT(AMV2) |
| 11005 | IF (AMV.GT.2.0D0*PTCUT(1)) GOTO 15 |
| 11006 | * check for pointlike interaction |
| 11007 | CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,1) |
| 11008 | **sr 27.10. |
| 11009 | C SIGSH = DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0 |
| 11010 | SIGSH = (ONE-RPNT)*DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0 |
| 11011 | ** |
| 11012 | ROSH = 0.1D0 |
| 11013 | BSLOPE = 2.0D0*(2.0D0+AMRHO0**2/(AMV2+SQ2) |
| 11014 | & +0.25D0*LOG(S/(AMV2+SQ2))) |
| 11015 | * coherence length |
| 11016 | IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+SQ2)*GEV2FM |
| 11017 | ELSEIF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN |
| 11018 | IF (MCGENE.EQ.2) THEN |
| 11019 | ZERO1 = ZERO |
| 11020 | CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SDUM1,SDUM2,SDUM3, |
| 11021 | & BSLOPE,0) |
| 11022 | ELSE |
| 11023 | BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S)) |
| 11024 | ENDIF |
| 11025 | IF (ECMNOW.LE.3.0D0) THEN |
| 11026 | ROSH = -0.43D0 |
| 11027 | ELSEIF ((ECMNOW.GT.3.0D0).AND.(ECMNOW.LE.50.D0)) THEN |
| 11028 | ROSH = -0.63D0+0.175D0*LOG(ECMNOW) |
| 11029 | ELSEIF (ECMNOW.GT.50.0D0) THEN |
| 11030 | ROSH = 0.1D0 |
| 11031 | ENDIF |
| 11032 | ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP) |
| 11033 | PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) ) |
| 11034 | IF (MCGENE.EQ.2) THEN |
| 11035 | ZERO1 = ZERO |
| 11036 | CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SIGSH,SDUM2,SDUM3, |
| 11037 | & BDUM,0) |
| 11038 | SIGSH = SIGSH/10.0D0 |
| 11039 | ELSE |
| 11040 | C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0 |
| 11041 | DUMZER = ZERO |
| 11042 | CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL) |
| 11043 | SIGSH = SIGSH/10.0D0 |
| 11044 | ENDIF |
| 11045 | ELSE |
| 11046 | BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S)) |
| 11047 | ROSH = 0.01D0 |
| 11048 | ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP) |
| 11049 | PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) ) |
| 11050 | C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0 |
| 11051 | DUMZER = ZERO |
| 11052 | CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL) |
| 11053 | SIGSH = SIGSH/10.0D0 |
| 11054 | ENDIF |
| 11055 | GSH = 10.0D0/(TWO*BSLOPE*GEV2MB) |
| 11056 | GAM = GSH |
| 11057 | RCA = GAM*SIGSH/TWOPI |
| 11058 | FCA = -ROSH*RCA |
| 11059 | CA = DCMPLX(RCA,FCA) |
| 11060 | CI = DCMPLX(ONE,ZERO) |
| 11061 | |
| 11062 | 16 CONTINUE |
| 11063 | * impact parameter |
| 11064 | IF (MCGENE.NE.3) CALL DT_MODB(B,NIDX) |
| 11065 | |
| 11066 | NTRY = 0 |
| 11067 | 3 CONTINUE |
| 11068 | NTRY = NTRY+1 |
| 11069 | * initializations |
| 11070 | JNT = 0 |
| 11071 | DO 1 I=1,NA |
| 11072 | JS(I) = 0 |
| 11073 | 1 CONTINUE |
| 11074 | DO 2 I=1,NB |
| 11075 | JT(I) = 0 |
| 11076 | 2 CONTINUE |
| 11077 | IF (IJPROJ.EQ.7) THEN |
| 11078 | DO 8 I=1,MAXNCL |
| 11079 | JS0(I) = 0 |
| 11080 | JNT0(I)= 0 |
| 11081 | DO 9 J=1,NB |
| 11082 | JT0(I,J) = 0 |
| 11083 | 9 CONTINUE |
| 11084 | 8 CONTINUE |
| 11085 | ENDIF |
| 11086 | |
| 11087 | * nucleon configuration |
| 11088 | C IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,5).EQ.0)) THEN |
| 11089 | IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,1).EQ.0)) THEN |
| 11090 | C CALL DT_CONUCL(PKOO,NA,RASH,2) |
| 11091 | C CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),1) |
| 11092 | IF (NIDX.LE.-1) THEN |
| 11093 | CALL DT_CONUCL(PKOO,NA,RASH(1),0) |
| 11094 | CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),0) |
| 11095 | ELSE |
| 11096 | CALL DT_CONUCL(PKOO,NA,RASH(NTARG),0) |
| 11097 | CALL DT_CONUCL(TKOO,NB,RBSH(1),0) |
| 11098 | ENDIF |
| 11099 | NTARGO = NTARG |
| 11100 | ENDIF |
| 11101 | ICNT = ICNT+1 |
| 11102 | |
| 11103 | * LEPTO: pick out one struck nucleon |
| 11104 | IF (MCGENE.EQ.3) THEN |
| 11105 | JNT = 1 |
| 11106 | JS(1) = 1 |
| 11107 | IDX = INT(DT_RNDM(X)*NB)+1 |
| 11108 | JT(IDX) = 1 |
| 11109 | B = ZERO |
| 11110 | GOTO 19 |
| 11111 | ENDIF |
| 11112 | |
| 11113 | DO 4 INA=1,NA |
| 11114 | * cross section fluctuations |
| 11115 | AFLUC = ONE |
| 11116 | IF (IFLUCT.EQ.1) THEN |
| 11117 | IFLUK = INT((DT_RNDM(X)+0.001D0)*1000.0D0) |
| 11118 | AFLUC = FLUIXX(IFLUK) |
| 11119 | ENDIF |
| 11120 | KK1 = 1 |
| 11121 | KINT = 1 |
| 11122 | DO 5 INB=1,NB |
| 11123 | * photon-projectile: check for supression by coherence length |
| 11124 | IF (IJPROJ.EQ.7) THEN |
| 11125 | IF (ABS(TKOO(3,INB)-TKOO(3,KK1)).GT.DCOH) THEN |
| 11126 | KK1 = INB |
| 11127 | KINT = KINT+1 |
| 11128 | ENDIF |
| 11129 | ENDIF |
| 11130 | QQ1 = B+TKOO(1,INB)-PKOO(1,INA) |
| 11131 | QQ2 = TKOO(2,INB)-PKOO(2,INA) |
| 11132 | XY = GAM*(QQ1*QQ1+QQ2*QQ2) |
| 11133 | IF (XY.LE.15.0D0) THEN |
| 11134 | C = CI-CA*AFLUC*EXP(-XY) |
| 11135 | AR = DBLE(C) |
| 11136 | AI = DIMAG(C) |
| 11137 | P = AR*AR+AI*AI |
| 11138 | IF (DT_RNDM(XY).GE.P) THEN |
| 11139 | JNT = JNT+1 |
| 11140 | IF (IJPROJ.EQ.7) THEN |
| 11141 | JNT0(KINT) = JNT0(KINT)+1 |
| 11142 | IF (JNT0(KINT).GT.MAXNCL) THEN |
| 11143 | WRITE(LOUT,1001) MAXNCL |
| 11144 | 1001 FORMAT(1X, |
| 11145 | & 'DIAGR: no. of requested interactions', |
| 11146 | & ' exceeds array dimensions ',I4) |
| 11147 | STOP |
| 11148 | ENDIF |
| 11149 | JS0(KINT) = JS0(KINT)+1 |
| 11150 | JT0(KINT,INB) = JT0(KINT,INB)+1 |
| 11151 | JI1(KINT,JNT0(KINT)) = INA |
| 11152 | JI2(KINT,JNT0(KINT)) = INB |
| 11153 | ELSE |
| 11154 | IF (JNT.GT.MAXINT) THEN |
| 11155 | WRITE(LOUT,1000) JNT, MAXINT |
| 11156 | 1000 FORMAT(1X, |
| 11157 | & 'DIAGR: no. of requested interactions (' |
| 11158 | & ,I4,') exceeds array dimensions (',I4,')') |
| 11159 | STOP |
| 11160 | ENDIF |
| 11161 | JS(INA) = JS(INA)+1 |
| 11162 | JT(INB) = JT(INB)+1 |
| 11163 | INTER1(JNT) = INA |
| 11164 | INTER2(JNT) = INB |
| 11165 | ENDIF |
| 11166 | ENDIF |
| 11167 | ENDIF |
| 11168 | 5 CONTINUE |
| 11169 | 4 CONTINUE |
| 11170 | |
| 11171 | IF (JNT.EQ.0) THEN |
| 11172 | IF (NTRY.LT.500) THEN |
| 11173 | GOTO 3 |
| 11174 | ELSE |
| 11175 | C WRITE(6,*) ' new impact parameter required (old= ',B,')' |
| 11176 | GOTO 16 |
| 11177 | ENDIF |
| 11178 | ENDIF |
| 11179 | |
| 11180 | IDIREC = 0 |
| 11181 | IF (IJPROJ.EQ.7) THEN |
| 11182 | K = INT(ONE+DT_RNDM(X)*DBLE(KINT)) |
| 11183 | 10 CONTINUE |
| 11184 | IF (JNT0(K).EQ.0) THEN |
| 11185 | K = K+1 |
| 11186 | IF (K.GT.KINT) K = 1 |
| 11187 | GOTO 10 |
| 11188 | ENDIF |
| 11189 | * supress Glauber-cascade by direct photon processes |
| 11190 | CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,2) |
| 11191 | IF (IPNT.GT.0) THEN |
| 11192 | JNT = 1 |
| 11193 | JS(1) = 1 |
| 11194 | DO 11 INB=1,NB |
| 11195 | JT(INB) = JT0(K,INB) |
| 11196 | IF (JT(INB).GT.0) GOTO 12 |
| 11197 | 11 CONTINUE |
| 11198 | 12 CONTINUE |
| 11199 | INTER1(1) = 1 |
| 11200 | INTER2(1) = INB |
| 11201 | IDIREC = IPNT |
| 11202 | ELSE |
| 11203 | JNT = JNT0(K) |
| 11204 | JS(1) = JS0(K) |
| 11205 | DO 13 INB=1,NB |
| 11206 | JT(INB) = JT0(K,INB) |
| 11207 | 13 CONTINUE |
| 11208 | DO 14 I=1,JNT |
| 11209 | INTER1(I) = JI1(K,I) |
| 11210 | INTER2(I) = JI2(K,I) |
| 11211 | 14 CONTINUE |
| 11212 | ENDIF |
| 11213 | ENDIF |
| 11214 | |
| 11215 | 19 CONTINUE |
| 11216 | INTA = 0 |
| 11217 | INTB = 0 |
| 11218 | DO 6 I=1,NA |
| 11219 | IF (JS(I).NE.0) INTA=INTA+1 |
| 11220 | 6 CONTINUE |
| 11221 | DO 7 I=1,NB |
| 11222 | IF (JT(I).NE.0) INTB=INTB+1 |
| 11223 | 7 CONTINUE |
| 11224 | ICWPG = INTA |
| 11225 | ICWTG = INTB |
| 11226 | ICIG = JNT |
| 11227 | IPGLB = IPGLB+INTA |
| 11228 | ITGLB = ITGLB+INTB |
| 11229 | NGLB = NGLB+1 |
| 11230 | |
| 11231 | IF (NCOMPO.EQ.0) THEN |
| 11232 | NCALL = NCALL+1 |
| 11233 | NWA(INTA) = NWA(INTA)+1 |
| 11234 | NWB(INTB) = NWB(INTB)+1 |
| 11235 | ENDIF |
| 11236 | |
| 11237 | RETURN |
| 11238 | END |
| 11239 | * |
| 11240 | *===modb===============================================================* |
| 11241 | * |
| 11242 | CDECK ID>, DT_MODB |
| 11243 | SUBROUTINE DT_MODB(B,NIDX) |
| 11244 | |
| 11245 | ************************************************************************ |
| 11246 | * Sampling of impact parameter of collision. * |
| 11247 | * B impact parameter (output) * |
| 11248 | * NIDX index of projectile/target material (input)* |
| 11249 | * Based on the original version by Shmakov et al. * |
| 11250 | * This version dated 21.04.95 is revised by S. Roesler * |
| 11251 | ************************************************************************ |
| 11252 | |
| 11253 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 11254 | SAVE |
| 11255 | |
| 11256 | PARAMETER ( LINP = 5 , |
| 11257 | & LOUT = 6 , |
| 11258 | & LDAT = 9 ) |
| 11259 | |
| 11260 | PARAMETER (ZERO=0.0D0,TINY15=1.0D-15,ONE=1.0D0,TWO=2.0D0) |
| 11261 | |
| 11262 | LOGICAL LEFT,LFIRST |
| 11263 | |
| 11264 | * central particle production, impact parameter biasing |
| 11265 | COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR |
| 11266 | |
| 11267 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 11268 | |
| 11269 | * Glauber formalism: parameters |
| 11270 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), |
| 11271 | & BMAX(NCOMPX),BSTEP(NCOMPX), |
| 11272 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), |
| 11273 | & NSITEB,NSTATB |
| 11274 | * Glauber formalism: cross sections |
| 11275 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, |
| 11276 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), |
| 11277 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), |
| 11278 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), |
| 11279 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), |
| 11280 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), |
| 11281 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), |
| 11282 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), |
| 11283 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), |
| 11284 | & BSLOPE,NEBINI,NQBINI |
| 11285 | |
| 11286 | DATA LFIRST /.TRUE./ |
| 11287 | |
| 11288 | NTARG = ABS(NIDX) |
| 11289 | IF (NIDX.LE.-1) THEN |
| 11290 | RA = RASH(1) |
| 11291 | RB = RBSH(NTARG) |
| 11292 | ELSE |
| 11293 | RA = RASH(NTARG) |
| 11294 | RB = RBSH(1) |
| 11295 | ENDIF |
| 11296 | |
| 11297 | IF (ICENTR.EQ.2) THEN |
| 11298 | IF (RA.EQ.RB) THEN |
| 11299 | BB = DT_RNDM(B)*(0.3D0*RA)**2 |
| 11300 | B = SQRT(BB) |
| 11301 | ELSEIF(RA.LT.RB)THEN |
| 11302 | BB = DT_RNDM(B)*1.4D0*(RB-RA)**2 |
| 11303 | B = SQRT(BB) |
| 11304 | ELSEIF(RA.GT.RB)THEN |
| 11305 | BB = DT_RNDM(B)*1.4D0*(RA-RB)**2 |
| 11306 | B = SQRT(BB) |
| 11307 | ENDIF |
| 11308 | ELSE |
| 11309 | 9 CONTINUE |
| 11310 | Y = DT_RNDM(BB) |
| 11311 | I0 = 1 |
| 11312 | I2 = NSITEB |
| 11313 | 10 CONTINUE |
| 11314 | I1 = (I0+I2)/2 |
| 11315 | LEFT = ((BSITE(0,1,NTARG,I0)-Y) |
| 11316 | & *(BSITE(0,1,NTARG,I1)-Y)).LT.ZERO |
| 11317 | IF (LEFT) GOTO 20 |
| 11318 | I0 = I1 |
| 11319 | GOTO 30 |
| 11320 | 20 CONTINUE |
| 11321 | I2 = I1 |
| 11322 | 30 CONTINUE |
| 11323 | IF (I2-I0-2) 40,50,60 |
| 11324 | 40 CONTINUE |
| 11325 | I1 = I2+1 |
| 11326 | IF (I1.GT.NSITEB) I1 = I0-1 |
| 11327 | GOTO 70 |
| 11328 | 50 CONTINUE |
| 11329 | I1 = I0+1 |
| 11330 | GOTO 70 |
| 11331 | 60 CONTINUE |
| 11332 | GOTO 10 |
| 11333 | 70 CONTINUE |
| 11334 | X0 = DBLE(I0-1)*BSTEP(NTARG) |
| 11335 | X1 = DBLE(I1-1)*BSTEP(NTARG) |
| 11336 | X2 = DBLE(I2-1)*BSTEP(NTARG) |
| 11337 | Y0 = BSITE(0,1,NTARG,I0) |
| 11338 | Y1 = BSITE(0,1,NTARG,I1) |
| 11339 | Y2 = BSITE(0,1,NTARG,I2) |
| 11340 | 80 CONTINUE |
| 11341 | B = X0*(Y-Y1)*(Y-Y2)/((Y0-Y1)*(Y0-Y2)+TINY15)+ |
| 11342 | & X1*(Y-Y0)*(Y-Y2)/((Y1-Y0)*(Y1-Y2)+TINY15)+ |
| 11343 | & X2*(Y-Y0)*(Y-Y1)/((Y2-Y0)*(Y2-Y1)+TINY15) |
| 11344 | **sr 5.4.98: shift B by half the bin width to be in agreement with BPROD |
| 11345 | B = B+0.5D0*BSTEP(NTARG) |
| 11346 | IF (B.LT.ZERO) B = X1 |
| 11347 | IF (B.GT.BMAX(NTARG)) B = BMAX(NTARG) |
| 11348 | IF (ICENTR.LT.0) THEN |
| 11349 | IF (LFIRST) THEN |
| 11350 | LFIRST = .FALSE. |
| 11351 | IF (ICENTR.LE.-100) THEN |
| 11352 | BIMIN = 0.0D0 |
| 11353 | ELSE |
| 11354 | XSFRAC = 0.0D0 |
| 11355 | ENDIF |
| 11356 | CALL DT_GETBXS(XSFRAC,BIMIN,BIMAX,NTARG) |
| 11357 | WRITE(LOUT,1000) RASH(1),RBSH(NTARG),BMAX(NTARG), |
| 11358 | & BIMIN,BIMAX,XSFRAC*100.0D0, |
| 11359 | & XSFRAC*XSPRO(1,1,NTARG) |
| 11360 | 10000 FORMAT(/,1X,'DT_MODB: Biasing in impact parameter', |
| 11361 | & /,15X,'---------------------------'/,/,4X, |
| 11362 | & 'average radii of proj / targ :',F10.3,' fm /', |
| 11363 | & F7.3,' fm',/,4X,'corresp. b_max (4*(r_p+r_t)) :', |
| 11364 | & F10.3,' fm',/,/,21X,'b_lo / b_hi :', |
| 11365 | & F10.3,' fm /',F7.3,' fm',/,5X,'percentage of', |
| 11366 | & ' cross section :',F10.3,' %',/,5X, |
| 11367 | & 'corresponding cross section :',F10.3,' mb',/) |
| 11368 | ENDIF |
| 11369 | IF (ABS(BIMAX-BIMIN).LT.1.0D-3) THEN |
| 11370 | B = BIMIN |
| 11371 | ELSE |
| 11372 | IF ((B.LT.BIMIN).OR.(B.GT.BIMAX)) GOTO 9 |
| 11373 | ENDIF |
| 11374 | ENDIF |
| 11375 | ENDIF |
| 11376 | |
| 11377 | RETURN |
| 11378 | END |
| 11379 | * |
| 11380 | *===shfast=============================================================* |
| 11381 | * |
| 11382 | CDECK ID>, DT_SHFAST |
| 11383 | SUBROUTINE DT_SHFAST(MODE,PPN,IBACK) |
| 11384 | |
| 11385 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 11386 | SAVE |
| 11387 | |
| 11388 | PARAMETER ( LINP = 5 , |
| 11389 | & LOUT = 6 , |
| 11390 | & LDAT = 9 ) |
| 11391 | |
| 11392 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY1=1.0D-1, |
| 11393 | & ONE=1.0D0,TWO=2.0D0) |
| 11394 | |
| 11395 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 11396 | |
| 11397 | * Glauber formalism: parameters |
| 11398 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), |
| 11399 | & BMAX(NCOMPX),BSTEP(NCOMPX), |
| 11400 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), |
| 11401 | & NSITEB,NSTATB |
| 11402 | * properties of interacting particles |
| 11403 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG |
| 11404 | * Glauber formalism: cross sections |
| 11405 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, |
| 11406 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), |
| 11407 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), |
| 11408 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), |
| 11409 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), |
| 11410 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), |
| 11411 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), |
| 11412 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), |
| 11413 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), |
| 11414 | & BSLOPE,NEBINI,NQBINI |
| 11415 | |
| 11416 | IBACK = 0 |
| 11417 | |
| 11418 | IF (MODE.EQ.2) THEN |
| 11419 | OPEN(47,FILE='shmakov.out',STATUS='UNKNOWN') |
| 11420 | WRITE(47,1000) IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG,PPN |
| 11421 | 1000 FORMAT(1X,8I5,E15.5) |
| 11422 | WRITE(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1) |
| 11423 | 1001 FORMAT(1X,4E15.5) |
| 11424 | WRITE(47,1002) SIGSH,ROSH,GSH |
| 11425 | 1002 FORMAT(1X,3E15.5) |
| 11426 | DO 10 I=1,100 |
| 11427 | WRITE(47,'(1X,E15.5)') BSITE(1,1,1,I) |
| 11428 | 10 CONTINUE |
| 11429 | WRITE(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE |
| 11430 | 1003 FORMAT(1X,2I10,3E15.5) |
| 11431 | CLOSE(47) |
| 11432 | ELSE |
| 11433 | OPEN(47,FILE='shmakov.out',STATUS='UNKNOWN') |
| 11434 | READ(47,1000) JT,JTZ,JP,JPZ,JJPROJ,JBPROJ,JJTARG,JBTARG,PP |
| 11435 | IF ((JT.EQ.IT).AND.(JTZ.EQ.ITZ).AND.(JP.EQ.IP).AND. |
| 11436 | & (JPZ.EQ.IPZ).AND.(JJPROJ.EQ.IJPROJ).AND.(JBPROJ.EQ.IBPROJ) |
| 11437 | & .AND.(JJTARG.EQ.IJTARG).AND.(JBTARG.EQ.IBTARG).AND. |
| 11438 | & (ABS(PP-PPN).LT.(PPN*0.01D0))) THEN |
| 11439 | READ(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1) |
| 11440 | READ(47,1002) SIGSH,ROSH,GSH |
| 11441 | DO 11 I=1,100 |
| 11442 | READ(47,'(1X,E15.5)') BSITE(1,1,1,I) |
| 11443 | 11 CONTINUE |
| 11444 | READ(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE |
| 11445 | ELSE |
| 11446 | IBACK = 1 |
| 11447 | ENDIF |
| 11448 | CLOSE(47) |
| 11449 | ENDIF |
| 11450 | |
| 11451 | RETURN |
| 11452 | END |
| 11453 | * |
| 11454 | *===poilik=============================================================* |
| 11455 | * |
| 11456 | CDECK ID>, DT_POILIK |
| 11457 | SUBROUTINE DT_POILIK(NB,NTARG,ECM,VIRT,IPNT,RPNT,MODE) |
| 11458 | |
| 11459 | IMPLICIT DOUBLE PRECISION(A-H,O-Z) |
| 11460 | SAVE |
| 11461 | |
| 11462 | PARAMETER ( LINP = 5 , |
| 11463 | & LOUT = 6 , |
| 11464 | & LDAT = 9 ) |
| 11465 | |
| 11466 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.0D0) |
| 11467 | PARAMETER (NE = 8) |
| 11468 | |
| 11469 | **PHOJET105a |
| 11470 | C CHARACTER*8 MDLNA |
| 11471 | C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100) |
| 11472 | C PARAMETER (IEETAB=10) |
| 11473 | C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX |
| 11474 | **PHOJET110 |
| 11475 | C model switches and parameters |
| 11476 | CHARACTER*8 MDLNA |
| 11477 | INTEGER ISWMDL,IPAMDL |
| 11478 | DOUBLE PRECISION PARMDL |
| 11479 | COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400) |
| 11480 | C energy-interpolation table |
| 11481 | INTEGER IEETA2 |
| 11482 | PARAMETER ( IEETA2 = 20 ) |
| 11483 | INTEGER ISIMAX |
| 11484 | DOUBLE PRECISION SIGTAB,SIGECM |
| 11485 | COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX |
| 11486 | ** |
| 11487 | * VDM parameter for photon-nucleus interactions |
| 11488 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) |
| 11489 | **sr 22.7.97 |
| 11490 | |
| 11491 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 11492 | |
| 11493 | * Glauber formalism: cross sections |
| 11494 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, |
| 11495 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), |
| 11496 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), |
| 11497 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), |
| 11498 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), |
| 11499 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), |
| 11500 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), |
| 11501 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), |
| 11502 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), |
| 11503 | & BSLOPE,NEBINI,NQBINI |
| 11504 | ** |
| 11505 | |
| 11506 | DATA ECMOLD,Q2OLD /-1.0D0,-1.0D0/ |
| 11507 | |
| 11508 | IF ((ECM.EQ.ECMOLD).AND.(VIRT.EQ.Q2OLD)) GOTO 3 |
| 11509 | |
| 11510 | * load cross sections from interpolation table |
| 11511 | IP = 1 |
| 11512 | IF(ECM.LE.SIGECM(IP,1)) THEN |
| 11513 | I1 = 1 |
| 11514 | I2 = 1 |
| 11515 | ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN |
| 11516 | DO 50 I=2,ISIMAX |
| 11517 | IF(ECM.LE.SIGECM(IP,I)) GOTO 200 |
| 11518 | 50 CONTINUE |
| 11519 | 200 CONTINUE |
| 11520 | I1 = I-1 |
| 11521 | I2 = I |
| 11522 | ELSE |
| 11523 | WRITE(LOUT,'(/1X,A,2E12.3)') |
| 11524 | & 'POILIK:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX) |
| 11525 | I1 = ISIMAX |
| 11526 | I2 = ISIMAX |
| 11527 | ENDIF |
| 11528 | FAC2 = ZERO |
| 11529 | IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1)) |
| 11530 | & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1)) |
| 11531 | FAC1 = ONE-FAC2 |
| 11532 | |
| 11533 | SIGANO = DT_SANO(ECM) |
| 11534 | |
| 11535 | * cross section dependence on photon virtuality |
| 11536 | FSUP1 = ZERO |
| 11537 | DO 150 I=1,3 |
| 11538 | FSUP1 = FSUP1+PARMDL(26+I)*(ONE+VIRT/(4.D0*PARMDL(30+I))) |
| 11539 | & /(ONE+VIRT/PARMDL(30+I))**2 |
| 11540 | 150 CONTINUE |
| 11541 | FSUP1 = FSUP1+PARMDL(30)/(ONE+VIRT/PARMDL(34)) |
| 11542 | FAC1 = FAC1*FSUP1 |
| 11543 | FAC2 = FAC2*FSUP1 |
| 11544 | FSUP2 = ONE |
| 11545 | |
| 11546 | ECMOLD = ECM |
| 11547 | Q2OLD = VIRT |
| 11548 | |
| 11549 | 3 CONTINUE |
| 11550 | |
| 11551 | C SIGTOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1) |
| 11552 | CALL DT_SIGGP(ZERO,VIRT,ECM,ZERO,SIGTOT,DUM1,DUM2) |
| 11553 | IF (ISHAD(1).EQ.1) THEN |
| 11554 | SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1) |
| 11555 | ELSE |
| 11556 | SIGDIR = ZERO |
| 11557 | ENDIF |
| 11558 | SIGANO = FSUP1*FSUP2*SIGANO |
| 11559 | SIGTOT = SIGTOT-SIGDIR-SIGANO |
| 11560 | SIGDIR = SIGDIR/(FSUP1*FSUP2) |
| 11561 | SIGANO = SIGANO/(FSUP1*FSUP2) |
| 11562 | SIGTOT = SIGTOT+SIGDIR+SIGANO |
| 11563 | |
| 11564 | RR = DT_RNDM(SIGTOT) |
| 11565 | IF (RR.LT.SIGDIR/SIGTOT) THEN |
| 11566 | IPNT = 1 |
| 11567 | ELSEIF ((RR.GE.SIGDIR/SIGTOT).AND. |
| 11568 | & (RR.LT.(SIGDIR+SIGANO)/SIGTOT)) THEN |
| 11569 | IPNT = 2 |
| 11570 | ELSE |
| 11571 | IPNT = 0 |
| 11572 | ENDIF |
| 11573 | RPNT = (SIGDIR+SIGANO)/SIGTOT |
| 11574 | C WRITE(LOUT,'(I3,2F15.5)') ISHAD(1),FAC1,FAC2 |
| 11575 | C WRITE(LOUT,'(I3,2F15.5)') MODE,SIGDIR,SIGANO |
| 11576 | C WRITE(LOUT,'(I3,4F15.5)') MODE,SIGDIR+SIGANO,SIGTOT,RPNT,ECM |
| 11577 | C WRITE(LOUT,'(1X,6E12.4)') ECM,VIRT,SIGTOT,SIGDIR,SIGANO,RPNT |
| 11578 | IF (MODE.EQ.1) RETURN |
| 11579 | |
| 11580 | **sr 22.7.97 |
| 11581 | K1 = 1 |
| 11582 | K2 = 1 |
| 11583 | RATE = ZERO |
| 11584 | IF (ECM.GE.ECMNN(NEBINI)) THEN |
| 11585 | K1 = NEBINI |
| 11586 | K2 = NEBINI |
| 11587 | RATE = ONE |
| 11588 | ELSEIF (ECM.GT.ECMNN(1)) THEN |
| 11589 | DO 10 I=2,NEBINI |
| 11590 | IF (ECM.LT.ECMNN(I)) THEN |
| 11591 | K1 = I-1 |
| 11592 | K2 = I |
| 11593 | RATE = (ECM-ECMNN(K1))/(ECMNN(K2)-ECMNN(K1)) |
| 11594 | GOTO 11 |
| 11595 | ENDIF |
| 11596 | 10 CONTINUE |
| 11597 | 11 CONTINUE |
| 11598 | ENDIF |
| 11599 | J1 = 1 |
| 11600 | J2 = 1 |
| 11601 | RATQ = ZERO |
| 11602 | IF (NQBINI.GT.1) THEN |
| 11603 | IF (VIRT.GE.Q2G(NQBINI)) THEN |
| 11604 | J1 = NQBINI |
| 11605 | J2 = NQBINI |
| 11606 | RATQ = ONE |
| 11607 | ELSEIF (VIRT.GT.Q2G(1)) THEN |
| 11608 | DO 12 I=2,NQBINI |
| 11609 | IF (VIRT.LT.Q2G(I)) THEN |
| 11610 | J1 = I-1 |
| 11611 | J2 = I |
| 11612 | RATQ = LOG10( VIRT/MAX(Q2G(J1),TINY14))/ |
| 11613 | & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14)) |
| 11614 | GOTO 13 |
| 11615 | ENDIF |
| 11616 | 12 CONTINUE |
| 11617 | 13 CONTINUE |
| 11618 | ENDIF |
| 11619 | ENDIF |
| 11620 | SGA = XSPRO(K1,J1,NTARG)+ |
| 11621 | & RATE*(XSPRO(K2,J1,NTARG)-XSPRO(K1,J1,NTARG))+ |
| 11622 | & RATQ*(XSPRO(K1,J2,NTARG)-XSPRO(K1,J1,NTARG))+ |
| 11623 | & RATE*RATQ*(XSPRO(K2,J2,NTARG)-XSPRO(K1,J2,NTARG)+ |
| 11624 | & XSPRO(K1,J1,NTARG)-XSPRO(K2,J1,NTARG)) |
| 11625 | SDI = DBLE(NB)*SIGDIR |
| 11626 | SAN = DBLE(NB)*SIGANO |
| 11627 | SPL = SDI+SAN |
| 11628 | RR = DT_RNDM(SPL) |
| 11629 | IF (RR.LT.SDI/SGA) THEN |
| 11630 | IPNT = 1 |
| 11631 | ELSEIF ((RR.GE.SDI/SGA).AND. |
| 11632 | & (RR.LT.SPL/SGA)) THEN |
| 11633 | IPNT = 2 |
| 11634 | ELSE |
| 11635 | IPNT = 0 |
| 11636 | ENDIF |
| 11637 | RPNT = SPL/SGA |
| 11638 | C WRITE(LOUT,'(I3,4F15.5)') MODE,SPL,SGA,RPNT,ECM |
| 11639 | ** |
| 11640 | |
| 11641 | RETURN |
| 11642 | END |
| 11643 | * |
| 11644 | *===glbini=============================================================* |
| 11645 | * |
| 11646 | CDECK ID>, DT_GLBINI |
| 11647 | SUBROUTINE DT_GLBINI(WHAT) |
| 11648 | |
| 11649 | ************************************************************************ |
| 11650 | * Pre-initialization of profile function * |
| 11651 | * This version dated 28.11.00 is written by S. Roesler. * |
| 11652 | ************************************************************************ |
| 11653 | |
| 11654 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 11655 | SAVE |
| 11656 | |
| 11657 | PARAMETER ( LINP = 5 , |
| 11658 | & LOUT = 6 , |
| 11659 | & LDAT = 9 ) |
| 11660 | |
| 11661 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.D-14) |
| 11662 | |
| 11663 | LOGICAL LCMS |
| 11664 | |
| 11665 | * particle properties (BAMJET index convention) |
| 11666 | CHARACTER*8 ANAME |
| 11667 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 11668 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 11669 | * properties of interacting particles |
| 11670 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG |
| 11671 | |
| 11672 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 11673 | |
| 11674 | * emulsion treatment |
| 11675 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), |
| 11676 | & NCOMPO,IEMUL |
| 11677 | * Glauber formalism: flags and parameters for statistics |
| 11678 | LOGICAL LPROD |
| 11679 | CHARACTER*8 CGLB |
| 11680 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD |
| 11681 | * number of data sets other than protons and nuclei |
| 11682 | * at the moment = 2 (pions and kaons) |
| 11683 | PARAMETER (MAXOFF=2) |
| 11684 | DIMENSION IJPINI(5),IOFFST(25) |
| 11685 | DATA IJPINI / 13, 15, 0, 0, 0/ |
| 11686 | * Glauber data-set to be used for hadron projectiles |
| 11687 | * (0=proton, 1=pion, 2=kaon) |
| 11688 | DATA (IOFFST(K),K=1,25) / |
| 11689 | & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0, |
| 11690 | & 0, 0, 1, 2, 2/ |
| 11691 | * Acceptance interval for target nucleus mass |
| 11692 | PARAMETER (KBACC = 6) |
| 11693 | |
| 11694 | PARAMETER (MAXMSS = 100) |
| 11695 | DIMENSION IASAV(MAXMSS),IBSAV(MAXMSS) |
| 11696 | DIMENSION WHAT(6) |
| 11697 | |
| 11698 | DATA JPEACH,JPSTEP / 18, 5 / |
| 11699 | |
| 11700 | * temporary patch until fix has been implemented in phojet: |
| 11701 | * maximum energy for pion projectile |
| 11702 | DATA ECMXPI / 100000.0D0 / |
| 11703 | * |
| 11704 | *-------------------------------------------------------------------------- |
| 11705 | * general initializations |
| 11706 | * |
| 11707 | * steps in projectile mass number for initialization |
| 11708 | IF (WHAT(4).GT.ZERO) JPEACH = INT(WHAT(4)) |
| 11709 | IF (WHAT(5).GT.ZERO) JPSTEP = INT(WHAT(5)) |
| 11710 | * |
| 11711 | * energy range and binning |
| 11712 | ELO = ABS(WHAT(1)) |
| 11713 | EHI = ABS(WHAT(2)) |
| 11714 | IF (ELO.GT.EHI) ELO = EHI |
| 11715 | NEBIN = MAX(INT(WHAT(3)),1) |
| 11716 | IF (ELO.EQ.EHI) NEBIN = 0 |
| 11717 | LCMS = (WHAT(1).LT.ZERO).OR.(WHAT(2).LT.ZERO) |
| 11718 | IF (LCMS) THEN |
| 11719 | ECMINI = EHI |
| 11720 | ELSE |
| 11721 | ECMINI = SQRT(AAM(IJPROJ)**2+AAM(IJTARG)**2 |
| 11722 | & +2.0D0*AAM(IJTARG)*EHI) |
| 11723 | ENDIF |
| 11724 | * |
| 11725 | * default arguments for Glauber-routine |
| 11726 | XI = ZERO |
| 11727 | Q2I = ZERO |
| 11728 | * |
| 11729 | * initialize nuclear parameters, etc. |
| 11730 | |
| 11731 | CALL BERTTP |
| 11732 | CALL INCINI |
| 11733 | |
| 11734 | * |
| 11735 | * open Glauber-data output file |
| 11736 | IDX = INDEX(CGLB,' ') |
| 11737 | K = 12 |
| 11738 | IF (IDX.GT.1) K = IDX-1 |
| 11739 | OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN') |
| 11740 | * |
| 11741 | *-------------------------------------------------------------------------- |
| 11742 | * Glauber-initialization for proton and nuclei projectiles |
| 11743 | * |
| 11744 | * initialize phojet for proton-proton interactions |
| 11745 | ELAB = ZERO |
| 11746 | PLAB = ZERO |
| 11747 | CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1) |
| 11748 | CALL DT_PHOINI |
| 11749 | * |
| 11750 | * record projectile masses |
| 11751 | NASAV = 0 |
| 11752 | NPROJ = MIN(IP,JPEACH) |
| 11753 | DO 10 KPROJ=1,NPROJ |
| 11754 | NASAV = NASAV+1 |
| 11755 | IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! ' |
| 11756 | IASAV(NASAV) = KPROJ |
| 11757 | 10 CONTINUE |
| 11758 | IF (IP.GT.JPEACH) THEN |
| 11759 | NPROJ = DBLE(IP-JPEACH)/DBLE(JPSTEP) |
| 11760 | IF (NPROJ.EQ.0) THEN |
| 11761 | NASAV = NASAV+1 |
| 11762 | IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! ' |
| 11763 | IASAV(NASAV) = IP |
| 11764 | ELSE |
| 11765 | DO 11 IPROJ=1,NPROJ |
| 11766 | KPROJ = JPEACH+IPROJ*JPSTEP |
| 11767 | NASAV = NASAV+1 |
| 11768 | IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! ' |
| 11769 | IASAV(NASAV) = KPROJ |
| 11770 | 11 CONTINUE |
| 11771 | IF (KPROJ.LT.IP) THEN |
| 11772 | NASAV = NASAV+1 |
| 11773 | IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! ' |
| 11774 | IASAV(NASAV) = IP |
| 11775 | ENDIF |
| 11776 | ENDIF |
| 11777 | ENDIF |
| 11778 | * |
| 11779 | * record target masses |
| 11780 | NBSAV = 0 |
| 11781 | NTARG = 1 |
| 11782 | IF (NCOMPO.GT.0) NTARG = NCOMPO |
| 11783 | DO 12 ITARG=1,NTARG |
| 11784 | NBSAV = NBSAV+1 |
| 11785 | IF (NBSAV.GT.MAXMSS) STOP ' GLBINI: NBSAV > MAXMSS ! ' |
| 11786 | IF (NCOMPO.GT.0) THEN |
| 11787 | IBSAV(NBSAV) = IEMUMA(ITARG) |
| 11788 | ELSE |
| 11789 | IBSAV(NBSAV) = IT |
| 11790 | ENDIF |
| 11791 | 12 CONTINUE |
| 11792 | * |
| 11793 | * print masses |
| 11794 | WRITE(LDAT,1000) NEBIN,': ',SIGN(ELO,WHAT(1)),SIGN(EHI,WHAT(2)) |
| 11795 | 1000 FORMAT(I4,A,1P,2E13.5) |
| 11796 | NLINES = DBLE(NASAV)/18.0D0 |
| 11797 | IF (NLINES.GT.0) THEN |
| 11798 | DO 13 I=1,NLINES |
| 11799 | IF (I.EQ.1) THEN |
| 11800 | WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=1,18) |
| 11801 | ELSE |
| 11802 | WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=18*I-17,18*I) |
| 11803 | ENDIF |
| 11804 | 13 CONTINUE |
| 11805 | ENDIF |
| 11806 | I0 = 18*NLINES+1 |
| 11807 | IF (I0.LE.NASAV) THEN |
| 11808 | IF (I0.EQ.1) THEN |
| 11809 | WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=I0,NASAV) |
| 11810 | ELSE |
| 11811 | WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=I0,NASAV) |
| 11812 | ENDIF |
| 11813 | ENDIF |
| 11814 | NLINES = DBLE(NBSAV)/18.0D0 |
| 11815 | IF (NLINES.GT.0) THEN |
| 11816 | DO 14 I=1,NLINES |
| 11817 | IF (I.EQ.1) THEN |
| 11818 | WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=1,18) |
| 11819 | ELSE |
| 11820 | WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=18*I-17,18*I) |
| 11821 | ENDIF |
| 11822 | 14 CONTINUE |
| 11823 | ENDIF |
| 11824 | I0 = 18*NLINES+1 |
| 11825 | IF (I0.LE.NBSAV) THEN |
| 11826 | IF (I0.EQ.1) THEN |
| 11827 | WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=I0,NBSAV) |
| 11828 | ELSE |
| 11829 | WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=I0,NBSAV) |
| 11830 | ENDIF |
| 11831 | ENDIF |
| 11832 | * |
| 11833 | * calculate Glauber-data for each energy and mass combination |
| 11834 | * |
| 11835 | * loop over energy bins |
| 11836 | ELO = LOG10(ELO) |
| 11837 | EHI = LOG10(EHI) |
| 11838 | DEBIN = (EHI-ELO)/MAX(DBLE(NEBIN),ONE) |
| 11839 | DO 1 IE=1,NEBIN+1 |
| 11840 | E = ELO+DBLE(IE-1)*DEBIN |
| 11841 | E = 10**E |
| 11842 | IF (LCMS) THEN |
| 11843 | E = MAX(2.0D0*AAM(IJPROJ)+0.1D0,E) |
| 11844 | ECM = E |
| 11845 | ELSE |
| 11846 | PLAB = ZERO |
| 11847 | ECM = ZERO |
| 11848 | E = MAX(AAM(IJPROJ)+0.1D0,E) |
| 11849 | CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0) |
| 11850 | ENDIF |
| 11851 | * |
| 11852 | * loop over projectile and target masses |
| 11853 | DO 2 ITARG=1,NBSAV |
| 11854 | DO 3 IPROJ=1,NASAV |
| 11855 | CALL DT_XSGLAU(IASAV(IPROJ),IBSAV(ITARG),IJPROJ, |
| 11856 | & XI,Q2I,ECM,1,1,-1) |
| 11857 | 3 CONTINUE |
| 11858 | 2 CONTINUE |
| 11859 | * |
| 11860 | 1 CONTINUE |
| 11861 | * |
| 11862 | *-------------------------------------------------------------------------- |
| 11863 | * Glauber-initialization for pion, kaon, ... projectiles |
| 11864 | * |
| 11865 | DO 6 IJ=1,MAXOFF |
| 11866 | * |
| 11867 | * initialize phojet for this interaction |
| 11868 | ELAB = ZERO |
| 11869 | PLAB = ZERO |
| 11870 | IJPROJ = IJPINI(IJ) |
| 11871 | IP = 1 |
| 11872 | IPZ = 1 |
| 11873 | * |
| 11874 | * temporary patch until fix has been implemented in phojet: |
| 11875 | IF (ECMINI.GT.ECMXPI) THEN |
| 11876 | CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMXPI,1) |
| 11877 | ELSE |
| 11878 | CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1) |
| 11879 | ENDIF |
| 11880 | CALL DT_PHOINI |
| 11881 | * |
| 11882 | * calculate Glauber-data for each energy and mass combination |
| 11883 | * |
| 11884 | * loop over energy bins |
| 11885 | DO 4 IE=1,NEBIN+1 |
| 11886 | E = ELO+DBLE(IE-1)*DEBIN |
| 11887 | E = 10**E |
| 11888 | IF (LCMS) THEN |
| 11889 | E = MAX(2.0D0*AAM(IJPROJ)+TINY14,E) |
| 11890 | ECM = E |
| 11891 | ELSE |
| 11892 | PLAB = ZERO |
| 11893 | ECM = ZERO |
| 11894 | E = MAX(AAM(IJPROJ)+TINY14,E) |
| 11895 | CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0) |
| 11896 | ENDIF |
| 11897 | * |
| 11898 | * loop over projectile and target masses |
| 11899 | DO 5 ITARG=1,NBSAV |
| 11900 | CALL DT_XSGLAU(1,IBSAV(ITARG),IJPROJ,XI,Q2I,ECM,1,1,-1) |
| 11901 | 5 CONTINUE |
| 11902 | * |
| 11903 | 4 CONTINUE |
| 11904 | * |
| 11905 | 6 CONTINUE |
| 11906 | |
| 11907 | *-------------------------------------------------------------------------- |
| 11908 | * close output unit(s), etc. |
| 11909 | * |
| 11910 | CLOSE(LDAT) |
| 11911 | |
| 11912 | RETURN |
| 11913 | END |
| 11914 | * |
| 11915 | *===glbset=============================================================* |
| 11916 | * |
| 11917 | CDECK ID>, DT_GLBSET |
| 11918 | SUBROUTINE DT_GLBSET(IDPROJ,NA,NB,ELAB,MODE) |
| 11919 | ************************************************************************ |
| 11920 | * Interpolation of pre-initialized profile functions * |
| 11921 | * This version dated 28.11.00 is written by S. Roesler. * |
| 11922 | ************************************************************************ |
| 11923 | |
| 11924 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 11925 | SAVE |
| 11926 | |
| 11927 | PARAMETER ( LINP = 5 , |
| 11928 | & LOUT = 6 , |
| 11929 | & LDAT = 9 ) |
| 11930 | |
| 11931 | PARAMETER (ZERO=0.0D0,ONE=1.0D0) |
| 11932 | |
| 11933 | LOGICAL LCMS,LREAD,LFRST1,LFRST2 |
| 11934 | |
| 11935 | * particle properties (BAMJET index convention) |
| 11936 | CHARACTER*8 ANAME |
| 11937 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 11938 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 11939 | * Glauber formalism: flags and parameters for statistics |
| 11940 | LOGICAL LPROD |
| 11941 | CHARACTER*8 CGLB |
| 11942 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD |
| 11943 | |
| 11944 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 11945 | |
| 11946 | * Glauber formalism: parameters |
| 11947 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), |
| 11948 | & BMAX(NCOMPX),BSTEP(NCOMPX), |
| 11949 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), |
| 11950 | & NSITEB,NSTATB |
| 11951 | * Glauber formalism: cross sections |
| 11952 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, |
| 11953 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), |
| 11954 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), |
| 11955 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), |
| 11956 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), |
| 11957 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), |
| 11958 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), |
| 11959 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), |
| 11960 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), |
| 11961 | & BSLOPE,NEBINI,NQBINI |
| 11962 | * number of data sets other than protons and nuclei |
| 11963 | * at the moment = 2 (pions and kaons) |
| 11964 | PARAMETER (MAXOFF=2) |
| 11965 | DIMENSION IJPINI(5),IOFFST(25) |
| 11966 | DATA IJPINI / 13, 15, 0, 0, 0/ |
| 11967 | * Glauber data-set to be used for hadron projectiles |
| 11968 | * (0=proton, 1=pion, 2=kaon) |
| 11969 | DATA (IOFFST(K),K=1,25) / |
| 11970 | & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0, |
| 11971 | & 0, 0, 1, 2, 2/ |
| 11972 | * Acceptance interval for target nucleus mass |
| 11973 | PARAMETER (KBACC = 6) |
| 11974 | * emulsion treatment |
| 11975 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), |
| 11976 | & NCOMPO,IEMUL |
| 11977 | |
| 11978 | PARAMETER (MAXSET=5000, |
| 11979 | & MAXBIN=100) |
| 11980 | DIMENSION XSIG(MAXSET,6),XERR(MAXSET,6),BPROFL(MAXSET,KSITEB) |
| 11981 | DIMENSION IABIN(MAXBIN),IBBIN(MAXBIN),XS(6),XE(6), |
| 11982 | & BPRO0(KSITEB),BPRO1(KSITEB),BPRO(KSITEB), |
| 11983 | & IAIDX(10) |
| 11984 | |
| 11985 | DATA LREAD,LFRST1,LFRST2 /.FALSE.,.TRUE.,.TRUE./ |
| 11986 | * |
| 11987 | * read data from file |
| 11988 | * |
| 11989 | IF (MODE.EQ.0) THEN |
| 11990 | |
| 11991 | IF (LREAD) RETURN |
| 11992 | |
| 11993 | DO 1 I=1,MAXSET |
| 11994 | DO 2 J=1,6 |
| 11995 | XSIG(I,J) = ZERO |
| 11996 | XERR(I,J) = ZERO |
| 11997 | 2 CONTINUE |
| 11998 | DO 3 J=1,KSITEB |
| 11999 | BPROFL(I,J) = ZERO |
| 12000 | 3 CONTINUE |
| 12001 | 1 CONTINUE |
| 12002 | DO 4 I=1,MAXBIN |
| 12003 | IABIN(I) = 0 |
| 12004 | IBBIN(I) = 0 |
| 12005 | 4 CONTINUE |
| 12006 | DO 5 I=1,KSITEB |
| 12007 | BPRO0(I) = ZERO |
| 12008 | BPRO1(I) = ZERO |
| 12009 | BPRO(I) = ZERO |
| 12010 | 5 CONTINUE |
| 12011 | |
| 12012 | IDX = INDEX(CGLB,' ') |
| 12013 | K = 12 |
| 12014 | IF (IDX.GT.1) K = IDX-1 |
| 12015 | OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN') |
| 12016 | WRITE(LOUT,1000) CGLB(1:K)//'.glb' |
| 12017 | 1000 FORMAT(/,' GLBSET: impact parameter distributions read from ', |
| 12018 | & 'file ',A12,/) |
| 12019 | * |
| 12020 | * read binning information |
| 12021 | READ(LDAT,'(I4,2X,2E13.5)') NEBIN,ELO,EHI |
| 12022 | * return lower energy threshold to Fluka-interface |
| 12023 | ELAB = ELO |
| 12024 | LCMS = ELO.LT.ZERO |
| 12025 | WRITE(LOUT,'(1X,A)') ' equidistant logarithmic energy binning:' |
| 12026 | IF (LCMS) THEN |
| 12027 | WRITE(LOUT,1001) '(cms)',ABS(ELO),ABS(EHI),NEBIN |
| 12028 | ELSE |
| 12029 | WRITE(LOUT,1001) '(lab)',ABS(ELO),ABS(EHI),NEBIN |
| 12030 | ENDIF |
| 12031 | 1001 FORMAT(2X,A5,' E_lo = ',1P,E9.3,' E_hi = ',1P,E9.3,4X, |
| 12032 | & 'No. of bins:',I5,/) |
| 12033 | ELO = LOG10(ABS(ELO)) |
| 12034 | EHI = LOG10(ABS(EHI)) |
| 12035 | DEBIN = (EHI-ELO)/ABS(DBLE(NEBIN)) |
| 12036 | WRITE(LOUT,'(/,1X,A)') ' projectiles: (mass number)' |
| 12037 | READ(LDAT,'(I4,2X,18I4)') NABIN,(IABIN(J),J=1,18) |
| 12038 | IF (NABIN.LT.18) THEN |
| 12039 | WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,NABIN) |
| 12040 | ELSE |
| 12041 | WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,18) |
| 12042 | ENDIF |
| 12043 | IF (NABIN.GT.MAXBIN) STOP ' GLBSET: NABIN > MAXBIN !' |
| 12044 | IF (NABIN.GT.18) THEN |
| 12045 | NLINES = DBLE(NABIN-18)/18.0D0 |
| 12046 | IF (NLINES.GT.0) THEN |
| 12047 | DO 7 I=1,NLINES |
| 12048 | I0 = 18*(I+1)-17 |
| 12049 | READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,I0+17) |
| 12050 | WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,I0+17) |
| 12051 | 7 CONTINUE |
| 12052 | ENDIF |
| 12053 | I0 = 18*(NLINES+1)+1 |
| 12054 | IF (I0.LE.NABIN) THEN |
| 12055 | READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,NABIN) |
| 12056 | WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,NABIN) |
| 12057 | ENDIF |
| 12058 | ENDIF |
| 12059 | WRITE(LOUT,'(/,1X,A)') ' targets: (mass number)' |
| 12060 | READ(LDAT,'(I4,2X,18I4)') NBBIN,(IBBIN(J),J=1,18) |
| 12061 | IF (NBBIN.LT.18) THEN |
| 12062 | WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,NBBIN) |
| 12063 | ELSE |
| 12064 | WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,18) |
| 12065 | ENDIF |
| 12066 | IF (NBBIN.GT.MAXBIN) STOP ' GLBSET: NBBIN > MAXBIN !' |
| 12067 | IF (NBBIN.GT.18) THEN |
| 12068 | NLINES = DBLE(NBBIN-18)/18.0D0 |
| 12069 | IF (NLINES.GT.0) THEN |
| 12070 | DO 8 I=1,NLINES |
| 12071 | I0 = 18*(I+1)-17 |
| 12072 | READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17) |
| 12073 | WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17) |
| 12074 | 8 CONTINUE |
| 12075 | ENDIF |
| 12076 | I0 = 18*(NLINES+1)+1 |
| 12077 | IF (I0.LE.NBBIN) THEN |
| 12078 | READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN) |
| 12079 | WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN) |
| 12080 | ENDIF |
| 12081 | ENDIF |
| 12082 | * number of data sets to follow in the Glauber data file |
| 12083 | * this variable is used for checks of consistency of projectile |
| 12084 | * and target mass configurations given in header of Glauber data |
| 12085 | * file and the data-sets which follow in this file |
| 12086 | NSET0 = (NEBIN+1)*(NABIN+MAXOFF)*NBBIN |
| 12087 | * |
| 12088 | * read profile function data |
| 12089 | NSET = 0 |
| 12090 | NAIDX = 0 |
| 12091 | IPOLD = 0 |
| 12092 | 10 CONTINUE |
| 12093 | NSET = NSET+1 |
| 12094 | IF (NSET.GT.MAXSET) STOP ' GLBSET: NSET > MAXSET ! ' |
| 12095 | READ(LDAT,1002,END=100) IP,IA,IB,ISTATB,ISITEB,ECM |
| 12096 | 1002 FORMAT(5I10,E15.5) |
| 12097 | IF ((IP.NE.1).AND.(IP.NE.IPOLD)) THEN |
| 12098 | NAIDX = NAIDX+1 |
| 12099 | IF (NAIDX.GT.10) STOP ' GLBSET: NAIDX > 10 !' |
| 12100 | IAIDX(NAIDX) = IP |
| 12101 | IPOLD = IP |
| 12102 | ENDIF |
| 12103 | READ(LDAT,'(6E12.5)') (XSIG(NSET,I),I=1,6) |
| 12104 | READ(LDAT,'(6E12.5)') (XERR(NSET,I),I=1,6) |
| 12105 | NLINES = INT(DBLE(ISITEB)/7.0D0) |
| 12106 | IF (NLINES.GT.0) THEN |
| 12107 | DO 11 I=1,NLINES |
| 12108 | READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=7*I-6,7*I) |
| 12109 | 11 CONTINUE |
| 12110 | ENDIF |
| 12111 | I0 = 7*NLINES+1 |
| 12112 | IF (I0.LE.ISITEB) |
| 12113 | & READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=I0,ISITEB) |
| 12114 | GOTO 10 |
| 12115 | 100 CONTINUE |
| 12116 | NSET = NSET-1 |
| 12117 | IF (NSET.NE.NSET0) STOP ' GLBSET: NSET.NE.NSET0 !' |
| 12118 | WRITE(LOUT,'(/,1X,A)') |
| 12119 | & ' projectiles other than protons and nuclei: (particle index)' |
| 12120 | IF (NAIDX.GT.0) THEN |
| 12121 | WRITE(LOUT,'(6X,18I4)') (IAIDX(J),J=1,NAIDX) |
| 12122 | ELSE |
| 12123 | WRITE(LOUT,'(6X,A)') 'none' |
| 12124 | ENDIF |
| 12125 | * |
| 12126 | CLOSE(LDAT) |
| 12127 | WRITE(LOUT,*) |
| 12128 | LREAD = .TRUE. |
| 12129 | |
| 12130 | IF (NCOMPO.EQ.0) THEN |
| 12131 | DO 12 J=1,NBBIN |
| 12132 | NCOMPO = NCOMPO+1 |
| 12133 | IEMUMA(NCOMPO) = IBBIN(J) |
| 12134 | IEMUCH(NCOMPO) = IEMUMA(NCOMPO)/2 |
| 12135 | EMUFRA(NCOMPO) = 1.0D0 |
| 12136 | 12 CONTINUE |
| 12137 | IEMUL = 1 |
| 12138 | ENDIF |
| 12139 | * |
| 12140 | * calculate profile function for certain set of parameters |
| 12141 | * |
| 12142 | ELSE |
| 12143 | |
| 12144 | c write(*,*) 'glbset called for ',IDPROJ,NA,NB,ELAB,MODE |
| 12145 | * |
| 12146 | * check for type of projectile and set index-offset to entry in |
| 12147 | * Glauber data array correspondingly |
| 12148 | IF (IDPROJ.GT.25) STOP ' GLBSET: IDPROJ > 25 !' |
| 12149 | IF (IOFFST(IDPROJ).EQ.-1) THEN |
| 12150 | STOP ' GLBSET: no data for this projectile !' |
| 12151 | ELSEIF (IOFFST(IDPROJ).GT.0) THEN |
| 12152 | IDXOFF = (NEBIN+1)*(NABIN+IOFFST(IDPROJ)-1)*NBBIN |
| 12153 | ELSE |
| 12154 | IDXOFF = 0 |
| 12155 | ENDIF |
| 12156 | * |
| 12157 | * get energy bin and interpolation factor |
| 12158 | IF (LCMS) THEN |
| 12159 | E = SQRT(AAM(IDPROJ)**2+AAM(1)**2+2.0D0*AAM(1)*ELAB) |
| 12160 | ELSE |
| 12161 | E = ELAB |
| 12162 | ENDIF |
| 12163 | E = LOG10(E) |
| 12164 | IF (E.LT.ELO) THEN |
| 12165 | IF (LFRST1) THEN |
| 12166 | WRITE(LOUT,*) ' GLBSET: Too low energy! (E_lo,E) ',ELO,E |
| 12167 | LFRST1 = .FALSE. |
| 12168 | ENDIF |
| 12169 | E = ELO |
| 12170 | ENDIF |
| 12171 | IF (E.GT.EHI) THEN |
| 12172 | IF (LFRST2) THEN |
| 12173 | WRITE(LOUT,*) ' GLBSET: Too high energy! (E_hi,E) ',EHI,E |
| 12174 | LFRST2 = .FALSE. |
| 12175 | ENDIF |
| 12176 | E = EHI |
| 12177 | ENDIF |
| 12178 | IE0 = (E-ELO)/DEBIN+1 |
| 12179 | IE1 = IE0+1 |
| 12180 | FACE = (E-(ELO+DBLE(IE0-1)*DEBIN))/DEBIN |
| 12181 | * |
| 12182 | * get target nucleus index |
| 12183 | KB = 0 |
| 12184 | NBACC = KBACC |
| 12185 | DO 20 I=1,NBBIN |
| 12186 | NBDIFF = ABS(NB-IBBIN(I)) |
| 12187 | IF (NB.EQ.IBBIN(I)) THEN |
| 12188 | KB = I |
| 12189 | GOTO 21 |
| 12190 | ELSEIF (NBDIFF.LE.NBACC) THEN |
| 12191 | KB = I |
| 12192 | NBACC = NBDIFF |
| 12193 | ENDIF |
| 12194 | 20 CONTINUE |
| 12195 | IF (KB.NE.0) GOTO 21 |
| 12196 | WRITE(LOUT,*) ' GLBSET: data not found for target ',NB |
| 12197 | STOP |
| 12198 | 21 CONTINUE |
| 12199 | * |
| 12200 | * get projectile nucleus bin and interpolation factor |
| 12201 | KA0 = 0 |
| 12202 | KA1 = 0 |
| 12203 | FACNA = 0 |
| 12204 | IF (IDXOFF.GT.0) THEN |
| 12205 | KA0 = 1 |
| 12206 | KA1 = 1 |
| 12207 | KABIN = 1 |
| 12208 | ELSE |
| 12209 | IF (NA.GT.IABIN(NABIN)) STOP ' GLBSET: NA > IABIN(NABIN) !' |
| 12210 | DO 22 I=1,NABIN |
| 12211 | IF (NA.EQ.IABIN(I)) THEN |
| 12212 | KA0 = I |
| 12213 | KA1 = I |
| 12214 | GOTO 23 |
| 12215 | ELSEIF (NA.LT.IABIN(I)) THEN |
| 12216 | KA0 = I-1 |
| 12217 | KA1 = I |
| 12218 | GOTO 23 |
| 12219 | ENDIF |
| 12220 | 22 CONTINUE |
| 12221 | WRITE(LOUT,*) ' GLBSET: data not found for projectile ',NA |
| 12222 | STOP |
| 12223 | 23 CONTINUE |
| 12224 | IF (KA0.NE.KA1) |
| 12225 | & FACNA = DBLE(NA-IABIN(KA0))/DBLE(IABIN(KA1)-IABIN(KA0)) |
| 12226 | KABIN = NABIN |
| 12227 | ENDIF |
| 12228 | * |
| 12229 | * interpolate profile functions for interactions ka0-kb and ka1-kb |
| 12230 | * for energy E separately |
| 12231 | IDX0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1) |
| 12232 | IDX1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1) |
| 12233 | IDY0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1) |
| 12234 | IDY1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1) |
| 12235 | DO 30 I=1,ISITEB |
| 12236 | BPRO0(I) = BPROFL(IDX0,I) |
| 12237 | & +FACE*(BPROFL(IDX1,I)-BPROFL(IDX0,I)) |
| 12238 | BPRO1(I) = BPROFL(IDY0,I) |
| 12239 | & +FACE*(BPROFL(IDY1,I)-BPROFL(IDY0,I)) |
| 12240 | 30 CONTINUE |
| 12241 | RADB = DT_RNCLUS(NB) |
| 12242 | BSTP0 = 2.0D0*(DT_RNCLUS(IABIN(KA0))+RADB)/DBLE(ISITEB-1) |
| 12243 | BSTP1 = 2.0D0*(DT_RNCLUS(IABIN(KA1))+RADB)/DBLE(ISITEB-1) |
| 12244 | * |
| 12245 | * interpolate cross sections for energy E and projectile mass |
| 12246 | DO 31 I=1,6 |
| 12247 | XS0 = XSIG(IDX0,I)+FACE*(XSIG(IDX1,I)-XSIG(IDX0,I)) |
| 12248 | XS1 = XSIG(IDY0,I)+FACE*(XSIG(IDY1,I)-XSIG(IDY0,I)) |
| 12249 | XS(I) = XS0+FACNA*(XS1-XS0) |
| 12250 | XE0 = XERR(IDX0,I)+FACE*(XERR(IDX1,I)-XERR(IDX0,I)) |
| 12251 | XE1 = XERR(IDY0,I)+FACE*(XERR(IDY1,I)-XERR(IDY0,I)) |
| 12252 | XE(I) = XE0+FACNA*(XE1-XE0) |
| 12253 | 31 CONTINUE |
| 12254 | * |
| 12255 | * interpolate between ka0 and ka1 |
| 12256 | RADA = DT_RNCLUS(NA) |
| 12257 | BMX = 2.0D0*(RADA+RADB) |
| 12258 | BSTP = BMX/DBLE(ISITEB-1) |
| 12259 | BPRO(1) = ZERO |
| 12260 | DO 32 I=1,ISITEB-1 |
| 12261 | B = DBLE(I)*BSTP |
| 12262 | * |
| 12263 | * calculate values of profile functions at B |
| 12264 | IDX0 = B/BSTP0+1 |
| 12265 | IF (IDX0.GT.ISITEB) IDX0 = ISITEB |
| 12266 | IDX1 = MIN(IDX0+1,ISITEB) |
| 12267 | FACB = (B-DBLE(IDX0-1)*BSTP0)/BSTP0 |
| 12268 | BPR0 = BPRO0(IDX0)+FACB*(BPRO0(IDX1)-BPRO0(IDX0)) |
| 12269 | IDX0 = B/BSTP1+1 |
| 12270 | IF (IDX0.GT.ISITEB) IDX0 = ISITEB |
| 12271 | IDX1 = MIN(IDX0+1,ISITEB) |
| 12272 | FACB = (B-DBLE(IDX0-1)*BSTP1)/BSTP1 |
| 12273 | BPR1 = BPRO1(IDX0)+FACB*(BPRO1(IDX1)-BPRO1(IDX0)) |
| 12274 | * |
| 12275 | BPRO(I+1) = BPR0+FACNA*(BPR1-BPR0) |
| 12276 | 32 CONTINUE |
| 12277 | * |
| 12278 | * fill common dtglam |
| 12279 | NSITEB = ISITEB |
| 12280 | RASH(1) = RADA |
| 12281 | RBSH(1) = RADB |
| 12282 | BMAX(1) = BMX |
| 12283 | BSTEP(1) = BSTP |
| 12284 | DO 33 I=1,KSITEB |
| 12285 | BSITE(0,1,1,I) = BPRO(I) |
| 12286 | 33 CONTINUE |
| 12287 | * |
| 12288 | * fill common dtglxs |
| 12289 | XSTOT(1,1,1) = XS(1) |
| 12290 | XSELA(1,1,1) = XS(2) |
| 12291 | XSQEP(1,1,1) = XS(3) |
| 12292 | XSQET(1,1,1) = XS(4) |
| 12293 | XSQE2(1,1,1) = XS(5) |
| 12294 | XSPRO(1,1,1) = XS(6) |
| 12295 | XETOT(1,1,1) = XE(1) |
| 12296 | XEELA(1,1,1) = XE(2) |
| 12297 | XEQEP(1,1,1) = XE(3) |
| 12298 | XEQET(1,1,1) = XE(4) |
| 12299 | XEQE2(1,1,1) = XE(5) |
| 12300 | XEPRO(1,1,1) = XE(6) |
| 12301 | |
| 12302 | ENDIF |
| 12303 | |
| 12304 | RETURN |
| 12305 | END |
| 12306 | * |
| 12307 | *===xksamp=============================================================* |
| 12308 | * |
| 12309 | CDECK ID>, DT_XKSAMP |
| 12310 | SUBROUTINE DT_XKSAMP(NN,ECM) |
| 12311 | |
| 12312 | ************************************************************************ |
| 12313 | * Sampling of parton x-values and chain system for one interaction. * |
| 12314 | * processed by S. Roesler, 9.8.95 * |
| 12315 | ************************************************************************ |
| 12316 | |
| 12317 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 12318 | SAVE |
| 12319 | |
| 12320 | PARAMETER ( LINP = 5 , |
| 12321 | & LOUT = 6 , |
| 12322 | & LDAT = 9 ) |
| 12323 | |
| 12324 | PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0) |
| 12325 | SAVE |
| 12326 | |
| 12327 | PARAMETER ( |
| 12328 | * lower cuts for (valence-sea/sea-valence) chain masses |
| 12329 | * antiquark-quark (u/d-sea quark) (s-sea quark) |
| 12330 | & AMIU = 0.5D0, AMIS = 0.8D0, |
| 12331 | * quark-diquark (u/d-sea quark) (s-sea quark) |
| 12332 | & AMAU = 2.6D0, AMAS = 2.6D0, |
| 12333 | * maximum lower valence-x threshold |
| 12334 | & XVMAX = 0.98D0, |
| 12335 | * fraction of sea-diquarks sampled out of sea-partons |
| 12336 | **test |
| 12337 | C & FRCDIQ = 0.9D0, |
| 12338 | ** |
| 12339 | * |
| 12340 | & SQMA = 0.7D0, |
| 12341 | * |
| 12342 | * maximum number of trials to generate x's for the required number |
| 12343 | * of sea quark pairs for a given hadron |
| 12344 | C & NSEATY = 12 |
| 12345 | & NSEATY = 3 |
| 12346 | & ) |
| 12347 | |
| 12348 | LOGICAL ZUOVP,ZUOSP,ZUOVT,ZUOST,INTLO |
| 12349 | |
| 12350 | PARAMETER ( MAXNCL = 260, |
| 12351 | |
| 12352 | & MAXVQU = MAXNCL, |
| 12353 | & MAXSQU = 20*MAXVQU, |
| 12354 | & MAXINT = MAXVQU+MAXSQU) |
| 12355 | * event history |
| 12356 | |
| 12357 | PARAMETER (NMXHKK=200000) |
| 12358 | |
| 12359 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 12360 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 12361 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 12362 | * particle properties (BAMJET index convention) |
| 12363 | CHARACTER*8 ANAME |
| 12364 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 12365 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 12366 | * interface between Glauber formalism and DPM |
| 12367 | COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL), |
| 12368 | & INTER1(MAXINT),INTER2(MAXINT) |
| 12369 | * properties of interacting particles |
| 12370 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG |
| 12371 | * threshold values for x-sampling (DTUNUC 1.x) |
| 12372 | COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA, |
| 12373 | & SSMIMQ,VVMTHR |
| 12374 | * x-values of partons (DTUNUC 1.x) |
| 12375 | COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU), |
| 12376 | & XTVQ(MAXVQU),XTVD(MAXVQU), |
| 12377 | & XPSQ(MAXSQU),XPSAQ(MAXSQU), |
| 12378 | & XTSQ(MAXSQU),XTSAQ(MAXSQU) |
| 12379 | * flavors of partons (DTUNUC 1.x) |
| 12380 | COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU), |
| 12381 | & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU), |
| 12382 | & IPSQ(MAXSQU),IPSQ2(MAXSQU), |
| 12383 | & IPSAQ(MAXSQU),IPSAQ2(MAXSQU), |
| 12384 | & ITSQ(MAXSQU),ITSQ2(MAXSQU), |
| 12385 | & ITSAQ(MAXSQU),ITSAQ2(MAXSQU), |
| 12386 | & KKPROJ(MAXVQU),KKTARG(MAXVQU) |
| 12387 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) |
| 12388 | COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD, |
| 12389 | & IXPV,IXPS,IXTV,IXTS, |
| 12390 | & INTVV1(MAXVQU),INTVV2(MAXVQU), |
| 12391 | & INTSV1(MAXVQU),INTSV2(MAXVQU), |
| 12392 | & INTVS1(MAXVQU),INTVS2(MAXVQU), |
| 12393 | & INTSS1(MAXSQU),INTSS2(MAXSQU), |
| 12394 | & INTDV1(MAXVQU),INTDV2(MAXVQU), |
| 12395 | & INTVD1(MAXVQU),INTVD2(MAXVQU), |
| 12396 | & INTDS1(MAXSQU),INTDS2(MAXSQU), |
| 12397 | & INTSD1(MAXSQU),INTSD2(MAXSQU) |
| 12398 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) |
| 12399 | COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU), |
| 12400 | & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU) |
| 12401 | * auxiliary common for chain system storage (DTUNUC 1.x) |
| 12402 | COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL) |
| 12403 | * flags for input different options |
| 12404 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 12405 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 12406 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 12407 | * various options for treatment of partons (DTUNUC 1.x) |
| 12408 | * (chain recombination, Cronin,..) |
| 12409 | LOGICAL LCO2CR,LINTPT |
| 12410 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, |
| 12411 | & LCO2CR,LINTPT |
| 12412 | |
| 12413 | DIMENSION ZUOVP(MAXVQU),ZUOSP(MAXSQU),ZUOVT(MAXVQU),ZUOST(MAXSQU), |
| 12414 | & INTLO(MAXINT) |
| 12415 | |
| 12416 | * (1) initializations |
| 12417 | *----------------------------------------------------------------------- |
| 12418 | |
| 12419 | **test |
| 12420 | IF (ECM.LT.4.5D0) THEN |
| 12421 | C FRCDIQ = 0.6D0 |
| 12422 | FRCDIQ = 0.4D0 |
| 12423 | ELSEIF ((ECM.GE.4.5D0).AND.(ECM.LT.7.5)) THEN |
| 12424 | C FRCDIQ = 0.6D0+(ECM-4.5D0)/3.0D0*0.3D0 |
| 12425 | FRCDIQ = 0.4D0+(ECM-4.5D0)/3.0D0*0.3D0 |
| 12426 | ELSE |
| 12427 | C FRCDIQ = 0.9D0 |
| 12428 | FRCDIQ = 0.7D0 |
| 12429 | ENDIF |
| 12430 | ** |
| 12431 | DO 30 I=1,MAXSQU |
| 12432 | ZUOSP(I) = .FALSE. |
| 12433 | ZUOST(I) = .FALSE. |
| 12434 | IF (I.LE.MAXVQU) THEN |
| 12435 | ZUOVP(I) = .FALSE. |
| 12436 | ZUOVT(I) = .FALSE. |
| 12437 | ENDIF |
| 12438 | 30 CONTINUE |
| 12439 | |
| 12440 | * lower thresholds for x-selection |
| 12441 | * sea-quarks (default: CSEA=0.2) |
| 12442 | IF (ECM.LT.10.0D0) THEN |
| 12443 | **!!test |
| 12444 | XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM |
| 12445 | C XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM**2.0D0 |
| 12446 | NSEA = NSEATY |
| 12447 | C XSTHR = ONE/ECM**2 |
| 12448 | ELSE |
| 12449 | **sr 30.3.98 |
| 12450 | C XSTHR = CSEA/ECM |
| 12451 | XSTHR = CSEA/ECM**2 |
| 12452 | C XSTHR = ONE/ECM**2 |
| 12453 | ** |
| 12454 | IF ((IP.GE.150).AND.(IT.GE.150)) |
| 12455 | & XSTHR = 2.5D0/(ECM*SQRT(ECM)) |
| 12456 | NSEA = NSEATY |
| 12457 | ENDIF |
| 12458 | * (default: SSMIMA=0.14) used for sea-diquarks (?) |
| 12459 | XSSTHR = SSMIMA/ECM |
| 12460 | BSQMA = SQMA/ECM |
| 12461 | * valence-quarks (default: CVQ=1.0) |
| 12462 | XVTHR = CVQ/ECM |
| 12463 | * valence-diquarks (default: CDQ=2.0) |
| 12464 | XDTHR = CDQ/ECM |
| 12465 | |
| 12466 | * maximum-x for sea-quarks |
| 12467 | XVCUT = XVTHR+XDTHR |
| 12468 | IF (XVCUT.GT.XVMAX) THEN |
| 12469 | XVCUT = XVMAX |
| 12470 | XVTHR = XVCUT/3.0D0 |
| 12471 | XDTHR = XVCUT-XVTHR |
| 12472 | ENDIF |
| 12473 | XXSEAM = ONE-XVCUT |
| 12474 | **sr 18.4. test: DPMJET |
| 12475 | C XXSEAM=1.0 - XVTHR*(1.D0+0.3D0*DT_RNDM(V1)) |
| 12476 | C & - XDTHR*(1.D0+0.3D0*DT_RNDM(V2)) |
| 12477 | C & -0.01*(1.D0+1.5D0*DT_RNDM(V3)) |
| 12478 | ** |
| 12479 | * maximum number of sea-pairs allowed kinematically |
| 12480 | C NSMAX = INT(OHALF*XXSEAM/XSTHR) |
| 12481 | RNSMAX = OHALF*XXSEAM/XSTHR |
| 12482 | IF (RNSMAX.GT.10000.0D0) THEN |
| 12483 | NSMAX = 10000 |
| 12484 | ELSE |
| 12485 | NSMAX = INT(OHALF*XXSEAM/XSTHR) |
| 12486 | ENDIF |
| 12487 | * check kinematical limit for valence-x thresholds |
| 12488 | * (should be obsolete now) |
| 12489 | IF (XVCUT.GT.XVMAX) THEN |
| 12490 | WRITE(LOUT,1000) XVCUT,ECM |
| 12491 | 1000 FORMAT(' XKSAMP: kin. limit for valence-x', |
| 12492 | & ' thresholds not allowed (',2E9.3,')') |
| 12493 | C XVTHR = XVMAX-XDTHR |
| 12494 | C IF (XVTHR.LT.ZERO) STOP |
| 12495 | STOP |
| 12496 | ENDIF |
| 12497 | |
| 12498 | * set eta for valence-x sampling (BETREJ) |
| 12499 | * (UNON per default, UNOM used for projectile mesons only) |
| 12500 | IF ((IJPROJ.NE.0).AND.(IBPROJ.EQ.0)) THEN |
| 12501 | UNOPRV = UNOM |
| 12502 | ELSE |
| 12503 | UNOPRV = UNON |
| 12504 | ENDIF |
| 12505 | |
| 12506 | * (2) select parton x-values of interacting projectile nucleons |
| 12507 | *----------------------------------------------------------------------- |
| 12508 | |
| 12509 | IXPV = 0 |
| 12510 | IXPS = 0 |
| 12511 | |
| 12512 | DO 100 IPP=1,IP |
| 12513 | * get interacting projectile nucleon as sampled by Glauber |
| 12514 | IF (JSSH(IPP).NE.0) THEN |
| 12515 | IXSTMP = IXPS |
| 12516 | IXVTMP = IXPV |
| 12517 | 99 CONTINUE |
| 12518 | IXPS = IXSTMP |
| 12519 | IXPV = IXVTMP |
| 12520 | * JIPP is the actual number of sea-pairs sampled for this nucleon |
| 12521 | JIPP = MIN(JSSH(IPP)-1,NSMAX) |
| 12522 | 41 CONTINUE |
| 12523 | XXSEA = ZERO |
| 12524 | IF (JIPP.GT.0) THEN |
| 12525 | XSMAX = XXSEAM-2.0D0*DBLE(JIPP)*XSTHR |
| 12526 | *??? |
| 12527 | IF (XSTHR.GE.XSMAX) THEN |
| 12528 | JIPP = JIPP-1 |
| 12529 | GOTO 41 |
| 12530 | ENDIF |
| 12531 | |
| 12532 | *>>>get x-values of sea-quark pairs |
| 12533 | NSCOUN = 0 |
| 12534 | PLW = 0.5D0 |
| 12535 | 40 CONTINUE |
| 12536 | * accumulator for sea x-values |
| 12537 | XXSEA = ZERO |
| 12538 | NSCOUN = NSCOUN+1 |
| 12539 | IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0 |
| 12540 | IF (NSCOUN.GT.NSEA) THEN |
| 12541 | * decrease the number of interactions after NSEA trials |
| 12542 | JIPP = JIPP-1 |
| 12543 | NSCOUN = 0 |
| 12544 | ENDIF |
| 12545 | DO 70 ISQ=1,JIPP |
| 12546 | * sea-quarks |
| 12547 | IF (IPSQ(IXPS+1).LE.2) THEN |
| 12548 | **sr 8.4.98 (1/sqrt(x)) |
| 12549 | C XPSQI = DT_SAMPEX(XSTHR,XSMAX) |
| 12550 | C XPSQI = DT_SAMSQX(XSTHR,XSMAX) |
| 12551 | XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW) |
| 12552 | ** |
| 12553 | ELSE |
| 12554 | IF (XSMAX.GT.XSTHR+BSQMA) THEN |
| 12555 | XPSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA) |
| 12556 | ELSE |
| 12557 | **sr 8.4.98 (1/sqrt(x)) |
| 12558 | C XPSQI = DT_SAMPEX(XSTHR,XSMAX) |
| 12559 | C XPSQI = DT_SAMSQX(XSTHR,XSMAX) |
| 12560 | XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW) |
| 12561 | ** |
| 12562 | ENDIF |
| 12563 | ENDIF |
| 12564 | * sea-antiquarks |
| 12565 | IF (IPSAQ(IXPS+1).GE.-2) THEN |
| 12566 | **sr 8.4.98 (1/sqrt(x)) |
| 12567 | C XPSAQI = DT_SAMPEX(XSTHR,XSMAX) |
| 12568 | C XPSAQI = DT_SAMSQX(XSTHR,XSMAX) |
| 12569 | XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW) |
| 12570 | ** |
| 12571 | ELSE |
| 12572 | IF (XSMAX.GT.XSTHR+BSQMA) THEN |
| 12573 | XPSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA) |
| 12574 | ELSE |
| 12575 | **sr 8.4.98 (1/sqrt(x)) |
| 12576 | C XPSAQI = DT_SAMPEX(XSTHR,XSMAX) |
| 12577 | C XPSAQI = DT_SAMSQX(XSTHR,XSMAX) |
| 12578 | XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW) |
| 12579 | ** |
| 12580 | ENDIF |
| 12581 | ENDIF |
| 12582 | XXSEA = XXSEA+XPSQI+XPSAQI |
| 12583 | * check for maximum allowed sea x-value |
| 12584 | IF (XXSEA.GE.XXSEAM) THEN |
| 12585 | IXPS = IXPS-ISQ+1 |
| 12586 | GOTO 40 |
| 12587 | ENDIF |
| 12588 | * accept this sea-quark pair |
| 12589 | IXPS = IXPS+1 |
| 12590 | XPSQ(IXPS) = XPSQI |
| 12591 | XPSAQ(IXPS) = XPSAQI |
| 12592 | IFROSP(IXPS) = IPP |
| 12593 | ZUOSP(IXPS) = .TRUE. |
| 12594 | 70 CONTINUE |
| 12595 | ENDIF |
| 12596 | |
| 12597 | *>>>get x-values of valence partons |
| 12598 | * valence quark |
| 12599 | IF (XVTHR.GT.0.05D0) THEN |
| 12600 | XVHI = ONE-XXSEA-XDTHR |
| 12601 | XPVQI = DT_BETREJ(OHALF,UNOPRV,XVTHR,XVHI) |
| 12602 | ELSE |
| 12603 | 90 CONTINUE |
| 12604 | XPVQI = DT_DBETAR(OHALF,UNOPRV) |
| 12605 | IF ((XPVQI.LT.XVTHR).OR.(ONE-XPVQI-XXSEA.LT.XDTHR)) |
| 12606 | & GOTO 90 |
| 12607 | ENDIF |
| 12608 | * valence diquark |
| 12609 | XPVDI = ONE-XPVQI-XXSEA |
| 12610 | * reject according to x**1.5 |
| 12611 | XDTMP = XPVDI**1.5D0 |
| 12612 | IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 99 |
| 12613 | * accept these valence partons |
| 12614 | IXPV = IXPV+1 |
| 12615 | XPVQ(IXPV) = XPVQI |
| 12616 | XPVD(IXPV) = XPVDI |
| 12617 | IFROVP(IXPV) = IPP |
| 12618 | ITOVP(IPP) = IXPV |
| 12619 | ZUOVP(IXPV) = .TRUE. |
| 12620 | |
| 12621 | ENDIF |
| 12622 | 100 CONTINUE |
| 12623 | |
| 12624 | * (3) select parton x-values of interacting target nucleons |
| 12625 | *----------------------------------------------------------------------- |
| 12626 | |
| 12627 | IXTV = 0 |
| 12628 | IXTS = 0 |
| 12629 | |
| 12630 | DO 170 ITT=1,IT |
| 12631 | * get interacting target nucleon as sampled by Glauber |
| 12632 | IF (JTSH(ITT).NE.0) THEN |
| 12633 | IXSTMP = IXTS |
| 12634 | IXVTMP = IXTV |
| 12635 | 169 CONTINUE |
| 12636 | IXTS = IXSTMP |
| 12637 | IXTV = IXVTMP |
| 12638 | * JITT is the actual number of sea-pairs sampled for this nucleon |
| 12639 | JITT = MIN(JTSH(ITT)-1,NSMAX) |
| 12640 | 111 CONTINUE |
| 12641 | XXSEA = ZERO |
| 12642 | IF (JITT.GT.0) THEN |
| 12643 | XSMAX = XXSEAM-2.0D0*DBLE(JITT)*XSTHR |
| 12644 | *??? |
| 12645 | IF (XSTHR.GE.XSMAX) THEN |
| 12646 | JITT = JITT-1 |
| 12647 | GOTO 111 |
| 12648 | ENDIF |
| 12649 | |
| 12650 | *>>>get x-values of sea-quark pairs |
| 12651 | NSCOUN = 0 |
| 12652 | PLW = 0.5D0 |
| 12653 | 110 CONTINUE |
| 12654 | * accumulator for sea x-values |
| 12655 | XXSEA = ZERO |
| 12656 | NSCOUN = NSCOUN+1 |
| 12657 | IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0 |
| 12658 | IF (NSCOUN.GT.NSEA)THEN |
| 12659 | * decrease the number of interactions after NSEA trials |
| 12660 | JITT = JITT-1 |
| 12661 | NSCOUN = 0 |
| 12662 | ENDIF |
| 12663 | DO 140 ISQ=1,JITT |
| 12664 | * sea-quarks |
| 12665 | IF (ITSQ(IXTS+1).LE.2) THEN |
| 12666 | **sr 8.4.98 (1/sqrt(x)) |
| 12667 | C XTSQI = DT_SAMPEX(XSTHR,XSMAX) |
| 12668 | C XTSQI = DT_SAMSQX(XSTHR,XSMAX) |
| 12669 | XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW) |
| 12670 | ** |
| 12671 | ELSE |
| 12672 | IF (XSMAX.GT.XSTHR+BSQMA) THEN |
| 12673 | XTSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA) |
| 12674 | ELSE |
| 12675 | **sr 8.4.98 (1/sqrt(x)) |
| 12676 | C XTSQI = DT_SAMPEX(XSTHR,XSMAX) |
| 12677 | C XTSQI = DT_SAMSQX(XSTHR,XSMAX) |
| 12678 | XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW) |
| 12679 | ** |
| 12680 | ENDIF |
| 12681 | ENDIF |
| 12682 | * sea-antiquarks |
| 12683 | IF (ITSAQ(IXTS+1).GE.-2) THEN |
| 12684 | **sr 8.4.98 (1/sqrt(x)) |
| 12685 | C XTSAQI = DT_SAMPEX(XSTHR,XSMAX) |
| 12686 | C XTSAQI = DT_SAMSQX(XSTHR,XSMAX) |
| 12687 | XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW) |
| 12688 | ** |
| 12689 | ELSE |
| 12690 | IF (XSMAX.GT.XSTHR+BSQMA) THEN |
| 12691 | XTSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA) |
| 12692 | ELSE |
| 12693 | **sr 8.4.98 (1/sqrt(x)) |
| 12694 | C XTSAQI = DT_SAMPEX(XSTHR,XSMAX) |
| 12695 | C XTSAQI = DT_SAMSQX(XSTHR,XSMAX) |
| 12696 | XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW) |
| 12697 | ** |
| 12698 | ENDIF |
| 12699 | ENDIF |
| 12700 | XXSEA = XXSEA+XTSQI+XTSAQI |
| 12701 | * check for maximum allowed sea x-value |
| 12702 | IF (XXSEA.GE.XXSEAM) THEN |
| 12703 | IXTS = IXTS-ISQ+1 |
| 12704 | GOTO 110 |
| 12705 | ENDIF |
| 12706 | * accept this sea-quark pair |
| 12707 | IXTS = IXTS+1 |
| 12708 | XTSQ(IXTS) = XTSQI |
| 12709 | XTSAQ(IXTS) = XTSAQI |
| 12710 | IFROST(IXTS) = ITT |
| 12711 | ZUOST(IXTS) = .TRUE. |
| 12712 | 140 CONTINUE |
| 12713 | ENDIF |
| 12714 | |
| 12715 | *>>>get x-values of valence partons |
| 12716 | * valence quark |
| 12717 | IF (XVTHR.GT.0.05D0) THEN |
| 12718 | XVHI = ONE-XXSEA-XDTHR |
| 12719 | XTVQI = DT_BETREJ(OHALF,UNON,XVTHR,XVHI) |
| 12720 | ELSE |
| 12721 | 160 CONTINUE |
| 12722 | XTVQI = DT_DBETAR(OHALF,UNON) |
| 12723 | IF ((XTVQI.LT.XVTHR).OR.(ONE-XTVQI-XXSEA.LT.XDTHR)) |
| 12724 | & GOTO 160 |
| 12725 | ENDIF |
| 12726 | * valence diquark |
| 12727 | XTVDI = ONE-XTVQI-XXSEA |
| 12728 | * reject according to x**1.5 |
| 12729 | XDTMP = XTVDI**1.5D0 |
| 12730 | IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 169 |
| 12731 | * accept these valence partons |
| 12732 | IXTV = IXTV+1 |
| 12733 | XTVQ(IXTV) = XTVQI |
| 12734 | XTVD(IXTV) = XTVDI |
| 12735 | IFROVT(IXTV) = ITT |
| 12736 | ITOVT(ITT) = IXTV |
| 12737 | ZUOVT(IXTV) = .TRUE. |
| 12738 | |
| 12739 | ENDIF |
| 12740 | 170 CONTINUE |
| 12741 | |
| 12742 | * (4) get valence-valence chains |
| 12743 | *----------------------------------------------------------------------- |
| 12744 | |
| 12745 | NVV = 0 |
| 12746 | DO 240 I=1,NN |
| 12747 | INTLO(I) = .TRUE. |
| 12748 | IPVAL = ITOVP(INTER1(I)) |
| 12749 | ITVAL = ITOVT(INTER2(I)) |
| 12750 | IF (ZUOVP(IPVAL).AND.ZUOVT(ITVAL)) THEN |
| 12751 | INTLO(I) = .FALSE. |
| 12752 | ZUOVP(IPVAL) = .FALSE. |
| 12753 | ZUOVT(ITVAL) = .FALSE. |
| 12754 | NVV = NVV+1 |
| 12755 | ISKPCH(8,NVV) = 0 |
| 12756 | INTVV1(NVV) = IPVAL |
| 12757 | INTVV2(NVV) = ITVAL |
| 12758 | ENDIF |
| 12759 | 240 CONTINUE |
| 12760 | |
| 12761 | * (5) get sea-valence chains |
| 12762 | *----------------------------------------------------------------------- |
| 12763 | |
| 12764 | NSV = 0 |
| 12765 | NDV = 0 |
| 12766 | PLW = 0.5D0 |
| 12767 | DO 270 I=1,NN |
| 12768 | IF (INTLO(I)) THEN |
| 12769 | IPVAL = ITOVP(INTER1(I)) |
| 12770 | ITVAL = ITOVT(INTER2(I)) |
| 12771 | DO 250 J=1,IXPS |
| 12772 | IF (ZUOSP(J).AND.(IFROSP(J).EQ.INTER1(I)).AND. |
| 12773 | & ZUOVT(ITVAL)) THEN |
| 12774 | ZUOSP(J) = .FALSE. |
| 12775 | ZUOVT(ITVAL) = .FALSE. |
| 12776 | INTLO(I) = .FALSE. |
| 12777 | IF (LSEADI.AND.(DT_RNDM(PLW).GT.FRCDIQ)) THEN |
| 12778 | * sample sea-diquark pair |
| 12779 | CALL DT_SAMSDQ(ECM,ITVAL,J,2,IREJ1) |
| 12780 | IF (IREJ1.EQ.0) GOTO 260 |
| 12781 | ENDIF |
| 12782 | NSV = NSV+1 |
| 12783 | ISKPCH(4,NSV) = 0 |
| 12784 | INTSV1(NSV) = J |
| 12785 | INTSV2(NSV) = ITVAL |
| 12786 | |
| 12787 | *>>>correct chain kinematics according to minimum chain masses |
| 12788 | * the actual chain masses |
| 12789 | AMSVQ1 = XPSQ(J) *XTVD(ITVAL)*ECM**2 |
| 12790 | AMSVQ2 = XPSAQ(J)*XTVQ(ITVAL)*ECM**2 |
| 12791 | * get lower mass cuts |
| 12792 | IF (IPSQ(J).EQ.3) THEN |
| 12793 | * q being s-quark |
| 12794 | AMCHK1 = AMAS |
| 12795 | AMCHK2 = AMIS |
| 12796 | ELSE |
| 12797 | * q being u/d-quark |
| 12798 | AMCHK1 = AMAU |
| 12799 | AMCHK2 = AMIU |
| 12800 | ENDIF |
| 12801 | * q-qq chain |
| 12802 | * chain mass above minimum - resampling of sea-q x-value |
| 12803 | IF (AMSVQ1.GT.AMCHK1) THEN |
| 12804 | XPSQTH = AMCHK1/(XTVD(ITVAL)*ECM**2) |
| 12805 | **sr 8.4.98 (1/sqrt(x)) |
| 12806 | C XPSQXX = DT_SAMPEX(XPSQTH,XPSQ(J)) |
| 12807 | C XPSQXX = DT_SAMSQX(XPSQTH,XPSQ(J)) |
| 12808 | XPSQXX = DT_SAMPLW(XPSQTH,XPSQ(J),PLW) |
| 12809 | ** |
| 12810 | XPVD(IPVAL) = XPVD(IPVAL)+XPSQ(J)-XPSQXX |
| 12811 | XPSQ(J) = XPSQXX |
| 12812 | * chain mass below minimum - reset sea-q x-value and correct |
| 12813 | * diquark-x of the same nucleon |
| 12814 | ELSEIF (AMSVQ1.LT.AMCHK1) THEN |
| 12815 | XPSQW = AMCHK1/(XTVD(ITVAL)*ECM**2) |
| 12816 | DXPSQ = XPSQW-XPSQ(J) |
| 12817 | IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN |
| 12818 | XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ |
| 12819 | XPSQ(J) = XPSQW |
| 12820 | ENDIF |
| 12821 | ENDIF |
| 12822 | * aq-q chain |
| 12823 | * chain mass below minimum - reset sea-aq x-value and correct |
| 12824 | * diquark-x of the same nucleon |
| 12825 | IF (AMSVQ2.LT.AMCHK2) THEN |
| 12826 | XPSQW = AMCHK2/(XTVQ(ITVAL)*ECM**2) |
| 12827 | DXPSQ = XPSQW-XPSAQ(J) |
| 12828 | IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN |
| 12829 | XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ |
| 12830 | XPSAQ(J) = XPSQW |
| 12831 | ENDIF |
| 12832 | ENDIF |
| 12833 | *>>>end of chain mass correction |
| 12834 | |
| 12835 | GOTO 260 |
| 12836 | ENDIF |
| 12837 | 250 CONTINUE |
| 12838 | ENDIF |
| 12839 | 260 CONTINUE |
| 12840 | 270 CONTINUE |
| 12841 | |
| 12842 | * (6) get valence-sea chains |
| 12843 | *----------------------------------------------------------------------- |
| 12844 | |
| 12845 | NVS = 0 |
| 12846 | NVD = 0 |
| 12847 | DO 300 I=1,NN |
| 12848 | IF (INTLO(I)) THEN |
| 12849 | IPVAL = ITOVP(INTER1(I)) |
| 12850 | ITVAL = ITOVT(INTER2(I)) |
| 12851 | DO 280 J=1,IXTS |
| 12852 | IF (ZUOVP(IPVAL).AND.ZUOST(J).AND. |
| 12853 | & (IFROST(J).EQ.INTER2(I))) THEN |
| 12854 | ZUOST(J) = .FALSE. |
| 12855 | ZUOVP(IPVAL) = .FALSE. |
| 12856 | INTLO(I) = .FALSE. |
| 12857 | IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN |
| 12858 | * sample sea-diquark pair |
| 12859 | CALL DT_SAMSDQ(ECM,IPVAL,J,1,IREJ1) |
| 12860 | IF (IREJ1.EQ.0) GOTO 290 |
| 12861 | ENDIF |
| 12862 | NVS = NVS + 1 |
| 12863 | ISKPCH(6,NVS) = 0 |
| 12864 | INTVS1(NVS) = IPVAL |
| 12865 | INTVS2(NVS) = J |
| 12866 | |
| 12867 | *>>>correct chain kinematics according to minimum chain masses |
| 12868 | * the actual chain masses |
| 12869 | AMVSQ1 = XPVQ(IPVAL)*XTSAQ(J)*ECM**2 |
| 12870 | AMVSQ2 = XPVD(IPVAL)*XTSQ(J) *ECM**2 |
| 12871 | * get lower mass cuts |
| 12872 | IF (ITSQ(J).EQ.3) THEN |
| 12873 | * q being s-quark |
| 12874 | AMCHK1 = AMIS |
| 12875 | AMCHK2 = AMAS |
| 12876 | ELSE |
| 12877 | * q being u/d-quark |
| 12878 | AMCHK1 = AMIU |
| 12879 | AMCHK2 = AMAU |
| 12880 | ENDIF |
| 12881 | * q-aq chain |
| 12882 | * chain mass below minimum - reset sea-aq x-value and correct |
| 12883 | * diquark-x of the same nucleon |
| 12884 | IF (AMVSQ1.LT.AMCHK1) THEN |
| 12885 | XTSQW = AMCHK1/(XPVQ(IPVAL)*ECM**2) |
| 12886 | DXTSQ = XTSQW-XTSAQ(J) |
| 12887 | IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN |
| 12888 | XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ |
| 12889 | XTSAQ(J) = XTSQW |
| 12890 | ENDIF |
| 12891 | ENDIF |
| 12892 | * qq-q chain |
| 12893 | * chain mass above minimum - resampling of sea-q x-value |
| 12894 | IF (AMVSQ2.GT.AMCHK2) THEN |
| 12895 | XTSQTH = AMCHK2/(XPVD(IPVAL)*ECM**2) |
| 12896 | **sr 8.4.98 (1/sqrt(x)) |
| 12897 | C XTSQXX = DT_SAMPEX(XTSQTH,XTSQ(J)) |
| 12898 | C XTSQXX = DT_SAMSQX(XTSQTH,XTSQ(J)) |
| 12899 | XTSQXX = DT_SAMPLW(XTSQTH,XTSQ(J),PLW) |
| 12900 | ** |
| 12901 | XTVD(ITVAL) = XTVD(ITVAL)+XTSQ(J)-XTSQXX |
| 12902 | XTSQ(J) = XTSQXX |
| 12903 | * chain mass below minimum - reset sea-q x-value and correct |
| 12904 | * diquark-x of the same nucleon |
| 12905 | ELSEIF (AMVSQ2.LT.AMCHK2) THEN |
| 12906 | XTSQW = AMCHK2/(XPVD(IPVAL)*ECM**2) |
| 12907 | DXTSQ = XTSQW-XTSQ(J) |
| 12908 | IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN |
| 12909 | XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ |
| 12910 | XTSQ(J) = XTSQW |
| 12911 | ENDIF |
| 12912 | ENDIF |
| 12913 | *>>>end of chain mass correction |
| 12914 | |
| 12915 | GOTO 290 |
| 12916 | ENDIF |
| 12917 | 280 CONTINUE |
| 12918 | ENDIF |
| 12919 | 290 CONTINUE |
| 12920 | 300 CONTINUE |
| 12921 | |
| 12922 | * (7) get sea-sea chains |
| 12923 | *----------------------------------------------------------------------- |
| 12924 | |
| 12925 | NSS = 0 |
| 12926 | NDS = 0 |
| 12927 | NSD = 0 |
| 12928 | DO 420 I=1,NN |
| 12929 | IF (INTLO(I)) THEN |
| 12930 | IPVAL = ITOVP(INTER1(I)) |
| 12931 | ITVAL = ITOVT(INTER2(I)) |
| 12932 | * loop over target partons not yet matched |
| 12933 | DO 400 J=1,IXTS |
| 12934 | IF (ZUOST(J).AND.(IFROST(J).EQ.INTER2(I))) THEN |
| 12935 | * loop over projectile partons not yet matched |
| 12936 | DO 390 JJ=1,IXPS |
| 12937 | IF (ZUOSP(JJ).AND.(IFROSP(JJ).EQ.INTER1(I))) THEN |
| 12938 | ZUOSP(JJ) = .FALSE. |
| 12939 | ZUOST(J) = .FALSE. |
| 12940 | INTLO(I) = .FALSE. |
| 12941 | NSS = NSS+1 |
| 12942 | ISKPCH(1,NSS) = 0 |
| 12943 | INTSS1(NSS) = JJ |
| 12944 | INTSS2(NSS) = J |
| 12945 | |
| 12946 | *---->chain recombination option |
| 12947 | VALFRA = DBLE(NVV/(NVV+IXPS+IXTS)) |
| 12948 | IF (IRECOM.EQ.1.AND.(DT_RNDM(BSQMA).GT.VALFRA)) |
| 12949 | & THEN |
| 12950 | * sea-sea chains may recombine with valence-valence chains |
| 12951 | * only if they have the same projectile or target nucleon |
| 12952 | DO 4201 IVV=1,NVV |
| 12953 | IF (ISKPCH(8,IVV).NE.99) THEN |
| 12954 | IXVPR = INTVV1(IVV) |
| 12955 | IXVTA = INTVV2(IVV) |
| 12956 | IF ((INTER1(I).EQ.IFROVP(IXVPR)).OR. |
| 12957 | & (INTER2(I).EQ.IFROVT(IXVTA))) THEN |
| 12958 | * recombination possible, drop old v-v and s-s chains |
| 12959 | ISKPCH(1,NSS) = 99 |
| 12960 | ISKPCH(8,IVV) = 99 |
| 12961 | |
| 12962 | * (a) assign new s-v chains |
| 12963 | * ~~~~~~~~~~~~~~~~~~~~~~~~~ |
| 12964 | IF (LSEADI.AND. |
| 12965 | & (DT_RNDM(VALFRA).GT.FRCDIQ)) |
| 12966 | & THEN |
| 12967 | * sample sea-diquark pair |
| 12968 | CALL DT_SAMSDQ(ECM,IXVTA,JJ,2, |
| 12969 | & IREJ1) |
| 12970 | IF (IREJ1.EQ.0) GOTO 4202 |
| 12971 | ENDIF |
| 12972 | NSV = NSV+1 |
| 12973 | ISKPCH(4,NSV) = 0 |
| 12974 | INTSV1(NSV) = JJ |
| 12975 | INTSV2(NSV) = IXVTA |
| 12976 | *>>>>>>>>>>>correct chain kinematics according to minimum chain masses |
| 12977 | * the actual chain masses |
| 12978 | AMSVQ1 = XPSQ(JJ) *XTVD(IXVTA) |
| 12979 | & *ECM**2 |
| 12980 | AMSVQ2 = XPSAQ(JJ)*XTVQ(IXVTA) |
| 12981 | & *ECM**2 |
| 12982 | * get lower mass cuts |
| 12983 | IF (IPSQ(JJ).EQ.3) THEN |
| 12984 | * q being s-quark |
| 12985 | AMCHK1 = AMAS |
| 12986 | AMCHK2 = AMIS |
| 12987 | ELSE |
| 12988 | * q being u/d-quark |
| 12989 | AMCHK1 = AMAU |
| 12990 | AMCHK2 = AMIU |
| 12991 | ENDIF |
| 12992 | * q-qq chain |
| 12993 | * chain mass above minimum - resampling of sea-q x-value |
| 12994 | IF (AMSVQ1.GT.AMCHK1) THEN |
| 12995 | XPSQTH = |
| 12996 | & AMCHK1/(XTVD(IXVTA)*ECM**2) |
| 12997 | **sr 8.4.98 (1/sqrt(x)) |
| 12998 | XPSQXX = |
| 12999 | & DT_SAMPLW(XPSQTH,XPSQ(JJ),PLW) |
| 13000 | C & DT_SAMSQX(XPSQTH,XPSQ(JJ)) |
| 13001 | C & DT_SAMPEX(XPSQTH,XPSQ(JJ)) |
| 13002 | ** |
| 13003 | XPVD(IPVAL) = |
| 13004 | & XPVD(IPVAL)+XPSQ(JJ)-XPSQXX |
| 13005 | XPSQ(JJ) = XPSQXX |
| 13006 | * chain mass below minimum - reset sea-q x-value and correct |
| 13007 | * diquark-x of the same nucleon |
| 13008 | ELSEIF (AMSVQ1.LT.AMCHK1) THEN |
| 13009 | XPSQW = |
| 13010 | & AMCHK1/(XTVD(IXVTA)*ECM**2) |
| 13011 | DXPSQ = XPSQW-XPSQ(JJ) |
| 13012 | IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) |
| 13013 | & THEN |
| 13014 | XPVD(IPVAL) = |
| 13015 | & XPVD(IPVAL)-DXPSQ |
| 13016 | XPSQ(JJ) = XPSQW |
| 13017 | ENDIF |
| 13018 | ENDIF |
| 13019 | * aq-q chain |
| 13020 | * chain mass below minimum - reset sea-aq x-value and correct |
| 13021 | * diquark-x of the same nucleon |
| 13022 | IF (AMSVQ2.LT.AMCHK2) THEN |
| 13023 | XPSQW = |
| 13024 | & AMCHK2/(XTVQ(IXVTA)*ECM**2) |
| 13025 | DXPSQ = XPSQW-XPSAQ(JJ) |
| 13026 | IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) |
| 13027 | & THEN |
| 13028 | XPVD(IPVAL) = |
| 13029 | & XPVD(IPVAL)-DXPSQ |
| 13030 | XPSAQ(JJ) = XPSQW |
| 13031 | ENDIF |
| 13032 | ENDIF |
| 13033 | *>>>>>>>>>>>end of chain mass correction |
| 13034 | 4202 CONTINUE |
| 13035 | |
| 13036 | * (b) assign new v-s chains |
| 13037 | * ~~~~~~~~~~~~~~~~~~~~~~~~~ |
| 13038 | IF (LSEADI.AND.( |
| 13039 | & DT_RNDM(AMSVQ2).GT.FRCDIQ)) |
| 13040 | & THEN |
| 13041 | * sample sea-diquark pair |
| 13042 | CALL DT_SAMSDQ(ECM,IXVPR,J,1, |
| 13043 | & IREJ1) |
| 13044 | IF (IREJ1.EQ.0) GOTO 4203 |
| 13045 | ENDIF |
| 13046 | NVS = NVS+1 |
| 13047 | ISKPCH(6,NVS) = 0 |
| 13048 | INTVS1(NVS) = IXVPR |
| 13049 | INTVS2(NVS) = J |
| 13050 | *>>>>>>>>>>>correct chain kinematics according to minimum chain masses |
| 13051 | * the actual chain masses |
| 13052 | AMVSQ1 = XPVQ(IXVPR)*XTSAQ(J)*ECM**2 |
| 13053 | AMVSQ2 = XPVD(IXVPR)*XTSQ(J) *ECM**2 |
| 13054 | * get lower mass cuts |
| 13055 | IF (ITSQ(J).EQ.3) THEN |
| 13056 | * q being s-quark |
| 13057 | AMCHK1 = AMIS |
| 13058 | AMCHK2 = AMAS |
| 13059 | ELSE |
| 13060 | * q being u/d-quark |
| 13061 | AMCHK1 = AMIU |
| 13062 | AMCHK2 = AMAU |
| 13063 | ENDIF |
| 13064 | * q-aq chain |
| 13065 | * chain mass below minimum - reset sea-aq x-value and correct |
| 13066 | * diquark-x of the same nucleon |
| 13067 | IF (AMVSQ1.LT.AMCHK1) THEN |
| 13068 | XTSQW = |
| 13069 | & AMCHK1/(XPVQ(IXVPR)*ECM**2) |
| 13070 | DXTSQ = XTSQW-XTSAQ(J) |
| 13071 | IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) |
| 13072 | & THEN |
| 13073 | XTVD(ITVAL) = |
| 13074 | & XTVD(ITVAL)-DXTSQ |
| 13075 | XTSAQ(J) = XTSQW |
| 13076 | ENDIF |
| 13077 | ENDIF |
| 13078 | IF (AMVSQ2.GT.AMCHK2) THEN |
| 13079 | XTSQTH = |
| 13080 | & AMCHK2/(XPVD(IXVPR)*ECM**2) |
| 13081 | **sr 8.4.98 (1/sqrt(x)) |
| 13082 | XTSQXX = |
| 13083 | & DT_SAMPLW(XTSQTH,XTSQ(J),PLW) |
| 13084 | C & DT_SAMSQX(XTSQTH,XTSQ(J)) |
| 13085 | C & DT_SAMPEX(XTSQTH,XTSQ(J)) |
| 13086 | ** |
| 13087 | XTVD(ITVAL) = |
| 13088 | & XTVD(ITVAL)+XTSQ(J)-XTSQXX |
| 13089 | XTSQ(J) = XTSQXX |
| 13090 | ELSEIF (AMVSQ2.LT.AMCHK2) THEN |
| 13091 | XTSQW = |
| 13092 | & AMCHK2/(XPVD(IXVPR)*ECM**2) |
| 13093 | DXTSQ = XTSQW-XTSQ(J) |
| 13094 | IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) |
| 13095 | & THEN |
| 13096 | XTVD(ITVAL) = |
| 13097 | & XTVD(ITVAL)-DXTSQ |
| 13098 | XTSQ(J) = XTSQW |
| 13099 | ENDIF |
| 13100 | ENDIF |
| 13101 | *>>>>>>>>>end of chain mass correction |
| 13102 | 4203 CONTINUE |
| 13103 | * jump out of s-s chain loop |
| 13104 | GOTO 420 |
| 13105 | ENDIF |
| 13106 | ENDIF |
| 13107 | 4201 CONTINUE |
| 13108 | ENDIF |
| 13109 | *---->end of chain recombination option |
| 13110 | |
| 13111 | * sample sea-diquark pair (projectile) |
| 13112 | IF (LSEADI.AND.(DT_RNDM(BSQMA).GT.FRCDIQ)) THEN |
| 13113 | CALL DT_SAMSDQ(ECM,J,JJ,4,IREJ1) |
| 13114 | IF (IREJ1.EQ.0) THEN |
| 13115 | ISKPCH(1,NSS) = 99 |
| 13116 | GOTO 410 |
| 13117 | ENDIF |
| 13118 | ENDIF |
| 13119 | * sample sea-diquark pair (target) |
| 13120 | IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN |
| 13121 | CALL DT_SAMSDQ(ECM,JJ,J,3,IREJ1) |
| 13122 | IF (IREJ1.EQ.0) THEN |
| 13123 | ISKPCH(1,NSS) = 99 |
| 13124 | GOTO 410 |
| 13125 | ENDIF |
| 13126 | ENDIF |
| 13127 | *>>>>>correct chain kinematics according to minimum chain masses |
| 13128 | * the actual chain masses |
| 13129 | SSMA1Q = XPSQ(JJ) *XTSAQ(J)*ECM**2 |
| 13130 | SSMA2Q = XPSAQ(JJ)*XTSQ(J) *ECM**2 |
| 13131 | * check for lower mass cuts |
| 13132 | IF ((SSMA1Q.LT.SSMIMQ).OR. |
| 13133 | & (SSMA2Q.LT.SSMIMQ)) THEN |
| 13134 | IPVAL = ITOVP(INTER1(I)) |
| 13135 | ITVAL = ITOVT(INTER2(I)) |
| 13136 | IF ((XPVD(IPVAL).GT.XDTHR+3.5D0*XSSTHR).AND. |
| 13137 | & (XTVD(ITVAL).GT.XDTHR+3.5D0*XSSTHR))THEN |
| 13138 | * maximum allowed x values for sea quarks |
| 13139 | XSPMAX = ONE-XPVQ(IPVAL)-XDTHR- |
| 13140 | & 1.2D0*XSSTHR |
| 13141 | XSTMAX = ONE-XTVQ(ITVAL)-XDTHR- |
| 13142 | & 1.2D0*XSSTHR |
| 13143 | * resampling of x values not possible - skip sea-sea chains |
| 13144 | IF ((XSPMAX.LE.XSSTHR+0.05D0).OR. |
| 13145 | & (XSTMAX.LE.XSSTHR+0.05D0)) GOTO 380 |
| 13146 | * resampling of x for projectile sea quark pair |
| 13147 | ICOUS = 0 |
| 13148 | 310 CONTINUE |
| 13149 | ICOUS = ICOUS+1 |
| 13150 | IF (XSSTHR.GT.0.05D0) THEN |
| 13151 | XPSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR, |
| 13152 | & XSPMAX) |
| 13153 | XPSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR, |
| 13154 | & XSPMAX) |
| 13155 | ELSE |
| 13156 | 320 CONTINUE |
| 13157 | XPSQI = DT_DBETAR(XSEACU,UNOSEA) |
| 13158 | IF ((XPSQI.LT.XSSTHR).OR. |
| 13159 | & (XPSQI.GT.XSPMAX)) GOTO 320 |
| 13160 | 330 CONTINUE |
| 13161 | XPSAQI = DT_DBETAR(XSEACU,UNOSEA) |
| 13162 | IF ((XPSAQI.LT.XSSTHR).OR. |
| 13163 | & (XPSAQI.GT.XSPMAX)) GOTO 330 |
| 13164 | ENDIF |
| 13165 | * final test of remaining x for projectile diquark |
| 13166 | XPVDCO = XPVD(IPVAL)-XPSQI-XPSAQI |
| 13167 | & +XPSQ(JJ)+XPSAQ(JJ) |
| 13168 | IF (XPVDCO.LE.XDTHR) THEN |
| 13169 | *!!! |
| 13170 | C IF (ICOUS.LT.5) GOTO 310 |
| 13171 | IF (ICOUS.LT.0.5D0) GOTO 310 |
| 13172 | GOTO 380 |
| 13173 | ENDIF |
| 13174 | * resampling of x for target sea quark pair |
| 13175 | ICOUS = 0 |
| 13176 | 350 CONTINUE |
| 13177 | ICOUS = ICOUS+1 |
| 13178 | IF (XSSTHR.GT.0.05D0) THEN |
| 13179 | XTSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR, |
| 13180 | & XSTMAX) |
| 13181 | XTSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR, |
| 13182 | & XSTMAX) |
| 13183 | ELSE |
| 13184 | 360 CONTINUE |
| 13185 | XTSQI = DT_DBETAR(XSEACU,UNOSEA) |
| 13186 | IF ((XTSQI.LT.XSSTHR).OR. |
| 13187 | & (XTSQI.GT.XSTMAX)) GOTO 360 |
| 13188 | 370 CONTINUE |
| 13189 | XTSAQI = DT_DBETAR(XSEACU,UNOSEA) |
| 13190 | IF ((XTSAQI.LT.XSSTHR).OR. |
| 13191 | & (XTSAQI.GT.XSTMAX)) GOTO 370 |
| 13192 | ENDIF |
| 13193 | * final test of remaining x for target diquark |
| 13194 | XTVDCO = XTVD(ITVAL)-XTSQI-XTSAQI |
| 13195 | & +XTSQ(J)+XTSAQ(J) |
| 13196 | IF (XTVDCO.LT.XDTHR) THEN |
| 13197 | IF (ICOUS.LT.5) GOTO 350 |
| 13198 | GOTO 380 |
| 13199 | ENDIF |
| 13200 | XPVD(IPVAL) = XPVDCO |
| 13201 | XTVD(ITVAL) = XTVDCO |
| 13202 | XPSQ(JJ) = XPSQI |
| 13203 | XPSAQ(JJ) = XPSAQI |
| 13204 | XTSQ(J) = XTSQI |
| 13205 | XTSAQ(J) = XTSAQI |
| 13206 | *>>>>>end of chain mass correction |
| 13207 | GOTO 410 |
| 13208 | ENDIF |
| 13209 | * come here to discard s-s interaction |
| 13210 | * resampling of x values not allowed or unsuccessful |
| 13211 | 380 CONTINUE |
| 13212 | INTLO(I) = .FALSE. |
| 13213 | ZUOST(J) = .TRUE. |
| 13214 | ZUOSP(JJ) = .TRUE. |
| 13215 | NSS = NSS-1 |
| 13216 | ENDIF |
| 13217 | * consider next s-s interaction |
| 13218 | GOTO 410 |
| 13219 | ENDIF |
| 13220 | 390 CONTINUE |
| 13221 | ENDIF |
| 13222 | 400 CONTINUE |
| 13223 | ENDIF |
| 13224 | 410 CONTINUE |
| 13225 | 420 CONTINUE |
| 13226 | |
| 13227 | * correct x-values of valence quarks for non-matching sea quarks |
| 13228 | DO 430 I=1,IXPS |
| 13229 | IF (ZUOSP(I)) THEN |
| 13230 | IPVAL = ITOVP(IFROSP(I)) |
| 13231 | XPVQ(IPVAL) = XPVQ(IPVAL)+XPSQ(I)+XPSAQ(I) |
| 13232 | XPSQ(I) = ZERO |
| 13233 | XPSAQ(I) = ZERO |
| 13234 | ZUOSP(I) = .FALSE. |
| 13235 | ENDIF |
| 13236 | 430 CONTINUE |
| 13237 | DO 440 I=1,IXTS |
| 13238 | IF (ZUOST(I)) THEN |
| 13239 | ITVAL = ITOVT(IFROST(I)) |
| 13240 | XTVQ(ITVAL) = XTVQ(ITVAL)+XTSQ(I)+XTSAQ(I) |
| 13241 | XTSQ(I) = ZERO |
| 13242 | XTSAQ(I) = ZERO |
| 13243 | ZUOST(I) = .FALSE. |
| 13244 | ENDIF |
| 13245 | 440 CONTINUE |
| 13246 | DO 450 I=1,IXPV |
| 13247 | IF (ZUOVP(I)) ISTHKK(IFROVP(I)) = 13 |
| 13248 | 450 CONTINUE |
| 13249 | DO 460 I=1,IXTV |
| 13250 | IF (ZUOVT(I)) ISTHKK(IFROVT(I)+IP) = 14 |
| 13251 | 460 CONTINUE |
| 13252 | |
| 13253 | RETURN |
| 13254 | END |
| 13255 | * |
| 13256 | *===samsdq=============================================================* |
| 13257 | * |
| 13258 | CDECK ID>, DT_SAMSDQ |
| 13259 | SUBROUTINE DT_SAMSDQ(ECM,IDX1,IDX2,MODE,IREJ) |
| 13260 | |
| 13261 | ************************************************************************ |
| 13262 | * SAMpling of Sea-DiQuarks * |
| 13263 | * ECM cm-energy of the nucleon-nucleon system * |
| 13264 | * IDX1,2 indices of x-values of the participating * |
| 13265 | * partons (IDX2 is always the sea-q-pair to be * |
| 13266 | * changed to sea-qq-pair) * |
| 13267 | * MODE = 1 valence-q - sea-diq * |
| 13268 | * = 2 sea-diq - valence-q * |
| 13269 | * = 3 sea-q - sea-diq * |
| 13270 | * = 4 sea-diq - sea-q * |
| 13271 | * Based on DIQVS, DIQSV, DIQSSD, DIQDSS. * |
| 13272 | * This version dated 17.10.95 is written by S. Roesler * |
| 13273 | ************************************************************************ |
| 13274 | |
| 13275 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 13276 | SAVE |
| 13277 | |
| 13278 | PARAMETER (ZERO=0.0D0) |
| 13279 | |
| 13280 | * threshold values for x-sampling (DTUNUC 1.x) |
| 13281 | COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA, |
| 13282 | & SSMIMQ,VVMTHR |
| 13283 | * various options for treatment of partons (DTUNUC 1.x) |
| 13284 | * (chain recombination, Cronin,..) |
| 13285 | LOGICAL LCO2CR,LINTPT |
| 13286 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, |
| 13287 | & LCO2CR,LINTPT |
| 13288 | |
| 13289 | PARAMETER ( MAXNCL = 260, |
| 13290 | |
| 13291 | & MAXVQU = MAXNCL, |
| 13292 | & MAXSQU = 20*MAXVQU, |
| 13293 | & MAXINT = MAXVQU+MAXSQU) |
| 13294 | * x-values of partons (DTUNUC 1.x) |
| 13295 | COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU), |
| 13296 | & XTVQ(MAXVQU),XTVD(MAXVQU), |
| 13297 | & XPSQ(MAXSQU),XPSAQ(MAXSQU), |
| 13298 | & XTSQ(MAXSQU),XTSAQ(MAXSQU) |
| 13299 | * flavors of partons (DTUNUC 1.x) |
| 13300 | COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU), |
| 13301 | & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU), |
| 13302 | & IPSQ(MAXSQU),IPSQ2(MAXSQU), |
| 13303 | & IPSAQ(MAXSQU),IPSAQ2(MAXSQU), |
| 13304 | & ITSQ(MAXSQU),ITSQ2(MAXSQU), |
| 13305 | & ITSAQ(MAXSQU),ITSAQ2(MAXSQU), |
| 13306 | & KKPROJ(MAXVQU),KKTARG(MAXVQU) |
| 13307 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) |
| 13308 | COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD, |
| 13309 | & IXPV,IXPS,IXTV,IXTS, |
| 13310 | & INTVV1(MAXVQU),INTVV2(MAXVQU), |
| 13311 | & INTSV1(MAXVQU),INTSV2(MAXVQU), |
| 13312 | & INTVS1(MAXVQU),INTVS2(MAXVQU), |
| 13313 | & INTSS1(MAXSQU),INTSS2(MAXSQU), |
| 13314 | & INTDV1(MAXVQU),INTDV2(MAXVQU), |
| 13315 | & INTVD1(MAXVQU),INTVD2(MAXVQU), |
| 13316 | & INTDS1(MAXSQU),INTDS2(MAXSQU), |
| 13317 | & INTSD1(MAXSQU),INTSD2(MAXSQU) |
| 13318 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) |
| 13319 | COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU), |
| 13320 | & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU) |
| 13321 | * auxiliary common for chain system storage (DTUNUC 1.x) |
| 13322 | COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL) |
| 13323 | |
| 13324 | IREJ = 0 |
| 13325 | * threshold-x for valence diquarks |
| 13326 | XDTHR = CDQ/ECM |
| 13327 | |
| 13328 | GOTO (1,2,3,4) MODE |
| 13329 | |
| 13330 | *--------------------------------------------------------------------- |
| 13331 | * proj. valence partons - targ. sea partons |
| 13332 | * get x-values and flavors for target sea-diquark pair |
| 13333 | |
| 13334 | 1 CONTINUE |
| 13335 | IDXVP = IDX1 |
| 13336 | IDXST = IDX2 |
| 13337 | |
| 13338 | * index of corr. val-diquark-x in target nucleon |
| 13339 | IDXVT = ITOVT(IFROST(IDXST)) |
| 13340 | * available x above diquark thresholds for valence- and sea-diquarks |
| 13341 | XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR |
| 13342 | |
| 13343 | IF (XXD.GE.ZERO) THEN |
| 13344 | * x-values for the three diquarks of the target nucleon |
| 13345 | RR1 = DT_RNDM(XXD) |
| 13346 | RR2 = DT_RNDM(RR1) |
| 13347 | RR3 = DT_RNDM(RR2) |
| 13348 | SR123 = RR1+RR2+RR3 |
| 13349 | XXTV = XDTHR+RR1*XXD/SR123 |
| 13350 | XXTSQ = XDTHR+RR2*XXD/SR123 |
| 13351 | XXTSAQ = XDTHR+RR3*XXD/SR123 |
| 13352 | ELSE |
| 13353 | XXTV = XTVD(IDXVT) |
| 13354 | XXTSQ = XTSQ(IDXST) |
| 13355 | XXTSAQ = XTSAQ(IDXST) |
| 13356 | ENDIF |
| 13357 | * flavor of the second quarks in the sea-diquark pair |
| 13358 | ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ)) |
| 13359 | ITSAQ2(IDXST) = -ITSQ2(IDXST) |
| 13360 | * check masses of the new val-q - sea-qq, val-qq - sea-aqaq chains |
| 13361 | AM1 = XXTSQ *XPVQ(IDXVP)*ECM**2 |
| 13362 | AM2 = XXTSAQ*XPVD(IDXVP)*ECM**2 |
| 13363 | IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND. |
| 13364 | * ss-asas pair |
| 13365 | & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN |
| 13366 | IREJ = 1 |
| 13367 | RETURN |
| 13368 | ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND. |
| 13369 | * at least one strange quark |
| 13370 | & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN |
| 13371 | IREJ = 1 |
| 13372 | RETURN |
| 13373 | ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN |
| 13374 | IREJ = 1 |
| 13375 | RETURN |
| 13376 | ENDIF |
| 13377 | * accept the new sea-diquark |
| 13378 | XTVD(IDXVT) = XXTV |
| 13379 | XTSQ(IDXST) = XXTSQ |
| 13380 | XTSAQ(IDXST) = XXTSAQ |
| 13381 | NVD = NVD+1 |
| 13382 | INTVD1(NVD) = IDXVP |
| 13383 | INTVD2(NVD) = IDXST |
| 13384 | ISKPCH(7,NVD) = 0 |
| 13385 | RETURN |
| 13386 | |
| 13387 | *--------------------------------------------------------------------- |
| 13388 | * proj. sea partons - targ. valence partons |
| 13389 | * get x-values and flavors for projectile sea-diquark pair |
| 13390 | |
| 13391 | 2 CONTINUE |
| 13392 | IDXSP = IDX2 |
| 13393 | IDXVT = IDX1 |
| 13394 | |
| 13395 | * index of corr. val-diquark-x in projectile nucleon |
| 13396 | IDXVP = ITOVP(IFROSP(IDXSP)) |
| 13397 | * available x above diquark thresholds for valence- and sea-diquarks |
| 13398 | XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR |
| 13399 | |
| 13400 | IF (XXD.GE.ZERO) THEN |
| 13401 | * x-values for the three diquarks of the projectile nucleon |
| 13402 | RR1 = DT_RNDM(XXD) |
| 13403 | RR2 = DT_RNDM(RR1) |
| 13404 | RR3 = DT_RNDM(RR2) |
| 13405 | SR123 = RR1+RR2+RR3 |
| 13406 | XXPV = XDTHR+RR1*XXD/SR123 |
| 13407 | XXPSQ = XDTHR+RR2*XXD/SR123 |
| 13408 | XXPSAQ = XDTHR+RR3*XXD/SR123 |
| 13409 | ELSE |
| 13410 | XXPV = XPVD(IDXVP) |
| 13411 | XXPSQ = XPSQ(IDXSP) |
| 13412 | XXPSAQ = XPSAQ(IDXSP) |
| 13413 | ENDIF |
| 13414 | * flavor of the second quarks in the sea-diquark pair |
| 13415 | IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ)) |
| 13416 | IPSAQ2(IDXSP) = -IPSQ2(IDXSP) |
| 13417 | * check masses of the new sea-qq - val-q, sea-aqaq - val-qq chains |
| 13418 | AM1 = XXPSQ *XTVQ(IDXVT)*ECM**2 |
| 13419 | AM2 = XXPSAQ*XTVD(IDXVT)*ECM**2 |
| 13420 | IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND. |
| 13421 | * ss-asas pair |
| 13422 | & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN |
| 13423 | IREJ = 1 |
| 13424 | RETURN |
| 13425 | ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND. |
| 13426 | * at least one strange quark |
| 13427 | & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN |
| 13428 | IREJ = 1 |
| 13429 | RETURN |
| 13430 | ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN |
| 13431 | IREJ = 1 |
| 13432 | RETURN |
| 13433 | ENDIF |
| 13434 | * accept the new sea-diquark |
| 13435 | XPVD(IDXVP) = XXPV |
| 13436 | XPSQ(IDXSP) = XXPSQ |
| 13437 | XPSAQ(IDXSP) = XXPSAQ |
| 13438 | NDV = NDV+1 |
| 13439 | INTDV1(NDV) = IDXSP |
| 13440 | INTDV2(NDV) = IDXVT |
| 13441 | ISKPCH(5,NDV) = 0 |
| 13442 | RETURN |
| 13443 | |
| 13444 | *--------------------------------------------------------------------- |
| 13445 | * proj. sea partons - targ. sea partons |
| 13446 | * get x-values and flavors for target sea-diquark pair |
| 13447 | |
| 13448 | 3 CONTINUE |
| 13449 | IDXSP = IDX1 |
| 13450 | IDXST = IDX2 |
| 13451 | |
| 13452 | * index of corr. val-diquark-x in target nucleon |
| 13453 | IDXVT = ITOVT(IFROST(IDXST)) |
| 13454 | * available x above diquark thresholds for valence- and sea-diquarks |
| 13455 | XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR |
| 13456 | |
| 13457 | IF (XXD.GE.ZERO) THEN |
| 13458 | * x-values for the three diquarks of the target nucleon |
| 13459 | RR1 = DT_RNDM(XXD) |
| 13460 | RR2 = DT_RNDM(RR1) |
| 13461 | RR3 = DT_RNDM(RR2) |
| 13462 | SR123 = RR1+RR2+RR3 |
| 13463 | XXTV = XDTHR+RR1*XXD/SR123 |
| 13464 | XXTSQ = XDTHR+RR2*XXD/SR123 |
| 13465 | XXTSAQ = XDTHR+RR3*XXD/SR123 |
| 13466 | ELSE |
| 13467 | XXTV = XTVD(IDXVT) |
| 13468 | XXTSQ = XTSQ(IDXST) |
| 13469 | XXTSAQ = XTSAQ(IDXST) |
| 13470 | ENDIF |
| 13471 | * flavor of the second quarks in the sea-diquark pair |
| 13472 | ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ)) |
| 13473 | ITSAQ2(IDXST) = -ITSQ2(IDXST) |
| 13474 | * check masses of the new sea-q - sea-qq, sea-aq - sea-aqaq chains |
| 13475 | AM1 = XXTSQ *XPSQ(IDXSP)*ECM**2 |
| 13476 | AM2 = XXTSAQ*XPSAQ(IDXSP)*ECM**2 |
| 13477 | IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND. |
| 13478 | * ss-asas pair |
| 13479 | & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN |
| 13480 | IREJ = 1 |
| 13481 | RETURN |
| 13482 | ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND. |
| 13483 | * at least one strange quark |
| 13484 | & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN |
| 13485 | IREJ = 1 |
| 13486 | RETURN |
| 13487 | ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN |
| 13488 | IREJ = 1 |
| 13489 | RETURN |
| 13490 | ENDIF |
| 13491 | * accept the new sea-diquark |
| 13492 | XTVD(IDXVT) = XXTV |
| 13493 | XTSQ(IDXST) = XXTSQ |
| 13494 | XTSAQ(IDXST) = XXTSAQ |
| 13495 | NSD = NSD+1 |
| 13496 | INTSD1(NSD) = IDXSP |
| 13497 | INTSD2(NSD) = IDXST |
| 13498 | ISKPCH(3,NSD) = 0 |
| 13499 | RETURN |
| 13500 | |
| 13501 | *--------------------------------------------------------------------- |
| 13502 | * proj. sea partons - targ. sea partons |
| 13503 | * get x-values and flavors for projectile sea-diquark pair |
| 13504 | |
| 13505 | 4 CONTINUE |
| 13506 | IDXSP = IDX2 |
| 13507 | IDXST = IDX1 |
| 13508 | |
| 13509 | * index of corr. val-diquark-x in projectile nucleon |
| 13510 | IDXVP = ITOVP(IFROSP(IDXSP)) |
| 13511 | * available x above diquark thresholds for valence- and sea-diquarks |
| 13512 | XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR |
| 13513 | |
| 13514 | IF (XXD.GE.ZERO) THEN |
| 13515 | * x-values for the three diquarks of the projectile nucleon |
| 13516 | RR1 = DT_RNDM(XXD) |
| 13517 | RR2 = DT_RNDM(RR1) |
| 13518 | RR3 = DT_RNDM(RR2) |
| 13519 | SR123 = RR1+RR2+RR3 |
| 13520 | XXPV = XDTHR+RR1*XXD/SR123 |
| 13521 | XXPSQ = XDTHR+RR2*XXD/SR123 |
| 13522 | XXPSAQ = XDTHR+RR3*XXD/SR123 |
| 13523 | ELSE |
| 13524 | XXPV = XPVD(IDXVP) |
| 13525 | XXPSQ = XPSQ(IDXSP) |
| 13526 | XXPSAQ = XPSAQ(IDXSP) |
| 13527 | ENDIF |
| 13528 | * flavor of the second quarks in the sea-diquark pair |
| 13529 | IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ)) |
| 13530 | IPSAQ2(IDXSP) = -IPSQ2(IDXSP) |
| 13531 | * check masses of the new sea-qq - sea-q, sea-aqaq - sea-qq chains |
| 13532 | AM1 = XXPSQ *XTSQ(IDXST)*ECM**2 |
| 13533 | AM2 = XXPSAQ*XTSAQ(IDXST)*ECM**2 |
| 13534 | IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND. |
| 13535 | * ss-asas pair |
| 13536 | & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN |
| 13537 | IREJ = 1 |
| 13538 | RETURN |
| 13539 | ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND. |
| 13540 | * at least one strange quark |
| 13541 | & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN |
| 13542 | IREJ = 1 |
| 13543 | RETURN |
| 13544 | ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN |
| 13545 | IREJ = 1 |
| 13546 | RETURN |
| 13547 | ENDIF |
| 13548 | * accept the new sea-diquark |
| 13549 | XPVD(IDXVP) = XXPV |
| 13550 | XPSQ(IDXSP) = XXPSQ |
| 13551 | XPSAQ(IDXSP) = XXPSAQ |
| 13552 | NDS = NDS+1 |
| 13553 | INTDS1(NDS) = IDXSP |
| 13554 | INTDS2(NDS) = IDXST |
| 13555 | ISKPCH(2,NDS) = 0 |
| 13556 | RETURN |
| 13557 | END |
| 13558 | * |
| 13559 | *===difevt=============================================================* |
| 13560 | * |
| 13561 | CDECK ID>, DT_DIFEVT |
| 13562 | SUBROUTINE DT_DIFEVT(IFP1,IFP2,PP,MOP, |
| 13563 | & IFT1,IFT2,PT,MOT,JDIFF,NCSY,IREJ) |
| 13564 | |
| 13565 | ************************************************************************ |
| 13566 | * Interface to treatment of diffractive interactions. * |
| 13567 | * (input) IFP1/2 PDG-indizes of projectile partons * |
| 13568 | * (baryon: IFP2 - adiquark) * |
| 13569 | * PP(4) projectile 4-momentum * |
| 13570 | * IFT1/2 PDG-indizes of target partons * |
| 13571 | * (baryon: IFT1 - adiquark) * |
| 13572 | * PT(4) target 4-momentum * |
| 13573 | * (output) JDIFF = 0 no diffraction * |
| 13574 | * = 1/-1 LMSD/LMDD * |
| 13575 | * = 2/-2 HMSD/HMDD * |
| 13576 | * NCSY counter for two-chain systems * |
| 13577 | * dumped to DTEVT1 * |
| 13578 | * This version dated 14.02.95 is written by S. Roesler * |
| 13579 | ************************************************************************ |
| 13580 | |
| 13581 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 13582 | SAVE |
| 13583 | |
| 13584 | PARAMETER ( LINP = 5 , |
| 13585 | & LOUT = 6 , |
| 13586 | & LDAT = 9 ) |
| 13587 | |
| 13588 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5, |
| 13589 | & OHALF=0.5D0) |
| 13590 | |
| 13591 | * event history |
| 13592 | |
| 13593 | PARAMETER (NMXHKK=200000) |
| 13594 | |
| 13595 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 13596 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 13597 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 13598 | * extended event history |
| 13599 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 13600 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 13601 | & IHIST(2,NMXHKK) |
| 13602 | * flags for diffractive interactions (DTUNUC 1.x) |
| 13603 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF |
| 13604 | |
| 13605 | DIMENSION PP(4),PT(4) |
| 13606 | |
| 13607 | LOGICAL LFIRST |
| 13608 | DATA LFIRST /.TRUE./ |
| 13609 | |
| 13610 | IREJ = 0 |
| 13611 | JDIFF = 0 |
| 13612 | IFLAGD = JDIFF |
| 13613 | |
| 13614 | * cm. energy |
| 13615 | XM = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2- |
| 13616 | & (PP(2)+PT(2))**2-(PP(3)+PT(3))**2) |
| 13617 | * identities of projectile hadron / target nucleon |
| 13618 | KPROJ = IDT_ICIHAD(IDHKK(MOP)) |
| 13619 | KTARG = IDT_ICIHAD(IDHKK(MOT)) |
| 13620 | |
| 13621 | * single diffractive xsections |
| 13622 | CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM) |
| 13623 | * double diffractive xsections |
| 13624 | **!! no double diff yet |
| 13625 | C CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM,DDTOT,DDHM) |
| 13626 | DDTOT = 0.0D0 |
| 13627 | DDHM = 0.0D0 |
| 13628 | **!! |
| 13629 | * total inelastic xsection |
| 13630 | C SIGIN = DT_SHNTOT(KPROJ,KTARG,XM,ZERO)-DT_SHNELA(KPROJ,KTARG,XM) |
| 13631 | DUMZER = ZERO |
| 13632 | CALL DT_XSHN(KPROJ,KTARG,DUMZER,XM,SIGTO,SIGEL) |
| 13633 | SIGIN = MAX(SIGTO-SIGEL,ZERO) |
| 13634 | |
| 13635 | * fraction of diffractive processes |
| 13636 | FRADIF = (SDTOT+DDTOT)/SIGIN |
| 13637 | |
| 13638 | IF (LFIRST) THEN |
| 13639 | WRITE(LOUT,1000) XM,SDTOT,SIGIN |
| 13640 | 1000 FORMAT(1X,'DIFEVT: single diffraction requested at E_cm = ', |
| 13641 | & F5.1,' GeV',/,9X,'sigma_sd = ',F4.1,' mb, sigma_in = ', |
| 13642 | & F5.1,' mb',/) |
| 13643 | LFIRST = .FALSE. |
| 13644 | ENDIF |
| 13645 | |
| 13646 | IF ((DT_RNDM(DDHM).LE.FRADIF).OR. |
| 13647 | & (ISINGD.GT.1).OR.(IDOUBD.GT.1)) THEN |
| 13648 | * diffractive interaction requested by x-section or by user |
| 13649 | FRASD = SDTOT/(SDTOT+DDTOT) |
| 13650 | FRASDH = SDHM/SDTOT |
| 13651 | **sr needs to be specified!! |
| 13652 | C FRADDH = DDHM/DDTOT |
| 13653 | FRADDH = 1.0D0 |
| 13654 | ** |
| 13655 | IF ((DT_RNDM(FRASD).LE.FRASD).OR.(ISINGD.GT.1)) THEN |
| 13656 | * single diffraction |
| 13657 | KDIFF = 1 |
| 13658 | IF (DT_RNDM(DDTOT).LE.FRASDH) THEN |
| 13659 | KP = 2 |
| 13660 | KT = 0 |
| 13661 | IF (((ISINGD.EQ.4).OR.(DT_RNDM(DDTOT).GE.OHALF)).AND. |
| 13662 | & ISINGD.NE.3) THEN |
| 13663 | KP = 0 |
| 13664 | KT = 2 |
| 13665 | ENDIF |
| 13666 | ELSE |
| 13667 | KP = 1 |
| 13668 | KT = 0 |
| 13669 | IF (((ISINGD.EQ.4).OR.(DT_RNDM(FRADDH).GE.OHALF)).AND. |
| 13670 | & ISINGD.NE.3) THEN |
| 13671 | KP = 0 |
| 13672 | KT = 1 |
| 13673 | ENDIF |
| 13674 | ENDIF |
| 13675 | ELSE |
| 13676 | * double diffraction |
| 13677 | KDIFF = -1 |
| 13678 | IF (DT_RNDM(FRADDH).LE.FRADDH) THEN |
| 13679 | KP = 2 |
| 13680 | KT = 2 |
| 13681 | ELSE |
| 13682 | KP = 1 |
| 13683 | KT = 1 |
| 13684 | ENDIF |
| 13685 | ENDIF |
| 13686 | CALL DT_DIFFKI(IFP1,IFP2,PP,MOP,KP, |
| 13687 | & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1) |
| 13688 | IF (IREJ1.EQ.0) THEN |
| 13689 | IFLAGD = 2*KDIFF |
| 13690 | IF ((KP.EQ.1).OR.(KT.EQ.1)) IFLAGD = KDIFF |
| 13691 | ELSE |
| 13692 | GOTO 9999 |
| 13693 | ENDIF |
| 13694 | ENDIF |
| 13695 | JDIFF = IFLAGD |
| 13696 | |
| 13697 | RETURN |
| 13698 | |
| 13699 | 9999 CONTINUE |
| 13700 | IREJ = 1 |
| 13701 | RETURN |
| 13702 | END |
| 13703 | * |
| 13704 | *===difkin=============================================================* |
| 13705 | * |
| 13706 | CDECK ID>, DT_DIFFKI |
| 13707 | SUBROUTINE DT_DIFFKI(IFP1,IFP2,PP,MOP,KP, |
| 13708 | & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ) |
| 13709 | |
| 13710 | ************************************************************************ |
| 13711 | * Kinematics of diffractive nucleon-nucleon interaction. * |
| 13712 | * IFP1/2 PDG-indizes of projectile partons * |
| 13713 | * (baryon: IFP2 - adiquark) * |
| 13714 | * PP(4) projectile 4-momentum * |
| 13715 | * IFT1/2 PDG-indizes of target partons * |
| 13716 | * (baryon: IFT1 - adiquark) * |
| 13717 | * PT(4) target 4-momentum * |
| 13718 | * KP = 0 projectile quasi-elastically scattered * |
| 13719 | * = 1 excited to low-mass diff. state * |
| 13720 | * = 2 excited to high-mass diff. state * |
| 13721 | * KT = 0 target quasi-elastically scattered * |
| 13722 | * = 1 excited to low-mass diff. state * |
| 13723 | * = 2 excited to high-mass diff. state * |
| 13724 | * This version dated 12.02.95 is written by S. Roesler * |
| 13725 | ************************************************************************ |
| 13726 | |
| 13727 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 13728 | SAVE |
| 13729 | |
| 13730 | PARAMETER ( LINP = 5 , |
| 13731 | & LOUT = 6 , |
| 13732 | & LDAT = 9 ) |
| 13733 | |
| 13734 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5) |
| 13735 | |
| 13736 | LOGICAL LSTART |
| 13737 | |
| 13738 | * particle properties (BAMJET index convention) |
| 13739 | CHARACTER*8 ANAME |
| 13740 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 13741 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 13742 | * flags for input different options |
| 13743 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 13744 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 13745 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 13746 | * rejection counter |
| 13747 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, |
| 13748 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, |
| 13749 | & IREXCI(3),IRDIFF(2),IRINC |
| 13750 | * kinematics of diffractive interactions (DTUNUC 1.x) |
| 13751 | COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4), |
| 13752 | & PPF(4),PTF(4), |
| 13753 | & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4), |
| 13754 | & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2) |
| 13755 | |
| 13756 | DIMENSION PITOT(4),BGTOT(4),PP1(4),PT1(4),PPBLOB(4),PTBLOB(4), |
| 13757 | & PP(4),PT(4),PPOM1(4),DEV1(4),DEV2(4) |
| 13758 | |
| 13759 | DATA LSTART /.TRUE./ |
| 13760 | |
| 13761 | IF (LSTART) THEN |
| 13762 | WRITE(LOUT,2000) |
| 13763 | 2000 FORMAT(/,1X,'DIFEVT: diffractive interactions treated ') |
| 13764 | LSTART = .FALSE. |
| 13765 | ENDIF |
| 13766 | |
| 13767 | IREJ = 0 |
| 13768 | |
| 13769 | * initialize common /DTDIKI/ |
| 13770 | CALL DT_DIFINI |
| 13771 | * store momenta of initial incoming particles for emc-check |
| 13772 | IF (LEMCCK) THEN |
| 13773 | CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM,IDUM) |
| 13774 | CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM,IDUM) |
| 13775 | ENDIF |
| 13776 | |
| 13777 | * masses of initial particles |
| 13778 | XMP2 = PP(4)**2-PP(1)**2-PP(2)**2-PP(3)**2 |
| 13779 | XMT2 = PT(4)**2-PT(1)**2-PT(2)**2-PT(3)**2 |
| 13780 | IF ((XMP2.LT.ZERO).OR.(XMT2.LT.ZERO)) GOTO 9999 |
| 13781 | XMP = SQRT(XMP2) |
| 13782 | XMT = SQRT(XMT2) |
| 13783 | * check quark-input (used to adjust coherence cond. for M-selection) |
| 13784 | IBP = 0 |
| 13785 | IF ((ABS(IFP1).GE.1000).OR.(ABS(IFP2).GE.1000)) IBP = 1 |
| 13786 | IBT = 0 |
| 13787 | IF ((ABS(IFT1).GE.1000).OR.(ABS(IFT2).GE.1000)) IBT = 1 |
| 13788 | |
| 13789 | * parameter for Lorentz-transformation into nucleon-nucleon cms |
| 13790 | DO 3 K=1,4 |
| 13791 | PITOT(K) = PP(K)+PT(K) |
| 13792 | 3 CONTINUE |
| 13793 | XMTOT2 = PITOT(4)**2-PITOT(1)**2-PITOT(2)**2-PITOT(3)**2 |
| 13794 | IF (XMTOT2.LE.ZERO) THEN |
| 13795 | WRITE(LOUT,1000) XMTOT2 |
| 13796 | 1000 FORMAT(1X,'DIFEVT: negative cm. energy! ', |
| 13797 | & 'XMTOT2 = ',E12.3) |
| 13798 | GOTO 9999 |
| 13799 | ENDIF |
| 13800 | XMTOT = SQRT(XMTOT2) |
| 13801 | DO 4 K=1,4 |
| 13802 | BGTOT(K) = PITOT(K)/XMTOT |
| 13803 | 4 CONTINUE |
| 13804 | * transformation of nucleons into cms |
| 13805 | CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PP(1),PP(2), |
| 13806 | & PP(3),PP(4),PPTOT,PP1(1),PP1(2),PP1(3),PP1(4)) |
| 13807 | CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PT(1),PT(2), |
| 13808 | & PT(3),PT(4),PTTOT,PT1(1),PT1(2),PT1(3),PT1(4)) |
| 13809 | * rotation angles |
| 13810 | COD = PP1(3)/PPTOT |
| 13811 | C SID = SQRT((ONE-COD)*(ONE+COD)) |
| 13812 | PPT = SQRT(PP1(1)**2+PP1(2)**2) |
| 13813 | SID = PPT/PPTOT |
| 13814 | COF = ONE |
| 13815 | SIF = ZERO |
| 13816 | IF(PPTOT*SID.GT.TINY10) THEN |
| 13817 | COF = PP1(1)/(SID*PPTOT) |
| 13818 | SIF = PP1(2)/(SID*PPTOT) |
| 13819 | ANORF = SQRT(COF*COF+SIF*SIF) |
| 13820 | COF = COF/ANORF |
| 13821 | SIF = SIF/ANORF |
| 13822 | ENDIF |
| 13823 | * check consistency |
| 13824 | DO 5 K=1,4 |
| 13825 | DEV1(K) = ABS(PP1(K)+PT1(K)) |
| 13826 | 5 CONTINUE |
| 13827 | DEV1(4) = ABS(DEV1(4)-XMTOT) |
| 13828 | IF ((DEV1(1).GT.TINY10).OR.(DEV1(2).GT.TINY10).OR. |
| 13829 | & (DEV1(3).GT.TINY10).OR.(DEV1(4).GT.TINY10)) THEN |
| 13830 | WRITE(LOUT,1001) DEV1 |
| 13831 | 1001 FORMAT(1X,'DIFEVT: inconsitent Lorentz-transformation! ', |
| 13832 | & /,8X,4E12.3) |
| 13833 | GOTO 9999 |
| 13834 | ENDIF |
| 13835 | |
| 13836 | * select x-fractions in high-mass diff. interactions |
| 13837 | IF ((KP.EQ.2).OR.(KT.EQ.2)) CALL DT_XVALHM(KP,KT) |
| 13838 | |
| 13839 | * select diffractive masses |
| 13840 | * - projectile |
| 13841 | IF (KP.EQ.1) THEN |
| 13842 | XMPF = DT_XMLMD(XMTOT) |
| 13843 | CALL DT_LM2RES(IFP1,IFP2,XMPF,IDPR,IDXPR,IREJ1) |
| 13844 | IF (IREJ1.GT.0) GOTO 9999 |
| 13845 | ELSEIF (KP.EQ.2) THEN |
| 13846 | XMPF = DT_XMHMD(XMTOT,IBP,1) |
| 13847 | ELSE |
| 13848 | XMPF = XMP |
| 13849 | ENDIF |
| 13850 | * - target |
| 13851 | IF (KT.EQ.1) THEN |
| 13852 | XMTF = DT_XMLMD(XMTOT) |
| 13853 | CALL DT_LM2RES(IFT1,IFT2,XMTF,IDTR,IDXTR,IREJ1) |
| 13854 | IF (IREJ1.GT.0) GOTO 9999 |
| 13855 | ELSEIF (KT.EQ.2) THEN |
| 13856 | XMTF = DT_XMHMD(XMTOT,IBT,2) |
| 13857 | ELSE |
| 13858 | XMTF = XMT |
| 13859 | ENDIF |
| 13860 | |
| 13861 | * kinematical treatment of "two-particle" system (masses - XMPF,XMTF) |
| 13862 | XMPF2 = XMPF**2 |
| 13863 | XMTF2 = XMTF**2 |
| 13864 | PPBLOB(3) = DT_YLAMB(XMTOT2,XMPF2,XMTF2)/(2.D0*XMTOT) |
| 13865 | PPBLOB(4) = SQRT(XMPF2+PPBLOB(3)**2) |
| 13866 | |
| 13867 | * select momentum transfer (all t-values used here are <0) |
| 13868 | * minimum absolute value to produce diffractive masses |
| 13869 | TMIN = XMP2+XMPF2-2.0D0*(PP1(4)*PPBLOB(4)-PPTOT*PPBLOB(3)) |
| 13870 | TT = DT_TDIFF(XMTOT,TMIN,XMPF,KP,XMTF,KT,IREJ1) |
| 13871 | IF (IREJ1.GT.0) GOTO 9999 |
| 13872 | |
| 13873 | * longitudinal momentum of excited/elastically scattered projectile |
| 13874 | PPBLOB(3) = (TT-XMP2-XMPF2+2.0D0*PP1(4)*PPBLOB(4))/(2.0D0*PPTOT) |
| 13875 | * total transverse momentum due to t-selection |
| 13876 | PPBLT2 = PPBLOB(4)**2-PPBLOB(3)**2-XMPF2 |
| 13877 | IF (PPBLT2.LT.ZERO) THEN |
| 13878 | WRITE(LOUT,1002) PPBLT2,KP,PP1,XMPF,KT,PT1,XMTF,TT |
| 13879 | 1002 FORMAT(1X,'DIFEVT: inconsistent transverse momentum! ', |
| 13880 | & E12.3,2(/,1X,I2,5E12.3),/,1X,E12.3) |
| 13881 | GOTO 9999 |
| 13882 | ENDIF |
| 13883 | CALL DT_DSFECF(SINPHI,COSPHI) |
| 13884 | PPBLT = SQRT(PPBLT2) |
| 13885 | PPBLOB(1) = COSPHI*PPBLT |
| 13886 | PPBLOB(2) = SINPHI*PPBLT |
| 13887 | |
| 13888 | * rotate excited/elastically scattered projectile into n-n cms. |
| 13889 | CALL DT_MYTRAN(1,PPBLOB(1),PPBLOB(2),PPBLOB(3),COD,SID,COF,SIF, |
| 13890 | & XX,YY,ZZ) |
| 13891 | PPBLOB(1) = XX |
| 13892 | PPBLOB(2) = YY |
| 13893 | PPBLOB(3) = ZZ |
| 13894 | |
| 13895 | * 4-momentum of excited/elastically scattered target and of exchanged |
| 13896 | * Pomeron |
| 13897 | DO 6 K=1,4 |
| 13898 | IF (K.LT.4) PTBLOB(K) = -PPBLOB(K) |
| 13899 | PPOM1(K) = PP1(K)-PPBLOB(K) |
| 13900 | 6 CONTINUE |
| 13901 | PTBLOB(4) = XMTOT-PPBLOB(4) |
| 13902 | |
| 13903 | * Lorentz-transformation back into system of initial diff. collision |
| 13904 | CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3), |
| 13905 | & PPBLOB(1),PPBLOB(2),PPBLOB(3),PPBLOB(4), |
| 13906 | & PPTOTF,PPF(1),PPF(2),PPF(3),PPF(4)) |
| 13907 | CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3), |
| 13908 | & PTBLOB(1),PTBLOB(2),PTBLOB(3),PTBLOB(4), |
| 13909 | & PTTOTF,PTF(1),PTF(2),PTF(3),PTF(4)) |
| 13910 | CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3), |
| 13911 | & PPOM1(1),PPOM1(2),PPOM1(3),PPOM1(4), |
| 13912 | & PPOMTO,PPOM(1),PPOM(2),PPOM(3),PPOM(4)) |
| 13913 | |
| 13914 | * store 4-momentum of elastically scattered particle (in single diff. |
| 13915 | * events) |
| 13916 | IF (KP.EQ.0) THEN |
| 13917 | DO 7 K=1,4 |
| 13918 | PSC(K) = PPF(K) |
| 13919 | 7 CONTINUE |
| 13920 | ELSEIF (KT.EQ.0) THEN |
| 13921 | DO 8 K=1,4 |
| 13922 | PSC(K) = PTF(K) |
| 13923 | 8 CONTINUE |
| 13924 | ENDIF |
| 13925 | |
| 13926 | * check consistency of kinematical treatment so far |
| 13927 | IF (LEMCCK) THEN |
| 13928 | CALL DT_EVTEMC(-PPF(1),-PPF(2),-PPF(3),-PPF(4),2,IDUM,IDUM) |
| 13929 | CALL DT_EVTEMC(-PTF(1),-PTF(2),-PTF(3),-PTF(4),2,IDUM,IDUM) |
| 13930 | CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,60,IREJ1) |
| 13931 | IF (IREJ1.NE.0) GOTO 9999 |
| 13932 | ENDIF |
| 13933 | DO 9 K=1,4 |
| 13934 | DEV1(K) = ABS(PP(K)-PPF(K)-PPOM(K)) |
| 13935 | DEV2(K) = ABS(PT(K)-PTF(K)+PPOM(K)) |
| 13936 | 9 CONTINUE |
| 13937 | IF ((DEV1(1).GT.TINY5).OR.(DEV1(2).GT.TINY5).OR. |
| 13938 | & (DEV1(3).GT.TINY5).OR.(DEV1(4).GT.TINY5).OR. |
| 13939 | & (DEV2(1).GT.TINY5).OR.(DEV2(2).GT.TINY5).OR. |
| 13940 | & (DEV2(3).GT.TINY5).OR.(DEV2(4).GT.TINY5)) THEN |
| 13941 | WRITE(LOUT,1003) DEV1,DEV2 |
| 13942 | 1003 FORMAT(1X,'DIFEVT: inconsitent kinematical treatment! ', |
| 13943 | & 2(/,8X,4E12.3)) |
| 13944 | GOTO 9999 |
| 13945 | ENDIF |
| 13946 | |
| 13947 | * kinematical treatment for low-mass diffraction |
| 13948 | CALL DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ1) |
| 13949 | IF (IREJ1.NE.0) GOTO 9999 |
| 13950 | |
| 13951 | * dump diffractive chains into DTEVT1 |
| 13952 | CALL DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1) |
| 13953 | IF (IREJ1.NE.0) GOTO 9999 |
| 13954 | |
| 13955 | RETURN |
| 13956 | |
| 13957 | 9999 CONTINUE |
| 13958 | IRDIFF(1) = IRDIFF(1)+1 |
| 13959 | IREJ = 1 |
| 13960 | RETURN |
| 13961 | END |
| 13962 | * |
| 13963 | *===xmhmd==============================================================* |
| 13964 | * |
| 13965 | CDECK ID>, DT_XMHMD |
| 13966 | DOUBLE PRECISION FUNCTION DT_XMHMD(ECM,IB,MODE) |
| 13967 | |
| 13968 | ************************************************************************ |
| 13969 | * Diffractive mass in high mass single/double diffractive events. * |
| 13970 | * This version dated 11.02.95 is written by S. Roesler * |
| 13971 | ************************************************************************ |
| 13972 | |
| 13973 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 13974 | SAVE |
| 13975 | |
| 13976 | PARAMETER ( LINP = 5 , |
| 13977 | & LOUT = 6 , |
| 13978 | & LDAT = 9 ) |
| 13979 | |
| 13980 | PARAMETER (OHALF=0.5D0,ONE=1.0D0,ZERO=0.0D0) |
| 13981 | |
| 13982 | * kinematics of diffractive interactions (DTUNUC 1.x) |
| 13983 | COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4), |
| 13984 | & PPF(4),PTF(4), |
| 13985 | & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4), |
| 13986 | & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2) |
| 13987 | |
| 13988 | C DATA XCOLOW /0.05D0/ |
| 13989 | DATA XCOLOW /0.15D0/ |
| 13990 | |
| 13991 | DT_XMHMD = ZERO |
| 13992 | XH = XPH(2) |
| 13993 | IF (MODE.EQ.2) XH = XTH(2) |
| 13994 | |
| 13995 | * minimum Pomeron-x for high-mass diffraction |
| 13996 | * (adjusted to get a smooth transition between HM and LM component) |
| 13997 | R = DT_RNDM(XH) |
| 13998 | XDIMIN = (3.0D0+400.0D0*R**2)/(XH*ECM**2) |
| 13999 | IF (ECM.LE.300.0D0) THEN |
| 14000 | RR = (1.0D0-EXP(-((ECM/140.0D0)**4))) |
| 14001 | XDIMIN = (3.0D0+400.0D0*(R**2)*RR)/(XH*ECM**2) |
| 14002 | ENDIF |
| 14003 | * maximum Pomeron-x for high-mass diffraction |
| 14004 | * (coherence condition, adjusted to fit to experimental data) |
| 14005 | IF (IB.NE.0) THEN |
| 14006 | * baryon-diffraction |
| 14007 | XDIMAX = XCOLOW*(1.0D0+EXP(-((ECM/420.0D0)**2))) |
| 14008 | ELSE |
| 14009 | * meson-diffraction |
| 14010 | XDIMAX = XCOLOW*(1.0D0+4.0D0*EXP(-((ECM/420.0D0)**2))) |
| 14011 | ENDIF |
| 14012 | * check boundaries |
| 14013 | IF (XDIMIN.GE.XDIMAX) THEN |
| 14014 | XDIMIN = OHALF*XDIMAX |
| 14015 | ENDIF |
| 14016 | |
| 14017 | KLOOP = 0 |
| 14018 | 1 CONTINUE |
| 14019 | KLOOP = KLOOP+1 |
| 14020 | IF (KLOOP.GT.20) RETURN |
| 14021 | * sample Pomeron-x from 1/x-distribution (critical Pomeron) |
| 14022 | XDIFF = DT_SAMPEX(XDIMIN,XDIMAX) |
| 14023 | * corr. diffr. mass |
| 14024 | DT_XMHMD = ECM*SQRT(XDIFF) |
| 14025 | IF (DT_XMHMD.LT.2.5D0) GOTO 1 |
| 14026 | |
| 14027 | RETURN |
| 14028 | END |
| 14029 | * |
| 14030 | *===xmlmd==============================================================* |
| 14031 | * |
| 14032 | CDECK ID>, DT_XMLMD |
| 14033 | DOUBLE PRECISION FUNCTION DT_XMLMD(ECM) |
| 14034 | |
| 14035 | ************************************************************************ |
| 14036 | * Diffractive mass in high mass single/double diffractive events. * |
| 14037 | * This version dated 11.02.95 is written by S. Roesler * |
| 14038 | ************************************************************************ |
| 14039 | |
| 14040 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 14041 | SAVE |
| 14042 | |
| 14043 | PARAMETER ( LINP = 5 , |
| 14044 | & LOUT = 6 , |
| 14045 | & LDAT = 9 ) |
| 14046 | |
| 14047 | * minimum Pomeron-x for low-mass diffraction |
| 14048 | C AMO = 1.5D0 |
| 14049 | AMO = 2.0D0 |
| 14050 | * maximum Pomeron-x for low-mass diffraction |
| 14051 | * (adjusted to get a smooth transition between HM and LM component) |
| 14052 | R = DT_RNDM(AMO) |
| 14053 | SAM = 1.0D0 |
| 14054 | IF (ECM.LE.300.0D0) SAM = 1.0D0-EXP(-((ECM/200.0D0)**4)) |
| 14055 | R = DT_RNDM(AMO)*SAM |
| 14056 | AMAX= (1.0D0-SAM)*SQRT(0.1D0*ECM**2)+SAM*SQRT(400.0D0) |
| 14057 | AMU = R*SQRT(100.0D0)+(1.0D0-R)*AMAX |
| 14058 | |
| 14059 | * selection of diffractive mass |
| 14060 | * (adjusted to get a smooth transition between HM and LM component) |
| 14061 | R = DT_RNDM(AMU) |
| 14062 | IF (ECM.LE.50.0D0) THEN |
| 14063 | DT_XMLMD = AMO*(AMU/AMO)**R |
| 14064 | ELSE |
| 14065 | A = 0.7D0 |
| 14066 | IF (ECM.LE.300.0D0) A = 0.7D0*(1.0D0-EXP(-((ECM/100.0D0)**2))) |
| 14067 | DT_XMLMD = 1.0D0/((R/(AMU**A)+(1.0D0-R)/(AMO**A))**(1.0D0/A)) |
| 14068 | ENDIF |
| 14069 | |
| 14070 | RETURN |
| 14071 | END |
| 14072 | * |
| 14073 | *===tdiff==============================================================* |
| 14074 | * |
| 14075 | CDECK ID>, DT_TDIFF |
| 14076 | DOUBLE PRECISION FUNCTION DT_TDIFF(ECM,TMIN,XM1I,K1,XM2I,K2,IREJ) |
| 14077 | |
| 14078 | ************************************************************************ |
| 14079 | * t-selection for single/double diffractive interactions. * |
| 14080 | * ECM cm. energy * |
| 14081 | * TMIN minimum momentum transfer to produce diff. masses * |
| 14082 | * XM1/XM2 diffractively produced masses * |
| 14083 | * (for single diffraction XM2 is obsolete) * |
| 14084 | * K1/K2= 0 not excited * |
| 14085 | * = 1 low-mass excitation * |
| 14086 | * = 2 high-mass excitation * |
| 14087 | * This version dated 11.02.95 is written by S. Roesler * |
| 14088 | ************************************************************************ |
| 14089 | |
| 14090 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 14091 | SAVE |
| 14092 | |
| 14093 | PARAMETER ( LINP = 5 , |
| 14094 | & LOUT = 6 , |
| 14095 | & LDAT = 9 ) |
| 14096 | |
| 14097 | PARAMETER (ZERO=0.0D0) |
| 14098 | |
| 14099 | PARAMETER ( BTP0 = 3.7D0, |
| 14100 | & ALPHAP = 0.24D0 ) |
| 14101 | |
| 14102 | IREJ = 0 |
| 14103 | NCLOOP = 0 |
| 14104 | DT_TDIFF = ZERO |
| 14105 | |
| 14106 | IF (K1.GT.0) THEN |
| 14107 | XM1 = XM1I |
| 14108 | XM2 = XM2I |
| 14109 | ELSE |
| 14110 | XM1 = XM2I |
| 14111 | ENDIF |
| 14112 | XDI = (XM1/ECM)**2 |
| 14113 | IF ((K1.EQ.0).OR.(K2.EQ.0)) THEN |
| 14114 | * slope for single diffraction |
| 14115 | SLOPE = BTP0-2.0D0*ALPHAP*LOG(XDI) |
| 14116 | ELSE |
| 14117 | * slope for double diffraction |
| 14118 | SLOPE = -2.0D0*ALPHAP*LOG(XDI*XM2**2) |
| 14119 | ENDIF |
| 14120 | |
| 14121 | 1 CONTINUE |
| 14122 | NCLOOP = NCLOOP+1 |
| 14123 | IF (MOD(NCLOOP,1000).EQ.0) GOTO 9999 |
| 14124 | Y = DT_RNDM(XDI) |
| 14125 | T = -LOG(1.0D0-Y)/SLOPE |
| 14126 | IF (ABS(T).LE.ABS(TMIN)) GOTO 1 |
| 14127 | DT_TDIFF = -ABS(T) |
| 14128 | |
| 14129 | RETURN |
| 14130 | |
| 14131 | 9999 CONTINUE |
| 14132 | WRITE(LOUT,1000) ECM,TMIN,XM1I,XM2I,K1,K2 |
| 14133 | 1000 FORMAT(1X,'DT_TDIFF: t-selection rejected!',/, |
| 14134 | & 1X,'ECM = ',E12.3,' TMIN = ',E12.2,/,1X,'XM1I = ', |
| 14135 | & E12.3,' XM2I = ',E12.3,' K1 = ',I2,' K2 = ',I2) |
| 14136 | IREJ = 1 |
| 14137 | RETURN |
| 14138 | END |
| 14139 | * |
| 14140 | *===xvalhm=============================================================* |
| 14141 | * |
| 14142 | CDECK ID>, DT_XVALHM |
| 14143 | SUBROUTINE DT_XVALHM(KP,KT) |
| 14144 | |
| 14145 | ************************************************************************ |
| 14146 | * Sampling of parton x-values in high-mass diffractive interactions. * |
| 14147 | * This version dated 12.02.95 is written by S. Roesler * |
| 14148 | ************************************************************************ |
| 14149 | |
| 14150 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 14151 | SAVE |
| 14152 | |
| 14153 | PARAMETER ( LINP = 5 , |
| 14154 | & LOUT = 6 , |
| 14155 | & LDAT = 9 ) |
| 14156 | |
| 14157 | PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0,TINY2=1.0D-2) |
| 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 | * various options for treatment of partons (DTUNUC 1.x) |
| 14165 | * (chain recombination, Cronin,..) |
| 14166 | LOGICAL LCO2CR,LINTPT |
| 14167 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, |
| 14168 | & LCO2CR,LINTPT |
| 14169 | |
| 14170 | DATA UNON,XVQTHR /2.0D0,0.8D0/ |
| 14171 | |
| 14172 | IF (KP.EQ.2) THEN |
| 14173 | * x-fractions of projectile valence partons |
| 14174 | 1 CONTINUE |
| 14175 | XPH(1) = DT_DBETAR(OHALF,UNON) |
| 14176 | IF (XPH(1).GE.XVQTHR) GOTO 1 |
| 14177 | XPH(2) = ONE-XPH(1) |
| 14178 | * x-fractions of Pomeron q-aq-pair |
| 14179 | XPOLO = TINY2 |
| 14180 | XPOHI = ONE-TINY2 |
| 14181 | XPPO(1) = DT_SAMPEX(XPOLO,XPOHI) |
| 14182 | XPPO(2) = ONE-XPPO(1) |
| 14183 | * flavors of Pomeron q-aq-pair |
| 14184 | IFLAV = INT(ONE+DT_RNDM(UNON)*(2.0D0+SEASQ)) |
| 14185 | IFPPO(1) = IFLAV |
| 14186 | IFPPO(2) = -IFLAV |
| 14187 | IF (DT_RNDM(UNON).GT.OHALF) THEN |
| 14188 | IFPPO(1) = -IFLAV |
| 14189 | IFPPO(2) = IFLAV |
| 14190 | ENDIF |
| 14191 | ENDIF |
| 14192 | |
| 14193 | IF (KT.EQ.2) THEN |
| 14194 | * x-fractions of projectile target partons |
| 14195 | 2 CONTINUE |
| 14196 | XTH(1) = DT_DBETAR(OHALF,UNON) |
| 14197 | IF (XTH(1).GE.XVQTHR) GOTO 2 |
| 14198 | XTH(2) = ONE-XTH(1) |
| 14199 | * x-fractions of Pomeron q-aq-pair |
| 14200 | XPOLO = TINY2 |
| 14201 | XPOHI = ONE-TINY2 |
| 14202 | XTPO(1) = DT_SAMPEX(XPOLO,XPOHI) |
| 14203 | XTPO(2) = ONE-XTPO(1) |
| 14204 | * flavors of Pomeron q-aq-pair |
| 14205 | IFLAV = INT(ONE+DT_RNDM(XPOLO)*(2.0D0+SEASQ)) |
| 14206 | IFTPO(1) = IFLAV |
| 14207 | IFTPO(2) = -IFLAV |
| 14208 | IF (DT_RNDM(XPOLO).GT.OHALF) THEN |
| 14209 | IFTPO(1) = -IFLAV |
| 14210 | IFTPO(2) = IFLAV |
| 14211 | ENDIF |
| 14212 | ENDIF |
| 14213 | |
| 14214 | RETURN |
| 14215 | END |
| 14216 | * |
| 14217 | *===lm2res=============================================================* |
| 14218 | * |
| 14219 | CDECK ID>, DT_LM2RES |
| 14220 | SUBROUTINE DT_LM2RES(IF1,IF2,XM,IDR,IDXR,IREJ) |
| 14221 | |
| 14222 | ************************************************************************ |
| 14223 | * Check low-mass diffractive excitation for resonance mass. * |
| 14224 | * (input) IF1/2 PDG-indizes of valence partons * |
| 14225 | * (in/out) XM diffractive mass requested/corrected * |
| 14226 | * (output) IDR/IDXR id./BAMJET-index of resonance * |
| 14227 | * This version dated 12.02.95 is written by S. Roesler * |
| 14228 | ************************************************************************ |
| 14229 | |
| 14230 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 14231 | SAVE |
| 14232 | |
| 14233 | PARAMETER ( LINP = 5 , |
| 14234 | & LOUT = 6 , |
| 14235 | & LDAT = 9 ) |
| 14236 | |
| 14237 | PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0) |
| 14238 | |
| 14239 | * kinematics of diffractive interactions (DTUNUC 1.x) |
| 14240 | COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4), |
| 14241 | & PPF(4),PTF(4), |
| 14242 | & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4), |
| 14243 | & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2) |
| 14244 | |
| 14245 | IREJ = 0 |
| 14246 | IF1B = 0 |
| 14247 | IF2B = 0 |
| 14248 | XMI = XM |
| 14249 | |
| 14250 | * BAMJET indices of partons |
| 14251 | IF1A = IDT_IPDG2B(IF1,1,2) |
| 14252 | IF (ABS(IF1).GE.1000) IF1B = IDT_IPDG2B(IF1,2,2) |
| 14253 | IF2A = IDT_IPDG2B(IF2,1,2) |
| 14254 | IF (ABS(IF2).GE.1000) IF2B = IDT_IPDG2B(IF2,2,2) |
| 14255 | |
| 14256 | * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq) |
| 14257 | IDCH = 2 |
| 14258 | IF ((IF1B.EQ.0).AND.(IF2B.EQ.0)) IDCH = 1 |
| 14259 | |
| 14260 | * check for resonance mass |
| 14261 | CALL DT_CH2RES(IF1A,IF1B,IF2A,IF2B,IDR,IDXR,XMI,XMN,IDCH,IREJ1) |
| 14262 | IF (IREJ1.NE.0) GOTO 9999 |
| 14263 | |
| 14264 | XM = XMN |
| 14265 | RETURN |
| 14266 | |
| 14267 | 9999 CONTINUE |
| 14268 | IREJ = 1 |
| 14269 | RETURN |
| 14270 | END |
| 14271 | * |
| 14272 | *===lmkine=============================================================* |
| 14273 | * |
| 14274 | CDECK ID>, DT_LMKINE |
| 14275 | SUBROUTINE DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ) |
| 14276 | |
| 14277 | ************************************************************************ |
| 14278 | * Kinematical treatment of low-mass excitations. * |
| 14279 | * This version dated 12.02.95 is written by S. Roesler * |
| 14280 | ************************************************************************ |
| 14281 | |
| 14282 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 14283 | SAVE |
| 14284 | |
| 14285 | PARAMETER ( LINP = 5 , |
| 14286 | & LOUT = 6 , |
| 14287 | & LDAT = 9 ) |
| 14288 | |
| 14289 | PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0) |
| 14290 | |
| 14291 | * flags for input different options |
| 14292 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 14293 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 14294 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 14295 | * kinematics of diffractive interactions (DTUNUC 1.x) |
| 14296 | COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4), |
| 14297 | & PPF(4),PTF(4), |
| 14298 | & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4), |
| 14299 | & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2) |
| 14300 | |
| 14301 | DIMENSION P1(4),P2(4) |
| 14302 | |
| 14303 | IREJ = 0 |
| 14304 | |
| 14305 | IF (KP.EQ.1) THEN |
| 14306 | PABS = SQRT(PPF(1)**2+PPF(2)**2+PPF(3)**2) |
| 14307 | POE = PPF(4)/PABS |
| 14308 | FAC1 = OHALF*(POE+ONE) |
| 14309 | FAC2 = -OHALF*(POE-ONE) |
| 14310 | DO 1 K=1,3 |
| 14311 | PPLM1(K) = FAC1*PPF(K) |
| 14312 | PPLM2(K) = FAC2*PPF(K) |
| 14313 | 1 CONTINUE |
| 14314 | PPLM1(4) = FAC1*PABS |
| 14315 | PPLM2(4) = -FAC2*PABS |
| 14316 | IF (IMSHL.EQ.1) THEN |
| 14317 | |
| 14318 | XM1 = PYMASS(IFP1) |
| 14319 | XM2 = PYMASS(IFP2) |
| 14320 | |
| 14321 | CALL DT_MASHEL(PPLM1,PPLM2,XM1,XM2,P1,P2,IREJ1) |
| 14322 | IF (IREJ1.NE.0) GOTO 9999 |
| 14323 | DO 2 K=1,4 |
| 14324 | PPLM1(K) = P1(K) |
| 14325 | PPLM2(K) = P2(K) |
| 14326 | 2 CONTINUE |
| 14327 | ENDIF |
| 14328 | ENDIF |
| 14329 | |
| 14330 | IF (KT.EQ.1) THEN |
| 14331 | PABS = SQRT(PTF(1)**2+PTF(2)**2+PTF(3)**2) |
| 14332 | POE = PTF(4)/PABS |
| 14333 | FAC1 = OHALF*(POE+ONE) |
| 14334 | FAC2 = -OHALF*(POE-ONE) |
| 14335 | DO 3 K=1,3 |
| 14336 | PTLM2(K) = FAC1*PTF(K) |
| 14337 | PTLM1(K) = FAC2*PTF(K) |
| 14338 | 3 CONTINUE |
| 14339 | PTLM2(4) = FAC1*PABS |
| 14340 | PTLM1(4) = -FAC2*PABS |
| 14341 | IF (IMSHL.EQ.1) THEN |
| 14342 | |
| 14343 | XM1 = PYMASS(IFT1) |
| 14344 | XM2 = PYMASS(IFT2) |
| 14345 | |
| 14346 | CALL DT_MASHEL(PTLM1,PTLM2,XM1,XM2,P1,P2,IREJ1) |
| 14347 | IF (IREJ1.NE.0) GOTO 9999 |
| 14348 | DO 4 K=1,4 |
| 14349 | PTLM1(K) = P1(K) |
| 14350 | PTLM2(K) = P2(K) |
| 14351 | 4 CONTINUE |
| 14352 | ENDIF |
| 14353 | ENDIF |
| 14354 | |
| 14355 | RETURN |
| 14356 | |
| 14357 | 9999 CONTINUE |
| 14358 | WRITE(LOUT,'(A)') 'LMKINE: kinematical treatment rejected' |
| 14359 | IREJ = 1 |
| 14360 | RETURN |
| 14361 | END |
| 14362 | * |
| 14363 | *===difini=============================================================* |
| 14364 | * |
| 14365 | CDECK ID>, DT_DIFINI |
| 14366 | SUBROUTINE DT_DIFINI |
| 14367 | |
| 14368 | ************************************************************************ |
| 14369 | * Initialization of common /DTDIKI/ * |
| 14370 | * This version dated 12.02.95 is written by S. Roesler * |
| 14371 | ************************************************************************ |
| 14372 | |
| 14373 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 14374 | SAVE |
| 14375 | |
| 14376 | PARAMETER ( LINP = 5 , |
| 14377 | & LOUT = 6 , |
| 14378 | & LDAT = 9 ) |
| 14379 | |
| 14380 | PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0) |
| 14381 | |
| 14382 | * kinematics of diffractive interactions (DTUNUC 1.x) |
| 14383 | COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4), |
| 14384 | & PPF(4),PTF(4), |
| 14385 | & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4), |
| 14386 | & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2) |
| 14387 | |
| 14388 | DO 1 K=1,4 |
| 14389 | PPOM(K) = ZERO |
| 14390 | PSC(K) = ZERO |
| 14391 | PPF(K) = ZERO |
| 14392 | PTF(K) = ZERO |
| 14393 | PPLM1(K) = ZERO |
| 14394 | PPLM2(K) = ZERO |
| 14395 | PTLM1(K) = ZERO |
| 14396 | PTLM2(K) = ZERO |
| 14397 | 1 CONTINUE |
| 14398 | DO 2 K=1,2 |
| 14399 | XPH(K) = ZERO |
| 14400 | XPPO(K) = ZERO |
| 14401 | XTH(K) = ZERO |
| 14402 | XTPO(K) = ZERO |
| 14403 | IFPPO(K) = 0 |
| 14404 | IFTPO(K) = 0 |
| 14405 | 2 CONTINUE |
| 14406 | IDPR = 0 |
| 14407 | IDXPR = 0 |
| 14408 | IDTR = 0 |
| 14409 | IDXTR = 0 |
| 14410 | |
| 14411 | RETURN |
| 14412 | END |
| 14413 | * |
| 14414 | *===difput=============================================================* |
| 14415 | * |
| 14416 | CDECK ID>, DT_DIFPUT |
| 14417 | SUBROUTINE DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY, |
| 14418 | & IREJ) |
| 14419 | |
| 14420 | ************************************************************************ |
| 14421 | * Dump diffractive chains into DTEVT1 * |
| 14422 | * This version dated 12.02.95 is written by S. Roesler * |
| 14423 | ************************************************************************ |
| 14424 | |
| 14425 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 14426 | SAVE |
| 14427 | |
| 14428 | PARAMETER ( LINP = 5 , |
| 14429 | & LOUT = 6 , |
| 14430 | & LDAT = 9 ) |
| 14431 | |
| 14432 | PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0) |
| 14433 | |
| 14434 | LOGICAL LCHK |
| 14435 | |
| 14436 | * kinematics of diffractive interactions (DTUNUC 1.x) |
| 14437 | COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4), |
| 14438 | & PPF(4),PTF(4), |
| 14439 | & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4), |
| 14440 | & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2) |
| 14441 | * event history |
| 14442 | |
| 14443 | PARAMETER (NMXHKK=200000) |
| 14444 | |
| 14445 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 14446 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 14447 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 14448 | * extended event history |
| 14449 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 14450 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 14451 | & IHIST(2,NMXHKK) |
| 14452 | * rejection counter |
| 14453 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, |
| 14454 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, |
| 14455 | & IREXCI(3),IRDIFF(2),IRINC |
| 14456 | |
| 14457 | DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PCH(4),PP(4),PT(4), |
| 14458 | & P1(4),P2(4),P3(4),P4(4) |
| 14459 | |
| 14460 | IREJ = 0 |
| 14461 | |
| 14462 | IF (KP.EQ.1) THEN |
| 14463 | DO 1 K=1,4 |
| 14464 | PCH(K) = PPLM1(K)+PPLM2(K) |
| 14465 | 1 CONTINUE |
| 14466 | ID1 = IFP1 |
| 14467 | ID2 = IFP2 |
| 14468 | IF (DT_RNDM(PT).GT.OHALF) THEN |
| 14469 | ID1 = IFP2 |
| 14470 | ID2 = IFP1 |
| 14471 | ENDIF |
| 14472 | CALL DT_EVTPUT(21,ID1,MOP,0,PPLM1(1),PPLM1(2),PPLM1(3), |
| 14473 | & PPLM1(4),0,0,0) |
| 14474 | CALL DT_EVTPUT(21,ID2,MOP,0,PPLM2(1),PPLM2(2),PPLM2(3), |
| 14475 | & PPLM2(4),0,0,0) |
| 14476 | CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4), |
| 14477 | & IDPR,IDXPR,8) |
| 14478 | ELSEIF (KP.EQ.2) THEN |
| 14479 | DO 2 K=1,4 |
| 14480 | PP1(K) = XPH(1)*PP(K) |
| 14481 | PP2(K) = XPH(2)*PP(K) |
| 14482 | PT1(K) = -XPPO(1)*PPOM(K) |
| 14483 | PT2(K) = -XPPO(2)*PPOM(K) |
| 14484 | 2 CONTINUE |
| 14485 | CALL DT_CHKCSY(IFP1,IFPPO(1),LCHK) |
| 14486 | XM1 = ZERO |
| 14487 | XM2 = ZERO |
| 14488 | IF (LCHK) THEN |
| 14489 | CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1) |
| 14490 | IF (IREJ1.NE.0) GOTO 9999 |
| 14491 | CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1) |
| 14492 | IF (IREJ1.NE.0) GOTO 9999 |
| 14493 | DO 3 K=1,4 |
| 14494 | PP1(K) = P1(K) |
| 14495 | PT1(K) = P2(K) |
| 14496 | PP2(K) = P3(K) |
| 14497 | PT2(K) = P4(K) |
| 14498 | 3 CONTINUE |
| 14499 | CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), |
| 14500 | & 0,0,8) |
| 14501 | CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3), |
| 14502 | & PT1(4),0,0,8) |
| 14503 | CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), |
| 14504 | & 0,0,8) |
| 14505 | CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3), |
| 14506 | & PT2(4),0,0,8) |
| 14507 | ELSE |
| 14508 | CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1) |
| 14509 | IF (IREJ1.NE.0) GOTO 9999 |
| 14510 | CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1) |
| 14511 | IF (IREJ1.NE.0) GOTO 9999 |
| 14512 | DO 4 K=1,4 |
| 14513 | PP1(K) = P1(K) |
| 14514 | PT2(K) = P2(K) |
| 14515 | PP2(K) = P3(K) |
| 14516 | PT1(K) = P4(K) |
| 14517 | 4 CONTINUE |
| 14518 | CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), |
| 14519 | & 0,0,8) |
| 14520 | CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3), |
| 14521 | & PT2(4),0,0,8) |
| 14522 | CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), |
| 14523 | & 0,0,8) |
| 14524 | CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3), |
| 14525 | & PT1(4),0,0,8) |
| 14526 | ENDIF |
| 14527 | NCSY = NCSY+1 |
| 14528 | ELSE |
| 14529 | CALL DT_EVTPUT(1,IDHKK(MOP),MOP,0,PSC(1),PSC(2),PSC(3),PSC(4), |
| 14530 | & 0,0,0) |
| 14531 | ENDIF |
| 14532 | |
| 14533 | IF (KT.EQ.1) THEN |
| 14534 | DO 5 K=1,4 |
| 14535 | PCH(K) = PTLM1(K)+PTLM2(K) |
| 14536 | 5 CONTINUE |
| 14537 | ID1 = IFT1 |
| 14538 | ID2 = IFT2 |
| 14539 | IF (DT_RNDM(PT).GT.OHALF) THEN |
| 14540 | ID1 = IFT2 |
| 14541 | ID2 = IFT1 |
| 14542 | ENDIF |
| 14543 | CALL DT_EVTPUT(22,ID1,MOT,0,PTLM1(1),PTLM1(2),PTLM1(3), |
| 14544 | & PTLM1(4),0,0,0) |
| 14545 | CALL DT_EVTPUT(22,ID2,MOT,0,PTLM2(1),PTLM2(2),PTLM2(3), |
| 14546 | & PTLM2(4),0,0,0) |
| 14547 | CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4), |
| 14548 | & IDTR,IDXTR,8) |
| 14549 | ELSEIF (KT.EQ.2) THEN |
| 14550 | DO 6 K=1,4 |
| 14551 | PP1(K) = XTPO(1)*PPOM(K) |
| 14552 | PP2(K) = XTPO(2)*PPOM(K) |
| 14553 | PT1(K) = XTH(2)*PT(K) |
| 14554 | PT2(K) = XTH(1)*PT(K) |
| 14555 | 6 CONTINUE |
| 14556 | CALL DT_CHKCSY(IFTPO(1),IFT1,LCHK) |
| 14557 | XM1 = ZERO |
| 14558 | XM2 = ZERO |
| 14559 | IF (LCHK) THEN |
| 14560 | CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1) |
| 14561 | IF (IREJ1.NE.0) GOTO 9999 |
| 14562 | CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1) |
| 14563 | IF (IREJ1.NE.0) GOTO 9999 |
| 14564 | DO 7 K=1,4 |
| 14565 | PP1(K) = P1(K) |
| 14566 | PT1(K) = P2(K) |
| 14567 | PP2(K) = P3(K) |
| 14568 | PT2(K) = P4(K) |
| 14569 | 7 CONTINUE |
| 14570 | CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3), |
| 14571 | & PP1(4),0,0,8) |
| 14572 | CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), |
| 14573 | & 0,0,8) |
| 14574 | CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3), |
| 14575 | & PP2(4),0,0,8) |
| 14576 | CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), |
| 14577 | & 0,0,8) |
| 14578 | ELSE |
| 14579 | CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1) |
| 14580 | IF (IREJ1.NE.0) GOTO 9999 |
| 14581 | CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1) |
| 14582 | IF (IREJ1.NE.0) GOTO 9999 |
| 14583 | DO 8 K=1,4 |
| 14584 | PP1(K) = P1(K) |
| 14585 | PT2(K) = P2(K) |
| 14586 | PP2(K) = P3(K) |
| 14587 | PT1(K) = P4(K) |
| 14588 | 8 CONTINUE |
| 14589 | CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3), |
| 14590 | & PP1(4),0,0,8) |
| 14591 | CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), |
| 14592 | & 0,0,8) |
| 14593 | CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3), |
| 14594 | & PP2(4),0,0,8) |
| 14595 | CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), |
| 14596 | & 0,0,8) |
| 14597 | ENDIF |
| 14598 | NCSY = NCSY+1 |
| 14599 | ELSE |
| 14600 | CALL DT_EVTPUT(1,IDHKK(MOT),MOT,0,PSC(1),PSC(2),PSC(3),PSC(4), |
| 14601 | & 0,0,0) |
| 14602 | ENDIF |
| 14603 | |
| 14604 | RETURN |
| 14605 | |
| 14606 | 9999 CONTINUE |
| 14607 | IRDIFF(2) = IRDIFF(2)+1 |
| 14608 | IREJ = 1 |
| 14609 | RETURN |
| 14610 | END |
| 14611 | * |
| 14612 | *===evtfrg=============================================================* |
| 14613 | * |
| 14614 | CDECK ID>, DT_EVTFRG |
| 14615 | SUBROUTINE DT_EVTFRG(KMODE,NFRG,NPYMEM,IREJ) |
| 14616 | |
| 14617 | ************************************************************************ |
| 14618 | * Hadronization of chains in DTEVT1. * |
| 14619 | * * |
| 14620 | * Input: * |
| 14621 | * KMODE = 1 hadronization of PHOJET-chains (id=77xxx) * |
| 14622 | * = 2 hadronization of DTUNUC-chains (id=88xxx) * |
| 14623 | * NFRG if KMODE = 1 : upper index of PHOJET-scatterings to be * |
| 14624 | * hadronized with one PYEXEC call * |
| 14625 | * if KMODE = 2 : max. number of DTUNUC-chains to be hadronized * |
| 14626 | * with one PYEXEC call * |
| 14627 | * Output: * |
| 14628 | * NPYMEM number of entries in JETSET-common after hadronization * |
| 14629 | * IREJ rejection flag * |
| 14630 | * * |
| 14631 | * This version dated 17.09.00 is written by S. Roesler * |
| 14632 | ************************************************************************ |
| 14633 | |
| 14634 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 14635 | SAVE |
| 14636 | |
| 14637 | PARAMETER ( LINP = 5 , |
| 14638 | & LOUT = 6 , |
| 14639 | & LDAT = 9 ) |
| 14640 | |
| 14641 | PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1) |
| 14642 | PARAMETER (ONE=1.0D0,ZERO=0.0D0) |
| 14643 | |
| 14644 | LOGICAL LACCEP |
| 14645 | |
| 14646 | PARAMETER (MXJOIN=200) |
| 14647 | |
| 14648 | * event history |
| 14649 | |
| 14650 | PARAMETER (NMXHKK=200000) |
| 14651 | |
| 14652 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 14653 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 14654 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 14655 | * extended event history |
| 14656 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 14657 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 14658 | & IHIST(2,NMXHKK) |
| 14659 | * flags for input different options |
| 14660 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 14661 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 14662 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 14663 | * statistics |
| 14664 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, |
| 14665 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), |
| 14666 | & ICEVTG(8,0:30) |
| 14667 | * flags for diffractive interactions (DTUNUC 1.x) |
| 14668 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF |
| 14669 | * nucleon-nucleon event-generator |
| 14670 | CHARACTER*8 CMODEL |
| 14671 | LOGICAL LPHOIN |
| 14672 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN |
| 14673 | * phojet |
| 14674 | C model switches and parameters |
| 14675 | CHARACTER*8 MDLNA |
| 14676 | INTEGER ISWMDL,IPAMDL |
| 14677 | DOUBLE PRECISION PARMDL |
| 14678 | COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400) |
| 14679 | * jetset |
| 14680 | |
| 14681 | COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) |
| 14682 | |
| 14683 | PARAMETER (MAXLND=4000) |
| 14684 | COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5) |
| 14685 | |
| 14686 | INTEGER PYK |
| 14687 | |
| 14688 | DIMENSION IJOIN(MXJOIN),ISJOIN(MXJOIN),IHISMO(8000),IFLG(4000) |
| 14689 | |
| 14690 | MODE = KMODE |
| 14691 | ISTSTG = 7 |
| 14692 | IF (MODE.NE.1) ISTSTG = 8 |
| 14693 | IREJ = 0 |
| 14694 | |
| 14695 | IP = 0 |
| 14696 | ISH = 0 |
| 14697 | INIEMC = 1 |
| 14698 | NEND = NHKK |
| 14699 | NACCEP = 0 |
| 14700 | IFRG = 0 |
| 14701 | IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1 |
| 14702 | DO 10 I=NPOINT(3),NEND |
| 14703 | * sr 14.02.00: seems to be not necessary anymore, commented |
| 14704 | C LACCEP = ((NOBAM(I).EQ.0).AND.(MODE.EQ.1)).OR. |
| 14705 | C & ((NOBAM(I).NE.0).AND.(MODE.EQ.2)) |
| 14706 | LACCEP = .TRUE. |
| 14707 | * pick up chains from dtevt1 |
| 14708 | IDCHK = IDHKK(I)/10000 |
| 14709 | IF ((IDCHK.EQ.ISTSTG).AND.LACCEP) THEN |
| 14710 | IF (IDCHK.EQ.7) THEN |
| 14711 | IPJE = IDHKK(I)-IDCHK*10000 |
| 14712 | IF (IPJE.NE.IFRG) THEN |
| 14713 | IFRG = IPJE |
| 14714 | IF (IFRG.GT.NFRG) GOTO 16 |
| 14715 | ENDIF |
| 14716 | ELSE |
| 14717 | IPJE = 1 |
| 14718 | IFRG = IFRG+1 |
| 14719 | IF (IFRG.GT.NFRG) THEN |
| 14720 | NFRG = -1 |
| 14721 | GOTO 16 |
| 14722 | ENDIF |
| 14723 | ENDIF |
| 14724 | * statistics counter |
| 14725 | c IF (IDCH(I).LE.8) |
| 14726 | c & ICCHAI(2,IDCH(I)) = ICCHAI(2,IDCH(I))+1 |
| 14727 | c IF (IDRES(I).NE.0) ICRES(IDCH(I)) = ICRES(IDCH(I))+1 |
| 14728 | * special treatment for small chains already corrected to hadrons |
| 14729 | IF (IDRES(I).NE.0) THEN |
| 14730 | IF (IDRES(I).EQ.11) THEN |
| 14731 | ID = IDXRES(I) |
| 14732 | ELSE |
| 14733 | ID = IDT_IPDGHA(IDXRES(I)) |
| 14734 | ENDIF |
| 14735 | IF (LEMCCK) THEN |
| 14736 | CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I), |
| 14737 | & PHKK(4,I),INIEMC,IDUM,IDUM) |
| 14738 | INIEMC = 2 |
| 14739 | ENDIF |
| 14740 | IP = IP+1 |
| 14741 | IF (IP.GT.MSTU(4)) STOP ' NEWFRA 1: IP.GT.MSTU(4) !' |
| 14742 | P(IP,1) = PHKK(1,I) |
| 14743 | P(IP,2) = PHKK(2,I) |
| 14744 | P(IP,3) = PHKK(3,I) |
| 14745 | P(IP,4) = PHKK(4,I) |
| 14746 | P(IP,5) = PHKK(5,I) |
| 14747 | K(IP,1) = 1 |
| 14748 | K(IP,2) = ID |
| 14749 | K(IP,3) = 0 |
| 14750 | K(IP,4) = 0 |
| 14751 | K(IP,5) = 0 |
| 14752 | IHIST(2,I) = 10000*IPJE+IP |
| 14753 | IF (IHIST(1,I).LE.-100) THEN |
| 14754 | ISH = ISH+1 |
| 14755 | IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !' |
| 14756 | ISJOIN(ISH) = I |
| 14757 | ENDIF |
| 14758 | N = IP |
| 14759 | IHISMO(IP) = I |
| 14760 | ELSE |
| 14761 | IJ = 0 |
| 14762 | DO 11 KK=JMOHKK(1,I),JMOHKK(2,I) |
| 14763 | IF (LEMCCK) THEN |
| 14764 | CALL DT_EVTEMC(PHKK(1,KK),PHKK(2,KK),PHKK(3,KK), |
| 14765 | & PHKK(4,KK),INIEMC,IDUM,IDUM) |
| 14766 | CALL DT_EVTFLC(IDHKK(KK),1,INIEMC,IDUM,IDUM) |
| 14767 | INIEMC = 2 |
| 14768 | ENDIF |
| 14769 | ID = IDHKK(KK) |
| 14770 | IF (ID.EQ.0) ID = 21 |
| 14771 | c PTOT = SQRT(PHKK(1,KK)**2+PHKK(2,KK)**2+PHKK(3,KK)**2) |
| 14772 | c AM0 = SQRT(ABS((PHKK(4,KK)-PTOT)*(PHKK(4,KK)+PTOT))) |
| 14773 | |
| 14774 | c AMRQ = PYMASS(ID) |
| 14775 | |
| 14776 | c AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ) |
| 14777 | c IF ((ABS(AMDIF2).GT.TINY3).AND.(PTOT.GT.ZERO).AND. |
| 14778 | c & (ABS(IDIFF).EQ.0)) THEN |
| 14779 | cC WRITE(LOUT,*)'here: ',NEVHKK,AM0,AMRQ |
| 14780 | c DELTA = -AMDIF2/(2.0D0*(PHKK(4,KK)+PTOT)) |
| 14781 | c PHKK(4,KK) = PHKK(4,KK)+DELTA |
| 14782 | c PTOT1 = PTOT-DELTA |
| 14783 | c PHKK(1,KK) = PHKK(1,KK)*PTOT1/PTOT |
| 14784 | c PHKK(2,KK) = PHKK(2,KK)*PTOT1/PTOT |
| 14785 | c PHKK(3,KK) = PHKK(3,KK)*PTOT1/PTOT |
| 14786 | c PHKK(5,KK) = AMRQ |
| 14787 | c ENDIF |
| 14788 | IP = IP+1 |
| 14789 | IF (IP.GT.MSTU(4)) STOP ' NEWFRA 2: IP.GT.MSTU(4) !' |
| 14790 | P(IP,1) = PHKK(1,KK) |
| 14791 | P(IP,2) = PHKK(2,KK) |
| 14792 | P(IP,3) = PHKK(3,KK) |
| 14793 | P(IP,4) = PHKK(4,KK) |
| 14794 | P(IP,5) = PHKK(5,KK) |
| 14795 | K(IP,1) = 1 |
| 14796 | K(IP,2) = ID |
| 14797 | K(IP,3) = 0 |
| 14798 | K(IP,4) = 0 |
| 14799 | K(IP,5) = 0 |
| 14800 | IHIST(2,KK) = 10000*IPJE+IP |
| 14801 | IF (IHIST(1,KK).LE.-100) THEN |
| 14802 | ISH = ISH+1 |
| 14803 | IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !' |
| 14804 | ISJOIN(ISH) = KK |
| 14805 | ENDIF |
| 14806 | IJ = IJ+1 |
| 14807 | IF (IJ.GT.MXJOIN) STOP 'IJ > MXJOIN !' |
| 14808 | IJOIN(IJ) = IP |
| 14809 | IHISMO(IP) = I |
| 14810 | 11 CONTINUE |
| 14811 | N = IP |
| 14812 | * join the two-parton system |
| 14813 | |
| 14814 | CALL PYJOIN(IJ,IJOIN) |
| 14815 | |
| 14816 | ENDIF |
| 14817 | IDHKK(I) = 99999 |
| 14818 | ENDIF |
| 14819 | 10 CONTINUE |
| 14820 | 16 CONTINUE |
| 14821 | N = IP |
| 14822 | |
| 14823 | IF (IP.GT.0) THEN |
| 14824 | |
| 14825 | * final state parton shower |
| 14826 | DO 136 NPJE=1,IPJE |
| 14827 | IF ((MCGENE.EQ.2).AND.(ISH.GE.2)) THEN |
| 14828 | IF ((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN |
| 14829 | DO 130 K1=1,ISH |
| 14830 | IF (ISJOIN(K1).EQ.0) GOTO 130 |
| 14831 | I = ISJOIN(K1) |
| 14832 | IF ((IPAMDL(102).EQ.1).AND.(IHIST(1,I).NE.-100)) |
| 14833 | & GOTO 130 |
| 14834 | IH1 = IHIST(2,I)/10000 |
| 14835 | IF (IH1.NE.NPJE) GOTO 130 |
| 14836 | IH1 = IHIST(2,I)-IH1*10000 |
| 14837 | DO 135 K2=K1+1,ISH |
| 14838 | IF (ISJOIN(K2).EQ.0) GOTO 135 |
| 14839 | II = ISJOIN(K2) |
| 14840 | IH2 = IHIST(2,II)/10000 |
| 14841 | IF (IH2.NE.NPJE) GOTO 135 |
| 14842 | IH2 = IHIST(2,II)-IH2*10000 |
| 14843 | IF (IHIST(1,I).EQ.IHIST(1,II)) THEN |
| 14844 | PT1 = SQRT(PHKK(1,II)**2+PHKK(2,II)**2) |
| 14845 | PT2 = SQRT(PHKK(1, I)**2+PHKK(2, I)**2) |
| 14846 | |
| 14847 | RQLUN = MIN(PT1,PT2) |
| 14848 | CALL PYSHOW(IH1,IH2,RQLUN) |
| 14849 | |
| 14850 | ISJOIN(K1) = 0 |
| 14851 | ISJOIN(K2) = 0 |
| 14852 | GOTO 130 |
| 14853 | ENDIF |
| 14854 | 135 CONTINUE |
| 14855 | 130 CONTINUE |
| 14856 | ENDIF |
| 14857 | ENDIF |
| 14858 | 136 CONTINUE |
| 14859 | |
| 14860 | CALL DT_INITJS(MODE) |
| 14861 | * hadronization |
| 14862 | |
| 14863 | CALL PYEXEC |
| 14864 | |
| 14865 | IF (MSTU(24).NE.0) THEN |
| 14866 | WRITE(LOUT,*) ' JETSET-reject at event', |
| 14867 | & NEVHKK,MSTU(24),KMODE |
| 14868 | C CALL DT_EVTOUT(4) |
| 14869 | |
| 14870 | C CALL PYLIST(2) |
| 14871 | |
| 14872 | GOTO 9999 |
| 14873 | ENDIF |
| 14874 | |
| 14875 | * number of entries in LUJETS |
| 14876 | |
| 14877 | NLINES = PYK(0,1) |
| 14878 | |
| 14879 | NPYMEM = NLINES |
| 14880 | |
| 14881 | DO 12 I=1,NLINES |
| 14882 | IFLG(I) = 0 |
| 14883 | 12 CONTINUE |
| 14884 | |
| 14885 | DO 13 II=1,NLINES |
| 14886 | |
| 14887 | IF ((PYK(II,7).EQ.1).AND.(IFLG(II).NE.1)) THEN |
| 14888 | |
| 14889 | * pick up mother resonance if possible and put it together with |
| 14890 | * their decay-products into the common |
| 14891 | IDXMOR = K(II,3) |
| 14892 | IF ((IDXMOR.GE.1).AND.(IDXMOR.LE.MAXLND)) THEN |
| 14893 | KFMOR = K(IDXMOR,2) |
| 14894 | ISMOR = K(IDXMOR,1) |
| 14895 | ELSE |
| 14896 | KFMOR = 91 |
| 14897 | ISMOR = 1 |
| 14898 | ENDIF |
| 14899 | IF ((KFMOR.NE.91).AND.(KFMOR.NE.92).AND. |
| 14900 | & (KFMOR.NE.94).AND.(ISMOR.EQ.11)) THEN |
| 14901 | ID = K(IDXMOR,2) |
| 14902 | |
| 14903 | MO = IHISMO(PYK(IDXMOR,15)) |
| 14904 | PX = PYP(IDXMOR,1) |
| 14905 | PY = PYP(IDXMOR,2) |
| 14906 | PZ = PYP(IDXMOR,3) |
| 14907 | PE = PYP(IDXMOR,4) |
| 14908 | |
| 14909 | CALL DT_EVTPUT(2,ID,MO,0,PX,PY,PZ,PE,0,0,0) |
| 14910 | IFLG(IDXMOR) = 1 |
| 14911 | MO = NHKK |
| 14912 | DO 15 JDAUG=K(IDXMOR,4),K(IDXMOR,5) |
| 14913 | |
| 14914 | IF (PYK(JDAUG,7).EQ.1) THEN |
| 14915 | ID = PYK(JDAUG,8) |
| 14916 | PX = PYP(JDAUG,1) |
| 14917 | PY = PYP(JDAUG,2) |
| 14918 | PZ = PYP(JDAUG,3) |
| 14919 | PE = PYP(JDAUG,4) |
| 14920 | |
| 14921 | CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0) |
| 14922 | IF (LEMCCK) THEN |
| 14923 | |
| 14924 | PX = -PYP(JDAUG,1) |
| 14925 | PY = -PYP(JDAUG,2) |
| 14926 | PZ = -PYP(JDAUG,3) |
| 14927 | PE = -PYP(JDAUG,4) |
| 14928 | |
| 14929 | CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM) |
| 14930 | ENDIF |
| 14931 | IFLG(JDAUG) = 1 |
| 14932 | ENDIF |
| 14933 | 15 CONTINUE |
| 14934 | ELSE |
| 14935 | * there was no mother resonance |
| 14936 | |
| 14937 | MO = IHISMO(PYK(II,15)) |
| 14938 | ID = PYK(II,8) |
| 14939 | PX = PYP(II,1) |
| 14940 | PY = PYP(II,2) |
| 14941 | PZ = PYP(II,3) |
| 14942 | PE = PYP(II,4) |
| 14943 | |
| 14944 | CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0) |
| 14945 | IF (LEMCCK) THEN |
| 14946 | |
| 14947 | PX = -PYP(II,1) |
| 14948 | PY = -PYP(II,2) |
| 14949 | PZ = -PYP(II,3) |
| 14950 | PE = -PYP(II,4) |
| 14951 | |
| 14952 | CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM) |
| 14953 | ENDIF |
| 14954 | ENDIF |
| 14955 | ENDIF |
| 14956 | 13 CONTINUE |
| 14957 | IF (LEMCCK) THEN |
| 14958 | CHKLEV = TINY1 |
| 14959 | CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,6,IREJ1) |
| 14960 | C IF (IREJ1.NE.0) CALL DT_EVTOUT(4) |
| 14961 | ENDIF |
| 14962 | |
| 14963 | * global energy-momentum & flavor conservation check |
| 14964 | **sr 16.5. this check is skipped in case of phojet-treatment |
| 14965 | IF (MCGENE.EQ.1) |
| 14966 | & CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,12,IREJ3) |
| 14967 | |
| 14968 | * update statistics-counter for diffraction |
| 14969 | c IF (IFLAGD.NE.0) THEN |
| 14970 | c ICDIFF(1) = ICDIFF(1)+1 |
| 14971 | c IF (IFLAGD.EQ. 1) ICDIFF(2) = ICDIFF(2)+1 |
| 14972 | c IF (IFLAGD.EQ. 2) ICDIFF(3) = ICDIFF(3)+1 |
| 14973 | c IF (IFLAGD.EQ.-1) ICDIFF(4) = ICDIFF(4)+1 |
| 14974 | c IF (IFLAGD.EQ.-2) ICDIFF(5) = ICDIFF(5)+1 |
| 14975 | c ENDIF |
| 14976 | |
| 14977 | ENDIF |
| 14978 | |
| 14979 | RETURN |
| 14980 | |
| 14981 | 9999 CONTINUE |
| 14982 | IREJ = 1 |
| 14983 | RETURN |
| 14984 | END |
| 14985 | * |
| 14986 | *===decay==============================================================* |
| 14987 | * |
| 14988 | CDECK ID>, DT_DECAYS |
| 14989 | SUBROUTINE DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ) |
| 14990 | |
| 14991 | ************************************************************************ |
| 14992 | * Resonance-decay. * |
| 14993 | * This subroutine replaces DDECAY/DECHKK. * |
| 14994 | * PIN(4) 4-momentum of resonance (input) * |
| 14995 | * IDXIN BAMJET-index of resonance (input) * |
| 14996 | * POUT(20,4) 4-momenta of decay-products (output) * |
| 14997 | * IDXOUT(20) BAMJET-indices of decay-products (output) * |
| 14998 | * NSEC number of secondaries (output) * |
| 14999 | * Adopted from the original version DECHKK. * |
| 15000 | * This version dated 09.01.95 is written by S. Roesler * |
| 15001 | ************************************************************************ |
| 15002 | |
| 15003 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 15004 | SAVE |
| 15005 | |
| 15006 | PARAMETER ( LINP = 5 , |
| 15007 | & LOUT = 6 , |
| 15008 | & LDAT = 9 ) |
| 15009 | |
| 15010 | PARAMETER (TINY17=1.0D-17) |
| 15011 | |
| 15012 | * HADRIN: decay channel information |
| 15013 | PARAMETER (IDMAX9=602) |
| 15014 | CHARACTER*8 ZKNAME |
| 15015 | COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3) |
| 15016 | * particle properties (BAMJET index convention) |
| 15017 | CHARACTER*8 ANAME |
| 15018 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 15019 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 15020 | * flags for input different options |
| 15021 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 15022 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 15023 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 15024 | |
| 15025 | DIMENSION PIN(4),PI(20,4),POUT(20,4),IDXOUT(20), |
| 15026 | & EF(3),PF(3),PFF(3),IDXSTK(20),IDX(3), |
| 15027 | & CODF(3),COFF(3),SIFF(3),DCOS(3),DCOSF(3) |
| 15028 | |
| 15029 | * ISTAB = 1 strong and weak decays |
| 15030 | * = 2 strong decays only |
| 15031 | * = 3 strong decays, weak decays for charmed particles and tau |
| 15032 | * leptons only |
| 15033 | DATA ISTAB /2/ |
| 15034 | |
| 15035 | IREJ = 0 |
| 15036 | NSEC = 0 |
| 15037 | * put initial resonance to stack |
| 15038 | NSTK = 1 |
| 15039 | IDXSTK(NSTK) = IDXIN |
| 15040 | DO 5 I=1,4 |
| 15041 | PI(NSTK,I) = PIN(I) |
| 15042 | 5 CONTINUE |
| 15043 | |
| 15044 | * store initial configuration for energy-momentum cons. check |
| 15045 | IF (LEMCCK) CALL DT_EVTEMC(PI(NSTK,1),PI(NSTK,2),PI(NSTK,3), |
| 15046 | & PI(NSTK,4),1,IDUM,IDUM) |
| 15047 | |
| 15048 | 100 CONTINUE |
| 15049 | * get particle from stack |
| 15050 | IDXI = IDXSTK(NSTK) |
| 15051 | * skip stable particles |
| 15052 | IF (ISTAB.EQ.1) THEN |
| 15053 | IF ((IDXI.EQ.135).OR. (IDXI.EQ.136)) GOTO 10 |
| 15054 | IF ((IDXI.GE. 1).AND.(IDXI.LE. 7)) GOTO 10 |
| 15055 | ELSEIF (ISTAB.EQ.2) THEN |
| 15056 | IF ((IDXI.GE. 1).AND.(IDXI.LE. 30)) GOTO 10 |
| 15057 | IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10 |
| 15058 | IF ((IDXI.GE.115).AND.(IDXI.LE.122)) GOTO 10 |
| 15059 | IF ((IDXI.GE.131).AND.(IDXI.LE.136)) GOTO 10 |
| 15060 | IF ( IDXI.EQ.109) GOTO 10 |
| 15061 | IF ((IDXI.GE.137).AND.(IDXI.LE.160)) GOTO 10 |
| 15062 | ELSEIF (ISTAB.EQ.3) THEN |
| 15063 | IF ((IDXI.GE. 1).AND.(IDXI.LE. 23)) GOTO 10 |
| 15064 | IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10 |
| 15065 | IF ((IDXI.GE.109).AND.(IDXI.LE.115)) GOTO 10 |
| 15066 | IF ((IDXI.GE.133).AND.(IDXI.LE.136)) GOTO 10 |
| 15067 | ENDIF |
| 15068 | |
| 15069 | * calculate direction cosines and Lorentz-parameter of decaying part. |
| 15070 | PTOT = SQRT(PI(NSTK,1)**2+PI(NSTK,2)**2+PI(NSTK,3)**2) |
| 15071 | PTOT = MAX(PTOT,TINY17) |
| 15072 | DO 1 I=1,3 |
| 15073 | DCOS(I) = PI(NSTK,I)/PTOT |
| 15074 | 1 CONTINUE |
| 15075 | GAM = PI(NSTK,4)/AAM(IDXI) |
| 15076 | BGAM = PTOT/AAM(IDXI) |
| 15077 | |
| 15078 | * get decay-channel |
| 15079 | KCHAN = K1(IDXI)-1 |
| 15080 | 2 CONTINUE |
| 15081 | KCHAN = KCHAN+1 |
| 15082 | IF ((DT_RNDM(GAM)-TINY17).GT.WT(KCHAN)) GOTO 2 |
| 15083 | |
| 15084 | * identities of secondaries |
| 15085 | IDX(1) = NZK(KCHAN,1) |
| 15086 | IDX(2) = NZK(KCHAN,2) |
| 15087 | IF (IDX(2).LT.1) GOTO 9999 |
| 15088 | IDX(3) = NZK(KCHAN,3) |
| 15089 | |
| 15090 | * handle decay in rest system of decaying particle |
| 15091 | IF (IDX(3).EQ.0) THEN |
| 15092 | * two-particle decay |
| 15093 | NDEC = 2 |
| 15094 | CALL DT_DTWOPD(AAM(IDXI),EF(1),EF(2),PF(1),PF(2), |
| 15095 | & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2), |
| 15096 | & AAM(IDX(1)),AAM(IDX(2))) |
| 15097 | ELSE |
| 15098 | * three-particle decay |
| 15099 | NDEC = 3 |
| 15100 | CALL DT_DTHREP(AAM(IDXI),EF(1),EF(2),EF(3),PF(1),PF(2),PF(3), |
| 15101 | & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2), |
| 15102 | & CODF(3),COFF(3),SIFF(3), |
| 15103 | & AAM(IDX(1)),AAM(IDX(2)),AAM(IDX(3))) |
| 15104 | ENDIF |
| 15105 | NSTK = NSTK-1 |
| 15106 | |
| 15107 | * transform decay products back |
| 15108 | DO 3 I=1,NDEC |
| 15109 | NSTK = NSTK+1 |
| 15110 | CALL DT_DTRAFO(GAM,BGAM,DCOS(1),DCOS(2),DCOS(3), |
| 15111 | & CODF(I),COFF(I),SIFF(I),PF(I),EF(I), |
| 15112 | & PFF(I),DCOSF(1),DCOSF(2),DCOSF(3),PI(NSTK,4)) |
| 15113 | * add particle to stack |
| 15114 | IDXSTK(NSTK) = IDX(I) |
| 15115 | DO 4 J=1,3 |
| 15116 | PI(NSTK,J) = DCOSF(J)*PFF(I) |
| 15117 | 4 CONTINUE |
| 15118 | 3 CONTINUE |
| 15119 | GOTO 100 |
| 15120 | |
| 15121 | 10 CONTINUE |
| 15122 | * stable particle, put to output-arrays |
| 15123 | NSEC = NSEC+1 |
| 15124 | DO 6 I=1,4 |
| 15125 | POUT(NSEC,I) = PI(NSTK,I) |
| 15126 | 6 CONTINUE |
| 15127 | IDXOUT(NSEC) = IDXSTK(NSTK) |
| 15128 | * store secondaries for energy-momentum conservation check |
| 15129 | IF (LEMCCK) |
| 15130 | &CALL DT_EVTEMC(-POUT(NSEC,1),-POUT(NSEC,2),-POUT(NSEC,3), |
| 15131 | & -POUT(NSEC,4),2,IDUM,IDUM) |
| 15132 | NSTK = NSTK-1 |
| 15133 | IF (NSTK.GT.0) GOTO 100 |
| 15134 | |
| 15135 | * check energy-momentum conservation |
| 15136 | IF (LEMCCK) THEN |
| 15137 | CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,5,IREJ1) |
| 15138 | IF (IREJ1.NE.0) GOTO 9999 |
| 15139 | ENDIF |
| 15140 | |
| 15141 | RETURN |
| 15142 | |
| 15143 | 9999 CONTINUE |
| 15144 | IREJ = 1 |
| 15145 | RETURN |
| 15146 | END |
| 15147 | * |
| 15148 | *===decay1=============================================================* |
| 15149 | * |
| 15150 | CDECK ID>, DT_DECAY1 |
| 15151 | SUBROUTINE DT_DECAY1 |
| 15152 | |
| 15153 | ************************************************************************ |
| 15154 | * Decay of resonances stored in DTEVT1. * |
| 15155 | * This version dated 20.01.95 is written by S. Roesler * |
| 15156 | ************************************************************************ |
| 15157 | |
| 15158 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 15159 | SAVE |
| 15160 | |
| 15161 | PARAMETER ( LINP = 5 , |
| 15162 | & LOUT = 6 , |
| 15163 | & LDAT = 9 ) |
| 15164 | |
| 15165 | * event history |
| 15166 | |
| 15167 | PARAMETER (NMXHKK=200000) |
| 15168 | |
| 15169 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 15170 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 15171 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 15172 | * extended event history |
| 15173 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 15174 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 15175 | & IHIST(2,NMXHKK) |
| 15176 | |
| 15177 | DIMENSION PIN(4),POUT(20,4),IDXOUT(20) |
| 15178 | |
| 15179 | NEND = NHKK |
| 15180 | C DO 1 I=NPOINT(5),NEND |
| 15181 | DO 1 I=NPOINT(4),NEND |
| 15182 | IF (ABS(ISTHKK(I)).EQ.1) THEN |
| 15183 | DO 2 K=1,4 |
| 15184 | PIN(K) = PHKK(K,I) |
| 15185 | 2 CONTINUE |
| 15186 | IDXIN = IDBAM(I) |
| 15187 | CALL DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ) |
| 15188 | IF (NSEC.GT.1) THEN |
| 15189 | DO 3 N=1,NSEC |
| 15190 | IDHAD = IDT_IPDGHA(IDXOUT(N)) |
| 15191 | CALL DT_EVTPUT(1,IDHAD,I,0,POUT(N,1),POUT(N,2), |
| 15192 | & POUT(N,3),POUT(N,4),0,0,0) |
| 15193 | 3 CONTINUE |
| 15194 | ENDIF |
| 15195 | ENDIF |
| 15196 | 1 CONTINUE |
| 15197 | |
| 15198 | RETURN |
| 15199 | END |
| 15200 | * |
| 15201 | *===decpi0=============================================================* |
| 15202 | * |
| 15203 | CDECK ID>, DT_DECPI0 |
| 15204 | SUBROUTINE DT_DECPI0 |
| 15205 | |
| 15206 | ************************************************************************ |
| 15207 | * Decay of pi0 handled with JETSET. * |
| 15208 | * This version dated 18.02.96 is written by S. Roesler * |
| 15209 | ************************************************************************ |
| 15210 | |
| 15211 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 15212 | SAVE |
| 15213 | |
| 15214 | PARAMETER ( LINP = 5 , |
| 15215 | & LOUT = 6 , |
| 15216 | & LDAT = 9 ) |
| 15217 | |
| 15218 | PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0,ZERO=0.0D0) |
| 15219 | |
| 15220 | * event history |
| 15221 | |
| 15222 | PARAMETER (NMXHKK=200000) |
| 15223 | |
| 15224 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 15225 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 15226 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 15227 | * extended event history |
| 15228 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 15229 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 15230 | & IHIST(2,NMXHKK) |
| 15231 | |
| 15232 | COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5) |
| 15233 | |
| 15234 | COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) |
| 15235 | |
| 15236 | PARAMETER (MAXLND=4000) |
| 15237 | COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5) |
| 15238 | |
| 15239 | * flags for input different options |
| 15240 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 15241 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 15242 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 15243 | |
| 15244 | INTEGER PYCOMP,PYK |
| 15245 | |
| 15246 | DIMENSION IHISMO(NMXHKK),P1(4) |
| 15247 | |
| 15248 | TWOPI = 2.0D0*ATAN2(0.0D0,-1.0D0) |
| 15249 | |
| 15250 | CALL DT_INITJS(2) |
| 15251 | * allow pi0 decay |
| 15252 | |
| 15253 | KC = PYCOMP(111) |
| 15254 | |
| 15255 | MDCY(KC,1) = 1 |
| 15256 | |
| 15257 | NN = 0 |
| 15258 | INI = 0 |
| 15259 | DO 1 I=1,NHKK |
| 15260 | IF ((ISTHKK(I).EQ.1).AND.(IDHKK(I).EQ.111)) THEN |
| 15261 | IF (INI.EQ.0) THEN |
| 15262 | INI = 1 |
| 15263 | ELSE |
| 15264 | INI = 2 |
| 15265 | ENDIF |
| 15266 | IF (LEMCCK) CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I), |
| 15267 | & PHKK(4,I),INI,IDUM,IDUM) |
| 15268 | PT = SQRT(PHKK(1,I)**2+PHKK(2,I)**2) |
| 15269 | PTOT = SQRT(PT**2+PHKK(3,I)**2) |
| 15270 | COSTH = PHKK(3,I)/(PTOT+TINY10) |
| 15271 | IF (COSTH.GT.ONE) THEN |
| 15272 | THETA = ZERO |
| 15273 | ELSEIF (COSTH.LT.-ONE) THEN |
| 15274 | THETA = TWOPI/2.0D0 |
| 15275 | ELSE |
| 15276 | THETA = ACOS(COSTH) |
| 15277 | ENDIF |
| 15278 | PHI = ASIN(PHKK(2,I)/(PT +TINY10)) |
| 15279 | IF (PHKK(1,I).LT.0.0D0) |
| 15280 | |
| 15281 | & PHI = SIGN(TWOPI/2.0D0-ABS(PHI),PHI) |
| 15282 | |
| 15283 | ENER = PHKK(4,I) |
| 15284 | NN = NN+1 |
| 15285 | KTEMP = MSTU(10) |
| 15286 | MSTU(10)= 1 |
| 15287 | P(NN,5) = PHKK(5,I) |
| 15288 | |
| 15289 | CALL PY1ENT(NN,111,ENER,THETA,PHI) |
| 15290 | |
| 15291 | MSTU(10) = KTEMP |
| 15292 | IHISMO(NN)= I |
| 15293 | ENDIF |
| 15294 | 1 CONTINUE |
| 15295 | IF (NN.GT.0) THEN |
| 15296 | |
| 15297 | CALL PYEXEC |
| 15298 | |
| 15299 | NLINES = PYK(0,1) |
| 15300 | |
| 15301 | DO 2 II=1,NLINES |
| 15302 | |
| 15303 | IF (PYK(II,7).EQ.1) THEN |
| 15304 | |
| 15305 | DO 3 KK=1,4 |
| 15306 | |
| 15307 | P1(KK) = PYP(II,KK) |
| 15308 | |
| 15309 | 3 CONTINUE |
| 15310 | |
| 15311 | ID = PYK(II,8) |
| 15312 | MO = IHISMO(PYK(II,15)) |
| 15313 | |
| 15314 | CALL DT_EVTPUT(1,ID,MO,0,P1(1),P1(2),P1(3),P1(4),0,0,0) |
| 15315 | IF (LEMCCK) |
| 15316 | & CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2, |
| 15317 | & IDUM,IDUM) |
| 15318 | *sr: flag with neg. sign (for HELIOS p/A-W jobs) |
| 15319 | ISTHKK(MO) = -2 |
| 15320 | ENDIF |
| 15321 | 2 CONTINUE |
| 15322 | IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,7000,IREJ1) |
| 15323 | ENDIF |
| 15324 | MDCY(KC,1) = 0 |
| 15325 | |
| 15326 | RETURN |
| 15327 | END |
| 15328 | * |
| 15329 | *===dtwopd=============================================================* |
| 15330 | * |
| 15331 | CDECK ID>, DT_DTWOPD |
| 15332 | SUBROUTINE DT_DTWOPD(UMO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,COD2, |
| 15333 | & COF2,SIF2,AM1,AM2) |
| 15334 | |
| 15335 | ************************************************************************ |
| 15336 | * Two-particle decay. * |
| 15337 | * UMO cm-energy of the decaying system (input) * |
| 15338 | * AM1/AM2 masses of the decay products (input) * |
| 15339 | * ECM1,ECM2/PCM1,PCM2 cm-energies/momenta of the decay prod. (output) * |
| 15340 | * COD,COF,SIF direction cosines of the decay prod. (output) * |
| 15341 | * Revised by S. Roesler, 20.11.95 * |
| 15342 | ************************************************************************ |
| 15343 | |
| 15344 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 15345 | SAVE |
| 15346 | |
| 15347 | PARAMETER ( LINP = 5 , |
| 15348 | & LOUT = 6 , |
| 15349 | & LDAT = 9 ) |
| 15350 | |
| 15351 | PARAMETER (TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,ZERO=0.0D0) |
| 15352 | |
| 15353 | IF (UMO.LT.(AM1+AM2)) THEN |
| 15354 | WRITE(LOUT,1000) UMO,AM1,AM2 |
| 15355 | 1000 FORMAT(1X,'DTWOPD: inconsistent kinematics - UMO,AM1,AM2 ', |
| 15356 | & 3E12.3) |
| 15357 | STOP |
| 15358 | ENDIF |
| 15359 | |
| 15360 | ECM1 = ((UMO-AM2)*(UMO+AM2)+AM1*AM1)/(TWO*UMO) |
| 15361 | ECM2 = UMO-ECM1 |
| 15362 | PCM1 = SQRT((ECM1-AM1)*(ECM1+AM1)) |
| 15363 | PCM2 = PCM1 |
| 15364 | CALL DT_DSFECF(SIF1,COF1) |
| 15365 | COD1 = TWO*DT_RNDM(PCM2)-ONE |
| 15366 | COD2 = -COD1 |
| 15367 | COF2 = -COF1 |
| 15368 | SIF2 = -SIF1 |
| 15369 | |
| 15370 | RETURN |
| 15371 | END |
| 15372 | * |
| 15373 | *===dthrep=============================================================* |
| 15374 | * |
| 15375 | CDECK ID>, DT_DTHREP |
| 15376 | SUBROUTINE DT_DTHREP(UMO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1, |
| 15377 | & SIF1,COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3) |
| 15378 | |
| 15379 | ************************************************************************ |
| 15380 | * Three-particle decay. * |
| 15381 | * UMO cm-energy of the decaying system (input) * |
| 15382 | * AM1/2/3 masses of the decay products (input) * |
| 15383 | * ECM1/2/2,PCM1/2/3 cm-energies/momenta of the decay prod. (output) * |
| 15384 | * COD,COF,SIF direction cosines of the decay prod. (output) * |
| 15385 | * * |
| 15386 | * Threpd89: slight revision by A. Ferrari * |
| 15387 | * Last change on 11-oct-93 by Alfredo Ferrari, INFN - Milan * |
| 15388 | * Revised by S. Roesler, 20.11.95 * |
| 15389 | ************************************************************************ |
| 15390 | |
| 15391 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 15392 | SAVE |
| 15393 | |
| 15394 | PARAMETER ( LINP = 5 , |
| 15395 | & LOUT = 6 , |
| 15396 | & LDAT = 9 ) |
| 15397 | |
| 15398 | PARAMETER ( ANGLSQ = 2.5D-31 ) |
| 15399 | PARAMETER ( AZRZRZ = 1.0D-30 ) |
| 15400 | PARAMETER ( ONEMNS = 0.999999999999999 D+00 ) |
| 15401 | PARAMETER ( ONEPLS = 1.000000000000001 D+00 ) |
| 15402 | PARAMETER ( ONEONE = 1.D+00 ) |
| 15403 | PARAMETER ( TWOTWO = 2.D+00 ) |
| 15404 | PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 ) |
| 15405 | |
| 15406 | COMMON /HNGAMR/ REDU,AMO,AMM(15) |
| 15407 | * flags for input different options |
| 15408 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 15409 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 15410 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 15411 | |
| 15412 | DIMENSION F(5),XX(5) |
| 15413 | DATA EPS /AZRZRZ/ |
| 15414 | |
| 15415 | UMOO=UMO+UMO |
| 15416 | C***S1, S2, S3 ARE THE INVARIANT MASSES OF THE PARTICLES 1, 2, 3 |
| 15417 | C***J. VON NEUMANN - RANDOM - SELECTION OF S2 |
| 15418 | C***CALCULATION OF THE MAXIMUM OF THE S2 - DISTRIBUTION |
| 15419 | UUMO=UMO |
| 15420 | AAM1=AM1 |
| 15421 | AAM2=AM2 |
| 15422 | AAM3=AM3 |
| 15423 | GU=(AM2+AM3)**2 |
| 15424 | GO=(UMO-AM1)**2 |
| 15425 | * UFAK=1.0000000000001D0 |
| 15426 | * IF (GU.GT.GO) UFAK=0.9999999999999D0 |
| 15427 | IF (GU.GT.GO) THEN |
| 15428 | UFAK=ONEMNS |
| 15429 | ELSE |
| 15430 | UFAK=ONEPLS |
| 15431 | END IF |
| 15432 | OFAK=2.D0-UFAK |
| 15433 | GU=GU*UFAK |
| 15434 | GO=GO*OFAK |
| 15435 | DS2=(GO-GU)/99.D0 |
| 15436 | AM11=AM1*AM1 |
| 15437 | AM22=AM2*AM2 |
| 15438 | AM33=AM3*AM3 |
| 15439 | UMO2=UMO*UMO |
| 15440 | RHO2=0.D0 |
| 15441 | S22=GU |
| 15442 | DO 124 I=1,100 |
| 15443 | S21=S22 |
| 15444 | S22=GU+(I-1.D0)*DS2 |
| 15445 | RHO1=RHO2 |
| 15446 | RHO2=DT_YLAMB(S22,UMO2,AM11)*DT_YLAMB(S22,AM22,AM33)/ |
| 15447 | * (S22+EPS) |
| 15448 | IF(RHO2.LT.RHO1) GO TO 125 |
| 15449 | 124 CONTINUE |
| 15450 | 125 S2SUP=(S22-S21)*.5D0+S21 |
| 15451 | SUPRHO=DT_YLAMB(S2SUP,UMO2,AM11)*DT_YLAMB(S2SUP,AM22,AM33)/ |
| 15452 | * (S2SUP+EPS) |
| 15453 | SUPRHO=SUPRHO*1.05D0 |
| 15454 | XO=S21-DS2 |
| 15455 | IF (GU.LT.GO.AND.XO.LT.GU) XO=GU |
| 15456 | IF (GU.GT.GO.AND.XO.GT.GU) XO=GU |
| 15457 | XX(1)=XO |
| 15458 | XX(3)=S22 |
| 15459 | X1=(XO+S22)*0.5D0 |
| 15460 | XX(2)=X1 |
| 15461 | F(3)=RHO2 |
| 15462 | F(1)=DT_YLAMB(XO,UMO2,AM11)*DT_YLAMB(XO,AM22,AM33)/(XO+EPS) |
| 15463 | F(2)=DT_YLAMB(X1,UMO2,AM11)*DT_YLAMB(X1,AM22,AM33)/(X1+EPS) |
| 15464 | DO 126 I=1,16 |
| 15465 | X4=(XX(1)+XX(2))*0.5D0 |
| 15466 | X5=(XX(2)+XX(3))*0.5D0 |
| 15467 | F(4)=DT_YLAMB(X4,UMO2,AM11)*DT_YLAMB(X4,AM22,AM33)/ |
| 15468 | * (X4+EPS) |
| 15469 | F(5)=DT_YLAMB(X5,UMO2,AM11)*DT_YLAMB(X5,AM22,AM33)/ |
| 15470 | * (X5+EPS) |
| 15471 | XX(4)=X4 |
| 15472 | XX(5)=X5 |
| 15473 | DO 128 II=1,5 |
| 15474 | IA=II |
| 15475 | DO 128 III=IA,5 |
| 15476 | IF (F (II).GE.F (III)) GO TO 128 |
| 15477 | FH=F(II) |
| 15478 | F(II)=F(III) |
| 15479 | F(III)=FH |
| 15480 | FH=XX(II) |
| 15481 | XX(II)=XX(III) |
| 15482 | XX(III)=FH |
| 15483 | 128 CONTINUE |
| 15484 | SUPRHO=F(1) |
| 15485 | S2SUP=XX(1) |
| 15486 | DO 129 II=1,3 |
| 15487 | IA=II |
| 15488 | DO 129 III=IA,3 |
| 15489 | IF (XX(II).GE.XX(III)) GO TO 129 |
| 15490 | FH=F(II) |
| 15491 | F(II)=F(III) |
| 15492 | F(III)=FH |
| 15493 | FH=XX(II) |
| 15494 | XX(II)=XX(III) |
| 15495 | XX(III)=FH |
| 15496 | 129 CONTINUE |
| 15497 | 126 CONTINUE |
| 15498 | AM23=(AM2+AM3)**2 |
| 15499 | ITH=0 |
| 15500 | REDU=2.D0 |
| 15501 | 1 CONTINUE |
| 15502 | ITH=ITH+1 |
| 15503 | IF (ITH.GT.200) REDU=-9.D0 |
| 15504 | IF (ITH.GT.200) GO TO 400 |
| 15505 | C=DT_RNDM(REDU) |
| 15506 | * S2=AM23+C*((UMO-AM1)**2-AM23) |
| 15507 | S2=AM23+C*(UMO-AM1-AM2-AM3)*(UMO-AM1+AM2+AM3) |
| 15508 | Y=DT_RNDM(S2) |
| 15509 | Y=Y*SUPRHO |
| 15510 | RHO=DT_YLAMB(S2,UMO2,AM11)*DT_YLAMB(S2,AM22,AM33)/S2 |
| 15511 | IF(Y.GT.RHO) GO TO 1 |
| 15512 | C***RANDOM SELECTION OF S3 AND CALCULATION OF S1 |
| 15513 | S1=DT_RNDM(S2) |
| 15514 | S1=S1*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)/(2.D0*S2)- |
| 15515 | &RHO*.5D0 |
| 15516 | S3=UMO2+AM11+AM22+AM33-S1-S2 |
| 15517 | ECM1=(UMO2+AM11-S2)/UMOO |
| 15518 | ECM2=(UMO2+AM22-S3)/UMOO |
| 15519 | ECM3=(UMO2+AM33-S1)/UMOO |
| 15520 | PCM1=SQRT((ECM1+AM1)*(ECM1-AM1)) |
| 15521 | PCM2=SQRT((ECM2+AM2)*(ECM2-AM2)) |
| 15522 | PCM3=SQRT((ECM3+AM3)*(ECM3-AM3)) |
| 15523 | CALL DT_DSFECF(SFE,CFE) |
| 15524 | C***TH IS THE ANGLE BETWEEN PARTICLES 1 AND 2 |
| 15525 | C***TH1, TH2 ARE THE ANGLES BETWEEN PARTICLES 1, 2 AND THE DIRECTION OF |
| 15526 | PCM12 = PCM1 * PCM2 |
| 15527 | IF ( PCM12 .LT. ANGLSQ ) GO TO 200 |
| 15528 | COSTH=(ECM1*ECM2+0.5D+00*(AM11+AM22-S1))/PCM12 |
| 15529 | GO TO 300 |
| 15530 | 200 CONTINUE |
| 15531 | UW=DT_RNDM(S1) |
| 15532 | COSTH=(UW-0.5D+00)*2.D+00 |
| 15533 | 300 CONTINUE |
| 15534 | * IF(ABS(COSTH).GT.0.9999999999999999D0) |
| 15535 | * &COSTH=SIGN(0.9999999999999999D0,COSTH) |
| 15536 | IF(ABS(COSTH).GT.ONEONE) |
| 15537 | &COSTH=SIGN(ONEONE,COSTH) |
| 15538 | IF (REDU.LT.1.D+00) RETURN |
| 15539 | COSTH2=(PCM3*PCM3+PCM2*PCM2-PCM1*PCM1)/(2.D+00*PCM2*PCM3) |
| 15540 | * IF(ABS(COSTH2).GT.0.9999999999999999D0) |
| 15541 | * &COSTH2=SIGN(0.9999999999999999D0,COSTH2) |
| 15542 | IF(ABS(COSTH2).GT.ONEONE) |
| 15543 | &COSTH2=SIGN(ONEONE,COSTH2) |
| 15544 | SINTH2=SQRT((ONEONE-COSTH2)*(ONEONE+COSTH2)) |
| 15545 | SINTH =SQRT((ONEONE-COSTH)*(ONEONE+COSTH)) |
| 15546 | SINTH1=COSTH2*SINTH-COSTH*SINTH2 |
| 15547 | COSTH1=COSTH*COSTH2+SINTH2*SINTH |
| 15548 | C***RANDOM SELECTION OF THE SPHERICAL COORDINATES OF THE DIRECTION OF PA |
| 15549 | C***CFE, SFE ARE COS AND SIN OF THE ROTATION ANGLE OF THE SYSTEM 1, 2 AR |
| 15550 | C***THE DIRECTION OF PARTICLE 3 |
| 15551 | C***CALCULATION OF THE SPHERICAL COORDINATES OF PARTICLES 1, 2 |
| 15552 | CX11=-COSTH1 |
| 15553 | CY11=SINTH1*CFE |
| 15554 | CZ11=SINTH1*SFE |
| 15555 | CX22=-COSTH2 |
| 15556 | CY22=-SINTH2*CFE |
| 15557 | CZ22=-SINTH2*SFE |
| 15558 | CALL DT_DSFECF(SIF3,COF3) |
| 15559 | COD3=TWOTWO*DT_RNDM(CX11)-ONEONE |
| 15560 | SID3=SQRT((1.D+00-COD3)*(1.D+00+COD3)) |
| 15561 | 2 FORMAT(5F20.15) |
| 15562 | COD1=CX11*COD3+CZ11*SID3 |
| 15563 | CHLP=(ONEONE-COD1)*(ONEONE+COD1) |
| 15564 | IF(CHLP.LT.1.D-14)WRITE(LOUT,2)COD1,COF3,SID3, |
| 15565 | &CX11,CZ11 |
| 15566 | SID1=SQRT(CHLP) |
| 15567 | COF1=(CX11*SID3*COF3-CY11*SIF3-CZ11*COD3*COF3)/SID1 |
| 15568 | SIF1=(CX11*SID3*SIF3+CY11*COF3-CZ11*COD3*SIF3)/SID1 |
| 15569 | COD2=CX22*COD3+CZ22*SID3 |
| 15570 | SID2=SQRT((ONEONE-COD2)*(ONEONE+COD2)) |
| 15571 | COF2=(CX22*SID3*COF3-CY22*SIF3-CZ22*COD3*COF3)/SID2 |
| 15572 | SIF2=(CX22*SID3*SIF3+CY22*COF3-CZ22*COD3*SIF3)/SID2 |
| 15573 | 400 CONTINUE |
| 15574 | * === Energy conservation check: === * |
| 15575 | EOCHCK = UMO - ECM1 - ECM2 - ECM3 |
| 15576 | * SID1 = SQRT ( ( ONEONE - COD1 ) * ( ONEONE + COD1 ) ) |
| 15577 | * SID2 = SQRT ( ( ONEONE - COD2 ) * ( ONEONE + COD2 ) ) |
| 15578 | * SID3 = SQRT ( ( ONEONE - COD3 ) * ( ONEONE + COD3 ) ) |
| 15579 | PZCHCK = PCM1 * COD1 + PCM2 * COD2 + PCM3 * COD3 |
| 15580 | PXCHCK = PCM1 * COF1 * SID1 + PCM2 * COF2 * SID2 |
| 15581 | & + PCM3 * COF3 * SID3 |
| 15582 | PYCHCK = PCM1 * SIF1 * SID1 + PCM2 * SIF2 * SID2 |
| 15583 | & + PCM3 * SIF3 * SID3 |
| 15584 | EOCMPR = 1.D-12 * UMO |
| 15585 | IF ( ABS (EOCHCK) + ABS (PXCHCK) + ABS (PYCHCK) + ABS (PZCHCK) |
| 15586 | & .GT. EOCMPR ) THEN |
| 15587 | **sr 5.5.95 output-unit changed |
| 15588 | IF (IOULEV(1).GT.0) THEN |
| 15589 | WRITE(LOUT,*) |
| 15590 | & ' *** Threpd: energy/momentum conservation failure! ***', |
| 15591 | & EOCHCK,PXCHCK,PYCHCK,PZCHCK |
| 15592 | WRITE(LOUT,*)' *** SID1,SID2,SID3',SID1,SID2,SID3 |
| 15593 | ENDIF |
| 15594 | ** |
| 15595 | END IF |
| 15596 | RETURN |
| 15597 | END |
| 15598 | * |
| 15599 | *===dbklas=============================================================* |
| 15600 | * |
| 15601 | CDECK ID>, DT_DBKLAS |
| 15602 | SUBROUTINE DT_DBKLAS(I,J,K,I8,I10) |
| 15603 | |
| 15604 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 15605 | SAVE |
| 15606 | |
| 15607 | PARAMETER ( LINP = 5 , |
| 15608 | & LOUT = 6 , |
| 15609 | & LDAT = 9 ) |
| 15610 | |
| 15611 | * quark-content to particle index conversion (DTUNUC 1.x) |
| 15612 | COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21), |
| 15613 | & IA08(6,21),IA10(6,21) |
| 15614 | |
| 15615 | IF (I) 20,20,10 |
| 15616 | * baryons |
| 15617 | 10 CONTINUE |
| 15618 | CALL DT_INDEXD(J,K,IND) |
| 15619 | I8 = IB08(I,IND) |
| 15620 | I10 = IB10(I,IND) |
| 15621 | IF (I8.LE.0) I8 = I10 |
| 15622 | RETURN |
| 15623 | * antibaryons |
| 15624 | 20 CONTINUE |
| 15625 | II = IABS(I) |
| 15626 | JJ = IABS(J) |
| 15627 | KK = IABS(K) |
| 15628 | CALL DT_INDEXD(JJ,KK,IND) |
| 15629 | I8 = IA08(II,IND) |
| 15630 | I10 = IA10(II,IND) |
| 15631 | IF (I8.LE.0) I8 = I10 |
| 15632 | |
| 15633 | RETURN |
| 15634 | END |
| 15635 | * |
| 15636 | *===indexd=============================================================* |
| 15637 | * |
| 15638 | CDECK ID>, DT_INDEXD |
| 15639 | SUBROUTINE DT_INDEXD(KA,KB,IND) |
| 15640 | |
| 15641 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 15642 | SAVE |
| 15643 | |
| 15644 | PARAMETER ( LINP = 5 , |
| 15645 | & LOUT = 6 , |
| 15646 | & LDAT = 9 ) |
| 15647 | |
| 15648 | KP = KA*KB |
| 15649 | KS = KA+KB |
| 15650 | IF (KP.EQ.1) IND=1 |
| 15651 | IF (KP.EQ.2) IND=2 |
| 15652 | IF (KP.EQ.3) IND=3 |
| 15653 | IF ((KP.EQ.4).AND.(KS.EQ.5)) IND=4 |
| 15654 | IF (KP.EQ.5) IND=5 |
| 15655 | IF ((KP.EQ.6).AND.(KS.EQ.7)) IND=6 |
| 15656 | IF ((KP.EQ.4).AND.(KS.EQ.4)) IND=7 |
| 15657 | IF ((KP.EQ.6).AND.(KS.EQ.5)) IND=8 |
| 15658 | IF (KP.EQ.8) IND=9 |
| 15659 | IF (KP.EQ.10) IND=10 |
| 15660 | IF ((KP.EQ.12).AND.(KS.EQ.8)) IND=11 |
| 15661 | IF (KP.EQ.9) IND=12 |
| 15662 | IF ((KP.EQ.12).AND.(KS.EQ.7)) IND=13 |
| 15663 | IF (KP.EQ.15) IND=14 |
| 15664 | IF (KP.EQ.18) IND=15 |
| 15665 | IF (KP.EQ.16) IND=16 |
| 15666 | IF (KP.EQ.20) IND=17 |
| 15667 | IF (KP.EQ.24) IND=18 |
| 15668 | IF (KP.EQ.25) IND=19 |
| 15669 | IF (KP.EQ.30) IND=20 |
| 15670 | IF (KP.EQ.36) IND=21 |
| 15671 | |
| 15672 | RETURN |
| 15673 | END |
| 15674 | * |
| 15675 | *===dchant=============================================================* |
| 15676 | * |
| 15677 | CDECK ID>, DT_DCHANT |
| 15678 | SUBROUTINE DT_DCHANT |
| 15679 | |
| 15680 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 15681 | SAVE |
| 15682 | |
| 15683 | PARAMETER ( LINP = 5 , |
| 15684 | & LOUT = 6 , |
| 15685 | & LDAT = 9 ) |
| 15686 | |
| 15687 | PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0) |
| 15688 | |
| 15689 | * HADRIN: decay channel information |
| 15690 | PARAMETER (IDMAX9=602) |
| 15691 | CHARACTER*8 ZKNAME |
| 15692 | COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3) |
| 15693 | * particle properties (BAMJET index convention) |
| 15694 | CHARACTER*8 ANAME |
| 15695 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 15696 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 15697 | |
| 15698 | DIMENSION HWT(IDMAX9) |
| 15699 | |
| 15700 | * change of weights wt from absolut values into the sum of wt of a dec. |
| 15701 | DO 10 J=1,IDMAX9 |
| 15702 | HWT(J) = ZERO |
| 15703 | 10 CONTINUE |
| 15704 | C DO 999 KKK=1,210 |
| 15705 | C WRITE(LOUT,'(A8,F5.2,2E10.3,2I4,2I10)') |
| 15706 | C & ANAME(KKK),AAM(KKK),GA(KKK),TAU(KKK),IICH(KKK),IIBAR(KKK), |
| 15707 | C & K1(KKK),K2(KKK) |
| 15708 | C 999 CONTINUE |
| 15709 | C STOP |
| 15710 | DO 30 I=1,210 |
| 15711 | IK1 = K1(I) |
| 15712 | IK2 = K2(I) |
| 15713 | HV = ZERO |
| 15714 | DO 20 J=IK1,IK2 |
| 15715 | HV = HV+WT(J) |
| 15716 | HWT(J) = HV |
| 15717 | **sr 13.1.95 |
| 15718 | IF (HWT(J).GT.1.0001) WRITE(LOUT,1000) HWT(J),J,I,IK1 |
| 15719 | 1000 FORMAT(2X,15H ERROR IN HWT =,1F10.5,8H J,I,K1=,3I5) |
| 15720 | 20 CONTINUE |
| 15721 | 30 CONTINUE |
| 15722 | DO 40 J=1,IDMAX9 |
| 15723 | WT(J) = HWT(J) |
| 15724 | 40 CONTINUE |
| 15725 | |
| 15726 | RETURN |
| 15727 | END |
| 15728 | * |
| 15729 | *===ddatar=============================================================* |
| 15730 | * |
| 15731 | CDECK ID>, DT_DDATAR |
| 15732 | SUBROUTINE DT_DDATAR |
| 15733 | |
| 15734 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 15735 | SAVE |
| 15736 | |
| 15737 | PARAMETER ( LINP = 5 , |
| 15738 | & LOUT = 6 , |
| 15739 | & LDAT = 9 ) |
| 15740 | |
| 15741 | PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0) |
| 15742 | |
| 15743 | * quark-content to particle index conversion (DTUNUC 1.x) |
| 15744 | COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21), |
| 15745 | & IA08(6,21),IA10(6,21) |
| 15746 | |
| 15747 | DIMENSION IV(36),IP(36),IB(126),IBB(126),IA(126),IAA(126) |
| 15748 | |
| 15749 | DATA IV/ 33, 34, 38,123, 0, 0, 32, 33, 39,124, |
| 15750 | & 0, 0, 36, 37, 96,127, 0, 0,126,125, |
| 15751 | & 128,129,14*0/ |
| 15752 | DATA IP/ 23, 14, 16,116, 0, 0, 13, 23, 25,117, |
| 15753 | & 0, 0, 15, 24, 31,120, 0, 0,119,118, |
| 15754 | & 121,122,14*0/ |
| 15755 | DATA IB/ 0, 1, 21,140, 0, 0, 8, 22,137, 0, |
| 15756 | & 0, 97,138, 0, 0,146, 0, 0, 0, 0, |
| 15757 | & 0, 1, 8, 22,137, 0, 0, 0, 20,142, |
| 15758 | & 0, 0, 98,139, 0, 0,147, 0, 0, 0, |
| 15759 | & 0, 0, 21, 22, 97,138, 0, 0, 20, 98, |
| 15760 | & 139, 0, 0, 0,145, 0, 0,148, 0, 0, |
| 15761 | & 0, 0, 0,140,137,138,146, 0, 0,142, |
| 15762 | & 139,147, 0, 0,145,148, 50*0/ |
| 15763 | DATA IBB/53, 54,104,161, 0, 0, 55,105,162, 0, |
| 15764 | & 0,107,164, 0, 0,167, 0, 0, 0, 0, |
| 15765 | & 0, 54, 55,105,162, 0, 0, 56,106,163, |
| 15766 | & 0, 0,108,165, 0, 0,168, 0, 0, 0, |
| 15767 | & 0, 0,104,105,107,164, 0, 0,106,108, |
| 15768 | & 165, 0, 0,109,166, 0, 0,169, 0, 0, |
| 15769 | & 0, 0, 0,161,162,164,167, 0, 0,163, |
| 15770 | & 165,168, 0, 0,166,169, 0, 0,170,47*0/ |
| 15771 | DATA IA/ 0, 2, 99,152, 0, 0, 9,100,149, 0, |
| 15772 | & 0,102,150, 0, 0,158, 0, 0, 0, 0, |
| 15773 | & 0, 2, 9,100,149, 0, 0, 0,101,154, |
| 15774 | & 0, 0,103,151, 0, 0,159, 0, 0, 0, |
| 15775 | & 0, 0, 99,100,102,150, 0, 0,101,103, |
| 15776 | & 151, 0, 0, 0,157, 0, 0,160, 0, 0, |
| 15777 | & 0, 0, 0,152,149,150,158, 0, 0,154, |
| 15778 | & 151,159, 0, 0,157,160, 50*0/ |
| 15779 | DATA IAA/67, 68,110,171, 0, 0, 69,111,172, 0, |
| 15780 | & 0,113,174, 0, 0,177, 0, 0, 0, 0, |
| 15781 | & 0, 68, 69,111,172, 0, 0, 70,112,173, |
| 15782 | & 0, 0,114,175, 0, 0,178, 0, 0, 0, |
| 15783 | & 0, 0,110,111,113,174, 0, 0,112,114, |
| 15784 | & 175, 0, 0,115,176, 0, 0,179, 0, 0, |
| 15785 | & 0, 0, 0,171,172,174,177, 0, 0,173, |
| 15786 | & 175,178, 0, 0,176,179, 0, 0,180,47*0/ |
| 15787 | |
| 15788 | L=0 |
| 15789 | DO 2 I=1,6 |
| 15790 | DO 1 J=1,6 |
| 15791 | L = L+1 |
| 15792 | IMPS(I,J) = IP(L) |
| 15793 | IMVE(I,J) = IV(L) |
| 15794 | 1 CONTINUE |
| 15795 | 2 CONTINUE |
| 15796 | L=0 |
| 15797 | DO 4 I=1,6 |
| 15798 | DO 3 J=1,21 |
| 15799 | L = L+1 |
| 15800 | IB08(I,J) = IB(L) |
| 15801 | IB10(I,J) = IBB(L) |
| 15802 | IA08(I,J) = IA(L) |
| 15803 | IA10(I,J) = IAA(L) |
| 15804 | 3 CONTINUE |
| 15805 | 4 CONTINUE |
| 15806 | C A1 = 0.88D0 |
| 15807 | C B1 = 3.0D0 |
| 15808 | C B2 = 3.0D0 |
| 15809 | C B3 = 8.0D0 |
| 15810 | C LT = 0 |
| 15811 | C LB = 0 |
| 15812 | C BET = 12.0D0 |
| 15813 | C AS = 0.25D0 |
| 15814 | C B8 = 0.33D0 |
| 15815 | C AME = 0.95D0 |
| 15816 | C DIQ = 0.375D0 |
| 15817 | C ISU = 4 |
| 15818 | |
| 15819 | RETURN |
| 15820 | END |
| 15821 | * |
| 15822 | *===initjs=============================================================* |
| 15823 | * |
| 15824 | CDECK ID>, DT_INITJS |
| 15825 | SUBROUTINE DT_INITJS(MODE) |
| 15826 | |
| 15827 | ************************************************************************ |
| 15828 | * Initialize JETSET paramters. * |
| 15829 | * MODE = 0 default settings * |
| 15830 | * = 1 PHOJET settings * |
| 15831 | * = 2 DTUNUC settings * |
| 15832 | * This version dated 16.02.96 is written by S. Roesler * |
| 15833 | ************************************************************************ |
| 15834 | |
| 15835 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 15836 | SAVE |
| 15837 | |
| 15838 | PARAMETER ( LINP = 5 , |
| 15839 | & LOUT = 6 , |
| 15840 | & LDAT = 9 ) |
| 15841 | |
| 15842 | PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0) |
| 15843 | |
| 15844 | LOGICAL LFIRST,LFIRDT,LFIRPH |
| 15845 | |
| 15846 | INCLUDE './flukapro/(DIMPAR)' |
| 15847 | INCLUDE './flukapro/(PART)' |
| 15848 | |
| 15849 | COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) |
| 15850 | |
| 15851 | COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) |
| 15852 | |
| 15853 | COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5) |
| 15854 | |
| 15855 | * flags for particle decays |
| 15856 | COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20), |
| 15857 | & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20), |
| 15858 | & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0 |
| 15859 | * flags for input different options |
| 15860 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 15861 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 15862 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 15863 | |
| 15864 | INTEGER PYCOMP |
| 15865 | |
| 15866 | DIMENSION IDXSTA(40) |
| 15867 | DATA IDXSTA |
| 15868 | * K0s pi0 lam alam sig+ asig+ sig- asig- tet0 atet0 |
| 15869 | & / 310, 111, 3122,-3122, 3222,-3222, 3112,-3112, 3322,-3322, |
| 15870 | * tet- atet- om- aom- D+ D- D0 aD0 Ds+ aDs+ |
| 15871 | & 3312,-3312, 3334,-3334, 411, -411, 421, -421, 431, -431, |
| 15872 | * etac lamc+alamc+sigc++ sigc+ sigc0asigc++asigc+asigc0 Ksic+ |
| 15873 | & 441, 4122,-4122, 4222, 4212, 4112,-4222,-4212,-4112, 4232, |
| 15874 | * Ksic0 aKsic+aKsic0 sig0 asig0 |
| 15875 | & 4132,-4232,-4132, 3212,-3212, 5*0/ |
| 15876 | |
| 15877 | DATA LFIRST,LFIRDT,LFIRPH /.TRUE.,.TRUE.,.TRUE./ |
| 15878 | |
| 15879 | IF (LFIRST) THEN |
| 15880 | * save default settings |
| 15881 | PDEF1 = PARJ(1) |
| 15882 | PDEF2 = PARJ(2) |
| 15883 | PDEF3 = PARJ(3) |
| 15884 | PDEF5 = PARJ(5) |
| 15885 | PDEF6 = PARJ(6) |
| 15886 | PDEF7 = PARJ(7) |
| 15887 | PDEF18 = PARJ(18) |
| 15888 | PDEF19 = PARJ(19) |
| 15889 | PDEF21 = PARJ(21) |
| 15890 | PDEF42 = PARJ(42) |
| 15891 | MDEF12 = MSTJ(12) |
| 15892 | * LUJETS / PYJETS array-dimensions |
| 15893 | |
| 15894 | MSTU(4) = 4000 |
| 15895 | |
| 15896 | * increase maximum number of JETSET-error prints |
| 15897 | MSTU(22) = 50000 |
| 15898 | * prevent particles decaying |
| 15899 | DO 1 I=1,35 |
| 15900 | IF (I.LT.34) THEN |
| 15901 | |
| 15902 | KC = PYCOMP(IDXSTA(I)) |
| 15903 | |
| 15904 | IF (I.EQ.2) THEN |
| 15905 | * pi0 decay |
| 15906 | C MDCY(KC,1) = 1 |
| 15907 | MDCY(KC,1) = 0 |
| 15908 | **cr mode |
| 15909 | C ELSEIF ((I.EQ.4).OR.(I.EQ. 6).OR. |
| 15910 | C & (I.EQ.8).OR.(I.EQ.10)) THEN |
| 15911 | C ELSEIF (I.EQ.4) THEN |
| 15912 | C MDCY(KC,1) = 1 |
| 15913 | ** |
| 15914 | ELSE |
| 15915 | MDCY(KC,1) = 0 |
| 15916 | ENDIF |
| 15917 | ELSEIF (((I.EQ.34).OR.(I.EQ.35)).AND.(ISIG0.EQ.0)) THEN |
| 15918 | |
| 15919 | KC = PYCOMP(IDXSTA(I)) |
| 15920 | |
| 15921 | MDCY(KC,1) = 0 |
| 15922 | ENDIF |
| 15923 | 1 CONTINUE |
| 15924 | * |
| 15925 | |
| 15926 | * as Fluka event-generator: allow only paprop particles to be stable |
| 15927 | * and let all other particles decay (i.e. those with strong decays) |
| 15928 | IF (ITRSPT.EQ.1) THEN |
| 15929 | DO 5 I=1,IDMAXP |
| 15930 | IF (KPTOIP(I).NE.0) THEN |
| 15931 | IDPDG = MPDGHA(I) |
| 15932 | |
| 15933 | KC = PYCOMP(IDPDG) |
| 15934 | |
| 15935 | IF (MDCY(KC,1).EQ.1) THEN |
| 15936 | WRITE(LOUT,*) ' DT_INITJS: Decay flag for FLUKA-', |
| 15937 | & 'transport : particle should not ', |
| 15938 | & 'decay : ',IDPDG,' ',ANAME(I) |
| 15939 | MDCY(KC,1) = 0 |
| 15940 | ENDIF |
| 15941 | ENDIF |
| 15942 | 5 CONTINUE |
| 15943 | DO 6 KC=1,500 |
| 15944 | IDPDG = KCHG(KC,4) |
| 15945 | KP = MCIHAD(IDPDG) |
| 15946 | IF (KP.GT.0) THEN |
| 15947 | IF ((MDCY(KC,1).EQ.0).AND.(KPTOIP(KP).EQ.0).AND. |
| 15948 | & (ANAME(KP).NE.'BLANK ').AND. |
| 15949 | & (ANAME(KP).NE.'RNDFLV ')) THEN |
| 15950 | WRITE(LOUT,*) ' DT_INITJS: Decay flag for FLUKA-', |
| 15951 | & 'transport: particle should decay ', |
| 15952 | & ': ',IDPDG,' ',ANAME(KP) |
| 15953 | MDCY(KC,1) = 1 |
| 15954 | ENDIF |
| 15955 | ENDIF |
| 15956 | 6 CONTINUE |
| 15957 | ENDIF |
| 15958 | |
| 15959 | * |
| 15960 | * popcorn: |
| 15961 | IF (PDB.LE.ZERO) THEN |
| 15962 | * no popcorn-mechanism |
| 15963 | MSTJ(12) = 1 |
| 15964 | ELSE |
| 15965 | MSTJ(12) = 3 |
| 15966 | PARJ(5) = PDB |
| 15967 | ENDIF |
| 15968 | * set JETSET-parameter requested by input cards |
| 15969 | IF (NMSTU.GT.0) THEN |
| 15970 | DO 2 I=1,NMSTU |
| 15971 | MSTU(IMSTU(I)) = MSTUX(I) |
| 15972 | 2 CONTINUE |
| 15973 | ENDIF |
| 15974 | IF (NMSTJ.GT.0) THEN |
| 15975 | DO 3 I=1,NMSTJ |
| 15976 | MSTJ(IMSTJ(I)) = MSTJX(I) |
| 15977 | 3 CONTINUE |
| 15978 | ENDIF |
| 15979 | IF (NPARU.GT.0) THEN |
| 15980 | DO 4 I=1,NPARU |
| 15981 | PARU(IPARU(I)) = PARUX(I) |
| 15982 | 4 CONTINUE |
| 15983 | ENDIF |
| 15984 | LFIRST = .FALSE. |
| 15985 | ENDIF |
| 15986 | * |
| 15987 | * PARJ(1) suppression of qq-aqaq pair prod. compared to |
| 15988 | * q-aq pair prod. (default: 0.1) |
| 15989 | * PARJ(2) strangeness suppression (default: 0.3) |
| 15990 | * PARJ(3) extra suppression of strange diquarks (default: 0.4) |
| 15991 | * PARJ(6) extra suppression of sas-pair shared by B and |
| 15992 | * aB in BMaB (default: 0.5) |
| 15993 | * PARJ(7) extra suppression of strange meson M in BMaB |
| 15994 | * configuration (default: 0.5) |
| 15995 | * PARJ(18) spin 3/2 baryon suppression (default: 1.0) |
| 15996 | * PARJ(21) width sigma in Gaussian p_x, p_y transverse |
| 15997 | * momentum distrib. for prim. hadrons (default: 0.35) |
| 15998 | * PARJ(42) b-parameter for symmetric Lund-fragmentation |
| 15999 | * function (default: 0.9 GeV^-2) |
| 16000 | * |
| 16001 | * PHOJET settings |
| 16002 | IF (MODE.EQ.1) THEN |
| 16003 | * JETSET default |
| 16004 | C PARJ(1) = PDEF1 |
| 16005 | C PARJ(2) = PDEF2 |
| 16006 | C PARJ(3) = PDEF3 |
| 16007 | C PARJ(6) = PDEF6 |
| 16008 | C PARJ(7) = PDEF7 |
| 16009 | C PARJ(18) = PDEF18 |
| 16010 | C PARJ(21) = PDEF21 |
| 16011 | C PARJ(42) = PDEF42 |
| 16012 | **sr 18.11.98 parameter tuning |
| 16013 | C PARJ(1) = 0.092D0 |
| 16014 | C PARJ(2) = 0.25D0 |
| 16015 | C PARJ(3) = 0.45D0 |
| 16016 | C PARJ(19) = 0.3D0 |
| 16017 | C PARJ(21) = 0.45D0 |
| 16018 | C PARJ(42) = 1.0D0 |
| 16019 | **sr 28.04.99 parameter tuning (May 99 minor modifications) |
| 16020 | PARJ(1) = 0.085D0 |
| 16021 | PARJ(2) = 0.26D0 |
| 16022 | PARJ(3) = 0.8D0 |
| 16023 | PARJ(11) = 0.38D0 |
| 16024 | PARJ(18) = 0.3D0 |
| 16025 | PARJ(19) = 0.4D0 |
| 16026 | PARJ(21) = 0.36D0 |
| 16027 | PARJ(41) = 0.3D0 |
| 16028 | PARJ(42) = 0.86D0 |
| 16029 | IF (NPARJ.GT.0) THEN |
| 16030 | DO 10 I=1,NPARJ |
| 16031 | IF (IPARJ(I).GT.0) PARJ(IPARJ(I)) = PARJX(I) |
| 16032 | 10 CONTINUE |
| 16033 | ENDIF |
| 16034 | IF (LFIRPH) THEN |
| 16035 | C *** Commented by Chiara |
| 16036 | C WRITE(LOUT,'(1X,A)') |
| 16037 | C & 'DT_INITJS: JETSET-parameter for PHOJET' |
| 16038 | CALL DT_JSPARA(0) |
| 16039 | LFIRPH = .FALSE. |
| 16040 | ENDIF |
| 16041 | * DTUNUC settings |
| 16042 | ELSEIF (MODE.EQ.2) THEN |
| 16043 | IF (IFRAG(2).EQ.1) THEN |
| 16044 | **sr parameters before 9.3.96 |
| 16045 | C PARJ(2) = 0.27D0 |
| 16046 | C PARJ(3) = 0.6D0 |
| 16047 | C PARJ(6) = 0.75D0 |
| 16048 | C PARJ(7) = 0.75D0 |
| 16049 | C PARJ(21) = 0.55D0 |
| 16050 | C PARJ(42) = 1.3D0 |
| 16051 | **sr 18.11.98 parameter tuning |
| 16052 | C PARJ(1) = 0.05D0 |
| 16053 | C PARJ(2) = 0.27D0 |
| 16054 | C PARJ(3) = 0.4D0 |
| 16055 | C PARJ(19) = 0.2D0 |
| 16056 | C PARJ(21) = 0.45D0 |
| 16057 | C PARJ(42) = 1.0D0 |
| 16058 | **sr 28.04.99 parameter tuning |
| 16059 | PARJ(1) = 0.11D0 |
| 16060 | PARJ(2) = 0.36D0 |
| 16061 | PARJ(3) = 0.8D0 |
| 16062 | PARJ(19) = 0.2D0 |
| 16063 | PARJ(21) = 0.3D0 |
| 16064 | PARJ(41) = 0.3D0 |
| 16065 | PARJ(42) = 0.58D0 |
| 16066 | IF (NPARJ.GT.0) THEN |
| 16067 | DO 20 I=1,NPARJ |
| 16068 | IF (IPARJ(I).LT.0) THEN |
| 16069 | IDX = ABS(IPARJ(I)) |
| 16070 | PARJ(IDX) = PARJX(I) |
| 16071 | ENDIF |
| 16072 | 20 CONTINUE |
| 16073 | ENDIF |
| 16074 | IF (LFIRDT) THEN |
| 16075 | WRITE(LOUT,'(1X,A)') |
| 16076 | & 'DT_INITJS: JETSET-parameter for DTUNUC' |
| 16077 | CALL DT_JSPARA(0) |
| 16078 | LFIRDT = .FALSE. |
| 16079 | ENDIF |
| 16080 | ELSEIF (IFRAG(2).EQ.2) THEN |
| 16081 | PARJ(1) = 0.11D0 |
| 16082 | PARJ(2) = 0.27D0 |
| 16083 | PARJ(3) = 0.3D0 |
| 16084 | PARJ(6) = 0.35D0 |
| 16085 | PARJ(7) = 0.45D0 |
| 16086 | PARJ(18) = 0.66D0 |
| 16087 | C PARJ(21) = 0.55D0 |
| 16088 | C PARJ(42) = 1.0D0 |
| 16089 | PARJ(21) = 0.60D0 |
| 16090 | PARJ(42) = 1.3D0 |
| 16091 | ELSE |
| 16092 | PARJ(1) = PDEF1 |
| 16093 | PARJ(2) = PDEF2 |
| 16094 | PARJ(3) = PDEF3 |
| 16095 | PARJ(6) = PDEF6 |
| 16096 | PARJ(7) = PDEF7 |
| 16097 | PARJ(18) = PDEF18 |
| 16098 | PARJ(21) = PDEF21 |
| 16099 | PARJ(42) = PDEF42 |
| 16100 | ENDIF |
| 16101 | ELSE |
| 16102 | PARJ(1) = PDEF1 |
| 16103 | PARJ(2) = PDEF2 |
| 16104 | PARJ(3) = PDEF3 |
| 16105 | PARJ(5) = PDEF5 |
| 16106 | PARJ(6) = PDEF6 |
| 16107 | PARJ(7) = PDEF7 |
| 16108 | PARJ(18) = PDEF18 |
| 16109 | PARJ(19) = PDEF19 |
| 16110 | PARJ(21) = PDEF21 |
| 16111 | PARJ(42) = PDEF42 |
| 16112 | MSTJ(12) = MDEF12 |
| 16113 | ENDIF |
| 16114 | |
| 16115 | RETURN |
| 16116 | END |
| 16117 | * |
| 16118 | *===jspara=============================================================* |
| 16119 | * |
| 16120 | CDECK ID>, DT_JSPARA |
| 16121 | SUBROUTINE DT_JSPARA(MODE) |
| 16122 | |
| 16123 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 16124 | SAVE |
| 16125 | |
| 16126 | PARAMETER ( LINP = 5 , |
| 16127 | & LOUT = 6 , |
| 16128 | & LDAT = 9 ) |
| 16129 | |
| 16130 | PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1, |
| 16131 | & ONE=1.0D0,ZERO=0.0D0) |
| 16132 | |
| 16133 | LOGICAL LFIRST |
| 16134 | |
| 16135 | COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) |
| 16136 | |
| 16137 | DIMENSION ISTU(200),QARU(200),ISTJ(200),QARJ(200) |
| 16138 | |
| 16139 | DATA LFIRST /.TRUE./ |
| 16140 | |
| 16141 | * save the default JETSET-parameter on the first call |
| 16142 | IF (LFIRST) THEN |
| 16143 | DO 1 I=1,200 |
| 16144 | ISTU(I) = MSTU(I) |
| 16145 | QARU(I) = PARU(I) |
| 16146 | ISTJ(I) = MSTJ(I) |
| 16147 | QARJ(I) = PARJ(I) |
| 16148 | 1 CONTINUE |
| 16149 | LFIRST = .FALSE. |
| 16150 | ENDIF |
| 16151 | |
| 16152 | C *** Commented by Chiara |
| 16153 | C WRITE(LOUT,1000) |
| 16154 | C 1000 FORMAT(1X,'DT_JSPARA: new value (default value)') |
| 16155 | |
| 16156 | * compare the default JETSET-parameter with the present values |
| 16157 | DO 2 I=1,200 |
| 16158 | C *** Commented by Chiara |
| 16159 | C IF ((MSTU(I).NE.ISTU(I)).AND.(I.NE.31)) THEN |
| 16160 | C WRITE(LOUT,1002) 'MSTU(',I,MSTU(I),ISTU(I) |
| 16161 | CC ISTU(I) = MSTU(I) |
| 16162 | C ENDIF |
| 16163 | DIFF = ABS(PARU(I)-QARU(I)) |
| 16164 | C *** Commented by Chiara |
| 16165 | C IF ((DIFF.GE.1.0D-5).AND.(I.NE.21)) THEN |
| 16166 | C WRITE(LOUT,1001) 'PARU(',I,PARU(I),QARU(I) |
| 16167 | CC QARU(I) = PARU(I) |
| 16168 | C ENDIF |
| 16169 | C *** Commented by Chiara |
| 16170 | C IF (MSTJ(I).NE.ISTJ(I)) THEN |
| 16171 | C WRITE(LOUT,1002) 'MSTJ(',I,MSTJ(I),ISTJ(I) |
| 16172 | CC ISTJ(I) = MSTJ(I) |
| 16173 | C ENDIF |
| 16174 | DIFF = ABS(PARJ(I)-QARJ(I)) |
| 16175 | C *** Commented by Chiara |
| 16176 | C IF (DIFF.GE.1.0D-5) THEN |
| 16177 | C WRITE(LOUT,1001) 'PARJ(',I,PARJ(I),QARJ(I) |
| 16178 | CC QARJ(I) = PARJ(I) |
| 16179 | C ENDIF |
| 16180 | 2 CONTINUE |
| 16181 | 1001 FORMAT(12X,A5,I3,'): ',F6.3,' (',F6.3,')') |
| 16182 | 1002 FORMAT(12X,A5,I3,'): ',I6,' (',I6,')') |
| 16183 | |
| 16184 | RETURN |
| 16185 | END |
| 16186 | * |
| 16187 | *===fozoca=============================================================* |
| 16188 | * |
| 16189 | CDECK ID>, DT_FOZOCA |
| 16190 | SUBROUTINE DT_FOZOCA(LFZC,IREJ) |
| 16191 | |
| 16192 | ************************************************************************ |
| 16193 | * This subroutine treats the complete FOrmation ZOne supressed intra- * |
| 16194 | * nuclear CAscade. * |
| 16195 | * LFZC = .true. cascade has been treated * |
| 16196 | * = .false. cascade skipped * |
| 16197 | * This is a completely revised version of the original FOZOKL. * |
| 16198 | * This version dated 18.11.95 is written by S. Roesler * |
| 16199 | ************************************************************************ |
| 16200 | |
| 16201 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 16202 | SAVE |
| 16203 | |
| 16204 | PARAMETER ( LINP = 5 , |
| 16205 | & LOUT = 6 , |
| 16206 | & LDAT = 9 ) |
| 16207 | |
| 16208 | PARAMETER (DLARGE=1.0D10,OHALF=0.5D0,ZERO=0.0D0) |
| 16209 | PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0) |
| 16210 | |
| 16211 | LOGICAL LSTART,LCAS,LFZC |
| 16212 | |
| 16213 | * event history |
| 16214 | |
| 16215 | PARAMETER (NMXHKK=200000) |
| 16216 | |
| 16217 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 16218 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 16219 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 16220 | * extended event history |
| 16221 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 16222 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 16223 | & IHIST(2,NMXHKK) |
| 16224 | * rejection counter |
| 16225 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, |
| 16226 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, |
| 16227 | & IREXCI(3),IRDIFF(2),IRINC |
| 16228 | * properties of interacting particles |
| 16229 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG |
| 16230 | * Glauber formalism: collision properties |
| 16231 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, |
| 16232 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC |
| 16233 | * flags for input different options |
| 16234 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 16235 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 16236 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 16237 | * final state after intranuclear cascade step |
| 16238 | COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC |
| 16239 | * parameter for intranuclear cascade |
| 16240 | LOGICAL LPAULI |
| 16241 | COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI |
| 16242 | |
| 16243 | DIMENSION NCWOUN(2) |
| 16244 | |
| 16245 | DATA LSTART /.TRUE./ |
| 16246 | |
| 16247 | LFZC = .TRUE. |
| 16248 | IREJ = 0 |
| 16249 | |
| 16250 | * skip cascade if hadron-hadron interaction or if supressed by user |
| 16251 | IF (((IP.EQ.1).AND.(IT.EQ.1)).OR.(KTAUGE.LT.1)) GOTO 9999 |
| 16252 | * skip cascade if not all possible chains systems are hadronized |
| 16253 | DO 1 I=1,8 |
| 16254 | IF (.NOT.LHADRO(I)) GOTO 9999 |
| 16255 | 1 CONTINUE |
| 16256 | |
| 16257 | IF (LSTART) THEN |
| 16258 | WRITE(LOUT,1000) KTAUGE,TAUFOR,INCMOD |
| 16259 | 1000 FORMAT(/,1X,'FOZOCA: intranuclear cascade treated for a ', |
| 16260 | & 'maximum of',I4,' generations',/,10X,'formation time ', |
| 16261 | & 'parameter:',F5.1,' fm/c',9X,'modus:',I2) |
| 16262 | IF (ITAUVE.EQ.1) WRITE(LOUT,1001) |
| 16263 | IF (ITAUVE.EQ.2) WRITE(LOUT,1002) |
| 16264 | 1001 FORMAT(10X,'p_t dependent formation zone',/) |
| 16265 | 1002 FORMAT(10X,'constant formation zone',/) |
| 16266 | LSTART = .FALSE. |
| 16267 | ENDIF |
| 16268 | |
| 16269 | * in order to avoid wasting of cpu-time the DTEVT1-indices of nucleons |
| 16270 | * which may interact with final state particles are stored in a seperate |
| 16271 | * array - here all proj./target nucleon-indices (just for simplicity) |
| 16272 | NOINC = 0 |
| 16273 | DO 9 I=1,NPOINT(1)-1 |
| 16274 | NOINC = NOINC+1 |
| 16275 | IDXINC(NOINC) = I |
| 16276 | 9 CONTINUE |
| 16277 | |
| 16278 | * initialize Pauli-principle treatment (find wounded nucleons) |
| 16279 | NWOUND(1) = 0 |
| 16280 | NWOUND(2) = 0 |
| 16281 | NCWOUN(1) = 0 |
| 16282 | NCWOUN(2) = 0 |
| 16283 | DO 2 J=1,NPOINT(1) |
| 16284 | DO 3 I=1,2 |
| 16285 | IF (ISTHKK(J).EQ.10+I) THEN |
| 16286 | NWOUND(I) = NWOUND(I)+1 |
| 16287 | EWOUND(I,NWOUND(I)) = PHKK(4,J) |
| 16288 | IF (IDHKK(J).EQ.2212) NCWOUN(I) = NCWOUN(I)+1 |
| 16289 | ENDIF |
| 16290 | 3 CONTINUE |
| 16291 | 2 CONTINUE |
| 16292 | |
| 16293 | * modify nuclear potential for wounded nucleons |
| 16294 | IPRCL = IP -NWOUND(1) |
| 16295 | IPZRCL = IPZ-NCWOUN(1) |
| 16296 | ITRCL = IT -NWOUND(2) |
| 16297 | ITZRCL = ITZ-NCWOUN(2) |
| 16298 | CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1) |
| 16299 | |
| 16300 | NSTART = NPOINT(4) |
| 16301 | NEND = NHKK |
| 16302 | |
| 16303 | 7 CONTINUE |
| 16304 | DO 8 I=NSTART,NEND |
| 16305 | |
| 16306 | IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDCH(I).LT.KTAUGE)) THEN |
| 16307 | * select nucleus the cascade starts first (proj. - 1, target - -1) |
| 16308 | NCAS = 1 |
| 16309 | * projectile/target with probab. 1/2 |
| 16310 | IF ((INCMOD.EQ.1).OR.(IDCH(I).GT.0)) THEN |
| 16311 | IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS |
| 16312 | * in the nucleus with highest mass |
| 16313 | ELSEIF (INCMOD.EQ.2) THEN |
| 16314 | IF (IP.GT.IT) THEN |
| 16315 | NCAS = -NCAS |
| 16316 | ELSEIF (IP.EQ.IT) THEN |
| 16317 | IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS |
| 16318 | ENDIF |
| 16319 | * the nucleus the cascade starts first is requested to be the one |
| 16320 | * moving in the direction of the secondary |
| 16321 | ELSEIF (INCMOD.EQ.3) THEN |
| 16322 | NCAS = INT(SIGN(1.0D0,PHKK(3,I))) |
| 16323 | ENDIF |
| 16324 | * check that the selected "nucleus" is not a hadron |
| 16325 | IF (((NCAS.EQ. 1).AND.(IP.LE.1)).OR. |
| 16326 | & ((NCAS.EQ.-1).AND.(IT.LE.1))) NCAS = -NCAS |
| 16327 | |
| 16328 | * treat intranuclear cascade in the nucleus selected first |
| 16329 | LCAS = .FALSE. |
| 16330 | CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1) |
| 16331 | IF (IREJ1.NE.0) GOTO 9998 |
| 16332 | * treat intranuclear cascade in the other nucleus if this isn't a had. |
| 16333 | NCAS = -NCAS |
| 16334 | IF (((NCAS.EQ. 1).AND.(IP.GT.1)).OR. |
| 16335 | & ((NCAS.EQ.-1).AND.(IT.GT.1))) THEN |
| 16336 | IF (LCAS) CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1) |
| 16337 | IF (IREJ1.NE.0) GOTO 9998 |
| 16338 | ENDIF |
| 16339 | |
| 16340 | ENDIF |
| 16341 | |
| 16342 | 8 CONTINUE |
| 16343 | NSTART = NEND+1 |
| 16344 | NEND = NHKK |
| 16345 | IF (NSTART.LE.NEND) GOTO 7 |
| 16346 | |
| 16347 | RETURN |
| 16348 | |
| 16349 | 9998 CONTINUE |
| 16350 | * reject this event |
| 16351 | IRINC = IRINC+1 |
| 16352 | IREJ = 1 |
| 16353 | |
| 16354 | 9999 CONTINUE |
| 16355 | * intranucl. cascade not treated because of interaction properties or |
| 16356 | * it is supressed by user or it was rejected or... |
| 16357 | LFZC = .FALSE. |
| 16358 | * reset flag characterizing direction of motion in n-n-cms |
| 16359 | **sr14-11-95 |
| 16360 | C DO 9990 I=NPOINT(5),NHKK |
| 16361 | C IF (ISTHKK(I).EQ.-1) ISTHKK(I)=1 |
| 16362 | C9990 CONTINUE |
| 16363 | |
| 16364 | RETURN |
| 16365 | END |
| 16366 | * |
| 16367 | *===inucas=============================================================* |
| 16368 | * |
| 16369 | CDECK ID>, DT_INUCAS |
| 16370 | SUBROUTINE DT_INUCAS(IT,IP,IDXCAS,LCAS,NCAS,IREJ) |
| 16371 | |
| 16372 | ************************************************************************ |
| 16373 | * Formation zone supressed IntraNUclear CAScade for one final state * |
| 16374 | * particle. * |
| 16375 | * IT, IP mass numbers of target, projectile nuclei * |
| 16376 | * IDXCAS index of final state particle in DTEVT1 * |
| 16377 | * NCAS = 1 intranuclear cascade in projectile * |
| 16378 | * = -1 intranuclear cascade in target * |
| 16379 | * This version dated 18.11.95 is written by S. Roesler * |
| 16380 | ************************************************************************ |
| 16381 | |
| 16382 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 16383 | SAVE |
| 16384 | |
| 16385 | PARAMETER ( LINP = 5 , |
| 16386 | & LOUT = 6 , |
| 16387 | & LDAT = 9 ) |
| 16388 | |
| 16389 | PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10, |
| 16390 | & OHALF=0.5D0,ONE=1.0D0) |
| 16391 | PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0) |
| 16392 | PARAMETER (TWOPI=6.283185307179586454D+00) |
| 16393 | PARAMETER (PLOWH=0.01D0,PHIH=9.0D0) |
| 16394 | |
| 16395 | LOGICAL LABSOR,LCAS |
| 16396 | |
| 16397 | * event history |
| 16398 | |
| 16399 | PARAMETER (NMXHKK=200000) |
| 16400 | |
| 16401 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 16402 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 16403 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 16404 | * extended event history |
| 16405 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 16406 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 16407 | & IHIST(2,NMXHKK) |
| 16408 | * final state after inc step |
| 16409 | PARAMETER (MAXFSP=10) |
| 16410 | COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP |
| 16411 | * flags for input different options |
| 16412 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 16413 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 16414 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 16415 | * particle properties (BAMJET index convention) |
| 16416 | CHARACTER*8 ANAME |
| 16417 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 16418 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 16419 | * Glauber formalism: collision properties |
| 16420 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, |
| 16421 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC |
| 16422 | * nuclear potential |
| 16423 | LOGICAL LFERMI |
| 16424 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, |
| 16425 | & EBINDP(2),EBINDN(2),EPOT(2,210), |
| 16426 | & ETACOU(2),ICOUL,LFERMI |
| 16427 | * parameter for intranuclear cascade |
| 16428 | LOGICAL LPAULI |
| 16429 | COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI |
| 16430 | * final state after intranuclear cascade step |
| 16431 | COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC |
| 16432 | * nucleon-nucleon event-generator |
| 16433 | CHARACTER*8 CMODEL |
| 16434 | LOGICAL LPHOIN |
| 16435 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN |
| 16436 | * statistics: residual nuclei |
| 16437 | COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2), |
| 16438 | & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2), |
| 16439 | & NINCST(2,4),NINCEV(2), |
| 16440 | & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2), |
| 16441 | & NRESPB(2),NRESCH(2),NRESEV(4), |
| 16442 | & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240), |
| 16443 | & NEVAFI(2,2) |
| 16444 | |
| 16445 | DIMENSION PCAS(2,5),PTOCAS(2),COSCAS(2,3),VTXCAS(2,4),VTXCA1(2,4), |
| 16446 | & PCAS1(5),PNUC(5),BGTA(4), |
| 16447 | & BGCAS(2),GACAS(2),BECAS(2), |
| 16448 | & RNUC(2),BIMPC(2),VTXDST(3),IDXSPE(2),IDSPE(2),NWTMP(2) |
| 16449 | |
| 16450 | DATA PDIF /0.545D0/ |
| 16451 | |
| 16452 | IREJ = 0 |
| 16453 | |
| 16454 | * update counter |
| 16455 | IF (NINCEV(1).NE.NEVHKK) THEN |
| 16456 | NINCEV(1) = NEVHKK |
| 16457 | NINCEV(2) = NINCEV(2)+1 |
| 16458 | ENDIF |
| 16459 | |
| 16460 | * "BAMJET-index" of this hadron |
| 16461 | IDCAS = IDBAM(IDXCAS) |
| 16462 | IF (IDT_MCHAD(IDCAS).EQ.-1) RETURN |
| 16463 | |
| 16464 | * skip gammas, electrons, etc.. |
| 16465 | IF (AAM(IDCAS).LT.TINY2) RETURN |
| 16466 | |
| 16467 | * Lorentz-trsf. into projectile rest system |
| 16468 | IF (IP.GT.1) THEN |
| 16469 | CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS), |
| 16470 | & PHKK(4,IDXCAS),PCAS(1,1),PCAS(1,2),PCAS(1,3), |
| 16471 | & PCAS(1,4),IDCAS,-2) |
| 16472 | PTOCAS(1) = SQRT(PCAS(1,1)**2+PCAS(1,2)**2+PCAS(1,3)**2) |
| 16473 | PCAS(1,5) = (PCAS(1,4)-PTOCAS(1))*(PCAS(1,4)+PTOCAS(1)) |
| 16474 | IF (PCAS(1,5).GT.ZERO) THEN |
| 16475 | PCAS(1,5) = SQRT(PCAS(1,5)) |
| 16476 | ELSE |
| 16477 | PCAS(1,5) = AAM(IDCAS) |
| 16478 | ENDIF |
| 16479 | DO 20 K=1,3 |
| 16480 | COSCAS(1,K) = PCAS(1,K)/MAX(PTOCAS(1),TINY10) |
| 16481 | 20 CONTINUE |
| 16482 | * Lorentz-parameters |
| 16483 | * particle rest system --> projectile rest system |
| 16484 | BGCAS(1) = PTOCAS(1)/MAX(PCAS(1,5),TINY10) |
| 16485 | GACAS(1) = PCAS(1,4)/MAX(PCAS(1,5),TINY10) |
| 16486 | BECAS(1) = BGCAS(1)/GACAS(1) |
| 16487 | ELSE |
| 16488 | DO 21 K=1,5 |
| 16489 | PCAS(1,K) = ZERO |
| 16490 | IF (K.LE.3) COSCAS(1,K) = ZERO |
| 16491 | 21 CONTINUE |
| 16492 | PTOCAS(1) = ZERO |
| 16493 | BGCAS(1) = ZERO |
| 16494 | GACAS(1) = ZERO |
| 16495 | BECAS(1) = ZERO |
| 16496 | ENDIF |
| 16497 | * Lorentz-trsf. into target rest system |
| 16498 | IF (IT.GT.1) THEN |
| 16499 | * LEPTO: final state particles are already in target rest frame |
| 16500 | C IF (MCGENE.EQ.3) THEN |
| 16501 | C PCAS(2,1) = PHKK(1,IDXCAS) |
| 16502 | C PCAS(2,2) = PHKK(2,IDXCAS) |
| 16503 | C PCAS(2,3) = PHKK(3,IDXCAS) |
| 16504 | C PCAS(2,4) = PHKK(4,IDXCAS) |
| 16505 | C ELSE |
| 16506 | CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS), |
| 16507 | & PHKK(4,IDXCAS),PCAS(2,1),PCAS(2,2),PCAS(2,3), |
| 16508 | & PCAS(2,4),IDCAS,-3) |
| 16509 | C ENDIF |
| 16510 | PTOCAS(2) = SQRT(PCAS(2,1)**2+PCAS(2,2)**2+PCAS(2,3)**2) |
| 16511 | PCAS(2,5) = (PCAS(2,4)-PTOCAS(2))*(PCAS(2,4)+PTOCAS(2)) |
| 16512 | IF (PCAS(2,5).GT.ZERO) THEN |
| 16513 | PCAS(2,5) = SQRT(PCAS(2,5)) |
| 16514 | ELSE |
| 16515 | PCAS(2,5) = AAM(IDCAS) |
| 16516 | ENDIF |
| 16517 | DO 22 K=1,3 |
| 16518 | COSCAS(2,K) = PCAS(2,K)/MAX(PTOCAS(2),TINY10) |
| 16519 | 22 CONTINUE |
| 16520 | * Lorentz-parameters |
| 16521 | * particle rest system --> target rest system |
| 16522 | BGCAS(2) = PTOCAS(2)/MAX(PCAS(2,5),TINY10) |
| 16523 | GACAS(2) = PCAS(2,4)/MAX(PCAS(2,5),TINY10) |
| 16524 | BECAS(2) = BGCAS(2)/GACAS(2) |
| 16525 | ELSE |
| 16526 | DO 23 K=1,5 |
| 16527 | PCAS(2,K) = ZERO |
| 16528 | IF (K.LE.3) COSCAS(2,K) = ZERO |
| 16529 | 23 CONTINUE |
| 16530 | PTOCAS(2) = ZERO |
| 16531 | BGCAS(2) = ZERO |
| 16532 | GACAS(2) = ZERO |
| 16533 | BECAS(2) = ZERO |
| 16534 | ENDIF |
| 16535 | |
| 16536 | * radii of nuclei (mm) modified by the wall-depth of the Woods-Saxon- |
| 16537 | * potential (see CONUCL) |
| 16538 | RNUC(1) = (RPROJ+4.605D0*PDIF)*FM2MM |
| 16539 | RNUC(2) = (RTARG+4.605D0*PDIF)*FM2MM |
| 16540 | * impact parameter (the projectile moving along z) |
| 16541 | BIMPC(1) = ZERO |
| 16542 | BIMPC(2) = BIMPAC*FM2MM |
| 16543 | |
| 16544 | * get position of initial hadron in projectile/target rest-syst. |
| 16545 | DO 3 K=1,4 |
| 16546 | VTXCAS(1,K) = WHKK(K,IDXCAS) |
| 16547 | VTXCAS(2,K) = VHKK(K,IDXCAS) |
| 16548 | 3 CONTINUE |
| 16549 | |
| 16550 | ICAS = 1 |
| 16551 | I2 = 2 |
| 16552 | IF (NCAS.EQ.-1) THEN |
| 16553 | ICAS = 2 |
| 16554 | I2 = 1 |
| 16555 | ENDIF |
| 16556 | |
| 16557 | IF (PTOCAS(ICAS).LT.TINY10) THEN |
| 16558 | WRITE(LOUT,1000) PTOCAS |
| 16559 | 1000 FORMAT(1X,'INUCAS: warning! zero momentum of initial', |
| 16560 | & ' hadron ',/,20X,2E12.4) |
| 16561 | GOTO 9999 |
| 16562 | ENDIF |
| 16563 | |
| 16564 | * reset spectator flags |
| 16565 | NSPE = 0 |
| 16566 | IDXSPE(1) = 0 |
| 16567 | IDXSPE(2) = 0 |
| 16568 | IDSPE(1) = 0 |
| 16569 | IDSPE(2) = 0 |
| 16570 | |
| 16571 | * formation length (in fm) |
| 16572 | C IF (LCAS) THEN |
| 16573 | C DEL0 = ZERO |
| 16574 | C ELSE |
| 16575 | DEL0 = TAUFOR*BGCAS(ICAS) |
| 16576 | IF (ITAUVE.EQ.1) THEN |
| 16577 | AMT = PCAS(ICAS,1)**2+PCAS(ICAS,2)**2+PCAS(ICAS,5)**2 |
| 16578 | DEL0 = DEL0*PCAS(ICAS,5)**2/AMT |
| 16579 | ENDIF |
| 16580 | C ENDIF |
| 16581 | * sample from exp(-del/del0) |
| 16582 | DEL1 = -DEL0*LOG(MAX(DT_RNDM(DEL0),TINY10)) |
| 16583 | * save formation time |
| 16584 | TAUSA1 = DEL1/BGCAS(ICAS) |
| 16585 | REL1 = TAUSA1*BGCAS(I2) |
| 16586 | |
| 16587 | DEL = DEL1 |
| 16588 | TAUSAM = DEL/BGCAS(ICAS) |
| 16589 | REL = TAUSAM*BGCAS(I2) |
| 16590 | |
| 16591 | * special treatment for negative particles unable to escape |
| 16592 | * nuclear potential (implemented for ap, pi-, K- only) |
| 16593 | LABSOR = .FALSE. |
| 16594 | IF ((IICH(IDCAS).EQ.-1).AND.(IDCAS.LT.20)) THEN |
| 16595 | * threshold energy = nuclear potential + Coulomb potential |
| 16596 | * (nuclear potential for hadron-nucleus interactions only) |
| 16597 | ETHR = AAM(IDCAS)+EPOT(ICAS,IDCAS)+ETACOU(ICAS) |
| 16598 | IF (PCAS(ICAS,4).LT.ETHR) THEN |
| 16599 | DO 4 K=1,5 |
| 16600 | PCAS1(K) = PCAS(ICAS,K) |
| 16601 | 4 CONTINUE |
| 16602 | * "absorb" negative particle in nucleus |
| 16603 | CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,0,IREJ1) |
| 16604 | IF (IREJ1.NE.0) GOTO 9999 |
| 16605 | IF (NSPE.GE.1) LABSOR = .TRUE. |
| 16606 | ENDIF |
| 16607 | ENDIF |
| 16608 | |
| 16609 | * if the initial particle has not been absorbed proceed with |
| 16610 | * "normal" cascade |
| 16611 | IF (.NOT.LABSOR) THEN |
| 16612 | |
| 16613 | * calculate coordinates of hadron at the end of the formation zone |
| 16614 | * transport-time and -step in the rest system where this step is |
| 16615 | * treated |
| 16616 | DSTEP = DEL*FM2MM |
| 16617 | DTIME = DSTEP/BECAS(ICAS) |
| 16618 | RSTEP = REL*FM2MM |
| 16619 | IF ((IP.GT.1).AND.(IT.GT.1)) THEN |
| 16620 | RTIME = RSTEP/BECAS(I2) |
| 16621 | ELSE |
| 16622 | RTIME = ZERO |
| 16623 | ENDIF |
| 16624 | * save step whithout considering the overlapping region |
| 16625 | DSTEP1 = DEL1*FM2MM |
| 16626 | DTIME1 = DSTEP1/BECAS(ICAS) |
| 16627 | RSTEP1 = REL1*FM2MM |
| 16628 | IF ((IP.GT.1).AND.(IT.GT.1)) THEN |
| 16629 | RTIME1 = RSTEP1/BECAS(I2) |
| 16630 | ELSE |
| 16631 | RTIME1 = ZERO |
| 16632 | ENDIF |
| 16633 | * transport to the end of the formation zone in this system |
| 16634 | DO 5 K=1,3 |
| 16635 | VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+DSTEP1*COSCAS(ICAS,K) |
| 16636 | VTXCA1(I2,K) = VTXCAS(I2,K) +RSTEP1*COSCAS(I2,K) |
| 16637 | VTXCAS(ICAS,K) = VTXCAS(ICAS,K)+DSTEP*COSCAS(ICAS,K) |
| 16638 | VTXCAS(I2,K) = VTXCAS(I2,K) +RSTEP*COSCAS(I2,K) |
| 16639 | 5 CONTINUE |
| 16640 | VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME1 |
| 16641 | VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME1 |
| 16642 | VTXCAS(ICAS,4) = VTXCAS(ICAS,4)+DTIME |
| 16643 | VTXCAS(I2,4) = VTXCAS(I2,4) +RTIME |
| 16644 | |
| 16645 | IF ((IP.GT.1).AND.(IT.GT.1)) THEN |
| 16646 | XCAS = VTXCAS(ICAS,1) |
| 16647 | YCAS = VTXCAS(ICAS,2) |
| 16648 | XNCLTA = BIMPAC*FM2MM |
| 16649 | RNCLPR = (RPROJ+RNUCLE)*FM2MM |
| 16650 | RNCLTA = (RTARG+RNUCLE)*FM2MM |
| 16651 | C RNCLPR = (RPROJ+1.605D0*PDIF)*FM2MM |
| 16652 | C RNCLTA = (RTARG+1.605D0*PDIF)*FM2MM |
| 16653 | C RNCLPR = (RPROJ)*FM2MM |
| 16654 | C RNCLTA = (RTARG)*FM2MM |
| 16655 | RCASPR = SQRT( XCAS**2 +YCAS**2) |
| 16656 | RCASTA = SQRT((XCAS-XNCLTA)**2+YCAS**2) |
| 16657 | IF ((RCASPR.LT.RNCLPR).AND.(RCASTA.LT.RNCLTA)) THEN |
| 16658 | IF (IDCH(IDXCAS).EQ.0) NOBAM(IDXCAS) = 3 |
| 16659 | ENDIF |
| 16660 | ENDIF |
| 16661 | |
| 16662 | * check if particle is already outside of the corresp. nucleus |
| 16663 | RDIST = SQRT((VTXCAS(ICAS,1)-BIMPC(ICAS))**2+ |
| 16664 | & VTXCAS(ICAS,2)**2+VTXCAS(ICAS,3)**2) |
| 16665 | IF (RDIST.GE.RNUC(ICAS)) THEN |
| 16666 | * here: IDCH is the generation of the final state part. starting |
| 16667 | * with zero for hadronization products |
| 16668 | * flag particles of generation 0 being outside the nuclei after |
| 16669 | * formation time (to be used for excitation energy calculation) |
| 16670 | IF ((IDCH(IDXCAS).EQ.0).AND.(NOBAM(IDXCAS).LT.3)) |
| 16671 | & NOBAM(IDXCAS) = NOBAM(IDXCAS)+ICAS |
| 16672 | GOTO 9997 |
| 16673 | ENDIF |
| 16674 | DIST = DLARGE |
| 16675 | DISTP = DLARGE |
| 16676 | DISTN = DLARGE |
| 16677 | IDXP = 0 |
| 16678 | IDXN = 0 |
| 16679 | |
| 16680 | * already here: skip particles being outside HADRIN "energy-window" |
| 16681 | * to avoid wasting of time |
| 16682 | NINCHR(ICAS,1) = NINCHR(ICAS,1)+1 |
| 16683 | IF ((PTOCAS(ICAS).LE.PLOWH).OR.(PTOCAS(ICAS).GE.PHIH)) THEN |
| 16684 | NINCHR(ICAS,2) = NINCHR(ICAS,2)+1 |
| 16685 | C WRITE(LOUT,1002) IDXCAS,IDCAS,ICAS,PTOCAS(ICAS),NEVHKK |
| 16686 | C1002 FORMAT(1X,'INUCAS: warning! momentum of particle with ', |
| 16687 | C & 'index ',I5,' (id: ',I3,') ',I3,/,11X,'p_tot = ', |
| 16688 | C & E12.4,', above or below HADRIN-thresholds',I6) |
| 16689 | NSPE = 0 |
| 16690 | GOTO 9997 |
| 16691 | ENDIF |
| 16692 | |
| 16693 | DO 7 IDXHKK=1,NOINC |
| 16694 | I = IDXINC(IDXHKK) |
| 16695 | * scan DTEVT1 for unwounded or excited nucleons |
| 16696 | IF ((ISTHKK(I).EQ.12+ICAS).OR.(ISTHKK(I).EQ.14+ICAS)) THEN |
| 16697 | DO 8 K=1,3 |
| 16698 | IF (ICAS.EQ.1) THEN |
| 16699 | VTXDST(K) = WHKK(K,I)-VTXCAS(1,K) |
| 16700 | ELSEIF (ICAS.EQ.2) THEN |
| 16701 | VTXDST(K) = VHKK(K,I)-VTXCAS(2,K) |
| 16702 | ENDIF |
| 16703 | 8 CONTINUE |
| 16704 | POSNUC = VTXDST(1)*COSCAS(ICAS,1)+ |
| 16705 | & VTXDST(2)*COSCAS(ICAS,2)+ |
| 16706 | & VTXDST(3)*COSCAS(ICAS,3) |
| 16707 | * check if nucleon is situated in forward direction |
| 16708 | IF (POSNUC.GT.ZERO) THEN |
| 16709 | * distance between hadron and this nucleon |
| 16710 | DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+ |
| 16711 | & VTXDST(3)**2) |
| 16712 | * impact parameter |
| 16713 | BIMNU2 = DISTNU**2-POSNUC**2 |
| 16714 | IF (BIMNU2.LT.ZERO) THEN |
| 16715 | WRITE(LOUT,1001) DISTNU,POSNUC,BIMNU2 |
| 16716 | 1001 FORMAT(1X,'INUCAS: warning! inconsistent impact', |
| 16717 | & ' parameter ',/,20X,3E12.4) |
| 16718 | GOTO 7 |
| 16719 | ENDIF |
| 16720 | BIMNU = SQRT(BIMNU2) |
| 16721 | * maximum impact parameter to have interaction |
| 16722 | IDNUC = IDT_ICIHAD(IDHKK(I)) |
| 16723 | IDNUC1 = IDT_MCHAD(IDNUC) |
| 16724 | IDCAS1 = IDT_MCHAD(IDCAS) |
| 16725 | DO 19 K=1,5 |
| 16726 | PCAS1(K) = PCAS(ICAS,K) |
| 16727 | PNUC(K) = PHKK(K,I) |
| 16728 | 19 CONTINUE |
| 16729 | * Lorentz-parameter for trafo into rest-system of target |
| 16730 | DO 18 K=1,4 |
| 16731 | BGTA(K) = PNUC(K)/MAX(PNUC(5),TINY10) |
| 16732 | 18 CONTINUE |
| 16733 | * transformation of projectile into rest-system of target |
| 16734 | CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3), |
| 16735 | & PCAS1(1),PCAS1(2),PCAS1(3),PCAS1(4), |
| 16736 | & PPTOT,PX,PY,PZ,PE) |
| 16737 | ** |
| 16738 | C CALL DT_SIHNIN(IDCAS1,IDNUC1,PPTOT,SIGIN) |
| 16739 | C CALL DT_SIHNEL(IDCAS1,IDNUC1,PPTOT,SIGEL) |
| 16740 | DUMZER = ZERO |
| 16741 | CALL DT_XSHN(IDCAS1,IDNUC1,PPTOT,DUMZER,SIGTOT,SIGEL) |
| 16742 | CALL DT_SIHNAB(IDCAS1,IDNUC1,PPTOT,SIGAB) |
| 16743 | IF (((IDCAS1.EQ.13).OR.(IDCAS1.EQ.14)).AND. |
| 16744 | & (PPTOT.LT.0.15D0)) SIGEL = SIGEL/2.0D0 |
| 16745 | SIGIN = SIGTOT-SIGEL-SIGAB |
| 16746 | C SIGTOT = SIGIN+SIGEL+SIGAB |
| 16747 | ** |
| 16748 | BIMMAX = SQRT(SIGTOT/(5.0D0*TWOPI))*FM2MM |
| 16749 | * check if interaction is possible |
| 16750 | IF (BIMNU.LE.BIMMAX) THEN |
| 16751 | * get nucleon with smallest distance and kind of interaction |
| 16752 | * (elastic/inelastic) |
| 16753 | IF (DISTNU.LT.DIST) THEN |
| 16754 | DIST = DISTNU |
| 16755 | BINT = BIMNU |
| 16756 | IF (IDNUC.NE.IDSPE(1)) THEN |
| 16757 | IDSPE(2) = IDSPE(1) |
| 16758 | IDXSPE(2) = IDXSPE(1) |
| 16759 | IDSPE(1) = IDNUC |
| 16760 | ENDIF |
| 16761 | IDXSPE(1) = I |
| 16762 | NSPE = 1 |
| 16763 | **sr |
| 16764 | SELA = SIGEL |
| 16765 | SABS = SIGAB |
| 16766 | STOT = SIGTOT |
| 16767 | C IF ((IDCAS.EQ.2).OR.(IDCAS.EQ.9)) THEN |
| 16768 | C SELA = SIGEL |
| 16769 | C STOT = SIGIN+SIGEL |
| 16770 | C ELSE |
| 16771 | C SELA = SIGEL+0.75D0*SIGIN |
| 16772 | C STOT = 0.25D0*SIGIN+SELA |
| 16773 | C ENDIF |
| 16774 | ** |
| 16775 | ENDIF |
| 16776 | ENDIf |
| 16777 | ENDIF |
| 16778 | DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+ |
| 16779 | & VTXDST(3)**2) |
| 16780 | IDNUC = IDT_ICIHAD(IDHKK(I)) |
| 16781 | IF (IDNUC.EQ.1) THEN |
| 16782 | IF (DISTNU.LT.DISTP) THEN |
| 16783 | DISTP = DISTNU |
| 16784 | IDXP = I |
| 16785 | POSP = POSNUC |
| 16786 | ENDIF |
| 16787 | ELSEIF (IDNUC.EQ.8) THEN |
| 16788 | IF (DISTNU.LT.DISTN) THEN |
| 16789 | DISTN = DISTNU |
| 16790 | IDXN = I |
| 16791 | POSN = POSNUC |
| 16792 | ENDIF |
| 16793 | ENDIF |
| 16794 | ENDIF |
| 16795 | 7 CONTINUE |
| 16796 | |
| 16797 | * there is no nucleon for a secondary interaction |
| 16798 | IF (NSPE.EQ.0) GOTO 9997 |
| 16799 | |
| 16800 | C IF ((IDCAS.EQ.13).AND.((PCAS(ICAS,4)-PCAS(ICAS,5)).LT.0.1D0)) |
| 16801 | C & WRITE(LOUT,*) STOT,SELA,SABS,IDXSPE |
| 16802 | IF (IDXSPE(2).EQ.0) THEN |
| 16803 | IF ((IDSPE(1).EQ.1).AND.(IDXN.GT.0)) THEN |
| 16804 | C DO 80 K=1,3 |
| 16805 | C IF (ICAS.EQ.1) THEN |
| 16806 | C VTXDST(K) = WHKK(K,IDXN)-WHKK(K,IDXSPE(1)) |
| 16807 | C ELSEIF (ICAS.EQ.2) THEN |
| 16808 | C VTXDST(K) = VHKK(K,IDXN)-VHKK(K,IDXSPE(1)) |
| 16809 | C ENDIF |
| 16810 | C 80 CONTINUE |
| 16811 | C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+ |
| 16812 | C & VTXDST(3)**2) |
| 16813 | C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSN.GT.ZERO)) THEN |
| 16814 | IDXSPE(2) = IDXN |
| 16815 | IDSPE(2) = 8 |
| 16816 | C ELSE |
| 16817 | C STOT = STOT-SABS |
| 16818 | C SABS = ZERO |
| 16819 | C ENDIF |
| 16820 | ELSEIF ((IDSPE(1).EQ.8).AND.(IDXP.GT.0)) THEN |
| 16821 | C DO 81 K=1,3 |
| 16822 | C IF (ICAS.EQ.1) THEN |
| 16823 | C VTXDST(K) = WHKK(K,IDXP)-WHKK(K,IDXSPE(1)) |
| 16824 | C ELSEIF (ICAS.EQ.2) THEN |
| 16825 | C VTXDST(K) = VHKK(K,IDXP)-VHKK(K,IDXSPE(1)) |
| 16826 | C ENDIF |
| 16827 | C 81 CONTINUE |
| 16828 | C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+ |
| 16829 | C & VTXDST(3)**2) |
| 16830 | C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSP.GT.ZERO)) THEN |
| 16831 | IDXSPE(2) = IDXP |
| 16832 | IDSPE(2) = 1 |
| 16833 | C ELSE |
| 16834 | C STOT = STOT-SABS |
| 16835 | C SABS = ZERO |
| 16836 | C ENDIF |
| 16837 | ELSE |
| 16838 | STOT = STOT-SABS |
| 16839 | SABS = ZERO |
| 16840 | ENDIF |
| 16841 | ENDIF |
| 16842 | RR = DT_RNDM(DIST) |
| 16843 | IF (RR.LT.SELA/STOT) THEN |
| 16844 | IPROC = 2 |
| 16845 | ELSEIF ((RR.GE.SELA/STOT).AND.(RR.LT.(SELA+SABS)/STOT)) THEN |
| 16846 | IPROC = 3 |
| 16847 | ELSE |
| 16848 | IPROC = 1 |
| 16849 | ENDIF |
| 16850 | |
| 16851 | DO 9 K=1,5 |
| 16852 | PCAS1(K) = PCAS(ICAS,K) |
| 16853 | PNUC(K) = PHKK(K,IDXSPE(1)) |
| 16854 | 9 CONTINUE |
| 16855 | IF (IPROC.EQ.3) THEN |
| 16856 | * 2-nucleon absorption of pion |
| 16857 | NSPE = 2 |
| 16858 | CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,1,IREJ1) |
| 16859 | IF (IREJ1.NE.0) GOTO 9999 |
| 16860 | IF (NSPE.GE.1) LABSOR = .TRUE. |
| 16861 | ELSE |
| 16862 | * sample secondary interaction |
| 16863 | IDNUC = IDBAM(IDXSPE(1)) |
| 16864 | CALL DT_HADRIN(IDCAS,PCAS1,IDNUC,PNUC,IPROC,IREJ1) |
| 16865 | IF (IREJ1.EQ.1) GOTO 9999 |
| 16866 | IF (IREJ1.GT.1) GOTO 9998 |
| 16867 | ENDIF |
| 16868 | ENDIF |
| 16869 | |
| 16870 | * update arrays to include Pauli-principle |
| 16871 | DO 10 I=1,NSPE |
| 16872 | IF (NWOUND(ICAS).LE.299) THEN |
| 16873 | NWOUND(ICAS) = NWOUND(ICAS)+1 |
| 16874 | EWOUND(ICAS,NWOUND(ICAS)) = PHKK(4,IDXSPE(I)) |
| 16875 | ENDIF |
| 16876 | 10 CONTINUE |
| 16877 | |
| 16878 | * dump initial hadron for energy-momentum conservation check |
| 16879 | IF (LEMCCK) |
| 16880 | & CALL DT_EVTEMC(PCAS(ICAS,1),PCAS(ICAS,2),PCAS(ICAS,3), |
| 16881 | & PCAS(ICAS,4),1,IDUM,IDUM) |
| 16882 | |
| 16883 | * dump final state particles into DTEVT1 |
| 16884 | |
| 16885 | * check if Pauli-principle is fulfilled |
| 16886 | NPAULI = 0 |
| 16887 | NWTMP(1) = NWOUND(1) |
| 16888 | NWTMP(2) = NWOUND(2) |
| 16889 | DO 111 I=1,NFSP |
| 16890 | NPAULI = 0 |
| 16891 | J1 = 2 |
| 16892 | IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR. |
| 16893 | & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1 |
| 16894 | DO 117 J=1,J1 |
| 16895 | IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 117 |
| 16896 | IF (J.EQ.1) THEN |
| 16897 | IDX = ICAS |
| 16898 | PE = PFSP(4,I) |
| 16899 | ELSE |
| 16900 | IDX = I2 |
| 16901 | MODE = 1 |
| 16902 | IF (IDX.EQ.1) MODE = -1 |
| 16903 | CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,MODE) |
| 16904 | ENDIF |
| 16905 | * first check if cascade step is forbidden due to Pauli-principle |
| 16906 | * (in case of absorpion this step is forced) |
| 16907 | IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR. |
| 16908 | & (IDFSP(I).EQ.8))) THEN |
| 16909 | * get nuclear potential barrier |
| 16910 | POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I)) |
| 16911 | IF (IDFSP(I).EQ.1) THEN |
| 16912 | POTLOW = POT-EBINDP(IDX) |
| 16913 | ELSE |
| 16914 | POTLOW = POT-EBINDN(IDX) |
| 16915 | ENDIF |
| 16916 | * final state particle not able to escape nucleus |
| 16917 | IF (PE.LE.POTLOW) THEN |
| 16918 | * check if there are wounded nucleons |
| 16919 | IF ((NWOUND(IDX).GE.1).AND.(PE.GE. |
| 16920 | & EWOUND(IDX,NWOUND(IDX)))) THEN |
| 16921 | NPAULI = NPAULI+1 |
| 16922 | NWOUND(IDX) = NWOUND(IDX)-1 |
| 16923 | ELSE |
| 16924 | * interaction prohibited by Pauli-principle |
| 16925 | NWOUND(1) = NWTMP(1) |
| 16926 | NWOUND(2) = NWTMP(2) |
| 16927 | GOTO 9997 |
| 16928 | ENDIF |
| 16929 | ENDIF |
| 16930 | ENDIF |
| 16931 | 117 CONTINUE |
| 16932 | 111 CONTINUE |
| 16933 | |
| 16934 | NPAULI = 0 |
| 16935 | NWOUND(1) = NWTMP(1) |
| 16936 | NWOUND(2) = NWTMP(2) |
| 16937 | |
| 16938 | DO 11 I=1,NFSP |
| 16939 | |
| 16940 | IST = ISTHKK(IDXCAS) |
| 16941 | |
| 16942 | NPAULI = 0 |
| 16943 | J1 = 2 |
| 16944 | IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR. |
| 16945 | & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1 |
| 16946 | DO 17 J=1,J1 |
| 16947 | IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 17 |
| 16948 | IDX = ICAS |
| 16949 | PE = PFSP(4,I) |
| 16950 | IF (J.EQ.2) THEN |
| 16951 | IDX = I2 |
| 16952 | CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,NCAS) |
| 16953 | ENDIF |
| 16954 | * first check if cascade step is forbidden due to Pauli-principle |
| 16955 | * (in case of absorpion this step is forced) |
| 16956 | IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR. |
| 16957 | & (IDFSP(I).EQ.8))) THEN |
| 16958 | * get nuclear potential barrier |
| 16959 | POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I)) |
| 16960 | IF (IDFSP(I).EQ.1) THEN |
| 16961 | POTLOW = POT-EBINDP(IDX) |
| 16962 | ELSE |
| 16963 | POTLOW = POT-EBINDN(IDX) |
| 16964 | ENDIF |
| 16965 | * final state particle not able to escape nucleus |
| 16966 | IF (PE.LE.POTLOW) THEN |
| 16967 | * check if there are wounded nucleons |
| 16968 | IF ((NWOUND(IDX).GE.1).AND.(PE.GE. |
| 16969 | & EWOUND(IDX,NWOUND(IDX)))) THEN |
| 16970 | NWOUND(IDX) = NWOUND(IDX)-1 |
| 16971 | NPAULI = NPAULI+1 |
| 16972 | IST = 14+IDX |
| 16973 | ELSE |
| 16974 | * interaction prohibited by Pauli-principle |
| 16975 | NWOUND(1) = NWTMP(1) |
| 16976 | NWOUND(2) = NWTMP(2) |
| 16977 | GOTO 9997 |
| 16978 | ENDIF |
| 16979 | **sr |
| 16980 | c ELSEIF (PE.LE.POT) THEN |
| 16981 | cC ELSEIF ((PE.LE.POT).AND.(NWOUND(IDX).GE.1)) THEN |
| 16982 | cC NWOUND(IDX) = NWOUND(IDX)-1 |
| 16983 | c** |
| 16984 | c NPAULI = NPAULI+1 |
| 16985 | c IST = 14+IDX |
| 16986 | ENDIF |
| 16987 | ENDIF |
| 16988 | 17 CONTINUE |
| 16989 | |
| 16990 | * dump final state particles for energy-momentum conservation check |
| 16991 | IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),-PFSP(3,I), |
| 16992 | & -PFSP(4,I),2,IDUM,IDUM) |
| 16993 | |
| 16994 | PX = PFSP(1,I) |
| 16995 | PY = PFSP(2,I) |
| 16996 | PZ = PFSP(3,I) |
| 16997 | PE = PFSP(4,I) |
| 16998 | IF (ABS(IST).EQ.1) THEN |
| 16999 | * transform particles back into n-n cms |
| 17000 | * LEPTO: leave final state particles in target rest frame |
| 17001 | C IF (MCGENE.EQ.3) THEN |
| 17002 | C PFSP(1,I) = PX |
| 17003 | C PFSP(2,I) = PY |
| 17004 | C PFSP(3,I) = PZ |
| 17005 | C PFSP(4,I) = PE |
| 17006 | C ELSE |
| 17007 | IMODE = ICAS+1 |
| 17008 | CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I), |
| 17009 | & PFSP(4,I),IDFSP(I),IMODE) |
| 17010 | C ENDIF |
| 17011 | ELSEIF ((ICAS.EQ.2).AND.(IST.EQ.15)) THEN |
| 17012 | * target cascade but fsp got stuck in proj. --> transform it into |
| 17013 | * proj. rest system |
| 17014 | CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I), |
| 17015 | & PFSP(4,I),IDFSP(I),-1) |
| 17016 | ELSEIF ((ICAS.EQ.1).AND.(IST.EQ.16)) THEN |
| 17017 | * proj. cascade but fsp got stuck in target --> transform it into |
| 17018 | * target rest system |
| 17019 | CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I), |
| 17020 | & PFSP(4,I),IDFSP(I),1) |
| 17021 | ENDIF |
| 17022 | |
| 17023 | * dump final state particles into DTEVT1 |
| 17024 | IGEN = IDCH(IDXCAS)+1 |
| 17025 | ID = IDT_IPDGHA(IDFSP(I)) |
| 17026 | IXR = 0 |
| 17027 | IF (LABSOR) IXR = 99 |
| 17028 | CALL DT_EVTPUT(IST,ID,IDXCAS,IDXSPE(1),PFSP(1,I), |
| 17029 | & PFSP(2,I),PFSP(3,I),PFSP(4,I),0,IXR,IGEN) |
| 17030 | |
| 17031 | * update the counter for particles which got stuck inside the nucleus |
| 17032 | IF ((IST.EQ.15).OR.(IST.EQ.16)) THEN |
| 17033 | NOINC = NOINC+1 |
| 17034 | IDXINC(NOINC) = NHKK |
| 17035 | ENDIF |
| 17036 | IF (LABSOR) THEN |
| 17037 | * in case of absorption the spatial treatment is an approximate |
| 17038 | * solution anyway (the positions of the nucleons which "absorb" the |
| 17039 | * cascade particle are not taken into consideration) therefore the |
| 17040 | * particles are produced at the position of the cascade particle |
| 17041 | DO 12 K=1,4 |
| 17042 | WHKK(K,NHKK) = WHKK(K,IDXCAS) |
| 17043 | VHKK(K,NHKK) = VHKK(K,IDXCAS) |
| 17044 | 12 CONTINUE |
| 17045 | ELSE |
| 17046 | * DDISTL - distance the cascade particle moves to the intera. point |
| 17047 | * (the position where impact-parameter = distance to the interacting |
| 17048 | * nucleon), DIST - distance to the interacting nucleon at the time of |
| 17049 | * formation of the cascade particle, BINT - impact-parameter of this |
| 17050 | * cascade-interaction |
| 17051 | DDISTL = SQRT(DIST**2-BINT**2) |
| 17052 | DTIME = DDISTL/BECAS(ICAS) |
| 17053 | DTIMEL = DDISTL/BGCAS(ICAS) |
| 17054 | RDISTL = DTIMEL*BGCAS(I2) |
| 17055 | IF ((IP.GT.1).AND.(IT.GT.1)) THEN |
| 17056 | RTIME = RDISTL/BECAS(I2) |
| 17057 | ELSE |
| 17058 | RTIME = ZERO |
| 17059 | ENDIF |
| 17060 | * RDISTL, RTIME are this step and time in the rest system of the other |
| 17061 | * nucleus |
| 17062 | DO 13 K=1,3 |
| 17063 | VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+COSCAS(ICAS,K)*DDISTL |
| 17064 | VTXCA1(I2,K) = VTXCAS(I2,K) +COSCAS(I2,K) *RDISTL |
| 17065 | 13 CONTINUE |
| 17066 | VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME |
| 17067 | VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME |
| 17068 | * position of particle production is half the impact-parameter to |
| 17069 | * the interacting nucleon |
| 17070 | DO 14 K=1,3 |
| 17071 | WHKK(K,NHKK) = OHALF*(VTXCA1(1,K)+WHKK(K,IDXSPE(1))) |
| 17072 | VHKK(K,NHKK) = OHALF*(VTXCA1(2,K)+VHKK(K,IDXSPE(1))) |
| 17073 | 14 CONTINUE |
| 17074 | * time of production of secondary = time of interaction |
| 17075 | WHKK(4,NHKK) = VTXCA1(1,4) |
| 17076 | VHKK(4,NHKK) = VTXCA1(2,4) |
| 17077 | ENDIF |
| 17078 | |
| 17079 | 11 CONTINUE |
| 17080 | |
| 17081 | * modify status and position of cascade particle (the latter for |
| 17082 | * statistics reasons only) |
| 17083 | ISTHKK(IDXCAS) = 2 |
| 17084 | IF (LABSOR) ISTHKK(IDXCAS) = 19 |
| 17085 | IF (.NOT.LABSOR) THEN |
| 17086 | DO 15 K=1,4 |
| 17087 | WHKK(K,IDXCAS) = VTXCA1(1,K) |
| 17088 | VHKK(K,IDXCAS) = VTXCA1(2,K) |
| 17089 | 15 CONTINUE |
| 17090 | ENDIF |
| 17091 | |
| 17092 | DO 16 I=1,NSPE |
| 17093 | IS = IDXSPE(I) |
| 17094 | * dump interacting nucleons for energy-momentum conservation check |
| 17095 | IF (LEMCCK) |
| 17096 | & CALL DT_EVTEMC(PHKK(1,IS),PHKK(2,IS),PHKK(3,IS),PHKK(4,IS), |
| 17097 | & 2,IDUM,IDUM) |
| 17098 | * modify entry for interacting nucleons |
| 17099 | IF (ISTHKK(IS).EQ.12+ICAS) ISTHKK(IS)=16+ICAS |
| 17100 | IF (ISTHKK(IS).EQ.14+ICAS) ISTHKK(IS)=2 |
| 17101 | IF (I.GE.2) THEN |
| 17102 | JDAHKK(1,IS) = JDAHKK(1,IDXSPE(1)) |
| 17103 | JDAHKK(2,IS) = JDAHKK(2,IDXSPE(1)) |
| 17104 | ENDIF |
| 17105 | 16 CONTINUE |
| 17106 | |
| 17107 | * check energy-momentum conservation |
| 17108 | IF (LEMCCK) THEN |
| 17109 | CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,500,IREJ1) |
| 17110 | IF (IREJ1.NE.0) GOTO 9999 |
| 17111 | ENDIF |
| 17112 | |
| 17113 | * update counter |
| 17114 | IF (LABSOR) THEN |
| 17115 | NINCCO(ICAS,1) = NINCCO(ICAS,1)+1 |
| 17116 | ELSE |
| 17117 | IF (IPROC.EQ.1) NINCCO(ICAS,2) = NINCCO(ICAS,2)+1 |
| 17118 | IF (IPROC.EQ.2) NINCCO(ICAS,3) = NINCCO(ICAS,3)+1 |
| 17119 | ENDIF |
| 17120 | |
| 17121 | RETURN |
| 17122 | |
| 17123 | 9997 CONTINUE |
| 17124 | 9998 CONTINUE |
| 17125 | * transport-step but no cascade step due to configuration (i.e. there |
| 17126 | * is no nucleon for interaction etc.) |
| 17127 | IF (LCAS) THEN |
| 17128 | DO 100 K=1,4 |
| 17129 | C WHKK(K,IDXCAS) = VTXCAS(1,K) |
| 17130 | C VHKK(K,IDXCAS) = VTXCAS(2,K) |
| 17131 | WHKK(K,IDXCAS) = VTXCA1(1,K) |
| 17132 | VHKK(K,IDXCAS) = VTXCA1(2,K) |
| 17133 | 100 CONTINUE |
| 17134 | ENDIF |
| 17135 | |
| 17136 | C9998 CONTINUE |
| 17137 | * no cascade-step because of configuration |
| 17138 | * (i.e. hadron outside nucleus etc.) |
| 17139 | LCAS = .TRUE. |
| 17140 | RETURN |
| 17141 | |
| 17142 | 9999 CONTINUE |
| 17143 | * rejection |
| 17144 | IREJ = 1 |
| 17145 | RETURN |
| 17146 | END |
| 17147 | * |
| 17148 | *===absorp=============================================================* |
| 17149 | * |
| 17150 | CDECK ID>, DT_ABSORP |
| 17151 | SUBROUTINE DT_ABSORP(IDCAS,PCAS,NCAS,NSPE,IDSPE,IDXSPE,MODE,IREJ) |
| 17152 | |
| 17153 | ************************************************************************ |
| 17154 | * Two-nucleon absorption of antiprotons, pi-, and K-. * |
| 17155 | * Antiproton absorption is handled by HADRIN. * |
| 17156 | * The following channels for meson-absorption are considered: * |
| 17157 | * pi- + p + p ---> n + p * |
| 17158 | * pi- + p + n ---> n + n * |
| 17159 | * K- + p + p ---> sigma+ + n / Lam + p / sigma0 + p * |
| 17160 | * K- + p + n ---> sigma- + n / Lam + n / sigma0 + n * |
| 17161 | * K- + p + p ---> sigma- + n * |
| 17162 | * IDCAS, PCAS identity, momentum of particle to be absorbed * |
| 17163 | * NCAS = 1 intranuclear cascade in projectile * |
| 17164 | * = -1 intranuclear cascade in target * |
| 17165 | * NSPE number of spectator nucleons involved * |
| 17166 | * IDXSPE(2) DTEVT1-indices of spectator nucleons involved * |
| 17167 | * Revised version of the original STOPIK written by HJM and J. Ranft. * |
| 17168 | * This version dated 24.02.95 is written by S. Roesler * |
| 17169 | ************************************************************************ |
| 17170 | |
| 17171 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 17172 | SAVE |
| 17173 | |
| 17174 | PARAMETER ( LINP = 5 , |
| 17175 | & LOUT = 6 , |
| 17176 | & LDAT = 9 ) |
| 17177 | |
| 17178 | PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,ONE=1.0D0, |
| 17179 | & ONETHI=0.3333D0,TWOTHI=0.6666D0) |
| 17180 | |
| 17181 | * event history |
| 17182 | |
| 17183 | PARAMETER (NMXHKK=200000) |
| 17184 | |
| 17185 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 17186 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 17187 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 17188 | * extended event history |
| 17189 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 17190 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 17191 | & IHIST(2,NMXHKK) |
| 17192 | * flags for input different options |
| 17193 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 17194 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 17195 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 17196 | * final state after inc step |
| 17197 | PARAMETER (MAXFSP=10) |
| 17198 | COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP |
| 17199 | * particle properties (BAMJET index convention) |
| 17200 | CHARACTER*8 ANAME |
| 17201 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 17202 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 17203 | |
| 17204 | DIMENSION PCAS(5),IDXSPE(2),IDSPE(2),PSPE(2,5),PSPE1(5), |
| 17205 | & PTOT3P(4),BG3P(4), |
| 17206 | & ECMF(2),PCMF(2),CODF(2),COFF(2),SIFF(2) |
| 17207 | |
| 17208 | IREJ = 0 |
| 17209 | NFSP = 0 |
| 17210 | |
| 17211 | * skip particles others than ap, pi-, K- for mode=0 |
| 17212 | IF ((MODE.EQ.0).AND. |
| 17213 | & (IDCAS.NE.2).AND.(IDCAS.NE.14).AND.(IDCAS.NE.16)) RETURN |
| 17214 | * skip particles others than pions for mode=1 |
| 17215 | * (2-nucleon absorption in intranuclear cascade) |
| 17216 | IF ((MODE.EQ.1).AND. |
| 17217 | & (IDCAS.NE.13).AND.(IDCAS.NE.14).AND.(IDCAS.NE.23)) RETURN |
| 17218 | |
| 17219 | NUCAS = NCAS |
| 17220 | IF (NUCAS.EQ.-1) NUCAS = 2 |
| 17221 | |
| 17222 | IF (MODE.EQ.0) THEN |
| 17223 | * scan spectator nucleons for nucleons being able to "absorb" |
| 17224 | NSPE = 0 |
| 17225 | IDXSPE(1) = 0 |
| 17226 | IDXSPE(2) = 0 |
| 17227 | DO 1 I=1,NHKK |
| 17228 | IF ((ISTHKK(I).EQ.12+NUCAS).OR.(ISTHKK(I).EQ.14+NUCAS)) THEN |
| 17229 | NSPE = NSPE+1 |
| 17230 | IDXSPE(NSPE) = I |
| 17231 | IDSPE(NSPE) = IDBAM(I) |
| 17232 | IF ((NSPE.EQ.1).AND.(IDCAS.EQ.2)) GOTO 2 |
| 17233 | IF (NSPE.EQ.2) THEN |
| 17234 | IF ((IDCAS.EQ.14).AND.(IDSPE(1).EQ.8).AND. |
| 17235 | & (IDSPE(2).EQ.8)) THEN |
| 17236 | * there is no pi-+n+n channel |
| 17237 | NSPE = 1 |
| 17238 | GOTO 1 |
| 17239 | ELSE |
| 17240 | GOTO 2 |
| 17241 | ENDIF |
| 17242 | ENDIF |
| 17243 | ENDIF |
| 17244 | 1 CONTINUE |
| 17245 | |
| 17246 | 2 CONTINUE |
| 17247 | ENDIF |
| 17248 | * transform excited projectile nucleons (status=15) into proj. rest s. |
| 17249 | DO 3 I=1,NSPE |
| 17250 | DO 4 K=1,5 |
| 17251 | PSPE(I,K) = PHKK(K,IDXSPE(I)) |
| 17252 | 4 CONTINUE |
| 17253 | 3 CONTINUE |
| 17254 | |
| 17255 | * antiproton absorption |
| 17256 | IF ((IDCAS.EQ.2).AND.(NSPE.GE.1)) THEN |
| 17257 | DO 5 K=1,5 |
| 17258 | PSPE1(K) = PSPE(1,K) |
| 17259 | 5 CONTINUE |
| 17260 | CALL DT_HADRIN(IDCAS,PCAS,IDSPE(1),PSPE1,1,IREJ1) |
| 17261 | IF (IREJ1.NE.0) GOTO 9999 |
| 17262 | |
| 17263 | * meson absorption |
| 17264 | ELSEIF (((IDCAS.EQ.13).OR.(IDCAS.EQ.14).OR.(IDCAS.EQ.23) |
| 17265 | & .OR.(IDCAS.EQ.16)).AND.(NSPE.GE.2)) THEN |
| 17266 | IF (IDCAS.EQ.14) THEN |
| 17267 | * pi- absorption |
| 17268 | IDFSP(1) = 8 |
| 17269 | IDFSP(2) = 8 |
| 17270 | IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) IDFSP(2) = 1 |
| 17271 | ELSEIF (IDCAS.EQ.13) THEN |
| 17272 | * pi+ absorption |
| 17273 | IDFSP(1) = 1 |
| 17274 | IDFSP(2) = 1 |
| 17275 | IF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) IDFSP(2) = 8 |
| 17276 | ELSEIF (IDCAS.EQ.23) THEN |
| 17277 | * pi0 absorption |
| 17278 | IDFSP(1) = IDSPE(1) |
| 17279 | IDFSP(2) = IDSPE(2) |
| 17280 | ELSEIF (IDCAS.EQ.16) THEN |
| 17281 | * K- absorption |
| 17282 | R = DT_RNDM(PCAS) |
| 17283 | IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) THEN |
| 17284 | IF (R.LT.ONETHI) THEN |
| 17285 | IDFSP(1) = 21 |
| 17286 | IDFSP(2) = 8 |
| 17287 | ELSEIF (R.LT.TWOTHI) THEN |
| 17288 | IDFSP(1) = 17 |
| 17289 | IDFSP(2) = 1 |
| 17290 | ELSE |
| 17291 | IDFSP(1) = 22 |
| 17292 | IDFSP(2) = 1 |
| 17293 | ENDIF |
| 17294 | ELSEIF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) THEN |
| 17295 | IDFSP(1) = 20 |
| 17296 | IDFSP(2) = 8 |
| 17297 | ELSE |
| 17298 | IF (R.LT.ONETHI) THEN |
| 17299 | IDFSP(1) = 20 |
| 17300 | IDFSP(2) = 1 |
| 17301 | ELSEIF (R.LT.TWOTHI) THEN |
| 17302 | IDFSP(1) = 17 |
| 17303 | IDFSP(2) = 8 |
| 17304 | ELSE |
| 17305 | IDFSP(1) = 22 |
| 17306 | IDFSP(2) = 8 |
| 17307 | ENDIF |
| 17308 | ENDIF |
| 17309 | ENDIF |
| 17310 | * dump initial particles for energy-momentum cons. check |
| 17311 | IF (LEMCCK) THEN |
| 17312 | CALL DT_EVTEMC(PCAS(1),PCAS(2),PCAS(3),PCAS(4),1,IDUM,IDUM) |
| 17313 | CALL DT_EVTEMC(PSPE(1,1),PSPE(1,2),PSPE(1,3),PSPE(1,4),2, |
| 17314 | & IDUM,IDUM) |
| 17315 | CALL DT_EVTEMC(PSPE(2,1),PSPE(2,2),PSPE(2,3),PSPE(2,4),2, |
| 17316 | & IDUM,IDUM) |
| 17317 | ENDIF |
| 17318 | * get Lorentz-parameter of 3 particle initial state |
| 17319 | DO 6 K=1,4 |
| 17320 | PTOT3P(K) = PCAS(K)+PSPE(1,K)+PSPE(2,K) |
| 17321 | 6 CONTINUE |
| 17322 | P3P = SQRT(PTOT3P(1)**2+PTOT3P(2)**2+PTOT3P(3)**2) |
| 17323 | AM3P = SQRT( (PTOT3P(4)-P3P)*(PTOT3P(4)+P3P) ) |
| 17324 | DO 7 K=1,4 |
| 17325 | BG3P(K) = PTOT3P(K)/MAX(AM3P,TINY10) |
| 17326 | 7 CONTINUE |
| 17327 | * 2-particle decay of the 3-particle compound system |
| 17328 | CALL DT_DTWOPD(AM3P,ECMF(1),ECMF(2),PCMF(1),PCMF(2), |
| 17329 | & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2), |
| 17330 | & AAM(IDFSP(1)),AAM(IDFSP(2))) |
| 17331 | DO 8 I=1,2 |
| 17332 | SDF = SQRT((ONE-CODF(I))*(ONE+CODF(I))) |
| 17333 | PX = PCMF(I)*COFF(I)*SDF |
| 17334 | PY = PCMF(I)*SIFF(I)*SDF |
| 17335 | PZ = PCMF(I)*CODF(I) |
| 17336 | CALL DT_DALTRA(BG3P(4),BG3P(1),BG3P(2),BG3P(3),PX,PY,PZ, |
| 17337 | & ECMF(I),PTOFSP,PFSP(1,I),PFSP(2,I),PFSP(3,I), |
| 17338 | & PFSP(4,I)) |
| 17339 | PFSP(5,I) = SQRT( (PFSP(4,I)-PTOFSP)*(PFSP(4,I)+PTOFSP) ) |
| 17340 | * check consistency of kinematics |
| 17341 | IF (ABS(AAM(IDFSP(I))-PFSP(5,I)).GT.TINY5) THEN |
| 17342 | WRITE(LOUT,1001) IDFSP(I),AAM(IDFSP(I)),PFSP(5,I) |
| 17343 | 1001 FORMAT(1X,'ABSORP: warning! inconsistent', |
| 17344 | & ' tree-particle kinematics',/,20X,'id: ',I3, |
| 17345 | & ' AAM = ',E10.4,' MFSP = ',E10.4) |
| 17346 | ENDIF |
| 17347 | * dump final state particles for energy-momentum cons. check |
| 17348 | IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I), |
| 17349 | & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM) |
| 17350 | 8 CONTINUE |
| 17351 | NFSP = 2 |
| 17352 | IF (LEMCCK) THEN |
| 17353 | CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,100,IREJ1) |
| 17354 | IF (IREJ1.NE.0) THEN |
| 17355 | WRITE(LOUT,*)'ABSORB: EMC ',AAM(IDFSP(1)),AAM(IDFSP(2)), |
| 17356 | & AM3P |
| 17357 | GOTO 9999 |
| 17358 | ENDIF |
| 17359 | ENDIF |
| 17360 | ELSE |
| 17361 | IF (IOULEV(3).GT.0) WRITE(LOUT,1000) IDCAS,NSPE |
| 17362 | 1000 FORMAT(1X,'ABSORP: warning! absorption for particle ',I3, |
| 17363 | & ' impossible',/,20X,'too few spectators (',I2,')') |
| 17364 | NSPE = 0 |
| 17365 | ENDIF |
| 17366 | |
| 17367 | RETURN |
| 17368 | |
| 17369 | 9999 CONTINUE |
| 17370 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in ABSORP' |
| 17371 | IREJ = 1 |
| 17372 | RETURN |
| 17373 | END |
| 17374 | * |
| 17375 | *===hadrin=============================================================* |
| 17376 | * |
| 17377 | CDECK ID>, DT_HADRIN |
| 17378 | SUBROUTINE DT_HADRIN(IDPR,PPR,IDTA,PTA,MODE,IREJ) |
| 17379 | |
| 17380 | ************************************************************************ |
| 17381 | * Interface to the HADRIN-routines for inelastic and elastic * |
| 17382 | * scattering. * |
| 17383 | * IDPR,PPR(5) identity, momentum of projectile * |
| 17384 | * IDTA,PTA(5) identity, momentum of target * |
| 17385 | * MODE = 1 inelastic interaction * |
| 17386 | * = 2 elastic interaction * |
| 17387 | * Revised version of the original FHAD. * |
| 17388 | * This version dated 27.10.95 is written by S. Roesler * |
| 17389 | ************************************************************************ |
| 17390 | |
| 17391 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 17392 | SAVE |
| 17393 | |
| 17394 | PARAMETER ( LINP = 5 , |
| 17395 | & LOUT = 6 , |
| 17396 | & LDAT = 9 ) |
| 17397 | |
| 17398 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3, |
| 17399 | & TINY2=1.0D-2,TINY1=1.0D-1,ONE=1.0D0) |
| 17400 | |
| 17401 | LOGICAL LCORR,LMSSG |
| 17402 | |
| 17403 | * flags for input different options |
| 17404 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 17405 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 17406 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 17407 | * final state after inc step |
| 17408 | PARAMETER (MAXFSP=10) |
| 17409 | COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP |
| 17410 | * particle properties (BAMJET index convention) |
| 17411 | CHARACTER*8 ANAME |
| 17412 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 17413 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 17414 | * output-common for DHADRI/ELHAIN |
| 17415 | * final state from HADRIN interaction |
| 17416 | PARAMETER (MAXFIN=10) |
| 17417 | COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN), |
| 17418 | & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH |
| 17419 | |
| 17420 | DIMENSION PPR(5),PPR1(5),PTA(5),BGTA(4), |
| 17421 | & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4),IMCORR(2) |
| 17422 | |
| 17423 | DATA LMSSG /.TRUE./ |
| 17424 | |
| 17425 | IREJ = 0 |
| 17426 | NFSP = 0 |
| 17427 | KCORR = 0 |
| 17428 | IMCORR(1) = 0 |
| 17429 | IMCORR(2) = 0 |
| 17430 | LCORR = .FALSE. |
| 17431 | |
| 17432 | * dump initial particles for energy-momentum cons. check |
| 17433 | IF (LEMCCK) THEN |
| 17434 | CALL DT_EVTEMC(PPR(1),PPR(2),PPR(3),PPR(4),1,IDUM,IDUM) |
| 17435 | CALL DT_EVTEMC(PTA(1),PTA(2),PTA(3),PTA(4),2,IDUM,IDUM) |
| 17436 | ENDIF |
| 17437 | |
| 17438 | AMP2 = PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2 |
| 17439 | AMT2 = PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2 |
| 17440 | IF ((AMP2.LT.ZERO).OR.(AMT2.LT.ZERO).OR. |
| 17441 | & (ABS(AMP2-AAM(IDPR)**2).GT.TINY5).OR. |
| 17442 | & (ABS(AMT2-AAM(IDTA)**2).GT.TINY5)) THEN |
| 17443 | IF (LMSSG.AND.(IOULEV(3).GT.0)) |
| 17444 | & WRITE(LOUT,1000) AMP2,AAM(IDPR)**2,AMT2,AAM(IDTA)**2 |
| 17445 | 1000 FORMAT(1X,'HADRIN: warning! inconsistent projectile/target', |
| 17446 | & ' mass',/,20X,'AMP2 = ',E12.4,', AAM(IDPR)**2 = ', |
| 17447 | & E12.4,/,20X,'AMT2 = ',E12.4,', AAM(IDTA)**2 = ',E12.4) |
| 17448 | LMSSG = .FALSE. |
| 17449 | LCORR = .TRUE. |
| 17450 | ENDIF |
| 17451 | |
| 17452 | * convert initial state particles into particles which can be |
| 17453 | * handled by HADRIN |
| 17454 | IDHPR = IDPR |
| 17455 | IDHTA = IDTA |
| 17456 | IF ((IDHPR.LE.0).OR.(IDHPR.GE.111).OR.LCORR) THEN |
| 17457 | IF ((IDHPR.LE.0).OR.(IDHPR.GE.111)) IDHPR = 1 |
| 17458 | DO 1 K=1,4 |
| 17459 | P1IN(K) = PPR(K) |
| 17460 | P2IN(K) = PTA(K) |
| 17461 | 1 CONTINUE |
| 17462 | XM1 = AAM(IDHPR) |
| 17463 | XM2 = AAM(IDHTA) |
| 17464 | CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1) |
| 17465 | IF (IREJ1.GT.0) THEN |
| 17466 | WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.' |
| 17467 | GOTO 9999 |
| 17468 | ENDIF |
| 17469 | DO 2 K=1,4 |
| 17470 | PPR(K) = P1OUT(K) |
| 17471 | PTA(K) = P2OUT(K) |
| 17472 | 2 CONTINUE |
| 17473 | PPR(5) = SQRT(PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2) |
| 17474 | PTA(5) = SQRT(PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2) |
| 17475 | ENDIF |
| 17476 | |
| 17477 | * Lorentz-parameter for trafo into rest-system of target |
| 17478 | DO 3 K=1,4 |
| 17479 | BGTA(K) = PTA(K)/PTA(5) |
| 17480 | 3 CONTINUE |
| 17481 | * transformation of projectile into rest-system of target |
| 17482 | CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),PPR(1),PPR(2), |
| 17483 | & PPR(3),PPR(4),PPRTO1,PPR1(1),PPR1(2),PPR1(3), |
| 17484 | & PPR1(4)) |
| 17485 | |
| 17486 | * direction cosines of projectile in target rest system |
| 17487 | CX = PPR1(1)/PPRTO1 |
| 17488 | CY = PPR1(2)/PPRTO1 |
| 17489 | CZ = PPR1(3)/PPRTO1 |
| 17490 | |
| 17491 | * sample inelastic interaction |
| 17492 | IF (MODE.EQ.1) THEN |
| 17493 | CALL DT_DHADRI(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA) |
| 17494 | IF (IRH.EQ.1) GOTO 9998 |
| 17495 | * sample elastic interaction |
| 17496 | ELSEIF (MODE.EQ.2) THEN |
| 17497 | CALL DT_ELHAIN(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA,IREJ1) |
| 17498 | IF (IREJ1.NE.0) THEN |
| 17499 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in HADRIN' |
| 17500 | GOTO 9999 |
| 17501 | ENDIF |
| 17502 | IF (IRH.EQ.1) GOTO 9998 |
| 17503 | ELSE |
| 17504 | WRITE(LOUT,1001) MODE,INTHAD |
| 17505 | 1001 FORMAT(1X,'HADRIN: warning! inconsistent interaction mode', |
| 17506 | & I4,' (INTHAD =',I4,')') |
| 17507 | GOTO 9999 |
| 17508 | ENDIF |
| 17509 | |
| 17510 | * transform final state particles back into Lab. |
| 17511 | DO 4 I=1,IRH |
| 17512 | NFSP = NFSP+1 |
| 17513 | PX = CXRH(I)*PLRH(I) |
| 17514 | PY = CYRH(I)*PLRH(I) |
| 17515 | PZ = CZRH(I)*PLRH(I) |
| 17516 | CALL DT_DALTRA(BGTA(4),BGTA(1),BGTA(2),BGTA(3), |
| 17517 | & PX,PY,PZ,ELRH(I),PTOFSP,PFSP(1,NFSP), |
| 17518 | & PFSP(2,NFSP),PFSP(3,NFSP),PFSP(4,NFSP)) |
| 17519 | IDFSP(NFSP) = ITRH(I) |
| 17520 | AMFSP2 = PFSP(4,NFSP)**2-PFSP(1,NFSP)**2-PFSP(2,NFSP)**2- |
| 17521 | & PFSP(3,NFSP)**2 |
| 17522 | IF (AMFSP2.LT.-TINY3) THEN |
| 17523 | WRITE(LOUT,1002) IDFSP(NFSP),PFSP(1,NFSP),PFSP(2,NFSP), |
| 17524 | & PFSP(3,NFSP),PFSP(4,NFSP),AMFSP2 |
| 17525 | 1002 FORMAT(1X,'HADRIN: warning! final state particle (id = ', |
| 17526 | & I2,') with negative mass^2',/,1X,5E12.4) |
| 17527 | GOTO 9999 |
| 17528 | ELSE |
| 17529 | PFSP(5,NFSP) = SQRT(ABS(AMFSP2)) |
| 17530 | IF (ABS(PFSP(5,NFSP)-AAM(IDFSP(NFSP))).GT.TINY1) THEN |
| 17531 | WRITE(LOUT,1003) IDFSP(NFSP),AAM(IDFSP(NFSP)), |
| 17532 | & PFSP(5,NFSP) |
| 17533 | 1003 FORMAT(1X,'HADRIN: warning! final state particle', |
| 17534 | & ' (id = ',I2,') with inconsistent mass',/,1X, |
| 17535 | & 2E12.4) |
| 17536 | KCORR = KCORR+1 |
| 17537 | IF (KCORR.GT.2) GOTO 9999 |
| 17538 | IMCORR(KCORR) = NFSP |
| 17539 | ENDIF |
| 17540 | ENDIF |
| 17541 | * dump final state particles for energy-momentum cons. check |
| 17542 | IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I), |
| 17543 | & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM) |
| 17544 | 4 CONTINUE |
| 17545 | |
| 17546 | * transform momenta on mass shell in case of inconsistencies in |
| 17547 | * HADRIN |
| 17548 | IF (KCORR.GT.0) THEN |
| 17549 | IF (KCORR.EQ.2) THEN |
| 17550 | I1 = IMCORR(1) |
| 17551 | I2 = IMCORR(2) |
| 17552 | ELSE |
| 17553 | IF (IMCORR(1).EQ.1) THEN |
| 17554 | I1 = 1 |
| 17555 | I2 = 2 |
| 17556 | ELSE |
| 17557 | I1 = 1 |
| 17558 | I2 = IMCORR(1) |
| 17559 | ENDIF |
| 17560 | ENDIF |
| 17561 | IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I1),PFSP(2,I1), |
| 17562 | & PFSP(3,I1),PFSP(4,I1),2,IDUM,IDUM) |
| 17563 | IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I2),PFSP(2,I2), |
| 17564 | & PFSP(3,I2),PFSP(4,I2),2,IDUM,IDUM) |
| 17565 | DO 5 K=1,4 |
| 17566 | P1IN(K) = PFSP(K,I1) |
| 17567 | P2IN(K) = PFSP(K,I2) |
| 17568 | 5 CONTINUE |
| 17569 | XM1 = AAM(IDFSP(I1)) |
| 17570 | XM2 = AAM(IDFSP(I2)) |
| 17571 | CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1) |
| 17572 | IF (IREJ1.GT.0) THEN |
| 17573 | WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.' |
| 17574 | C GOTO 9999 |
| 17575 | ENDIF |
| 17576 | DO 6 K=1,4 |
| 17577 | PFSP(K,I1) = P1OUT(K) |
| 17578 | PFSP(K,I2) = P2OUT(K) |
| 17579 | 6 CONTINUE |
| 17580 | PFSP(5,I1) = SQRT(PFSP(4,I1)**2-PFSP(1,I1)**2 |
| 17581 | & -PFSP(2,I1)**2-PFSP(3,I1)**2) |
| 17582 | PFSP(5,I2) = SQRT(PFSP(4,I2)**2-PFSP(1,I2)**2 |
| 17583 | & -PFSP(2,I2)**2-PFSP(3,I2)**2) |
| 17584 | * dump final state particles for energy-momentum cons. check |
| 17585 | IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I1),-PFSP(2,I1), |
| 17586 | & -PFSP(3,I1),-PFSP(4,I1),2,IDUM,IDUM) |
| 17587 | IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I2),-PFSP(2,I2), |
| 17588 | & -PFSP(3,I2),-PFSP(4,I2),2,IDUM,IDUM) |
| 17589 | ENDIF |
| 17590 | |
| 17591 | * check energy-momentum conservation |
| 17592 | IF (LEMCCK) THEN |
| 17593 | CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,102,IREJ1) |
| 17594 | IF (IREJ1.NE.0) GOTO 9999 |
| 17595 | ENDIF |
| 17596 | |
| 17597 | RETURN |
| 17598 | |
| 17599 | 9998 CONTINUE |
| 17600 | IREJ = 2 |
| 17601 | RETURN |
| 17602 | |
| 17603 | 9999 CONTINUE |
| 17604 | IREJ = 1 |
| 17605 | RETURN |
| 17606 | END |
| 17607 | * |
| 17608 | *===hadcol=============================================================* |
| 17609 | * |
| 17610 | CDECK ID>, DT_HADCOL |
| 17611 | SUBROUTINE DT_HADCOL(IDPROJ,PPN,IDXTAR,IREJ) |
| 17612 | |
| 17613 | ************************************************************************ |
| 17614 | * Interface to the HADRIN-routines for inelastic and elastic * |
| 17615 | * scattering. This subroutine samples hadron-nucleus interactions * |
| 17616 | * below DPM-threshold. * |
| 17617 | * IDPROJ BAMJET-index of projectile hadron * |
| 17618 | * PPN projectile momentum in target rest frame * |
| 17619 | * IDXTAR DTEVT1-index of target nucleon undergoing * |
| 17620 | * interaction with projectile hadron * |
| 17621 | * This subroutine replaces HADHAD. * |
| 17622 | * This version dated 5.5.95 is written by S. Roesler * |
| 17623 | ************************************************************************ |
| 17624 | |
| 17625 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 17626 | SAVE |
| 17627 | |
| 17628 | PARAMETER ( LINP = 5 , |
| 17629 | & LOUT = 6 , |
| 17630 | & LDAT = 9 ) |
| 17631 | |
| 17632 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0) |
| 17633 | |
| 17634 | LOGICAL LSTART |
| 17635 | |
| 17636 | * event history |
| 17637 | |
| 17638 | PARAMETER (NMXHKK=200000) |
| 17639 | |
| 17640 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 17641 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 17642 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 17643 | * extended event history |
| 17644 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 17645 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 17646 | & IHIST(2,NMXHKK) |
| 17647 | * nuclear potential |
| 17648 | LOGICAL LFERMI |
| 17649 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, |
| 17650 | & EBINDP(2),EBINDN(2),EPOT(2,210), |
| 17651 | & ETACOU(2),ICOUL,LFERMI |
| 17652 | * interface HADRIN-DPM |
| 17653 | COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA |
| 17654 | * parameter for intranuclear cascade |
| 17655 | LOGICAL LPAULI |
| 17656 | COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI |
| 17657 | * final state after inc step |
| 17658 | PARAMETER (MAXFSP=10) |
| 17659 | COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP |
| 17660 | * particle properties (BAMJET index convention) |
| 17661 | CHARACTER*8 ANAME |
| 17662 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 17663 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 17664 | |
| 17665 | DIMENSION PPROJ(5),PNUC(5) |
| 17666 | |
| 17667 | DATA LSTART /.TRUE./ |
| 17668 | |
| 17669 | IREJ = 0 |
| 17670 | |
| 17671 | NPOINT(1) = NHKK+1 |
| 17672 | |
| 17673 | TAUSAV = TAUFOR |
| 17674 | **sr 6/9/01 commented |
| 17675 | C TAUFOR = TAUFOR/2.0D0 |
| 17676 | ** |
| 17677 | IF (LSTART) THEN |
| 17678 | WRITE(LOUT,1000) |
| 17679 | 1000 FORMAT(/,1X,'HADCOL: Scattering handled by HADRIN') |
| 17680 | WRITE(LOUT,1001) TAUFOR |
| 17681 | 1001 FORMAT(/,1X,'HADCOL: Formation zone parameter set to ', |
| 17682 | & F5.1,' fm/c') |
| 17683 | LSTART = .FALSE. |
| 17684 | ENDIF |
| 17685 | |
| 17686 | IDNUC = IDBAM(IDXTAR) |
| 17687 | IDNUC1 = IDT_MCHAD(IDNUC) |
| 17688 | IDPRO1 = IDT_MCHAD(IDPROJ) |
| 17689 | |
| 17690 | IF ((INTHAD.EQ.1).OR.(INTHAD.EQ.2)) THEN |
| 17691 | IPROC = INTHAD |
| 17692 | ELSE |
| 17693 | ** |
| 17694 | C CALL DT_SIHNIN(IDPRO1,IDNUC1,PPN,SIGIN) |
| 17695 | C CALL DT_SIHNEL(IDPRO1,IDNUC1,PPN,SIGEL) |
| 17696 | DUMZER = ZERO |
| 17697 | CALL DT_XSHN(IDPRO1,IDNUC1,PPN,DUMZER,SIGTOT,SIGEL) |
| 17698 | SIGIN = SIGTOT-SIGEL |
| 17699 | C SIGTOT = SIGIN+SIGEL |
| 17700 | ** |
| 17701 | IPROC = 1 |
| 17702 | IF (DT_RNDM(SIGIN).LT.SIGEL/SIGTOT) IPROC = 2 |
| 17703 | ENDIF |
| 17704 | |
| 17705 | PPROJ(1) = ZERO |
| 17706 | PPROJ(2) = ZERO |
| 17707 | PPROJ(3) = PPN |
| 17708 | PPROJ(5) = AAM(IDPROJ) |
| 17709 | PPROJ(4) = SQRT(PPROJ(5)**2+PPROJ(3)**2) |
| 17710 | DO 1 K=1,5 |
| 17711 | PNUC(K) = PHKK(K,IDXTAR) |
| 17712 | 1 CONTINUE |
| 17713 | |
| 17714 | ILOOP = 0 |
| 17715 | 2 CONTINUE |
| 17716 | ILOOP = ILOOP+1 |
| 17717 | IF (ILOOP.GT.100) GOTO 9999 |
| 17718 | |
| 17719 | CALL DT_HADRIN(IDPROJ,PPROJ,IDNUC,PNUC,IPROC,IREJ1) |
| 17720 | IF (IREJ1.EQ.1) GOTO 9999 |
| 17721 | |
| 17722 | IF (IREJ1.GT.1) THEN |
| 17723 | * no interaction possible |
| 17724 | * require Pauli blocking |
| 17725 | IF ((IDPROJ.EQ.1).AND.(PPROJ(4).LE.PFERMP(2)+PPROJ(5))) GOTO 2 |
| 17726 | IF ((IDPROJ.EQ.8).AND.(PPROJ(4).LE.PFERMN(2)+PPROJ(5))) GOTO 2 |
| 17727 | IF ((IIBAR(IDPROJ).NE.1).AND. |
| 17728 | & (PPROJ(4).LE.EPOT(2,IDPROJ)+PPROJ(5))) GOTO 2 |
| 17729 | * store incoming particle as final state particle |
| 17730 | CALL DT_LTNUC(PPROJ(3),PPROJ(4),PCMS,ECMS,3) |
| 17731 | CALL DT_EVTPUT(1,IDPROJ,1,0,PPROJ(1),PPROJ(2),PCMS,ECMS,0,0,0) |
| 17732 | NPOINT(4) = NHKK |
| 17733 | ELSE |
| 17734 | * require Pauli blocking for final state nucleons |
| 17735 | DO 4 I=1,NFSP |
| 17736 | IF ((IDFSP(I).EQ.1).AND. |
| 17737 | & (PFSP(4,I).LE.PFERMP(2)+AAM(IDFSP(I)))) GOTO 2 |
| 17738 | IF ((IDFSP(I).EQ.8).AND. |
| 17739 | & (PFSP(4,I).LE.PFERMN(2)+AAM(IDFSP(I)))) GOTO 2 |
| 17740 | IF ((IIBAR(IDFSP(I)).NE.1).AND. |
| 17741 | & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I))))GOTO 2 |
| 17742 | 4 CONTINUE |
| 17743 | * store final state particles |
| 17744 | DO 5 I=1,NFSP |
| 17745 | IST = 1 |
| 17746 | IF ((IIBAR(IDFSP(I)).EQ.1).AND. |
| 17747 | & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I)))) IST = 16 |
| 17748 | IDHAD = IDT_IPDGHA(IDFSP(I)) |
| 17749 | CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PCMS,ECMS,3) |
| 17750 | CALL DT_EVTPUT(IST,IDHAD,1,IDXTAR,PFSP(1,I),PFSP(2,I), |
| 17751 | & PCMS,ECMS,0,0,0) |
| 17752 | IF (I.EQ.1) NPOINT(4) = NHKK |
| 17753 | VHKK(1,NHKK) = 0.5D0*(VHKK(1,1)+VHKK(1,IDXTAR)) |
| 17754 | VHKK(2,NHKK) = 0.5D0*(VHKK(2,1)+VHKK(2,IDXTAR)) |
| 17755 | VHKK(3,NHKK) = VHKK(3,IDXTAR) |
| 17756 | VHKK(4,NHKK) = VHKK(4,IDXTAR) |
| 17757 | WHKK(1,NHKK) = 0.5D0*(WHKK(1,1)+WHKK(1,IDXTAR)) |
| 17758 | WHKK(2,NHKK) = 0.5D0*(WHKK(2,1)+WHKK(2,IDXTAR)) |
| 17759 | WHKK(3,NHKK) = WHKK(3,1) |
| 17760 | WHKK(4,NHKK) = WHKK(4,1) |
| 17761 | 5 CONTINUE |
| 17762 | ENDIF |
| 17763 | TAUFOR = TAUSAV |
| 17764 | RETURN |
| 17765 | |
| 17766 | 9999 CONTINUE |
| 17767 | IREJ = 1 |
| 17768 | TAUFOR = TAUSAV |
| 17769 | RETURN |
| 17770 | END |
| 17771 | * |
| 17772 | *===getemu=============================================================* |
| 17773 | * |
| 17774 | CDECK ID>, DT_GETEMU |
| 17775 | SUBROUTINE DT_GETEMU(IT,ITZ,KKMAT,MODE) |
| 17776 | |
| 17777 | ************************************************************************ |
| 17778 | * Sampling of emulsion component to be considered as target-nucleus. * |
| 17779 | * This version dated 6.5.95 is written by S. Roesler. * |
| 17780 | ************************************************************************ |
| 17781 | |
| 17782 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 17783 | SAVE |
| 17784 | |
| 17785 | PARAMETER ( LINP = 5 , |
| 17786 | & LOUT = 6 , |
| 17787 | & LDAT = 9 ) |
| 17788 | |
| 17789 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10) |
| 17790 | |
| 17791 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 17792 | |
| 17793 | * emulsion treatment |
| 17794 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), |
| 17795 | & NCOMPO,IEMUL |
| 17796 | * Glauber formalism: flags and parameters for statistics |
| 17797 | LOGICAL LPROD |
| 17798 | CHARACTER*8 CGLB |
| 17799 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD |
| 17800 | |
| 17801 | IF (MODE.EQ.0) THEN |
| 17802 | SUMFRA = ZERO |
| 17803 | RR = DT_RNDM(SUMFRA) |
| 17804 | IT = 0 |
| 17805 | ITZ = 0 |
| 17806 | DO 1 ICOMP=1,NCOMPO |
| 17807 | SUMFRA = SUMFRA+EMUFRA(ICOMP) |
| 17808 | IF (SUMFRA.GT.RR) THEN |
| 17809 | IT = IEMUMA(ICOMP) |
| 17810 | ITZ = IEMUCH(ICOMP) |
| 17811 | KKMAT = ICOMP |
| 17812 | GOTO 2 |
| 17813 | ENDIF |
| 17814 | 1 CONTINUE |
| 17815 | 2 CONTINUE |
| 17816 | IF (IT.LE.0) THEN |
| 17817 | WRITE(LOUT,'(1X,A,E12.3)') |
| 17818 | & 'Warning! norm. failure within emulsion fractions', |
| 17819 | & SUMFRA |
| 17820 | STOP |
| 17821 | ENDIF |
| 17822 | ELSEIF (MODE.EQ.1) THEN |
| 17823 | NDIFF = 10000 |
| 17824 | DO 3 I=1,NCOMPO |
| 17825 | IDIFF = ABS(IT-IEMUMA(I)) |
| 17826 | IF (IDIFF.LT.NDIFF) THEN |
| 17827 | KKMAT = I |
| 17828 | NDIFF = IDIFF |
| 17829 | ENDIF |
| 17830 | 3 CONTINUE |
| 17831 | ELSE |
| 17832 | STOP 'DT_GETEMU' |
| 17833 | ENDIF |
| 17834 | |
| 17835 | * bypass for variable projectile/target/energy runs: the correct |
| 17836 | * Glauber data will be always loaded on kkmat=1 |
| 17837 | IF (IOGLB.EQ.100) THEN |
| 17838 | KKMAT = 1 |
| 17839 | ENDIF |
| 17840 | |
| 17841 | RETURN |
| 17842 | END |
| 17843 | * |
| 17844 | *===nclpot=============================================================* |
| 17845 | * |
| 17846 | CDECK ID>, DT_NCLPOT |
| 17847 | SUBROUTINE DT_NCLPOT(IPZ,IP,ITZ,IT,AFERP,AFERT,MODE) |
| 17848 | |
| 17849 | ************************************************************************ |
| 17850 | * Calculation of Coulomb and nuclear potential for a given configurat. * |
| 17851 | * IPZ, IP charge/mass number of proj. * |
| 17852 | * ITZ, IT charge/mass number of targ. * |
| 17853 | * AFERP,AFERT factors modifying proj./target pot. * |
| 17854 | * if =0, FERMOD is used * |
| 17855 | * MODE = 0 calculation of binding energy * |
| 17856 | * = 1 pre-calculated binding energy is used * |
| 17857 | * This version dated 16.11.95 is written by S. Roesler. * |
| 17858 | ************************************************************************ |
| 17859 | |
| 17860 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 17861 | SAVE |
| 17862 | |
| 17863 | PARAMETER ( LINP = 5 , |
| 17864 | & LOUT = 6 , |
| 17865 | & LDAT = 9 ) |
| 17866 | |
| 17867 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2, |
| 17868 | & TINY10=1.0D-10) |
| 17869 | |
| 17870 | LOGICAL LSTART |
| 17871 | |
| 17872 | * particle properties (BAMJET index convention) |
| 17873 | CHARACTER*8 ANAME |
| 17874 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 17875 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 17876 | * nuclear potential |
| 17877 | LOGICAL LFERMI |
| 17878 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, |
| 17879 | & EBINDP(2),EBINDN(2),EPOT(2,210), |
| 17880 | & ETACOU(2),ICOUL,LFERMI |
| 17881 | |
| 17882 | DIMENSION IDXPOT(14) |
| 17883 | * ap an lam alam sig- sig+ sig0 tet0 tet- asig- |
| 17884 | DATA IDXPOT / 2, 9, 17, 18, 20, 21, 22, 97, 98, 99, |
| 17885 | * asig0 asig+ atet0 atet+ |
| 17886 | & 100, 101, 102, 103/ |
| 17887 | |
| 17888 | DATA AN /0.4D0/ |
| 17889 | DATA LSTART /.TRUE./ |
| 17890 | |
| 17891 | IF (MODE.EQ.0) THEN |
| 17892 | EBINDP(1) = ZERO |
| 17893 | EBINDN(1) = ZERO |
| 17894 | EBINDP(2) = ZERO |
| 17895 | EBINDN(2) = ZERO |
| 17896 | ENDIF |
| 17897 | AIP = DBLE(IP) |
| 17898 | AIPZ = DBLE(IPZ) |
| 17899 | AIT = DBLE(IT) |
| 17900 | AITZ = DBLE(ITZ) |
| 17901 | |
| 17902 | FERMIP = AFERP |
| 17903 | IF (AFERP.LE.ZERO) FERMIP = FERMOD |
| 17904 | FERMIT = AFERT |
| 17905 | IF (AFERT.LE.ZERO) FERMIT = FERMOD |
| 17906 | |
| 17907 | * Fermi momenta and binding energy for projectile |
| 17908 | IF ((IP.GT.1).AND.LFERMI) THEN |
| 17909 | IF (MODE.EQ.0) THEN |
| 17910 | C EBINDP(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ-1) |
| 17911 | C EBINDN(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ) |
| 17912 | BIP = AIP -ONE |
| 17913 | BIPZ = AIPZ-ONE |
| 17914 | |
| 17915 | EBINDP(1) = 1.0D-3*ABS(ENERGY(AIP,AIPZ) |
| 17916 | & -ENERGY(BIP,BIPZ)) |
| 17917 | |
| 17918 | IF (AIP.LE.AIPZ) THEN |
| 17919 | EBINDN(1) = EBINDP(1) |
| 17920 | WRITE(LOUT,*) ' DT_NCLPOT: AIP.LE.AIPZ (',AIP,AIPZ,')' |
| 17921 | ELSE |
| 17922 | |
| 17923 | EBINDN(1) = 1.0D-3*ABS(ENERGY(AIP,AIPZ) |
| 17924 | & -ENERGY(BIP,AIPZ)) |
| 17925 | |
| 17926 | ENDIF |
| 17927 | ENDIF |
| 17928 | PFERMP(1) = FERMIP*AN*(AIPZ/AIP)**0.333333D0 |
| 17929 | PFERMN(1) = FERMIP*AN*((AIP-AIPZ)/AIP)**0.33333D0 |
| 17930 | ELSE |
| 17931 | PFERMP(1) = ZERO |
| 17932 | PFERMN(1) = ZERO |
| 17933 | ENDIF |
| 17934 | * effective nuclear potential for projectile |
| 17935 | C EPOT(1,1) = PFERMP(1)**2/(2.0D0*AAM(1)) + EBINDP(1) |
| 17936 | C EPOT(1,8) = PFERMN(1)**2/(2.0D0*AAM(8)) + EBINDN(1) |
| 17937 | EPOT(1,1) = SQRT(PFERMP(1)**2+AAM(1)**2) -AAM(1) + EBINDP(1) |
| 17938 | EPOT(1,8) = SQRT(PFERMN(1)**2+AAM(8)**2) -AAM(8) + EBINDN(1) |
| 17939 | |
| 17940 | * Fermi momenta and binding energy for target |
| 17941 | IF ((IT.GT.1).AND.LFERMI) THEN |
| 17942 | IF (MODE.EQ.0) THEN |
| 17943 | C EBINDP(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ-1) |
| 17944 | C EBINDN(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ) |
| 17945 | BIT = AIT -ONE |
| 17946 | BITZ = AITZ-ONE |
| 17947 | |
| 17948 | EBINDP(2) = 1.0D-3*ABS(ENERGY(AIT,AITZ) |
| 17949 | & -ENERGY(BIT,BITZ)) |
| 17950 | |
| 17951 | IF (AIT.LE.AITZ) THEN |
| 17952 | EBINDN(2) = EBINDP(2) |
| 17953 | WRITE(LOUT,*) ' DT_NCLPOT: AIT.LE.AIPT (',AIT,AIPT,')' |
| 17954 | ELSE |
| 17955 | |
| 17956 | EBINDN(2) = 1.0D-3*ABS(ENERGY(AIT,AITZ) |
| 17957 | & -ENERGY(BIT,AITZ)) |
| 17958 | |
| 17959 | ENDIF |
| 17960 | ENDIF |
| 17961 | PFERMP(2) = FERMIT*AN*(AITZ/AIT)**0.333333D0 |
| 17962 | PFERMN(2) = FERMIT*AN*((AIT-AITZ)/AIT)**0.33333D0 |
| 17963 | ELSE |
| 17964 | PFERMP(2) = ZERO |
| 17965 | PFERMN(2) = ZERO |
| 17966 | ENDIF |
| 17967 | * effective nuclear potential for target |
| 17968 | C EPOT(2,1) = PFERMP(2)**2/(2.0D0*AAM(1)) + EBINDP(2) |
| 17969 | C EPOT(2,8) = PFERMN(2)**2/(2.0D0*AAM(8)) + EBINDN(2) |
| 17970 | EPOT(2,1) = SQRT(PFERMP(2)**2+AAM(1)**2) -AAM(1) + EBINDP(2) |
| 17971 | EPOT(2,8) = SQRT(PFERMN(2)**2+AAM(8)**2) -AAM(8) + EBINDN(2) |
| 17972 | |
| 17973 | DO 2 I=1,14 |
| 17974 | EPOT(1,IDXPOT(I)) = EPOT(1,8) |
| 17975 | EPOT(2,IDXPOT(I)) = EPOT(2,8) |
| 17976 | 2 CONTINUE |
| 17977 | |
| 17978 | * Coulomb energy |
| 17979 | ETACOU(1) = ZERO |
| 17980 | ETACOU(2) = ZERO |
| 17981 | IF (ICOUL.EQ.1) THEN |
| 17982 | IF (IP.GT.1) |
| 17983 | & ETACOU(1) = 0.001116D0*AIPZ/(1.0D0+AIP**0.333D0) |
| 17984 | IF (IT.GT.1) |
| 17985 | & ETACOU(2) = 0.001116D0*AITZ/(1.0D0+AIT**0.333D0) |
| 17986 | ENDIF |
| 17987 | |
| 17988 | IF (LSTART) THEN |
| 17989 | WRITE(LOUT,1000) IP,IPZ,IT,ITZ,EBINDP,EBINDN, |
| 17990 | & EPOT(1,1)-EBINDP(1),EPOT(2,1)-EBINDP(2), |
| 17991 | & EPOT(1,8)-EBINDN(1),EPOT(2,8)-EBINDN(2), |
| 17992 | & FERMOD,ETACOU |
| 17993 | 1000 FORMAT(/,/,1X,'NCLPOT: quantities for inclusion of nuclear' |
| 17994 | & ,' effects',/,12X,'---------------------------', |
| 17995 | & '----------------',/,/,38X,'projectile', |
| 17996 | & ' target',/,/,1X,'Mass number / charge', |
| 17997 | & 17X,I3,' /',I3,6X,I3,' /',I3,/,1X,'Binding energy -', |
| 17998 | & ' proton (GeV) ',2E14.4,/,17X,'- neutron (GeV)' |
| 17999 | & ,1X,2E14.4,/,1X,'Fermi-potential - proton (GeV)', |
| 18000 | & 1X,2E14.4,/,17X,'- neutron (GeV) ',2E14.4,/,/, |
| 18001 | & 1X,'Scale factor for Fermi-momentum ',F4.2,/, |
| 18002 | & /,1X,'Coulomb-energy ',2(E14.4,' GeV '),/,/) |
| 18003 | LSTART = .FALSE. |
| 18004 | ENDIF |
| 18005 | |
| 18006 | RETURN |
| 18007 | END |
| 18008 | * |
| 18009 | *===resncl=============================================================* |
| 18010 | * |
| 18011 | CDECK ID>, DT_RESNCL |
| 18012 | SUBROUTINE DT_RESNCL(EPN,NLOOP,MODE) |
| 18013 | |
| 18014 | ************************************************************************ |
| 18015 | * Treatment of residual nuclei and nuclear effects. * |
| 18016 | * MODE = 1 initializations * |
| 18017 | * = 2 treatment of final state * |
| 18018 | * This version dated 16.11.95 is written by S. Roesler. * |
| 18019 | ************************************************************************ |
| 18020 | |
| 18021 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 18022 | SAVE |
| 18023 | |
| 18024 | PARAMETER ( LINP = 5 , |
| 18025 | & LOUT = 6 , |
| 18026 | & LDAT = 9 ) |
| 18027 | |
| 18028 | PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,THREE=3.D0,TINY3=1.0D-3, |
| 18029 | & TINY2=1.0D-2,TINY1=1.0D-1,TINY4=1.0D-4,TINY10=1.0D-10, |
| 18030 | & ONETHI=ONE/THREE) |
| 18031 | PARAMETER (AMUAMU = 0.93149432D0, |
| 18032 | & FM2MM = 1.0D-12, |
| 18033 | & RNUCLE = 1.12D0) |
| 18034 | |
| 18035 | * event history |
| 18036 | |
| 18037 | PARAMETER (NMXHKK=200000) |
| 18038 | |
| 18039 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 18040 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 18041 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 18042 | * extended event history |
| 18043 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 18044 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 18045 | & IHIST(2,NMXHKK) |
| 18046 | * particle properties (BAMJET index convention) |
| 18047 | CHARACTER*8 ANAME |
| 18048 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 18049 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 18050 | * flags for input different options |
| 18051 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 18052 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 18053 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 18054 | * nuclear potential |
| 18055 | LOGICAL LFERMI |
| 18056 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, |
| 18057 | & EBINDP(2),EBINDN(2),EPOT(2,210), |
| 18058 | & ETACOU(2),ICOUL,LFERMI |
| 18059 | * properties of interacting particles |
| 18060 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG |
| 18061 | * properties of photon/lepton projectiles |
| 18062 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC |
| 18063 | * Lorentz-parameters of the current interaction |
| 18064 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, |
| 18065 | & UMO,PPCM,EPROJ,PPROJ |
| 18066 | * treatment of residual nuclei: wounded nucleons |
| 18067 | COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210) |
| 18068 | * treatment of residual nuclei: 4-momenta |
| 18069 | LOGICAL LRCLPR,LRCLTA |
| 18070 | COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5), |
| 18071 | & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA |
| 18072 | |
| 18073 | DIMENSION PFSP(4),PSEC(4),PSEC0(4) |
| 18074 | DIMENSION PMOMB(5000),IDXB(5000),PMOMM(10000),IDXM(10000), |
| 18075 | & IDXCOR(15000),IDXOTH(NMXHKK) |
| 18076 | |
| 18077 | GOTO (1,2) MODE |
| 18078 | |
| 18079 | *------- initializations |
| 18080 | 1 CONTINUE |
| 18081 | |
| 18082 | * initialize arrays for residual nuclei |
| 18083 | DO 10 K=1,5 |
| 18084 | IF (K.LE.4) THEN |
| 18085 | PFSP(K) = ZERO |
| 18086 | ENDIF |
| 18087 | PINIPR(K) = ZERO |
| 18088 | PINITA(K) = ZERO |
| 18089 | PRCLPR(K) = ZERO |
| 18090 | PRCLTA(K) = ZERO |
| 18091 | TRCLPR(K) = ZERO |
| 18092 | TRCLTA(K) = ZERO |
| 18093 | 10 CONTINUE |
| 18094 | SCPOT = ONE |
| 18095 | NLOOP = 0 |
| 18096 | |
| 18097 | * correction of projectile 4-momentum for effective target pot. |
| 18098 | * and Coulomb-energy (in case of hadron-nucleus interaction only) |
| 18099 | IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN |
| 18100 | EPNI = EPN |
| 18101 | * Coulomb-energy: |
| 18102 | * positively charged hadron - check energy for Coloumb pot. |
| 18103 | IF (IICH(IJPROJ).EQ.1) THEN |
| 18104 | THRESH = ETACOU(2)+AAM(IJPROJ) |
| 18105 | IF (EPNI.LE.THRESH) THEN |
| 18106 | WRITE(LOUT,1000) |
| 18107 | 1000 FORMAT(/,1X,'KKINC: WARNING! projectile energy', |
| 18108 | & ' below Coulomb threshold - event rejected',/) |
| 18109 | ISTHKK(1) = 1 |
| 18110 | RETURN |
| 18111 | ENDIF |
| 18112 | * negatively charged hadron - increase energy by Coulomb energy |
| 18113 | ELSEIF (IICH(IJPROJ).EQ.-1) THEN |
| 18114 | EPNI = EPNI+ETACOU(2) |
| 18115 | ENDIF |
| 18116 | IF ((IJPROJ.EQ.1).OR.(IJPROJ.EQ.8)) THEN |
| 18117 | * Effective target potential |
| 18118 | *sr 6.6. binding energy only (to avoid negative exc. energies) |
| 18119 | C EPNI = EPNI+EPOT(2,IJPROJ) |
| 18120 | EBIPOT = EBINDP(2) |
| 18121 | IF ((IJPROJ.NE.1).AND.(ABS(EPOT(2,IJPROJ)).GT.5.0D-3)) |
| 18122 | & EBIPOT = EBINDN(2) |
| 18123 | EPNI = EPNI+ABS(EBIPOT) |
| 18124 | * re-initialization of DTLTRA |
| 18125 | DUM1 = ZERO |
| 18126 | DUM2 = ZERO |
| 18127 | CALL DT_LTINI(IJPROJ,IJTARG,EPNI,DUM1,DUM2,0) |
| 18128 | ENDIF |
| 18129 | ENDIF |
| 18130 | |
| 18131 | * projectile in n-n cms |
| 18132 | IF ((IP.LE.1).AND.(IT.GT.1)) THEN |
| 18133 | PMASS1 = AAM(IJPROJ) |
| 18134 | C* VDM assumption |
| 18135 | C IF (IJPROJ.EQ.7) PMASS1 = AAM(33) |
| 18136 | IF (IJPROJ.EQ.7) PMASS1 = AAM(IJPROJ)-SQRT(VIRT) |
| 18137 | PMASS2 = AAM(1) |
| 18138 | PM1 = SIGN(PMASS1**2,PMASS1) |
| 18139 | PM2 = SIGN(PMASS2**2,PMASS2) |
| 18140 | PINIPR(4) = (UMO**2-PM2+PM1)/(TWO*UMO) |
| 18141 | PINIPR(5) = PMASS1 |
| 18142 | IF (PMASS1.GT.ZERO) THEN |
| 18143 | PINIPR(3) = SQRT((PINIPR(4)-PINIPR(5)) |
| 18144 | & *(PINIPR(4)+PINIPR(5))) |
| 18145 | ELSE |
| 18146 | PINIPR(3) = SQRT(PINIPR(4)**2-PM1) |
| 18147 | ENDIF |
| 18148 | AIT = DBLE(IT) |
| 18149 | AITZ = DBLE(ITZ) |
| 18150 | |
| 18151 | PINITA(5) = AIT*AMUAMU+1.0D-3*ENERGY(AIT,AITZ) |
| 18152 | |
| 18153 | CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3) |
| 18154 | ELSEIF ((IP.GT.1).AND.(IT.LE.1)) THEN |
| 18155 | PMASS1 = AAM(1) |
| 18156 | PMASS2 = AAM(IJTARG) |
| 18157 | PM1 = SIGN(PMASS1**2,PMASS1) |
| 18158 | PM2 = SIGN(PMASS2**2,PMASS2) |
| 18159 | PINITA(4) = (UMO**2-PM1+PM2)/(TWO*UMO) |
| 18160 | PINITA(5) = PMASS2 |
| 18161 | PINITA(3) = -SQRT((PINITA(4)-PINITA(5)) |
| 18162 | & *(PINITA(4)+PINITA(5))) |
| 18163 | AIP = DBLE(IP) |
| 18164 | AIPZ = DBLE(IPZ) |
| 18165 | |
| 18166 | PINIPR(5) = AIP*AMUAMU+1.0D-3*ENERGY(AIP,AIPZ) |
| 18167 | |
| 18168 | CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2) |
| 18169 | ELSEIF ((IP.GT.1).AND.(IT.GT.1)) THEN |
| 18170 | AIP = DBLE(IP) |
| 18171 | AIPZ = DBLE(IPZ) |
| 18172 | |
| 18173 | PINIPR(5) = AIP*AMUAMU+1.0D-3*ENERGY(AIP,AIPZ) |
| 18174 | |
| 18175 | CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2) |
| 18176 | AIT = DBLE(IT) |
| 18177 | AITZ = DBLE(ITZ) |
| 18178 | |
| 18179 | PINITA(5) = AIT*AMUAMU+1.0D-3*ENERGY(AIT,AITZ) |
| 18180 | |
| 18181 | CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3) |
| 18182 | ENDIF |
| 18183 | |
| 18184 | RETURN |
| 18185 | |
| 18186 | *------- treatment of final state |
| 18187 | 2 CONTINUE |
| 18188 | |
| 18189 | NLOOP = NLOOP+1 |
| 18190 | IF (NLOOP.GT.1) SCPOT = 0.10D0 |
| 18191 | C WRITE(LOUT,*) 'event ',NEVHKK,NLOOP,SCPOT |
| 18192 | |
| 18193 | JPW = NPW |
| 18194 | JPCW = NPCW |
| 18195 | JTW = NTW |
| 18196 | JTCW = NTCW |
| 18197 | DO 40 K=1,4 |
| 18198 | PFSP(K) = ZERO |
| 18199 | 40 CONTINUE |
| 18200 | |
| 18201 | NOB = 0 |
| 18202 | NOM = 0 |
| 18203 | DO 900 I=NPOINT(4),NHKK |
| 18204 | IDXOTH(I) = -1 |
| 18205 | IF (ISTHKK(I).EQ.1) THEN |
| 18206 | IF (IDBAM(I).EQ.7) GOTO 900 |
| 18207 | IPOT = 0 |
| 18208 | IOTHER = 0 |
| 18209 | * particle moving into forward direction |
| 18210 | IF (PHKK(3,I).GE.ZERO) THEN |
| 18211 | * most likely to be effected by projectile potential |
| 18212 | IPOT = 1 |
| 18213 | * there is no projectile nucleus, try target |
| 18214 | IF ((IP.LE.1).OR.((IP-NPW).LE.1)) THEN |
| 18215 | IPOT = 2 |
| 18216 | IF (IP.GT.1) IOTHER = 1 |
| 18217 | * there is no target nucleus --> skip |
| 18218 | IF ((IT.LE.1).OR.((IT-NTW).LE.1)) GOTO 900 |
| 18219 | ENDIF |
| 18220 | * particle moving into backward direction |
| 18221 | ELSE |
| 18222 | * most likely to be effected by target potential |
| 18223 | IPOT = 2 |
| 18224 | * there is no target nucleus, try projectile |
| 18225 | IF ((IT.LE.1).OR.((IT-NTW).LE.1)) THEN |
| 18226 | IPOT = 1 |
| 18227 | IF (IT.GT.1) IOTHER = 1 |
| 18228 | * there is no projectile nucleus --> skip |
| 18229 | IF ((IP.LE.1).OR.((IP-NPW).LE.1)) GOTO 900 |
| 18230 | ENDIF |
| 18231 | ENDIF |
| 18232 | IFLG = -IPOT |
| 18233 | * nobam=3: particle is in overlap-region or neither inside proj. nor target |
| 18234 | * =1: particle is not in overlap-region AND is inside target (2) |
| 18235 | * =2: particle is not in overlap-region AND is inside projectile (1) |
| 18236 | * flag particles which are inside the nucleus ipot but not in its |
| 18237 | * overlap region |
| 18238 | IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) IFLG = IPOT |
| 18239 | * baryons: keep all nucleons and all others where flag is set |
| 18240 | IF (IIBAR(IDBAM(I)).NE.0) THEN |
| 18241 | IF ((IDBAM(I).EQ.1).OR.(IDBAM(I).EQ.8).OR.(IFLG.GT.0)) |
| 18242 | & THEN |
| 18243 | NOB = NOB+1 |
| 18244 | PMOMB(NOB) = PHKK(3,I) |
| 18245 | IDXB(NOB) = SIGN(1000000*IABS(IFLG) |
| 18246 | & +100000*IOTHER+I,IFLG) |
| 18247 | ENDIF |
| 18248 | * mesons: keep only those mesons where flag is set |
| 18249 | ELSE |
| 18250 | IF (IFLG.GT.0) THEN |
| 18251 | NOM = NOM+1 |
| 18252 | PMOMM(NOM) = PHKK(3,I) |
| 18253 | IDXM(NOM) = 1000000*IFLG+100000*IOTHER+I |
| 18254 | ENDIF |
| 18255 | ENDIF |
| 18256 | ENDIF |
| 18257 | 900 CONTINUE |
| 18258 | * |
| 18259 | * sort particles in the arrays according to increasing long. momentum |
| 18260 | CALL DT_SORT1(PMOMB,IDXB,NOB,1,NOB,1) |
| 18261 | CALL DT_SORT1(PMOMM,IDXM,NOM,1,NOM,1) |
| 18262 | * |
| 18263 | * shuffle indices into one and the same array according to the later |
| 18264 | * sequence of correction |
| 18265 | NCOR = 0 |
| 18266 | IF (IT.GT.1) THEN |
| 18267 | DO 910 I=1,NOB |
| 18268 | IF (PMOMB(I).GT.ZERO) GOTO 911 |
| 18269 | NCOR = NCOR+1 |
| 18270 | IDXCOR(NCOR) = IDXB(I) |
| 18271 | 910 CONTINUE |
| 18272 | 911 CONTINUE |
| 18273 | IF (IP.GT.1) THEN |
| 18274 | DO 912 J=1,NOB |
| 18275 | I = NOB+1-J |
| 18276 | IF (PMOMB(I).LT.ZERO) GOTO 913 |
| 18277 | NCOR = NCOR+1 |
| 18278 | IDXCOR(NCOR) = IDXB(I) |
| 18279 | 912 CONTINUE |
| 18280 | 913 CONTINUE |
| 18281 | ELSE |
| 18282 | DO 914 I=1,NOB |
| 18283 | IF (PMOMB(I).GT.ZERO) THEN |
| 18284 | NCOR = NCOR+1 |
| 18285 | IDXCOR(NCOR) = IDXB(I) |
| 18286 | ENDIF |
| 18287 | 914 CONTINUE |
| 18288 | ENDIF |
| 18289 | ELSE |
| 18290 | DO 915 J=1,NOB |
| 18291 | I = NOB+1-J |
| 18292 | NCOR = NCOR+1 |
| 18293 | IDXCOR(NCOR) = IDXB(I) |
| 18294 | 915 CONTINUE |
| 18295 | ENDIF |
| 18296 | DO 925 I=1,NOM |
| 18297 | IF (PMOMM(I).GT.ZERO) GOTO 926 |
| 18298 | NCOR = NCOR+1 |
| 18299 | IDXCOR(NCOR) = IDXM(I) |
| 18300 | 925 CONTINUE |
| 18301 | 926 CONTINUE |
| 18302 | DO 927 J=1,NOM |
| 18303 | I = NOM+1-J |
| 18304 | IF (PMOMM(I).LT.ZERO) GOTO 928 |
| 18305 | NCOR = NCOR+1 |
| 18306 | IDXCOR(NCOR) = IDXM(I) |
| 18307 | 927 CONTINUE |
| 18308 | 928 CONTINUE |
| 18309 | * |
| 18310 | C IF (NEVHKK.EQ.484) THEN |
| 18311 | C WRITE(LOUT,9000) JPCW,JPW-JPCW,JTCW,JTW-JTCW |
| 18312 | C 9000 FORMAT(1X,'wounded nucleons (proj.-p,n targ.-p,n)',/,4I10) |
| 18313 | C WRITE(LOUT,9001) NOB,NOM,NCOR |
| 18314 | C 9001 FORMAT(1X,'produced particles (baryons,mesons,all)',3I10) |
| 18315 | C WRITE(LOUT,'(/,A)') ' baryons ' |
| 18316 | C DO 950 I=1,NOB |
| 18317 | CC J = IABS(IDXB(I)) |
| 18318 | CC INDEX = J-IABS(J/1000000)*1000000 |
| 18319 | C IPOT = IABS(IDXB(I))/1000000 |
| 18320 | C IOTHER = IABS(IDXB(I))/100000-IPOT*10 |
| 18321 | C INDEX = IABS(IDXB(I))-IPOT*1000000-IOTHER*100000 |
| 18322 | C WRITE(LOUT,9002) I,INDEX,IDXB(I),IDBAM(INDEX),PMOMB(I) |
| 18323 | C 950 CONTINUE |
| 18324 | C WRITE(LOUT,'(/,A)') ' mesons ' |
| 18325 | C DO 951 I=1,NOM |
| 18326 | CC INDEX = IDXM(I)-IABS(IDXM(I)/1000000)*1000000 |
| 18327 | C IPOT = IABS(IDXM(I))/1000000 |
| 18328 | C IOTHER = IABS(IDXM(I))/100000-IPOT*10 |
| 18329 | C INDEX = IABS(IDXM(I))-IPOT*1000000-IOTHER*100000 |
| 18330 | C WRITE(LOUT,9002) I,INDEX,IDXM(I),IDBAM(INDEX),PMOMM(I) |
| 18331 | C 951 CONTINUE |
| 18332 | C 9002 FORMAT(1X,4I14,E14.5) |
| 18333 | C WRITE(LOUT,'(/,A)') ' all ' |
| 18334 | C DO 952 I=1,NCOR |
| 18335 | CC J = IABS(IDXCOR(I)) |
| 18336 | CC INDEX = J-IABS(J/1000000)*1000000 |
| 18337 | CC IPOT = IABS(IDXCOR(I))/1000000 |
| 18338 | C IOTHER = IABS(IDXCOR(I))/100000-IPOT*10 |
| 18339 | C INDEX = IABS(IDXCOR(I))-IPOT*1000000-IOTHER*100000 |
| 18340 | C WRITE(LOUT,9003) I,INDEX,IDXCOR(I),IDBAM(INDEX) |
| 18341 | C 952 CONTINUE |
| 18342 | C 9003 FORMAT(1X,4I14) |
| 18343 | C ENDIF |
| 18344 | * |
| 18345 | DO 20 ICOR=1,NCOR |
| 18346 | IPOT = IABS(IDXCOR(ICOR))/1000000 |
| 18347 | IOTHER = IABS(IDXCOR(ICOR))/100000-IPOT*10 |
| 18348 | I = IABS(IDXCOR(ICOR))-IPOT*1000000-IOTHER*100000 |
| 18349 | IDXOTH(I) = 1 |
| 18350 | |
| 18351 | IDSEC = IDBAM(I) |
| 18352 | |
| 18353 | * reduction of particle momentum by corresponding nuclear potential |
| 18354 | * (this applies only if Fermi-momenta are requested) |
| 18355 | |
| 18356 | IF (LFERMI) THEN |
| 18357 | |
| 18358 | * Lorentz-transformation into the rest system of the selected nucleus |
| 18359 | IMODE = -IPOT-1 |
| 18360 | CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I), |
| 18361 | & PSEC(1),PSEC(2),PSEC(3),PSEC(4),IDSEC,IMODE) |
| 18362 | PSECO = SQRT(PSEC(1)**2+PSEC(2)**2+PSEC(3)**2) |
| 18363 | AMSEC = SQRT(ABS((PSEC(4)-PSECO)*(PSEC(4)+PSECO))) |
| 18364 | JPMOD = 0 |
| 18365 | |
| 18366 | CHKLEV = TINY3 |
| 18367 | IF ((EPROJ.GE.1.0D4).AND.(IDSEC.EQ.7)) CHKLEV = TINY1 |
| 18368 | IF (EPROJ.GE.2.0D6) CHKLEV = 1.0D0 |
| 18369 | IF (ABS(AMSEC-AAM(IDSEC)).GT.CHKLEV) THEN |
| 18370 | IF (IOULEV(3).GT.0) |
| 18371 | & WRITE(LOUT,2000) I,NEVHKK,IDSEC,AMSEC,AAM(IDSEC) |
| 18372 | 2000 FORMAT(1X,'RESNCL: inconsistent mass of particle', |
| 18373 | & ' at entry ',I5,' (evt.',I8,')',/,' IDSEC: ', |
| 18374 | & I4,' AMSEC: ',E12.3,' AAM(IDSEC): ',E12.3,/) |
| 18375 | GOTO 23 |
| 18376 | ENDIF |
| 18377 | |
| 18378 | DO 21 K=1,4 |
| 18379 | PSEC0(K) = PSEC(K) |
| 18380 | 21 CONTINUE |
| 18381 | |
| 18382 | * the correction for nuclear potential effects is applied to as many |
| 18383 | * p/n as many nucleons were wounded; the momenta of other final state |
| 18384 | * particles are corrected only if they materialize inside the corresp. |
| 18385 | * nucleus (here: NOBAM = 1 part. outside proj., = 2 part. outside targ |
| 18386 | * = 3 part. outside proj. and targ., >=10 in overlapping region) |
| 18387 | IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) THEN |
| 18388 | IF (IPOT.EQ.1) THEN |
| 18389 | IF ((JPW.GT.0).AND.(IOTHER.EQ.0)) THEN |
| 18390 | * this is most likely a wounded nucleon |
| 18391 | **test |
| 18392 | C RDIST = SQRT((VHKK(1,IPW(JPW))/FM2MM)**2 |
| 18393 | C & +(VHKK(2,IPW(JPW))/FM2MM)**2 |
| 18394 | C & +(VHKK(3,IPW(JPW))/FM2MM)**2) |
| 18395 | C RAD = RNUCLE*DBLE(IP)**ONETHI |
| 18396 | C FDEN = 1.4D0*DT_DENSIT(IP,RDIST,RAD) |
| 18397 | C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC) |
| 18398 | ** |
| 18399 | PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC) |
| 18400 | JPW = JPW-1 |
| 18401 | JPMOD = 1 |
| 18402 | ELSE |
| 18403 | * correct only if part. was materialized inside nucleus |
| 18404 | * and if it is ouside the overlapping region |
| 18405 | IF ((NOBAM(I).NE.1).AND.(NOBAM(I).LT.3)) THEN |
| 18406 | PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC) |
| 18407 | JPMOD = 1 |
| 18408 | ENDIF |
| 18409 | ENDIF |
| 18410 | ELSEIF (IPOT.EQ.2) THEN |
| 18411 | IF ((JTW.GT.0).AND.(IOTHER.EQ.0)) THEN |
| 18412 | * this is most likely a wounded nucleon |
| 18413 | **test |
| 18414 | C RDIST = SQRT((VHKK(1,ITW(JTW))/FM2MM)**2 |
| 18415 | C & +(VHKK(2,ITW(JTW))/FM2MM)**2 |
| 18416 | C & +(VHKK(3,ITW(JTW))/FM2MM)**2) |
| 18417 | C RAD = RNUCLE*DBLE(IT)**ONETHI |
| 18418 | C FDEN = 1.4D0*DT_DENSIT(IT,RDIST,RAD) |
| 18419 | C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC) |
| 18420 | ** |
| 18421 | PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC) |
| 18422 | JTW = JTW-1 |
| 18423 | JPMOD = 1 |
| 18424 | ELSE |
| 18425 | * correct only if part. was materialized inside nucleus |
| 18426 | IF ((NOBAM(I).NE.2).AND.(NOBAM(I).LT.3)) THEN |
| 18427 | PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC) |
| 18428 | JPMOD = 1 |
| 18429 | ENDIF |
| 18430 | ENDIF |
| 18431 | ENDIF |
| 18432 | ELSE |
| 18433 | IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) THEN |
| 18434 | PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC) |
| 18435 | JPMOD = 1 |
| 18436 | ENDIF |
| 18437 | ENDIF |
| 18438 | |
| 18439 | IF (NLOOP.EQ.1) THEN |
| 18440 | * Coulomb energy correction: |
| 18441 | * the treatment of Coulomb potential correction is similar to the |
| 18442 | * one for nuclear potential |
| 18443 | IF (IDSEC.EQ.1) THEN |
| 18444 | IF ((IPOT.EQ.1).AND.(JPCW.GT.0)) THEN |
| 18445 | JPCW = JPCW-1 |
| 18446 | ELSEIF ((IPOT.EQ.2).AND.(JTCW.GT.0)) THEN |
| 18447 | JTCW = JTCW-1 |
| 18448 | ELSE |
| 18449 | IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25 |
| 18450 | ENDIF |
| 18451 | ELSE |
| 18452 | IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25 |
| 18453 | ENDIF |
| 18454 | IF (IICH(IDSEC).EQ.1) THEN |
| 18455 | * pos. particles: check if they are able to escape Coulomb potential |
| 18456 | IF (PSEC(4).LT.AMSEC+ETACOU(IPOT)) THEN |
| 18457 | ISTHKK(I) = 14+IPOT |
| 18458 | IF (ISTHKK(I).EQ.15) THEN |
| 18459 | DO 26 K=1,4 |
| 18460 | PHKK(K,I) = PSEC0(K) |
| 18461 | TRCLPR(K) = TRCLPR(K)+PSEC0(K) |
| 18462 | 26 CONTINUE |
| 18463 | IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1 |
| 18464 | IF (IDSEC.EQ.1) NPCW = NPCW-1 |
| 18465 | ELSEIF (ISTHKK(I).EQ.16) THEN |
| 18466 | DO 27 K=1,4 |
| 18467 | PHKK(K,I) = PSEC0(K) |
| 18468 | TRCLTA(K) = TRCLTA(K)+PSEC0(K) |
| 18469 | 27 CONTINUE |
| 18470 | IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1 |
| 18471 | IF (IDSEC.EQ.1) NTCW = NTCW-1 |
| 18472 | ENDIF |
| 18473 | GOTO 20 |
| 18474 | ENDIF |
| 18475 | ELSEIF (IICH(IDSEC).EQ.-1) THEN |
| 18476 | * neg. particles: decrease energy by Coulomb-potential |
| 18477 | PSEC(4) = PSEC(4)-ETACOU(IPOT) |
| 18478 | JPMOD = 1 |
| 18479 | ENDIF |
| 18480 | ENDIF |
| 18481 | |
| 18482 | 25 CONTINUE |
| 18483 | |
| 18484 | IF (PSEC(4).LT.AMSEC) THEN |
| 18485 | IF (IOULEV(6).GT.0) |
| 18486 | & WRITE(LOUT,2001) I,IDSEC,PSEC(4),AMSEC |
| 18487 | 2001 FORMAT(1X,'KKINC: particle at DTEVT1-pos. ',I5, |
| 18488 | & ' is not allowed to escape nucleus',/, |
| 18489 | & 8X,'id : ',I3,' reduced energy: ',E15.4, |
| 18490 | & ' mass: ',E12.3) |
| 18491 | ISTHKK(I) = 14+IPOT |
| 18492 | IF (ISTHKK(I).EQ.15) THEN |
| 18493 | DO 28 K=1,4 |
| 18494 | PHKK(K,I) = PSEC0(K) |
| 18495 | TRCLPR(K) = TRCLPR(K)+PSEC0(K) |
| 18496 | 28 CONTINUE |
| 18497 | IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1 |
| 18498 | IF (IDSEC.EQ.1) NPCW = NPCW-1 |
| 18499 | ELSEIF (ISTHKK(I).EQ.16) THEN |
| 18500 | DO 29 K=1,4 |
| 18501 | PHKK(K,I) = PSEC0(K) |
| 18502 | TRCLTA(K) = TRCLTA(K)+PSEC0(K) |
| 18503 | 29 CONTINUE |
| 18504 | IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1 |
| 18505 | IF (IDSEC.EQ.1) NTCW = NTCW-1 |
| 18506 | ENDIF |
| 18507 | GOTO 20 |
| 18508 | ENDIF |
| 18509 | |
| 18510 | IF (JPMOD.EQ.1) THEN |
| 18511 | PSECN = SQRT( (PSEC(4)-AMSEC)*(PSEC(4)+AMSEC) ) |
| 18512 | * 4-momentum after correction for nuclear potential |
| 18513 | DO 22 K=1,3 |
| 18514 | PSEC(K) = PSEC(K)*PSECN/PSECO |
| 18515 | 22 CONTINUE |
| 18516 | |
| 18517 | * store recoil momentum from particles escaping the nuclear potentials |
| 18518 | DO 30 K=1,4 |
| 18519 | IF (IPOT.EQ.1) THEN |
| 18520 | TRCLPR(K) = TRCLPR(K)+PSEC0(K)-PSEC(K) |
| 18521 | ELSEIF (IPOT.EQ.2) THEN |
| 18522 | TRCLTA(K) = TRCLTA(K)+PSEC0(K)-PSEC(K) |
| 18523 | ENDIF |
| 18524 | 30 CONTINUE |
| 18525 | |
| 18526 | * transform momentum back into n-n cms |
| 18527 | IMODE = IPOT+1 |
| 18528 | CALL DT_LTRANS(PSEC(1),PSEC(2),PSEC(3),PSEC(4), |
| 18529 | & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I), |
| 18530 | & IDSEC,IMODE) |
| 18531 | ENDIF |
| 18532 | |
| 18533 | ENDIF |
| 18534 | |
| 18535 | 23 CONTINUE |
| 18536 | DO 31 K=1,4 |
| 18537 | PFSP(K) = PFSP(K)+PHKK(K,I) |
| 18538 | 31 CONTINUE |
| 18539 | |
| 18540 | 20 CONTINUE |
| 18541 | |
| 18542 | DO 33 I=NPOINT(4),NHKK |
| 18543 | IF ((ISTHKK(I).EQ.1).AND.(IDXOTH(I).LT.0)) THEN |
| 18544 | PFSP(1) = PFSP(1)+PHKK(1,I) |
| 18545 | PFSP(2) = PFSP(2)+PHKK(2,I) |
| 18546 | PFSP(3) = PFSP(3)+PHKK(3,I) |
| 18547 | PFSP(4) = PFSP(4)+PHKK(4,I) |
| 18548 | ENDIF |
| 18549 | 33 CONTINUE |
| 18550 | |
| 18551 | DO 34 K=1,5 |
| 18552 | PRCLPR(K) = TRCLPR(K) |
| 18553 | PRCLTA(K) = TRCLTA(K) |
| 18554 | 34 CONTINUE |
| 18555 | |
| 18556 | IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN |
| 18557 | * hadron-nucleus interactions: get residual momentum from energy- |
| 18558 | * momentum conservation |
| 18559 | DO 32 K=1,4 |
| 18560 | PRCLPR(K) = ZERO |
| 18561 | PRCLTA(K) = PINIPR(K)+PINITA(K)-PFSP(K) |
| 18562 | 32 CONTINUE |
| 18563 | ELSE |
| 18564 | * nucleus-hadron, nucleus-nucleus: get residual momentum from |
| 18565 | * accumulated recoil momenta of particles leaving the spectators |
| 18566 | * transform accumulated recoil momenta of residual nuclei into |
| 18567 | * n-n cms |
| 18568 | PZI = PRCLPR(3) |
| 18569 | PEI = PRCLPR(4) |
| 18570 | CALL DT_LTNUC(PZI,PEI,PRCLPR(3),PRCLPR(4),2) |
| 18571 | PZI = PRCLTA(3) |
| 18572 | PEI = PRCLTA(4) |
| 18573 | CALL DT_LTNUC(PZI,PEI,PRCLTA(3),PRCLTA(4),3) |
| 18574 | C IF (IP.GT.1) THEN |
| 18575 | PRCLPR(3) = PRCLPR(3)+PINIPR(3) |
| 18576 | PRCLPR(4) = PRCLPR(4)+PINIPR(4) |
| 18577 | C ENDIF |
| 18578 | IF (IT.GT.1) THEN |
| 18579 | PRCLTA(3) = PRCLTA(3)+PINITA(3) |
| 18580 | PRCLTA(4) = PRCLTA(4)+PINITA(4) |
| 18581 | ENDIF |
| 18582 | ENDIF |
| 18583 | |
| 18584 | * check momenta of residual nuclei |
| 18585 | IF (LEMCCK) THEN |
| 18586 | CALL DT_EVTEMC(-PINIPR(1),-PINIPR(2),-PINIPR(3),-PINIPR(4), |
| 18587 | & 1,IDUM,IDUM) |
| 18588 | CALL DT_EVTEMC(-PINITA(1),-PINITA(2),-PINITA(3),-PINITA(4), |
| 18589 | & 2,IDUM,IDUM) |
| 18590 | CALL DT_EVTEMC(PRCLPR(1),PRCLPR(2),PRCLPR(3),PRCLPR(4), |
| 18591 | & 2,IDUM,IDUM) |
| 18592 | CALL DT_EVTEMC(PRCLTA(1),PRCLTA(2),PRCLTA(3),PRCLTA(4), |
| 18593 | & 2,IDUM,IDUM) |
| 18594 | CALL DT_EVTEMC(PFSP(1),PFSP(2),PFSP(3),PFSP(4),2,IDUM,IDUM) |
| 18595 | **sr 19.12. changed to avoid output when used with phojet |
| 18596 | C CHKLEV = TINY3 |
| 18597 | CHKLEV = TINY1 |
| 18598 | CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,501,IREJ1) |
| 18599 | C IF ((NEVHKK.EQ.409).OR.(NEVHKK.EQ.460).OR.(NEVHKK.EQ.765)) |
| 18600 | C & CALL DT_EVTOUT(4) |
| 18601 | IF (IREJ1.GT.0) RETURN |
| 18602 | ENDIF |
| 18603 | |
| 18604 | RETURN |
| 18605 | END |
| 18606 | * |
| 18607 | *===scn4ba=============================================================* |
| 18608 | * |
| 18609 | CDECK ID>, DT_SCN4BA |
| 18610 | SUBROUTINE DT_SCN4BA |
| 18611 | |
| 18612 | ************************************************************************ |
| 18613 | * SCan /DTEVT1/ 4 BAryons which are not able to escape nuclear pot. * |
| 18614 | * This version dated 12.12.95 is written by S. Roesler. * |
| 18615 | ************************************************************************ |
| 18616 | |
| 18617 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 18618 | SAVE |
| 18619 | |
| 18620 | PARAMETER ( LINP = 5 , |
| 18621 | & LOUT = 6 , |
| 18622 | & LDAT = 9 ) |
| 18623 | |
| 18624 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2, |
| 18625 | & TINY10=1.0D-10) |
| 18626 | |
| 18627 | * event history |
| 18628 | |
| 18629 | PARAMETER (NMXHKK=200000) |
| 18630 | |
| 18631 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 18632 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 18633 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 18634 | * extended event history |
| 18635 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 18636 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 18637 | & IHIST(2,NMXHKK) |
| 18638 | * particle properties (BAMJET index convention) |
| 18639 | CHARACTER*8 ANAME |
| 18640 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 18641 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 18642 | * properties of interacting particles |
| 18643 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG |
| 18644 | * nuclear potential |
| 18645 | LOGICAL LFERMI |
| 18646 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, |
| 18647 | & EBINDP(2),EBINDN(2),EPOT(2,210), |
| 18648 | & ETACOU(2),ICOUL,LFERMI |
| 18649 | * treatment of residual nuclei: wounded nucleons |
| 18650 | COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210) |
| 18651 | * treatment of residual nuclei: 4-momenta |
| 18652 | LOGICAL LRCLPR,LRCLTA |
| 18653 | COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5), |
| 18654 | & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA |
| 18655 | |
| 18656 | DIMENSION PLAB(2,5),PCMS(4) |
| 18657 | |
| 18658 | IREJ = 0 |
| 18659 | |
| 18660 | * get number of wounded nucleons |
| 18661 | NPW = 0 |
| 18662 | NPW0 = 0 |
| 18663 | NPCW = 0 |
| 18664 | NPSTCK = 0 |
| 18665 | NTW = 0 |
| 18666 | NTW0 = 0 |
| 18667 | NTCW = 0 |
| 18668 | NTSTCK = 0 |
| 18669 | |
| 18670 | ISGLPR = 0 |
| 18671 | ISGLTA = 0 |
| 18672 | LRCLPR = .FALSE. |
| 18673 | LRCLTA = .FALSE. |
| 18674 | |
| 18675 | C DO 2 I=1,NHKK |
| 18676 | DO 2 I=1,NPOINT(1) |
| 18677 | * projectile nucleons wounded in primary interaction and in fzc |
| 18678 | IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.17)) THEN |
| 18679 | NPW = NPW+1 |
| 18680 | IPW(NPW) = I |
| 18681 | NPSTCK = NPSTCK+1 |
| 18682 | IF (IDHKK(I).EQ.2212) NPCW = NPCW+1 |
| 18683 | IF (ISTHKK(I).EQ.11) NPW0 = NPW0+1 |
| 18684 | C IF (IP.GT.1) THEN |
| 18685 | DO 5 K=1,4 |
| 18686 | TRCLPR(K) = TRCLPR(K)-PHKK(K,I) |
| 18687 | 5 CONTINUE |
| 18688 | C ENDIF |
| 18689 | * target nucleons wounded in primary interaction and in fzc |
| 18690 | ELSEIF ((ISTHKK(I).EQ.12).OR.(ISTHKK(I).EQ.18)) THEN |
| 18691 | NTW = NTW+1 |
| 18692 | ITW(NTW) = I |
| 18693 | NTSTCK = NTSTCK+1 |
| 18694 | IF (IDHKK(I).EQ.2212) NTCW = NTCW+1 |
| 18695 | IF (ISTHKK(I).EQ.12) NTW0 = NTW0+1 |
| 18696 | IF (IT.GT.1) THEN |
| 18697 | DO 6 K=1,4 |
| 18698 | TRCLTA(K) = TRCLTA(K)-PHKK(K,I) |
| 18699 | 6 CONTINUE |
| 18700 | ENDIF |
| 18701 | ELSEIF (ISTHKK(I).EQ.13) THEN |
| 18702 | ISGLPR = I |
| 18703 | ELSEIF (ISTHKK(I).EQ.14) THEN |
| 18704 | ISGLTA = I |
| 18705 | ENDIF |
| 18706 | 2 CONTINUE |
| 18707 | |
| 18708 | DO 11 I=NPOINT(4),NHKK |
| 18709 | * baryons which are unable to escape the nuclear potential of proj. |
| 18710 | IF (ISTHKK(I).EQ.15) THEN |
| 18711 | ISGLPR = I |
| 18712 | NPSTCK = NPSTCK-1 |
| 18713 | IF (IIBAR(IDBAM(I)).NE.0) THEN |
| 18714 | NPW = NPW-1 |
| 18715 | IF (IICH(IDBAM(I)).GT.0) NPCW = NPCW-1 |
| 18716 | ENDIF |
| 18717 | DO 7 K=1,4 |
| 18718 | TRCLPR(K) = TRCLPR(K)+PHKK(K,I) |
| 18719 | 7 CONTINUE |
| 18720 | * baryons which are unable to escape the nuclear potential of targ. |
| 18721 | ELSEIF (ISTHKK(I).EQ.16) THEN |
| 18722 | ISGLTA = I |
| 18723 | NTSTCK = NTSTCK-1 |
| 18724 | IF (IIBAR(IDBAM(I)).NE.0) THEN |
| 18725 | NTW = NTW-1 |
| 18726 | IF (IICH(IDBAM(I)).GT.0) NTCW = NTCW-1 |
| 18727 | ENDIF |
| 18728 | DO 8 K=1,4 |
| 18729 | TRCLTA(K) = TRCLTA(K)+PHKK(K,I) |
| 18730 | 8 CONTINUE |
| 18731 | ENDIF |
| 18732 | 11 CONTINUE |
| 18733 | |
| 18734 | * residual nuclei so far |
| 18735 | IRESP = IP-NPSTCK |
| 18736 | IREST = IT-NTSTCK |
| 18737 | |
| 18738 | * ckeck for "residual nuclei" consisting of one nucleon only |
| 18739 | * treat it as final state particle |
| 18740 | IF (IRESP.EQ.1) THEN |
| 18741 | ID = IDBAM(ISGLPR) |
| 18742 | IST = ISTHKK(ISGLPR) |
| 18743 | CALL DT_LTRANS(PHKK(1,ISGLPR),PHKK(2,ISGLPR), |
| 18744 | & PHKK(3,ISGLPR),PHKK(4,ISGLPR), |
| 18745 | & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,2) |
| 18746 | IF (IST.EQ.13) THEN |
| 18747 | ISTHKK(ISGLPR) = 11 |
| 18748 | ELSE |
| 18749 | ISTHKK(ISGLPR) = 2 |
| 18750 | ENDIF |
| 18751 | CALL DT_EVTPUT(1,IDHKK(ISGLPR),ISGLPR,0, |
| 18752 | & PCMS(1),PCMS(2),PCMS(3),PCMS(4), |
| 18753 | & IDRES(ISGLPR),IDXRES(ISGLPR),IDCH(ISGLPR)) |
| 18754 | NOBAM(NHKK) = NOBAM(ISGLPR) |
| 18755 | JDAHKK(1,ISGLPR) = NHKK |
| 18756 | DO 21 K=1,4 |
| 18757 | TRCLPR(K) = TRCLPR(K)-PHKK(K,ISGLPR) |
| 18758 | 21 CONTINUE |
| 18759 | ENDIF |
| 18760 | IF (IREST.EQ.1) THEN |
| 18761 | ID = IDBAM(ISGLTA) |
| 18762 | IST = ISTHKK(ISGLTA) |
| 18763 | CALL DT_LTRANS(PHKK(1,ISGLTA),PHKK(2,ISGLTA), |
| 18764 | & PHKK(3,ISGLTA),PHKK(4,ISGLTA), |
| 18765 | & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,3) |
| 18766 | IF (IST.EQ.14) THEN |
| 18767 | ISTHKK(ISGLTA) = 12 |
| 18768 | ELSE |
| 18769 | ISTHKK(ISGLTA) = 2 |
| 18770 | ENDIF |
| 18771 | CALL DT_EVTPUT(1,IDHKK(ISGLTA),ISGLTA,0, |
| 18772 | & PCMS(1),PCMS(2),PCMS(3),PCMS(4), |
| 18773 | & IDRES(ISGLTA),IDXRES(ISGLTA),IDCH(ISGLTA)) |
| 18774 | NOBAM(NHKK) = NOBAM(ISGLTA) |
| 18775 | JDAHKK(1,ISGLTA) = NHKK |
| 18776 | DO 22 K=1,4 |
| 18777 | TRCLTA(K) = TRCLTA(K)-PHKK(K,ISGLTA) |
| 18778 | 22 CONTINUE |
| 18779 | ENDIF |
| 18780 | |
| 18781 | * get nuclear potential corresp. to the residual nucleus |
| 18782 | IPRCL = IP -NPW |
| 18783 | IPZRCL = IPZ-NPCW |
| 18784 | ITRCL = IT -NTW |
| 18785 | ITZRCL = ITZ-NTCW |
| 18786 | CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1) |
| 18787 | |
| 18788 | * baryons unable to escape the nuclear potential are treated as |
| 18789 | * excited nucleons (ISTHKK=15,16) |
| 18790 | DO 3 I=NPOINT(4),NHKK |
| 18791 | IF (ISTHKK(I).EQ.1) THEN |
| 18792 | ID = IDBAM(I) |
| 18793 | IF ( ((ID.EQ.1).OR.(ID.EQ.8)).AND.(NOBAM(I).NE.3) ) THEN |
| 18794 | * final state n and p not being outside of both nuclei are considered |
| 18795 | NPOTP = 1 |
| 18796 | NPOTT = 1 |
| 18797 | IF ( (IP.GT.1) .AND.(IRESP.GT.1).AND. |
| 18798 | & (NOBAM(I).NE.1).AND.(NPW.GT.0) ) THEN |
| 18799 | * Lorentz-trsf. into proj. rest sys. for those being inside proj. |
| 18800 | CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I), |
| 18801 | & PHKK(4,I),PLAB(1,1),PLAB(1,2),PLAB(1,3), |
| 18802 | & PLAB(1,4),ID,-2) |
| 18803 | PLABT = SQRT(PLAB(1,1)**2+PLAB(1,2)**2+PLAB(1,3)**2) |
| 18804 | PLAB(1,5) = SQRT(ABS( (PLAB(1,4)-PLABT)* |
| 18805 | & (PLAB(1,4)+PLABT) )) |
| 18806 | EKIN = PLAB(1,4)-PLAB(1,5) |
| 18807 | IF (EKIN.LE.EPOT(1,ID)) NPOTP = 15 |
| 18808 | IF ((ID.EQ.1).AND.(NPCW.LE.0)) NPOTP = 1 |
| 18809 | ENDIF |
| 18810 | IF ( (IT.GT.1) .AND.(IREST.GT.1).AND. |
| 18811 | & (NOBAM(I).NE.2).AND.(NTW.GT.0) ) THEN |
| 18812 | * Lorentz-trsf. into targ. rest sys. for those being inside targ. |
| 18813 | CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I), |
| 18814 | & PHKK(4,I),PLAB(2,1),PLAB(2,2),PLAB(2,3), |
| 18815 | & PLAB(2,4),ID,-3) |
| 18816 | PLABT = SQRT(PLAB(2,1)**2+PLAB(2,2)**2+PLAB(2,3)**2) |
| 18817 | PLAB(2,5) = SQRT(ABS( (PLAB(2,4)-PLABT)* |
| 18818 | & (PLAB(2,4)+PLABT) )) |
| 18819 | EKIN = PLAB(2,4)-PLAB(2,5) |
| 18820 | IF (EKIN.LE.EPOT(2,ID)) NPOTT = 16 |
| 18821 | IF ((ID.EQ.1).AND.(NTCW.LE.0)) NPOTT = 1 |
| 18822 | ENDIF |
| 18823 | IF (PHKK(3,I).GE.ZERO) THEN |
| 18824 | ISTHKK(I) = NPOTT |
| 18825 | IF (NPOTP.NE.1) ISTHKK(I) = NPOTP |
| 18826 | ELSE |
| 18827 | ISTHKK(I) = NPOTP |
| 18828 | IF (NPOTT.NE.1) ISTHKK(I) = NPOTT |
| 18829 | ENDIF |
| 18830 | IF (ISTHKK(I).NE.1) THEN |
| 18831 | J = ISTHKK(I)-14 |
| 18832 | DO 4 K=1,5 |
| 18833 | PHKK(K,I) = PLAB(J,K) |
| 18834 | 4 CONTINUE |
| 18835 | IF (ISTHKK(I).EQ.15) THEN |
| 18836 | NPW = NPW-1 |
| 18837 | IF (ID.EQ.1) NPCW = NPCW-1 |
| 18838 | DO 9 K=1,4 |
| 18839 | TRCLPR(K) = TRCLPR(K)+PHKK(K,I) |
| 18840 | 9 CONTINUE |
| 18841 | ELSEIF (ISTHKK(I).EQ.16) THEN |
| 18842 | NTW = NTW-1 |
| 18843 | IF (ID.EQ.1) NTCW = NTCW-1 |
| 18844 | DO 10 K=1,4 |
| 18845 | TRCLTA(K) = TRCLTA(K)+PHKK(K,I) |
| 18846 | 10 CONTINUE |
| 18847 | ENDIF |
| 18848 | ENDIF |
| 18849 | ENDIF |
| 18850 | ENDIF |
| 18851 | 3 CONTINUE |
| 18852 | |
| 18853 | * again: get nuclear potential corresp. to the residual nucleus |
| 18854 | IPRCL = IP -NPW |
| 18855 | IPZRCL = IPZ-NPCW |
| 18856 | ITRCL = IT -NTW |
| 18857 | ITZRCL = ITZ-NTCW |
| 18858 | c AFERP = 1.2D0*FERMOD*(ONE+(DBLE(IP+10-NPW0)/DBLE(IP+10))**1.1D0) |
| 18859 | cC AFERP = 1.21D0*FERMOD*(ONE+(DBLE(IP+40-NPW0)/DBLE(IP+40))**1.1D0) |
| 18860 | c & *(0.94D0+0.3D0*EXP(-DBLE(NPW0)/5.0D0)) /2.0D0 |
| 18861 | C AFERP = 0.0D0 |
| 18862 | c AFERT = 1.2D0*FERMOD*(ONE+(DBLE(IT+10-NTW0)/DBLE(IT+10))**1.1D0) |
| 18863 | cC AFERT = 1.21D0*FERMOD*(ONE+(DBLE(IT+40-NTW0)/DBLE(IT+40))**1.1D0) |
| 18864 | c & *(0.94D0+0.3D0*EXP(-DBLE(NTW0)/5.0D0)) /2.0D0 |
| 18865 | C AFERT = 0.0D0 |
| 18866 | C IF (AFERP.LT.FERMOD) AFERP = FERMOD+0.1 |
| 18867 | C IF (AFERT.LT.FERMOD) AFERT = FERMOD+0.1 |
| 18868 | C IF (AFERP.GT.0.85D0) AFERP = 0.85D0 |
| 18869 | C IF (AFERT.GT.0.85D0) AFERT = 0.85D0 |
| 18870 | AFERP = FERMOD+0.1D0 |
| 18871 | AFERT = FERMOD+0.1D0 |
| 18872 | |
| 18873 | CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,AFERP,AFERT,1) |
| 18874 | |
| 18875 | RETURN |
| 18876 | END |
| 18877 | * |
| 18878 | *===ficonf=============================================================* |
| 18879 | * |
| 18880 | CDECK ID>, DT_FICONF |
| 18881 | SUBROUTINE DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ) |
| 18882 | |
| 18883 | ************************************************************************ |
| 18884 | * Treatment of FInal CONFiguration including evaporation, fission and * |
| 18885 | * Fermi-break-up (for light nuclei only). * |
| 18886 | * Adopted from the original routine FINALE and extended to residual * |
| 18887 | * projectile nuclei. * |
| 18888 | * This version dated 12.12.95 is written by S. Roesler. * |
| 18889 | ************************************************************************ |
| 18890 | |
| 18891 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 18892 | SAVE |
| 18893 | |
| 18894 | PARAMETER ( LINP = 5 , |
| 18895 | & LOUT = 6 , |
| 18896 | & LDAT = 9 ) |
| 18897 | |
| 18898 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10) |
| 18899 | PARAMETER (ANGLGB=5.0D-16) |
| 18900 | |
| 18901 | * event history |
| 18902 | |
| 18903 | PARAMETER (NMXHKK=200000) |
| 18904 | |
| 18905 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 18906 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 18907 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 18908 | * extended event history |
| 18909 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 18910 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 18911 | & IHIST(2,NMXHKK) |
| 18912 | * rejection counter |
| 18913 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, |
| 18914 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, |
| 18915 | & IREXCI(3),IRDIFF(2),IRINC |
| 18916 | * central particle production, impact parameter biasing |
| 18917 | COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR |
| 18918 | * particle properties (BAMJET index convention) |
| 18919 | CHARACTER*8 ANAME |
| 18920 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 18921 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 18922 | * treatment of residual nuclei: 4-momenta |
| 18923 | LOGICAL LRCLPR,LRCLTA |
| 18924 | COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5), |
| 18925 | & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA |
| 18926 | * treatment of residual nuclei: properties of residual nuclei |
| 18927 | COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2), |
| 18928 | & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2), |
| 18929 | & NTOTFI(2),NPROFI(2) |
| 18930 | * statistics: residual nuclei |
| 18931 | COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2), |
| 18932 | & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2), |
| 18933 | & NINCST(2,4),NINCEV(2), |
| 18934 | & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2), |
| 18935 | & NRESPB(2),NRESCH(2),NRESEV(4), |
| 18936 | & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240), |
| 18937 | & NEVAFI(2,2) |
| 18938 | * flags for input different options |
| 18939 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 18940 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 18941 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 18942 | |
| 18943 | INCLUDE './flukapro/(DIMPAR)' |
| 18944 | INCLUDE './flukapro/(FINUC)' |
| 18945 | INCLUDE './flukapro/(RESNUC)' |
| 18946 | PARAMETER ( EMVGEV = 1.0 D-03 ) |
| 18947 | PARAMETER ( AMUGEV = 0.93149432 D+00 ) |
| 18948 | PARAMETER ( AMPRTN = 0.93827231 D+00 ) |
| 18949 | PARAMETER ( AMNTRN = 0.93956563 D+00 ) |
| 18950 | PARAMETER ( AMELCT = 0.51099906 D-03 ) |
| 18951 | PARAMETER ( ELCCGS = 4.8032068 D-10 ) |
| 18952 | PARAMETER ( ELCMKS = 1.60217733 D-19 ) |
| 18953 | PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13 |
| 18954 | & * 1.D-09 ) |
| 18955 | PARAMETER ( HLFHLF = 0.5D+00 ) |
| 18956 | PARAMETER ( FERTHO = 14.33 D-09 ) |
| 18957 | PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 ) |
| 18958 | PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 ) |
| 18959 | PARAMETER ( AMUC12 = AMUGEV - AMUNMU ) |
| 18960 | INCLUDE './flukapro/(NUCDAT)' |
| 18961 | INCLUDE './flukapro/(PAREVT)' |
| 18962 | INCLUDE './flukapro/(FHEAVY)' |
| 18963 | |
| 18964 | * event flag |
| 18965 | COMMON /DTEVNO/ NEVENT,ICASCA |
| 18966 | |
| 18967 | DIMENSION INUC(2),IDXPAR(2),IDPAR(2),AIF(2),AIZF(2),AMRCL(2), |
| 18968 | & PRCL(2,4),MO1(2),MO2(2),VRCL(2,4),WRCL(2,4), |
| 18969 | & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4) |
| 18970 | |
| 18971 | DIMENSION EXPNUC(2),EXC(2,260),NEXC(2,260) |
| 18972 | DATA EXC,NEXC /520*ZERO,520*0/ |
| 18973 | DATA EXPNUC /4.0D-3,4.0D-3/ |
| 18974 | |
| 18975 | IREJ = 0 |
| 18976 | LRCLPR = .FALSE. |
| 18977 | LRCLTA = .FALSE. |
| 18978 | |
| 18979 | * skip residual nucleus treatment if not requested or in case |
| 18980 | * of central collisions |
| 18981 | IF ((.NOT.LEVPRT).OR.(ICENTR.GT.0).OR.(ICENTR.EQ.-1)) RETURN |
| 18982 | |
| 18983 | DO 1 K=1,2 |
| 18984 | IDPAR(K) = 0 |
| 18985 | IDXPAR(K)= 0 |
| 18986 | NTOT(K) = 0 |
| 18987 | NTOTFI(K)= 0 |
| 18988 | NPRO(K) = 0 |
| 18989 | NPROFI(K)= 0 |
| 18990 | NN(K) = 0 |
| 18991 | NH(K) = 0 |
| 18992 | NHPOS(K) = 0 |
| 18993 | NQ(K) = 0 |
| 18994 | EEXC(K) = ZERO |
| 18995 | MO1(K) = 0 |
| 18996 | MO2(K) = 0 |
| 18997 | DO 2 I=1,4 |
| 18998 | VRCL(K,I) = ZERO |
| 18999 | WRCL(K,I) = ZERO |
| 19000 | 2 CONTINUE |
| 19001 | 1 CONTINUE |
| 19002 | NFSP = 0 |
| 19003 | INUC(1) = IP |
| 19004 | INUC(2) = IT |
| 19005 | |
| 19006 | DO 3 I=1,NHKK |
| 19007 | |
| 19008 | * number of final state particles |
| 19009 | IF (ABS(ISTHKK(I)).EQ.1) THEN |
| 19010 | NFSP = NFSP+1 |
| 19011 | IDFSP = IDBAM(I) |
| 19012 | ENDIF |
| 19013 | |
| 19014 | * properties of remaining nucleon configurations |
| 19015 | KF = 0 |
| 19016 | IF ((ISTHKK(I).EQ.13).OR.(ISTHKK(I).EQ.15)) KF = 1 |
| 19017 | IF ((ISTHKK(I).EQ.14).OR.(ISTHKK(I).EQ.16)) KF = 2 |
| 19018 | IF (KF.GT.0) THEN |
| 19019 | IF (MO1(KF).EQ.0) MO1(KF) = I |
| 19020 | MO2(KF) = I |
| 19021 | * position of residual nucleus = average position of nucleons |
| 19022 | DO 4 K=1,4 |
| 19023 | VRCL(KF,K) = VRCL(KF,K)+VHKK(K,I) |
| 19024 | WRCL(KF,K) = WRCL(KF,K)+WHKK(K,I) |
| 19025 | 4 CONTINUE |
| 19026 | * total number of particles contributing to each residual nucleus |
| 19027 | NTOT(KF) = NTOT(KF)+1 |
| 19028 | IDTMP = IDBAM(I) |
| 19029 | IDXTMP = I |
| 19030 | * total charge of residual nuclei |
| 19031 | NQ(KF) = NQ(KF)+IICH(IDTMP) |
| 19032 | * number of protons |
| 19033 | IF (IDHKK(I).EQ.2212) THEN |
| 19034 | NPRO(KF) = NPRO(KF)+1 |
| 19035 | * number of neutrons |
| 19036 | ELSEIF (IDHKK(I).EQ.2112) THEN |
| 19037 | NN(KF) = NN(KF)+1 |
| 19038 | ELSE |
| 19039 | * number of baryons other than n, p |
| 19040 | IF (IIBAR(IDTMP).EQ.1) THEN |
| 19041 | NH(KF) = NH(KF)+1 |
| 19042 | IF (IICH(IDTMP).EQ.1) NHPOS(KF) = NHPOS(KF)+1 |
| 19043 | ELSE |
| 19044 | * any other mesons (status set to 1) |
| 19045 | C WRITE(LOUT,1002) KF,IDTMP |
| 19046 | C1002 FORMAT(1X,'FICONF: residual nucleus ',I2, |
| 19047 | C & ' containing meson ',I4,', status set to 1') |
| 19048 | ISTHKK(I) = 1 |
| 19049 | IDTMP = IDPAR(KF) |
| 19050 | IDXTMP = IDXPAR(KF) |
| 19051 | NTOT(KF) = NTOT(KF)-1 |
| 19052 | ENDIF |
| 19053 | ENDIF |
| 19054 | IDPAR(KF) = IDTMP |
| 19055 | IDXPAR(KF) = IDXTMP |
| 19056 | ENDIF |
| 19057 | 3 CONTINUE |
| 19058 | |
| 19059 | * reject elastic events (def: one final state particle = projectile) |
| 19060 | IF ((IP.EQ.1).AND.(NFSP.EQ.1).AND.(IDFSP.EQ.IJPROJ)) THEN |
| 19061 | IREXCI(3) = IREXCI(3)+1 |
| 19062 | GOTO 9999 |
| 19063 | C RETURN |
| 19064 | ENDIF |
| 19065 | |
| 19066 | * check if one nucleus disappeared.. |
| 19067 | C IF ((IP.GT.1).AND.(NTOT(1).EQ.0).AND.(NTOT(2).NE.0)) THEN |
| 19068 | C DO 5 K=1,4 |
| 19069 | C PRCLTA(K) = PRCLTA(K)+PRCLPR(K) |
| 19070 | C PRCLPR(K) = ZERO |
| 19071 | C 5 CONTINUE |
| 19072 | C ELSEIF ((IT.GT.1).AND.(NTOT(2).EQ.0).AND.(NTOT(1).NE.0)) THEN |
| 19073 | C DO 6 K=1,4 |
| 19074 | C PRCLPR(K) = PRCLPR(K)+PRCLTA(K) |
| 19075 | C PRCLTA(K) = ZERO |
| 19076 | C 6 CONTINUE |
| 19077 | C ENDIF |
| 19078 | |
| 19079 | ICOR = 0 |
| 19080 | INORCL = 0 |
| 19081 | DO 7 I=1,2 |
| 19082 | DO 8 K=1,4 |
| 19083 | * get the average of the nucleon positions |
| 19084 | VRCL(I,K) = VRCL(I,K)/MAX(NTOT(I),1) |
| 19085 | WRCL(I,K) = WRCL(I,K)/MAX(NTOT(I),1) |
| 19086 | IF (I.EQ.1) PRCL(1,K) = PRCLPR(K) |
| 19087 | IF (I.EQ.2) PRCL(2,K) = PRCLTA(K) |
| 19088 | 8 CONTINUE |
| 19089 | * mass number and charge of residual nuclei |
| 19090 | AIF(I) = DBLE(NTOT(I)) |
| 19091 | AIZF(I) = DBLE(NPRO(I)+NHPOS(I)) |
| 19092 | IF (NTOT(I).GT.1) THEN |
| 19093 | * masses of residual nuclei in ground state |
| 19094 | |
| 19095 | C AMRCL0(I) = AIF(I)*AMUAMU+1.0D-3*ENERGY(AIF(I),AIZF(I)) |
| 19096 | AMRCL0(I) = AIF(I)*AMUC12 |
| 19097 | & +EMVGEV*EXMSAZ(AIF(I),AIZF(I),.TRUE.,IZDUM) |
| 19098 | |
| 19099 | * masses of residual nuclei |
| 19100 | PTORCL = SQRT(PRCL(I,1)**2+PRCL(I,2)**2+PRCL(I,3)**2) |
| 19101 | AMRCL(I) = (PRCL(I,4)-PTORCL)*(PRCL(I,4)+PTORCL) |
| 19102 | IF (AMRCL(I).GT.ZERO) AMRCL(I) = SQRT(AMRCL(I)) |
| 19103 | IF (AMRCL(I).LE.ZERO) THEN |
| 19104 | IF (IOULEV(3).GT.0) |
| 19105 | & WRITE(LOUT,1000) I,PRCL(I,1),PRCL(I,2),PRCL(I,3), |
| 19106 | & PRCL(I,4),NTOT |
| 19107 | 1000 FORMAT(1X,'warning! negative excitation energy',/, |
| 19108 | & I4,4E15.4,2I4) |
| 19109 | AMRCL(I) = ZERO |
| 19110 | EEXC(I) = ZERO |
| 19111 | IF (NLOOP.LE.500) THEN |
| 19112 | GOTO 9998 |
| 19113 | ELSE |
| 19114 | IREXCI(2) = IREXCI(2)+1 |
| 19115 | GOTO 9999 |
| 19116 | ENDIF |
| 19117 | ELSEIF ((AMRCL(I).GT.ZERO).AND.(AMRCL(I).LT.AMRCL0(I))) |
| 19118 | & THEN |
| 19119 | **sr |
| 19120 | C WRITE(6,*) NEVHKK,I,NTOT(1),NTOT(2),AMRCL(I),AMRCL0(I) |
| 19121 | ** |
| 19122 | **sr 3.3 |
| 19123 | C AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I)) |
| 19124 | M = MIN(NTOT(I),260) |
| 19125 | IF (NEXC(I,M).GT.0) THEN |
| 19126 | AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M)) |
| 19127 | ELSE |
| 19128 | 70 CONTINUE |
| 19129 | M = M+1 |
| 19130 | IF (M.GE.INUC(I)) THEN |
| 19131 | AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I)) |
| 19132 | ELSE |
| 19133 | IF (NEXC(I,M).GT.0) THEN |
| 19134 | AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M)) |
| 19135 | ELSE |
| 19136 | GOTO 70 |
| 19137 | ENDIF |
| 19138 | ENDIF |
| 19139 | ENDIF |
| 19140 | ** |
| 19141 | EEXC(I) = AMRCL(I)-AMRCL0(I) |
| 19142 | ICOR = ICOR+I |
| 19143 | ELSEIF (AMRCL(I).GE.2.5D0*AMRCL0(I)) THEN |
| 19144 | IF (IOULEV(3).GT.0) |
| 19145 | & WRITE(LOUT,1004) I,AMRCL(I),AMRCL0(I),NTOT,NEVHKK |
| 19146 | 1004 FORMAT(1X,'warning! too high excitation energy',/, |
| 19147 | & I4,1P,2E15.4,3I5) |
| 19148 | AMRCL(I) = ZERO |
| 19149 | EEXC(I) = ZERO |
| 19150 | IF (NLOOP.LE.500) THEN |
| 19151 | GOTO 9998 |
| 19152 | ELSE |
| 19153 | IREXCI(2) = IREXCI(2)+1 |
| 19154 | GOTO 9999 |
| 19155 | ENDIF |
| 19156 | ELSE |
| 19157 | * excitation energies of residual nuclei |
| 19158 | EEXC(I) = AMRCL(I)-AMRCL0(I) |
| 19159 | IF (ICASCA.EQ.0) THEN |
| 19160 | **sr 15.1. |
| 19161 | C EXPNUC(I) = EEXC(I)/DBLE(NTOT(I)) |
| 19162 | EXPNUC(I) = EEXC(I)/MAX(1,INUC(I)-NTOT(I)) |
| 19163 | M = MIN(NTOT(I),260) |
| 19164 | EXC(I,M) = EXC(I,M)+EEXC(I) |
| 19165 | NEXC(I,M) = NEXC(I,M)+1 |
| 19166 | ENDIF |
| 19167 | ENDIF |
| 19168 | ELSEIF (NTOT(I).EQ.1) THEN |
| 19169 | WRITE(LOUT,1003) I |
| 19170 | 1003 FORMAT(1X,'FICONF: warning! NTOT(I)=1? (I=',I3,')') |
| 19171 | GOTO 9999 |
| 19172 | ELSE |
| 19173 | AMRCL0(I) = ZERO |
| 19174 | AMRCL(I) = ZERO |
| 19175 | EEXC(I) = ZERO |
| 19176 | INORCL = INORCL+I |
| 19177 | ENDIF |
| 19178 | 7 CONTINUE |
| 19179 | |
| 19180 | PRCLPR(5) = AMRCL(1) |
| 19181 | PRCLTA(5) = AMRCL(2) |
| 19182 | |
| 19183 | IF (ICOR.GT.0) THEN |
| 19184 | IF (INORCL.EQ.0) THEN |
| 19185 | * one or both residual nuclei consist of one nucleon only, transform |
| 19186 | * this nucleon on mass shell |
| 19187 | DO 9 K=1,4 |
| 19188 | P1IN(K) = PRCL(1,K) |
| 19189 | P2IN(K) = PRCL(2,K) |
| 19190 | 9 CONTINUE |
| 19191 | XM1 = AMRCL(1) |
| 19192 | XM2 = AMRCL(2) |
| 19193 | CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1) |
| 19194 | IF (IREJ1.GT.0) THEN |
| 19195 | WRITE(LOUT,*) 'ficonf-mashel rejection' |
| 19196 | GOTO 9999 |
| 19197 | ENDIF |
| 19198 | DO 10 K=1,4 |
| 19199 | PRCL(1,K) = P1OUT(K) |
| 19200 | PRCL(2,K) = P2OUT(K) |
| 19201 | PRCLPR(K) = P1OUT(K) |
| 19202 | PRCLTA(K) = P2OUT(K) |
| 19203 | 10 CONTINUE |
| 19204 | PRCLPR(5) = AMRCL(1) |
| 19205 | PRCLTA(5) = AMRCL(2) |
| 19206 | ELSE |
| 19207 | IF (IOULEV(3).GT.0) |
| 19208 | & WRITE(LOUT,1001) NEVHKK,INT(AIF(1)),INT(AIZF(1)), |
| 19209 | & INT(AIF(2)),INT(AIZF(2)),AMRCL0(1), |
| 19210 | & AMRCL(1),AMRCL(1)-AMRCL0(1),AMRCL0(2), |
| 19211 | & AMRCL(2),AMRCL(2)-AMRCL0(2) |
| 19212 | 1001 FORMAT(1X,'FICONF: warning! no residual nucleus for', |
| 19213 | & ' correction',/,11X,'at event',I8, |
| 19214 | & ', nucleon config. 1:',2I4,' 2:',2I4, |
| 19215 | & 2(/,11X,3E12.3)) |
| 19216 | IF (NLOOP.LE.500) THEN |
| 19217 | GOTO 9998 |
| 19218 | ELSE |
| 19219 | IREXCI(1) = IREXCI(1)+1 |
| 19220 | ENDIF |
| 19221 | ENDIF |
| 19222 | ENDIF |
| 19223 | |
| 19224 | * update counter |
| 19225 | C IF (NRESEV(1).NE.NEVHKK) THEN |
| 19226 | C NRESEV(1) = NEVHKK |
| 19227 | C NRESEV(2) = NRESEV(2)+1 |
| 19228 | C ENDIF |
| 19229 | NRESEV(2) = NRESEV(2)+1 |
| 19230 | DO 15 I=1,2 |
| 19231 | EXCDPM(I) = EXCDPM(I)+EEXC(I) |
| 19232 | EXCDPM(I+2) = EXCDPM(I+2)+(EEXC(I)/MAX(NTOT(I),1)) |
| 19233 | NRESTO(I) = NRESTO(I)+NTOT(I) |
| 19234 | NRESPR(I) = NRESPR(I)+NPRO(I) |
| 19235 | NRESNU(I) = NRESNU(I)+NN(I) |
| 19236 | NRESBA(I) = NRESBA(I)+NH(I) |
| 19237 | NRESPB(I) = NRESPB(I)+NHPOS(I) |
| 19238 | NRESCH(I) = NRESCH(I)+NQ(I) |
| 19239 | 15 CONTINUE |
| 19240 | |
| 19241 | * evaporation |
| 19242 | IF (LEVPRT) THEN |
| 19243 | DO 13 I=1,2 |
| 19244 | * initialize evaporation counter |
| 19245 | NP = 0 |
| 19246 | EEXCFI(I) = ZERO |
| 19247 | IF ((INUC(I).GT.1).AND.(AIF(I).GT.ONE).AND. |
| 19248 | & (EEXC(I).GT.ZERO)) THEN |
| 19249 | * put residual nuclei into DTEVT1 |
| 19250 | IDRCL = 80000 |
| 19251 | JMASS = INT( AIF(I)) |
| 19252 | JCHAR = INT(AIZF(I)) |
| 19253 | * the following patch is required to transmit the correct excitation |
| 19254 | * energy to Eventd |
| 19255 | IF (ITRSPT.EQ.1) THEN |
| 19256 | PRCL0 = PRCL(I,4) |
| 19257 | PRCL(I,4) =SQRT(AMRCL(I)**2+PRCL(I,1)**2+PRCL(I,2)**2 |
| 19258 | & +PRCL(I,3)**2) |
| 19259 | IF (ABS(PRCL0-PRCL(I,4)).GT.0.1D0) THEN |
| 19260 | WRITE(LOUT,*) |
| 19261 | & ' PRCL(I,4) recalculated :',PRCL0,PRCL(I,4) |
| 19262 | ENDIF |
| 19263 | ENDIF |
| 19264 | CALL DT_EVTPUT(1000,IDRCL,MO1(I),MO2(I),PRCL(I,1), |
| 19265 | & PRCL(I,2),PRCL(I,3),PRCL(I,4),JMASS,JCHAR,0) |
| 19266 | **sr 22.6.97 |
| 19267 | NOBAM(NHKK) = I |
| 19268 | ** |
| 19269 | DO 14 J=1,4 |
| 19270 | VHKK(J,NHKK) = VRCL(I,J) |
| 19271 | WHKK(J,NHKK) = WRCL(I,J) |
| 19272 | 14 CONTINUE |
| 19273 | * interface to evaporation module - fill final residual nucleus into |
| 19274 | * common FKRESN |
| 19275 | * fill resnuc only if code is not used as event generator in Fluka |
| 19276 | IF (ITRSPT.NE.1) THEN |
| 19277 | PXRES = PRCL(I,1) |
| 19278 | PYRES = PRCL(I,2) |
| 19279 | PZRES = PRCL(I,3) |
| 19280 | IBRES = NPRO(I)+NN(I)+NH(I) |
| 19281 | ICRES = NPRO(I)+NHPOS(I) |
| 19282 | ANOW = DBLE(IBRES) |
| 19283 | ZNOW = DBLE(ICRES) |
| 19284 | PTRES = SQRT(PXRES**2+PYRES**2+PZRES**2) |
| 19285 | * ground state mass of the residual nucleus (should be equal to AM0T) |
| 19286 | |
| 19287 | AMNRES = AMRCL0(I) |
| 19288 | AMMRES = AMNAMA ( AMNRES, IBRES, ICRES ) |
| 19289 | |
| 19290 | * common FKFINU |
| 19291 | TV = ZERO |
| 19292 | * kinetic energy of residual nucleus |
| 19293 | TVRECL = PRCL(I,4)-AMRCL(I) |
| 19294 | * excitation energy of residual nucleus |
| 19295 | TVCMS = EEXC(I) |
| 19296 | PTOLD = PTRES |
| 19297 | PTRES = SQRT(ABS(TVRECL*(TVRECL+ |
| 19298 | & 2.0D0*(AMMRES+TVCMS)))) |
| 19299 | IF (PTOLD.LT.ANGLGB) THEN |
| 19300 | CALL DT_RACO(PXRES,PYRES,PZRES) |
| 19301 | PTOLD = ONE |
| 19302 | ENDIF |
| 19303 | PXRES = PXRES*PTRES/PTOLD |
| 19304 | PYRES = PYRES*PTRES/PTOLD |
| 19305 | PZRES = PZRES*PTRES/PTOLD |
| 19306 | * evaporation |
| 19307 | WE = ONE |
| 19308 | |
| 19309 | NPHEAV = 0 |
| 19310 | LRNFSS = .FALSE. |
| 19311 | LFRAGM = .FALSE. |
| 19312 | CALL EVEVAP(WE) |
| 19313 | |
| 19314 | * put evaporated particles and residual nuclei to DTEVT1 |
| 19315 | MO = NHKK |
| 19316 | CALL DT_EVA2HE(MO,EXCITF,I,IREJ1) |
| 19317 | ENDIF |
| 19318 | EEXCFI(I) = EXCITF |
| 19319 | EXCEVA(I) = EXCEVA(I)+EXCITF |
| 19320 | ENDIF |
| 19321 | 13 CONTINUE |
| 19322 | ENDIF |
| 19323 | |
| 19324 | RETURN |
| 19325 | |
| 19326 | C9998 IREXCI(1) = IREXCI(1)+1 |
| 19327 | 9998 IREJ = IREJ+1 |
| 19328 | 9999 CONTINUE |
| 19329 | LRCLPR = .TRUE. |
| 19330 | LRCLTA = .TRUE. |
| 19331 | IREJ = IREJ+1 |
| 19332 | RETURN |
| 19333 | END |
| 19334 | * * |
| 19335 | *====eva2he============================================================* |
| 19336 | * * |
| 19337 | CDECK ID>, DT_EVA2HE |
| 19338 | SUBROUTINE DT_EVA2HE(MO,EEXCF,IRCL,IREJ) |
| 19339 | |
| 19340 | ************************************************************************ |
| 19341 | * Interface between common's of evaporation module (FKFINU,FKFHVY) * |
| 19342 | * and DTEVT1. * |
| 19343 | * MO DTEVT1-index of "mother" (residual) nucleus before evap. * |
| 19344 | * EEXCF exitation energy of residual nucleus after evaporation * |
| 19345 | * IRCL = 1 projectile residual nucleus * |
| 19346 | * = 2 target residual nucleus * |
| 19347 | * This version dated 19.04.95 is written by S. Roesler. * |
| 19348 | ************************************************************************ |
| 19349 | |
| 19350 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 19351 | SAVE |
| 19352 | |
| 19353 | PARAMETER ( LINP = 5 , |
| 19354 | & LOUT = 6 , |
| 19355 | & LDAT = 9 ) |
| 19356 | |
| 19357 | PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3) |
| 19358 | |
| 19359 | * event history |
| 19360 | |
| 19361 | PARAMETER (NMXHKK=200000) |
| 19362 | |
| 19363 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 19364 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 19365 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 19366 | * Note: DTEVT2 - special use for heavy fragments ! |
| 19367 | * (IDRES(I) = mass number, IDXRES(I) = charge) |
| 19368 | * extended event history |
| 19369 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 19370 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 19371 | & IHIST(2,NMXHKK) |
| 19372 | * particle properties (BAMJET index convention) |
| 19373 | CHARACTER*8 ANAME |
| 19374 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 19375 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 19376 | * flags for input different options |
| 19377 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 19378 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 19379 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 19380 | * statistics: residual nuclei |
| 19381 | COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2), |
| 19382 | & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2), |
| 19383 | & NINCST(2,4),NINCEV(2), |
| 19384 | & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2), |
| 19385 | & NRESPB(2),NRESCH(2),NRESEV(4), |
| 19386 | & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240), |
| 19387 | & NEVAFI(2,2) |
| 19388 | * treatment of residual nuclei: properties of residual nuclei |
| 19389 | COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2), |
| 19390 | & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2), |
| 19391 | & NTOTFI(2),NPROFI(2) |
| 19392 | |
| 19393 | INCLUDE './flukapro/(DIMPAR)' |
| 19394 | INCLUDE './flukapro/(FINUC)' |
| 19395 | INCLUDE './flukapro/(RESNUC)' |
| 19396 | INCLUDE './flukapro/(FHEAVY)' |
| 19397 | |
| 19398 | DIMENSION IPTOKP(39) |
| 19399 | DATA IPTOKP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, |
| 19400 | & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 99, |
| 19401 | & 100, 101, 97, 102, 98, 103, 109, 115 / |
| 19402 | |
| 19403 | IREJ = 0 |
| 19404 | |
| 19405 | * skip if evaporation package is not included |
| 19406 | IF (.NOT.LEVAPO) RETURN |
| 19407 | |
| 19408 | * update counter |
| 19409 | IF (NRESEV(3).NE.NEVHKK) THEN |
| 19410 | NRESEV(3) = NEVHKK |
| 19411 | NRESEV(4) = NRESEV(4)+1 |
| 19412 | ENDIF |
| 19413 | |
| 19414 | IF (LEMCCK) |
| 19415 | & CALL DT_EVTEMC(PHKK(1,MO),PHKK(2,MO),PHKK(3,MO),PHKK(4,MO),1, |
| 19416 | & IDUM,IDUM) |
| 19417 | * mass number/charge of residual nucleus before evaporation |
| 19418 | IBTOT = IDRES(MO) |
| 19419 | IZTOT = IDXRES(MO) |
| 19420 | |
| 19421 | * protons/neutrons/gammas |
| 19422 | DO 1 I=1,NP |
| 19423 | PX = CXR(I)*PLR(I) |
| 19424 | PY = CYR(I)*PLR(I) |
| 19425 | PZ = CZR(I)*PLR(I) |
| 19426 | ID = IPTOKP(KPART(I)) |
| 19427 | IDPDG = IDT_IPDGHA(ID) |
| 19428 | AM = ((PLR(I)+TKI(I))*(PLR(I)-TKI(I)))/ |
| 19429 | & (2.0D0*MAX(TKI(I),TINY10)) |
| 19430 | IF (ABS(AM-AAM(ID)).GT.TINY3) THEN |
| 19431 | WRITE(LOUT,1000) ID,AM,AAM(ID) |
| 19432 | 1000 FORMAT(1X,'EVA2HE: inconsistent mass of evap. ', |
| 19433 | & 'particle',I3,2E10.3) |
| 19434 | ENDIF |
| 19435 | PE = TKI(I)+AM |
| 19436 | CALL DT_EVTPUT(-1,IDPDG,MO,0,PX,PY,PZ,PE,0,0,0) |
| 19437 | NOBAM(NHKK) = IRCL |
| 19438 | IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM) |
| 19439 | IBTOT = IBTOT-IIBAR(ID) |
| 19440 | IZTOT = IZTOT-IICH(ID) |
| 19441 | 1 CONTINUE |
| 19442 | |
| 19443 | * heavy fragments |
| 19444 | DO 2 I=1,NPHEAV |
| 19445 | PX = CXHEAV(I)*PHEAVY(I) |
| 19446 | PY = CYHEAV(I)*PHEAVY(I) |
| 19447 | PZ = CZHEAV(I)*PHEAVY(I) |
| 19448 | IDHEAV = 80000 |
| 19449 | AM = ((PHEAVY(I)+TKHEAV(I))*(PHEAVY(I)-TKHEAV(I)))/ |
| 19450 | & (2.0D0*MAX(TKHEAV(I),TINY10)) |
| 19451 | PE = TKHEAV(I)+AM |
| 19452 | CALL DT_EVTPUT(-1,IDHEAV,MO,0,PX,PY,PZ,PE, |
| 19453 | & IBHEAV(KHEAVY(I)),ICHEAV(KHEAVY(I)),0) |
| 19454 | NOBAM(NHKK) = IRCL |
| 19455 | IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM) |
| 19456 | IBTOT = IBTOT-IBHEAV(KHEAVY(I)) |
| 19457 | IZTOT = IZTOT-ICHEAV(KHEAVY(I)) |
| 19458 | 2 CONTINUE |
| 19459 | |
| 19460 | IF (IBRES.GT.0) THEN |
| 19461 | * residual nucleus after evaporation |
| 19462 | IDNUC = 80000 |
| 19463 | CALL DT_EVTPUT(1001,IDNUC,MO,0,PXRES,PYRES,PZRES,ERES, |
| 19464 | & IBRES,ICRES,0) |
| 19465 | NOBAM(NHKK) = IRCL |
| 19466 | ENDIF |
| 19467 | EEXCF = TVCMS |
| 19468 | NTOTFI(IRCL) = IBRES |
| 19469 | NPROFI(IRCL) = ICRES |
| 19470 | IF (LEMCCK) CALL DT_EVTEMC(-PXRES,-PYRES,-PZRES,-ERES,2,IDUM,IDUM) |
| 19471 | IBTOT = IBTOT-IBRES |
| 19472 | IZTOT = IZTOT-ICRES |
| 19473 | |
| 19474 | * count events with fission |
| 19475 | NEVAFI(1,IRCL) = NEVAFI(1,IRCL)+1 |
| 19476 | IF (LRNFSS) NEVAFI(2,IRCL) = NEVAFI(2,IRCL)+1 |
| 19477 | |
| 19478 | * energy-momentum conservation check |
| 19479 | IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,40,IREJ) |
| 19480 | C IF (IREJ.GT.0) THEN |
| 19481 | C CALL DT_EVTOUT(4) |
| 19482 | C WRITE(*,*) EEXC(2),EEXCFI(2),NP,NPHEAV |
| 19483 | C ENDIF |
| 19484 | * baryon-number/charge conservation check |
| 19485 | IF (IBTOT+IZTOT.NE.0) THEN |
| 19486 | WRITE(LOUT,1001) NEVHKK,IBTOT,IZTOT |
| 19487 | 1001 FORMAT(1X,'EVA2HE: baryon-number/charge conservation ', |
| 19488 | & 'failure at event ',I8,' : IBTOT,IZTOT = ',2I3) |
| 19489 | ENDIF |
| 19490 | |
| 19491 | RETURN |
| 19492 | END |
| 19493 | * |
| 19494 | *===ebind==============================================================* |
| 19495 | * |
| 19496 | CDECK ID>, DT_EBIND |
| 19497 | DOUBLE PRECISION FUNCTION DT_EBIND(IA,IZ) |
| 19498 | |
| 19499 | ************************************************************************ |
| 19500 | * Binding energy for nuclei. * |
| 19501 | * (Shirokov & Yudin, Yad. Fizika, Nauka, Moskva 1972) * |
| 19502 | * IA mass number * |
| 19503 | * IZ atomic number * |
| 19504 | * This version dated 5.5.95 is updated by S. Roesler. * |
| 19505 | ************************************************************************ |
| 19506 | |
| 19507 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 19508 | SAVE |
| 19509 | |
| 19510 | PARAMETER ( LINP = 5 , |
| 19511 | & LOUT = 6 , |
| 19512 | & LDAT = 9 ) |
| 19513 | |
| 19514 | PARAMETER (ZERO=0.0D0) |
| 19515 | |
| 19516 | DATA A1, A2, A3, A4, A5 |
| 19517 | & / 0.01575D0, 0.0178D0, 0.000710D0, 0.0237D0, 0.034D0/ |
| 19518 | |
| 19519 | IF ((IA.LE.1).OR.(IZ.EQ.0)) THEN |
| 19520 | WRITE(LOUT,'(1X,A,2I5)') 'DT_EBIND IA,IZ set EBIND=0. ',IA,IZ |
| 19521 | DT_EBIND = ZERO |
| 19522 | RETURN |
| 19523 | ENDIF |
| 19524 | AA = IA |
| 19525 | DT_EBIND = A1*AA - A2*AA**0.666667D0-A3*IZ*IZ*AA**(-0.333333D0) |
| 19526 | & -A4*(IA-2*IZ)**2/AA |
| 19527 | IF (MOD(IA,2).EQ.1) THEN |
| 19528 | IA5 = 0 |
| 19529 | ELSEIF (MOD(IZ,2).EQ.1) THEN |
| 19530 | IA5 = 1 |
| 19531 | ELSE |
| 19532 | IA5 = -1 |
| 19533 | ENDIF |
| 19534 | DT_EBIND = DT_EBIND - IA5*A5*AA**(-0.75D0) |
| 19535 | |
| 19536 | RETURN |
| 19537 | END |
| 19538 | |
| 19539 | ************************************************************************ |
| 19540 | * * |
| 19541 | * DPMJET 3.0: cross section routines * |
| 19542 | * * |
| 19543 | ************************************************************************ |
| 19544 | * |
| 19545 | * |
| 19546 | * SUBROUTINE DT_SHNDIF |
| 19547 | * diffractive cross sections (all energies) |
| 19548 | * SUBROUTINE DT_PHOXS |
| 19549 | * total and inel. cross sections from PHOJET interpol. tables |
| 19550 | * SUBROUTINE DT_XSHN |
| 19551 | * total and el. cross sections for all energies |
| 19552 | * SUBROUTINE DT_SIHNAB |
| 19553 | * pion 2-nucleon absorption cross sections |
| 19554 | * SUBROUTINE DT_SIGEMU |
| 19555 | * cross section for target "compounds" |
| 19556 | * SUBROUTINE DT_SIGGA |
| 19557 | * photon nucleus cross sections |
| 19558 | * SUBROUTINE DT_SIGGAT |
| 19559 | * photon nucleus cross sections from tables |
| 19560 | * SUBROUTINE DT_SANO |
| 19561 | * anomalous hard photon-nucleon cross sections from tables |
| 19562 | * SUBROUTINE DT_SIGGP |
| 19563 | * photon nucleon cross sections |
| 19564 | * SUBROUTINE DT_SIGVEL |
| 19565 | * quasi-elastic vector meson prod. cross sections |
| 19566 | * DOUBLE PRECISION FUNCTION DT_SIGVP |
| 19567 | * sigma_VN(tilde) |
| 19568 | * DOUBLE PRECISION FUNCTION DT_RRM2 |
| 19569 | * DOUBLE PRECISION FUNCTION DT_RM2 |
| 19570 | * DOUBLE PRECISION FUNCTION DT_SAM2 |
| 19571 | * SUBROUTINE DT_CKMT |
| 19572 | * SUBROUTINE DT_CKMTX |
| 19573 | * SUBROUTINE DT_PDF0 |
| 19574 | * SUBROUTINE DT_CKMTQ0 |
| 19575 | * SUBROUTINE DT_CKMTDE |
| 19576 | * SUBROUTINE DT_CKMTPR |
| 19577 | * FUNCTION DT_CKMTFF |
| 19578 | * |
| 19579 | * SUBROUTINE DT_FLUINI |
| 19580 | * total nucleon cross section fluctuation treatment |
| 19581 | * |
| 19582 | * SUBROUTINE DT_SIGTBL |
| 19583 | * pre-tabulation of low-energy elastic x-sec. using SIHNEL |
| 19584 | * SUBROUTINE DT_XSTABL |
| 19585 | * service routines |
| 19586 | * |
| 19587 | * |
| 19588 | * |
| 19589 | *===shndif===============================================================* |
| 19590 | * |
| 19591 | CDECK ID>, DT_SHNDIF |
| 19592 | SUBROUTINE DT_SHNDIF(ECM,KPROJ,KTARG,SIGDIF,SIGDIH) |
| 19593 | |
| 19594 | ********************************************************************** |
| 19595 | * Single diffractive hadron-nucleon cross sections * |
| 19596 | * S.Roesler 14/1/93 * |
| 19597 | * * |
| 19598 | * The cross sections are calculated from extrapolated single * |
| 19599 | * diffractive antiproton-proton cross sections (DTUJET92) using * |
| 19600 | * scaling relations between total and single diffractive cross * |
| 19601 | * sections. * |
| 19602 | ********************************************************************** |
| 19603 | |
| 19604 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 19605 | SAVE |
| 19606 | PARAMETER (ZERO=0.0D0) |
| 19607 | |
| 19608 | * particle properties (BAMJET index convention) |
| 19609 | CHARACTER*8 ANAME |
| 19610 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 19611 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 19612 | * |
| 19613 | CSD1 = 4.201483727D0 |
| 19614 | CSD4 = -0.4763103556D-02 |
| 19615 | CSD5 = 0.4324148297D0 |
| 19616 | * |
| 19617 | CHMSD1 = 0.8519297242D0 |
| 19618 | CHMSD4 = -0.1443076599D-01 |
| 19619 | CHMSD5 = 0.4014954567D0 |
| 19620 | * |
| 19621 | EPN = (ECM**2 -AAM(KPROJ)**2 -AAM(KTARG)**2)/(2.0D0*AAM(KTARG)) |
| 19622 | PPN = SQRT((EPN-AAM(KPROJ))*(EPN+AAM(KPROJ))) |
| 19623 | * |
| 19624 | SDIAPP = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN) |
| 19625 | SHMSD = CHMSD1+CHMSD4*LOG(PPN)**2+CHMSD5*LOG(PPN) |
| 19626 | FRAC = SHMSD/SDIAPP |
| 19627 | * |
| 19628 | GOTO( 10, 20,999,999,999,999,999, 10, 20,999, |
| 19629 | & 999, 20, 20, 20, 20, 20, 10, 20, 20, 10, |
| 19630 | & 10, 10, 20, 20, 20) KPROJ |
| 19631 | * |
| 19632 | 10 CONTINUE |
| 19633 | *---------------------------- p - p , n - p , sigma0+- - p , |
| 19634 | * Lambda - p |
| 19635 | CSD1 = 6.004476070D0 |
| 19636 | CSD4 = -0.1257784606D-03 |
| 19637 | CSD5 = 0.2447335720D0 |
| 19638 | SIGDIF = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN) |
| 19639 | SIGDIH = FRAC*SIGDIF |
| 19640 | RETURN |
| 19641 | * |
| 19642 | 20 CONTINUE |
| 19643 | * |
| 19644 | KPSCAL = 2 |
| 19645 | KTSCAL = 1 |
| 19646 | C F = SDIAPP/DT_SHNTOT(KPSCAL,KTSCAL,ECM,ZERO) |
| 19647 | DUMZER = ZERO |
| 19648 | CALL DT_XSHN(KPSCAL,KTSCAL,DUMZER,ECM,SIGTO,SIGEL) |
| 19649 | F = SDIAPP/SIGTO |
| 19650 | KT = 1 |
| 19651 | C SIGDIF = DT_SHNTOT(KPROJ,KT,ECM,ZERO)*F |
| 19652 | CALL DT_XSHN(KPROJ,KT,DUMZER,ECM,SIGTO,SIGEL) |
| 19653 | SIGDIF = SIGTO*F |
| 19654 | SIGDIH = FRAC*SIGDIF |
| 19655 | RETURN |
| 19656 | * |
| 19657 | 999 CONTINUE |
| 19658 | *-------------------------- leptons.. |
| 19659 | SIGDIF = 1.D-10 |
| 19660 | SIGDIH = 1.D-10 |
| 19661 | RETURN |
| 19662 | END |
| 19663 | * |
| 19664 | *===phoxs================================================================* |
| 19665 | * |
| 19666 | CDECK ID>, DT_PHOXS |
| 19667 | SUBROUTINE DT_PHOXS(KPROJ,KTARG,ECM,PLAB,STOT,SINE,SDIF1,BEL,MODE) |
| 19668 | |
| 19669 | ************************************************************************ |
| 19670 | * Total/inelastic proton-nucleon cross sections taken from PHOJET- * |
| 19671 | * interpolation tables. * |
| 19672 | * This version dated 05.11.97 is written by S. Roesler * |
| 19673 | ************************************************************************ |
| 19674 | |
| 19675 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 19676 | SAVE |
| 19677 | |
| 19678 | PARAMETER ( LINP = 5 , |
| 19679 | & LOUT = 6 , |
| 19680 | & LDAT = 9 ) |
| 19681 | |
| 19682 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0) |
| 19683 | PARAMETER (TWOPI = 6.283185307179586454D+00, |
| 19684 | & PI = TWOPI/TWO, |
| 19685 | & GEV2MB = 0.38938D0) |
| 19686 | |
| 19687 | LOGICAL LFIRST |
| 19688 | DATA LFIRST /.TRUE./ |
| 19689 | |
| 19690 | * nucleon-nucleon event-generator |
| 19691 | CHARACTER*8 CMODEL |
| 19692 | LOGICAL LPHOIN |
| 19693 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN |
| 19694 | * particle properties (BAMJET index convention) |
| 19695 | CHARACTER*8 ANAME |
| 19696 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 19697 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 19698 | |
| 19699 | **PHOJET105a |
| 19700 | C PARAMETER (IEETAB=10) |
| 19701 | C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX |
| 19702 | **PHOJET110 |
| 19703 | C energy-interpolation table |
| 19704 | INTEGER IEETA2 |
| 19705 | PARAMETER ( IEETA2 = 20 ) |
| 19706 | INTEGER ISIMAX |
| 19707 | DOUBLE PRECISION SIGTAB,SIGECM |
| 19708 | COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX |
| 19709 | ** |
| 19710 | |
| 19711 | IF ((MCGENE.NE.2).AND.(MODE.NE.1)) THEN |
| 19712 | WRITE(LOUT,*) MCGENE |
| 19713 | 1000 FORMAT(1X,'PHOXS: warning! PHOJET not initialized (',I2,')') |
| 19714 | STOP |
| 19715 | ENDIF |
| 19716 | |
| 19717 | IF (ECM.LE.ZERO) THEN |
| 19718 | EPN = SQRT(AAM(KPROJ)**2+PLAB**2) |
| 19719 | ECM = SQRT(AAM(KPROJ)**2+AAM(KTARG)**2+2.0D0*EPN*AAM(KTARG)) |
| 19720 | ENDIF |
| 19721 | |
| 19722 | IF (MODE.EQ.1) THEN |
| 19723 | * DL |
| 19724 | DELDL = 0.0808D0 |
| 19725 | EPSDL = -0.4525D0 |
| 19726 | S = ECM*ECM |
| 19727 | STOT = 21.7D0*S**DELDL+56.08D0*S**EPSDL |
| 19728 | ALPHAP= 0.25D0 |
| 19729 | BEL = 8.5D0+2.D0*ALPHAP*LOG(S) |
| 19730 | SIGEL = STOT**2/(16.D0*PI*BEL*GEV2MB) |
| 19731 | SINE = STOT-SIGEL |
| 19732 | SDIF1 = ZERO |
| 19733 | ELSE |
| 19734 | * Phojet |
| 19735 | IP = 1 |
| 19736 | IF(ECM.LE.SIGECM(IP,1)) THEN |
| 19737 | I1 = 1 |
| 19738 | I2 = 1 |
| 19739 | ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN |
| 19740 | DO 1 I=2,ISIMAX |
| 19741 | IF (ECM.LE.SIGECM(IP,I)) GOTO 2 |
| 19742 | 1 CONTINUE |
| 19743 | 2 CONTINUE |
| 19744 | I1 = I-1 |
| 19745 | I2 = I |
| 19746 | ELSE |
| 19747 | IF (LFIRST) THEN |
| 19748 | WRITE(LOUT,'(/1X,A,2E12.3)') |
| 19749 | & 'PHOXS: warning! energy above initialization limit (', |
| 19750 | & ECM,SIGECM(IP,ISIMAX) |
| 19751 | LFIRST = .FALSE. |
| 19752 | ENDIF |
| 19753 | I1 = ISIMAX |
| 19754 | I2 = ISIMAX |
| 19755 | ENDIF |
| 19756 | FAC2 = ZERO |
| 19757 | IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1)) |
| 19758 | & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1)) |
| 19759 | FAC1 = ONE-FAC2 |
| 19760 | STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1) |
| 19761 | SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1) |
| 19762 | SDIF1 = FAC2*(SIGTAB(IP,30,I2)+SIGTAB(IP,32,I2))+ |
| 19763 | & FAC1*(SIGTAB(IP,30,I1)+SIGTAB(IP,32,I1)) |
| 19764 | BEL = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1) |
| 19765 | ENDIF |
| 19766 | |
| 19767 | RETURN |
| 19768 | END |
| 19769 | * |
| 19770 | *===xshn===============================================================* |
| 19771 | * |
| 19772 | CDECK ID>, DT_XSHN |
| 19773 | SUBROUTINE DT_XSHN(IP,IT,PL,ECM,STOT,SELA) |
| 19774 | |
| 19775 | ************************************************************************ |
| 19776 | * Total and elastic hadron-nucleon cross section. * |
| 19777 | * Below 500GeV cross sections are based on the '98 data compilation * |
| 19778 | * of the PDG. At higher energies PHOJET results are used (patched to * |
| 19779 | * the low energy data at 500GeV). * |
| 19780 | * IP projectile index (BAMJET numbering scheme) * |
| 19781 | * (should be in the range 1..25) * |
| 19782 | * IT target index (BAMJET numbering scheme) * |
| 19783 | * (1 = proton, 8 = neutron) * |
| 19784 | * PL laboratory momentum * |
| 19785 | * ECM cm. energy (ignored if PL>0) * |
| 19786 | * STOT total cross section * |
| 19787 | * SELA elastic cross section * |
| 19788 | * Last change: 24.4.99 by S. Roesler * |
| 19789 | ************************************************************************ |
| 19790 | |
| 19791 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 19792 | SAVE |
| 19793 | |
| 19794 | PARAMETER ( LINP = 5 , |
| 19795 | & LOUT = 6 , |
| 19796 | & LDAT = 9 ) |
| 19797 | |
| 19798 | PARAMETER (ZERO=0.0D0,ONE=1.0D0) |
| 19799 | |
| 19800 | PARAMETER (NPOIN1 = 54, NPOIN2 = 8, |
| 19801 | & PLABLO = 0.1D0, PTHRE = 5.0D0, PLABHI = 500.0D0) |
| 19802 | PARAMETER (NPOINT = NPOIN1+NPOIN2+1) |
| 19803 | |
| 19804 | LOGICAL LFIRST |
| 19805 | * particle properties (BAMJET index convention) |
| 19806 | CHARACTER*8 ANAME |
| 19807 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 19808 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 19809 | * nucleon-nucleon event-generator |
| 19810 | CHARACTER*8 CMODEL |
| 19811 | LOGICAL LPHOIN |
| 19812 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN |
| 19813 | **PHOJET105a |
| 19814 | C PARAMETER (IEETAB=10) |
| 19815 | C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX |
| 19816 | **PHOJET110 |
| 19817 | C energy-interpolation table |
| 19818 | INTEGER IEETA2 |
| 19819 | PARAMETER ( IEETA2 = 20 ) |
| 19820 | INTEGER ISIMAX |
| 19821 | DOUBLE PRECISION SIGTAB,SIGECM |
| 19822 | COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX |
| 19823 | |
| 19824 | DIMENSION APL(NPOINT),ASIGTO(10,NPOINT),ASIGEL(10,NPOINT) |
| 19825 | DIMENSION IDXDAT(25,2) |
| 19826 | * |
| 19827 | DATA APL / |
| 19828 | &-1.000,-0.969,-0.937,-0.906,-0.874,-0.843,-0.811,-0.780,-0.748, |
| 19829 | &-0.717,-0.685,-0.654,-0.622,-0.591,-0.560,-0.528,-0.497,-0.465, |
| 19830 | &-0.434,-0.402,-0.371,-0.339,-0.308,-0.276,-0.245,-0.213,-0.182, |
| 19831 | &-0.151,-0.119,-0.088,-0.056,-0.025, 0.007, 0.038, 0.070, 0.101, |
| 19832 | & 0.133, 0.164, 0.196, 0.227, 0.258, 0.290, 0.321, 0.353, 0.384, |
| 19833 | & 0.416, 0.447, 0.479, 0.510, 0.542, 0.573, 0.605, 0.636, 0.668, |
| 19834 | & 0.699, 0.949, 1.199, 1.449, 1.699, 1.949, 2.199, 2.449, 2.699/ |
| 19835 | * |
| 19836 | * total cross sections: |
| 19837 | * p p |
| 19838 | DATA (ASIGTO(1,K),K=1,NPOINT) / |
| 19839 | & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255, |
| 19840 | & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646, |
| 19841 | & 1.577, 1.518, 1.462, 1.420, 1.393, 1.375, 1.363, 1.356, 1.352, |
| 19842 | & 1.350, 1.351, 1.359, 1.381, 1.410, 1.444, 1.487, 1.544, 1.596, |
| 19843 | & 1.650, 1.672, 1.676, 1.677, 1.677, 1.675, 1.675, 1.669, 1.664, |
| 19844 | & 1.658, 1.653, 1.645, 1.640, 1.634, 1.630, 1.625, 1.620, 1.617, |
| 19845 | & 1.614, 1.602, 1.594, 1.589, 1.581, 1.583, 1.588, 1.596, 1.603/ |
| 19846 | * pbar p |
| 19847 | DATA (ASIGTO(2,K),K=1,NPOINT) / |
| 19848 | & 2.778, 2.759, 2.739, 2.718, 2.697, 2.675, 2.651, 2.626, 2.598, |
| 19849 | & 2.569, 2.537, 2.502, 2.471, 2.443, 2.420, 2.389, 2.361, 2.329, |
| 19850 | & 2.313, 2.304, 2.268, 2.244, 2.222, 2.212, 2.178, 2.162, 2.151, |
| 19851 | & 2.132, 2.109, 2.097, 2.089, 2.078, 2.063, 2.049, 2.035, 2.024, |
| 19852 | & 2.014, 2.004, 1.993, 1.981, 1.970, 1.958, 1.946, 1.933, 1.921, |
| 19853 | & 1.909, 1.894, 1.885, 1.871, 1.854, 1.836, 1.825, 1.816, 1.802, |
| 19854 | & 1.790, 1.744, 1.694, 1.663, 1.642, 1.614, 1.623, 1.623, 1.630/ |
| 19855 | * n p |
| 19856 | DATA (ASIGTO(3,K),K=1,NPOINT) / |
| 19857 | & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763, |
| 19858 | & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115, |
| 19859 | & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569, |
| 19860 | & 1.547, 1.534, 1.526, 1.522, 1.520, 1.525, 1.536, 1.550, 1.566, |
| 19861 | & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609, |
| 19862 | & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605, |
| 19863 | & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/ |
| 19864 | * pi+ p |
| 19865 | DATA (ASIGTO(4,K),K=1,NPOINT) / |
| 19866 | & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610, |
| 19867 | & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118, |
| 19868 | & 2.001, 1.875, 1.801, 1.665, 1.609, 1.484, 1.412, 1.334, 1.195, |
| 19869 | & 1.160, 1.166, 1.208, 1.309, 1.356, 1.394, 1.406, 1.419, 1.473, |
| 19870 | & 1.540, 1.596, 1.570, 1.533, 1.516, 1.484, 1.471, 1.478, 1.492, |
| 19871 | & 1.497, 1.491, 1.479, 1.465, 1.453, 1.449, 1.450, 1.444, 1.428, |
| 19872 | & 1.422, 1.406, 1.384, 1.369, 1.364, 1.369, 1.374, 1.388, 1.395/ |
| 19873 | * pi- p |
| 19874 | DATA (ASIGTO(5,K),K=1,NPOINT) / |
| 19875 | & 0.458, 0.540, 0.626, 0.718, 0.819, 0.933, 1.063, 1.208, 1.226, |
| 19876 | & 1.436, 1.470, 1.594, 1.708, 1.786, 1.852, 1.836, 1.763, 1.679, |
| 19877 | & 1.590, 1.492, 1.445, 1.426, 1.423, 1.433, 1.473, 1.506, 1.547, |
| 19878 | & 1.660, 1.671, 1.545, 1.591, 1.687, 1.808, 1.656, 1.582, 1.543, |
| 19879 | & 1.562, 1.560, 1.537, 1.540, 1.549, 1.557, 1.557, 1.551, 1.535, |
| 19880 | & 1.527, 1.511, 1.510, 1.507, 1.500, 1.491, 1.483, 1.478, 1.468, |
| 19881 | & 1.463, 1.435, 1.408, 1.394, 1.384, 1.380, 1.383, 1.393, 1.411/ |
| 19882 | * K+ p |
| 19883 | DATA (ASIGTO(6,K),K=1,NPOINT) / |
| 19884 | & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, |
| 19885 | & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, |
| 19886 | & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.096, 1.095, |
| 19887 | & 1.098, 1.105, 1.111, 1.139, 1.169, 1.209, 1.248, 1.259, 1.268, |
| 19888 | & 1.262, 1.257, 1.254, 1.252, 1.250, 1.249, 1.246, 1.244, 1.244, |
| 19889 | & 1.243, 1.240, 1.238, 1.237, 1.236, 1.235, 1.235, 1.236, 1.236, |
| 19890 | & 1.236, 1.233, 1.238, 1.248, 1.257, 1.272, 1.292, 1.311, 1.336/ |
| 19891 | * K- p |
| 19892 | DATA (ASIGTO(7,K),K=1,NPOINT) / |
| 19893 | & 2.003, 2.002, 2.001, 2.000, 1.999, 1.998, 1.998, 1.997, 1.997, |
| 19894 | & 1.996, 1.995, 1.993, 1.990, 1.992, 1.974, 1.912, 1.865, 1.847, |
| 19895 | & 1.896, 1.950, 1.827, 1.681, 1.637, 1.616, 1.589, 1.545, 1.543, |
| 19896 | & 1.532, 1.603, 1.604, 1.616, 1.658, 1.700, 1.658, 1.595, 1.508, |
| 19897 | & 1.493, 1.514, 1.531, 1.523, 1.501, 1.479, 1.474, 1.467, 1.463, |
| 19898 | & 1.450, 1.444, 1.435, 1.426, 1.424, 1.423, 1.415, 1.401, 1.396, |
| 19899 | & 1.384, 1.364, 1.330, 1.313, 1.310, 1.309, 1.317, 1.329, 1.338/ |
| 19900 | * K+ n |
| 19901 | DATA (ASIGTO(8,K),K=1,NPOINT) / |
| 19902 | & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584, |
| 19903 | & 0.631, 0.675, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931, |
| 19904 | & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.102, 1.125, 1.147, |
| 19905 | & 1.168, 1.187, 1.205, 1.224, 1.248, 1.279, 1.315, 1.324, 1.301, |
| 19906 | & 1.285, 1.279, 1.274, 1.273, 1.272, 1.271, 1.267, 1.263, 1.261, |
| 19907 | & 1.259, 1.256, 1.252, 1.247, 1.244, 1.241, 1.240, 1.240, 1.240, |
| 19908 | & 1.241, 1.243, 1.245, 1.253, 1.265, 1.275, 1.293, 1.314, 1.342/ |
| 19909 | * K- n |
| 19910 | DATA (ASIGTO(9,K),K=1,NPOINT) / |
| 19911 | & 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, |
| 19912 | & 1.778, 1.778, 1.778, 1.778, 1.778, 1.779, 1.779, 1.778, 1.773, |
| 19913 | & 1.765, 1.746, 1.703, 1.646, 1.561, 1.488, 1.454, 1.437, 1.437, |
| 19914 | & 1.458, 1.505, 1.561, 1.588, 1.593, 1.581, 1.551, 1.500, 1.454, |
| 19915 | & 1.427, 1.408, 1.390, 1.372, 1.361, 1.356, 1.351, 1.347, 1.343, |
| 19916 | & 1.341, 1.340, 1.338, 1.337, 1.335, 1.334, 1.332, 1.331, 1.330, |
| 19917 | & 1.330, 1.313, 1.303, 1.288, 1.288, 1.297, 1.305, 1.320, 1.342/ |
| 19918 | * Lambda p |
| 19919 | DATA (ASIGTO(10,K),K=1,NPOINT) / |
| 19920 | & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224, |
| 19921 | & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.629, |
| 19922 | & 1.599, 1.576, 1.558, 1.543, 1.530, 1.520, 1.512, 1.505, 1.499, |
| 19923 | & 1.495, 1.495, 1.497, 1.504, 1.514, 1.525, 1.536, 1.550, 1.567, |
| 19924 | & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609, |
| 19925 | & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605, |
| 19926 | & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/ |
| 19927 | * |
| 19928 | * elastic cross sections: |
| 19929 | * p p |
| 19930 | DATA (ASIGEL(1,K),K=1,NPOINT) / |
| 19931 | & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255, |
| 19932 | & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646, |
| 19933 | & 1.577, 1.518, 1.462, 1.420, 1.393, 1.374, 1.360, 1.353, 1.350, |
| 19934 | & 1.351, 1.356, 1.362, 1.369, 1.376, 1.384, 1.385, 1.399, 1.397, |
| 19935 | & 1.389, 1.385, 1.379, 1.366, 1.358, 1.344, 1.320, 1.294, 1.275, |
| 19936 | & 1.260, 1.248, 1.235, 1.219, 1.199, 1.172, 1.144, 1.126, 1.115, |
| 19937 | & 1.104, 1.013, 0.962, 0.905, 0.869, 0.845, 0.846, 0.850, 0.868/ |
| 19938 | * pbar p |
| 19939 | DATA (ASIGEL(2,K),K=1,NPOINT) / |
| 19940 | & 1.987, 1.985, 1.983, 1.980, 1.978, 1.975, 1.971, 1.968, 1.963, |
| 19941 | & 1.958, 1.951, 1.944, 1.935, 1.925, 1.914, 1.902, 1.889, 1.875, |
| 19942 | & 1.859, 1.845, 1.834, 1.817, 1.792, 1.769, 1.754, 1.738, 1.720, |
| 19943 | & 1.702, 1.688, 1.676, 1.667, 1.659, 1.652, 1.645, 1.640, 1.636, |
| 19944 | & 1.620, 1.591, 1.562, 1.546, 1.540, 1.524, 1.496, 1.475, 1.457, |
| 19945 | & 1.429, 1.402, 1.373, 1.344, 1.330, 1.306, 1.294, 1.265, 1.228, |
| 19946 | & 1.204, 1.086, 0.977, 0.933, 0.914, 0.850, 0.862, 0.848, 0.845/ |
| 19947 | * n p |
| 19948 | DATA (ASIGEL(3,K),K=1,NPOINT) / |
| 19949 | & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763, |
| 19950 | & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115, |
| 19951 | & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569, |
| 19952 | & 1.544, 1.527, 1.514, 1.504, 1.495, 1.486, 1.476, 1.466, 1.454, |
| 19953 | & 1.440, 1.425, 1.409, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304, |
| 19954 | & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136, |
| 19955 | & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/ |
| 19956 | * pi+ p |
| 19957 | DATA (ASIGEL(4,K),K=1,NPOINT) / |
| 19958 | & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610, |
| 19959 | & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118, |
| 19960 | & 2.001, 1.875, 1.801, 1.664, 1.610, 1.479, 1.423, 1.299, 1.166, |
| 19961 | & 1.097, 1.020, 0.958, 0.914, 1.013, 1.088, 1.153, 1.167, 1.235, |
| 19962 | & 1.240, 1.237, 1.202, 1.135, 1.090, 1.026, 0.975, 0.941, 0.904, |
| 19963 | & 0.894, 0.884, 0.862, 0.850, 0.845, 0.827, 0.805, 0.789, 0.776, |
| 19964 | & 0.763, 0.686, 0.626, 0.562, 0.505, 0.518, 0.525, 0.528, 0.528/ |
| 19965 | * pi- p |
| 19966 | DATA (ASIGEL(5,K),K=1,NPOINT) / |
| 19967 | & 0.266, 0.278, 0.294, 0.320, 0.360, 0.419, 0.503, 0.608, 0.727, |
| 19968 | & 0.850, 0.968, 1.071, 1.167, 1.305, 1.369, 1.404, 1.446, 1.217, |
| 19969 | & 1.112, 1.071, 1.014, 1.002, 0.996, 1.008, 1.070, 1.126, 1.209, |
| 19970 | & 1.300, 1.281, 1.188, 1.156, 1.341, 1.423, 1.314, 1.171, 1.140, |
| 19971 | & 1.106, 1.071, 1.011, 1.037, 1.026, 1.024, 0.988, 0.953, 0.895, |
| 19972 | & 0.894, 0.880, 0.871, 0.864, 0.853, 0.837, 0.820, 0.809, 0.800, |
| 19973 | & 0.782, 0.674, 0.612, 0.530, 0.521, 0.528, 0.524, 0.542, 0.569/ |
| 19974 | * K+ p |
| 19975 | DATA (ASIGEL(6,K),K=1,NPOINT) / |
| 19976 | & 1.064, 1.065, 1.065, 1.066, 1.066, 1.066, 1.066, 1.066, 1.066, |
| 19977 | & 1.065, 1.064, 1.063, 1.062, 1.062, 1.062, 1.064, 1.066, 1.070, |
| 19978 | & 1.076, 1.082, 1.088, 1.096, 1.103, 1.104, 1.104, 1.102, 1.093, |
| 19979 | & 1.087, 1.084, 1.079, 1.075, 1.067, 1.058, 1.040, 1.029, 1.012, |
| 19980 | & 1.003, 0.985, 0.935, 0.909, 0.880, 0.846, 0.790, 0.771, 0.759, |
| 19981 | & 0.743, 0.718, 0.681, 0.666, 0.645, 0.622, 0.606, 0.594, 0.584, |
| 19982 | & 0.575, 0.513, 0.453, 0.403, 0.356, 0.365, 0.389, 0.430, 0.477/ |
| 19983 | * K- p |
| 19984 | DATA (ASIGEL(7,K),K=1,NPOINT) / |
| 19985 | & 1.941, 1.936, 1.931, 1.926, 1.919, 1.912, 1.903, 1.892, 1.878, |
| 19986 | & 1.863, 1.844, 1.821, 1.791, 1.755, 1.713, 1.666, 1.615, 1.561, |
| 19987 | & 1.533, 1.531, 1.518, 1.511, 1.452, 1.339, 1.265, 1.233, 1.188, |
| 19988 | & 1.184, 1.236, 1.316, 1.333, 1.336, 1.333, 1.277, 1.216, 1.077, |
| 19989 | & 1.018, 0.912, 0.926, 0.920, 0.910, 0.894, 0.830, 0.825, 0.800, |
| 19990 | & 0.788, 0.747, 0.703, 0.707, 0.689, 0.643, 0.633, 0.635, 0.618, |
| 19991 | & 0.584, 0.579, 0.461, 0.403, 0.405, 0.399, 0.408, 0.418, 0.413/ |
| 19992 | * K+ n |
| 19993 | DATA (ASIGEL(8,K),K=1,NPOINT) / |
| 19994 | & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584, |
| 19995 | & 0.631, 0.676, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931, |
| 19996 | & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.103, 1.126, 1.148, |
| 19997 | & 1.168, 1.187, 1.205, 1.223, 1.248, 1.282, 1.269, 1.185, 1.111, |
| 19998 | & 1.063, 1.031, 0.998, 0.964, 0.928, 0.889, 0.849, 0.814, 0.785, |
| 19999 | & 0.760, 0.738, 0.720, 0.703, 0.688, 0.674, 0.660, 0.648, 0.635, |
| 20000 | & 0.624, 0.536, 0.473, 0.442, 0.428, 0.428, 0.436, 0.453, 0.477/ |
| 20001 | * K- n |
| 20002 | DATA (ASIGEL(9,K),K=1,NPOINT) / |
| 20003 | & 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, |
| 20004 | & 1.613, 1.613, 1.613, 1.612, 1.613, 1.614, 1.614, 1.612, 1.606, |
| 20005 | & 1.593, 1.564, 1.498, 1.402, 1.240, 1.071, 0.977, 0.922, 0.914, |
| 20006 | & 0.961, 1.077, 1.214, 1.271, 1.290, 1.281, 1.217, 1.096, 0.979, |
| 20007 | & 0.896, 0.822, 0.736, 0.655, 0.608, 0.591, 0.580, 0.569, 0.559, |
| 20008 | & 0.550, 0.540, 0.531, 0.522, 0.514, 0.507, 0.500, 0.494, 0.489, |
| 20009 | & 0.485, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477/ |
| 20010 | * Lambda p |
| 20011 | DATA (ASIGEL(10,K),K=1,NPOINT) / |
| 20012 | & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224, |
| 20013 | & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.630, |
| 20014 | & 1.600, 1.577, 1.558, 1.542, 1.528, 1.518, 1.510, 1.505, 1.502, |
| 20015 | & 1.501, 1.500, 1.499, 1.496, 1.491, 1.485, 1.477, 1.466, 1.454, |
| 20016 | & 1.440, 1.425, 1.408, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304, |
| 20017 | & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136, |
| 20018 | & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/ |
| 20019 | |
| 20020 | DATA (IDXDAT(K,1),K=1,25) / |
| 20021 | & 1, 2, 0, 0, 0, 0, 0, 3, 2, 0, 0,67, 4, 5, 6, 7,10, 2,67, 3, |
| 20022 | & 1, 3,45, 8, 9/ |
| 20023 | DATA (IDXDAT(K,2),K=1,25) / |
| 20024 | & 3, 2, 0, 0, 0, 0, 0, 1, 2, 0, 0,89, 5, 4, 8, 9, 1, 2,89, 1, |
| 20025 | & 3, 1,45, 6, 7/ |
| 20026 | |
| 20027 | DATA LFIRST /.TRUE./ |
| 20028 | |
| 20029 | IF (LFIRST) THEN |
| 20030 | APLABL = LOG10(PLABLO) |
| 20031 | APLABH = LOG10(PLABHI) |
| 20032 | APTHRE = LOG10(PTHRE) |
| 20033 | ADP1 = (APTHRE-APLABL)/DBLE(NPOIN1) |
| 20034 | ADP2 = (APLABH-APTHRE)/DBLE(NPOIN2) |
| 20035 | DUM0 = ZERO |
| 20036 | PHOPLA = PLABHI |
| 20037 | PHOELA = SQRT(AAM(1)**2+PHOPLA**2) |
| 20038 | ECMS = SQRT(2.0D0*AAM(1)**2+2.0D0*AAM(1)*PHOELA) |
| 20039 | IF (MCGENE.EQ.2) THEN |
| 20040 | IF (ECMS.LE.SIGECM(1,ISIMAX)) THEN |
| 20041 | CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,0) |
| 20042 | ELSE |
| 20043 | CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1) |
| 20044 | ENDIF |
| 20045 | ELSE |
| 20046 | CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1) |
| 20047 | ENDIF |
| 20048 | PHOSEL = PHOSTO-PHOSIN |
| 20049 | APHOST = LOG10(PHOSTO) |
| 20050 | APHOSE = LOG10(PHOSEL) |
| 20051 | LFIRST = .FALSE. |
| 20052 | ENDIF |
| 20053 | STOT = ZERO |
| 20054 | SELA = ZERO |
| 20055 | PLAB = PL |
| 20056 | ECMS = ECM |
| 20057 | IF ( (IP.LT.1).OR.((IT.NE.1).AND.(IT.NE.8)) ) THEN |
| 20058 | WRITE(LOUT,1000) IP,IT |
| 20059 | 1000 FORMAT(1X,'DT_XSHN: cross sections not implemented for ', |
| 20060 | & 'proj/target',2I4) |
| 20061 | STOP |
| 20062 | ENDIF |
| 20063 | |
| 20064 | IF ((PLAB.LE.ZERO).AND.(ECMS.GT.ZERO)) THEN |
| 20065 | ELAB = (ECMS**2-AAM(IP)**2-AAM(IT)**2)/(2.0D0*AAM(IT)) |
| 20066 | PLAB = SQRT((ELAB-AAM(IP))*(ELAB+AAM(IP))) |
| 20067 | ELSEIF ((PLAB.LE.ZERO).AND.(ECMS.LE.ZERO)) THEN |
| 20068 | WRITE(LOUT,1001) PLAB,ECMS |
| 20069 | 1001 FORMAT(1X,'DT_XSHN: invalid momentum/cm-energy ',2E15.5) |
| 20070 | STOP |
| 20071 | ENDIF |
| 20072 | |
| 20073 | * index of spectrum |
| 20074 | IDXP = IP |
| 20075 | IF (IP.GT.25) THEN |
| 20076 | IF (AAM(IP).GT.ZERO) THEN |
| 20077 | IF (ABS(IIBAR(IP)).GT.0) THEN |
| 20078 | IDXP = 1 |
| 20079 | ELSE |
| 20080 | IDXP = 13 |
| 20081 | ENDIF |
| 20082 | ELSE |
| 20083 | IDXP = 7 |
| 20084 | ENDIF |
| 20085 | ENDIF |
| 20086 | IDXT = 1 |
| 20087 | IF (IT.EQ.8) IDXT = 2 |
| 20088 | IDXS = IDXDAT(IDXP,IDXT) |
| 20089 | IF (IDXS.EQ.0) RETURN |
| 20090 | |
| 20091 | * compute momentum bin indices |
| 20092 | IF (PLAB.LT.PLABLO) THEN |
| 20093 | IDX0 = 1 |
| 20094 | IDX1 = 1 |
| 20095 | ELSEIF (PLAB.GE.PLABHI) THEN |
| 20096 | IDX0 = NPOINT |
| 20097 | IDX1 = NPOINT |
| 20098 | ELSE |
| 20099 | APLAB = LOG10(PLAB) |
| 20100 | IF ((PLAB.GE.PLABLO).AND.(PLAB.LT.PTHRE )) THEN |
| 20101 | IDX0 = INT((APLAB-APLABL)/ADP1)+1 |
| 20102 | ELSEIF ((PLAB.GE.PTHRE ).AND.(PLAB.LT.PLABHI)) THEN |
| 20103 | IDX0 = INT((APLAB-APTHRE)/ADP2)+NPOIN1+1 |
| 20104 | ENDIF |
| 20105 | IDX1 = IDX0+1 |
| 20106 | ENDIF |
| 20107 | |
| 20108 | * interpolate cross section |
| 20109 | IF (IDXS.GT.10) THEN |
| 20110 | IDXS1 = IDXS/10 |
| 20111 | IDXS2 = IDXS-10*IDXS1 |
| 20112 | IF (IDX0.EQ.IDX1) THEN |
| 20113 | IF (IDX0.EQ.1) THEN |
| 20114 | ASTOT = 0.5D0*(ASIGTO(IDXS1,IDX0)+ASIGTO(IDXS2,IDX0)) |
| 20115 | ASELA = 0.5D0*(ASIGEL(IDXS1,IDX0)+ASIGEL(IDXS2,IDX0)) |
| 20116 | ELSE |
| 20117 | DUM0 = ZERO |
| 20118 | CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0) |
| 20119 | PHOSEL = PHOSTO-PHOSIN |
| 20120 | ASTOT1 = ASIGTO(IDXS1,NPOINT)-APHOST+LOG10(PHOSTO) |
| 20121 | ASELA1 = ASIGEL(IDXS1,NPOINT)-APHOSE+LOG10(PHOSEL) |
| 20122 | ASTOT2 = ASIGTO(IDXS2,NPOINT)-APHOST+LOG10(PHOSTO) |
| 20123 | ASELA2 = ASIGEL(IDXS2,NPOINT)-APHOSE+LOG10(PHOSEL) |
| 20124 | ASTOT = 0.5D0*(ASTOT1+ASTOT2) |
| 20125 | ASELA = 0.5D0*(ASELA1+ASELA2) |
| 20126 | ENDIF |
| 20127 | ELSE |
| 20128 | FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0)) |
| 20129 | ASTOT1 = ASIGTO(IDXS1,IDX0)+ |
| 20130 | & FAC*(ASIGTO(IDXS1,IDX1)-ASIGTO(IDXS1,IDX0)) |
| 20131 | ASTOT2 = ASIGTO(IDXS2,IDX0)+ |
| 20132 | & FAC*(ASIGTO(IDXS2,IDX1)-ASIGTO(IDXS2,IDX0)) |
| 20133 | ASTOT = 0.5D0*(ASTOT1+ASTOT2) |
| 20134 | ASELA1 = ASIGEL(IDXS1,IDX0)+ |
| 20135 | & FAC*(ASIGEL(IDXS1,IDX1)-ASIGEL(IDXS1,IDX0)) |
| 20136 | ASELA2 = ASIGEL(IDXS2,IDX0)+ |
| 20137 | & FAC*(ASIGEL(IDXS2,IDX1)-ASIGEL(IDXS2,IDX0)) |
| 20138 | ASELA = 0.5D0*(ASELA1+ASELA2) |
| 20139 | ENDIF |
| 20140 | ELSE |
| 20141 | IF (IDX0.EQ.IDX1) THEN |
| 20142 | IF (IDX0.EQ.1) THEN |
| 20143 | ASTOT = ASIGTO(IDXS,IDX0) |
| 20144 | ASELA = ASIGEL(IDXS,IDX0) |
| 20145 | ELSE |
| 20146 | DUM0 = ZERO |
| 20147 | CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0) |
| 20148 | PHOSEL = PHOSTO-PHOSIN |
| 20149 | ASTOT = ASIGTO(IDXS,NPOINT)-APHOST+LOG10(PHOSTO) |
| 20150 | ASELA = ASIGEL(IDXS,NPOINT)-APHOSE+LOG10(PHOSEL) |
| 20151 | ENDIF |
| 20152 | ELSE |
| 20153 | FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0)) |
| 20154 | ASTOT = ASIGTO(IDXS,IDX0)+ |
| 20155 | & FAC*(ASIGTO(IDXS,IDX1)-ASIGTO(IDXS,IDX0)) |
| 20156 | ASELA = ASIGEL(IDXS,IDX0)+ |
| 20157 | & FAC*(ASIGEL(IDXS,IDX1)-ASIGEL(IDXS,IDX0)) |
| 20158 | ENDIF |
| 20159 | ENDIF |
| 20160 | STOT = 10.0D0**ASTOT |
| 20161 | SELA = 10.0D0**ASELA |
| 20162 | |
| 20163 | RETURN |
| 20164 | END |
| 20165 | * |
| 20166 | *===sihnab===============================================================* |
| 20167 | * |
| 20168 | CDECK ID>, DT_SIHNAB |
| 20169 | SUBROUTINE DT_SIHNAB(IDP,IDT,PLAB,SIGABS) |
| 20170 | |
| 20171 | ********************************************************************** |
| 20172 | * Pion 2-nucleon absorption cross sections. * |
| 20173 | * (sigma_tot for pi+ d --> p p, pi- d --> n n * |
| 20174 | * taken from Ritchie PRC 28 (1983) 926 ) * |
| 20175 | * This version dated 18.05.96 is written by S. Roesler * |
| 20176 | ********************************************************************** |
| 20177 | |
| 20178 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 20179 | SAVE |
| 20180 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY3=1.0D-3) |
| 20181 | PARAMETER (AMPR = 938.0D0, |
| 20182 | & AMPI = 140.0D0, |
| 20183 | & AMDE = TWO*AMPR, |
| 20184 | & A = -1.2D0, |
| 20185 | & B = 3.5D0, |
| 20186 | & C = 7.4D0, |
| 20187 | & D = 5600.0D0, |
| 20188 | & ER = 2136.0D0) |
| 20189 | |
| 20190 | SIGABS = ZERO |
| 20191 | IF ( ((IDP.NE.13).AND.(IDP.NE.14).AND.(IDP.NE.23)) |
| 20192 | & .OR.((IDT.NE.1).AND.(IDT.NE.8)) ) RETURN |
| 20193 | PTOT = PLAB*1.0D3 |
| 20194 | EKIN = SQRT(AMPI**2+PTOT**2)-AMPI |
| 20195 | IF ((EKIN.LT.TINY3).OR.(EKIN.GT.400.0D0)) RETURN |
| 20196 | ECM = SQRT( (AMPI+AMDE)**2+TWO*EKIN*AMDE ) |
| 20197 | SIGABS = A+B/SQRT(EKIN)+C*1.0D4/((ECM-ER)**2+D) |
| 20198 | * approximate 3N-abs., I=1-abs. etc. |
| 20199 | SIGABS = SIGABS/0.40D0 |
| 20200 | * pi0-absorption (rough approximation!!) |
| 20201 | IF (IDP.EQ.23) SIGABS = 0.5D0*SIGABS |
| 20202 | |
| 20203 | RETURN |
| 20204 | END |
| 20205 | * |
| 20206 | *===sigemu=============================================================* |
| 20207 | * |
| 20208 | CDECK ID>, DT_SIGEMU |
| 20209 | SUBROUTINE DT_SIGEMU |
| 20210 | |
| 20211 | ************************************************************************ |
| 20212 | * Combined cross section for target compounds. * |
| 20213 | * This version dated 6.4.98 is written by S. Roesler * |
| 20214 | ************************************************************************ |
| 20215 | |
| 20216 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 20217 | SAVE |
| 20218 | |
| 20219 | PARAMETER ( LINP = 5 , |
| 20220 | & LOUT = 6 , |
| 20221 | & LDAT = 9 ) |
| 20222 | |
| 20223 | PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10, |
| 20224 | & OHALF=0.5D0,ONE=1.0D0) |
| 20225 | |
| 20226 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 20227 | |
| 20228 | * Glauber formalism: cross sections |
| 20229 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, |
| 20230 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), |
| 20231 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), |
| 20232 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), |
| 20233 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), |
| 20234 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), |
| 20235 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), |
| 20236 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), |
| 20237 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), |
| 20238 | & BSLOPE,NEBINI,NQBINI |
| 20239 | * emulsion treatment |
| 20240 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), |
| 20241 | & NCOMPO,IEMUL |
| 20242 | * nucleon-nucleon event-generator |
| 20243 | CHARACTER*8 CMODEL |
| 20244 | LOGICAL LPHOIN |
| 20245 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN |
| 20246 | |
| 20247 | IF (MCGENE.NE.4) THEN |
| 20248 | WRITE(LOUT,'(A)') ' DT_SIGEMU: Combined cross sections' |
| 20249 | WRITE(LOUT,'(15X,A)') '-----------------------' |
| 20250 | ENDIF |
| 20251 | DO 1 IE=1,NEBINI |
| 20252 | DO 2 IQ=1,NQBINI |
| 20253 | SIGTOT = ZERO |
| 20254 | SIGELA = ZERO |
| 20255 | SIGQEP = ZERO |
| 20256 | SIGQET = ZERO |
| 20257 | SIGQE2 = ZERO |
| 20258 | SIGPRO = ZERO |
| 20259 | SIGDEL = ZERO |
| 20260 | SIGDQE = ZERO |
| 20261 | ERRTOT = ZERO |
| 20262 | ERRELA = ZERO |
| 20263 | ERRQEP = ZERO |
| 20264 | ERRQET = ZERO |
| 20265 | ERRQE2 = ZERO |
| 20266 | ERRPRO = ZERO |
| 20267 | ERRDEL = ZERO |
| 20268 | ERRDQE = ZERO |
| 20269 | IF (NCOMPO.GT.0) THEN |
| 20270 | DO 3 IC=1,NCOMPO |
| 20271 | SIGTOT = SIGTOT+EMUFRA(IC)*XSTOT(IE,IQ,IC) |
| 20272 | SIGELA = SIGELA+EMUFRA(IC)*XSELA(IE,IQ,IC) |
| 20273 | SIGQEP = SIGQEP+EMUFRA(IC)*XSQEP(IE,IQ,IC) |
| 20274 | SIGQET = SIGQET+EMUFRA(IC)*XSQET(IE,IQ,IC) |
| 20275 | SIGQE2 = SIGQE2+EMUFRA(IC)*XSQE2(IE,IQ,IC) |
| 20276 | SIGPRO = SIGPRO+EMUFRA(IC)*XSPRO(IE,IQ,IC) |
| 20277 | SIGDEL = SIGDEL+EMUFRA(IC)*XSDEL(IE,IQ,IC) |
| 20278 | SIGDQE = SIGDQE+EMUFRA(IC)*XSDQE(IE,IQ,IC) |
| 20279 | ERRTOT = ERRTOT+XETOT(IE,IQ,IC)**2 |
| 20280 | ERRELA = ERRELA+XEELA(IE,IQ,IC)**2 |
| 20281 | ERRQEP = ERRQEP+XEQEP(IE,IQ,IC)**2 |
| 20282 | ERRQET = ERRQET+XEQET(IE,IQ,IC)**2 |
| 20283 | ERRQE2 = ERRQE2+XEQE2(IE,IQ,IC)**2 |
| 20284 | ERRPRO = ERRPRO+XEPRO(IE,IQ,IC)**2 |
| 20285 | ERRDEL = ERRDEL+XEDEL(IE,IQ,IC)**2 |
| 20286 | ERRDQE = ERRDQE+XEDQE(IE,IQ,IC)**2 |
| 20287 | 3 CONTINUE |
| 20288 | ERRTOT = SQRT(ERRTOT) |
| 20289 | ERRELA = SQRT(ERRELA) |
| 20290 | ERRQEP = SQRT(ERRQEP) |
| 20291 | ERRQET = SQRT(ERRQET) |
| 20292 | ERRQE2 = SQRT(ERRQE2) |
| 20293 | ERRPRO = SQRT(ERRPRO) |
| 20294 | ERRDEL = SQRT(ERRDEL) |
| 20295 | ERRDQE = SQRT(ERRDQE) |
| 20296 | ELSE |
| 20297 | SIGTOT = XSTOT(IE,IQ,1) |
| 20298 | SIGELA = XSELA(IE,IQ,1) |
| 20299 | SIGQEP = XSQEP(IE,IQ,1) |
| 20300 | SIGQET = XSQET(IE,IQ,1) |
| 20301 | SIGQE2 = XSQE2(IE,IQ,1) |
| 20302 | SIGPRO = XSPRO(IE,IQ,1) |
| 20303 | SIGDEL = XSDEL(IE,IQ,1) |
| 20304 | SIGDQE = XSDQE(IE,IQ,1) |
| 20305 | ERRTOT = XETOT(IE,IQ,1) |
| 20306 | ERRELA = XEELA(IE,IQ,1) |
| 20307 | ERRQEP = XEQEP(IE,IQ,1) |
| 20308 | ERRQET = XEQET(IE,IQ,1) |
| 20309 | ERRQE2 = XEQE2(IE,IQ,1) |
| 20310 | ERRPRO = XEPRO(IE,IQ,1) |
| 20311 | ERRDEL = XEDEL(IE,IQ,1) |
| 20312 | ERRDQE = XEDQE(IE,IQ,1) |
| 20313 | ENDIF |
| 20314 | IF (MCGENE.NE.4) THEN |
| 20315 | WRITE(LOUT,1000) ECMNN(IE),Q2G(IQ) |
| 20316 | 1000 FORMAT(/,1X,'E_cm =',F9.1,' GeV Q^2 =',F6.1,' GeV^2 :',/) |
| 20317 | WRITE(LOUT,1001) SIGTOT,ERRTOT |
| 20318 | 1001 FORMAT(1X,'total',32X,F10.4,' +-',F11.5,' mb') |
| 20319 | WRITE(LOUT,1002) SIGELA,ERRELA |
| 20320 | 1002 FORMAT(1X,'elastic',30X,F10.4,' +-',F11.5,' mb') |
| 20321 | WRITE(LOUT,1003) SIGQEP,ERRQEP |
| 20322 | 1003 FORMAT(1X,'quasi-elastic (A+B-->A+X)',12X,F10.4,' +-', |
| 20323 | & F11.5,' mb') |
| 20324 | WRITE(LOUT,1004) SIGQET,ERRQET |
| 20325 | 1004 FORMAT(1X,'quasi-elastic (A+B-->X+B)',12X,F10.4,' +-', |
| 20326 | & F11.5,' mb') |
| 20327 | WRITE(LOUT,1005) SIGQE2,ERRQE2 |
| 20328 | 1005 FORMAT(1X,'quasi-elastic (A+B-->X, excl. 2-4)',3X,F10.4, |
| 20329 | & ' +-',F11.5,' mb') |
| 20330 | WRITE(LOUT,1006) SIGPRO,ERRPRO |
| 20331 | 1006 FORMAT(1X,'production',27X,F10.4,' +-',F11.5,' mb') |
| 20332 | WRITE(LOUT,1007) SIGDEL,ERRDEL |
| 20333 | 1007 FORMAT(1X,'diff-el ',27X,F10.4,' +-',F11.5,' mb') |
| 20334 | WRITE(LOUT,1008) SIGDQE,ERRDQE |
| 20335 | 1008 FORMAT(1X,'diff-qel ',27X,F10.4,' +-',F11.5,' mb') |
| 20336 | ENDIF |
| 20337 | |
| 20338 | 2 CONTINUE |
| 20339 | 1 CONTINUE |
| 20340 | |
| 20341 | RETURN |
| 20342 | END |
| 20343 | * |
| 20344 | *===sigga==============================================================* |
| 20345 | * |
| 20346 | CDECK ID>, DT_SIGGA |
| 20347 | SUBROUTINE DT_SIGGA(NTI,XI,Q2I,ECMI,XNUI,STOT,ETOT,SIN,EIN,STOT0) |
| 20348 | |
| 20349 | ************************************************************************ |
| 20350 | * Total/inelastic photon-nucleus cross sections. * |
| 20351 | * !!!! Overwrites SHMAKI-initialization. Do not use it during * |
| 20352 | * production runs !!!! * |
| 20353 | * This version dated 27.03.96 is written by S. Roesler * |
| 20354 | ************************************************************************ |
| 20355 | |
| 20356 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 20357 | SAVE |
| 20358 | |
| 20359 | PARAMETER ( LINP = 5 , |
| 20360 | & LOUT = 6 , |
| 20361 | & LDAT = 9 ) |
| 20362 | |
| 20363 | PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10, |
| 20364 | & OHALF=0.5D0,ONE=1.0D0) |
| 20365 | PARAMETER (AMPROT = 0.938D0) |
| 20366 | |
| 20367 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 20368 | |
| 20369 | * Glauber formalism: cross sections |
| 20370 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, |
| 20371 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), |
| 20372 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), |
| 20373 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), |
| 20374 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), |
| 20375 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), |
| 20376 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), |
| 20377 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), |
| 20378 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), |
| 20379 | & BSLOPE,NEBINI,NQBINI |
| 20380 | |
| 20381 | NT = NTI |
| 20382 | X = XI |
| 20383 | Q2 = Q2I |
| 20384 | ECM = ECMI |
| 20385 | XNU = XNUI |
| 20386 | IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO)) |
| 20387 | & ECM = SQRT(AMPROT**2-Q2+2.0D0*XNUI*AMPROT) |
| 20388 | CALL DT_XSGLAU(1,NT,7,X,Q2,ECM,1,1,-1) |
| 20389 | STOT = XSTOT(1,1,1) |
| 20390 | ETOT = XETOT(1,1,1) |
| 20391 | SIN = XSPRO(1,1,1) |
| 20392 | EIN = XEPRO(1,1,1) |
| 20393 | |
| 20394 | RETURN |
| 20395 | END |
| 20396 | * |
| 20397 | *===siggat=============================================================* |
| 20398 | * |
| 20399 | CDECK ID>, DT_SIGGAT |
| 20400 | SUBROUTINE DT_SIGGAT(Q2I,ECMI,STOT,NT) |
| 20401 | |
| 20402 | ************************************************************************ |
| 20403 | * Total/inelastic photon-nucleus cross sections. * |
| 20404 | * Uses pre-tabulated cross section. * |
| 20405 | * This version dated 29.07.96 is written by S. Roesler * |
| 20406 | ************************************************************************ |
| 20407 | |
| 20408 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 20409 | SAVE |
| 20410 | |
| 20411 | PARAMETER ( LINP = 5 , |
| 20412 | & LOUT = 6 , |
| 20413 | & LDAT = 9 ) |
| 20414 | |
| 20415 | PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14, |
| 20416 | & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0) |
| 20417 | |
| 20418 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 20419 | |
| 20420 | * Glauber formalism: cross sections |
| 20421 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, |
| 20422 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), |
| 20423 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), |
| 20424 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), |
| 20425 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), |
| 20426 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), |
| 20427 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), |
| 20428 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), |
| 20429 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), |
| 20430 | & BSLOPE,NEBINI,NQBINI |
| 20431 | |
| 20432 | NTARG = ABS(NT) |
| 20433 | I1 = 1 |
| 20434 | I2 = 1 |
| 20435 | RATE = ONE |
| 20436 | IF (NEBINI.GT.1) THEN |
| 20437 | IF (ECMI.GE.ECMNN(NEBINI)) THEN |
| 20438 | I1 = NEBINI |
| 20439 | I2 = NEBINI |
| 20440 | RATE = ONE |
| 20441 | ELSEIF (ECMI.GT.ECMNN(1)) THEN |
| 20442 | DO 1 I=2,NEBINI |
| 20443 | IF (ECMI.LT.ECMNN(I)) THEN |
| 20444 | I1 = I-1 |
| 20445 | I2 = I |
| 20446 | RATE = (ECMI-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1)) |
| 20447 | GOTO 2 |
| 20448 | ENDIF |
| 20449 | 1 CONTINUE |
| 20450 | 2 CONTINUE |
| 20451 | ENDIF |
| 20452 | ENDIF |
| 20453 | J1 = 1 |
| 20454 | J2 = 1 |
| 20455 | RATQ = ONE |
| 20456 | IF (NQBINI.GT.1) THEN |
| 20457 | IF (Q2I.GE.Q2G(NQBINI)) THEN |
| 20458 | J1 = NQBINI |
| 20459 | J2 = NQBINI |
| 20460 | RATQ = ONE |
| 20461 | ELSEIF (Q2I.GT.Q2G(1)) THEN |
| 20462 | DO 3 I=2,NQBINI |
| 20463 | IF (Q2I.LT.Q2G(I)) THEN |
| 20464 | J1 = I-1 |
| 20465 | J2 = I |
| 20466 | RATQ = LOG10( Q2I/MAX(Q2G(J1),TINY14))/ |
| 20467 | & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14)) |
| 20468 | C RATQ = (Q2I-Q2G(J1))/(Q2G(J2)-Q2G(J1)) |
| 20469 | GOTO 4 |
| 20470 | ENDIF |
| 20471 | 3 CONTINUE |
| 20472 | 4 CONTINUE |
| 20473 | ENDIF |
| 20474 | ENDIF |
| 20475 | |
| 20476 | STOT = XSTOT(I1,J1,NTARG)+ |
| 20477 | & RATE*(XSTOT(I2,J1,NTARG)-XSTOT(I1,J1,NTARG))+ |
| 20478 | & RATQ*(XSTOT(I1,J2,NTARG)-XSTOT(I1,J1,NTARG))+ |
| 20479 | & RATE*RATQ*(XSTOT(I2,J2,NTARG)-XSTOT(I1,J2,NTARG)+ |
| 20480 | & XSTOT(I1,J1,NTARG)-XSTOT(I2,J1,NTARG)) |
| 20481 | |
| 20482 | RETURN |
| 20483 | END |
| 20484 | * |
| 20485 | *===sigano=============================================================* |
| 20486 | * |
| 20487 | CDECK ID>, DT_SANO |
| 20488 | DOUBLE PRECISION FUNCTION DT_SANO(ECM) |
| 20489 | |
| 20490 | ************************************************************************ |
| 20491 | * This version dated 31.07.96 is written by S. Roesler * |
| 20492 | ************************************************************************ |
| 20493 | |
| 20494 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 20495 | SAVE |
| 20496 | |
| 20497 | PARAMETER ( LINP = 5 , |
| 20498 | & LOUT = 6 , |
| 20499 | & LDAT = 9 ) |
| 20500 | |
| 20501 | PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14, |
| 20502 | & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0) |
| 20503 | PARAMETER (NE = 8) |
| 20504 | |
| 20505 | * VDM parameter for photon-nucleus interactions |
| 20506 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) |
| 20507 | * properties of interacting particles |
| 20508 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG |
| 20509 | |
| 20510 | DIMENSION ECMANO(NE),FRAANO(NE),SIGHRD(NE) |
| 20511 | DATA ECMANO / |
| 20512 | & 0.200D+02,0.500D+02,0.100D+03,0.200D+03,0.500D+03, |
| 20513 | & 0.100D+04,0.200D+04,0.500D+04 |
| 20514 | & / |
| 20515 | * fixed cut (3 GeV/c) |
| 20516 | DATA FRAANO / |
| 20517 | & 0.085D+00,0.114D+00,0.105D+00,0.091D+00,0.073D+00, |
| 20518 | & 0.062D+00,0.054D+00,0.042D+00 |
| 20519 | & / |
| 20520 | DATA SIGHRD / |
| 20521 | & 4.0099D-04,3.3104D-03,1.1905D-02,3.6435D-02,1.3493D-01, |
| 20522 | & 3.3086D-01,7.6255D-01,2.1319D+00 |
| 20523 | & / |
| 20524 | * running cut (based on obsolete Phojet-caluclations, bugs..) |
| 20525 | C DATA FRAANO / |
| 20526 | C & 0.251E+00,0.313E+00,0.279E+00,0.239E+00,0.186E+00, |
| 20527 | C & 0.167E+00,0.150E+00,0.131E+00 |
| 20528 | C & / |
| 20529 | C DATA SIGHRD / |
| 20530 | C & 6.6569E-04,4.4949E-03,1.4837E-02,4.1466E-02,1.5071E-01, |
| 20531 | C & 2.5736E-01,4.5593E-01,8.2550E-01 |
| 20532 | C & / |
| 20533 | |
| 20534 | DT_SANO = ZERO |
| 20535 | IF ((ISHAD(2).NE.1).OR.(IJPROJ.NE.7)) RETURN |
| 20536 | J1 = 0 |
| 20537 | J2 = 0 |
| 20538 | RATE = ONE |
| 20539 | IF (ECM.GE.ECMANO(NE)) THEN |
| 20540 | J1 = NE |
| 20541 | J2 = NE |
| 20542 | ELSEIF (ECM.GT.ECMANO(1)) THEN |
| 20543 | DO 1 IE=2,NE |
| 20544 | IF (ECM.LT.ECMANO(IE)) THEN |
| 20545 | J1 = IE-1 |
| 20546 | J2 = IE |
| 20547 | RATE = LOG10(ECM/ECMANO(J1))/LOG10(ECMANO(J2)/ECMANO(J1)) |
| 20548 | GOTO 2 |
| 20549 | ENDIF |
| 20550 | 1 CONTINUE |
| 20551 | 2 CONTINUE |
| 20552 | ENDIF |
| 20553 | IF ((J1.GT.0).AND.(J2.GT.0)) THEN |
| 20554 | AFRA1 = LOG10(MAX(FRAANO(J1)*SIGHRD(J1),TINY14)) |
| 20555 | AFRA2 = LOG10(MAX(FRAANO(J2)*SIGHRD(J2),TINY14)) |
| 20556 | DT_SANO = 10.0D0**(AFRA1+RATE*(AFRA2-AFRA1)) |
| 20557 | ENDIF |
| 20558 | |
| 20559 | RETURN |
| 20560 | END |
| 20561 | * |
| 20562 | *===siggp==============================================================* |
| 20563 | * |
| 20564 | CDECK ID>, DT_SIGGP |
| 20565 | SUBROUTINE DT_SIGGP(XI,Q2I,ECMI,XNUI,STOT,SINE,SDIR) |
| 20566 | |
| 20567 | ************************************************************************ |
| 20568 | * Total/inelastic photon-nucleon cross sections. * |
| 20569 | * This version dated 30.04.96 is written by S. Roesler * |
| 20570 | ************************************************************************ |
| 20571 | |
| 20572 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 20573 | SAVE |
| 20574 | |
| 20575 | PARAMETER ( LINP = 5 , |
| 20576 | & LOUT = 6 , |
| 20577 | & LDAT = 9 ) |
| 20578 | |
| 20579 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) |
| 20580 | PARAMETER (TWOPI = 6.283185307179586476925286766559D+00, |
| 20581 | & PI = TWOPI/TWO, |
| 20582 | & GEV2MB = 0.38938D0, |
| 20583 | & ALPHEM = ONE/137.0D0) |
| 20584 | |
| 20585 | * particle properties (BAMJET index convention) |
| 20586 | CHARACTER*8 ANAME |
| 20587 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 20588 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 20589 | * VDM parameter for photon-nucleus interactions |
| 20590 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) |
| 20591 | |
| 20592 | **PHOJET105a |
| 20593 | C CHARACTER*8 MDLNA |
| 20594 | C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100) |
| 20595 | C PARAMETER (IEETAB=10) |
| 20596 | C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX |
| 20597 | **PHOJET110 |
| 20598 | C model switches and parameters |
| 20599 | CHARACTER*8 MDLNA |
| 20600 | INTEGER ISWMDL,IPAMDL |
| 20601 | DOUBLE PRECISION PARMDL |
| 20602 | COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400) |
| 20603 | C energy-interpolation table |
| 20604 | INTEGER IEETA2 |
| 20605 | PARAMETER ( IEETA2 = 20 ) |
| 20606 | INTEGER ISIMAX |
| 20607 | DOUBLE PRECISION SIGTAB,SIGECM |
| 20608 | COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX |
| 20609 | ** |
| 20610 | |
| 20611 | C PARAMETER (NPOINT=80) |
| 20612 | PARAMETER (NPOINT=16) |
| 20613 | DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT) |
| 20614 | |
| 20615 | STOT = ZERO |
| 20616 | SINE = ZERO |
| 20617 | SDIR = ZERO |
| 20618 | |
| 20619 | W2 = ECMI**2 |
| 20620 | IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO)) |
| 20621 | & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1) |
| 20622 | Q2 = Q2I |
| 20623 | X = XI |
| 20624 | * photoprod. |
| 20625 | IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN |
| 20626 | Q2 = 0.0001D0 |
| 20627 | X = Q2/(W2+Q2-AAM(1)**2) |
| 20628 | * DIS |
| 20629 | ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN |
| 20630 | X = Q2/(W2+Q2-AAM(1)**2) |
| 20631 | ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN |
| 20632 | Q2 = (W2-AAM(1)**2)*X/(ONE-X) |
| 20633 | ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN |
| 20634 | W2 = Q2*(ONE-X)/X+AAM(1)**2 |
| 20635 | ELSE |
| 20636 | WRITE(LOUT,*) 'SIGGP: inconsistent input ',W2,Q2,X |
| 20637 | STOP |
| 20638 | ENDIF |
| 20639 | ECM = SQRT(W2) |
| 20640 | |
| 20641 | IF (MODEGA.EQ.1) THEN |
| 20642 | SCALE = SQRT(Q2) |
| 20643 | CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2, |
| 20644 | & IDPDF) |
| 20645 | C W = SQRT(W2) |
| 20646 | |
| 20647 | C ALLMF2 = PHO_ALLM97(Q2,W) |
| 20648 | |
| 20649 | C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2 |
| 20650 | STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB |
| 20651 | SINE = ZERO |
| 20652 | SDIR = ZERO |
| 20653 | ELSEIF (MODEGA.EQ.2) THEN |
| 20654 | IF (INTRGE(1).EQ.1) THEN |
| 20655 | AMLO2 = (3.0D0*AAM(13))**2 |
| 20656 | ELSEIF (INTRGE(1).EQ.2) THEN |
| 20657 | AMLO2 = AAM(33)**2 |
| 20658 | ELSE |
| 20659 | AMLO2 = AAM(96)**2 |
| 20660 | ENDIF |
| 20661 | IF (INTRGE(2).EQ.1) THEN |
| 20662 | AMHI2 = W2/TWO |
| 20663 | ELSEIF (INTRGE(2).EQ.2) THEN |
| 20664 | AMHI2 = W2/4.0D0 |
| 20665 | ELSE |
| 20666 | AMHI2 = W2 |
| 20667 | ENDIF |
| 20668 | AMHI20 = (ECM-AAM(1))**2 |
| 20669 | IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20 |
| 20670 | XAMLO = LOG( AMLO2+Q2 ) |
| 20671 | XAMHI = LOG( AMHI2+Q2 ) |
| 20672 | **PHOJET105a |
| 20673 | C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT) |
| 20674 | **PHOJET112 |
| 20675 | |
| 20676 | CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT) |
| 20677 | |
| 20678 | ** |
| 20679 | SUM = ZERO |
| 20680 | DO 1 J=1,NPOINT |
| 20681 | AM2 = EXP(ABSZX(J))-Q2 |
| 20682 | IF (AM2.LT.16.0D0) THEN |
| 20683 | R = TWO |
| 20684 | ELSEIF ((AM2.GE.16.0D0).AND.(AM2.LT.121.0D0)) THEN |
| 20685 | R = 10.0D0/3.0D0 |
| 20686 | ELSE |
| 20687 | R = 11.0D0/3.0D0 |
| 20688 | ENDIF |
| 20689 | C FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) ) |
| 20690 | FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) ) |
| 20691 | & * (ONE+EPSPOL*Q2/AM2) |
| 20692 | SUM = SUM+WEIGHT(J)*FAC |
| 20693 | 1 CONTINUE |
| 20694 | SINE = SUM |
| 20695 | SDIR = DT_SIGVP(X,Q2) |
| 20696 | STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*SDIR |
| 20697 | SDIR = SDIR/(0.588D0+RL2+Q2) |
| 20698 | C STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*DT_SIGVP(X,Q2) |
| 20699 | ELSEIF (MODEGA.EQ.3) THEN |
| 20700 | CALL DT_SIGGA(1,XI,Q2I,ECMI,ZERO,STOT,ETOT,SINE,EINE,DUM) |
| 20701 | ELSEIF (MODEGA.EQ.4) THEN |
| 20702 | * load cross sections from PHOJET interpolation table |
| 20703 | IP = 1 |
| 20704 | IF(ECM.LE.SIGECM(IP,1)) THEN |
| 20705 | I1 = 1 |
| 20706 | I2 = 1 |
| 20707 | ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN |
| 20708 | DO 2 I=2,ISIMAX |
| 20709 | IF (ECM.LE.SIGECM(IP,I)) GOTO 3 |
| 20710 | 2 CONTINUE |
| 20711 | 3 CONTINUE |
| 20712 | I1 = I-1 |
| 20713 | I2 = I |
| 20714 | ELSE |
| 20715 | WRITE(LOUT,'(/1X,A,2E12.3)') |
| 20716 | & 'SIGGP:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX) |
| 20717 | I1 = ISIMAX |
| 20718 | I2 = ISIMAX |
| 20719 | ENDIF |
| 20720 | FAC2 = ZERO |
| 20721 | IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1)) |
| 20722 | & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1)) |
| 20723 | FAC1 = ONE-FAC2 |
| 20724 | * cross section dependence on photon virtuality |
| 20725 | FSUP1 = ZERO |
| 20726 | DO 4 I=1,3 |
| 20727 | FSUP1 = FSUP1+PARMDL(26+I)*(1.D0+Q2/(4.D0*PARMDL(30+I))) |
| 20728 | & /(1.D0+Q2/PARMDL(30+I))**2 |
| 20729 | 4 CONTINUE |
| 20730 | FSUP1 = FSUP1+PARMDL(30)/(1.D0+Q2/PARMDL(34)) |
| 20731 | FAC1 = FAC1*FSUP1 |
| 20732 | FAC2 = FAC2*FSUP1 |
| 20733 | FSUP2 = 1.0D0 |
| 20734 | STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1) |
| 20735 | SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1) |
| 20736 | SDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1) |
| 20737 | **re: |
| 20738 | STOT = STOT-SDIR |
| 20739 | ** |
| 20740 | SDIR = SDIR/(FSUP1*FSUP2) |
| 20741 | **re: |
| 20742 | STOT = STOT+SDIR |
| 20743 | ** |
| 20744 | ENDIF |
| 20745 | |
| 20746 | RETURN |
| 20747 | END |
| 20748 | * |
| 20749 | *===sigvel=============================================================* |
| 20750 | * |
| 20751 | CDECK ID>, DT_SIGVEL |
| 20752 | SUBROUTINE DT_SIGVEL(XI,Q2I,ECMI,XNUI,IDXV,SVEL,SIG1,SIG2) |
| 20753 | |
| 20754 | ************************************************************************ |
| 20755 | * Cross section for elastic vector meson production * |
| 20756 | * This version dated 10.05.96 is written by S. Roesler * |
| 20757 | ************************************************************************ |
| 20758 | |
| 20759 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 20760 | SAVE |
| 20761 | |
| 20762 | PARAMETER ( LINP = 5 , |
| 20763 | & LOUT = 6 , |
| 20764 | & LDAT = 9 ) |
| 20765 | |
| 20766 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) |
| 20767 | PARAMETER (TWOPI = 6.283185307179586476925286766559D+00, |
| 20768 | & PI = TWOPI/TWO, |
| 20769 | & GEV2MB = 0.38938D0, |
| 20770 | & ALPHEM = ONE/137.0D0) |
| 20771 | |
| 20772 | * particle properties (BAMJET index convention) |
| 20773 | CHARACTER*8 ANAME |
| 20774 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 20775 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 20776 | * VDM parameter for photon-nucleus interactions |
| 20777 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) |
| 20778 | |
| 20779 | W2 = ECMI**2 |
| 20780 | IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO)) |
| 20781 | & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1) |
| 20782 | Q2 = Q2I |
| 20783 | X = XI |
| 20784 | * photoprod. |
| 20785 | IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN |
| 20786 | Q2 = 0.0001D0 |
| 20787 | X = Q2/(W2+Q2-AAM(1)**2) |
| 20788 | * DIS |
| 20789 | ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN |
| 20790 | X = Q2/(W2+Q2-AAM(1)**2) |
| 20791 | ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN |
| 20792 | Q2 = (W2-AAM(1)**2)*X/(ONE-X) |
| 20793 | ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN |
| 20794 | W2 = Q2*(ONE-X)/X+AAM(1)**2 |
| 20795 | ELSE |
| 20796 | WRITE(LOUT,*) 'SIGVEL: inconsistent input ',W2,Q2,X |
| 20797 | STOP |
| 20798 | ENDIF |
| 20799 | ECM = SQRT(W2) |
| 20800 | |
| 20801 | AMV = AAM(IDXV) |
| 20802 | AMV2 = AMV**2 |
| 20803 | |
| 20804 | BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2) |
| 20805 | & +0.25D0*LOG(W2/(AMV2+Q2)))*GEV2MB |
| 20806 | ROSH = 0.1D0 |
| 20807 | STOVP = DT_SIGVP(X,Q2)/(AMV2+Q2+RL2) |
| 20808 | SELVP = STOVP**2*(ONE+ROSH**2)/(8.0D0*TWOPI*BSLOPE) |
| 20809 | |
| 20810 | IF (IDXV.EQ.33) THEN |
| 20811 | COUPL = 0.00365D0 |
| 20812 | ELSE |
| 20813 | STOP |
| 20814 | ENDIF |
| 20815 | SIG1 = (AMV2/(AMV2+Q2))**2 * (ONE+EPSPOL*Q2/AMV2) |
| 20816 | SIG2 = SELVP |
| 20817 | SVEL = COUPL * (AMV2/(AMV2+Q2))**2 |
| 20818 | & * (ONE+EPSPOL*Q2/AMV2) * SELVP |
| 20819 | |
| 20820 | RETURN |
| 20821 | END |
| 20822 | * |
| 20823 | *===sigvp==============================================================* |
| 20824 | * |
| 20825 | CDECK ID>, DT_SIGVP |
| 20826 | DOUBLE PRECISION FUNCTION DT_SIGVP(XI,Q2I) |
| 20827 | |
| 20828 | ************************************************************************ |
| 20829 | * sigma_Vp * |
| 20830 | ************************************************************************ |
| 20831 | |
| 20832 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 20833 | SAVE |
| 20834 | |
| 20835 | PARAMETER ( LINP = 5 , |
| 20836 | & LOUT = 6 , |
| 20837 | & LDAT = 9 ) |
| 20838 | |
| 20839 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) |
| 20840 | PARAMETER (TWOPI = 6.283185307179586476925286766559D+00, |
| 20841 | & PI = TWOPI/TWO, |
| 20842 | & GEV2MB = 0.38938D0, |
| 20843 | & AMPROT = 0.938D0, |
| 20844 | & ALPHEM = ONE/137.0D0) |
| 20845 | * VDM parameter for photon-nucleus interactions |
| 20846 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) |
| 20847 | |
| 20848 | X = XI |
| 20849 | Q2 = Q2I |
| 20850 | IF (XI.LE.ZERO) X = 0.0001D0 |
| 20851 | IF (Q2I.LE.ZERO) Q2 = 0.0001D0 |
| 20852 | |
| 20853 | ECM = SQRT( Q2*(ONE-X)/X+AMPROT**2 ) |
| 20854 | |
| 20855 | SCALE = SQRT(Q2) |
| 20856 | IF (MODEGA.EQ.1) THEN |
| 20857 | CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2, |
| 20858 | & IDPDF) |
| 20859 | C W = ECM |
| 20860 | |
| 20861 | C ALLMF2 = PHO_ALLM97(Q2,W) |
| 20862 | |
| 20863 | C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2 |
| 20864 | C STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB |
| 20865 | C DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2)) |
| 20866 | DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))*GEV2MB |
| 20867 | ELSEIF (MODEGA.EQ.4) THEN |
| 20868 | CALL DT_SIGGP(X,Q2,ECM,DUM1,STOT,DUM2,DUM3) |
| 20869 | C F2 = Q2*(ONE-X)/(TWOPI**2*ALPHEM*GEV2MB) * STOT |
| 20870 | DT_SIGVP = 3.0D0*PI/(ALPHEM*DT_RRM2(X,Q2)) * STOT |
| 20871 | ELSE |
| 20872 | STOP ' DT_SIGVP: F2 not defined for this MODEGA !' |
| 20873 | ENDIF |
| 20874 | |
| 20875 | RETURN |
| 20876 | |
| 20877 | END |
| 20878 | * |
| 20879 | *===RRM2===============================================================* |
| 20880 | * |
| 20881 | CDECK ID>, DT_RRM2 |
| 20882 | DOUBLE PRECISION FUNCTION DT_RRM2(X,Q2) |
| 20883 | |
| 20884 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 20885 | SAVE |
| 20886 | |
| 20887 | PARAMETER ( LINP = 5 , |
| 20888 | & LOUT = 6 , |
| 20889 | & LDAT = 9 ) |
| 20890 | |
| 20891 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) |
| 20892 | PARAMETER (TWOPI = 6.283185307179586476925286766559D+00, |
| 20893 | & PI = TWOPI/TWO, |
| 20894 | & GEV2MB = 0.38938D0) |
| 20895 | |
| 20896 | * particle properties (BAMJET index convention) |
| 20897 | CHARACTER*8 ANAME |
| 20898 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 20899 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 20900 | * VDM parameter for photon-nucleus interactions |
| 20901 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) |
| 20902 | |
| 20903 | S = Q2*(ONE-X)/X+AAM(1)**2 |
| 20904 | ECM = SQRT(S) |
| 20905 | |
| 20906 | IF (INTRGE(1).EQ.1) THEN |
| 20907 | AMLO2 = (3.0D0*AAM(13))**2 |
| 20908 | ELSEIF (INTRGE(1).EQ.2) THEN |
| 20909 | AMLO2 = AAM(33)**2 |
| 20910 | ELSE |
| 20911 | AMLO2 = AAM(96)**2 |
| 20912 | ENDIF |
| 20913 | IF (INTRGE(2).EQ.1) THEN |
| 20914 | AMHI2 = S/TWO |
| 20915 | ELSEIF (INTRGE(2).EQ.2) THEN |
| 20916 | AMHI2 = S/4.0D0 |
| 20917 | ELSE |
| 20918 | AMHI2 = S |
| 20919 | ENDIF |
| 20920 | AMHI20 = (ECM-AAM(1))**2 |
| 20921 | IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20 |
| 20922 | |
| 20923 | AM1C2 = 16.0D0 |
| 20924 | AM2C2 = 121.0D0 |
| 20925 | IF (AMHI2.LE.AM1C2) THEN |
| 20926 | DT_RRM2 = TWO*DT_RM2(AMLO2,AMHI2,Q2) |
| 20927 | ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN |
| 20928 | DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+ |
| 20929 | & 10.0D0/3.0D0*DT_RM2(AM1C2,AMHI2,Q2) |
| 20930 | ELSE |
| 20931 | DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+ |
| 20932 | & 10.0D0/3.0D0*DT_RM2(AM1C2,AM2C2,Q2)+ |
| 20933 | & 11.0D0/3.0D0*DT_RM2(AM2C2,AMHI2,Q2) |
| 20934 | ENDIF |
| 20935 | |
| 20936 | RETURN |
| 20937 | END |
| 20938 | * |
| 20939 | *===RM2================================================================* |
| 20940 | * |
| 20941 | CDECK ID>, DT_RM2 |
| 20942 | DOUBLE PRECISION FUNCTION DT_RM2(AMLO2,AMHI2,Q2) |
| 20943 | |
| 20944 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 20945 | SAVE |
| 20946 | |
| 20947 | PARAMETER ( LINP = 5 , |
| 20948 | & LOUT = 6 , |
| 20949 | & LDAT = 9 ) |
| 20950 | |
| 20951 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) |
| 20952 | PARAMETER (TWOPI = 6.283185307179586476925286766559D+00, |
| 20953 | & PI = TWOPI/TWO, |
| 20954 | & GEV2MB = 0.38938D0) |
| 20955 | * VDM parameter for photon-nucleus interactions |
| 20956 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) |
| 20957 | |
| 20958 | IF (RL2.LE.ZERO) THEN |
| 20959 | DT_RM2 = -ONE/(AMHI2+Q2)+Q2/(TWO*(AMHI2+Q2)**2) - |
| 20960 | & (-ONE/(AMLO2+Q2)+Q2/(TWO*(AMLO2+Q2)**2)) |
| 20961 | & +EPSPOL*(-Q2/(TWO*(AMHI2+Q2)**2)+Q2/(TWO*(AMLO2+Q2)**2)) |
| 20962 | ELSE |
| 20963 | TMPMLO = LOG(ONE+RL2/(AMLO2+Q2)) |
| 20964 | TMPMHI = LOG(ONE+RL2/(AMHI2+Q2)) |
| 20965 | DT_RM2 = Q2/(RL2*(AMHI2+Q2))-(Q2+RL2)/RL2**2*TMPMHI |
| 20966 | & -(Q2/(RL2*(AMLO2+Q2))-(Q2+RL2)/RL2**2*TMPMLO) |
| 20967 | & +EPSPOL*( |
| 20968 | & -Q2/(RL2*(AMHI2+Q2))+Q2/RL2**2*TMPMHI |
| 20969 | & -(-Q2/(RL2*(AMLO2+Q2))+Q2/RL2**2*TMPMLO)) |
| 20970 | ENDIF |
| 20971 | |
| 20972 | RETURN |
| 20973 | END |
| 20974 | * |
| 20975 | *===SAM2===============================================================* |
| 20976 | * |
| 20977 | CDECK ID>, DT_SAM2 |
| 20978 | DOUBLE PRECISION FUNCTION DT_SAM2(Q2,ECM) |
| 20979 | |
| 20980 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 20981 | SAVE |
| 20982 | |
| 20983 | PARAMETER ( LINP = 5 , |
| 20984 | & LOUT = 6 , |
| 20985 | & LDAT = 9 ) |
| 20986 | |
| 20987 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0, |
| 20988 | & TENTRD=10.0D0/3.0D0,ELVTRD=11.0D0/3.0D0) |
| 20989 | PARAMETER (TWOPI = 6.283185307179586476925286766559D+00, |
| 20990 | & PI = TWOPI/TWO, |
| 20991 | & GEV2MB = 0.38938D0) |
| 20992 | |
| 20993 | * particle properties (BAMJET index convention) |
| 20994 | CHARACTER*8 ANAME |
| 20995 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 20996 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 20997 | * VDM parameter for photon-nucleus interactions |
| 20998 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) |
| 20999 | |
| 21000 | S = ECM**2 |
| 21001 | IF (INTRGE(1).EQ.1) THEN |
| 21002 | AMLO2 = (3.0D0*AAM(13))**2 |
| 21003 | ELSEIF (INTRGE(1).EQ.2) THEN |
| 21004 | AMLO2 = AAM(33)**2 |
| 21005 | ELSE |
| 21006 | AMLO2 = AAM(96)**2 |
| 21007 | ENDIF |
| 21008 | IF (INTRGE(2).EQ.1) THEN |
| 21009 | AMHI2 = S/TWO |
| 21010 | ELSEIF (INTRGE(2).EQ.2) THEN |
| 21011 | AMHI2 = S/4.0D0 |
| 21012 | ELSE |
| 21013 | AMHI2 = S |
| 21014 | ENDIF |
| 21015 | AMHI20 = (ECM-AAM(1))**2 |
| 21016 | IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20 |
| 21017 | |
| 21018 | AM1C2 = 16.0D0 |
| 21019 | AM2C2 = 121.0D0 |
| 21020 | YLO = LOG(AMLO2+Q2) |
| 21021 | YC1 = LOG(AM1C2+Q2) |
| 21022 | YC2 = LOG(AM2C2+Q2) |
| 21023 | YHI = LOG(AMHI2+Q2) |
| 21024 | IF (AMHI2.LE.AM1C2) THEN |
| 21025 | FACHI = TWO |
| 21026 | ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN |
| 21027 | FACHI = TENTRD |
| 21028 | ELSE |
| 21029 | FACHI = ELVTRD |
| 21030 | ENDIF |
| 21031 | |
| 21032 | 1 CONTINUE |
| 21033 | YSAM2 = YLO+(YHI-YLO)*DT_RNDM(AM1C2) |
| 21034 | IF (YSAM2.LE.YC1) THEN |
| 21035 | FAC = TWO |
| 21036 | ELSEIF ((YSAM2.GT.YC1).AND.(YSAM2.LE.YC2)) THEN |
| 21037 | FAC = TENTRD |
| 21038 | ELSE |
| 21039 | FAC = ELVTRD |
| 21040 | ENDIF |
| 21041 | WEIGMX = FACHI*(ONE-Q2*EXP( -YHI)) |
| 21042 | XSAM2 = FAC *(ONE-Q2*EXP(-YSAM2)) |
| 21043 | IF (DT_RNDM(YSAM2)*WEIGMX.GT.XSAM2) GOTO 1 |
| 21044 | |
| 21045 | DT_SAM2 = EXP(YSAM2)-Q2 |
| 21046 | |
| 21047 | RETURN |
| 21048 | END |
| 21049 | * |
| 21050 | *===ckmt===============================================================* |
| 21051 | * |
| 21052 | CDECK ID>, DT_CKMT |
| 21053 | SUBROUTINE DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL, |
| 21054 | & F2,IPAR) |
| 21055 | |
| 21056 | ************************************************************************ |
| 21057 | * This version dated 31.01.96 is written by S. Roesler * |
| 21058 | ************************************************************************ |
| 21059 | |
| 21060 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 21061 | SAVE |
| 21062 | |
| 21063 | PARAMETER ( LINP = 5 , |
| 21064 | & LOUT = 6 , |
| 21065 | & LDAT = 9 ) |
| 21066 | |
| 21067 | PARAMETER (ZERO=0.0D0,TWO=2.0D0,TINY10=1.0D-10) |
| 21068 | |
| 21069 | PARAMETER (Q02 = 2.0D0, |
| 21070 | & DQ2 = 10.05D0, |
| 21071 | & Q12 = Q02+DQ2) |
| 21072 | |
| 21073 | DIMENSION PD(-6:6),SEA(3),VAL(2) |
| 21074 | |
| 21075 | CALL DT_PDF0(Q02,X,F2Q0,VAL,SEA,GLU,IPAR) |
| 21076 | CALL DT_PDF0(Q12,X,F2Q1,VAL,SEA,GLU,IPAR) |
| 21077 | ADQ2 = LOG10(Q12)-LOG10(Q02) |
| 21078 | F2P = (F2Q1-F2Q0)/ADQ2 |
| 21079 | CALL DT_CKMTX(IPAR,X,Q02,PD,F2PQ0) |
| 21080 | CALL DT_CKMTX(IPAR,X,Q12,PD,F2PQ1) |
| 21081 | F2PP = (F2PQ1-F2PQ0)/ADQ2 |
| 21082 | FX = (F2P-F2PP)/(F2PP+LOG(DQ2)*F2PQ0+TINY10)*Q02 |
| 21083 | |
| 21084 | Q2 = MAX(SCALE**2.0D0,TINY10) |
| 21085 | SMOOTH = 1.0D0+FX*(Q2-Q02)/Q2**2 |
| 21086 | IF (Q2.LT.Q02) THEN |
| 21087 | CALL DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR) |
| 21088 | UPV = VAL(1) |
| 21089 | DNV = VAL(2) |
| 21090 | USEA = SEA(1) |
| 21091 | DSEA = SEA(2) |
| 21092 | STR = SEA(3) |
| 21093 | CHM = 0.0D0 |
| 21094 | BOT = 0.0D0 |
| 21095 | TOP = 0.0D0 |
| 21096 | GL = GLU |
| 21097 | ELSE |
| 21098 | CALL DT_CKMTX(IPAR,X,Q2,PD,F2) |
| 21099 | F2 = F2*SMOOTH |
| 21100 | UPV = PD(2)-PD(3) |
| 21101 | DNV = PD(1)-PD(3) |
| 21102 | USEA = PD(3) |
| 21103 | DSEA = PD(3) |
| 21104 | STR = PD(3) |
| 21105 | CHM = PD(4) |
| 21106 | BOT = PD(5) |
| 21107 | TOP = PD(6) |
| 21108 | GL = PD(0) |
| 21109 | C UPV = UPV*SMOOTH |
| 21110 | C DNV = DNV*SMOOTH |
| 21111 | C USEA = USEA*SMOOTH |
| 21112 | C DSEA = DSEA*SMOOTH |
| 21113 | C STR = STR*SMOOTH |
| 21114 | C CHM = CHM*SMOOTH |
| 21115 | C GL = GL*SMOOTH |
| 21116 | ENDIF |
| 21117 | |
| 21118 | RETURN |
| 21119 | END |
| 21120 | C |
| 21121 | CDECK ID>, DT_CKMTX |
| 21122 | SUBROUTINE DT_CKMTX(IPAR,X,SCALE2,PD,F2) |
| 21123 | C********************************************************************** |
| 21124 | C |
| 21125 | C PDF based on Regge theory, evolved with .... by .... |
| 21126 | C |
| 21127 | C input: IPAR 2212 proton (not installed) |
| 21128 | C 45 Pomeron |
| 21129 | C 100 Deuteron |
| 21130 | C |
| 21131 | C output: PD(-6:6) x*f(x) parton distribution functions |
| 21132 | C (PDFLIB convention: d = PD(1), u = PD(2) ) |
| 21133 | C |
| 21134 | C********************************************************************** |
| 21135 | |
| 21136 | SAVE |
| 21137 | DOUBLE PRECISION X,SCALE2,PD(-6:6),CDN,CUP,F2 |
| 21138 | |
| 21139 | PARAMETER ( LINP = 5 , |
| 21140 | & LOUT = 6 , |
| 21141 | & LDAT = 9 ) |
| 21142 | |
| 21143 | DIMENSION QQ(7) |
| 21144 | C |
| 21145 | Q2=SNGL(SCALE2) |
| 21146 | Q1S=Q2 |
| 21147 | XX=SNGL(X) |
| 21148 | C QCD lambda for evolution |
| 21149 | OWLAM = 0.23D0 |
| 21150 | OWLAM2=OWLAM**2 |
| 21151 | C Q0**2 for evolution |
| 21152 | Q02 = 2.D0 |
| 21153 | C |
| 21154 | C |
| 21155 | C the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=... |
| 21156 | C q(6)=x*charm, q(7)=x*gluon |
| 21157 | C |
| 21158 | SB=0. |
| 21159 | IF(Q2-Q02) 1,1,2 |
| 21160 | 2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2)) |
| 21161 | 1 CONTINUE |
| 21162 | IF(IPAR.EQ.2212) THEN |
| 21163 | CALL DT_CKMTPR(1,0,XX,SB,QQ(1)) |
| 21164 | CALL DT_CKMTPR(2,0,XX,SB,QQ(2)) |
| 21165 | CALL DT_CKMTPR(3,0,XX,SB,QQ(3)) |
| 21166 | CALL DT_CKMTPR(4,0,XX,SB,QQ(4)) |
| 21167 | CALL DT_CKMTPR(5,0,XX,SB,QQ(5)) |
| 21168 | CALL DT_CKMTPR(8,0,XX,SB,QQ(6)) |
| 21169 | CALL DT_CKMTPR(7,0,XX,SB,QQ(7)) |
| 21170 | C ELSEIF (IPAR.EQ.45) THEN |
| 21171 | C CALL CKMTPO(1,0,XX,SB,QQ(1)) |
| 21172 | C CALL CKMTPO(2,0,XX,SB,QQ(2)) |
| 21173 | C CALL CKMTPO(3,0,XX,SB,QQ(3)) |
| 21174 | C CALL CKMTPO(4,0,XX,SB,QQ(4)) |
| 21175 | C CALL CKMTPO(5,0,XX,SB,QQ(5)) |
| 21176 | C CALL CKMTPO(8,0,XX,SB,QQ(6)) |
| 21177 | C CALL CKMTPO(7,0,XX,SB,QQ(7)) |
| 21178 | ELSEIF (IPAR.EQ.100) THEN |
| 21179 | CALL DT_CKMTDE(1,0,XX,SB,QQ(1)) |
| 21180 | CALL DT_CKMTDE(2,0,XX,SB,QQ(2)) |
| 21181 | CALL DT_CKMTDE(3,0,XX,SB,QQ(3)) |
| 21182 | CALL DT_CKMTDE(4,0,XX,SB,QQ(4)) |
| 21183 | CALL DT_CKMTDE(5,0,XX,SB,QQ(5)) |
| 21184 | CALL DT_CKMTDE(8,0,XX,SB,QQ(6)) |
| 21185 | CALL DT_CKMTDE(7,0,XX,SB,QQ(7)) |
| 21186 | ELSE |
| 21187 | WRITE(LOUT,'(1X,A,I4,A)') |
| 21188 | & 'CKMTX: IPAR =',IPAR,' not implemented!' |
| 21189 | STOP |
| 21190 | ENDIF |
| 21191 | C |
| 21192 | PD(-6) = 0.D0 |
| 21193 | PD(-5) = 0.D0 |
| 21194 | PD(-4) = DBLE(QQ(6)) |
| 21195 | PD(-3) = DBLE(QQ(3)) |
| 21196 | PD(-2) = DBLE(QQ(4)) |
| 21197 | PD(-1) = DBLE(QQ(5)) |
| 21198 | PD(0) = DBLE(QQ(7)) |
| 21199 | PD(1) = DBLE(QQ(2)) |
| 21200 | PD(2) = DBLE(QQ(1)) |
| 21201 | PD(3) = DBLE(QQ(3)) |
| 21202 | PD(4) = DBLE(QQ(6)) |
| 21203 | PD(5) = 0.D0 |
| 21204 | PD(6) = 0.D0 |
| 21205 | IF(IPAR.EQ.45) THEN |
| 21206 | CDN = (PD(1)-PD(-1))/2.D0 |
| 21207 | CUP = (PD(2)-PD(-2))/2.D0 |
| 21208 | PD(-1) = PD(-1) + CDN |
| 21209 | PD(-2) = PD(-2) + CUP |
| 21210 | PD(1) = PD(-1) |
| 21211 | PD(2) = PD(-2) |
| 21212 | ENDIF |
| 21213 | F2 = 4.0D0/9.0D0*(PD(2)-PD(3)+2.0D0*PD(3))+ |
| 21214 | & 1.0D0/9.0D0*(PD(1)-PD(3)+2.0D0*PD(3))+ |
| 21215 | & 1.0D0/9.0D0*(2.0D0*PD(3))+4.0D0/9.0D0*(2.0D0*PD(4)) |
| 21216 | END |
| 21217 | C |
| 21218 | * |
| 21219 | *===pdf0===============================================================* |
| 21220 | * |
| 21221 | CDECK ID>, DT_PDF0 |
| 21222 | SUBROUTINE DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR) |
| 21223 | |
| 21224 | ************************************************************************ |
| 21225 | * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 * |
| 21226 | * an F_2-ansatz given in Capella et al. PLB 337(1994)358. * |
| 21227 | * IPAR = 2212 proton * |
| 21228 | * = 100 deuteron * |
| 21229 | * This version dated 31.01.96 is written by S. Roesler * |
| 21230 | ************************************************************************ |
| 21231 | |
| 21232 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 21233 | SAVE |
| 21234 | |
| 21235 | PARAMETER ( LINP = 5 , |
| 21236 | & LOUT = 6 , |
| 21237 | & LDAT = 9 ) |
| 21238 | |
| 21239 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9) |
| 21240 | |
| 21241 | PARAMETER ( |
| 21242 | & AA = 0.1502D0, |
| 21243 | & BBDEU = 1.2D0, |
| 21244 | & BUD = 0.754D0, |
| 21245 | & BDD = 0.4495D0, |
| 21246 | & BUP = 1.2064D0, |
| 21247 | & BDP = 0.1798D0, |
| 21248 | & DELTA0 = 0.07684D0, |
| 21249 | & D = 1.117D0, |
| 21250 | & C = 3.5489D0, |
| 21251 | & A = 0.2631D0, |
| 21252 | & B = 0.6452D0, |
| 21253 | & ALPHAR = 0.415D0, |
| 21254 | & E = 0.1D0 |
| 21255 | & ) |
| 21256 | |
| 21257 | PARAMETER (NPOINT=16) |
| 21258 | C DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT) |
| 21259 | DIMENSION SEA(3),VAL(2) |
| 21260 | |
| 21261 | DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D)) |
| 21262 | AN = 1.5D0*(1.0D0+Q2/(Q2+C)) |
| 21263 | * proton, deuteron |
| 21264 | IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN |
| 21265 | CALL DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0) |
| 21266 | SEA(1) = 0.75D0*SEA0 |
| 21267 | SEA(2) = SEA(1) |
| 21268 | SEA(3) = SEA(1) |
| 21269 | VAL(1) = 9.0D0/4.0D0*VALU0 |
| 21270 | VAL(2) = 9.0D0*VALD0 |
| 21271 | GLU0 = SEA(1)/(1.0D0-X) |
| 21272 | F2 = SEA0+VALU0+VALD0 |
| 21273 | F2PDF = 4.0D0/9.0D0*(VAL(1)+2.0D0*SEA(1))+ |
| 21274 | & 1.0D0/9.0D0*(VAL(2)+2.0D0*SEA(2))+ |
| 21275 | & 1.0D0/9.0D0*(2.0D0*SEA(3)) |
| 21276 | IF (ABS(F2-F2PDF).GT.TINY9) THEN |
| 21277 | WRITE(LOUT,'(1X,A,2E15.5)') 'inconsistent PDF! ',F2,F2PDF |
| 21278 | STOP |
| 21279 | ENDIF |
| 21280 | **PHOJET105a |
| 21281 | C CALL GSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT) |
| 21282 | **PHOJET112 |
| 21283 | |
| 21284 | C CALL PHO_GAUSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT) |
| 21285 | |
| 21286 | ** |
| 21287 | C SUMQ = ZERO |
| 21288 | C SUMG = ZERO |
| 21289 | C DO 1 J=1,NPOINT |
| 21290 | C CALL DT_CKMTQ0(Q2,ABSZX(J),IPAR,VALU0,VALD0,SEA0) |
| 21291 | C VALU0 = 9.0D0/4.0D0*VALU0 |
| 21292 | C VALD0 = 9.0D0*VALD0 |
| 21293 | C SEA0 = 0.75D0*SEA0 |
| 21294 | C SUMQ = SUMQ+ (VALU0+VALD0+6.0D0*SEA0) *WEIGHT(J) |
| 21295 | C SUMG = SUMG+ (SEA0/(1.0D0-ABSZX(J))) *WEIGHT(J) |
| 21296 | C 1 CONTINUE |
| 21297 | C GLU = GLU0*(1.0D0-SUMQ)/SUMG |
| 21298 | ELSE |
| 21299 | WRITE(LOUT,'(1X,A,I4,A)') |
| 21300 | & 'PDF0: IPAR =',IPAR,' not implemented!' |
| 21301 | STOP |
| 21302 | ENDIF |
| 21303 | |
| 21304 | RETURN |
| 21305 | END |
| 21306 | * |
| 21307 | *===ckmtq0=============================================================* |
| 21308 | * |
| 21309 | CDECK ID>, DT_CKMTQ0 |
| 21310 | SUBROUTINE DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0) |
| 21311 | |
| 21312 | ************************************************************************ |
| 21313 | * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 * |
| 21314 | * an F_2-ansatz given in Capella et al. PLB 337(1994)358. * |
| 21315 | * IPAR = 2212 proton * |
| 21316 | * = 100 deuteron * |
| 21317 | * This version dated 31.01.96 is written by S. Roesler * |
| 21318 | ************************************************************************ |
| 21319 | |
| 21320 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 21321 | SAVE |
| 21322 | |
| 21323 | PARAMETER ( LINP = 5 , |
| 21324 | & LOUT = 6 , |
| 21325 | & LDAT = 9 ) |
| 21326 | |
| 21327 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9) |
| 21328 | |
| 21329 | PARAMETER ( |
| 21330 | & AA = 0.1502D0, |
| 21331 | & BBDEU = 1.2D0, |
| 21332 | & BUD = 0.754D0, |
| 21333 | & BDD = 0.4495D0, |
| 21334 | & BUP = 1.2064D0, |
| 21335 | & BDP = 0.1798D0, |
| 21336 | & DELTA0 = 0.07684D0, |
| 21337 | & D = 1.117D0, |
| 21338 | & C = 3.5489D0, |
| 21339 | & A = 0.2631D0, |
| 21340 | & B = 0.6452D0, |
| 21341 | & ALPHAR = 0.415D0, |
| 21342 | & E = 0.1D0 |
| 21343 | & ) |
| 21344 | |
| 21345 | DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D)) |
| 21346 | AN = 1.5D0*(1.0D0+Q2/(Q2+C)) |
| 21347 | * proton, deuteron |
| 21348 | IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN |
| 21349 | IF (IPAR.EQ.2212) THEN |
| 21350 | BU = BUP |
| 21351 | BD = BDP |
| 21352 | ELSE |
| 21353 | BU = BUD |
| 21354 | BD = BDD |
| 21355 | ENDIF |
| 21356 | SEA0 = AA*X**(-DELTA)*(1.0D0-X)**(AN+4.0D0)* |
| 21357 | & (Q2/(Q2+A))**(1.0D0+DELTA) |
| 21358 | VALU0 = BU*X**(1.0D0-ALPHAR)*(1.0D0-X)**AN* |
| 21359 | & (Q2/(Q2+B))**(ALPHAR) |
| 21360 | VALD0 = BD*X**(1.0D0-ALPHAR)*(1.0D0-X)**(AN+1.0D0)* |
| 21361 | & (Q2/(Q2+B))**(ALPHAR) |
| 21362 | ELSE |
| 21363 | WRITE(LOUT,'(1X,A,I4,A)') |
| 21364 | & 'CKMTQ0: IPAR =',IPAR,' not implemented!' |
| 21365 | STOP |
| 21366 | ENDIF |
| 21367 | RETURN |
| 21368 | END |
| 21369 | C |
| 21370 | C |
| 21371 | CDECK ID>, DT_CKMTDE |
| 21372 | SUBROUTINE DT_CKMTDE(I,NDRV,X,S,ANS) |
| 21373 | C |
| 21374 | C********************************************************************** |
| 21375 | C Deuteron - PDFs |
| 21376 | C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc |
| 21377 | C ANS = PDF(I) |
| 21378 | C This version by S. Roesler, 30.01.96 |
| 21379 | C********************************************************************** |
| 21380 | |
| 21381 | SAVE |
| 21382 | DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000) |
| 21383 | EQUIVALENCE (GF(1,1,1),DL(1)) |
| 21384 | DATA DELTA/.13/ |
| 21385 | C |
| 21386 | DATA (DL(K),K= 1, 85) / |
| 21387 | &0.351858E+00,0.388489E+00,0.325356E+00,0.325356E+00,0.325356E+00, |
| 21388 | &0.325356E+00,0.445218E+01,0.000000E+00,0.419818E+00,0.459249E+00, |
| 21389 | &0.391167E+00,0.391143E+00,0.391125E+00,0.391167E+00,0.628186E+01, |
| 21390 | &0.703797E-01,0.498333E+00,0.540626E+00,0.467466E+00,0.467423E+00, |
| 21391 | &0.467393E+00,0.467466E+00,0.837368E+01,0.151191E+00,0.587839E+00, |
| 21392 | &0.633058E+00,0.554689E+00,0.554630E+00,0.554595E+00,0.554689E+00, |
| 21393 | &0.107170E+02,0.242877E+00,0.688652E+00,0.736861E+00,0.653150E+00, |
| 21394 | &0.653080E+00,0.653046E+00,0.653150E+00,0.132960E+02,0.345760E+00, |
| 21395 | &0.800961E+00,0.852226E+00,0.763038E+00,0.762961E+00,0.762933E+00, |
| 21396 | &0.763038E+00,0.160884E+02,0.460033E+00,0.924829E+00,0.979213E+00, |
| 21397 | &0.884414E+00,0.884335E+00,0.884319E+00,0.884414E+00,0.190679E+02, |
| 21398 | &0.585764E+00,0.106016E+01,0.111773E+01,0.101719E+01,0.101711E+01, |
| 21399 | &0.101711E+01,0.101719E+01,0.222033E+02,0.722864E+00,0.120670E+01, |
| 21400 | &0.126752E+01,0.116110E+01,0.116102E+01,0.116105E+01,0.116110E+01, |
| 21401 | &0.254603E+02,0.871079E+00,0.136402E+01,0.142815E+01,0.131571E+01, |
| 21402 | &0.131565E+01,0.131570E+01,0.131571E+01,0.288020E+02,0.102998E+01, |
| 21403 | &0.153151E+01,0.159900E+01,0.148043E+01,0.148038E+01,0.148046E+01/ |
| 21404 | DATA (DL(K),K= 86, 170) / |
| 21405 | &0.148043E+01,0.321898E+02,0.119897E+01,0.170838E+01,0.177930E+01, |
| 21406 | &0.165447E+01,0.165444E+01,0.165455E+01,0.165447E+01,0.355845E+02, |
| 21407 | &0.137726E+01,0.189369E+01,0.196807E+01,0.183687E+01,0.183686E+01, |
| 21408 | &0.183701E+01,0.183687E+01,0.389473E+02,0.156390E+01,0.208631E+01, |
| 21409 | &0.216422E+01,0.202653E+01,0.202654E+01,0.202673E+01,0.202653E+01, |
| 21410 | &0.422402E+02,0.175779E+01,0.228501E+01,0.236648E+01,0.222220E+01, |
| 21411 | &0.222224E+01,0.222248E+01,0.222220E+01,0.454277E+02,0.195768E+01, |
| 21412 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21413 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21414 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21415 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21416 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21417 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21418 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21419 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21420 | &0.326035E+00,0.380777E+00,0.286363E+00,0.286363E+00,0.286363E+00, |
| 21421 | &0.286363E+00,0.392252E+01,-.138778E-16,0.380092E+00,0.438587E+00/ |
| 21422 | DATA (DL(K),K= 171, 255) / |
| 21423 | &0.337452E+00,0.337430E+00,0.337424E+00,0.337452E+00,0.532193E+01, |
| 21424 | &0.553645E-01,0.440879E+00,0.503177E+00,0.395208E+00,0.395169E+00, |
| 21425 | &0.395165E+00,0.395208E+00,0.686454E+01,0.117354E+00,0.508415E+00, |
| 21426 | &0.574566E+00,0.459649E+00,0.459600E+00,0.459604E+00,0.459649E+00, |
| 21427 | &0.853316E+01,0.185994E+00,0.582647E+00,0.652699E+00,0.530722E+00, |
| 21428 | &0.530667E+00,0.530687E+00,0.530722E+00,0.103093E+02,0.261237E+00, |
| 21429 | &0.663404E+00,0.737405E+00,0.608254E+00,0.608199E+00,0.608241E+00, |
| 21430 | &0.608254E+00,0.121710E+02,0.342917E+00,0.750429E+00,0.828423E+00, |
| 21431 | &0.691990E+00,0.691941E+00,0.692009E+00,0.691990E+00,0.140946E+02, |
| 21432 | &0.430783E+00,0.843361E+00,0.925391E+00,0.781571E+00,0.781533E+00, |
| 21433 | &0.781632E+00,0.781571E+00,0.160553E+02,0.524479E+00,0.941741E+00, |
| 21434 | &0.102784E+01,0.876538E+00,0.876515E+00,0.876650E+00,0.876538E+00, |
| 21435 | &0.180277E+02,0.623549E+00,0.104501E+01,0.113521E+01,0.976335E+00, |
| 21436 | &0.976332E+00,0.976506E+00,0.976335E+00,0.199863E+02,0.727439E+00, |
| 21437 | &0.115251E+01,0.124685E+01,0.108031E+01,0.108034E+01,0.108055E+01, |
| 21438 | &0.108031E+01,0.219066E+02,0.835506E+00,0.126352E+01,0.136201E+01, |
| 21439 | &0.118775E+01,0.118780E+01,0.118806E+01,0.118775E+01,0.237652E+02/ |
| 21440 | DATA (DL(K),K= 256, 340) / |
| 21441 | &0.947020E+00,0.137724E+01,0.147989E+01,0.129783E+01,0.129791E+01, |
| 21442 | &0.129822E+01,0.129783E+01,0.255406E+02,0.106119E+01,0.149279E+01, |
| 21443 | &0.159961E+01,0.140972E+01,0.140984E+01,0.141019E+01,0.140972E+01, |
| 21444 | &0.272135E+02,0.117715E+01,0.160929E+01,0.172028E+01,0.152252E+01, |
| 21445 | &0.152267E+01,0.152308E+01,0.152252E+01,0.287669E+02,0.129402E+01, |
| 21446 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21447 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21448 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21449 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21450 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21451 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21452 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21453 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21454 | &0.309785E+00,0.391282E+00,0.250518E+00,0.250518E+00,0.250518E+00, |
| 21455 | &0.250518E+00,0.343842E+01,-.138778E-16,0.352113E+00,0.438463E+00, |
| 21456 | &0.288877E+00,0.288863E+00,0.288878E+00,0.288877E+00,0.446765E+01, |
| 21457 | &0.424850E-01,0.398382E+00,0.489596E+00,0.331132E+00,0.331111E+00/ |
| 21458 | DATA (DL(K),K= 341, 425) / |
| 21459 | &0.331148E+00,0.331132E+00,0.555902E+01,0.888369E-01,0.448375E+00, |
| 21460 | &0.544458E+00,0.377064E+00,0.377043E+00,0.377108E+00,0.377064E+00, |
| 21461 | &0.669490E+01,0.138845E+00,0.501854E+00,0.602811E+00,0.426440E+00, |
| 21462 | &0.426425E+00,0.426523E+00,0.426440E+00,0.785892E+01,0.192281E+00, |
| 21463 | &0.558506E+00,0.664331E+00,0.478946E+00,0.478944E+00,0.479079E+00, |
| 21464 | &0.478946E+00,0.903368E+01,0.248834E+00,0.617972E+00,0.728657E+00, |
| 21465 | &0.534229E+00,0.534244E+00,0.534421E+00,0.534229E+00,0.102022E+02, |
| 21466 | &0.308155E+00,0.679844E+00,0.795370E+00,0.591883E+00,0.591921E+00, |
| 21467 | &0.592141E+00,0.591883E+00,0.113479E+02,0.369841E+00,0.743667E+00, |
| 21468 | &0.864009E+00,0.651460E+00,0.651525E+00,0.651792E+00,0.651460E+00, |
| 21469 | &0.124553E+02,0.433447E+00,0.808951E+00,0.934073E+00,0.712474E+00, |
| 21470 | &0.712571E+00,0.712885E+00,0.712474E+00,0.135102E+02,0.498486E+00, |
| 21471 | &0.875171E+00,0.100503E+01,0.774408E+00,0.774541E+00,0.774902E+00, |
| 21472 | &0.774408E+00,0.144999E+02,0.564446E+00,0.941784E+00,0.107632E+01, |
| 21473 | &0.836726E+00,0.836897E+00,0.837307E+00,0.836726E+00,0.154136E+02, |
| 21474 | &0.630788E+00,0.100823E+01,0.114738E+01,0.898879E+00,0.899092E+00, |
| 21475 | &0.899551E+00,0.898879E+00,0.162423E+02,0.696967E+00,0.107396E+01/ |
| 21476 | DATA (DL(K),K= 426, 510) / |
| 21477 | &0.121764E+01,0.960319E+00,0.960577E+00,0.961084E+00,0.960319E+00, |
| 21478 | &0.169791E+02,0.762433E+00,0.113843E+01,0.128655E+01,0.102051E+01, |
| 21479 | &0.102081E+01,0.102137E+01,0.102051E+01,0.176190E+02,0.826647E+00, |
| 21480 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21481 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21482 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21483 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21484 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21485 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21486 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21487 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21488 | &0.304680E+00,0.425088E+00,0.216504E+00,0.216504E+00,0.216504E+00, |
| 21489 | &0.216504E+00,0.298356E+01,0.000000E+00,0.337300E+00,0.463627E+00, |
| 21490 | &0.244023E+00,0.244024E+00,0.244063E+00,0.244023E+00,0.370271E+01, |
| 21491 | &0.316585E-01,0.371787E+00,0.503942E+00,0.273415E+00,0.273423E+00, |
| 21492 | &0.273505E+00,0.273415E+00,0.443039E+01,0.651685E-01,0.407853E+00, |
| 21493 | &0.545739E+00,0.304395E+00,0.304418E+00,0.304545E+00,0.304395E+00/ |
| 21494 | DATA (DL(K),K= 511, 595) / |
| 21495 | &0.515321E+01,0.100252E+00,0.445229E+00,0.588741E+00,0.336700E+00, |
| 21496 | &0.336744E+00,0.336918E+00,0.336700E+00,0.586004E+01,0.136648E+00, |
| 21497 | &0.483606E+00,0.632629E+00,0.370026E+00,0.370095E+00,0.370318E+00, |
| 21498 | &0.370026E+00,0.654027E+01,0.174056E+00,0.522666E+00,0.677074E+00, |
| 21499 | &0.404062E+00,0.404162E+00,0.404433E+00,0.404062E+00,0.718442E+01, |
| 21500 | &0.212167E+00,0.562075E+00,0.721735E+00,0.438483E+00,0.438618E+00, |
| 21501 | &0.438938E+00,0.438483E+00,0.778423E+01,0.250658E+00,0.601494E+00, |
| 21502 | &0.766258E+00,0.472959E+00,0.473131E+00,0.473500E+00,0.472959E+00, |
| 21503 | &0.833276E+01,0.289199E+00,0.640580E+00,0.810290E+00,0.507156E+00, |
| 21504 | &0.507369E+00,0.507784E+00,0.507156E+00,0.882448E+01,0.327457E+00, |
| 21505 | &0.678993E+00,0.853479E+00,0.540747E+00,0.541003E+00,0.541463E+00, |
| 21506 | &0.540747E+00,0.925529E+01,0.365104E+00,0.716405E+00,0.895483E+00, |
| 21507 | &0.573411E+00,0.573714E+00,0.574216E+00,0.573411E+00,0.962250E+01, |
| 21508 | &0.401821E+00,0.752501E+00,0.935975E+00,0.604848E+00,0.605197E+00, |
| 21509 | &0.605740E+00,0.604848E+00,0.992478E+01,0.437304E+00,0.786987E+00, |
| 21510 | &0.974647E+00,0.634775E+00,0.635173E+00,0.635752E+00,0.634775E+00, |
| 21511 | &0.101620E+02,0.471269E+00,0.819594E+00,0.101122E+01,0.662936E+00/ |
| 21512 | DATA (DL(K),K= 596, 680) / |
| 21513 | &0.663382E+00,0.663995E+00,0.662936E+00,0.103354E+02,0.503459E+00, |
| 21514 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21515 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21516 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21517 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21518 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21519 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21520 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21521 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21522 | &0.312661E+00,0.487836E+00,0.182562E+00,0.182562E+00,0.182562E+00, |
| 21523 | &0.182562E+00,0.253626E+01,0.000000E+00,0.336910E+00,0.518440E+00, |
| 21524 | &0.200702E+00,0.200721E+00,0.200779E+00,0.200702E+00,0.299460E+01, |
| 21525 | &0.224425E-01,0.361554E+00,0.549164E+00,0.219359E+00,0.219402E+00, |
| 21526 | &0.219517E+00,0.219359E+00,0.343183E+01,0.453742E-01,0.386348E+00, |
| 21527 | &0.579759E+00,0.238296E+00,0.238367E+00,0.238536E+00,0.238296E+00, |
| 21528 | &0.384076E+01,0.685610E-01,0.411080E+00,0.610003E+00,0.257305E+00, |
| 21529 | &0.257408E+00,0.257630E+00,0.257305E+00,0.421619E+01,0.917987E-01/ |
| 21530 | DATA (DL(K),K= 681, 765) / |
| 21531 | &0.435528E+00,0.639668E+00,0.276174E+00,0.276313E+00,0.276583E+00, |
| 21532 | &0.276174E+00,0.455400E+01,0.114876E+00,0.459476E+00,0.668531E+00, |
| 21533 | &0.294698E+00,0.294875E+00,0.295191E+00,0.294698E+00,0.485107E+01, |
| 21534 | &0.137589E+00,0.482719E+00,0.696375E+00,0.312682E+00,0.312900E+00, |
| 21535 | &0.313258E+00,0.312682E+00,0.510539E+01,0.159742E+00,0.505060E+00, |
| 21536 | &0.722995E+00,0.329941E+00,0.330200E+00,0.330596E+00,0.329941E+00, |
| 21537 | &0.531589E+01,0.181149E+00,0.526315E+00,0.748199E+00,0.346303E+00, |
| 21538 | &0.346604E+00,0.347034E+00,0.346303E+00,0.548250E+01,0.201638E+00, |
| 21539 | &0.546317E+00,0.771808E+00,0.361613E+00,0.361957E+00,0.362418E+00, |
| 21540 | &0.361613E+00,0.560595E+01,0.221052E+00,0.564917E+00,0.793667E+00, |
| 21541 | &0.375735E+00,0.376122E+00,0.376609E+00,0.375735E+00,0.568772E+01, |
| 21542 | &0.239253E+00,0.581987E+00,0.813638E+00,0.388553E+00,0.388982E+00, |
| 21543 | &0.389491E+00,0.388553E+00,0.572992E+01,0.256122E+00,0.597419E+00, |
| 21544 | &0.831608E+00,0.399972E+00,0.400443E+00,0.400970E+00,0.399972E+00, |
| 21545 | &0.573516E+01,0.271562E+00,0.611129E+00,0.847487E+00,0.409919E+00, |
| 21546 | &0.410430E+00,0.410972E+00,0.409919E+00,0.570642E+01,0.285497E+00, |
| 21547 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ |
| 21548 | DATA (DL(K),K= 766, 850) / |
| 21549 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21550 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21551 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21552 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21553 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21554 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21555 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21556 | &0.335149E+00,0.582072E+00,0.146415E+00,0.146415E+00,0.146415E+00, |
| 21557 | &0.146415E+00,0.206772E+01,0.000000E+00,0.351552E+00,0.603437E+00, |
| 21558 | &0.156515E+00,0.156542E+00,0.156595E+00,0.156515E+00,0.231143E+01, |
| 21559 | &0.146091E-01,0.367407E+00,0.623737E+00,0.166387E+00,0.166442E+00, |
| 21560 | &0.166542E+00,0.166387E+00,0.252488E+01,0.289315E-01,0.382571E+00, |
| 21561 | &0.642832E+00,0.175891E+00,0.175976E+00,0.176118E+00,0.175891E+00, |
| 21562 | &0.270658E+01,0.428312E-01,0.396926E+00,0.660609E+00,0.184917E+00, |
| 21563 | &0.185034E+00,0.185212E+00,0.184917E+00,0.285608E+01,0.561981E-01, |
| 21564 | &0.410365E+00,0.676962E+00,0.193365E+00,0.193513E+00,0.193722E+00, |
| 21565 | &0.193365E+00,0.297375E+01,0.689319E-01,0.422792E+00,0.691796E+00/ |
| 21566 | DATA (DL(K),K= 851, 935) / |
| 21567 | &0.201144E+00,0.201324E+00,0.201560E+00,0.201144E+00,0.306050E+01, |
| 21568 | &0.809434E-01,0.434123E+00,0.705030E+00,0.208181E+00,0.208393E+00, |
| 21569 | &0.208650E+00,0.208181E+00,0.311775E+01,0.921567E-01,0.444287E+00, |
| 21570 | &0.716596E+00,0.214413E+00,0.214656E+00,0.214931E+00,0.214413E+00, |
| 21571 | &0.314738E+01,0.102508E+00,0.453228E+00,0.726441E+00,0.219792E+00, |
| 21572 | &0.220066E+00,0.220354E+00,0.219792E+00,0.315156E+01,0.111949E+00, |
| 21573 | &0.460906E+00,0.734527E+00,0.224285E+00,0.224589E+00,0.224886E+00, |
| 21574 | &0.224285E+00,0.313271E+01,0.120441E+00,0.467291E+00,0.740835E+00, |
| 21575 | &0.227870E+00,0.228203E+00,0.228506E+00,0.227870E+00,0.309338E+01, |
| 21576 | &0.127963E+00,0.472372E+00,0.745357E+00,0.230541E+00,0.230902E+00, |
| 21577 | &0.231208E+00,0.230541E+00,0.303621E+01,0.134506E+00,0.476148E+00, |
| 21578 | &0.748105E+00,0.232304E+00,0.232690E+00,0.232996E+00,0.232304E+00, |
| 21579 | &0.296381E+01,0.140070E+00,0.478635E+00,0.749103E+00,0.233176E+00, |
| 21580 | &0.233586E+00,0.233889E+00,0.233176E+00,0.287874E+01,0.144672E+00, |
| 21581 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21582 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21583 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ |
| 21584 | DATA (DL(K),K= 936, 1020) / |
| 21585 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21586 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21587 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21588 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21589 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21590 | &0.370162E+00,0.695827E+00,0.105823E+00,0.105823E+00,0.105823E+00, |
| 21591 | &0.105823E+00,0.154556E+01,0.208167E-16,0.378214E+00,0.703794E+00, |
| 21592 | &0.109539E+00,0.109554E+00,0.109571E+00,0.109539E+00,0.162770E+01, |
| 21593 | &0.818783E-02,0.385258E+00,0.710067E+00,0.112818E+00,0.112847E+00, |
| 21594 | &0.112879E+00,0.112818E+00,0.168578E+01,0.158212E-01,0.391264E+00, |
| 21595 | &0.714648E+00,0.115620E+00,0.115666E+00,0.115709E+00,0.115620E+00, |
| 21596 | &0.172175E+01,0.228667E-01,0.396214E+00,0.717539E+00,0.117923E+00, |
| 21597 | &0.117985E+00,0.118037E+00,0.117923E+00,0.173756E+01,0.293009E-01, |
| 21598 | &0.400098E+00,0.718759E+00,0.119711E+00,0.119790E+00,0.119848E+00, |
| 21599 | &0.119711E+00,0.173541E+01,0.351123E-01,0.402915E+00,0.718332E+00, |
| 21600 | &0.120979E+00,0.121074E+00,0.121137E+00,0.120979E+00,0.171755E+01, |
| 21601 | &0.402951E-01,0.404672E+00,0.716292E+00,0.121728E+00,0.121840E+00/ |
| 21602 | DATA (DL(K),K= 1021, 1105) / |
| 21603 | &0.121905E+00,0.121728E+00,0.168619E+01,0.448514E-01,0.405385E+00, |
| 21604 | &0.712681E+00,0.121967E+00,0.122095E+00,0.122161E+00,0.121967E+00, |
| 21605 | &0.164352E+01,0.487902E-01,0.405077E+00,0.707551E+00,0.121712E+00, |
| 21606 | &0.121855E+00,0.121920E+00,0.121712E+00,0.159162E+01,0.521265E-01, |
| 21607 | &0.403778E+00,0.700963E+00,0.120984E+00,0.121141E+00,0.121204E+00, |
| 21608 | &0.120984E+00,0.153245E+01,0.548814E-01,0.401525E+00,0.692984E+00, |
| 21609 | &0.119809E+00,0.119980E+00,0.120040E+00,0.119809E+00,0.146780E+01, |
| 21610 | &0.570807E-01,0.398361E+00,0.683691E+00,0.118218E+00,0.118402E+00, |
| 21611 | &0.118457E+00,0.118218E+00,0.139928E+01,0.587542E-01,0.394333E+00, |
| 21612 | &0.673166E+00,0.116244E+00,0.116440E+00,0.116490E+00,0.116244E+00, |
| 21613 | &0.132834E+01,0.599355E-01,0.389495E+00,0.661496E+00,0.113924E+00, |
| 21614 | &0.114131E+00,0.114175E+00,0.113924E+00,0.125620E+01,0.606602E-01, |
| 21615 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21616 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21617 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21618 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21619 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ |
| 21620 | DATA (DL(K),K= 1106, 1190) / |
| 21621 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21622 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21623 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21624 | &0.394012E+00,0.757115E+00,0.772117E-01,0.772117E-01,0.772117E-01, |
| 21625 | &0.772117E-01,0.117279E+01,0.346945E-17,0.395841E+00,0.752988E+00, |
| 21626 | &0.780501E-01,0.780655E-01,0.780723E-01,0.780501E-01,0.118528E+01, |
| 21627 | &0.491697E-02,0.396627E+00,0.747223E+00,0.785386E-01,0.785692E-01, |
| 21628 | &0.785806E-01,0.785386E-01,0.118242E+01,0.932754E-02,0.396401E+00, |
| 21629 | &0.739901E+00,0.786820E-01,0.787273E-01,0.787413E-01,0.786820E-01, |
| 21630 | &0.116673E+01,0.132427E-01,0.395190E+00,0.731092E+00,0.784870E-01, |
| 21631 | &0.785464E-01,0.785613E-01,0.784870E-01,0.114033E+01,0.166738E-01, |
| 21632 | &0.393030E+00,0.720878E+00,0.779683E-01,0.780410E-01,0.780555E-01, |
| 21633 | &0.779683E-01,0.110528E+01,0.196392E-01,0.389962E+00,0.709342E+00, |
| 21634 | &0.771427E-01,0.772280E-01,0.772409E-01,0.771427E-01,0.106344E+01, |
| 21635 | &0.221591E-01,0.386027E+00,0.696571E+00,0.760304E-01,0.761276E-01, |
| 21636 | &0.761378E-01,0.760304E-01,0.101653E+01,0.242567E-01,0.381274E+00, |
| 21637 | &0.682657E+00,0.746543E-01,0.747623E-01,0.747692E-01,0.746543E-01/ |
| 21638 | DATA (DL(K),K= 1191, 1275) / |
| 21639 | &0.966057E+00,0.259571E-01,0.375752E+00,0.667695E+00,0.730389E-01, |
| 21640 | &0.731569E-01,0.731598E-01,0.730389E-01,0.913345E+00,0.272876E-01, |
| 21641 | &0.369514E+00,0.651782E+00,0.712104E-01,0.713374E-01,0.713358E-01, |
| 21642 | &0.712104E-01,0.859530E+00,0.282763E-01,0.362616E+00,0.635021E+00, |
| 21643 | &0.691957E-01,0.693307E-01,0.693243E-01,0.691957E-01,0.805566E+00, |
| 21644 | &0.289524E-01,0.355116E+00,0.617511E+00,0.670220E-01,0.671640E-01, |
| 21645 | &0.671526E-01,0.670220E-01,0.752235E+00,0.293453E-01,0.347072E+00, |
| 21646 | &0.599357E+00,0.647162E-01,0.648642E-01,0.648478E-01,0.647162E-01, |
| 21647 | &0.700161E+00,0.294844E-01,0.338543E+00,0.580659E+00,0.623046E-01, |
| 21648 | &0.624578E-01,0.624363E-01,0.623046E-01,0.649828E+00,0.293983E-01, |
| 21649 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21650 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21651 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21652 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21653 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21654 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21655 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ |
| 21656 | DATA (DL(K),K= 1276, 1360) / |
| 21657 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21658 | &0.408305E+00,0.775318E+00,0.509141E-01,0.509141E-01,0.509141E-01, |
| 21659 | &0.509141E-01,0.818839E+00,-.867362E-17,0.403619E+00,0.758058E+00, |
| 21660 | &0.502245E-01,0.502351E-01,0.502337E-01,0.502245E-01,0.795347E+00, |
| 21661 | &0.264045E-02,0.398068E+00,0.739709E+00,0.493454E-01,0.493661E-01, |
| 21662 | &0.493626E-01,0.493454E-01,0.764942E+00,0.491508E-02,0.391719E+00, |
| 21663 | &0.720394E+00,0.482952E-01,0.483253E-01,0.483192E-01,0.482952E-01, |
| 21664 | &0.729624E+00,0.685202E-02,0.384627E+00,0.700222E+00,0.470896E-01, |
| 21665 | &0.471285E-01,0.471194E-01,0.470896E-01,0.690906E+00,0.847433E-02, |
| 21666 | &0.376851E+00,0.679300E+00,0.457475E-01,0.457946E-01,0.457822E-01, |
| 21667 | &0.457475E-01,0.650078E+00,0.980774E-02,0.368452E+00,0.657739E+00, |
| 21668 | &0.442875E-01,0.443419E-01,0.443261E-01,0.442875E-01,0.608239E+00, |
| 21669 | &0.108769E-01,0.359490E+00,0.635646E+00,0.427281E-01,0.427892E-01, |
| 21670 | &0.427698E-01,0.427281E-01,0.566280E+00,0.117061E-01,0.350026E+00, |
| 21671 | &0.613128E+00,0.410878E-01,0.411549E-01,0.411320E-01,0.410878E-01, |
| 21672 | &0.524918E+00,0.123191E-01,0.340122E+00,0.590292E+00,0.393848E-01, |
| 21673 | &0.394571E-01,0.394308E-01,0.393848E-01,0.484713E+00,0.127393E-01/ |
| 21674 | DATA (DL(K),K= 1361, 1445) / |
| 21675 | &0.329838E+00,0.567240E+00,0.376363E-01,0.377132E-01,0.376836E-01, |
| 21676 | &0.376363E-01,0.446084E+00,0.129888E-01,0.319236E+00,0.544074E+00, |
| 21677 | &0.358589E-01,0.359396E-01,0.359068E-01,0.358589E-01,0.409328E+00, |
| 21678 | &0.130888E-01,0.308374E+00,0.520890E+00,0.340678E-01,0.341517E-01, |
| 21679 | &0.341160E-01,0.340678E-01,0.374641E+00,0.130594E-01,0.297312E+00, |
| 21680 | &0.497781E+00,0.322772E-01,0.323636E-01,0.323253E-01,0.322772E-01, |
| 21681 | &0.342135E+00,0.129195E-01,0.286106E+00,0.474837E+00,0.304999E-01, |
| 21682 | &0.305882E-01,0.305474E-01,0.304999E-01,0.311854E+00,0.126863E-01, |
| 21683 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21684 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21685 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21686 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21687 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21688 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21689 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21690 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21691 | &0.407248E+00,0.746438E+00,0.335640E-01,0.335640E-01,0.335640E-01/ |
| 21692 | DATA (DL(K),K= 1446, 1530) / |
| 21693 | &0.335640E-01,0.573540E+00,0.173472E-16,0.397516E+00,0.719825E+00, |
| 21694 | &0.324649E-01,0.324735E-01,0.324698E-01,0.324649E-01,0.540770E+00, |
| 21695 | &0.147177E-02,0.387197E+00,0.692869E+00,0.312911E-01,0.313075E-01, |
| 21696 | &0.313000E-01,0.312911E-01,0.505972E+00,0.269995E-02,0.376365E+00, |
| 21697 | &0.665689E+00,0.300576E-01,0.300811E-01,0.300699E-01,0.300576E-01, |
| 21698 | &0.470389E+00,0.371147E-02,0.365085E+00,0.638387E+00,0.287770E-01, |
| 21699 | &0.288070E-01,0.287922E-01,0.287770E-01,0.434885E+00,0.452768E-02, |
| 21700 | &0.353423E+00,0.611066E+00,0.274623E-01,0.274980E-01,0.274797E-01, |
| 21701 | &0.274623E-01,0.400103E+00,0.516996E-02,0.341442E+00,0.583823E+00, |
| 21702 | &0.261256E-01,0.261663E-01,0.261448E-01,0.261256E-01,0.366541E+00, |
| 21703 | &0.565807E-02,0.329207E+00,0.556753E+00,0.247782E-01,0.248234E-01, |
| 21704 | &0.247989E-01,0.247782E-01,0.334555E+00,0.601048E-02,0.316777E+00, |
| 21705 | &0.529946E+00,0.234308E-01,0.234798E-01,0.234525E-01,0.234308E-01, |
| 21706 | &0.304384E+00,0.624451E-02,0.304214E+00,0.503489E+00,0.220932E-01, |
| 21707 | &0.221452E-01,0.221155E-01,0.220932E-01,0.276170E+00,0.637618E-02, |
| 21708 | &0.291575E+00,0.477462E+00,0.207739E-01,0.208286E-01,0.207966E-01, |
| 21709 | &0.207739E-01,0.249976E+00,0.642028E-02,0.278917E+00,0.451941E+00/ |
| 21710 | DATA (DL(K),K= 1531, 1615) / |
| 21711 | &0.194809E-01,0.195376E-01,0.195037E-01,0.194809E-01,0.225809E+00, |
| 21712 | &0.639038E-02,0.266293E+00,0.426995E+00,0.182209E-01,0.182791E-01, |
| 21713 | &0.182436E-01,0.182209E-01,0.203629E+00,0.629880E-02,0.253754E+00, |
| 21714 | &0.402686E+00,0.169996E-01,0.170587E-01,0.170219E-01,0.169996E-01, |
| 21715 | &0.183361E+00,0.615665E-02,0.241347E+00,0.379071E+00,0.158217E-01, |
| 21716 | &0.158814E-01,0.158436E-01,0.158217E-01,0.164907E+00,0.597385E-02, |
| 21717 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21718 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21719 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21720 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21721 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21722 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21723 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21724 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21725 | &0.395106E+00,0.689399E+00,0.218554E-01,0.218554E-01,0.218554E-01, |
| 21726 | &0.218554E-01,0.398362E+00,-.173472E-17,0.381441E+00,0.656777E+00, |
| 21727 | &0.207816E-01,0.207886E-01,0.207844E-01,0.207816E-01,0.366703E+00/ |
| 21728 | DATA (DL(K),K= 1616, 1700) / |
| 21729 | &0.826643E-03,0.367505E+00,0.624578E+00,0.197001E-01,0.197133E-01, |
| 21730 | &0.197053E-01,0.197001E-01,0.335573E+00,0.149886E-02,0.353373E+00, |
| 21731 | &0.592889E+00,0.186195E-01,0.186383E-01,0.186266E-01,0.186195E-01, |
| 21732 | &0.305590E+00,0.203730E-02,0.339106E+00,0.561783E+00,0.175468E-01, |
| 21733 | &0.175705E-01,0.175555E-01,0.175468E-01,0.277136E+00,0.245817E-02, |
| 21734 | &0.324766E+00,0.531331E+00,0.164887E-01,0.165166E-01,0.164986E-01, |
| 21735 | &0.164887E-01,0.250424E+00,0.277666E-02,0.310411E+00,0.501599E+00, |
| 21736 | &0.154510E-01,0.154825E-01,0.154618E-01,0.154510E-01,0.225588E+00, |
| 21737 | &0.300658E-02,0.296100E+00,0.472648E+00,0.144390E-01,0.144735E-01, |
| 21738 | &0.144504E-01,0.144390E-01,0.202681E+00,0.316040E-02,0.281885E+00, |
| 21739 | &0.444535E+00,0.134570E-01,0.134940E-01,0.134689E-01,0.134570E-01, |
| 21740 | &0.181693E+00,0.324944E-02,0.267820E+00,0.417309E+00,0.125091E-01, |
| 21741 | &0.125481E-01,0.125212E-01,0.125091E-01,0.162572E+00,0.328396E-02, |
| 21742 | &0.253953E+00,0.391017E+00,0.115984E-01,0.116389E-01,0.116106E-01, |
| 21743 | &0.115984E-01,0.145235E+00,0.327313E-02,0.240328E+00,0.365695E+00, |
| 21744 | &0.107275E-01,0.107690E-01,0.107396E-01,0.107275E-01,0.129575E+00, |
| 21745 | &0.322510E-02,0.226989E+00,0.341375E+00,0.989805E-02,0.994030E-02/ |
| 21746 | DATA (DL(K),K= 1701, 1785) / |
| 21747 | &0.990998E-02,0.989805E-02,0.115477E+00,0.314713E-02,0.213972E+00, |
| 21748 | &0.318081E+00,0.911149E-02,0.915408E-02,0.912316E-02,0.911149E-02, |
| 21749 | &0.102820E+00,0.304556E-02,0.201311E+00,0.295830E+00,0.836852E-02, |
| 21750 | &0.841111E-02,0.837984E-02,0.836852E-02,0.914804E-01,0.292596E-02, |
| 21751 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21752 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21753 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21754 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21755 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21756 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21757 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21758 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21759 | &0.374678E+00,0.616087E+00,0.139531E-01,0.139531E-01,0.139531E-01, |
| 21760 | &0.139531E-01,0.272491E+00,-.693889E-17,0.358052E+00,0.580345E+00, |
| 21761 | &0.130624E-01,0.130680E-01,0.130641E-01,0.130624E-01,0.245861E+00, |
| 21762 | &0.460255E-03,0.341487E+00,0.545719E+00,0.121971E-01,0.122076E-01, |
| 21763 | &0.122002E-01,0.121971E-01,0.220877E+00,0.826785E-03,0.325046E+00/ |
| 21764 | DATA (DL(K),K= 1786, 1870) / |
| 21765 | &0.512244E+00,0.113599E-01,0.113748E-01,0.113641E-01,0.113599E-01, |
| 21766 | &0.197730E+00,0.111366E-02,0.308783E+00,0.479952E+00,0.105534E-01, |
| 21767 | &0.105720E-01,0.105585E-01,0.105534E-01,0.176497E+00,0.133192E-02, |
| 21768 | &0.292747E+00,0.448868E+00,0.977938E-02,0.980112E-02,0.978518E-02, |
| 21769 | &0.977938E-02,0.157150E+00,0.149139E-02,0.276986E+00,0.419015E+00, |
| 21770 | &0.903955E-02,0.906394E-02,0.904584E-02,0.903955E-02,0.139631E+00, |
| 21771 | &0.160093E-02,0.261546E+00,0.390412E+00,0.833509E-02,0.836165E-02, |
| 21772 | &0.834171E-02,0.833509E-02,0.123850E+00,0.166838E-02,0.246467E+00, |
| 21773 | &0.363074E+00,0.766687E-02,0.769516E-02,0.767369E-02,0.766687E-02, |
| 21774 | &0.109695E+00,0.170073E-02,0.231787E+00,0.337008E+00,0.703540E-02, |
| 21775 | &0.706500E-02,0.704230E-02,0.703540E-02,0.970428E-01,0.170416E-02, |
| 21776 | &0.217542E+00,0.312218E+00,0.644083E-02,0.647137E-02,0.644772E-02, |
| 21777 | &0.644083E-02,0.857658E-01,0.168409E-02,0.203759E+00,0.288701E+00, |
| 21778 | &0.588300E-02,0.591415E-02,0.588981E-02,0.588300E-02,0.757385E-01, |
| 21779 | &0.164528E-02,0.190467E+00,0.266449E+00,0.536147E-02,0.539292E-02, |
| 21780 | &0.536812E-02,0.536147E-02,0.668383E-01,0.159185E-02,0.177686E+00, |
| 21781 | &0.245447E+00,0.487551E-02,0.490698E-02,0.488195E-02,0.487551E-02/ |
| 21782 | DATA (DL(K),K= 1871, 1955) / |
| 21783 | &0.589492E-01,0.152735E-02,0.165434E+00,0.225677E+00,0.442416E-02, |
| 21784 | &0.445543E-02,0.443037E-02,0.442416E-02,0.519652E-01,0.145483E-02, |
| 21785 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21786 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21787 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21788 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21789 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21790 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21791 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21792 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21793 | &0.348042E+00,0.534691E+00,0.867977E-02,0.867977E-02,0.867977E-02, |
| 21794 | &0.867977E-02,0.182547E+00,-.693889E-17,0.329349E+00,0.498248E+00, |
| 21795 | &0.800724E-02,0.801198E-02,0.800836E-02,0.800724E-02,0.161948E+00, |
| 21796 | &0.250949E-03,0.311047E+00,0.463485E+00,0.737155E-02,0.738040E-02, |
| 21797 | &0.737356E-02,0.737155E-02,0.143267E+00,0.447662E-03,0.293181E+00, |
| 21798 | &0.430377E+00,0.677169E-02,0.678409E-02,0.677441E-02,0.677169E-02, |
| 21799 | &0.126447E+00,0.598803E-03,0.275787E+00,0.398907E+00,0.620726E-02/ |
| 21800 | DATA (DL(K),K= 1956, 2040) / |
| 21801 | &0.622265E-02,0.621051E-02,0.620726E-02,0.111401E+00,0.711280E-03, |
| 21802 | &0.258900E+00,0.369051E+00,0.567741E-02,0.569532E-02,0.568106E-02, |
| 21803 | &0.567741E-02,0.979944E-01,0.790986E-03,0.242550E+00,0.340785E+00, |
| 21804 | &0.518138E-02,0.520134E-02,0.518531E-02,0.518138E-02,0.860936E-01, |
| 21805 | &0.843227E-03,0.226765E+00,0.314083E+00,0.471828E-02,0.473987E-02, |
| 21806 | &0.472238E-02,0.471828E-02,0.755615E-01,0.872644E-03,0.211568E+00, |
| 21807 | &0.288916E+00,0.428714E-02,0.430998E-02,0.429133E-02,0.428714E-02, |
| 21808 | &0.662627E-01,0.883319E-03,0.196981E+00,0.265252E+00,0.388691E-02, |
| 21809 | &0.391065E-02,0.389112E-02,0.388691E-02,0.580684E-01,0.878818E-03, |
| 21810 | &0.183020E+00,0.243053E+00,0.351645E-02,0.354077E-02,0.352060E-02, |
| 21811 | &0.351645E-02,0.508578E-01,0.862228E-03,0.169696E+00,0.222280E+00, |
| 21812 | &0.317451E-02,0.319914E-02,0.317858E-02,0.317451E-02,0.445190E-01, |
| 21813 | &0.836224E-03,0.157017E+00,0.202888E+00,0.285982E-02,0.288450E-02, |
| 21814 | &0.286376E-02,0.285982E-02,0.389523E-01,0.803096E-03,0.144987E+00, |
| 21815 | &0.184832E+00,0.257101E-02,0.259553E-02,0.257480E-02,0.257101E-02, |
| 21816 | &0.340677E-01,0.764787E-03,0.133605E+00,0.168060E+00,0.230670E-02, |
| 21817 | &0.233087E-02,0.231031E-02,0.230670E-02,0.297820E-01,0.722929E-03/ |
| 21818 | DATA (DL(K),K= 2041, 2125) / |
| 21819 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21820 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21821 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21822 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21823 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21824 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21825 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21826 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21827 | &0.316867E+00,0.451111E+00,0.522815E-02,0.522815E-02,0.522815E-02, |
| 21828 | &0.522815E-02,0.119118E+00,0.889046E-17,0.296950E+00,0.415915E+00, |
| 21829 | &0.475497E-02,0.475914E-02,0.475574E-02,0.475497E-02,0.104204E+00, |
| 21830 | &0.132513E-03,0.277735E+00,0.382805E+00,0.431809E-02,0.432582E-02, |
| 21831 | &0.431944E-02,0.431809E-02,0.910279E-01,0.235347E-03,0.259241E+00, |
| 21832 | &0.351694E+00,0.391455E-02,0.392531E-02,0.391637E-02,0.391455E-02, |
| 21833 | &0.794222E-01,0.313322E-03,0.241485E+00,0.322517E+00,0.354249E-02, |
| 21834 | &0.355575E-02,0.354464E-02,0.354249E-02,0.692354E-01,0.370408E-03, |
| 21835 | &0.224480E+00,0.295202E+00,0.319987E-02,0.321518E-02,0.320226E-02/ |
| 21836 | DATA (DL(K),K= 2126, 2210) / |
| 21837 | &0.319987E-02,0.603106E-01,0.409866E-03,0.208235E+00,0.269681E+00, |
| 21838 | &0.288490E-02,0.290184E-02,0.288744E-02,0.288490E-02,0.525034E-01, |
| 21839 | &0.434663E-03,0.192759E+00,0.245887E+00,0.259589E-02,0.261407E-02, |
| 21840 | &0.259852E-02,0.259589E-02,0.456838E-01,0.447393E-03,0.178054E+00, |
| 21841 | &0.223752E+00,0.233123E-02,0.235033E-02,0.233390E-02,0.233123E-02, |
| 21842 | &0.397318E-01,0.450314E-03,0.164120E+00,0.203207E+00,0.208941E-02, |
| 21843 | &0.210910E-02,0.209206E-02,0.208941E-02,0.345396E-01,0.445394E-03, |
| 21844 | &0.150954E+00,0.184182E+00,0.186896E-02,0.188897E-02,0.187155E-02, |
| 21845 | &0.186896E-02,0.300131E-01,0.434333E-03,0.138548E+00,0.166608E+00, |
| 21846 | &0.166844E-02,0.168854E-02,0.167096E-02,0.166844E-02,0.260692E-01, |
| 21847 | &0.418584E-03,0.126892E+00,0.150412E+00,0.148650E-02,0.150648E-02, |
| 21848 | &0.148891E-02,0.148650E-02,0.226325E-01,0.399380E-03,0.115971E+00, |
| 21849 | &0.135523E+00,0.132180E-02,0.134148E-02,0.132409E-02,0.132180E-02, |
| 21850 | &0.196374E-01,0.377764E-03,0.105767E+00,0.121870E+00,0.117308E-02, |
| 21851 | &0.119231E-02,0.117524E-02,0.117308E-02,0.170312E-01,0.354610E-03, |
| 21852 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21853 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ |
| 21854 | DATA (DL(K),K= 2211, 2295) / |
| 21855 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21856 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21857 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21858 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21859 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21860 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21861 | &0.282579E+00,0.369670E+00,0.302765E-02,0.302765E-02,0.302765E-02, |
| 21862 | &0.302765E-02,0.752529E-01,-.455365E-17,0.262229E+00,0.337209E+00, |
| 21863 | &0.271512E-02,0.271883E-02,0.271564E-02,0.271512E-02,0.651086E-01, |
| 21864 | &0.669321E-04,0.242857E+00,0.307069E+00,0.243269E-02,0.243953E-02, |
| 21865 | &0.243360E-02,0.243269E-02,0.563252E-01,0.118744E-03,0.224455E+00, |
| 21866 | &0.279111E+00,0.217687E-02,0.218631E-02,0.217808E-02,0.217687E-02, |
| 21867 | &0.487143E-01,0.157767E-03,0.207014E+00,0.253223E+00,0.194534E-02, |
| 21868 | &0.195689E-02,0.194675E-02,0.194534E-02,0.421227E-01,0.186063E-03, |
| 21869 | &0.190523E+00,0.229293E+00,0.173585E-02,0.174909E-02,0.173741E-02, |
| 21870 | &0.173585E-02,0.364156E-01,0.205286E-03,0.174969E+00,0.207218E+00, |
| 21871 | &0.154647E-02,0.156100E-02,0.154811E-02,0.154647E-02,0.314732E-01/ |
| 21872 | DATA (DL(K),K= 2296, 2380) / |
| 21873 | &0.216964E-03,0.160335E+00,0.186895E+00,0.137545E-02,0.139092E-02, |
| 21874 | &0.137713E-02,0.137545E-02,0.271927E-01,0.222455E-03,0.146604E+00, |
| 21875 | &0.168227E+00,0.122121E-02,0.123733E-02,0.122290E-02,0.122121E-02, |
| 21876 | &0.234852E-01,0.222947E-03,0.133756E+00,0.151116E+00,0.108234E-02, |
| 21877 | &0.109881E-02,0.108400E-02,0.108234E-02,0.202747E-01,0.219474E-03, |
| 21878 | &0.121765E+00,0.135471E+00,0.957502E-03,0.974107E-03,0.959112E-03, |
| 21879 | &0.957502E-03,0.174932E-01,0.212928E-03,0.110606E+00,0.121198E+00, |
| 21880 | &0.845493E-03,0.862024E-03,0.847037E-03,0.845493E-03,0.150824E-01, |
| 21881 | &0.204075E-03,0.100250E+00,0.108210E+00,0.745196E-03,0.761482E-03, |
| 21882 | &0.746662E-03,0.745196E-03,0.129965E-01,0.193573E-03,0.906661E-01, |
| 21883 | &0.964191E-01,0.655569E-03,0.671466E-03,0.656948E-03,0.655569E-03, |
| 21884 | &0.111930E-01,0.181962E-03,0.818218E-01,0.857412E-01,0.575637E-03, |
| 21885 | &0.591030E-03,0.576925E-03,0.575637E-03,0.962922E-02,0.169687E-03, |
| 21886 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21887 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21888 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21889 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ |
| 21890 | DATA (DL(K),K= 2381, 2465) / |
| 21891 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21892 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21893 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21894 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21895 | &0.246444E+00,0.293515E+00,0.167124E-02,0.167124E-02,0.167124E-02, |
| 21896 | &0.167124E-02,0.456929E-01,-.260209E-17,0.226393E+00,0.264836E+00, |
| 21897 | &0.147748E-02,0.148085E-02,0.147783E-02,0.147748E-02,0.392393E-01, |
| 21898 | &0.318190E-04,0.207552E+00,0.238550E+00,0.130596E-02,0.131212E-02, |
| 21899 | &0.130656E-02,0.130596E-02,0.337276E-01,0.566426E-04,0.189877E+00, |
| 21900 | &0.214470E+00,0.115347E-02,0.116190E-02,0.115427E-02,0.115347E-02, |
| 21901 | &0.290012E-01,0.753776E-04,0.173336E+00,0.192452E+00,0.101789E-02, |
| 21902 | &0.102811E-02,0.101881E-02,0.101789E-02,0.249381E-01,0.889466E-04, |
| 21903 | &0.157889E+00,0.172355E+00,0.897268E-03,0.908872E-03,0.898270E-03, |
| 21904 | &0.897268E-03,0.214419E-01,0.980950E-04,0.143501E+00,0.154046E+00, |
| 21905 | &0.789951E-03,0.802565E-03,0.790996E-03,0.789951E-03,0.184296E-01, |
| 21906 | &0.103536E-03,0.130132E+00,0.137402E+00,0.694510E-03,0.707811E-03, |
| 21907 | &0.695568E-03,0.694510E-03,0.158331E-01,0.105929E-03,0.117743E+00/ |
| 21908 | DATA (DL(K),K= 2466, 2550) / |
| 21909 | &0.122303E+00,0.609684E-03,0.623394E-03,0.610733E-03,0.609684E-03, |
| 21910 | &0.135929E-01,0.105853E-03,0.106293E+00,0.108637E+00,0.534365E-03, |
| 21911 | &0.548244E-03,0.535386E-03,0.534365E-03,0.116583E-01,0.103825E-03, |
| 21912 | &0.957386E-01,0.962976E-01,0.467572E-03,0.481416E-03,0.468551E-03, |
| 21913 | &0.467572E-03,0.999103E-02,0.100301E-03,0.860376E-01,0.851820E-01, |
| 21914 | &0.408422E-03,0.422062E-03,0.409350E-03,0.408422E-03,0.855563E-02, |
| 21915 | &0.956675E-04,0.771455E-01,0.751930E-01,0.356117E-03,0.369416E-03, |
| 21916 | &0.356989E-03,0.356117E-03,0.731542E-02,0.902499E-04,0.690178E-01, |
| 21917 | &0.662386E-01,0.309950E-03,0.322797E-03,0.310761E-03,0.309950E-03, |
| 21918 | &0.624633E-02,0.843305E-04,0.616096E-01,0.582312E-01,0.269281E-03, |
| 21919 | &0.281590E-03,0.270030E-03,0.269281E-03,0.533230E-02,0.781441E-04, |
| 21920 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21921 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21922 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21923 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21924 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21925 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ |
| 21926 | DATA (DL(K),K= 2551, 2635) / |
| 21927 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21928 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21929 | &0.209608E+00,0.224862E+00,0.869706E-03,0.869706E-03,0.869706E-03, |
| 21930 | &0.869706E-03,0.264204E-01,-.138236E-17,0.190523E+00,0.200603E+00, |
| 21931 | &0.757542E-03,0.760626E-03,0.757768E-03,0.757542E-03,0.226261E-01, |
| 21932 | &0.138827E-04,0.172819E+00,0.178656E+00,0.660281E-03,0.665837E-03, |
| 21933 | &0.660670E-03,0.660281E-03,0.194018E-01,0.249832E-04,0.156420E+00, |
| 21934 | &0.158805E+00,0.575414E-03,0.582918E-03,0.575917E-03,0.575414E-03, |
| 21935 | &0.166434E-01,0.334851E-04,0.141265E+00,0.140883E+00,0.501258E-03, |
| 21936 | &0.510252E-03,0.501836E-03,0.501258E-03,0.142710E-01,0.397017E-04, |
| 21937 | &0.127291E+00,0.124732E+00,0.436386E-03,0.446473E-03,0.437008E-03, |
| 21938 | &0.436386E-03,0.122297E-01,0.439154E-04,0.114437E+00,0.110205E+00, |
| 21939 | &0.379575E-03,0.390415E-03,0.380217E-03,0.379575E-03,0.104701E-01, |
| 21940 | &0.464110E-04,0.102644E+00,0.971655E-01,0.329805E-03,0.341109E-03, |
| 21941 | &0.330448E-03,0.329805E-03,0.895086E-02,0.474758E-04,0.918521E-01, |
| 21942 | &0.854876E-01,0.286206E-03,0.297729E-03,0.286836E-03,0.286206E-03, |
| 21943 | &0.764249E-02,0.473771E-04,0.820032E-01,0.750529E-01,0.248027E-03/ |
| 21944 | DATA (DL(K),K= 2636, 2720) / |
| 21945 | &0.259564E-03,0.248633E-03,0.248027E-03,0.651744E-02,0.463561E-04, |
| 21946 | &0.730394E-01,0.657510E-01,0.214611E-03,0.225995E-03,0.215186E-03, |
| 21947 | &0.214611E-03,0.554573E-02,0.446239E-04,0.649040E-01,0.574789E-01, |
| 21948 | &0.185396E-03,0.196491E-03,0.185935E-03,0.185396E-03,0.470938E-02, |
| 21949 | &0.423722E-04,0.575411E-01,0.501405E-01,0.159891E-03,0.170590E-03, |
| 21950 | &0.160391E-03,0.159891E-03,0.399752E-02,0.397689E-04,0.508960E-01, |
| 21951 | &0.436466E-01,0.137650E-03,0.147874E-03,0.138111E-03,0.137650E-03, |
| 21952 | &0.338807E-02,0.369434E-04,0.449157E-01,0.379141E-01,0.118285E-03, |
| 21953 | &0.127973E-03,0.118705E-03,0.118285E-03,0.286125E-02,0.340035E-04, |
| 21954 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21955 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21956 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21957 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21958 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21959 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21960 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21961 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ |
| 21962 | DATA (DL(K),K= 2721, 2805) / |
| 21963 | &0.173133E+00,0.165162E+00,0.420483E-03,0.420483E-03,0.420483E-03, |
| 21964 | &0.420483E-03,0.143704E-01,0.418773E-17,0.155600E+00,0.145586E+00, |
| 21965 | &0.360490E-03,0.363140E-03,0.360629E-03,0.360490E-03,0.123560E-01, |
| 21966 | &0.533279E-05,0.139551E+00,0.128113E+00,0.309555E-03,0.314310E-03, |
| 21967 | &0.309792E-03,0.309555E-03,0.106262E-01,0.982612E-05,0.124876E+00, |
| 21968 | &0.112516E+00,0.265952E-03,0.272344E-03,0.266256E-03,0.265952E-03, |
| 21969 | &0.913151E-02,0.133834E-04,0.111490E+00,0.986188E-01,0.228522E-03, |
| 21970 | &0.236138E-03,0.228869E-03,0.228522E-03,0.783135E-02,0.160429E-04, |
| 21971 | &0.993081E-01,0.862590E-01,0.196336E-03,0.204821E-03,0.196706E-03, |
| 21972 | &0.196336E-03,0.670031E-02,0.178799E-04,0.882484E-01,0.752883E-01, |
| 21973 | &0.168604E-03,0.177655E-03,0.168981E-03,0.168604E-03,0.572016E-02, |
| 21974 | &0.189837E-04,0.782334E-01,0.655714E-01,0.144684E-03,0.154047E-03, |
| 21975 | &0.145058E-03,0.144684E-03,0.487276E-02,0.194655E-04,0.691885E-01, |
| 21976 | &0.569841E-01,0.124035E-03,0.133497E-03,0.124397E-03,0.124035E-03, |
| 21977 | &0.413648E-02,0.194296E-04,0.610420E-01,0.494128E-01,0.106203E-03, |
| 21978 | &0.115592E-03,0.106548E-03,0.106203E-03,0.350042E-02,0.189800E-04, |
| 21979 | &0.537249E-01,0.427533E-01,0.908141E-04,0.999895E-04,0.911377E-04/ |
| 21980 | DATA (DL(K),K= 2806, 2890) / |
| 21981 | &0.908141E-04,0.295961E-02,0.182192E-04,0.471713E-01,0.369100E-01, |
| 21982 | &0.775359E-04,0.863895E-04,0.778360E-04,0.775359E-04,0.249629E-02, |
| 21983 | &0.172287E-04,0.413182E-01,0.317957E-01,0.660857E-04,0.745356E-04, |
| 21984 | &0.663611E-04,0.660857E-04,0.209482E-02,0.160791E-04,0.361056E-01, |
| 21985 | &0.273306E-01,0.562298E-04,0.642173E-04,0.564804E-04,0.562298E-04, |
| 21986 | &0.175588E-02,0.148407E-04,0.314766E-01,0.234421E-01,0.477598E-04, |
| 21987 | &0.552457E-04,0.479859E-04,0.477598E-04,0.147398E-02,0.135653E-04, |
| 21988 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21989 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21990 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21991 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21992 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21993 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21994 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21995 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 21996 | &0.138007E+00,0.115214E+00,0.185072E-03,0.185072E-03,0.185072E-03, |
| 21997 | &0.185072E-03,0.722856E-02,-.380826E-17,0.122517E+00,0.100251E+00/ |
| 21998 | DATA (DL(K),K= 2891, 2975) / |
| 21999 | &0.155814E-03,0.158287E-03,0.155901E-03,0.155814E-03,0.630580E-02, |
| 22000 | &0.155371E-05,0.108535E+00,0.870870E-01,0.131535E-03,0.135909E-03, |
| 22001 | &0.131680E-03,0.131535E-03,0.547867E-02,0.304952E-05,0.959260E-01, |
| 22002 | &0.754985E-01,0.111183E-03,0.116980E-03,0.111366E-03,0.111183E-03, |
| 22003 | &0.473794E-02,0.433106E-05,0.845828E-01,0.653163E-01,0.940433E-04, |
| 22004 | &0.100851E-03,0.942493E-04,0.940433E-04,0.407647E-02,0.533613E-05, |
| 22005 | &0.744017E-01,0.563870E-01,0.795843E-04,0.870596E-04,0.798007E-04, |
| 22006 | &0.795843E-04,0.349165E-02,0.606691E-05,0.652864E-01,0.485720E-01, |
| 22007 | &0.673476E-04,0.752069E-04,0.675656E-04,0.673476E-04,0.297273E-02, |
| 22008 | &0.652898E-05,0.571466E-01,0.417472E-01,0.569700E-04,0.649812E-04, |
| 22009 | &0.571831E-04,0.569700E-04,0.251732E-02,0.675028E-05,0.498975E-01, |
| 22010 | &0.358008E-01,0.481618E-04,0.561391E-04,0.483654E-04,0.481618E-04, |
| 22011 | &0.212754E-02,0.677236E-05,0.434594E-01,0.306320E-01,0.406746E-04, |
| 22012 | &0.484724E-04,0.408657E-04,0.406746E-04,0.179059E-02,0.662814E-05, |
| 22013 | &0.377578E-01,0.261500E-01,0.343050E-04,0.418123E-04,0.344818E-04, |
| 22014 | &0.343050E-04,0.149563E-02,0.635273E-05,0.327229E-01,0.222734E-01, |
| 22015 | &0.288923E-04,0.360279E-04,0.290540E-04,0.288923E-04,0.124695E-02/ |
| 22016 | DATA (DL(K),K= 2976, 3060) / |
| 22017 | &0.598767E-05,0.282894E-01,0.189287E-01,0.242960E-04,0.310036E-04, |
| 22018 | &0.244423E-04,0.242960E-04,0.104112E-02,0.556344E-05,0.243968E-01, |
| 22019 | &0.160504E-01,0.203920E-04,0.266363E-04,0.205232E-04,0.203920E-04, |
| 22020 | &0.863677E-03,0.510070E-05,0.209890E-01,0.135797E-01,0.170822E-04, |
| 22021 | &0.228449E-04,0.171989E-04,0.170822E-04,0.711641E-03,0.462338E-05, |
| 22022 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22023 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22024 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22025 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22026 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22027 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22028 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22029 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22030 | &0.105155E+00,0.752467E-01,0.719932E-04,0.719932E-04,0.719932E-04, |
| 22031 | &0.719932E-04,0.328057E-02,-.758942E-18,0.920856E-01,0.645455E-01, |
| 22032 | &0.592305E-04,0.615087E-04,0.592802E-04,0.592305E-04,0.295327E-02, |
| 22033 | &0.945234E-07,0.804695E-01,0.552770E-01,0.489125E-04,0.528632E-04/ |
| 22034 | DATA (DL(K),K= 3061, 3145) / |
| 22035 | &0.489946E-04,0.489125E-04,0.261804E-02,0.365139E-06,0.701499E-01, |
| 22036 | &0.472409E-01,0.404786E-04,0.456186E-04,0.405807E-04,0.404786E-04, |
| 22037 | &0.229460E-02,0.686912E-06,0.610049E-01,0.402864E-01,0.335367E-04, |
| 22038 | &0.394631E-04,0.336495E-04,0.335367E-04,0.198445E-02,0.981070E-06, |
| 22039 | &0.529201E-01,0.342803E-01,0.278134E-04,0.342044E-04,0.279301E-04, |
| 22040 | &0.278134E-04,0.169772E-02,0.122521E-05,0.457907E-01,0.291037E-01, |
| 22041 | &0.230821E-04,0.296833E-04,0.231978E-04,0.230821E-04,0.144575E-02, |
| 22042 | &0.140819E-05,0.395205E-01,0.246522E-01,0.191553E-04,0.257661E-04, |
| 22043 | &0.192666E-04,0.191553E-04,0.122125E-02,0.152152E-05,0.340212E-01, |
| 22044 | &0.208330E-01,0.158874E-04,0.223546E-04,0.159921E-04,0.158874E-04, |
| 22045 | &0.101912E-02,0.156880E-05,0.292116E-01,0.175644E-01,0.131678E-04, |
| 22046 | &0.193783E-04,0.132645E-04,0.131678E-04,0.847586E-03,0.156432E-05, |
| 22047 | &0.250173E-01,0.147740E-01,0.109029E-04,0.167762E-04,0.109910E-04, |
| 22048 | &0.109029E-04,0.705515E-03,0.151845E-05,0.213702E-01,0.123979E-01, |
| 22049 | &0.901273E-05,0.144953E-04,0.909200E-05,0.901273E-05,0.581767E-03, |
| 22050 | &0.143817E-05,0.182083E-01,0.103797E-01,0.743733E-05,0.124978E-04, |
| 22051 | &0.750792E-05,0.743733E-05,0.475483E-03,0.133574E-05,0.154751E-01/ |
| 22052 | DATA (DL(K),K= 3146, 3230) / |
| 22053 | &0.867011E-02,0.612722E-05,0.107517E-04,0.618950E-05,0.612722E-05, |
| 22054 | &0.390116E-03,0.122183E-05,0.131193E-01,0.722560E-02,0.503734E-05, |
| 22055 | &0.922584E-05,0.509185E-05,0.503734E-05,0.319980E-03,0.110130E-05, |
| 22056 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22057 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22058 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22059 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22060 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22061 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22062 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22063 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22064 | &0.754424E-01,0.449848E-01,0.236444E-04,0.236444E-04,0.236444E-04, |
| 22065 | &0.236444E-04,0.129291E-02,0.113079E-17,0.650429E-01,0.379660E-01, |
| 22066 | &0.187739E-04,0.207130E-04,0.187990E-04,0.187739E-04,0.124038E-02, |
| 22067 | &-.327995E-06,0.559588E-01,0.319936E-01,0.149625E-04,0.182671E-04, |
| 22068 | &0.150033E-04,0.149625E-04,0.113497E-02,-.464337E-06,0.480234E-01, |
| 22069 | &0.269030E-01,0.119484E-04,0.161746E-04,0.119982E-04,0.119484E-04/ |
| 22070 | DATA (DL(K),K= 3231, 3315) / |
| 22071 | &0.100877E-02,-.490618E-06,0.411091E-01,0.225716E-01,0.954833E-05, |
| 22072 | &0.143391E-04,0.960250E-05,0.954833E-05,0.883852E-03,-.461770E-06, |
| 22073 | &0.350995E-01,0.188947E-01,0.763738E-05,0.127129E-04,0.769248E-05, |
| 22074 | &0.763738E-05,0.760077E-03,-.403363E-06,0.298897E-01,0.157798E-01, |
| 22075 | &0.611070E-05,0.112548E-04,0.616439E-05,0.611070E-05,0.639505E-03, |
| 22076 | &-.335607E-06,0.253856E-01,0.131470E-01,0.488993E-05,0.994021E-05, |
| 22077 | &0.494070E-05,0.488993E-05,0.534131E-03,-.267652E-06,0.215026E-01, |
| 22078 | &0.109271E-01,0.391276E-05,0.875190E-05,0.395967E-05,0.391276E-05, |
| 22079 | &0.445478E-03,-.205292E-06,0.181648E-01,0.906007E-02,0.312720E-05, |
| 22080 | &0.767418E-05,0.316978E-05,0.312720E-05,0.366232E-03,-.154024E-06, |
| 22081 | &0.153041E-01,0.749382E-02,0.249633E-05,0.670002E-05,0.253440E-05, |
| 22082 | &0.249633E-05,0.297435E-03,-.112673E-06,0.128596E-01,0.618334E-02, |
| 22083 | &0.199074E-05,0.582360E-05,0.202435E-05,0.199074E-05,0.242305E-03, |
| 22084 | &-.794410E-07,0.107770E-01,0.508977E-02,0.158457E-05,0.503733E-05, |
| 22085 | &0.161393E-05,0.158457E-05,0.196927E-03,-.546702E-07,0.900806E-02, |
| 22086 | &0.417964E-02,0.125888E-05,0.433619E-05,0.128428E-05,0.125888E-05, |
| 22087 | &0.158171E-03,-.364714E-07,0.751006E-02,0.342418E-02,0.998674E-06/ |
| 22088 | DATA (DL(K),K= 3316, 3400) / |
| 22089 | &0.371518E-05,0.102046E-05,0.998674E-06,0.126865E-03,-.228706E-07, |
| 22090 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22091 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22092 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22093 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22094 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22095 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22096 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22097 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22098 | &0.496787E-01,0.236961E-01,0.607312E-05,0.607312E-05,0.607312E-05, |
| 22099 | &0.607312E-05,0.415108E-03,-.140523E-17,0.420445E-01,0.196196E-01, |
| 22100 | &0.443589E-05,0.603481E-05,0.444683E-05,0.443589E-05,0.444425E-03, |
| 22101 | &-.375397E-06,0.355108E-01,0.162223E-01,0.321766E-05,0.587645E-05, |
| 22102 | &0.323504E-05,0.321766E-05,0.432635E-03,-.593989E-06,0.299148E-01, |
| 22103 | &0.133836E-01,0.231504E-05,0.562250E-05,0.233581E-05,0.231504E-05, |
| 22104 | &0.395801E-03,-.699904E-06,0.251339E-01,0.110157E-01,0.164651E-05, |
| 22105 | &0.526880E-05,0.166853E-05,0.164651E-05,0.344925E-03,-.733095E-06/ |
| 22106 | DATA (DL(K),K= 3401, 3485) / |
| 22107 | &0.210605E-01,0.904539E-02,0.115940E-05,0.485739E-05,0.118122E-05, |
| 22108 | &0.115940E-05,0.294439E-03,-.715193E-06,0.175989E-01,0.740944E-02, |
| 22109 | &0.808365E-06,0.441709E-05,0.829075E-06,0.808365E-06,0.249093E-03, |
| 22110 | &-.665420E-06,0.146656E-01,0.605433E-02,0.555563E-06,0.396078E-05, |
| 22111 | &0.574607E-06,0.555563E-06,0.205675E-03,-.600648E-06,0.121872E-01, |
| 22112 | &0.493466E-02,0.375914E-06,0.350822E-05,0.393011E-06,0.375914E-06, |
| 22113 | &0.166757E-03,-.529210E-06,0.100993E-01,0.401191E-02,0.250032E-06, |
| 22114 | &0.307359E-05,0.265094E-06,0.250032E-06,0.135196E-03,-.456996E-06, |
| 22115 | &0.834582E-02,0.325348E-02,0.162261E-06,0.266488E-05,0.175325E-06, |
| 22116 | &0.162261E-06,0.108862E-03,-.388821E-06,0.687767E-02,0.263179E-02, |
| 22117 | &0.102273E-06,0.228913E-05,0.113453E-06,0.102273E-06,0.865539E-04, |
| 22118 | &-.326325E-06,0.565221E-02,0.212357E-02,0.620694E-07,0.194975E-05, |
| 22119 | &0.715290E-07,0.620694E-07,0.687156E-04,-.270547E-06,0.463248E-02, |
| 22120 | &0.170926E-02,0.351992E-07,0.164711E-05,0.431226E-07,0.351992E-07, |
| 22121 | &0.543744E-04,-.222379E-06,0.378655E-02,0.137242E-02,0.178902E-07, |
| 22122 | &0.138124E-05,0.244675E-07,0.178902E-07,0.426626E-04,-.181158E-06, |
| 22123 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ |
| 22124 | DATA (DL(K),K= 3486, 3570) / |
| 22125 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22126 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22127 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22128 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22129 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22130 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22131 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22132 | &0.286141E-01,0.102357E-01,0.105702E-05,0.105702E-05,0.105702E-05, |
| 22133 | &0.105702E-05,0.963318E-04,0.591070E-18,0.236608E-01,0.827483E-02, |
| 22134 | &0.548552E-06,0.163293E-05,0.551993E-06,0.548552E-06,0.133058E-03, |
| 22135 | &-.268677E-06,0.195282E-01,0.668247E-02,0.238780E-06,0.183459E-05, |
| 22136 | &0.243802E-06,0.238780E-06,0.135119E-03,-.393414E-06,0.160742E-01, |
| 22137 | &0.538444E-02,0.599864E-07,0.183277E-05,0.655085E-07,0.599864E-07, |
| 22138 | &0.124554E-03,-.428349E-06,0.131940E-01,0.432750E-02,-.392825E-07, |
| 22139 | &0.172071E-05,-.338391E-07,-.392825E-07,0.111121E-03,-.415550E-06, |
| 22140 | &0.107996E-01,0.346954E-02,-.875089E-07,0.154604E-05,-.824926E-07, |
| 22141 | &-.875089E-07,0.941854E-04,-.376855E-06,0.881435E-02,0.277463E-02/ |
| 22142 | DATA (DL(K),K= 3571, 3655) / |
| 22143 | &-.103962E-06,0.135013E-05,-.995446E-07,-.103962E-06,0.772195E-04, |
| 22144 | &-.326008E-06,0.717317E-02,0.221313E-02,-.102844E-06,0.115335E-05, |
| 22145 | &-.990733E-07,-.102844E-06,0.626565E-04,-.272858E-06,0.582050E-02, |
| 22146 | &0.176061E-02,-.929503E-07,0.967229E-06,-.898064E-07,-.929503E-07, |
| 22147 | &0.499930E-04,-.222828E-06,0.470908E-02,0.139692E-02,-.791495E-07, |
| 22148 | &0.800414E-06,-.765797E-07,-.791495E-07,0.394181E-04,-.178141E-06, |
| 22149 | &0.379875E-02,0.110542E-02,-.647230E-07,0.655119E-06,-.626567E-07, |
| 22150 | &-.647230E-07,0.309999E-04,-.140000E-06,0.305549E-02,0.872447E-03, |
| 22151 | &-.515215E-07,0.530834E-06,-.498829E-07,-.515215E-07,0.240354E-04, |
| 22152 | &-.108633E-06,0.245058E-02,0.686769E-03,-.400234E-07,0.426835E-06, |
| 22153 | &-.387401E-07,-.400234E-07,0.184613E-04,-.832544E-07,0.195984E-02, |
| 22154 | &0.539209E-03,-.304312E-07,0.341169E-06,-.294373E-07,-.304312E-07, |
| 22155 | &0.143512E-04,-.630818E-07,0.156297E-02,0.422273E-03,-.228633E-07, |
| 22156 | &0.271199E-06,-.221014E-07,-.228633E-07,0.110898E-04,-.474683E-07, |
| 22157 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22158 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22159 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ |
| 22160 | DATA (DL(K),K= 3656, 3740) / |
| 22161 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22162 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22163 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22164 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22165 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22166 | &0.129345E-01,0.308444E-02,0.903693E-07,0.903693E-07,0.903693E-07, |
| 22167 | &0.903693E-07,0.123538E-04,-.166230E-18,0.103598E-01,0.241354E-02, |
| 22168 | &0.155648E-06,-.205296E-06,0.154889E-06,0.155648E-06,0.267249E-04, |
| 22169 | &0.880707E-07,0.828507E-02,0.188764E-02,0.176333E-06,-.341498E-06, |
| 22170 | &0.175220E-06,0.176333E-06,0.306432E-04,0.125718E-06,0.660736E-02, |
| 22171 | &0.147304E-02,0.173444E-06,-.383695E-06,0.172215E-06,0.173444E-06, |
| 22172 | &0.280787E-04,0.135578E-06,0.525320E-02,0.114618E-02,0.158651E-06, |
| 22173 | &-.373371E-06,0.157437E-06,0.158651E-06,0.243526E-04,0.130412E-06, |
| 22174 | &0.416429E-02,0.889584E-03,0.137131E-06,-.333468E-06,0.136012E-06, |
| 22175 | &0.137131E-06,0.203463E-04,0.116115E-06,0.329102E-02,0.688580E-03, |
| 22176 | &0.113839E-06,-.280874E-06,0.112853E-06,0.113839E-06,0.161038E-04, |
| 22177 | &0.982305E-07,0.259282E-02,0.531508E-03,0.914374E-07,-.225427E-06/ |
| 22178 | DATA (DL(K),K= 3741, 3825) / |
| 22179 | &0.905971E-07,0.914374E-07,0.125639E-04,0.798741E-07,0.203641E-02, |
| 22180 | &0.409120E-03,0.709595E-07,-.173123E-06,0.702607E-07,0.709595E-07, |
| 22181 | &0.979247E-05,0.624138E-07,0.159441E-02,0.314027E-03,0.532256E-07, |
| 22182 | &-.127272E-06,0.526566E-07,0.532256E-07,0.741899E-05,0.469253E-07, |
| 22183 | &0.124447E-02,0.240357E-03,0.385509E-07,-.888851E-07,0.380956E-07, |
| 22184 | &0.385509E-07,0.554070E-05,0.339174E-07,0.968328E-03,0.183454E-03, |
| 22185 | &0.267272E-07,-.580277E-07,0.263687E-07,0.267272E-07,0.420032E-05, |
| 22186 | &0.233280E-07,0.751159E-03,0.139632E-03,0.174605E-07,-.342016E-07, |
| 22187 | &0.171822E-07,0.174605E-07,0.315522E-05,0.149727E-07,0.580936E-03, |
| 22188 | &0.105986E-03,0.104515E-07,-.164567E-07,0.102383E-07,0.104515E-07, |
| 22189 | &0.230829E-05,0.863527E-08,0.447955E-03,0.802293E-04,0.531954E-08, |
| 22190 | &-.376312E-08,0.515829E-08,0.531954E-08,0.170771E-05,0.399662E-08, |
| 22191 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22192 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22193 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22194 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22195 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ |
| 22196 | DATA (DL(K),K= 3826, 3910) / |
| 22197 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22198 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22199 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22200 | &0.324478E-02,0.386879E-03,0.135983E-08,0.135983E-08,0.135983E-08, |
| 22201 | &0.135983E-08,0.371787E-06,-.274599E-19,0.246219E-02,0.286505E-03, |
| 22202 | &-.106852E-06,0.327611E-06,-.106589E-06,-.106852E-06,0.231631E-05, |
| 22203 | &-.107814E-06,0.186777E-02,0.212413E-03,-.161566E-06,0.492001E-06, |
| 22204 | &-.161179E-06,-.161566E-06,0.311589E-05,-.162249E-06,0.141322E-02, |
| 22205 | &0.157212E-03,-.183398E-06,0.557106E-06,-.182972E-06,-.183398E-06, |
| 22206 | &0.267943E-05,-.183884E-06,0.106518E-02,0.115892E-03,-.185231E-06, |
| 22207 | &0.562185E-06,-.184809E-06,-.185231E-06,0.203027E-05,-.185573E-06, |
| 22208 | &0.800350E-03,0.851995E-04,-.174680E-06,0.530096E-06,-.174290E-06, |
| 22209 | &-.174680E-06,0.165870E-05,-.174922E-06,0.599444E-03,0.624676E-04, |
| 22210 | &-.157644E-06,0.478420E-06,-.157300E-06,-.157644E-06,0.130112E-05, |
| 22211 | &-.157815E-06,0.447433E-03,0.456556E-04,-.137838E-06,0.418429E-06, |
| 22212 | &-.137543E-06,-.137838E-06,0.903220E-06,-.137958E-06,0.332836E-03, |
| 22213 | &0.332643E-04,-.117616E-06,0.357179E-06,-.117368E-06,-.117616E-06/ |
| 22214 | DATA (DL(K),K= 3911, 3995) / |
| 22215 | &0.636187E-06,-.117699E-06,0.246754E-03,0.241622E-04,-.984560E-07, |
| 22216 | &0.299077E-06,-.982529E-07,-.984560E-07,0.481221E-06,-.985144E-07, |
| 22217 | &0.182315E-03,0.174961E-04,-.811089E-07,0.246465E-06,-.809446E-07, |
| 22218 | &-.811089E-07,0.342859E-06,-.811495E-07,0.134250E-03,0.126299E-04, |
| 22219 | &-.659052E-07,0.200354E-06,-.657742E-07,-.659052E-07,0.227840E-06, |
| 22220 | &-.659334E-07,0.985288E-04,0.908931E-05,-.529252E-07,0.160947E-06, |
| 22221 | &-.528218E-07,-.529252E-07,0.161641E-06,-.529447E-07,0.720750E-04, |
| 22222 | &0.652153E-05,-.420621E-07,0.127943E-06,-.419814E-07,-.420621E-07, |
| 22223 | &0.119540E-06,-.420756E-07,0.525538E-04,0.466527E-05,-.331141E-07, |
| 22224 | &0.100758E-06,-.330516E-07,-.331141E-07,0.808991E-07,-.331233E-07, |
| 22225 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22226 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22227 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22228 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22229 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22230 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22231 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ |
| 22232 | DATA (DL(K),K= 3996, 4000) / |
| 22233 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ |
| 22234 | C |
| 22235 | ANS = 0. |
| 22236 | IF (X.GT.0.9985) RETURN |
| 22237 | IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN |
| 22238 | C |
| 22239 | IS = S/DELTA+1 |
| 22240 | IS1 = IS+1 |
| 22241 | DO 1 L=1,25 |
| 22242 | KL = L+NDRV*25 |
| 22243 | F1(L) = GF(I,IS,KL) |
| 22244 | F2(L) = GF(I,IS1,KL) |
| 22245 | 1 CONTINUE |
| 22246 | A1 = DT_CKMTFF(X,F1) |
| 22247 | A2 = DT_CKMTFF(X,F2) |
| 22248 | C A1=ALOG(A1) |
| 22249 | C A2=ALOG(A2) |
| 22250 | S1 = (IS-1)*DELTA |
| 22251 | S2 = S1+DELTA |
| 22252 | ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1) |
| 22253 | C ANS=EXP(ANS) |
| 22254 | RETURN |
| 22255 | END |
| 22256 | C |
| 22257 | C |
| 22258 | CDECK ID>, DT_CKMTPR |
| 22259 | SUBROUTINE DT_CKMTPR(I,NDRV,X,S,ANS) |
| 22260 | C |
| 22261 | C********************************************************************** |
| 22262 | C Proton - PDFs |
| 22263 | C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc |
| 22264 | C ANS = PDF(I) |
| 22265 | C This version by S. Roesler, 31.01.96 |
| 22266 | C********************************************************************** |
| 22267 | |
| 22268 | SAVE |
| 22269 | DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000) |
| 22270 | EQUIVALENCE (GF(1,1,1),DL(1)) |
| 22271 | DATA DELTA/.10/ |
| 22272 | C |
| 22273 | DATA (DL(K),K= 1, 85) / |
| 22274 | &0.367759E+00,0.350609E+00,0.325356E+00,0.325356E+00,0.325356E+00, |
| 22275 | &0.325356E+00,0.533117E+01,0.138778E-16,0.427988E+00,0.409718E+00, |
| 22276 | &0.382948E+00,0.382920E+00,0.382933E+00,0.382948E+00,0.686279E+01, |
| 22277 | &0.611113E-01,0.494752E+00,0.475328E+00,0.447011E+00,0.446959E+00, |
| 22278 | &0.446984E+00,0.447011E+00,0.855688E+01,0.128659E+00,0.568248E+00, |
| 22279 | &0.547637E+00,0.517743E+00,0.517671E+00,0.517705E+00,0.517743E+00, |
| 22280 | &0.104074E+02,0.202846E+00,0.648622E+00,0.626792E+00,0.595289E+00, |
| 22281 | &0.595201E+00,0.595244E+00,0.595289E+00,0.124065E+02,0.283819E+00, |
| 22282 | &0.735974E+00,0.712890E+00,0.679748E+00,0.679648E+00,0.679696E+00, |
| 22283 | &0.679748E+00,0.145441E+02,0.371679E+00,0.830359E+00,0.805987E+00, |
| 22284 | &0.771173E+00,0.771066E+00,0.771119E+00,0.771173E+00,0.168081E+02, |
| 22285 | &0.466485E+00,0.931778E+00,0.906084E+00,0.869566E+00,0.869456E+00, |
| 22286 | &0.869511E+00,0.869566E+00,0.191850E+02,0.568240E+00,0.104018E+01, |
| 22287 | &0.101313E+01,0.974873E+00,0.974763E+00,0.974819E+00,0.974873E+00, |
| 22288 | &0.216593E+02,0.676890E+00,0.115544E+01,0.112700E+01,0.108698E+01, |
| 22289 | &0.108687E+01,0.108693E+01,0.108698E+01,0.242146E+02,0.792321E+00, |
| 22290 | &0.127738E+01,0.124751E+01,0.120570E+01,0.120560E+01,0.120565E+01/ |
| 22291 | DATA (DL(K),K= 86, 170) / |
| 22292 | &0.120570E+01,0.268333E+02,0.914356E+00,0.140577E+01,0.137444E+01, |
| 22293 | &0.133079E+01,0.133070E+01,0.133075E+01,0.133079E+01,0.294970E+02, |
| 22294 | &0.104275E+01,0.154028E+01,0.150745E+01,0.146194E+01,0.146187E+01, |
| 22295 | &0.146192E+01,0.146194E+01,0.321867E+02,0.117720E+01,0.168054E+01, |
| 22296 | &0.164619E+01,0.159879E+01,0.159874E+01,0.159877E+01,0.159879E+01, |
| 22297 | &0.348836E+02,0.131732E+01,0.182613E+01,0.179020E+01,0.174088E+01, |
| 22298 | &0.174086E+01,0.174088E+01,0.174088E+01,0.375685E+02,0.146269E+01, |
| 22299 | &0.197653E+01,0.193901E+01,0.188774E+01,0.188774E+01,0.188775E+01, |
| 22300 | &0.188774E+01,0.402228E+02,0.161282E+01,0.213121E+01,0.209205E+01, |
| 22301 | &0.203880E+01,0.203884E+01,0.203884E+01,0.203880E+01,0.428285E+02, |
| 22302 | &0.176714E+01,0.228955E+01,0.224873E+01,0.219348E+01,0.219355E+01, |
| 22303 | &0.219353E+01,0.219348E+01,0.453682E+02,0.192507E+01,0.245093E+01, |
| 22304 | &0.240840E+01,0.235113E+01,0.235123E+01,0.235120E+01,0.235113E+01, |
| 22305 | &0.478258E+02,0.208597E+01,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22306 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22307 | &0.349839E+00,0.324128E+00,0.286363E+00,0.286363E+00,0.286363E+00, |
| 22308 | &0.286363E+00,0.469694E+01,0.000000E+00,0.398361E+00,0.371065E+00/ |
| 22309 | DATA (DL(K),K= 171, 255) / |
| 22310 | &0.331239E+00,0.331213E+00,0.331227E+00,0.331239E+00,0.586152E+01, |
| 22311 | &0.481683E-01,0.451010E+00,0.422096E+00,0.380182E+00,0.380137E+00, |
| 22312 | &0.380161E+00,0.380182E+00,0.711349E+01,0.100378E+00,0.507782E+00, |
| 22313 | &0.477215E+00,0.433187E+00,0.433128E+00,0.433160E+00,0.433187E+00, |
| 22314 | &0.844371E+01,0.156627E+00,0.568644E+00,0.536390E+00,0.490220E+00, |
| 22315 | &0.490152E+00,0.490190E+00,0.490220E+00,0.984291E+01,0.216886E+00, |
| 22316 | &0.633517E+00,0.599543E+00,0.551204E+00,0.551133E+00,0.551174E+00, |
| 22317 | &0.551204E+00,0.113005E+02,0.281079E+00,0.702295E+00,0.666565E+00, |
| 22318 | &0.616031E+00,0.615963E+00,0.616004E+00,0.616031E+00,0.128050E+02, |
| 22319 | &0.349101E+00,0.774832E+00,0.737311E+00,0.684556E+00,0.684495E+00, |
| 22320 | &0.684535E+00,0.684556E+00,0.143447E+02,0.420809E+00,0.850945E+00, |
| 22321 | &0.811598E+00,0.756596E+00,0.756547E+00,0.756583E+00,0.756596E+00, |
| 22322 | &0.159073E+02,0.496022E+00,0.930413E+00,0.889207E+00,0.831933E+00, |
| 22323 | &0.831901E+00,0.831931E+00,0.831933E+00,0.174801E+02,0.574524E+00, |
| 22324 | &0.101298E+01,0.969882E+00,0.910312E+00,0.910301E+00,0.910324E+00, |
| 22325 | &0.910312E+00,0.190508E+02,0.656061E+00,0.109836E+01,0.105333E+01, |
| 22326 | &0.991445E+00,0.991459E+00,0.991471E+00,0.991445E+00,0.206070E+02/ |
| 22327 | DATA (DL(K),K= 256, 340) / |
| 22328 | &0.740345E+00,0.118622E+01,0.113923E+01,0.107501E+01,0.107505E+01, |
| 22329 | &0.107505E+01,0.107501E+01,0.221368E+02,0.827056E+00,0.127622E+01, |
| 22330 | &0.122724E+01,0.116065E+01,0.116073E+01,0.116072E+01,0.116065E+01, |
| 22331 | &0.236287E+02,0.915845E+00,0.136797E+01,0.131696E+01,0.124800E+01, |
| 22332 | &0.124812E+01,0.124809E+01,0.124800E+01,0.250721E+02,0.100634E+01, |
| 22333 | &0.146107E+01,0.140801E+01,0.133666E+01,0.133681E+01,0.133677E+01, |
| 22334 | &0.133666E+01,0.264571E+02,0.109813E+01,0.155511E+01,0.149996E+01, |
| 22335 | &0.142621E+01,0.142641E+01,0.142634E+01,0.142621E+01,0.277747E+02, |
| 22336 | &0.119081E+01,0.164964E+01,0.159239E+01,0.151622E+01,0.151646E+01, |
| 22337 | &0.151638E+01,0.151622E+01,0.290168E+02,0.128396E+01,0.174424E+01, |
| 22338 | &0.168485E+01,0.160626E+01,0.160655E+01,0.160645E+01,0.160626E+01, |
| 22339 | &0.301765E+02,0.137713E+01,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22340 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22341 | &0.345345E+00,0.306823E+00,0.250518E+00,0.250518E+00,0.250518E+00, |
| 22342 | &0.250518E+00,0.411726E+01,-.138778E-16,0.384210E+00,0.343514E+00, |
| 22343 | &0.284500E+00,0.284487E+00,0.284496E+00,0.284500E+00,0.496835E+01, |
| 22344 | &0.371582E-01,0.425419E+00,0.382518E+00,0.320782E+00,0.320762E+00/ |
| 22345 | DATA (DL(K),K= 341, 425) / |
| 22346 | &0.320777E+00,0.320782E+00,0.585504E+01,0.765988E-01,0.468853E+00, |
| 22347 | &0.423717E+00,0.359246E+00,0.359226E+00,0.359243E+00,0.359246E+00, |
| 22348 | &0.676824E+01,0.118207E+00,0.514392E+00,0.466990E+00,0.399771E+00, |
| 22349 | &0.399758E+00,0.399775E+00,0.399771E+00,0.769967E+01,0.161865E+00, |
| 22350 | &0.561883E+00,0.512186E+00,0.442209E+00,0.442208E+00,0.442222E+00, |
| 22351 | &0.442209E+00,0.864071E+01,0.207426E+00,0.611162E+00,0.559140E+00, |
| 22352 | &0.486395E+00,0.486411E+00,0.486420E+00,0.486395E+00,0.958280E+01, |
| 22353 | &0.254727E+00,0.662044E+00,0.607667E+00,0.532145E+00,0.532185E+00, |
| 22354 | &0.532185E+00,0.532145E+00,0.105176E+02,0.303587E+00,0.714325E+00, |
| 22355 | &0.657566E+00,0.579261E+00,0.579328E+00,0.579318E+00,0.579261E+00, |
| 22356 | &0.114370E+02,0.353808E+00,0.767786E+00,0.708618E+00,0.627526E+00, |
| 22357 | &0.627625E+00,0.627603E+00,0.627526E+00,0.123333E+02,0.405174E+00, |
| 22358 | &0.822195E+00,0.760591E+00,0.676711E+00,0.676846E+00,0.676810E+00, |
| 22359 | &0.676711E+00,0.131994E+02,0.457458E+00,0.877307E+00,0.813242E+00, |
| 22360 | &0.726575E+00,0.726750E+00,0.726697E+00,0.726575E+00,0.140286E+02, |
| 22361 | &0.510420E+00,0.932865E+00,0.866317E+00,0.776867E+00,0.777085E+00, |
| 22362 | &0.777015E+00,0.776867E+00,0.148150E+02,0.563809E+00,0.988608E+00/ |
| 22363 | DATA (DL(K),K= 426, 510) / |
| 22364 | &0.919556E+00,0.827330E+00,0.827594E+00,0.827505E+00,0.827330E+00, |
| 22365 | &0.155533E+02,0.617368E+00,0.104427E+01,0.972694E+00,0.877703E+00, |
| 22366 | &0.878016E+00,0.877907E+00,0.877703E+00,0.162391E+02,0.670837E+00, |
| 22367 | &0.109958E+01,0.102547E+01,0.927723E+00,0.928088E+00,0.927957E+00, |
| 22368 | &0.927723E+00,0.168687E+02,0.723954E+00,0.115428E+01,0.107761E+01, |
| 22369 | &0.977132E+00,0.977550E+00,0.977397E+00,0.977132E+00,0.174391E+02, |
| 22370 | &0.776458E+00,0.120809E+01,0.112886E+01,0.102567E+01,0.102615E+01, |
| 22371 | &0.102597E+01,0.102567E+01,0.179481E+02,0.828097E+00,0.126078E+01, |
| 22372 | &0.117898E+01,0.107310E+01,0.107363E+01,0.107343E+01,0.107310E+01, |
| 22373 | &0.183942E+02,0.878621E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22374 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22375 | &0.357586E+00,0.299938E+00,0.216504E+00,0.216504E+00,0.216504E+00, |
| 22376 | &0.216504E+00,0.357260E+01,-.277556E-16,0.388529E+00,0.327984E+00, |
| 22377 | &0.241161E+00,0.241168E+00,0.241168E+00,0.241161E+00,0.415893E+01, |
| 22378 | &0.278429E-01,0.420472E+00,0.357015E+00,0.266823E+00,0.266844E+00, |
| 22379 | &0.266842E+00,0.266823E+00,0.474689E+01,0.566783E-01,0.453271E+00, |
| 22380 | &0.386886E+00,0.293349E+00,0.293389E+00,0.293381E+00,0.293349E+00/ |
| 22381 | DATA (DL(K),K= 511, 595) / |
| 22382 | &0.532982E+01,0.863668E-01,0.486793E+00,0.417464E+00,0.320608E+00, |
| 22383 | &0.320673E+00,0.320657E+00,0.320608E+00,0.590219E+01,0.116779E+00, |
| 22384 | &0.520887E+00,0.448601E+00,0.348454E+00,0.348549E+00,0.348523E+00, |
| 22385 | &0.348454E+00,0.645868E+01,0.147773E+00,0.555403E+00,0.480149E+00, |
| 22386 | &0.376740E+00,0.376870E+00,0.376831E+00,0.376740E+00,0.699440E+01, |
| 22387 | &0.179201E+00,0.590183E+00,0.511950E+00,0.405314E+00,0.405482E+00, |
| 22388 | &0.405429E+00,0.405314E+00,0.750493E+01,0.210912E+00,0.625064E+00, |
| 22389 | &0.543845E+00,0.434019E+00,0.434229E+00,0.434159E+00,0.434019E+00, |
| 22390 | &0.798636E+01,0.242750E+00,0.659882E+00,0.575673E+00,0.462696E+00, |
| 22391 | &0.462952E+00,0.462864E+00,0.462696E+00,0.843528E+01,0.274558E+00, |
| 22392 | &0.694472E+00,0.607271E+00,0.491188E+00,0.491492E+00,0.491385E+00, |
| 22393 | &0.491188E+00,0.884885E+01,0.306178E+00,0.728669E+00,0.638478E+00, |
| 22394 | &0.519337E+00,0.519690E+00,0.519563E+00,0.519337E+00,0.922480E+01, |
| 22395 | &0.337451E+00,0.762311E+00,0.669133E+00,0.546987E+00,0.547392E+00, |
| 22396 | &0.547244E+00,0.546987E+00,0.956139E+01,0.368224E+00,0.795240E+00, |
| 22397 | &0.699084E+00,0.573988E+00,0.574447E+00,0.574277E+00,0.573988E+00, |
| 22398 | &0.985744E+01,0.398346E+00,0.827302E+00,0.728181E+00,0.600196E+00/ |
| 22399 | DATA (DL(K),K= 596, 680) / |
| 22400 | &0.600710E+00,0.600518E+00,0.600196E+00,0.101123E+02,0.427671E+00, |
| 22401 | &0.858354E+00,0.756282E+00,0.625475E+00,0.626044E+00,0.625829E+00, |
| 22402 | &0.625475E+00,0.103258E+02,0.456064E+00,0.888257E+00,0.783256E+00, |
| 22403 | &0.649696E+00,0.650321E+00,0.650083E+00,0.649696E+00,0.104982E+02, |
| 22404 | &0.483395E+00,0.916887E+00,0.808981E+00,0.672742E+00,0.673422E+00, |
| 22405 | &0.673161E+00,0.672742E+00,0.106303E+02,0.509546E+00,0.944126E+00, |
| 22406 | &0.833345E+00,0.694506E+00,0.695243E+00,0.694958E+00,0.694506E+00, |
| 22407 | &0.107231E+02,0.534410E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22408 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22409 | &0.390721E+00,0.304671E+00,0.182562E+00,0.182562E+00,0.182562E+00, |
| 22410 | &0.182562E+00,0.303699E+01,0.693889E-17,0.414806E+00,0.325059E+00, |
| 22411 | &0.199103E+00,0.199133E+00,0.199124E+00,0.199103E+00,0.339971E+01, |
| 22412 | &0.198528E-01,0.438929E+00,0.345508E+00,0.215797E+00,0.215862E+00, |
| 22413 | &0.215842E+00,0.215797E+00,0.374624E+01,0.398420E-01,0.462973E+00, |
| 22414 | &0.365903E+00,0.232531E+00,0.232635E+00,0.232601E+00,0.232531E+00, |
| 22415 | &0.407322E+01,0.598565E-01,0.486835E+00,0.386142E+00,0.249208E+00, |
| 22416 | &0.249352E+00,0.249304E+00,0.249208E+00,0.437817E+01,0.797987E-01/ |
| 22417 | DATA (DL(K),K= 681, 765) / |
| 22418 | &0.510407E+00,0.406123E+00,0.265725E+00,0.265913E+00,0.265849E+00, |
| 22419 | &0.265725E+00,0.465901E+01,0.995694E-01,0.533588E+00,0.425746E+00, |
| 22420 | &0.281986E+00,0.282220E+00,0.282139E+00,0.281986E+00,0.491410E+01, |
| 22421 | &0.119072E+00,0.556274E+00,0.444912E+00,0.297897E+00,0.298178E+00, |
| 22422 | &0.298079E+00,0.297897E+00,0.514220E+01,0.138212E+00,0.578369E+00, |
| 22423 | &0.463528E+00,0.313366E+00,0.313696E+00,0.313578E+00,0.313366E+00, |
| 22424 | &0.534249E+01,0.156900E+00,0.599777E+00,0.481503E+00,0.328308E+00, |
| 22425 | &0.328688E+00,0.328549E+00,0.328308E+00,0.551456E+01,0.175048E+00, |
| 22426 | &0.620409E+00,0.498752E+00,0.342642E+00,0.343071E+00,0.342913E+00, |
| 22427 | &0.342642E+00,0.565833E+01,0.192575E+00,0.640181E+00,0.515196E+00, |
| 22428 | &0.356292E+00,0.356770E+00,0.356592E+00,0.356292E+00,0.577410E+01, |
| 22429 | &0.209407E+00,0.659017E+00,0.530764E+00,0.369190E+00,0.369718E+00, |
| 22430 | &0.369519E+00,0.369190E+00,0.586243E+01,0.225474E+00,0.676845E+00, |
| 22431 | &0.545389E+00,0.381275E+00,0.381852E+00,0.381633E+00,0.381275E+00, |
| 22432 | &0.592421E+01,0.240714E+00,0.693604E+00,0.559015E+00,0.392493E+00, |
| 22433 | &0.393118E+00,0.392880E+00,0.392493E+00,0.596052E+01,0.255072E+00, |
| 22434 | &0.709239E+00,0.571593E+00,0.402799E+00,0.403472E+00,0.403213E+00/ |
| 22435 | DATA (DL(K),K= 766, 850) / |
| 22436 | &0.402799E+00,0.597267E+01,0.268502E+00,0.723703E+00,0.583081E+00, |
| 22437 | &0.412157E+00,0.412875E+00,0.412597E+00,0.412157E+00,0.596211E+01, |
| 22438 | &0.280966E+00,0.736960E+00,0.593447E+00,0.420536E+00,0.421299E+00, |
| 22439 | &0.421002E+00,0.420536E+00,0.593045E+01,0.292434E+00,0.748980E+00, |
| 22440 | &0.602669E+00,0.427918E+00,0.428723E+00,0.428408E+00,0.427918E+00, |
| 22441 | &0.587934E+01,0.302884E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22442 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22443 | &0.448390E+00,0.320678E+00,0.146415E+00,0.146415E+00,0.146415E+00, |
| 22444 | &0.146415E+00,0.247594E+01,0.000000E+00,0.465760E+00,0.333734E+00, |
| 22445 | &0.155974E+00,0.156013E+00,0.156000E+00,0.155974E+00,0.265633E+01, |
| 22446 | &0.130329E-01,0.482525E+00,0.346293E+00,0.165233E+00,0.165311E+00, |
| 22447 | &0.165285E+00,0.165233E+00,0.281612E+01,0.257304E-01,0.498626E+00, |
| 22448 | &0.358294E+00,0.174131E+00,0.174249E+00,0.174209E+00,0.174131E+00, |
| 22449 | &0.295484E+01,0.380345E-01,0.514008E+00,0.369688E+00,0.182622E+00, |
| 22450 | &0.182779E+00,0.182724E+00,0.182622E+00,0.307242E+01,0.498976E-01, |
| 22451 | &0.528624E+00,0.380432E+00,0.190660E+00,0.190856E+00,0.190786E+00, |
| 22452 | &0.190660E+00,0.316911E+01,0.612760E-01,0.542428E+00,0.390485E+00/ |
| 22453 | DATA (DL(K),K= 851, 935) / |
| 22454 | &0.198205E+00,0.198441E+00,0.198356E+00,0.198205E+00,0.324538E+01, |
| 22455 | &0.721303E-01,0.555382E+00,0.399810E+00,0.205224E+00,0.205498E+00, |
| 22456 | &0.205398E+00,0.205224E+00,0.330192E+01,0.824256E-01,0.567448E+00, |
| 22457 | &0.408377E+00,0.211687E+00,0.211997E+00,0.211882E+00,0.211687E+00, |
| 22458 | &0.333960E+01,0.921319E-01,0.578597E+00,0.416159E+00,0.217568E+00, |
| 22459 | &0.217915E+00,0.217784E+00,0.217568E+00,0.335945E+01,0.101224E+00, |
| 22460 | &0.588802E+00,0.423136E+00,0.222847E+00,0.223229E+00,0.223084E+00, |
| 22461 | &0.222847E+00,0.336262E+01,0.109681E+00,0.598043E+00,0.429293E+00, |
| 22462 | &0.227512E+00,0.227928E+00,0.227768E+00,0.227512E+00,0.335036E+01, |
| 22463 | &0.117489E+00,0.606305E+00,0.434619E+00,0.231551E+00,0.232000E+00, |
| 22464 | &0.231826E+00,0.231551E+00,0.332398E+01,0.124636E+00,0.613579E+00, |
| 22465 | &0.439110E+00,0.234962E+00,0.235442E+00,0.235254E+00,0.234962E+00, |
| 22466 | &0.328483E+01,0.131119E+00,0.619860E+00,0.442766E+00,0.237745E+00, |
| 22467 | &0.238254E+00,0.238053E+00,0.237745E+00,0.323429E+01,0.136936E+00, |
| 22468 | &0.625150E+00,0.445594E+00,0.239905E+00,0.240441E+00,0.240228E+00, |
| 22469 | &0.239905E+00,0.317371E+01,0.142091E+00,0.629453E+00,0.447603E+00, |
| 22470 | &0.241452E+00,0.242014E+00,0.241788E+00,0.241452E+00,0.310443E+01/ |
| 22471 | DATA (DL(K),K= 936, 1020) / |
| 22472 | &0.146594E+00,0.632782E+00,0.448808E+00,0.242400E+00,0.242987E+00, |
| 22473 | &0.242749E+00,0.242400E+00,0.302775E+01,0.150456E+00,0.635151E+00, |
| 22474 | &0.449228E+00,0.242767E+00,0.243376E+00,0.243127E+00,0.242767E+00, |
| 22475 | &0.294491E+01,0.153694E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22476 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22477 | &0.528765E+00,0.341825E+00,0.105823E+00,0.105823E+00,0.105823E+00, |
| 22478 | &0.105823E+00,0.185069E+01,-.138778E-16,0.538124E+00,0.347118E+00, |
| 22479 | &0.109762E+00,0.109780E+00,0.109774E+00,0.109762E+00,0.189644E+01, |
| 22480 | &0.738880E-02,0.546541E+00,0.351712E+00,0.113300E+00,0.113336E+00, |
| 22481 | &0.113324E+00,0.113300E+00,0.192700E+01,0.143076E-01,0.554014E+00, |
| 22482 | &0.355607E+00,0.116431E+00,0.116485E+00,0.116466E+00,0.116431E+00, |
| 22483 | &0.194356E+01,0.207515E-01,0.560546E+00,0.358805E+00,0.119150E+00, |
| 22484 | &0.119222E+00,0.119196E+00,0.119150E+00,0.194722E+01,0.267179E-01, |
| 22485 | &0.566139E+00,0.361311E+00,0.121459E+00,0.121549E+00,0.121515E+00, |
| 22486 | &0.121459E+00,0.193921E+01,0.322084E-01,0.570802E+00,0.363134E+00, |
| 22487 | &0.123359E+00,0.123467E+00,0.123426E+00,0.123359E+00,0.192071E+01, |
| 22488 | &0.372262E-01,0.574542E+00,0.364286E+00,0.124858E+00,0.124983E+00/ |
| 22489 | DATA (DL(K),K= 1021, 1105) / |
| 22490 | &0.124933E+00,0.124858E+00,0.189295E+01,0.417774E-01,0.577372E+00, |
| 22491 | &0.364779E+00,0.125961E+00,0.126103E+00,0.126046E+00,0.125961E+00, |
| 22492 | &0.185710E+01,0.458703E-01,0.579307E+00,0.364629E+00,0.126681E+00, |
| 22493 | &0.126839E+00,0.126774E+00,0.126681E+00,0.181432E+01,0.495154E-01, |
| 22494 | &0.580363E+00,0.363857E+00,0.127029E+00,0.127202E+00,0.127130E+00, |
| 22495 | &0.127029E+00,0.176571E+01,0.527252E-01,0.580561E+00,0.362483E+00, |
| 22496 | &0.127020E+00,0.127208E+00,0.127128E+00,0.127020E+00,0.171231E+01, |
| 22497 | &0.555142E-01,0.579923E+00,0.360529E+00,0.126670E+00,0.126872E+00, |
| 22498 | &0.126785E+00,0.126670E+00,0.165511E+01,0.578985E-01,0.578474E+00, |
| 22499 | &0.358021E+00,0.125998E+00,0.126213E+00,0.126119E+00,0.125998E+00, |
| 22500 | &0.159501E+01,0.598958E-01,0.576241E+00,0.354987E+00,0.125022E+00, |
| 22501 | &0.125249E+00,0.125148E+00,0.125022E+00,0.153284E+01,0.615248E-01, |
| 22502 | &0.573252E+00,0.351453E+00,0.123762E+00,0.124000E+00,0.123893E+00, |
| 22503 | &0.123762E+00,0.146934E+01,0.628056E-01,0.569539E+00,0.347450E+00, |
| 22504 | &0.122240E+00,0.122488E+00,0.122375E+00,0.122240E+00,0.140517E+01, |
| 22505 | &0.637587E-01,0.565134E+00,0.343008E+00,0.120476E+00,0.120733E+00, |
| 22506 | &0.120615E+00,0.120476E+00,0.134093E+01,0.644054E-01,0.560071E+00/ |
| 22507 | DATA (DL(K),K= 1106, 1190) / |
| 22508 | &0.338158E+00,0.118493E+00,0.118758E+00,0.118635E+00,0.118493E+00, |
| 22509 | &0.127712E+01,0.647671E-01,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22510 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22511 | &0.584093E+00,0.349173E+00,0.772117E-01,0.772117E-01,0.772117E-01, |
| 22512 | &0.772117E-01,0.140433E+01,0.346945E-17,0.586736E+00,0.349017E+00, |
| 22513 | &0.785355E-01,0.785519E-01,0.785448E-01,0.785355E-01,0.139434E+01, |
| 22514 | &0.447504E-02,0.588402E+00,0.348237E+00,0.795437E-01,0.795759E-01, |
| 22515 | &0.795617E-01,0.795437E-01,0.137550E+01,0.854114E-02,0.589124E+00, |
| 22516 | &0.346861E+00,0.802498E-01,0.802970E-01,0.802758E-01,0.802498E-01, |
| 22517 | &0.134918E+01,0.122148E-01,0.588930E+00,0.344912E+00,0.806656E-01, |
| 22518 | &0.807271E-01,0.806990E-01,0.806656E-01,0.131652E+01,0.155101E-01, |
| 22519 | &0.587849E+00,0.342417E+00,0.808055E-01,0.808805E-01,0.808457E-01, |
| 22520 | &0.808055E-01,0.127862E+01,0.184435E-01,0.585912E+00,0.339402E+00, |
| 22521 | &0.806843E-01,0.807718E-01,0.807306E-01,0.806843E-01,0.123648E+01, |
| 22522 | &0.210315E-01,0.583151E+00,0.335894E+00,0.803173E-01,0.804166E-01, |
| 22523 | &0.803692E-01,0.803173E-01,0.119104E+01,0.232909E-01,0.579599E+00, |
| 22524 | &0.331923E+00,0.797205E-01,0.798308E-01,0.797775E-01,0.797205E-01/ |
| 22525 | DATA (DL(K),K= 1191, 1275) / |
| 22526 | &0.114317E+01,0.252394E-01,0.575288E+00,0.327516E+00,0.789107E-01, |
| 22527 | &0.790310E-01,0.789721E-01,0.789107E-01,0.109362E+01,0.268946E-01, |
| 22528 | &0.570253E+00,0.322704E+00,0.779045E-01,0.780341E-01,0.779698E-01, |
| 22529 | &0.779045E-01,0.104307E+01,0.282745E-01,0.564530E+00,0.317515E+00, |
| 22530 | &0.767190E-01,0.768570E-01,0.767878E-01,0.767190E-01,0.992143E+00, |
| 22531 | &0.293974E-01,0.558155E+00,0.311981E+00,0.753713E-01,0.755169E-01, |
| 22532 | &0.754432E-01,0.753713E-01,0.941341E+00,0.302812E-01,0.551166E+00, |
| 22533 | &0.306131E+00,0.738784E-01,0.740308E-01,0.739528E-01,0.738784E-01, |
| 22534 | &0.891113E+00,0.309441E-01,0.543599E+00,0.299995E+00,0.722571E-01, |
| 22535 | &0.724154E-01,0.723336E-01,0.722571E-01,0.841829E+00,0.314037E-01, |
| 22536 | &0.535494E+00,0.293603E+00,0.705237E-01,0.706871E-01,0.706019E-01, |
| 22537 | &0.705237E-01,0.793794E+00,0.316774E-01,0.526888E+00,0.286986E+00, |
| 22538 | &0.686941E-01,0.688619E-01,0.687736E-01,0.686941E-01,0.747249E+00, |
| 22539 | &0.317823E-01,0.517822E+00,0.280172E+00,0.667836E-01,0.669551E-01, |
| 22540 | &0.668640E-01,0.667836E-01,0.702381E+00,0.317346E-01,0.508333E+00, |
| 22541 | &0.273189E+00,0.648068E-01,0.649814E-01,0.648879E-01,0.648068E-01, |
| 22542 | &0.659330E+00,0.315501E-01,0.000000E+00,0.000000E+00,0.000000E+00/ |
| 22543 | DATA (DL(K),K= 1276, 1360) / |
| 22544 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22545 | &0.622739E+00,0.340676E+00,0.509141E-01,0.509141E-01,0.509141E-01, |
| 22546 | &0.509141E-01,0.980502E+00,-.173472E-17,0.617764E+00,0.335457E+00, |
| 22547 | &0.507607E-01,0.507701E-01,0.507651E-01,0.507607E-01,0.944375E+00, |
| 22548 | &0.242386E-02,0.611957E+00,0.329837E+00,0.504236E-01,0.504417E-01, |
| 22549 | &0.504321E-01,0.504236E-01,0.905225E+00,0.455851E-02,0.605372E+00, |
| 22550 | &0.323853E+00,0.499207E-01,0.499471E-01,0.499328E-01,0.499207E-01, |
| 22551 | &0.864035E+00,0.642656E-02,0.598052E+00,0.317537E+00,0.492668E-01, |
| 22552 | &0.493008E-01,0.492822E-01,0.492668E-01,0.821557E+00,0.804638E-02, |
| 22553 | &0.590044E+00,0.310919E+00,0.484772E-01,0.485183E-01,0.484955E-01, |
| 22554 | &0.484772E-01,0.778444E+00,0.943663E-02,0.581391E+00,0.304033E+00, |
| 22555 | &0.475665E-01,0.476142E-01,0.475874E-01,0.475665E-01,0.735263E+00, |
| 22556 | &0.106150E-01,0.572137E+00,0.296908E+00,0.465487E-01,0.466024E-01, |
| 22557 | &0.465720E-01,0.465487E-01,0.692487E+00,0.115984E-01,0.562326E+00, |
| 22558 | &0.289573E+00,0.454376E-01,0.454968E-01,0.454629E-01,0.454376E-01, |
| 22559 | &0.650510E+00,0.124032E-01,0.552003E+00,0.282060E+00,0.442463E-01, |
| 22560 | &0.443103E-01,0.442733E-01,0.442463E-01,0.609652E+00,0.130451E-01/ |
| 22561 | DATA (DL(K),K= 1361, 1445) / |
| 22562 | &0.541210E+00,0.274395E+00,0.429871E-01,0.430555E-01,0.430156E-01, |
| 22563 | &0.429871E-01,0.570164E+00,0.135389E-01,0.529991E+00,0.266608E+00, |
| 22564 | &0.416720E-01,0.417443E-01,0.417018E-01,0.416720E-01,0.532237E+00, |
| 22565 | &0.138989E-01,0.518389E+00,0.258725E+00,0.403123E-01,0.403879E-01, |
| 22566 | &0.403431E-01,0.403123E-01,0.496010E+00,0.141386E-01,0.506446E+00, |
| 22567 | &0.250772E+00,0.389186E-01,0.389971E-01,0.389501E-01,0.389186E-01, |
| 22568 | &0.461573E+00,0.142708E-01,0.494204E+00,0.242775E+00,0.375006E-01, |
| 22569 | &0.375815E-01,0.375327E-01,0.375006E-01,0.428979E+00,0.143074E-01, |
| 22570 | &0.481705E+00,0.234757E+00,0.360674E-01,0.361503E-01,0.361000E-01, |
| 22571 | &0.360674E-01,0.398246E+00,0.142598E-01,0.468990E+00,0.226741E+00, |
| 22572 | &0.346276E-01,0.347120E-01,0.346605E-01,0.346276E-01,0.369363E+00, |
| 22573 | &0.141385E-01,0.456098E+00,0.218750E+00,0.331887E-01,0.332743E-01, |
| 22574 | &0.332216E-01,0.331887E-01,0.342300E+00,0.139532E-01,0.443068E+00, |
| 22575 | &0.210804E+00,0.317576E-01,0.318440E-01,0.317905E-01,0.317576E-01, |
| 22576 | &0.317005E+00,0.137130E-01,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22577 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22578 | &0.631458E+00,0.318714E+00,0.335640E-01,0.335640E-01,0.335640E-01/ |
| 22579 | DATA (DL(K),K= 1446, 1530) / |
| 22580 | &0.335640E-01,0.686773E+00,0.346945E-17,0.620274E+00,0.310241E+00, |
| 22581 | &0.329311E-01,0.329377E-01,0.329337E-01,0.329311E-01,0.646559E+00, |
| 22582 | &0.135960E-02,0.608504E+00,0.301610E+00,0.322083E-01,0.322210E-01, |
| 22583 | &0.322133E-01,0.322083E-01,0.606503E+00,0.252820E-02,0.596205E+00, |
| 22584 | &0.292854E+00,0.314099E-01,0.314281E-01,0.314169E-01,0.314099E-01, |
| 22585 | &0.567134E+00,0.352543E-02,0.583429E+00,0.284002E+00,0.305470E-01, |
| 22586 | &0.305704E-01,0.305558E-01,0.305470E-01,0.528824E+00,0.436693E-02, |
| 22587 | &0.570223E+00,0.275080E+00,0.296307E-01,0.296586E-01,0.296411E-01, |
| 22588 | &0.296307E-01,0.491848E+00,0.506768E-02,0.556637E+00,0.266115E+00, |
| 22589 | &0.286709E-01,0.287030E-01,0.286827E-01,0.286709E-01,0.456422E+00, |
| 22590 | &0.564157E-02,0.542717E+00,0.257131E+00,0.276770E-01,0.277128E-01, |
| 22591 | &0.276900E-01,0.276770E-01,0.422697E+00,0.610148E-02,0.528511E+00, |
| 22592 | &0.248154E+00,0.266578E-01,0.266968E-01,0.266718E-01,0.266578E-01, |
| 22593 | &0.390771E+00,0.645942E-02,0.514062E+00,0.239205E+00,0.256210E-01, |
| 22594 | &0.256629E-01,0.256359E-01,0.256210E-01,0.360700E+00,0.672653E-02, |
| 22595 | &0.499417E+00,0.230307E+00,0.245741E-01,0.246185E-01,0.245896E-01, |
| 22596 | &0.245741E-01,0.332498E+00,0.691312E-02,0.484617E+00,0.221480E+00/ |
| 22597 | DATA (DL(K),K= 1531, 1615) / |
| 22598 | &0.235237E-01,0.235701E-01,0.235397E-01,0.235237E-01,0.306153E+00, |
| 22599 | &0.702875E-02,0.469706E+00,0.212745E+00,0.224757E-01,0.225238E-01, |
| 22600 | &0.224921E-01,0.224757E-01,0.281624E+00,0.708222E-02,0.454725E+00, |
| 22601 | &0.204118E+00,0.214355E-01,0.214850E-01,0.214522E-01,0.214355E-01, |
| 22602 | &0.258855E+00,0.708159E-02,0.439713E+00,0.195618E+00,0.204079E-01, |
| 22603 | &0.204586E-01,0.204249E-01,0.204079E-01,0.237774E+00,0.703428E-02, |
| 22604 | &0.424709E+00,0.187259E+00,0.193972E-01,0.194486E-01,0.194142E-01, |
| 22605 | &0.193972E-01,0.218298E+00,0.694702E-02,0.409750E+00,0.179057E+00, |
| 22606 | &0.184069E-01,0.184588E-01,0.184239E-01,0.184069E-01,0.200339E+00, |
| 22607 | &0.682594E-02,0.394870E+00,0.171023E+00,0.174402E-01,0.174924E-01, |
| 22608 | &0.174571E-01,0.174402E-01,0.183804E+00,0.667657E-02,0.380104E+00, |
| 22609 | &0.163171E+00,0.164997E-01,0.165519E-01,0.165164E-01,0.164997E-01, |
| 22610 | &0.168600E+00,0.650389E-02,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22611 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22612 | &0.619056E+00,0.288873E+00,0.218554E-01,0.218554E-01,0.218554E-01, |
| 22613 | &0.218554E-01,0.477010E+00,-.867362E-17,0.602890E+00,0.278444E+00, |
| 22614 | &0.211480E-01,0.211530E-01,0.211497E-01,0.211480E-01,0.440877E+00/ |
| 22615 | DATA (DL(K),K= 1616, 1700) / |
| 22616 | &0.767466E-03,0.586431E+00,0.268081E+00,0.204081E-01,0.204175E-01, |
| 22617 | &0.204113E-01,0.204081E-01,0.406417E+00,0.141432E-02,0.569736E+00, |
| 22618 | &0.257807E+00,0.196446E-01,0.196581E-01,0.196491E-01,0.196446E-01, |
| 22619 | &0.373808E+00,0.195508E-02,0.552853E+00,0.247642E+00,0.188646E-01, |
| 22620 | &0.188816E-01,0.188701E-01,0.188646E-01,0.343145E+00,0.240123E-02, |
| 22621 | &0.535829E+00,0.237603E+00,0.180743E-01,0.180945E-01,0.180808E-01, |
| 22622 | &0.180743E-01,0.314460E+00,0.276332E-02,0.518710E+00,0.227710E+00, |
| 22623 | &0.172796E-01,0.173025E-01,0.172868E-01,0.172796E-01,0.287750E+00, |
| 22624 | &0.305100E-02,0.501539E+00,0.217977E+00,0.164854E-01,0.165108E-01, |
| 22625 | &0.164933E-01,0.164854E-01,0.262983E+00,0.327305E-02,0.484360E+00, |
| 22626 | &0.208420E+00,0.156964E-01,0.157239E-01,0.157049E-01,0.156964E-01, |
| 22627 | &0.240098E+00,0.343744E-02,0.467213E+00,0.199053E+00,0.149165E-01, |
| 22628 | &0.149457E-01,0.149254E-01,0.149165E-01,0.219021E+00,0.355144E-02, |
| 22629 | &0.450140E+00,0.189889E+00,0.141493E-01,0.141800E-01,0.141586E-01, |
| 22630 | &0.141493E-01,0.199660E+00,0.362164E-02,0.433177E+00,0.180939E+00, |
| 22631 | &0.133978E-01,0.134297E-01,0.134073E-01,0.133978E-01,0.181918E+00, |
| 22632 | &0.365401E-02,0.416362E+00,0.172214E+00,0.126646E-01,0.126974E-01/ |
| 22633 | DATA (DL(K),K= 1701, 1785) / |
| 22634 | &0.126742E-01,0.126646E-01,0.165692E+00,0.365394E-02,0.399729E+00, |
| 22635 | &0.163725E+00,0.119518E-01,0.119853E-01,0.119615E-01,0.119518E-01, |
| 22636 | &0.150875E+00,0.362628E-02,0.383310E+00,0.155477E+00,0.112613E-01, |
| 22637 | &0.112952E-01,0.112711E-01,0.112613E-01,0.137364E+00,0.357539E-02, |
| 22638 | &0.367138E+00,0.147479E+00,0.105945E-01,0.106287E-01,0.106042E-01, |
| 22639 | &0.105945E-01,0.125056E+00,0.350515E-02,0.351239E+00,0.139737E+00, |
| 22640 | &0.995250E-02,0.998673E-02,0.996211E-02,0.995250E-02,0.113852E+00, |
| 22641 | &0.341903E-02,0.335641E+00,0.132253E+00,0.933610E-02,0.937024E-02, |
| 22642 | &0.934557E-02,0.933610E-02,0.103659E+00,0.332009E-02,0.320367E+00, |
| 22643 | &0.125033E+00,0.874584E-02,0.877973E-02,0.875514E-02,0.874584E-02, |
| 22644 | &0.943886E-01,0.321106E-02,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22645 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22646 | &0.591114E+00,0.254807E+00,0.139531E-01,0.139531E-01,0.139531E-01, |
| 22647 | &0.139531E-01,0.326288E+00,0.000000E+00,0.571121E+00,0.243424E+00, |
| 22648 | &0.133325E-01,0.133362E-01,0.133336E-01,0.133325E-01,0.296956E+00, |
| 22649 | &0.429082E-03,0.551151E+00,0.232297E+00,0.127105E-01,0.127175E-01, |
| 22650 | &0.127126E-01,0.127105E-01,0.269811E+00,0.785137E-03,0.531253E+00/ |
| 22651 | DATA (DL(K),K= 1786, 1870) / |
| 22652 | &0.221436E+00,0.120916E-01,0.121015E-01,0.120945E-01,0.120916E-01, |
| 22653 | &0.244803E+00,0.107790E-02,0.511467E+00,0.210850E+00,0.114794E-01, |
| 22654 | &0.114918E-01,0.114829E-01,0.114794E-01,0.221863E+00,0.131504E-02, |
| 22655 | &0.491833E+00,0.200545E+00,0.108767E-01,0.108913E-01,0.108808E-01, |
| 22656 | &0.108767E-01,0.200886E+00,0.150337E-02,0.472388E+00,0.190531E+00, |
| 22657 | &0.102861E-01,0.103027E-01,0.102907E-01,0.102861E-01,0.181762E+00, |
| 22658 | &0.164910E-02,0.453170E+00,0.180812E+00,0.970979E-02,0.972799E-02, |
| 22659 | &0.971477E-02,0.970979E-02,0.164371E+00,0.175777E-02,0.434213E+00, |
| 22660 | &0.171394E+00,0.914959E-02,0.916916E-02,0.915488E-02,0.914959E-02, |
| 22661 | &0.148589E+00,0.183434E-02,0.415548E+00,0.162282E+00,0.860700E-02, |
| 22662 | &0.862770E-02,0.861252E-02,0.860700E-02,0.134293E+00,0.188328E-02, |
| 22663 | &0.397208E+00,0.153479E+00,0.808323E-02,0.810484E-02,0.808891E-02, |
| 22664 | &0.808323E-02,0.121361E+00,0.190856E-02,0.379220E+00,0.144989E+00, |
| 22665 | &0.757922E-02,0.760152E-02,0.758501E-02,0.757922E-02,0.109676E+00, |
| 22666 | &0.191374E-02,0.361611E+00,0.136811E+00,0.709565E-02,0.711846E-02, |
| 22667 | &0.710150E-02,0.709565E-02,0.991261E-01,0.190199E-02,0.344406E+00, |
| 22668 | &0.128948E+00,0.663300E-02,0.665614E-02,0.663885E-02,0.663300E-02/ |
| 22669 | DATA (DL(K),K= 1871, 1955) / |
| 22670 | &0.896059E-01,0.187610E-02,0.327627E+00,0.121398E+00,0.619152E-02, |
| 22671 | &0.621484E-02,0.619734E-02,0.619152E-02,0.810177E-01,0.183856E-02, |
| 22672 | &0.311292E+00,0.114161E+00,0.577130E-02,0.579466E-02,0.577706E-02, |
| 22673 | &0.577130E-02,0.732709E-01,0.179155E-02,0.295421E+00,0.107235E+00, |
| 22674 | &0.537228E-02,0.539554E-02,0.537794E-02,0.537228E-02,0.662824E-01, |
| 22675 | &0.173700E-02,0.280026E+00,0.100616E+00,0.499423E-02,0.501728E-02, |
| 22676 | &0.499977E-02,0.499423E-02,0.599766E-01,0.167658E-02,0.265121E+00, |
| 22677 | &0.943000E-01,0.463683E-02,0.465958E-02,0.464223E-02,0.463683E-02, |
| 22678 | &0.542848E-01,0.161174E-02,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22679 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22680 | &0.551659E+00,0.219084E+00,0.867977E-02,0.867977E-02,0.867977E-02, |
| 22681 | &0.867977E-02,0.218587E+00,-.173472E-16,0.528947E+00,0.207536E+00, |
| 22682 | &0.819621E-02,0.819909E-02,0.819696E-02,0.819621E-02,0.196367E+00, |
| 22683 | &0.234843E-03,0.506575E+00,0.196391E+00,0.772540E-02,0.773082E-02, |
| 22684 | &0.772680E-02,0.772540E-02,0.176280E+00,0.427503E-03,0.484579E+00, |
| 22685 | &0.185646E+00,0.726876E-02,0.727639E-02,0.727069E-02,0.726876E-02, |
| 22686 | &0.158158E+00,0.583933E-03,0.462988E+00,0.175298E+00,0.682746E-02/ |
| 22687 | DATA (DL(K),K= 1956, 2040) / |
| 22688 | &0.683702E-02,0.682985E-02,0.682746E-02,0.141851E+00,0.708874E-03, |
| 22689 | &0.441830E+00,0.165345E+00,0.640226E-02,0.641347E-02,0.640502E-02, |
| 22690 | &0.640226E-02,0.127203E+00,0.806409E-03,0.421129E+00,0.155783E+00, |
| 22691 | &0.599380E-02,0.600641E-02,0.599686E-02,0.599380E-02,0.114065E+00, |
| 22692 | &0.880249E-03,0.400912E+00,0.146609E+00,0.560252E-02,0.561629E-02, |
| 22693 | &0.560581E-02,0.560252E-02,0.102296E+00,0.933676E-03,0.381199E+00, |
| 22694 | &0.137819E+00,0.522870E-02,0.524342E-02,0.523217E-02,0.522870E-02, |
| 22695 | &0.917608E-01,0.969607E-03,0.362011E+00,0.129407E+00,0.487247E-02, |
| 22696 | &0.488796E-02,0.487607E-02,0.487247E-02,0.823356E-01,0.990632E-03, |
| 22697 | &0.343367E+00,0.121370E+00,0.453385E-02,0.454992E-02,0.453753E-02, |
| 22698 | &0.453385E-02,0.739054E-01,0.999042E-03,0.325282E+00,0.113700E+00, |
| 22699 | &0.421272E-02,0.422921E-02,0.421644E-02,0.421272E-02,0.663651E-01, |
| 22700 | &0.996863E-03,0.307770E+00,0.106393E+00,0.390887E-02,0.392563E-02, |
| 22701 | &0.391260E-02,0.390887E-02,0.596195E-01,0.985881E-03,0.290841E+00, |
| 22702 | &0.994399E-01,0.362199E-02,0.363889E-02,0.362570E-02,0.362199E-02, |
| 22703 | &0.535826E-01,0.967664E-03,0.274506E+00,0.928343E-01,0.335170E-02, |
| 22704 | &0.336862E-02,0.335536E-02,0.335170E-02,0.481769E-01,0.943587E-03/ |
| 22705 | DATA (DL(K),K= 2041, 2125) / |
| 22706 | &0.258771E+00,0.865679E-01,0.309756E-02,0.311439E-02,0.310114E-02, |
| 22707 | &0.309756E-02,0.433336E-01,0.914850E-03,0.243639E+00,0.806321E-01, |
| 22708 | &0.285905E-02,0.287571E-02,0.286255E-02,0.285905E-02,0.389912E-01, |
| 22709 | &0.882497E-03,0.229113E+00,0.750177E-01,0.263565E-02,0.265205E-02, |
| 22710 | &0.263905E-02,0.263565E-02,0.350948E-01,0.847432E-03,0.215193E+00, |
| 22711 | &0.697152E-01,0.242677E-02,0.244285E-02,0.243005E-02,0.242677E-02, |
| 22712 | &0.315960E-01,0.810432E-03,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22713 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22714 | &0.503850E+00,0.183581E+00,0.522815E-02,0.522815E-02,0.522815E-02, |
| 22715 | &0.522815E-02,0.142635E+00,0.123599E-16,0.479478E+00,0.172477E+00, |
| 22716 | &0.488093E-02,0.488328E-02,0.488147E-02,0.488093E-02,0.126767E+00, |
| 22717 | &0.124505E-03,0.455750E+00,0.161879E+00,0.455054E-02,0.455493E-02, |
| 22718 | &0.455153E-02,0.455054E-02,0.112695E+00,0.225968E-03,0.432681E+00, |
| 22719 | &0.151771E+00,0.423664E-02,0.424278E-02,0.423800E-02,0.423664E-02, |
| 22720 | &0.100212E+00,0.307702E-03,0.410286E+00,0.142140E+00,0.393907E-02, |
| 22721 | &0.394671E-02,0.394073E-02,0.393907E-02,0.891488E-01,0.372395E-03, |
| 22722 | &0.388577E+00,0.132974E+00,0.365743E-02,0.366634E-02,0.365934E-02/ |
| 22723 | DATA (DL(K),K= 2126, 2210) / |
| 22724 | &0.365743E-02,0.793490E-01,0.422302E-03,0.367563E+00,0.124259E+00, |
| 22725 | &0.339138E-02,0.340133E-02,0.339347E-02,0.339138E-02,0.706688E-01, |
| 22726 | &0.459484E-03,0.347256E+00,0.115984E+00,0.314049E-02,0.315129E-02, |
| 22727 | &0.314273E-02,0.314049E-02,0.629792E-01,0.485762E-03,0.327660E+00, |
| 22728 | &0.108136E+00,0.290433E-02,0.291580E-02,0.290667E-02,0.290433E-02, |
| 22729 | &0.561642E-01,0.502744E-03,0.308782E+00,0.100701E+00,0.268243E-02, |
| 22730 | &0.269440E-02,0.268483E-02,0.268243E-02,0.501207E-01,0.511853E-03, |
| 22731 | &0.290625E+00,0.936693E-01,0.247429E-02,0.248663E-02,0.247672E-02, |
| 22732 | &0.247429E-02,0.447569E-01,0.514346E-03,0.273189E+00,0.870261E-01, |
| 22733 | &0.227939E-02,0.229197E-02,0.228184E-02,0.227939E-02,0.399920E-01, |
| 22734 | &0.511328E-03,0.256475E+00,0.807592E-01,0.209722E-02,0.210991E-02, |
| 22735 | &0.209965E-02,0.209722E-02,0.357547E-01,0.503769E-03,0.240478E+00, |
| 22736 | &0.748555E-01,0.192721E-02,0.193992E-02,0.192961E-02,0.192721E-02, |
| 22737 | &0.319825E-01,0.492518E-03,0.225194E+00,0.693019E-01,0.176883E-02, |
| 22738 | &0.178147E-02,0.177117E-02,0.176883E-02,0.286209E-01,0.478318E-03, |
| 22739 | &0.210615E+00,0.640851E-01,0.162151E-02,0.163400E-02,0.162379E-02, |
| 22740 | &0.162151E-02,0.256219E-01,0.461813E-03,0.196733E+00,0.591917E-01/ |
| 22741 | DATA (DL(K),K= 2211, 2295) / |
| 22742 | &0.148471E-02,0.149698E-02,0.148691E-02,0.148471E-02,0.229436E-01, |
| 22743 | &0.443561E-03,0.183536E+00,0.546085E-01,0.135786E-02,0.136986E-02, |
| 22744 | &0.135998E-02,0.135786E-02,0.205496E-01,0.424043E-03,0.171011E+00, |
| 22745 | &0.503219E-01,0.124042E-02,0.125211E-02,0.124246E-02,0.124042E-02, |
| 22746 | &0.184079E-01,0.403672E-03,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22747 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22748 | &0.450310E+00,0.149685E+00,0.302765E-02,0.302765E-02,0.302765E-02, |
| 22749 | &0.302765E-02,0.901099E-01,-.108420E-17,0.425282E+00,0.139479E+00, |
| 22750 | &0.279499E-02,0.279691E-02,0.279537E-02,0.279499E-02,0.794239E-01, |
| 22751 | &0.632140E-04,0.401169E+00,0.129837E+00,0.257801E-02,0.258157E-02, |
| 22752 | &0.257870E-02,0.257801E-02,0.700941E-01,0.114711E-03,0.377966E+00, |
| 22753 | &0.120733E+00,0.237556E-02,0.238052E-02,0.237650E-02,0.237556E-02, |
| 22754 | &0.619270E-01,0.156107E-03,0.355668E+00,0.112145E+00,0.218688E-02, |
| 22755 | &0.219301E-02,0.218802E-02,0.218688E-02,0.547717E-01,0.188777E-03, |
| 22756 | &0.334269E+00,0.104052E+00,0.201113E-02,0.201823E-02,0.201243E-02, |
| 22757 | &0.201113E-02,0.484974E-01,0.213848E-03,0.313762E+00,0.964335E-01, |
| 22758 | &0.184758E-02,0.185546E-02,0.184900E-02,0.184758E-02,0.429879E-01/ |
| 22759 | DATA (DL(K),K= 2296, 2380) / |
| 22760 | &0.232367E-03,0.294139E+00,0.892696E-01,0.169553E-02,0.170402E-02, |
| 22761 | &0.169703E-02,0.169553E-02,0.381432E-01,0.245270E-03,0.275389E+00, |
| 22762 | &0.825414E-01,0.155431E-02,0.156326E-02,0.155586E-02,0.155431E-02, |
| 22763 | &0.338762E-01,0.253383E-03,0.257502E+00,0.762303E-01,0.142329E-02, |
| 22764 | &0.143258E-02,0.142487E-02,0.142329E-02,0.301119E-01,0.257441E-03, |
| 22765 | &0.240464E+00,0.703180E-01,0.130188E-02,0.131138E-02,0.130347E-02, |
| 22766 | &0.130188E-02,0.267853E-01,0.258098E-03,0.224262E+00,0.647867E-01, |
| 22767 | &0.118950E-02,0.119912E-02,0.119108E-02,0.118950E-02,0.238409E-01, |
| 22768 | &0.255929E-03,0.208879E+00,0.596190E-01,0.108562E-02,0.109526E-02, |
| 22769 | &0.108717E-02,0.108562E-02,0.212308E-01,0.251442E-03,0.194298E+00, |
| 22770 | &0.547975E-01,0.989698E-03,0.999283E-03,0.991221E-03,0.989698E-03, |
| 22771 | &0.189136E-01,0.245082E-03,0.180499E+00,0.503054E-01,0.901248E-03, |
| 22772 | &0.910711E-03,0.902726E-03,0.901248E-03,0.168537E-01,0.237238E-03, |
| 22773 | &0.167463E+00,0.461263E-01,0.819789E-03,0.829074E-03,0.821215E-03, |
| 22774 | &0.819789E-03,0.150206E-01,0.228250E-03,0.155167E+00,0.422438E-01, |
| 22775 | &0.744866E-03,0.753925E-03,0.746234E-03,0.744866E-03,0.133878E-01, |
| 22776 | &0.218412E-03,0.143590E+00,0.386421E-01,0.676043E-03,0.684836E-03/ |
| 22777 | DATA (DL(K),K= 2381, 2465) / |
| 22778 | &0.677349E-03,0.676043E-03,0.119320E-01,0.207976E-03,0.132706E+00, |
| 22779 | &0.353058E-01,0.612907E-03,0.621403E-03,0.614147E-03,0.612907E-03, |
| 22780 | &0.106334E-01,0.197159E-03,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22781 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22782 | &0.393307E+00,0.118409E+00,0.167124E-02,0.167124E-02,0.167124E-02, |
| 22783 | &0.167124E-02,0.547140E-01,0.433681E-17,0.368555E+00,0.109414E+00, |
| 22784 | &0.152547E-02,0.152705E-02,0.152573E-02,0.152547E-02,0.479708E-01, |
| 22785 | &0.303147E-04,0.344946E+00,0.101001E+00,0.139202E-02,0.139494E-02, |
| 22786 | &0.139249E-02,0.139202E-02,0.421517E-01,0.552185E-04,0.322450E+00, |
| 22787 | &0.931345E-01,0.126960E-02,0.127363E-02,0.127024E-02,0.126960E-02, |
| 22788 | &0.371043E-01,0.753524E-04,0.301043E+00,0.857854E-01,0.115731E-02, |
| 22789 | &0.116225E-02,0.115808E-02,0.115731E-02,0.327131E-01,0.913172E-04, |
| 22790 | &0.280698E+00,0.789267E-01,0.105427E-02,0.105995E-02,0.105514E-02, |
| 22791 | &0.105427E-02,0.288844E-01,0.103605E-03,0.261390E+00,0.725323E-01, |
| 22792 | &0.959726E-03,0.965979E-03,0.960659E-03,0.959726E-03,0.255366E-01, |
| 22793 | &0.112688E-03,0.243091E+00,0.665774E-01,0.872987E-03,0.879676E-03, |
| 22794 | &0.873966E-03,0.872987E-03,0.226017E-01,0.119000E-03,0.225775E+00/ |
| 22795 | DATA (DL(K),K= 2466, 2550) / |
| 22796 | &0.610385E-01,0.793435E-03,0.800438E-03,0.794441E-03,0.793435E-03, |
| 22797 | &0.200219E-01,0.122931E-03,0.209414E+00,0.558928E-01,0.720508E-03, |
| 22798 | &0.727716E-03,0.721524E-03,0.720508E-03,0.177490E-01,0.124835E-03, |
| 22799 | &0.193979E+00,0.511187E-01,0.653691E-03,0.661011E-03,0.654703E-03, |
| 22800 | &0.653691E-03,0.157425E-01,0.125031E-03,0.179441E+00,0.466950E-01, |
| 22801 | &0.592513E-03,0.599863E-03,0.593511E-03,0.592513E-03,0.139674E-01, |
| 22802 | &0.123805E-03,0.165770E+00,0.426018E-01,0.536539E-03,0.543850E-03, |
| 22803 | &0.537513E-03,0.536539E-03,0.123945E-01,0.121411E-03,0.152935E+00, |
| 22804 | &0.388195E-01,0.485370E-03,0.492584E-03,0.486314E-03,0.485370E-03, |
| 22805 | &0.109993E-01,0.118076E-03,0.140905E+00,0.353295E-01,0.438636E-03, |
| 22806 | &0.445702E-03,0.439543E-03,0.438636E-03,0.976027E-02,0.113999E-03, |
| 22807 | &0.129648E+00,0.321137E-01,0.395992E-03,0.402871E-03,0.396859E-03, |
| 22808 | &0.395992E-03,0.865895E-02,0.109353E-03,0.119131E+00,0.291550E-01, |
| 22809 | &0.357120E-03,0.363779E-03,0.357945E-03,0.357120E-03,0.767960E-02, |
| 22810 | &0.104292E-03,0.109323E+00,0.264366E-01,0.321725E-03,0.328139E-03, |
| 22811 | &0.322505E-03,0.321725E-03,0.680866E-02,0.989468E-04,0.100191E+00, |
| 22812 | &0.239428E-01,0.289531E-03,0.295679E-03,0.290266E-03,0.289531E-03/ |
| 22813 | DATA (DL(K),K= 2551, 2635) / |
| 22814 | &0.603390E-02,0.934295E-04,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22815 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22816 | &0.334851E+00,0.904666E-01,0.869706E-03,0.869706E-03,0.869706E-03, |
| 22817 | &0.869706E-03,0.316365E-01,-.311708E-17,0.311223E+00,0.828706E-01, |
| 22818 | &0.784673E-03,0.785968E-03,0.784847E-03,0.784673E-03,0.277037E-01, |
| 22819 | &0.134749E-04,0.288910E+00,0.758361E-01,0.708234E-03,0.710597E-03, |
| 22820 | &0.708543E-03,0.708234E-03,0.243298E-01,0.247881E-04,0.267855E+00, |
| 22821 | &0.693222E-01,0.639256E-03,0.642491E-03,0.639671E-03,0.639256E-03, |
| 22822 | &0.214125E-01,0.340882E-04,0.248015E+00,0.632964E-01,0.576953E-03, |
| 22823 | &0.580887E-03,0.577448E-03,0.576953E-03,0.188764E-01,0.415701E-04, |
| 22824 | &0.229343E+00,0.577274E-01,0.520615E-03,0.525096E-03,0.521167E-03, |
| 22825 | &0.520615E-03,0.166642E-01,0.474027E-04,0.211794E+00,0.525860E-01, |
| 22826 | &0.469624E-03,0.474520E-03,0.470215E-03,0.469624E-03,0.147265E-01, |
| 22827 | &0.517615E-04,0.195325E+00,0.478447E-01,0.423445E-03,0.428640E-03, |
| 22828 | &0.424060E-03,0.423445E-03,0.130234E-01,0.548213E-04,0.179891E+00, |
| 22829 | &0.434776E-01,0.381606E-03,0.387001E-03,0.382232E-03,0.381606E-03, |
| 22830 | &0.115226E-01,0.567474E-04,0.165449E+00,0.394601E-01,0.343691E-03/ |
| 22831 | DATA (DL(K),K= 2636, 2720) / |
| 22832 | &0.349200E-03,0.344317E-03,0.343691E-03,0.101965E-01,0.576952E-04, |
| 22833 | &0.151958E+00,0.357691E-01,0.309329E-03,0.314879E-03,0.309948E-03, |
| 22834 | &0.309329E-03,0.902217E-02,0.578101E-04,0.139374E+00,0.323826E-01, |
| 22835 | &0.278192E-03,0.283721E-03,0.278796E-03,0.278192E-03,0.798131E-02, |
| 22836 | &0.572266E-04,0.127655E+00,0.292797E-01,0.249984E-03,0.255440E-03, |
| 22837 | &0.250569E-03,0.249984E-03,0.705796E-02,0.560672E-04,0.116760E+00, |
| 22838 | &0.264406E-01,0.224440E-03,0.229782E-03,0.225002E-03,0.224440E-03, |
| 22839 | &0.623793E-02,0.544420E-04,0.106647E+00,0.238467E-01,0.201321E-03, |
| 22840 | &0.206513E-03,0.201856E-03,0.201321E-03,0.550962E-02,0.524504E-04, |
| 22841 | &0.972762E-01,0.214802E-01,0.180411E-03,0.185425E-03,0.180918E-03, |
| 22842 | &0.180411E-03,0.486321E-02,0.501804E-04,0.886073E-01,0.193242E-01, |
| 22843 | &0.161512E-03,0.166328E-03,0.161990E-03,0.161512E-03,0.428946E-02, |
| 22844 | &0.477087E-04,0.806013E-01,0.173629E-01,0.144446E-03,0.149048E-03, |
| 22845 | &0.144894E-03,0.144446E-03,0.378030E-02,0.451020E-04,0.732197E-01, |
| 22846 | &0.155814E-01,0.129049E-03,0.133425E-03,0.129467E-03,0.129049E-03, |
| 22847 | &0.332897E-02,0.424179E-04,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22848 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ |
| 22849 | DATA (DL(K),K= 2721, 2805) / |
| 22850 | &0.276761E+00,0.663170E-01,0.420483E-03,0.420483E-03,0.420483E-03, |
| 22851 | &0.420483E-03,0.172075E-01,0.418773E-17,0.255003E+00,0.601925E-01, |
| 22852 | &0.374768E-03,0.375776E-03,0.374876E-03,0.374768E-03,0.151410E-01, |
| 22853 | &0.540038E-05,0.234664E+00,0.545789E-01,0.334420E-03,0.336252E-03, |
| 22854 | &0.334612E-03,0.334420E-03,0.133594E-01,0.101360E-04,0.215665E+00, |
| 22855 | &0.494328E-01,0.298611E-03,0.301108E-03,0.298867E-03,0.298611E-03, |
| 22856 | &0.118079E-01,0.141555E-04,0.197941E+00,0.447203E-01,0.266766E-03, |
| 22857 | &0.269787E-03,0.267068E-03,0.266766E-03,0.104461E-01,0.174750E-04, |
| 22858 | &0.181428E+00,0.404089E-01,0.238391E-03,0.241815E-03,0.238726E-03, |
| 22859 | &0.238391E-03,0.924609E-02,0.201244E-04,0.166064E+00,0.364687E-01, |
| 22860 | &0.213061E-03,0.216782E-03,0.213417E-03,0.213061E-03,0.818507E-02, |
| 22861 | &0.221467E-04,0.151790E+00,0.328719E-01,0.190418E-03,0.194343E-03, |
| 22862 | &0.190785E-03,0.190418E-03,0.724366E-02,0.235974E-04,0.138548E+00, |
| 22863 | &0.295925E-01,0.170150E-03,0.174202E-03,0.170521E-03,0.170150E-03, |
| 22864 | &0.640614E-02,0.245354E-04,0.126282E+00,0.266063E-01,0.151991E-03, |
| 22865 | &0.156104E-03,0.152359E-03,0.151991E-03,0.566089E-02,0.250221E-04, |
| 22866 | &0.114939E+00,0.238907E-01,0.135710E-03,0.139827E-03,0.136071E-03/ |
| 22867 | DATA (DL(K),K= 2806, 2890) / |
| 22868 | &0.135710E-03,0.499773E-02,0.251191E-04,0.104465E+00,0.214245E-01, |
| 22869 | &0.121106E-03,0.125180E-03,0.121455E-03,0.121106E-03,0.440691E-02, |
| 22870 | &0.248850E-04,0.948101E-01,0.191879E-01,0.108002E-03,0.111994E-03, |
| 22871 | &0.108337E-03,0.108002E-03,0.388094E-02,0.243760E-04,0.859247E-01, |
| 22872 | &0.171625E-01,0.962435E-04,0.100124E-03,0.965624E-04,0.962435E-04, |
| 22873 | &0.341379E-02,0.236445E-04,0.777613E-01,0.153309E-01,0.856948E-04, |
| 22874 | &0.894394E-04,0.859960E-04,0.856948E-04,0.299910E-02,0.227378E-04, |
| 22875 | &0.702736E-01,0.136770E-01,0.762337E-04,0.798235E-04,0.765166E-04, |
| 22876 | &0.762337E-04,0.263116E-02,0.216984E-04,0.634174E-01,0.121859E-01, |
| 22877 | &0.677528E-04,0.711742E-04,0.680169E-04,0.677528E-04,0.230551E-02, |
| 22878 | &0.205642E-04,0.571500E-01,0.108434E-01,0.601554E-04,0.633990E-04, |
| 22879 | &0.604008E-04,0.601554E-04,0.201791E-02,0.193681E-04,0.514305E-01, |
| 22880 | &0.963651E-02,0.533545E-04,0.564148E-04,0.535814E-04,0.533545E-04, |
| 22881 | &0.176404E-02,0.181381E-04,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22882 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22883 | &0.220700E+00,0.461964E-01,0.185072E-03,0.185072E-03,0.185072E-03, |
| 22884 | &0.185072E-03,0.865568E-02,-.294090E-17,0.201438E+00,0.415162E-01/ |
| 22885 | DATA (DL(K),K= 2891, 2975) / |
| 22886 | &0.162774E-03,0.163610E-03,0.162842E-03,0.162774E-03,0.772611E-02, |
| 22887 | &0.184134E-05,0.183625E+00,0.372730E-01,0.143469E-03,0.144974E-03, |
| 22888 | &0.143588E-03,0.143469E-03,0.690038E-02,0.359959E-05,0.167162E+00, |
| 22889 | &0.334245E-01,0.126634E-03,0.128666E-03,0.126791E-03,0.126634E-03, |
| 22890 | &0.616000E-02,0.518075E-05,0.151966E+00,0.299378E-01,0.111904E-03, |
| 22891 | &0.114340E-03,0.112088E-03,0.111904E-03,0.549219E-02,0.654232E-05, |
| 22892 | &0.137959E+00,0.267821E-01,0.989836E-04,0.101716E-03,0.991845E-04, |
| 22893 | &0.989836E-04,0.488896E-02,0.767008E-05,0.125065E+00,0.239289E-01, |
| 22894 | &0.876157E-04,0.905559E-04,0.878269E-04,0.876157E-04,0.434253E-02, |
| 22895 | &0.855860E-05,0.113213E+00,0.213524E-01,0.775899E-04,0.806611E-04, |
| 22896 | &0.778055E-04,0.775899E-04,0.384886E-02,0.921640E-05,0.102335E+00, |
| 22897 | &0.190285E-01,0.687292E-04,0.718676E-04,0.689446E-04,0.687292E-04, |
| 22898 | &0.340422E-02,0.965961E-05,0.923671E-01,0.169353E-01,0.608829E-04, |
| 22899 | &0.640353E-04,0.610944E-04,0.608829E-04,0.300332E-02,0.990752E-05, |
| 22900 | &0.832476E-01,0.150523E-01,0.539242E-04,0.570473E-04,0.541291E-04, |
| 22901 | &0.539242E-04,0.264288E-02,0.998320E-05,0.749179E-01,0.133608E-01, |
| 22902 | &0.477459E-04,0.508046E-04,0.479422E-04,0.477459E-04,0.232088E-02/ |
| 22903 | DATA (DL(K),K= 2976, 3060) / |
| 22904 | &0.991147E-05,0.673221E-01,0.118435E-01,0.422554E-04,0.452220E-04, |
| 22905 | &0.424417E-04,0.422554E-04,0.203376E-02,0.971603E-05,0.604073E-01, |
| 22906 | &0.104845E-01,0.373730E-04,0.402263E-04,0.375483E-04,0.373730E-04, |
| 22907 | &0.177791E-02,0.941959E-05,0.541231E-01,0.926900E-02,0.330304E-04, |
| 22908 | &0.357544E-04,0.331943E-04,0.330304E-04,0.155117E-02,0.904408E-05, |
| 22909 | &0.484216E-01,0.818347E-02,0.291681E-04,0.317517E-04,0.293202E-04, |
| 22910 | &0.291681E-04,0.135108E-02,0.860921E-05,0.432578E-01,0.721549E-02, |
| 22911 | &0.257333E-04,0.281694E-04,0.258738E-04,0.257333E-04,0.117463E-02, |
| 22912 | &0.813214E-05,0.385889E-01,0.635362E-02,0.226802E-04,0.249648E-04, |
| 22913 | &0.228093E-04,0.226802E-04,0.101941E-02,0.762814E-05,0.343746E-01, |
| 22914 | &0.558739E-02,0.199682E-04,0.221003E-04,0.200863E-04,0.199682E-04, |
| 22915 | &0.883469E-03,0.711035E-05,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22916 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22917 | &0.168205E+00,0.301419E-01,0.719932E-04,0.719932E-04,0.719932E-04, |
| 22918 | &0.719932E-04,0.392825E-02,-.205998E-17,0.151922E+00,0.267932E-01, |
| 22919 | &0.623634E-04,0.630456E-04,0.624028E-04,0.623634E-04,0.361412E-02, |
| 22920 | &0.457084E-06,0.137042E+00,0.237932E-01,0.541981E-04,0.554098E-04/ |
| 22921 | DATA (DL(K),K= 3061, 3145) / |
| 22922 | &0.542663E-04,0.541981E-04,0.330342E-02,0.989813E-06,0.123446E+00, |
| 22923 | &0.211038E-01,0.472163E-04,0.488314E-04,0.473050E-04,0.472163E-04, |
| 22924 | &0.300140E-02,0.152631E-05,0.111042E+00,0.186954E-01,0.412159E-04, |
| 22925 | &0.431273E-04,0.413184E-04,0.412159E-04,0.270826E-02,0.202092E-05, |
| 22926 | &0.997395E-01,0.165410E-01,0.360433E-04,0.381615E-04,0.361542E-04, |
| 22927 | &0.360433E-04,0.242968E-02,0.245400E-05,0.894558E-01,0.146159E-01, |
| 22928 | &0.315670E-04,0.338178E-04,0.316822E-04,0.315670E-04,0.216928E-02, |
| 22929 | &0.281218E-05,0.801130E-01,0.128978E-01,0.276779E-04,0.300002E-04, |
| 22930 | &0.277940E-04,0.276779E-04,0.192603E-02,0.308878E-05,0.716379E-01, |
| 22931 | &0.113663E-01,0.242878E-04,0.266317E-04,0.244024E-04,0.242878E-04, |
| 22932 | &0.170100E-02,0.328451E-05,0.639623E-01,0.100031E-01,0.213246E-04, |
| 22933 | &0.236502E-04,0.214357E-04,0.213246E-04,0.149649E-02,0.340483E-05, |
| 22934 | &0.570222E-01,0.879131E-02,0.187277E-04,0.210033E-04,0.188341E-04, |
| 22935 | &0.187277E-04,0.131163E-02,0.345656E-05,0.507574E-01,0.771565E-02, |
| 22936 | &0.164465E-04,0.186476E-04,0.165471E-04,0.164465E-04,0.114469E-02, |
| 22937 | &0.344782E-05,0.451118E-01,0.676223E-02,0.144396E-04,0.165480E-04, |
| 22938 | &0.145339E-04,0.144396E-04,0.995649E-03,0.338831E-05,0.400330E-01/ |
| 22939 | DATA (DL(K),K= 3146, 3230) / |
| 22940 | &0.591841E-02,0.126720E-04,0.146744E-04,0.127597E-04,0.126720E-04, |
| 22941 | &0.863829E-03,0.328754E-05,0.354720E-01,0.517273E-02,0.111137E-04, |
| 22942 | &0.130013E-04,0.111946E-04,0.111137E-04,0.747293E-03,0.315403E-05, |
| 22943 | &0.313830E-01,0.451477E-02,0.973915E-05,0.115067E-04,0.981339E-05, |
| 22944 | &0.973915E-05,0.644664E-03,0.299600E-05,0.277237E-01,0.393511E-02, |
| 22945 | &0.852687E-05,0.101721E-04,0.859457E-05,0.852687E-05,0.555034E-03, |
| 22946 | &0.282099E-05,0.244545E-01,0.342521E-02,0.745784E-05,0.898076E-05, |
| 22947 | &0.751926E-05,0.745784E-05,0.476998E-03,0.263530E-05,0.215390E-01, |
| 22948 | &0.297737E-02,0.651555E-05,0.791817E-05,0.657100E-05,0.651555E-05, |
| 22949 | &0.409096E-03,0.244427E-05,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22950 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22951 | &0.120694E+00,0.180081E-01,0.236444E-04,0.236444E-04,0.236444E-04, |
| 22952 | &0.236444E-04,0.154817E-02,0.416656E-17,0.107713E+00,0.158098E-01, |
| 22953 | &0.200945E-04,0.206098E-04,0.201146E-04,0.200945E-04,0.151249E-02, |
| 22954 | &0.192118E-07,0.960063E-01,0.138667E-01,0.171552E-04,0.180593E-04, |
| 22955 | &0.171894E-04,0.171552E-04,0.143574E-02,0.116516E-06,0.854477E-01, |
| 22956 | &0.121473E-01,0.146986E-04,0.158894E-04,0.147425E-04,0.146986E-04/ |
| 22957 | DATA (DL(K),K= 3231, 3315) / |
| 22958 | &0.133744E-02,0.251060E-06,0.759386E-01,0.106275E-01,0.126329E-04, |
| 22959 | &0.140252E-04,0.126830E-04,0.126329E-04,0.122900E-02,0.395272E-06, |
| 22960 | &0.673865E-01,0.928577E-02,0.108901E-04,0.124142E-04,0.109436E-04, |
| 22961 | &0.108901E-04,0.111367E-02,0.535145E-06,0.597062E-01,0.810254E-02, |
| 22962 | &0.941160E-05,0.110108E-04,0.946648E-05,0.941160E-05,0.996785E-03, |
| 22963 | &0.659421E-06,0.528194E-01,0.706039E-02,0.815165E-05,0.978016E-05, |
| 22964 | &0.820627E-05,0.815165E-05,0.885152E-03,0.762600E-06,0.466540E-01, |
| 22965 | &0.614371E-02,0.707299E-05,0.869464E-05,0.712616E-05,0.707299E-05, |
| 22966 | &0.780484E-03,0.842072E-06,0.411433E-01,0.533850E-02,0.614470E-05, |
| 22967 | &0.773135E-05,0.619559E-05,0.614470E-05,0.682563E-03,0.896683E-06, |
| 22968 | &0.362261E-01,0.463223E-02,0.534297E-05,0.687330E-05,0.539102E-05, |
| 22969 | &0.534297E-05,0.593317E-03,0.928176E-06,0.318459E-01,0.401364E-02, |
| 22970 | &0.464848E-05,0.610690E-05,0.469333E-05,0.464848E-05,0.513720E-03, |
| 22971 | &0.939174E-06,0.279510E-01,0.347266E-02,0.404483E-05,0.542054E-05, |
| 22972 | &0.408628E-05,0.404483E-05,0.442713E-03,0.932117E-06,0.244935E-01, |
| 22973 | &0.300029E-02,0.351893E-05,0.480507E-05,0.355692E-05,0.351893E-05, |
| 22974 | &0.379744E-03,0.910085E-06,0.214299E-01,0.258845E-02,0.306021E-05/ |
| 22975 | DATA (DL(K),K= 3316, 3400) / |
| 22976 | &0.425313E-05,0.309476E-05,0.306021E-05,0.324785E-03,0.876365E-06, |
| 22977 | &0.187200E-01,0.222996E-02,0.265958E-05,0.375823E-05,0.269081E-05, |
| 22978 | &0.265958E-05,0.277080E-03,0.833755E-06,0.163273E-01,0.191840E-02, |
| 22979 | &0.230942E-05,0.331477E-05,0.233747E-05,0.230942E-05,0.235661E-03, |
| 22980 | &0.784780E-06,0.142185E-01,0.164805E-02,0.200337E-05,0.291797E-05, |
| 22981 | &0.202844E-05,0.200337E-05,0.199949E-03,0.731774E-06,0.123631E-01, |
| 22982 | &0.141382E-02,0.173596E-05,0.256351E-05,0.175824E-05,0.173596E-05, |
| 22983 | &0.169376E-03,0.676674E-06,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22984 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 22985 | &0.794823E-01,0.948208E-02,0.607312E-05,0.607312E-05,0.607312E-05, |
| 22986 | &0.607312E-05,0.497062E-03,-.140523E-17,0.699344E-01,0.820355E-02, |
| 22987 | &0.500852E-05,0.538347E-05,0.501731E-05,0.500852E-05,0.542262E-03, |
| 22988 | &-.714686E-07,0.614560E-01,0.709106E-02,0.415227E-05,0.479898E-05, |
| 22989 | &0.416702E-05,0.415227E-05,0.549985E-03,-.960102E-07,0.539240E-01, |
| 22990 | &0.612155E-02,0.345977E-05,0.429563E-05,0.347839E-05,0.345977E-05, |
| 22991 | &0.531288E-03,-.894946E-07,0.472426E-01,0.527757E-02,0.289508E-05, |
| 22992 | &0.385164E-05,0.291595E-05,0.289508E-05,0.495120E-03,-.668594E-07/ |
| 22993 | DATA (DL(K),K= 3401, 3485) / |
| 22994 | &0.413245E-01,0.454380E-02,0.243524E-05,0.345851E-05,0.245713E-05, |
| 22995 | &0.243524E-05,0.452156E-03,-.338861E-07,0.360903E-01,0.390658E-02, |
| 22996 | &0.205923E-05,0.310726E-05,0.208123E-05,0.205923E-05,0.406686E-03, |
| 22997 | &0.329349E-08,0.314681E-01,0.335393E-02,0.174861E-05,0.278918E-05, |
| 22998 | &0.177007E-05,0.174861E-05,0.359402E-03,0.387747E-07,0.273932E-01, |
| 22999 | &0.287528E-02,0.149082E-05,0.250013E-05,0.151127E-05,0.149082E-05, |
| 23000 | &0.313779E-03,0.705560E-07,0.238068E-01,0.246132E-02,0.127582E-05, |
| 23001 | &0.223699E-05,0.129498E-05,0.127582E-05,0.272195E-03,0.975744E-07, |
| 23002 | &0.206558E-01,0.210383E-02,0.109488E-05,0.199657E-05,0.111257E-05, |
| 23003 | &0.109488E-05,0.234227E-03,0.118651E-06,0.178921E-01,0.179558E-02, |
| 23004 | &0.941584E-06,0.177694E-05,0.957733E-06,0.941584E-06,0.199907E-03, |
| 23005 | &0.133780E-06,0.154726E-01,0.153020E-02,0.811157E-06,0.157680E-05, |
| 23006 | &0.825743E-06,0.811157E-06,0.169849E-03,0.143581E-06,0.133582E-01, |
| 23007 | &0.130209E-02,0.699567E-06,0.139481E-05,0.712624E-06,0.699567E-06, |
| 23008 | &0.143794E-03,0.148591E-06,0.115137E-01,0.110634E-02,0.603631E-06, |
| 23009 | &0.122977E-05,0.615228E-06,0.603631E-06,0.121163E-03,0.149477E-06, |
| 23010 | &0.990774E-02,0.938615E-03,0.520920E-06,0.108072E-05,0.531148E-06/ |
| 23011 | DATA (DL(K),K= 3486, 3570) / |
| 23012 | &0.520920E-06,0.101725E-03,0.147055E-06,0.851194E-02,0.795146E-03, |
| 23013 | &0.449441E-06,0.946634E-06,0.458405E-06,0.449441E-06,0.852238E-04, |
| 23014 | &0.142064E-06,0.730103E-02,0.672622E-03,0.387542E-06,0.826497E-06, |
| 23015 | &0.395353E-06,0.387542E-06,0.712290E-04,0.135149E-06,0.625244E-02, |
| 23016 | &0.568155E-03,0.333888E-06,0.719316E-06,0.340658E-06,0.333888E-06, |
| 23017 | &0.593824E-04,0.126902E-06,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23018 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23019 | &0.457819E-01,0.409492E-02,0.105702E-05,0.105702E-05,0.105702E-05, |
| 23020 | &0.105702E-05,0.115350E-03,0.265810E-18,0.395724E-01,0.347873E-02, |
| 23021 | &0.812397E-06,0.103880E-05,0.815187E-06,0.812397E-06,0.160406E-03, |
| 23022 | &-.555147E-07,0.341639E-01,0.295295E-02,0.627904E-06,0.987449E-06, |
| 23023 | &0.632305E-06,0.627904E-06,0.174490E-03,-.847266E-07,0.294481E-01, |
| 23024 | &0.250329E-02,0.490075E-06,0.920197E-06,0.495305E-06,0.490075E-06, |
| 23025 | &0.174490E-03,-.944763E-07,0.253423E-01,0.211912E-02,0.387225E-06, |
| 23026 | &0.845257E-06,0.392760E-06,0.387225E-06,0.167111E-03,-.916775E-07, |
| 23027 | &0.217735E-01,0.179138E-02,0.309989E-06,0.766697E-06,0.315473E-06, |
| 23028 | &0.309989E-06,0.152540E-03,-.819158E-07,0.186760E-01,0.151211E-02/ |
| 23029 | DATA (DL(K),K= 3571, 3655) / |
| 23030 | &0.252109E-06,0.688927E-06,0.257316E-06,0.252109E-06,0.135295E-03, |
| 23031 | &-.682145E-07,0.159921E-01,0.127447E-02,0.208612E-06,0.614302E-06, |
| 23032 | &0.213410E-06,0.208612E-06,0.118648E-03,-.528734E-07,0.136704E-01, |
| 23033 | &0.107254E-02,0.175203E-06,0.543807E-06,0.179526E-06,0.175203E-06, |
| 23034 | &0.102484E-03,-.379748E-07,0.116656E-01,0.901214E-03,0.149064E-06, |
| 23035 | &0.478363E-06,0.152890E-06,0.149064E-06,0.871530E-04,-.245007E-07, |
| 23036 | &0.993760E-02,0.756074E-03,0.128274E-06,0.418496E-06,0.131610E-06, |
| 23037 | &0.128274E-06,0.735682E-04,-.128491E-07,0.845081E-02,0.633315E-03, |
| 23038 | &0.111313E-06,0.364260E-06,0.114187E-06,0.111313E-06,0.617706E-04, |
| 23039 | &-.327698E-08,0.717398E-02,0.529654E-03,0.971373E-07,0.315568E-06, |
| 23040 | &0.995871E-07,0.971373E-07,0.514764E-04,0.421954E-08,0.607950E-02, |
| 23041 | &0.442265E-03,0.850687E-07,0.272228E-06,0.871375E-07,0.850687E-07, |
| 23042 | &0.426580E-04,0.982709E-08,0.514311E-02,0.368716E-03,0.746164E-07, |
| 23043 | &0.233927E-06,0.763489E-07,0.746164E-07,0.352463E-04,0.137715E-07, |
| 23044 | &0.434349E-02,0.306920E-03,0.654439E-07,0.200291E-06,0.668838E-07, |
| 23045 | &0.654439E-07,0.290260E-04,0.163078E-07,0.366196E-02,0.255085E-03, |
| 23046 | &0.573307E-07,0.170932E-06,0.585192E-07,0.573307E-07,0.238196E-04/ |
| 23047 | DATA (DL(K),K= 3656, 3740) / |
| 23048 | &0.177037E-07,0.308217E-02,0.211681E-03,0.501185E-07,0.145441E-06, |
| 23049 | &0.510931E-07,0.501185E-07,0.195033E-04,0.182028E-07,0.258987E-02, |
| 23050 | &0.175396E-03,0.436915E-07,0.123415E-06,0.444860E-07,0.436915E-07, |
| 23051 | &0.159423E-04,0.180204E-07,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23052 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23053 | &0.206951E-01,0.123383E-02,0.903693E-07,0.903693E-07,0.903693E-07, |
| 23054 | &0.903693E-07,0.147928E-04,0.131925E-18,0.174566E-01,0.102241E-02, |
| 23055 | &0.892028E-07,0.129792E-07,0.885875E-07,0.892028E-07,0.328931E-04, |
| 23056 | &0.168541E-07,0.147092E-01,0.846741E-03,0.841992E-07,-.346085E-07, |
| 23057 | &0.832249E-07,0.841992E-07,0.410825E-04,0.262547E-07,0.123736E-01, |
| 23058 | &0.700287E-03,0.769173E-07,-.620958E-07,0.757563E-07,0.769173E-07, |
| 23059 | &0.418512E-04,0.305542E-07,0.103910E-01,0.578275E-03,0.688622E-07, |
| 23060 | &-.753692E-07,0.676306E-07,0.688622E-07,0.392599E-04,0.318183E-07, |
| 23061 | &0.871109E-02,0.476815E-03,0.611778E-07,-.782788E-07,0.599557E-07, |
| 23062 | &0.611778E-07,0.356221E-04,0.316149E-07,0.728984E-02,0.392546E-03, |
| 23063 | &0.537256E-07,-.749101E-07,0.525642E-07,0.537256E-07,0.312295E-04, |
| 23064 | &0.301630E-07,0.608951E-02,0.322656E-03,0.466227E-07,-.678673E-07/ |
| 23065 | DATA (DL(K),K= 3741, 3825) / |
| 23066 | &0.455521E-07,0.466227E-07,0.265816E-04,0.278681E-07,0.507758E-02, |
| 23067 | &0.264779E-03,0.400790E-07,-.588670E-07,0.391148E-07,0.400790E-07, |
| 23068 | &0.223044E-04,0.251720E-07,0.422604E-02,0.216927E-03,0.341205E-07, |
| 23069 | &-.492124E-07,0.332680E-07,0.341205E-07,0.185283E-04,0.222885E-07, |
| 23070 | &0.351082E-02,0.177427E-03,0.287480E-07,-.397442E-07,0.280058E-07, |
| 23071 | &0.287480E-07,0.152122E-04,0.193702E-07,0.291126E-02,0.144878E-03, |
| 23072 | &0.239699E-07,-.309608E-07,0.233320E-07,0.239699E-07,0.123840E-04, |
| 23073 | &0.165481E-07,0.240962E-02,0.118102E-03,0.197695E-07,-.231453E-07, |
| 23074 | &0.192276E-07,0.197695E-07,0.100316E-04,0.139043E-07,0.199075E-02, |
| 23075 | &0.961132E-04,0.161186E-07,-.164194E-07,0.156628E-07,0.161186E-07, |
| 23076 | &0.808648E-05,0.114903E-07,0.164168E-02,0.780880E-04,0.129826E-07, |
| 23077 | &-.107955E-07,0.126029E-07,0.129826E-07,0.648861E-05,0.933575E-08, |
| 23078 | &0.135135E-02,0.633381E-04,0.103192E-07,-.622051E-08,0.100055E-07, |
| 23079 | &0.103192E-07,0.519042E-05,0.744979E-08,0.111036E-02,0.512898E-04, |
| 23080 | &0.808255E-08,-.260101E-08,0.782557E-08,0.808255E-08,0.414192E-05, |
| 23081 | &0.582811E-08,0.910718E-03,0.414657E-04,0.622640E-08,0.177583E-09, |
| 23082 | &0.601750E-08,0.622640E-08,0.329729E-05,0.445766E-08,0.745657E-03/ |
| 23083 | DATA (DL(K),K= 3826, 3910) / |
| 23084 | &0.334694E-04,0.470431E-08,0.223586E-08,0.453577E-08,0.470431E-08, |
| 23085 | &0.261981E-05,0.331859E-08,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23086 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, |
| 23087 | &0.519165E-02,0.154752E-03,0.135983E-08,0.135983E-08,0.135983E-08, |
| 23088 | &0.135983E-08,0.445189E-06,0.165858E-19,0.420352E-02,0.123002E-03, |
| 23089 | &-.202651E-07,0.730203E-07,-.200511E-07,-.202651E-07,0.358557E-05, |
| 23090 | &-.213089E-07,0.340143E-02,0.977718E-04,-.356451E-07,0.114908E-06, |
| 23091 | &-.353066E-07,-.356451E-07,0.384652E-05,-.364475E-07,0.274771E-02, |
| 23092 | &0.776124E-04,-.435588E-07,0.139200E-06,-.431556E-07,-.435588E-07, |
| 23093 | &0.404834E-05,-.441752E-07,0.221524E-02,0.614950E-04,-.471629E-07, |
| 23094 | &0.150069E-06,-.467352E-07,-.471629E-07,0.391615E-05,-.476355E-07, |
| 23095 | &0.178268E-02,0.486476E-04,-.477545E-07,0.151420E-06,-.473296E-07, |
| 23096 | &-.477545E-07,0.334100E-05,-.481163E-07,0.143185E-02,0.384202E-04, |
| 23097 | &-.462359E-07,0.146515E-06,-.458316E-07,-.462359E-07,0.275426E-05, |
| 23098 | &-.465126E-07,0.114781E-02,0.302894E-04,-.434031E-07,0.137587E-06, |
| 23099 | &-.430295E-07,-.434031E-07,0.226010E-05,-.436143E-07,0.918288E-03, |
| 23100 | &0.238367E-04,-.398089E-07,0.126321E-06,-.394715E-07,-.398089E-07/ |
| 23101 | DATA (DL(K),K= 3911, 3995) / |
| 23102 | &0.180947E-05,-.399700E-07,0.733193E-03,0.187249E-04,-.358525E-07, |
| 23103 | &0.113940E-06,-.355529E-07,-.358525E-07,0.142045E-05,-.359751E-07, |
| 23104 | &0.584227E-03,0.146823E-04,-.318183E-07,0.101291E-06,-.315563E-07, |
| 23105 | &-.318183E-07,0.110919E-05,-.319115E-07,0.464586E-03,0.114914E-04, |
| 23106 | &-.278936E-07,0.889550E-07,-.276671E-07,-.278936E-07,0.860964E-06, |
| 23107 | &-.279643E-07,0.368700E-03,0.897731E-05,-.241972E-07,0.773096E-07, |
| 23108 | &-.240033E-07,-.241972E-07,0.662825E-06,-.242508E-07,0.292013E-03, |
| 23109 | &0.700034E-05,-.208001E-07,0.665779E-07,-.206356E-07,-.208001E-07, |
| 23110 | &0.508061E-06,-.208406E-07,0.230814E-03,0.544870E-05,-.177366E-07, |
| 23111 | &0.568734E-07,-.175982E-07,-.177366E-07,0.388493E-06,-.177672E-07, |
| 23112 | &0.182078E-03,0.423324E-05,-.150157E-07,0.482316E-07,-.149000E-07, |
| 23113 | &-.150157E-07,0.296111E-06,-.150387E-07,0.143349E-03,0.328297E-05, |
| 23114 | &-.126295E-07,0.406343E-07,-.125335E-07,-.126295E-07,0.225104E-06, |
| 23115 | &-.126468E-07,0.112639E-03,0.254145E-05,-.105595E-07,0.340280E-07, |
| 23116 | &-.104803E-07,-.105595E-07,0.170871E-06,-.105726E-07,0.883377E-04, |
| 23117 | &0.196395E-05,-.878062E-08,0.283380E-07,-.871555E-08,-.878062E-08, |
| 23118 | &0.129517E-06,-.879039E-08,0.000000E+00,0.000000E+00,0.000000E+00/ |
| 23119 | DATA (DL(K),K= 3996, 4000) / |
| 23120 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ |
| 23121 | C |
| 23122 | ANS = 0. |
| 23123 | IF (X.GT.0.9985) RETURN |
| 23124 | IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN |
| 23125 | C |
| 23126 | IS = S/DELTA+1 |
| 23127 | IS1 = IS+1 |
| 23128 | DO 1 L=1,25 |
| 23129 | KL = L+NDRV*25 |
| 23130 | F1(L) = GF(I,IS,KL) |
| 23131 | F2(L) = GF(I,IS1,KL) |
| 23132 | 1 CONTINUE |
| 23133 | A1 = DT_CKMTFF(X,F1) |
| 23134 | A2 = DT_CKMTFF(X,F2) |
| 23135 | C A1=ALOG(A1) |
| 23136 | C A2=ALOG(A2) |
| 23137 | S1 = (IS-1)*DELTA |
| 23138 | S2 = S1+DELTA |
| 23139 | ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1) |
| 23140 | C ANS=EXP(ANS) |
| 23141 | RETURN |
| 23142 | END |
| 23143 | C |
| 23144 | CDECK ID>, DT_CKMTFF |
| 23145 | FUNCTION DT_CKMTFF(X,FVL) |
| 23146 | C********************************************************************** |
| 23147 | C |
| 23148 | C LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE |
| 23149 | C FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1. |
| 23150 | C NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED |
| 23151 | C IN MAIN ROUTINE. |
| 23152 | C |
| 23153 | C********************************************************************** |
| 23154 | |
| 23155 | SAVE |
| 23156 | DIMENSION FVL(25),XGRID(25) |
| 23157 | DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15, |
| 23158 | *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/ |
| 23159 | C |
| 23160 | DT_CKMTFF=0. |
| 23161 | DO 1 I=1,NX |
| 23162 | IF(X.LT.XGRID(I)) GO TO 2 |
| 23163 | 1 CONTINUE |
| 23164 | 2 I=I-1 |
| 23165 | IF(I.EQ.0) THEN |
| 23166 | I=I+1 |
| 23167 | ELSE IF(I.GT.23) THEN |
| 23168 | I=23 |
| 23169 | ENDIF |
| 23170 | J=I+1 |
| 23171 | K=J+1 |
| 23172 | AXI=LOG(XGRID(I)) |
| 23173 | BXI=LOG(1.-XGRID(I)) |
| 23174 | AXJ=LOG(XGRID(J)) |
| 23175 | BXJ=LOG(1.-XGRID(J)) |
| 23176 | AXK=LOG(XGRID(K)) |
| 23177 | BXK=LOG(1.-XGRID(K)) |
| 23178 | FI=LOG(ABS(FVL(I)) +1.E-15) |
| 23179 | FJ=LOG(ABS(FVL(J)) +1.E-16) |
| 23180 | FK=LOG(ABS(FVL(K)) +1.E-17) |
| 23181 | DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ) |
| 23182 | ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ* |
| 23183 | $ BXI))/DET |
| 23184 | ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET |
| 23185 | BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET |
| 23186 | IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.) |
| 23187 | 1RETURN |
| 23188 | C IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN |
| 23189 | C WRITE(6,2001) X,FVL |
| 23190 | C 2001 FORMAT(8E12.4) |
| 23191 | C WRITE(6,2001) ALPHA,BETA,ALOGA,DET |
| 23192 | C ENDIF |
| 23193 | DT_CKMTFF=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA |
| 23194 | RETURN |
| 23195 | END |
| 23196 | * |
| 23197 | *===fluini=============================================================* |
| 23198 | * |
| 23199 | CDECK ID>, DT_FLUINI |
| 23200 | SUBROUTINE DT_FLUINI |
| 23201 | |
| 23202 | ************************************************************************ |
| 23203 | * Initialisation of the nucleon-nucleon cross section fluctuation * |
| 23204 | * treatment. The original version by J. Ranft. * |
| 23205 | * This version dated 21.04.95 is revised by S. Roesler. * |
| 23206 | ************************************************************************ |
| 23207 | |
| 23208 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 23209 | SAVE |
| 23210 | |
| 23211 | PARAMETER ( LINP = 5 , |
| 23212 | & LOUT = 6 , |
| 23213 | & LDAT = 9 ) |
| 23214 | |
| 23215 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) |
| 23216 | |
| 23217 | PARAMETER ( A = 0.1D0, |
| 23218 | & B = 0.893D0, |
| 23219 | & OM = 1.1D0, |
| 23220 | & N = 6, |
| 23221 | & DX = 0.003D0) |
| 23222 | |
| 23223 | * n-n cross section fluctuations |
| 23224 | PARAMETER (NBINS = 1000) |
| 23225 | COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT |
| 23226 | DIMENSION FLUSI(NBINS),FLUIX(NBINS) |
| 23227 | |
| 23228 | WRITE(LOUT,1000) |
| 23229 | 1000 FORMAT(/,1X,'FLUINI: hadronic cross section fluctuations ', |
| 23230 | & 'treated') |
| 23231 | |
| 23232 | FLUSU = ZERO |
| 23233 | FLUSUU = ZERO |
| 23234 | |
| 23235 | DO 1 I=1,NBINS |
| 23236 | X = DBLE(I)*DX |
| 23237 | FLUIX(I) = X |
| 23238 | FLUS = ((X-B)/(OM*B))**N |
| 23239 | IF (FLUS.LE.20.0D0) THEN |
| 23240 | FLUSI(I) = (X/B)*EXP(-FLUS)/(X/B+A) |
| 23241 | ELSE |
| 23242 | FLUSI(I) = ZERO |
| 23243 | ENDIF |
| 23244 | FLUSU = FLUSU+FLUSI(I) |
| 23245 | 1 CONTINUE |
| 23246 | DO 2 I=1,NBINS |
| 23247 | FLUSUU = FLUSUU+FLUSI(I)/FLUSU |
| 23248 | FLUSI(I) = FLUSUU |
| 23249 | 2 CONTINUE |
| 23250 | |
| 23251 | C WRITE(LOUT,1001) |
| 23252 | C1001 FORMAT(1X,'FLUCTUATIONS') |
| 23253 | C CALL PLOT(FLUIX,FLUSI,1000,1,1000,0.0D0,0.06D0,0.0D0,0.01D0) |
| 23254 | |
| 23255 | DO 3 I=1,NBINS |
| 23256 | AF = DBLE(I)*0.001D0 |
| 23257 | DO 4 J=1,NBINS |
| 23258 | IF (AF.LE.FLUSI(J)) THEN |
| 23259 | FLUIXX(I) = FLUIX(J) |
| 23260 | GOTO 5 |
| 23261 | ENDIF |
| 23262 | 4 CONTINUE |
| 23263 | 5 CONTINUE |
| 23264 | 3 CONTINUE |
| 23265 | FLUIXX(1) = FLUIX(1) |
| 23266 | FLUIXX(NBINS) = FLUIX(NBINS) |
| 23267 | |
| 23268 | RETURN |
| 23269 | END |
| 23270 | * |
| 23271 | *===sigtab=============================================================* |
| 23272 | * |
| 23273 | CDECK ID>, DT_SIGTBL |
| 23274 | SUBROUTINE DT_SIGTBL(JP,JT,PTOT,SIGE,MODE) |
| 23275 | |
| 23276 | ************************************************************************ |
| 23277 | * This version dated 18.11.95 is written by S. Roesler * |
| 23278 | ************************************************************************ |
| 23279 | |
| 23280 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 23281 | SAVE |
| 23282 | |
| 23283 | PARAMETER ( LINP = 5 , |
| 23284 | & LOUT = 6 , |
| 23285 | & LDAT = 9 ) |
| 23286 | |
| 23287 | PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10, |
| 23288 | & OHALF=0.5D0,ONE=1.0D0) |
| 23289 | PARAMETER (PLO=0.01D0,PHI=20.0D0,NBINS=150) |
| 23290 | |
| 23291 | LOGICAL LINIT |
| 23292 | |
| 23293 | * particle properties (BAMJET index convention) |
| 23294 | CHARACTER*8 ANAME |
| 23295 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 23296 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 23297 | |
| 23298 | DIMENSION SIGEP(5,NBINS+1),SIGEN(5,NBINS+1),IDSIG(23) |
| 23299 | DATA IDSIG / 1, 0, 0, 0, 0, 0, 0, 2, 0, 0, |
| 23300 | & 0, 0, 3, 4, 0, 0, 0, 0, 0, 0, |
| 23301 | & 0, 0, 5/ |
| 23302 | DATA LINIT /.FALSE./ |
| 23303 | |
| 23304 | * precalculation and tabulation of elastic cross sections |
| 23305 | IF (ABS(MODE).EQ.1) THEN |
| 23306 | IF (MODE.EQ.1) |
| 23307 | & OPEN(LDAT,FILE='sigtab.out',STATUS='UNKNOWN') |
| 23308 | PLABLX = LOG10(PLO) |
| 23309 | PLABHX = LOG10(PHI) |
| 23310 | DPLAB = (PLABHX-PLABLX)/DBLE(NBINS) |
| 23311 | DO 1 I=1,NBINS+1 |
| 23312 | PLAB = PLABLX+DBLE(I-1)*DPLAB |
| 23313 | PLAB = 10**PLAB |
| 23314 | DO 2 IPROJ=1,23 |
| 23315 | IDX = IDSIG(IPROJ) |
| 23316 | IF (IDX.GT.0) THEN |
| 23317 | C CALL DT_SIHNEL(IPROJ,1,PLAB,SIGEP(IDX,I)) |
| 23318 | C CALL DT_SIHNEL(IPROJ,8,PLAB,SIGEN(IDX,I)) |
| 23319 | DUMZER = ZERO |
| 23320 | CALL DT_XSHN(IPROJ,1,PLAB,DUMZER,SIGTOT,SIGEP(IDX,I)) |
| 23321 | CALL DT_XSHN(IPROJ,8,PLAB,DUMZER,SIGTOT,SIGEN(IDX,I)) |
| 23322 | ENDIF |
| 23323 | 2 CONTINUE |
| 23324 | IF (MODE.EQ.1) THEN |
| 23325 | WRITE(LDAT,1000) PLAB,(SIGEP(IDX,I),IDX=1,5), |
| 23326 | & (SIGEN(IDX,I),IDX=1,5) |
| 23327 | 1000 FORMAT(F5.1,10F7.2) |
| 23328 | ENDIF |
| 23329 | 1 CONTINUE |
| 23330 | IF (MODE.EQ.1) CLOSE(LDAT) |
| 23331 | LINIT = .TRUE. |
| 23332 | ELSE |
| 23333 | SIGE = -ONE |
| 23334 | IF (LINIT.AND.(JP.LE.23).AND.(PTOT.GE.PLO) |
| 23335 | & .AND.(PTOT.LE.PHI) ) THEN |
| 23336 | IDX = IDSIG(JP) |
| 23337 | IF ( (IDX.GT.0).AND.((JT.EQ.1).OR.(JT.EQ.8)) ) THEN |
| 23338 | PLABX = LOG10(PTOT) |
| 23339 | IF (PLABX.LE.PLABLX) THEN |
| 23340 | I1 = 1 |
| 23341 | I2 = 1 |
| 23342 | ELSEIF (PLABX.GE.PLABHX) THEN |
| 23343 | I1 = NBINS+1 |
| 23344 | I2 = NBINS+1 |
| 23345 | ELSE |
| 23346 | I1 = INT((PLABX-PLABLX)/DPLAB)+1 |
| 23347 | I2 = I1+1 |
| 23348 | ENDIF |
| 23349 | PLAB1X = PLABLX+DBLE(I1-1)*DPLAB |
| 23350 | PLAB2X = PLABLX+DBLE(I2-1)*DPLAB |
| 23351 | PBIN = PLAB2X-PLAB1X |
| 23352 | IF (PBIN.GT.TINY10) THEN |
| 23353 | RATX = (PLABX-PLAB1X)/(PLAB2X-PLAB1X) |
| 23354 | ELSE |
| 23355 | RATX = ZERO |
| 23356 | ENDIF |
| 23357 | IF (JT.EQ.1) THEN |
| 23358 | SIG1 = SIGEP(IDX,I1) |
| 23359 | SIG2 = SIGEP(IDX,I2) |
| 23360 | ELSE |
| 23361 | SIG1 = SIGEN(IDX,I1) |
| 23362 | SIG2 = SIGEN(IDX,I2) |
| 23363 | ENDIF |
| 23364 | SIGE = SIG1+RATX*(SIG2-SIG1) |
| 23365 | ENDIF |
| 23366 | ENDIF |
| 23367 | ENDIF |
| 23368 | |
| 23369 | RETURN |
| 23370 | END |
| 23371 | * |
| 23372 | *===xstabl=============================================================* |
| 23373 | * |
| 23374 | CDECK ID>, DT_XSTABL |
| 23375 | SUBROUTINE DT_XSTABL(WHAT,IXSQEL,IRATIO) |
| 23376 | |
| 23377 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 23378 | SAVE |
| 23379 | |
| 23380 | PARAMETER ( LINP = 5 , |
| 23381 | & LOUT = 6 , |
| 23382 | & LDAT = 9 ) |
| 23383 | |
| 23384 | PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10, |
| 23385 | & OHALF=0.5D0,ONE=1.0D0,TWO=2.0D0) |
| 23386 | LOGICAL LLAB,LELOG,LQLOG |
| 23387 | |
| 23388 | * particle properties (BAMJET index convention) |
| 23389 | CHARACTER*8 ANAME |
| 23390 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 23391 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 23392 | * properties of interacting particles |
| 23393 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG |
| 23394 | |
| 23395 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 23396 | |
| 23397 | * Glauber formalism: cross sections |
| 23398 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, |
| 23399 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), |
| 23400 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), |
| 23401 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), |
| 23402 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), |
| 23403 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), |
| 23404 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), |
| 23405 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), |
| 23406 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), |
| 23407 | & BSLOPE,NEBINI,NQBINI |
| 23408 | * emulsion treatment |
| 23409 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), |
| 23410 | & NCOMPO,IEMUL |
| 23411 | |
| 23412 | DIMENSION WHAT(6) |
| 23413 | |
| 23414 | LLAB = (WHAT(1).GT.ZERO).OR.(WHAT(2).GT.ZERO) |
| 23415 | ELO = ABS(WHAT(1)) |
| 23416 | EHI = ABS(WHAT(2)) |
| 23417 | IF (ELO.GT.EHI) ELO = EHI |
| 23418 | LELOG = WHAT(3).LT.ZERO |
| 23419 | NEBINS = MAX(INT(ABS(WHAT(3))),1) |
| 23420 | DEBINS = (EHI-ELO)/DBLE(NEBINS) |
| 23421 | IF (LELOG) THEN |
| 23422 | AELO = LOG10(ELO) |
| 23423 | AEHI = LOG10(EHI) |
| 23424 | ADEBIN = (AEHI-AELO)/DBLE(NEBINS) |
| 23425 | ENDIF |
| 23426 | Q2LO = WHAT(4) |
| 23427 | Q2HI = WHAT(5) |
| 23428 | IF (Q2LO.GT.Q2HI) Q2LO = Q2HI |
| 23429 | LQLOG = WHAT(6).LT.ZERO |
| 23430 | NQBINS = MAX(INT(ABS(WHAT(6))),1) |
| 23431 | DQBINS = (Q2HI-Q2LO)/DBLE(NQBINS) |
| 23432 | IF (LQLOG) THEN |
| 23433 | AQ2LO = LOG10(Q2LO) |
| 23434 | AQ2HI = LOG10(Q2HI) |
| 23435 | ADQBIN = (AQ2HI-AQ2LO)/DBLE(NQBINS) |
| 23436 | ENDIF |
| 23437 | |
| 23438 | IF ( ELO.EQ. EHI) NEBINS = 0 |
| 23439 | IF (Q2LO.EQ.Q2HI) NQBINS = 0 |
| 23440 | |
| 23441 | WRITE(LOUT,1000) ELO,EHI,LLAB,IXSQEL,Q2LO,Q2HI,IJPROJ,IP,IT |
| 23442 | 1000 FORMAT(/,1X,'XSTABL: E_lo =',E10.3,' GeV E_hi =',E10.3, |
| 23443 | & ' GeV Lab = ',L1,' qel: ',I2,/,10X,'Q2_lo =',F10.5, |
| 23444 | & ' GeV^2 Q2_hi =',F10.5,' GeV^2',/,10X,'id_p = ',I2, |
| 23445 | & ' A_p = ',I3,' A_t = ',I3,/) |
| 23446 | |
| 23447 | C IF (IJPROJ.NE.7) THEN |
| 23448 | WRITE(LOUT,'(1X,A,/)')'(E,STOT,SELA,SQEP,SQET,SQE2,SINE,SPROD)' |
| 23449 | * normalize fractions of emulsion components |
| 23450 | IF (NCOMPO.GT.0) THEN |
| 23451 | SUMFRA = ZERO |
| 23452 | DO 10 I=1,NCOMPO |
| 23453 | SUMFRA = SUMFRA+EMUFRA(I) |
| 23454 | 10 CONTINUE |
| 23455 | IF (SUMFRA.GT.ZERO) THEN |
| 23456 | DO 11 I=1,NCOMPO |
| 23457 | EMUFRA(I) = EMUFRA(I)/SUMFRA |
| 23458 | 11 CONTINUE |
| 23459 | ENDIF |
| 23460 | ENDIF |
| 23461 | C ELSE |
| 23462 | C WRITE(LOUT,'(1X,A,/)') '(Q2,E,STOT,ETOT,SIN,EIN,STOT0)' |
| 23463 | C ENDIF |
| 23464 | DO 1 I=1,NEBINS+1 |
| 23465 | IF (LELOG) THEN |
| 23466 | E = 10**(AELO+DBLE(I-1)*ADEBIN) |
| 23467 | ELSE |
| 23468 | E = ELO+DBLE(I-1)*DEBINS |
| 23469 | ENDIF |
| 23470 | DO 2 J=1,NQBINS+1 |
| 23471 | IF (LQLOG) THEN |
| 23472 | Q2 = 10**(AQ2LO+DBLE(J-1)*ADQBIN) |
| 23473 | ELSE |
| 23474 | Q2 = Q2LO+DBLE(J-1)*DQBINS |
| 23475 | ENDIF |
| 23476 | c IF (IJPROJ.NE.7) THEN |
| 23477 | IF (LLAB) THEN |
| 23478 | PLAB = ZERO |
| 23479 | ECM = ZERO |
| 23480 | CALL DT_LTINI(IJPROJ,1,E,PPN0,ECM,0) |
| 23481 | ELSE |
| 23482 | ECM = E |
| 23483 | ENDIF |
| 23484 | XI = ZERO |
| 23485 | Q2I = ZERO |
| 23486 | IF (IJPROJ.EQ.7) Q2I = Q2 |
| 23487 | IF (NCOMPO.GT.0) THEN |
| 23488 | DO 20 IC=1,NCOMPO |
| 23489 | IIT = IEMUMA(IC) |
| 23490 | CALL DT_XSGLAU(IP,IIT,IJPROJ,XI,Q2I,ECM,1,1,-IC) |
| 23491 | 20 CONTINUE |
| 23492 | ELSE |
| 23493 | CALL DT_XSGLAU(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,-1) |
| 23494 | C CALL AMPLIT(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,1) |
| 23495 | ENDIF |
| 23496 | IF (NCOMPO.GT.0) THEN |
| 23497 | XTOT = ZERO |
| 23498 | ETOT = ZERO |
| 23499 | XELA = ZERO |
| 23500 | EELA = ZERO |
| 23501 | XQEP = ZERO |
| 23502 | EQEP = ZERO |
| 23503 | XQET = ZERO |
| 23504 | EQET = ZERO |
| 23505 | XQE2 = ZERO |
| 23506 | EQE2 = ZERO |
| 23507 | XPRO = ZERO |
| 23508 | EPRO = ZERO |
| 23509 | XPRO1= ZERO |
| 23510 | XDEL = ZERO |
| 23511 | EDEL = ZERO |
| 23512 | XDQE = ZERO |
| 23513 | EDQE = ZERO |
| 23514 | DO 21 IC=1,NCOMPO |
| 23515 | XTOT = XTOT+EMUFRA(IC)*XSTOT(1,1,IC) |
| 23516 | ETOT = ETOT+EMUFRA(IC)*XETOT(1,1,IC)**2 |
| 23517 | XELA = XELA+EMUFRA(IC)*XSELA(1,1,IC) |
| 23518 | EELA = EELA+EMUFRA(IC)*XEELA(1,1,IC)**2 |
| 23519 | XQEP = XQEP+EMUFRA(IC)*XSQEP(1,1,IC) |
| 23520 | EQEP = EQEP+EMUFRA(IC)*XEQEP(1,1,IC)**2 |
| 23521 | XQET = XQET+EMUFRA(IC)*XSQET(1,1,IC) |
| 23522 | EQET = EQET+EMUFRA(IC)*XEQET(1,1,IC)**2 |
| 23523 | XQE2 = XQE2+EMUFRA(IC)*XSQE2(1,1,IC) |
| 23524 | EQE2 = EQE2+EMUFRA(IC)*XEQE2(1,1,IC)**2 |
| 23525 | XPRO = XPRO+EMUFRA(IC)*XSPRO(1,1,IC) |
| 23526 | EPRO = EPRO+EMUFRA(IC)*XEPRO(1,1,IC)**2 |
| 23527 | XDEL = XDEL+EMUFRA(IC)*XSDEL(1,1,IC) |
| 23528 | EDEL = EDEL+EMUFRA(IC)*XEDEL(1,1,IC)**2 |
| 23529 | XDQE = XDQE+EMUFRA(IC)*XSDQE(1,1,IC) |
| 23530 | EDQE = EDQE+EMUFRA(IC)*XEDQE(1,1,IC)**2 |
| 23531 | YPRO = XSTOT(1,1,IC)-XSELA(1,1,IC) |
| 23532 | & -XSQEP(1,1,IC)-XSQET(1,1,IC) |
| 23533 | & -XSQE2(1,1,IC) |
| 23534 | XPRO1= XPRO1+EMUFRA(IC)*YPRO |
| 23535 | 21 CONTINUE |
| 23536 | ETOT = SQRT(ETOT) |
| 23537 | EELA = SQRT(EELA) |
| 23538 | EQEP = SQRT(EQEP) |
| 23539 | EQET = SQRT(EQET) |
| 23540 | EQE2 = SQRT(EQE2) |
| 23541 | EPRO = SQRT(EPRO) |
| 23542 | EDEL = SQRT(EDEL) |
| 23543 | EDQE = SQRT(EDQE) |
| 23544 | WRITE(LOUT,'(8E9.3)') |
| 23545 | & E,XTOT,XELA,XQEP,XQET,XQE2,XPRO,XPRO1 |
| 23546 | C WRITE(LOUT,'(4E9.3)') |
| 23547 | C & E,XDEL,XDQE,XDEL+XDQE |
| 23548 | ELSE |
| 23549 | WRITE(LOUT,'(11E10.3)') |
| 23550 | & E, |
| 23551 | & XSTOT(1,1,1),XSELA(1,1,1),XSQEP(1,1,1),XSQET(1,1,1), |
| 23552 | & XSQE2(1,1,1),XSPRO(1,1,1), |
| 23553 | & XSTOT(1,1,1)-XSELA(1,1,1)-XSQEP(1,1,1)-XSQET(1,1,1) |
| 23554 | & -XSQE2(1,1,1),XSDEL(1,1,1),XSDQE(1,1,1), |
| 23555 | & XSDEL(1,1,1)+XSDQE(1,1,1) |
| 23556 | C WRITE(LOUT,'(4E9.3)') E,XSDEL(1,1,1),XSDQE(1,1,1), |
| 23557 | C & XSDEL(1,1,1)+XSDQE(1,1,1) |
| 23558 | ENDIF |
| 23559 | c ELSE |
| 23560 | c IF (LLAB) THEN |
| 23561 | c IF (IT.GT.1) THEN |
| 23562 | c IF (IXSQEL.EQ.0) THEN |
| 23563 | cC CALL DT_SIGGA(IT, Q2, E,ZERO,ZERO, |
| 23564 | cC CALL DT_SIGGA(IT, E,Q2,ZERO,ZERO, |
| 23565 | c CALL DT_SIGGA(IT,ZERO,Q2,ZERO,E, |
| 23566 | c & STOT,ETOT,SIN,EIN,STOT0) |
| 23567 | c IF (IRATIO.EQ.1) THEN |
| 23568 | c CALL DT_SIGGP( Q2, E,ZERO,ZERO,STGP,SIGP,SDGP) |
| 23569 | cC CALL DT_SIGGP( E,Q2,ZERO,ZERO,STGP,SIGP,SDGP) |
| 23570 | cC CALL DT_SIGGP(ZERO,Q2,ZERO,E,STGP,SIGP,SDGP) |
| 23571 | c*!! save cross sections |
| 23572 | c STOTA = STOT |
| 23573 | c ETOTA = ETOT |
| 23574 | c STOTP = STGP |
| 23575 | c*!! |
| 23576 | c STOT = STOT/(DBLE(IT)*STGP) |
| 23577 | c SIN = SIN/(DBLE(IT)*SIGP) |
| 23578 | c STOT0 = STGP |
| 23579 | c ETOT = ZERO |
| 23580 | c EIN = ZERO |
| 23581 | c ENDIF |
| 23582 | c ELSE |
| 23583 | c WRITE(LOUT,*) |
| 23584 | c & ' XSTABL: qel. xs. not implemented for nuclei' |
| 23585 | c STOP |
| 23586 | c ENDIF |
| 23587 | c ELSE |
| 23588 | c ETOT = ZERO |
| 23589 | c EIN = ZERO |
| 23590 | c STOT0= ZERO |
| 23591 | c IF (IXSQEL.EQ.0) THEN |
| 23592 | c CALL DT_SIGGP(ZERO,Q2,ZERO,E,STOT,SIN,SDIR) |
| 23593 | c ELSE |
| 23594 | c SIN = ZERO |
| 23595 | c CALL DT_SIGVEL(ZERO,Q2,ZERO,E,IXSQEL,STOT,SIN,STOT0) |
| 23596 | c ENDIF |
| 23597 | c ENDIF |
| 23598 | c ELSE |
| 23599 | c IF (IT.GT.1) THEN |
| 23600 | c IF (IXSQEL.EQ.0) THEN |
| 23601 | c CALL DT_SIGGA(IT,ZERO,Q2,E,ZERO, |
| 23602 | c & STOT,ETOT,SIN,EIN,STOT0) |
| 23603 | c IF (IRATIO.EQ.1) THEN |
| 23604 | c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STGP,SIGP,SDGP) |
| 23605 | c*!! save cross sections |
| 23606 | c STOTA = STOT |
| 23607 | c ETOTA = ETOT |
| 23608 | c STOTP = STGP |
| 23609 | c*!! |
| 23610 | c STOT = STOT/(DBLE(IT)*STGP) |
| 23611 | c SIN = SIN/(DBLE(IT)*SIGP) |
| 23612 | c STOT0 = STGP |
| 23613 | c ETOT = ZERO |
| 23614 | c EIN = ZERO |
| 23615 | c ENDIF |
| 23616 | c ELSE |
| 23617 | c WRITE(LOUT,*) |
| 23618 | c & ' XSTABL: qel. xs. not implemented for nuclei' |
| 23619 | c STOP |
| 23620 | c ENDIF |
| 23621 | c ELSE |
| 23622 | c ETOT = ZERO |
| 23623 | c EIN = ZERO |
| 23624 | c STOT0= ZERO |
| 23625 | c IF (IXSQEL.EQ.0) THEN |
| 23626 | c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STOT,SIN,SDIR) |
| 23627 | c ELSE |
| 23628 | c SIN = ZERO |
| 23629 | c CALL DT_SIGVEL(ZERO,Q2,E,ZERO,IXSQEL,STOT,SIN,STOT0) |
| 23630 | c ENDIF |
| 23631 | c ENDIF |
| 23632 | c ENDIF |
| 23633 | cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,STOTA,ETOTA,STOTP,ZERO |
| 23634 | cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,SDIR |
| 23635 | cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,STOT0 |
| 23636 | c WRITE(LOUT,'(1X,6E10.3)')Q2,E,STOT,ETOT,SIN,EIN |
| 23637 | c ENDIF |
| 23638 | 2 CONTINUE |
| 23639 | 1 CONTINUE |
| 23640 | |
| 23641 | RETURN |
| 23642 | END |
| 23643 | * |
| 23644 | *===testxs=============================================================* |
| 23645 | * |
| 23646 | CDECK ID>, DT_TESTXS |
| 23647 | SUBROUTINE DT_TESTXS |
| 23648 | |
| 23649 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 23650 | SAVE |
| 23651 | |
| 23652 | DIMENSION XSTOT(26,2),XSELA(26,2) |
| 23653 | |
| 23654 | OPEN(10,FILE='testxs_ptot.out',STATUS='UNKNOWN') |
| 23655 | OPEN(11,FILE='testxs_pela.out',STATUS='UNKNOWN') |
| 23656 | OPEN(12,FILE='testxs_ntot.out',STATUS='UNKNOWN') |
| 23657 | OPEN(13,FILE='testxs_nela.out',STATUS='UNKNOWN') |
| 23658 | DUMECM = 0.0D0 |
| 23659 | PLABL = 0.01D0 |
| 23660 | PLABH = 10000.0D0 |
| 23661 | NBINS = 120 |
| 23662 | APLABL = LOG10(PLABL) |
| 23663 | APLABH = LOG10(PLABH) |
| 23664 | ADPLAB = (APLABH-APLABL)/DBLE(NBINS) |
| 23665 | DO 1 I=1,NBINS+1 |
| 23666 | ADP = APLABL+DBLE(I-1)*ADPLAB |
| 23667 | P = 10.0D0**ADP |
| 23668 | DO 2 J=1,26 |
| 23669 | CALL DT_XSHN(J,1,P,DUMECM,XSTOT(J,1),XSELA(J,1)) |
| 23670 | CALL DT_XSHN(J,8,P,DUMECM,XSTOT(J,2),XSELA(J,2)) |
| 23671 | 2 CONTINUE |
| 23672 | WRITE(10,1000) P,(XSTOT(K,1),K=1,26) |
| 23673 | WRITE(11,1000) P,(XSELA(K,1),K=1,26) |
| 23674 | WRITE(12,1000) P,(XSTOT(K,2),K=1,26) |
| 23675 | WRITE(13,1000) P,(XSELA(K,2),K=1,26) |
| 23676 | 1 CONTINUE |
| 23677 | 1000 FORMAT(F8.3,26F9.3) |
| 23678 | |
| 23679 | RETURN |
| 23680 | END |
| 23681 | ************************************************************************ |
| 23682 | * * |
| 23683 | * DTUNUC 2.0: library routines * |
| 23684 | * processed by S. Roesler, 6.5.95 * |
| 23685 | * * |
| 23686 | ************************************************************************ |
| 23687 | * |
| 23688 | * 1) Handling of parton momenta |
| 23689 | * SUBROUTINE MASHEL |
| 23690 | * SUBROUTINE DFERMI |
| 23691 | * |
| 23692 | * 2) Handling of parton flavors and particle indices |
| 23693 | * INTEGER FUNCTION IPDG2B |
| 23694 | * INTEGER FUNCTION IB2PDG |
| 23695 | * INTEGER FUNCTION IQUARK |
| 23696 | * INTEGER FUNCTION IBJQUA |
| 23697 | * INTEGER FUNCTION ICIHAD |
| 23698 | * INTEGER FUNCTION IPDGHA |
| 23699 | * INTEGER FUNCTION MCHAD |
| 23700 | * SUBROUTINE FLAHAD |
| 23701 | * |
| 23702 | * 3) Energy-momentum and quantum number conservation check routines |
| 23703 | * SUBROUTINE EMC1 |
| 23704 | * SUBROUTINE EMC2 |
| 23705 | * SUBROUTINE EVTEMC |
| 23706 | * SUBROUTINE EVTFLC |
| 23707 | * SUBROUTINE EVTCHG |
| 23708 | * |
| 23709 | * 4) Transformations |
| 23710 | * SUBROUTINE LTINI |
| 23711 | * SUBROUTINE LTRANS |
| 23712 | * SUBROUTINE LTNUC |
| 23713 | * SUBROUTINE DALTRA |
| 23714 | * SUBROUTINE DTRAFO |
| 23715 | * SUBROUTINE STTRAN |
| 23716 | * SUBROUTINE MYTRAN |
| 23717 | * SUBROUTINE LT2LAO |
| 23718 | * SUBROUTINE LT2LAB |
| 23719 | * |
| 23720 | * 5) Sampling from distributions |
| 23721 | * INTEGER FUNCTION NPOISS |
| 23722 | * DOUBLE PRECISION FUNCTION SAMPXB |
| 23723 | * DOUBLE PRECISION FUNCTION SAMPEX |
| 23724 | * DOUBLE PRECISION FUNCTION SAMSQX |
| 23725 | * DOUBLE PRECISION FUNCTION BETREJ |
| 23726 | * DOUBLE PRECISION FUNCTION DGAMRN |
| 23727 | * DOUBLE PRECISION FUNCTION DBETAR |
| 23728 | * SUBROUTINE RANNOR |
| 23729 | * SUBROUTINE DPOLI |
| 23730 | * SUBROUTINE DSFECF |
| 23731 | * SUBROUTINE RACO |
| 23732 | * |
| 23733 | * 6) Special functions, algorithms and service routines |
| 23734 | * DOUBLE PRECISION FUNCTION YLAMB |
| 23735 | * SUBROUTINE SORT |
| 23736 | * SUBROUTINE SORT1 |
| 23737 | * SUBROUTINE DT_XTIME |
| 23738 | * |
| 23739 | * 7) Random number generator package |
| 23740 | * DOUBLE PRECISION FUNCTION DT_RNDM |
| 23741 | * SUBROUTINE DT_RNDMST |
| 23742 | * SUBROUTINE DT_RNDMIN |
| 23743 | * SUBROUTINE DT_RNDMOU |
| 23744 | * SUBROUTINE DT_RNDMTE |
| 23745 | * |
| 23746 | ************************************************************************ |
| 23747 | * * |
| 23748 | * 1) Handling of parton momenta * |
| 23749 | * * |
| 23750 | ************************************************************************ |
| 23751 | * |
| 23752 | *===mashel=============================================================* |
| 23753 | * |
| 23754 | CDECK ID>, DT_MASHEL |
| 23755 | SUBROUTINE DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ) |
| 23756 | |
| 23757 | ************************************************************************ |
| 23758 | * * |
| 23759 | * rescaling of momenta of two partons to put both * |
| 23760 | * on mass shell * |
| 23761 | * * |
| 23762 | * input: PA1,PA2 input momentum vectors * |
| 23763 | * XM1,2 desired masses of particles afterwards * |
| 23764 | * P1,P2 changed momentum vectors * |
| 23765 | * * |
| 23766 | * The original version is written by R. Engel. * |
| 23767 | * This version dated 12.12.94 is modified by S. Roesler. * |
| 23768 | ************************************************************************ |
| 23769 | |
| 23770 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 23771 | SAVE |
| 23772 | |
| 23773 | PARAMETER ( LINP = 5 , |
| 23774 | & LOUT = 6 , |
| 23775 | & LDAT = 9 ) |
| 23776 | |
| 23777 | PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0) |
| 23778 | |
| 23779 | DIMENSION PA1(4),PA2(4),P1(4),P2(4) |
| 23780 | |
| 23781 | IREJ = 0 |
| 23782 | |
| 23783 | * Lorentz transformation into system CMS |
| 23784 | PX = PA1(1)+PA2(1) |
| 23785 | PY = PA1(2)+PA2(2) |
| 23786 | PZ = PA1(3)+PA2(3) |
| 23787 | EE = PA1(4)+PA2(4) |
| 23788 | XPTOT = SQRT(PX**2+PY**2+PZ**2) |
| 23789 | XMS = (EE-XPTOT)*(EE+XPTOT) |
| 23790 | IF(XMS.LT.(XM1+XM2)**2) THEN |
| 23791 | C WRITE(LOUT,'(3E12.4)')XMS,XM1,XM2 |
| 23792 | GOTO 9999 |
| 23793 | ENDIF |
| 23794 | XMS = SQRT(XMS) |
| 23795 | BGX = PX/XMS |
| 23796 | BGY = PY/XMS |
| 23797 | BGZ = PZ/XMS |
| 23798 | GAM = EE/XMS |
| 23799 | CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3), |
| 23800 | & PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4)) |
| 23801 | * rotation angles |
| 23802 | COD = P1(3)/PTOT1 |
| 23803 | C SID = SQRT((ONE-COD)*(ONE+COD)) |
| 23804 | PPT = SQRT(P1(1)**2+P1(2)**2) |
| 23805 | SID = PPT/PTOT1 |
| 23806 | COF = ONE |
| 23807 | SIF = ZERO |
| 23808 | IF(PTOT1*SID.GT.TINY10) THEN |
| 23809 | COF = P1(1)/(SID*PTOT1) |
| 23810 | SIF = P1(2)/(SID*PTOT1) |
| 23811 | ANORF = SQRT(COF*COF+SIF*SIF) |
| 23812 | COF = COF/ANORF |
| 23813 | SIF = SIF/ANORF |
| 23814 | ENDIF |
| 23815 | * new CM momentum and energies (for masses XM1,XM2) |
| 23816 | XM12 = SIGN(XM1**2,XM1) |
| 23817 | XM22 = SIGN(XM2**2,XM2) |
| 23818 | SS = XMS**2 |
| 23819 | PCMP = DT_YLAMB(SS,XM12,XM22)/(2.D0*XMS) |
| 23820 | EE1 = SQRT(XM12+PCMP**2) |
| 23821 | EE2 = XMS-EE1 |
| 23822 | * back rotation |
| 23823 | MODE = 1 |
| 23824 | CALL DT_MYTRAN(MODE,ZERO,ZERO,PCMP,COD,SID,COF,SIF,XX,YY,ZZ) |
| 23825 | CALL DT_DALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1, |
| 23826 | & PTOT1,P1(1),P1(2),P1(3),P1(4)) |
| 23827 | CALL DT_DALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2, |
| 23828 | & PTOT2,P2(1),P2(2),P2(3),P2(4)) |
| 23829 | * check consistency |
| 23830 | DEL = XMS*0.0001D0 |
| 23831 | IF (ABS(PX-P1(1)-P2(1)).GT.DEL) THEN |
| 23832 | IDEV = 1 |
| 23833 | ELSEIF (ABS(PY-P1(2)-P2(2)).GT.DEL) THEN |
| 23834 | IDEV = 2 |
| 23835 | ELSEIF (ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN |
| 23836 | IDEV = 3 |
| 23837 | ELSEIF (ABS(EE-P1(4)-P2(4)).GT.DEL) THEN |
| 23838 | IDEV = 4 |
| 23839 | ELSE |
| 23840 | IDEV = 0 |
| 23841 | ENDIF |
| 23842 | IF (IDEV.NE.0) THEN |
| 23843 | WRITE(LOUT,'(/1X,A,I3)') |
| 23844 | & 'MASHEL: inconsistent transformation',IDEV |
| 23845 | WRITE(LOUT,'(1X,A)') 'MASHEL: input momenta/masses:' |
| 23846 | WRITE(LOUT,'(1X,5E12.5)') (PA1(K),K=1,4),XM1 |
| 23847 | WRITE(LOUT,'(1X,5E12.5)') (PA2(K),K=1,4),XM2 |
| 23848 | WRITE(LOUT,'(1X,A)') 'MASHEL: output momenta:' |
| 23849 | WRITE(LOUT,'(5X,4E12.5)') (P1(K),K=1,4) |
| 23850 | WRITE(LOUT,'(5X,4E12.5)') (P2(K),K=1,4) |
| 23851 | ENDIF |
| 23852 | RETURN |
| 23853 | |
| 23854 | 9999 CONTINUE |
| 23855 | IREJ = 1 |
| 23856 | RETURN |
| 23857 | END |
| 23858 | * |
| 23859 | *===dfermi=============================================================* |
| 23860 | * |
| 23861 | CDECK ID>, DT_DFERMI |
| 23862 | SUBROUTINE DT_DFERMI(GPART) |
| 23863 | |
| 23864 | ************************************************************************ |
| 23865 | * Find largest of three random numbers. * |
| 23866 | ************************************************************************ |
| 23867 | |
| 23868 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 23869 | SAVE |
| 23870 | |
| 23871 | DIMENSION G(3) |
| 23872 | |
| 23873 | DO 10 I=1,3 |
| 23874 | G(I)=DT_RNDM(GPART) |
| 23875 | 10 CONTINUE |
| 23876 | IF (G(3).LT.G(2)) GOTO 40 |
| 23877 | IF (G(3).LT.G(1)) GOTO 30 |
| 23878 | GPART = G(3) |
| 23879 | 20 RETURN |
| 23880 | 30 GPART = G(1) |
| 23881 | GOTO 20 |
| 23882 | 40 IF (G(2).LT.G(1)) GOTO 30 |
| 23883 | GPART = G(2) |
| 23884 | GOTO 20 |
| 23885 | |
| 23886 | END |
| 23887 | |
| 23888 | ************************************************************************ |
| 23889 | * * |
| 23890 | * 2) Handling of parton flavors and particle indices * |
| 23891 | * * |
| 23892 | ************************************************************************ |
| 23893 | * |
| 23894 | *===ipdg2b=============================================================* |
| 23895 | * |
| 23896 | CDECK ID>, IDT_IPDG2B |
| 23897 | INTEGER FUNCTION IDT_IPDG2B(ID,NN,MODE) |
| 23898 | |
| 23899 | ************************************************************************ |
| 23900 | * * |
| 23901 | * conversion of quark numbering scheme * |
| 23902 | * * |
| 23903 | * input: PDG parton numbering * |
| 23904 | * for diquarks: NN number of the constituent quark * |
| 23905 | * (e.g. ID=2301,NN=1 -> ICONV2=1) * |
| 23906 | * * |
| 23907 | * output: BAMJET particle codes * |
| 23908 | * 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) * |
| 23909 | * 2 d 8 a-d -2 a-d * |
| 23910 | * 3 s 9 a-s -3 a-s * |
| 23911 | * 4 c 10 a-c -4 a-c * |
| 23912 | * * |
| 23913 | * This is a modified version of ICONV2 written by R. Engel. * |
| 23914 | * This version dated 13.12.94 is written by S. Roesler. * |
| 23915 | ************************************************************************ |
| 23916 | |
| 23917 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 23918 | SAVE |
| 23919 | |
| 23920 | PARAMETER ( LINP = 5 , |
| 23921 | & LOUT = 6 , |
| 23922 | & LDAT = 9 ) |
| 23923 | |
| 23924 | IDA = ABS(ID) |
| 23925 | * diquarks |
| 23926 | IF (IDA.GT.6) THEN |
| 23927 | KF = 3 |
| 23928 | IF (IDA.GE.1000) KF = 4 |
| 23929 | IDA = IDA/(10**(KF-NN)) |
| 23930 | IDA = MOD(IDA,10) |
| 23931 | ENDIF |
| 23932 | * exchange up and dn quarks |
| 23933 | IF (IDA.EQ.1) THEN |
| 23934 | IDA = 2 |
| 23935 | ELSEIF (IDA.EQ.2) THEN |
| 23936 | IDA = 1 |
| 23937 | ENDIF |
| 23938 | * antiquarks |
| 23939 | IF (ID.LT.0) THEN |
| 23940 | IF (MODE.EQ.1) THEN |
| 23941 | IDA = IDA+6 |
| 23942 | ELSE |
| 23943 | IDA = -IDA |
| 23944 | ENDIF |
| 23945 | ENDIF |
| 23946 | IDT_IPDG2B = IDA |
| 23947 | |
| 23948 | RETURN |
| 23949 | END |
| 23950 | * |
| 23951 | *===ib2pdg=============================================================* |
| 23952 | * |
| 23953 | CDECK ID>, IDT_IB2PDG |
| 23954 | INTEGER FUNCTION IDT_IB2PDG(ID1,ID2,MODE) |
| 23955 | |
| 23956 | ************************************************************************ |
| 23957 | * * |
| 23958 | * conversion of quark numbering scheme * |
| 23959 | * * |
| 23960 | * input: BAMJET particle codes * |
| 23961 | * 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) * |
| 23962 | * 2 d 8 a-d -2 a-d * |
| 23963 | * 3 s 9 a-s -3 a-s * |
| 23964 | * 4 c 10 a-c -4 a-c * |
| 23965 | * * |
| 23966 | * output: PDG parton numbering * |
| 23967 | * * |
| 23968 | * This version dated 13.12.94 is written by S. Roesler. * |
| 23969 | ************************************************************************ |
| 23970 | |
| 23971 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 23972 | SAVE |
| 23973 | |
| 23974 | PARAMETER ( LINP = 5 , |
| 23975 | & LOUT = 6 , |
| 23976 | & LDAT = 9 ) |
| 23977 | |
| 23978 | DIMENSION IHKKQ(-6:6),IHKKQQ(-3:3,-3:3) |
| 23979 | DATA IHKKQ/-6,-5,-4,-3,-1,-2,0,2,1,3,4,5,6/ |
| 23980 | DATA IHKKQQ/-3303,-3103,-3203,0,0,0,0, -3103,-1103,-2103,0,0,0,0, |
| 23981 | &-3203,-2103,-2203,0,0,0,0, 0,0,0,0,0,0,0, 0,0,0,0,2203,2103,3203, |
| 23982 | &0,0,0,0,2103,1103,3103, 0,0,0,0,3203,3103,3303/ |
| 23983 | |
| 23984 | IDA = ID1 |
| 23985 | IDB = ID2 |
| 23986 | IF (MODE.EQ.1) THEN |
| 23987 | IF (ID1.GT.6) IDA = -(ID1-6) |
| 23988 | IF (ID2.GT.6) IDB = -(ID2-6) |
| 23989 | ENDIF |
| 23990 | IF (ID2.EQ.0) THEN |
| 23991 | IDT_IB2PDG = IHKKQ(IDA) |
| 23992 | ELSE |
| 23993 | IDT_IB2PDG = IHKKQQ(IDA,IDB) |
| 23994 | ENDIF |
| 23995 | |
| 23996 | RETURN |
| 23997 | END |
| 23998 | * |
| 23999 | *===ipdgqu=============================================================* |
| 24000 | * |
| 24001 | CDECK ID>, IDT_IQUARK |
| 24002 | INTEGER FUNCTION IDT_IQUARK(K,IDBAMJ) |
| 24003 | |
| 24004 | ************************************************************************ |
| 24005 | * * |
| 24006 | * quark contents according to PDG conventions * |
| 24007 | * (random selection in case of quark mixing) * |
| 24008 | * * |
| 24009 | * input: IDBAMJ BAMJET particle code * |
| 24010 | * K 1..3 quark number * |
| 24011 | * * |
| 24012 | * output: 1 d (anti --> neg.) * |
| 24013 | * 2 u * |
| 24014 | * 3 s * |
| 24015 | * 4 c * |
| 24016 | * * |
| 24017 | * This version written by R. Engel. * |
| 24018 | ************************************************************************ |
| 24019 | |
| 24020 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 24021 | SAVE |
| 24022 | |
| 24023 | IQ = IDT_IBJQUA(K,IDBAMJ) |
| 24024 | * quark-antiquark |
| 24025 | IF (IQ.GT.6) THEN |
| 24026 | IQ = 6-IQ |
| 24027 | ENDIF |
| 24028 | * exchange of up and down |
| 24029 | IF (ABS(IQ).EQ.1) THEN |
| 24030 | IQ = SIGN(2,IQ) |
| 24031 | ELSEIF (ABS(IQ).EQ.2) THEN |
| 24032 | IQ = SIGN(1,IQ) |
| 24033 | ENDIF |
| 24034 | IDT_IQUARK = IQ |
| 24035 | |
| 24036 | RETURN |
| 24037 | END |
| 24038 | * |
| 24039 | *===ibamq==============================================================* |
| 24040 | * |
| 24041 | CDECK ID>, IDT_IBJQUA |
| 24042 | INTEGER FUNCTION IDT_IBJQUA(K,IDBAMJ) |
| 24043 | |
| 24044 | ************************************************************************ |
| 24045 | * * |
| 24046 | * quark contents according to BAMJET conventions * |
| 24047 | * (random selection in case of quark mixing) * |
| 24048 | * * |
| 24049 | * input: IDBAMJ BAMJET particle code * |
| 24050 | * K 1..3 quark number * |
| 24051 | * * |
| 24052 | * output: 1 u 7 u bar * |
| 24053 | * 2 d 8 d bar * |
| 24054 | * 3 s 9 s bar * |
| 24055 | * 4 c 10 c bar * |
| 24056 | * * |
| 24057 | * This version written by R. Engel. * |
| 24058 | ************************************************************************ |
| 24059 | |
| 24060 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 24061 | SAVE |
| 24062 | |
| 24063 | DIMENSION ITAB(3,210) |
| 24064 | DATA ((ITAB(I,K),I=1,3),K=1,30) / |
| 24065 | & 1, 1, 2, 7, 7, 8, 0, 0, 0, |
| 24066 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 24067 | & 0, 0, 0, 1, 2, 2, 7, 8, 8, |
| 24068 | *sr 10.1.94 |
| 24069 | C & 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 24070 | & 0, 0, 0, 0, 0, 0, 3, 8, 0, |
| 24071 | * |
| 24072 | & 1, 8, 0, 2, 7, 0, 1, 9, 0, |
| 24073 | *sr 10.1.94 |
| 24074 | C & 3, 7, 0, 0, 0, 0, 0, 0, 0, |
| 24075 | & 3, 7, 0, 3, 1, 2, 9, 7, 8, |
| 24076 | *sr 10.1.94 |
| 24077 | C & 0, 0, 0, 2, 2, 3, 1, 1, 3, |
| 24078 | & 2, 9, 0, 2, 2, 3, 1, 1, 3, |
| 24079 | * |
| 24080 | & 1, 2, 3, 201,202, 0, 2, 9, 0, |
| 24081 | & 3, 8, 0, 0, 0, 0, 0, 0, 0, |
| 24082 | & 0, 0, 0, 0, 0, 0, 0, 0, 0 / |
| 24083 | DATA ((ITAB(I,K),I=1,3),K=31,60) / |
| 24084 | & 3, 9, 0, 1, 8, 0, 203,204, 0, |
| 24085 | & 2, 7, 0, 0, 0, 0, 1, 9, 0, |
| 24086 | & 2, 9, 0, 3, 7, 0, 3, 8, 0, |
| 24087 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 24088 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 24089 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 24090 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 24091 | & 0, 0, 0, 1, 1, 1, 1, 1, 2, |
| 24092 | & 1, 2, 2, 2, 2, 2, 0, 0, 0, |
| 24093 | & 0, 0, 0, 0, 0, 0, 0, 0, 0 / |
| 24094 | DATA ((ITAB(I,K),I=1,3),K=61,90) / |
| 24095 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 24096 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 24097 | & 7, 7, 7, 7, 7, 8, 7, 8, 8, |
| 24098 | & 8, 8, 8, 0, 0, 0, 0, 0, 0, |
| 24099 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 24100 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 24101 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 24102 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 24103 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 24104 | & 0, 0, 0, 0, 0, 0, 0, 0, 0 / |
| 24105 | DATA ((ITAB(I,K),I=1,3),K=91,120) / |
| 24106 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 24107 | & 0, 0, 0, 0, 0, 0, 3, 9, 0, |
| 24108 | & 1, 3, 3, 2, 3, 3, 7, 7, 9, |
| 24109 | & 7, 8, 9, 8, 8, 9, 7, 9, 9, |
| 24110 | & 8, 9, 9, 1, 1, 3, 1, 2, 3, |
| 24111 | & 2, 2, 3, 1, 3, 3, 2, 3, 3, |
| 24112 | & 3, 3, 3, 7, 7, 9, 7, 8, 9, |
| 24113 | & 8, 8, 9, 7, 9, 9, 8, 9, 9, |
| 24114 | & 9, 9, 9, 4, 7, 0, 4, 8, 0, |
| 24115 | & 2, 10, 0, 1, 10, 0, 4, 9, 0 / |
| 24116 | DATA ((ITAB(I,K),I=1,3),K=121,150) / |
| 24117 | & 3, 10, 0, 4, 10, 0, 4, 7, 0, |
| 24118 | & 4, 8, 0, 2, 10, 0, 1, 10, 0, |
| 24119 | & 4, 9, 0, 3, 10, 0, 4, 10, 0, |
| 24120 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 24121 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 24122 | & 0, 0, 0, 1, 2, 4, 1, 3, 4, |
| 24123 | & 2, 3, 4, 1, 1, 4, 0, 0, 0, |
| 24124 | & 2, 2, 4, 0, 0, 0, 0, 0, 0, |
| 24125 | & 3, 3, 4, 1, 4, 4, 2, 4, 4, |
| 24126 | & 3, 4, 4, 7, 8, 10, 7, 9, 10 / |
| 24127 | DATA ((ITAB(I,K),I=1,3),K=151,180) / |
| 24128 | & 8, 9, 10, 7, 7, 10, 0, 0, 0, |
| 24129 | & 8, 8, 10, 0, 0, 0, 0, 0, 0, |
| 24130 | & 9, 9, 10, 7, 10, 10, 8, 10, 10, |
| 24131 | & 9, 10, 10, 1, 1, 4, 1, 2, 4, |
| 24132 | & 2, 2, 4, 1, 3, 4, 2, 3, 4, |
| 24133 | & 3, 3, 4, 1, 4, 4, 2, 4, 4, |
| 24134 | & 3, 4, 4, 4, 4, 4, 7, 7, 10, |
| 24135 | & 7, 8, 10, 8, 8, 10, 7, 9, 10, |
| 24136 | & 8, 9, 10, 9, 9, 10, 7, 10, 10, |
| 24137 | & 8, 10, 10, 9, 10, 10, 10, 10, 10 / |
| 24138 | DATA ((ITAB(I,K),I=1,3),K=181,210) / |
| 24139 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 24140 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 24141 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 24142 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 24143 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 24144 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 24145 | & 0, 0, 0, 0, 0, 0, 1, 7, 0, |
| 24146 | & 2, 8, 0, 1, 7, 0, 2, 8, 0, |
| 24147 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 24148 | & 0, 0, 0, 0, 0, 0, 0, 0, 0 / |
| 24149 | DATA IDOLD /0/ |
| 24150 | |
| 24151 | ONE = 1.0D0 |
| 24152 | IF (ITAB(1,IDBAMJ).LE.200) THEN |
| 24153 | ID = ITAB(K,IDBAMJ) |
| 24154 | ELSE |
| 24155 | IF(IDOLD.NE.IDBAMJ) THEN |
| 24156 | IT = AINT((ITAB(2,IDBAMJ)-ITAB(1,IDBAMJ)+0.999999D0)* |
| 24157 | & DT_RNDM(ONE)+ITAB(1,IDBAMJ)) |
| 24158 | ELSE |
| 24159 | IDOLD = 0 |
| 24160 | ENDIF |
| 24161 | ID = ITAB(K,IT) |
| 24162 | ENDIF |
| 24163 | IDOLD = IDBAMJ |
| 24164 | IDT_IBJQUA = ID |
| 24165 | |
| 24166 | RETURN |
| 24167 | END |
| 24168 | * |
| 24169 | *===icihad=============================================================* |
| 24170 | * |
| 24171 | CDECK ID>, IDT_ICIHAD |
| 24172 | INTEGER FUNCTION IDT_ICIHAD(MCIND) |
| 24173 | |
| 24174 | ************************************************************************ |
| 24175 | * Conversion of particle index PDG proposal --> BAMJET-index scheme * |
| 24176 | * This is a completely new version dated 25.10.95. * |
| 24177 | * Renamed to be not in conflict with the modified PHOJET-version * |
| 24178 | ************************************************************************ |
| 24179 | |
| 24180 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 24181 | SAVE |
| 24182 | |
| 24183 | * hadron index conversion (BAMJET <--> PDG) |
| 24184 | COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22), |
| 24185 | & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19), |
| 24186 | & IAMCIN(210) |
| 24187 | |
| 24188 | IDT_ICIHAD = 0 |
| 24189 | KPDG = ABS(MCIND) |
| 24190 | IF ((KPDG.EQ.0).OR.(KPDG.GT.70000)) RETURN |
| 24191 | IF (MCIND.LT.0) THEN |
| 24192 | JSIGN = 1 |
| 24193 | ELSE |
| 24194 | JSIGN = 2 |
| 24195 | ENDIF |
| 24196 | IF (KPDG.GE.10000) THEN |
| 24197 | DO 1 I=1,19 |
| 24198 | IDT_ICIHAD = IBAM5(JSIGN,I) |
| 24199 | IF (IPDG5(JSIGN,I).EQ.MCIND) GOTO 5 |
| 24200 | IDT_ICIHAD = 0 |
| 24201 | 1 CONTINUE |
| 24202 | ELSEIF (KPDG.GE.1000) THEN |
| 24203 | DO 2 I=1,29 |
| 24204 | IDT_ICIHAD = IBAM4(JSIGN,I) |
| 24205 | IF (IPDG4(JSIGN,I).EQ.MCIND) GOTO 5 |
| 24206 | IDT_ICIHAD = 0 |
| 24207 | 2 CONTINUE |
| 24208 | ELSEIF (KPDG.GE.100) THEN |
| 24209 | DO 3 I=1,22 |
| 24210 | IDT_ICIHAD = IBAM3(JSIGN,I) |
| 24211 | IF (IPDG3(JSIGN,I).EQ.MCIND) GOTO 5 |
| 24212 | IDT_ICIHAD = 0 |
| 24213 | 3 CONTINUE |
| 24214 | ELSEIF (KPDG.GE.10) THEN |
| 24215 | DO 4 I=1,7 |
| 24216 | IDT_ICIHAD = IBAM2(JSIGN,I) |
| 24217 | IF (IPDG2(JSIGN,I).EQ.MCIND) GOTO 5 |
| 24218 | IDT_ICIHAD = 0 |
| 24219 | 4 CONTINUE |
| 24220 | ENDIF |
| 24221 | 5 CONTINUE |
| 24222 | |
| 24223 | RETURN |
| 24224 | END |
| 24225 | * |
| 24226 | *===ipdgha=============================================================* |
| 24227 | * |
| 24228 | CDECK ID>, IDT_IPDGHA |
| 24229 | INTEGER FUNCTION IDT_IPDGHA(MCIND) |
| 24230 | |
| 24231 | ************************************************************************ |
| 24232 | * Conversion of particle index BAMJET-index scheme --> PDG proposal * |
| 24233 | * Adopted from the original by S. Roesler. This version dated 12.5.95 * |
| 24234 | * Renamed to be not in conflict with the modified PHOJET-version * |
| 24235 | ************************************************************************ |
| 24236 | |
| 24237 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 24238 | SAVE |
| 24239 | |
| 24240 | * hadron index conversion (BAMJET <--> PDG) |
| 24241 | COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22), |
| 24242 | & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19), |
| 24243 | & IAMCIN(210) |
| 24244 | |
| 24245 | IDT_IPDGHA = IAMCIN(MCIND) |
| 24246 | |
| 24247 | RETURN |
| 24248 | END |
| 24249 | * |
| 24250 | *===flahad=============================================================* |
| 24251 | * |
| 24252 | CDECK ID>, DT_FLAHAD |
| 24253 | SUBROUTINE DT_FLAHAD(ID,IF1,IF2,IF3) |
| 24254 | |
| 24255 | ************************************************************************ |
| 24256 | * sampling of FLAvor composition for HADrons/photons * |
| 24257 | * ID BAMJET-id of hadron * |
| 24258 | * IF1,2,3 flavor content * |
| 24259 | * (u,d,s: 1,2,3; au,ad,as: -1,-1,-3) * |
| 24260 | * Note: - u,d numbering as in BAMJET * |
| 24261 | * - ID .le. 30 !! * |
| 24262 | * This version dated 12.03.96 is written by S. Roesler * |
| 24263 | ************************************************************************ |
| 24264 | |
| 24265 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 24266 | SAVE |
| 24267 | |
| 24268 | * auxiliary common for reggeon exchange (DTUNUC 1.x) |
| 24269 | COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6), |
| 24270 | & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6), |
| 24271 | & IQTCHR(-6:6),MQUARK(3,39) |
| 24272 | |
| 24273 | DIMENSION JSEL(3,6) |
| 24274 | DATA JSEL/ 1,2,3, 2,3,1, 3,1,2, 1,3,2, 2,1,3, 3,2,1/ |
| 24275 | |
| 24276 | ONE = 1.0D0 |
| 24277 | IF (ID.EQ.7) THEN |
| 24278 | * photon (charge dependent flavour sampling) |
| 24279 | K = INT(DT_RNDM(ONE)*6.D0+1.D0) |
| 24280 | IF (K.LE.4) THEN |
| 24281 | IF1 = 2 |
| 24282 | IF2 = -2 |
| 24283 | ELSE IF(K.EQ.5) THEN |
| 24284 | IF1 = 1 |
| 24285 | IF2 = -1 |
| 24286 | ELSE |
| 24287 | IF1 = 3 |
| 24288 | IF2 = -3 |
| 24289 | ENDIF |
| 24290 | IF(DT_RNDM(ONE).LT.0.5D0) THEN |
| 24291 | K = IF1 |
| 24292 | IF1 = IF2 |
| 24293 | IF2 = K |
| 24294 | ENDIF |
| 24295 | IF3 = 0 |
| 24296 | ELSE |
| 24297 | * hadron |
| 24298 | IX = INT(1.0D0+5.99999D0*DT_RNDM(ONE)) |
| 24299 | IF1 = MQUARK(JSEL(1,IX),ID) |
| 24300 | IF2 = MQUARK(JSEL(2,IX),ID) |
| 24301 | IF3 = MQUARK(JSEL(3,IX),ID) |
| 24302 | IF ((IF1.EQ.0).AND.(IF3.NE.0)) THEN |
| 24303 | IF1 = IF3 |
| 24304 | IF3 = 0 |
| 24305 | ELSEIF ((IF2.EQ.0).AND.(IF3.NE.0)) THEN |
| 24306 | IF2 = IF3 |
| 24307 | IF3 = 0 |
| 24308 | ENDIF |
| 24309 | ENDIF |
| 24310 | |
| 24311 | RETURN |
| 24312 | END |
| 24313 | * |
| 24314 | *===mchad==============================================================* |
| 24315 | * |
| 24316 | CDECK ID>, IDT_MCHAD |
| 24317 | INTEGER FUNCTION IDT_MCHAD(ITDTU) |
| 24318 | |
| 24319 | ************************************************************************ |
| 24320 | * Conversion of particle index BAMJET-index scheme --> HADRIN index s. * |
| 24321 | * Adopted from the original by S. Roesler. This version dated 6.5.95 * |
| 24322 | ************************************************************************ |
| 24323 | |
| 24324 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 24325 | SAVE |
| 24326 | |
| 24327 | DIMENSION ITRANS(210) |
| 24328 | DATA ITRANS / 1, 2, -1, -1, -1, -1, -1, 8, 9, -1, -1, 24, 13, 14, |
| 24329 | &15, 16, 8, 9, 25, 8, 1, 8, 23, 24, 25, -1, -1, -1, -1, -1, 23, 13, |
| 24330 | &23, 14, 23, 15, 24, 16, 25, 15, 24, 16, 25, 15, 24, 16, 25, 1, 8, |
| 24331 | &8, 8, 1, 1, 1, 8, 8, 1, 1, 8, 8, 1, 8, 1, 8, 1, 8, 2, 2, 9, 9, 2, |
| 24332 | &2, 9, 9, 2, 9, 1, 13, 23, 14, 1, 1, 8, 8, 1, 1, 23, 14, 1, 8, 1, |
| 24333 | &8, 1, 8, 23, 23, 8, 8, 2, 9, 9, 9, 9, 1, 8, 8, 8, 8, 8, 2, 9, 9, |
| 24334 | &9, 9, 9, 85*- 1,7*-1,1,8,-1/ |
| 24335 | |
| 24336 | IDT_MCHAD = ITRANS(ITDTU) |
| 24337 | |
| 24338 | RETURN |
| 24339 | END |
| 24340 | |
| 24341 | ************************************************************************ |
| 24342 | * * |
| 24343 | * 3) Energy-momentum and quantum number conservation check routines * |
| 24344 | * * |
| 24345 | ************************************************************************ |
| 24346 | * |
| 24347 | *===emc1===============================================================* |
| 24348 | * |
| 24349 | CDECK ID>, DT_EMC1 |
| 24350 | SUBROUTINE DT_EMC1(PP1,PP2,PT1,PT2,MODE,IPOS,IREJ) |
| 24351 | |
| 24352 | ************************************************************************ |
| 24353 | * This version dated 15.12.94 is written by S. Roesler * |
| 24354 | ************************************************************************ |
| 24355 | |
| 24356 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 24357 | SAVE |
| 24358 | |
| 24359 | PARAMETER ( LINP = 5 , |
| 24360 | & LOUT = 6 , |
| 24361 | & LDAT = 9 ) |
| 24362 | |
| 24363 | PARAMETER (TINY10=1.0D-10) |
| 24364 | |
| 24365 | DIMENSION PP1(4),PP2(4),PT1(4),PT2(4) |
| 24366 | |
| 24367 | IREJ = 0 |
| 24368 | |
| 24369 | IF ((MODE.EQ.0).OR.(ABS(MODE).GT.3)) |
| 24370 | & WRITE(LOUT,'(1X,A,I6)')'EMC1: not supported MODE ',MODE |
| 24371 | |
| 24372 | IF ((MODE.GT.0).AND.(MODE.LT.3)) THEN |
| 24373 | IF (MODE.EQ.1) THEN |
| 24374 | CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),1,IDUM,IDUM) |
| 24375 | ELSEIF (MODE.EQ.2) THEN |
| 24376 | CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),2,IDUM,IDUM) |
| 24377 | ENDIF |
| 24378 | CALL DT_EVTEMC(PP2(1),PP2(2),PP2(3),PP2(4),2,IDUM,IDUM) |
| 24379 | CALL DT_EVTEMC(PT1(1),PT1(2),PT1(3),PT1(4),2,IDUM,IDUM) |
| 24380 | CALL DT_EVTEMC(PT2(1),PT2(2),PT2(3),PT2(4),2,IDUM,IDUM) |
| 24381 | ELSEIF (MODE.LT.0) THEN |
| 24382 | IF (MODE.EQ.-1) THEN |
| 24383 | CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),1,IDUM,IDUM) |
| 24384 | ELSEIF (MODE.EQ.-2) THEN |
| 24385 | CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),2,IDUM,IDUM) |
| 24386 | ENDIF |
| 24387 | CALL DT_EVTEMC(-PP2(1),-PP2(2),-PP2(3),-PP2(4),2,IDUM,IDUM) |
| 24388 | CALL DT_EVTEMC(-PT1(1),-PT1(2),-PT1(3),-PT1(4),2,IDUM,IDUM) |
| 24389 | CALL DT_EVTEMC(-PT2(1),-PT2(2),-PT2(3),-PT2(4),2,IDUM,IDUM) |
| 24390 | ENDIF |
| 24391 | |
| 24392 | IF (ABS(MODE).EQ.3) THEN |
| 24393 | CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,IPOS,IREJ1) |
| 24394 | IF (IREJ1.NE.0) GOTO 9999 |
| 24395 | ENDIF |
| 24396 | RETURN |
| 24397 | |
| 24398 | 9999 CONTINUE |
| 24399 | IREJ = 1 |
| 24400 | RETURN |
| 24401 | END |
| 24402 | * |
| 24403 | *===emc2===============================================================* |
| 24404 | * |
| 24405 | CDECK ID>, DT_EMC2 |
| 24406 | SUBROUTINE DT_EMC2(IP1,IP2,IP3,IP4,IP5,MP,IN1,IN2,IN3,IN4,IN5,MN, |
| 24407 | & MODE,IPOS,IREJ) |
| 24408 | |
| 24409 | ************************************************************************ |
| 24410 | * MODE = 1 energy-momentum cons. check * |
| 24411 | * = 2 flavor-cons. check * |
| 24412 | * = 3 energy-momentum & flavor cons. check * |
| 24413 | * = 4 energy-momentum & charge cons. check * |
| 24414 | * = 5 energy-momentum & flavor & charge cons. check * |
| 24415 | * This version dated 16.01.95 is written by S. Roesler * |
| 24416 | ************************************************************************ |
| 24417 | |
| 24418 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 24419 | SAVE |
| 24420 | |
| 24421 | PARAMETER ( LINP = 5 , |
| 24422 | & LOUT = 6 , |
| 24423 | & LDAT = 9 ) |
| 24424 | |
| 24425 | PARAMETER (TINY10=1.0D-10,ZERO=0.0D0) |
| 24426 | |
| 24427 | * event history |
| 24428 | |
| 24429 | PARAMETER (NMXHKK=200000) |
| 24430 | |
| 24431 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 24432 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 24433 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 24434 | * extended event history |
| 24435 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 24436 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 24437 | & IHIST(2,NMXHKK) |
| 24438 | |
| 24439 | IREJ = 0 |
| 24440 | IREJ1 = 0 |
| 24441 | IREJ2 = 0 |
| 24442 | IREJ3 = 0 |
| 24443 | |
| 24444 | IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5)) |
| 24445 | & CALL DT_EVTEMC(ZERO,ZERO,ZERO,ZERO,1,IDUM,IDUM) |
| 24446 | IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5)) |
| 24447 | & CALL DT_EVTFLC(0,IDUM,1,IDUM,IDUM) |
| 24448 | IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,1,IDUM,IDUM) |
| 24449 | DO 1 I=1,NHKK |
| 24450 | IF ((ISTHKK(I).EQ.IP1).OR.(ISTHKK(I).EQ.IP2).OR. |
| 24451 | & (ISTHKK(I).EQ.IP3).OR.(ISTHKK(I).EQ.IP4).OR. |
| 24452 | & (ISTHKK(I).EQ.IP5)) THEN |
| 24453 | IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4) |
| 24454 | & .OR.(MODE.EQ.5)) |
| 24455 | & CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I), |
| 24456 | & 2,IDUM,IDUM) |
| 24457 | IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5)) |
| 24458 | & CALL DT_EVTFLC(IDHKK(I),MP,2,IDUM,IDUM) |
| 24459 | IF ((MODE.EQ.4).OR.(MODE.EQ.5)) |
| 24460 | & CALL DT_EVTCHG(IDHKK(I),2,IDUM,IDUM) |
| 24461 | ENDIF |
| 24462 | IF ((ISTHKK(I).EQ.IN1).OR.(ISTHKK(I).EQ.IN2).OR. |
| 24463 | & (ISTHKK(I).EQ.IN3).OR.(ISTHKK(I).EQ.IN4).OR. |
| 24464 | & (ISTHKK(I).EQ.IN5)) THEN |
| 24465 | IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4) |
| 24466 | & .OR.(MODE.EQ.5)) |
| 24467 | & CALL DT_EVTEMC(-PHKK(1,I),-PHKK(2,I),-PHKK(3,I),-PHKK(4,I), |
| 24468 | & 2,IDUM,IDUM) |
| 24469 | IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5)) |
| 24470 | & CALL DT_EVTFLC(IDHKK(I),MN,-2,IDUM,IDUM) |
| 24471 | IF ((MODE.EQ.4).OR.(MODE.EQ.5)) |
| 24472 | & CALL DT_EVTCHG(IDHKK(I),-2,IDUM,IDUM) |
| 24473 | ENDIF |
| 24474 | 1 CONTINUE |
| 24475 | IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5)) |
| 24476 | & CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,IPOS,IREJ1) |
| 24477 | IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5)) |
| 24478 | & CALL DT_EVTFLC(0,IDUM,3,IPOS,IREJ2) |
| 24479 | IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,3,IPOS,IREJ3) |
| 24480 | IF ((IREJ1.NE.0).OR.(IREJ2.NE.0).OR.(IREJ3.NE.0)) GOTO 9999 |
| 24481 | |
| 24482 | RETURN |
| 24483 | |
| 24484 | 9999 CONTINUE |
| 24485 | IREJ = 1 |
| 24486 | RETURN |
| 24487 | END |
| 24488 | * |
| 24489 | *===evtemc=============================================================* |
| 24490 | * |
| 24491 | CDECK ID>, DT_EVTEMC |
| 24492 | SUBROUTINE DT_EVTEMC(PXIO,PYIO,PZIO,EIO,IMODE,IPOS,IREJ) |
| 24493 | |
| 24494 | ************************************************************************ |
| 24495 | * This version dated 13.12.94 is written by S. Roesler * |
| 24496 | ************************************************************************ |
| 24497 | |
| 24498 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 24499 | SAVE |
| 24500 | |
| 24501 | PARAMETER ( LINP = 5 , |
| 24502 | & LOUT = 6 , |
| 24503 | & LDAT = 9 ) |
| 24504 | |
| 24505 | PARAMETER (TINY1=1.0D-1,TINY2=1.0D-2,TINY4=1.0D-4,TINY10=1.0D-10, |
| 24506 | & ZERO=0.0D0) |
| 24507 | |
| 24508 | * event history |
| 24509 | |
| 24510 | PARAMETER (NMXHKK=200000) |
| 24511 | |
| 24512 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 24513 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 24514 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 24515 | * flags for input different options |
| 24516 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 24517 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 24518 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 24519 | |
| 24520 | IREJ = 0 |
| 24521 | |
| 24522 | MODE = IMODE |
| 24523 | CHKLEV = TINY10 |
| 24524 | IF (MODE.EQ.4) THEN |
| 24525 | CHKLEV = TINY2 |
| 24526 | MODE = 3 |
| 24527 | ELSEIF (MODE.EQ.5) THEN |
| 24528 | CHKLEV = TINY1 |
| 24529 | MODE = 3 |
| 24530 | ELSEIF (MODE.EQ.-1) THEN |
| 24531 | CHKLEV = EIO |
| 24532 | MODE = 3 |
| 24533 | ENDIF |
| 24534 | |
| 24535 | IF (ABS(MODE).EQ.3) THEN |
| 24536 | PXDEV = PX |
| 24537 | PYDEV = PY |
| 24538 | PZDEV = PZ |
| 24539 | EDEV = E |
| 24540 | IF ((IFRAG(1).EQ.2).AND.(CHKLEV.LT.TINY4)) CHKLEV = TINY4 |
| 24541 | IF ((ABS(PXDEV).GT.CHKLEV).OR.(ABS(PYDEV).GT.CHKLEV).OR. |
| 24542 | & (ABS(PZDEV).GT.CHKLEV).OR.(ABS(EDEV).GT.CHKLEV)) THEN |
| 24543 | IF (IOULEV(2).GT.0) WRITE(LOUT,'(1X,A,I4,A,I8,A,/,4G10.3)') |
| 24544 | & 'EVTEMC: energy-momentum cons. failure at pos. ',IPOS, |
| 24545 | & ' event ',NEVHKK, |
| 24546 | & ' ! ',PXDEV,PYDEV,PZDEV,EDEV |
| 24547 | PX = 0.0D0 |
| 24548 | PY = 0.0D0 |
| 24549 | PZ = 0.0D0 |
| 24550 | E = 0.0D0 |
| 24551 | GOTO 9999 |
| 24552 | ENDIF |
| 24553 | PX = 0.0D0 |
| 24554 | PY = 0.0D0 |
| 24555 | PZ = 0.0D0 |
| 24556 | E = 0.0D0 |
| 24557 | RETURN |
| 24558 | ENDIF |
| 24559 | |
| 24560 | IF (MODE.EQ.1) THEN |
| 24561 | PX = 0.0D0 |
| 24562 | PY = 0.0D0 |
| 24563 | PZ = 0.0D0 |
| 24564 | E = 0.0D0 |
| 24565 | ENDIF |
| 24566 | |
| 24567 | PX = PX+PXIO |
| 24568 | PY = PY+PYIO |
| 24569 | PZ = PZ+PZIO |
| 24570 | E = E+EIO |
| 24571 | |
| 24572 | RETURN |
| 24573 | |
| 24574 | 9999 CONTINUE |
| 24575 | IREJ = 1 |
| 24576 | RETURN |
| 24577 | END |
| 24578 | * |
| 24579 | *===evtflc=============================================================* |
| 24580 | * |
| 24581 | CDECK ID>, DT_EVTFLC |
| 24582 | SUBROUTINE DT_EVTFLC(ID,ID1,MODE,IPOS,IREJ) |
| 24583 | |
| 24584 | ************************************************************************ |
| 24585 | * Flavor conservation check. * |
| 24586 | * ID identity of particle * |
| 24587 | * ID1 = 1 ID for q,aq,qq,aqaq in PDG-numbering scheme * |
| 24588 | * = 2 ID for particle/resonance in BAMJET numbering scheme * |
| 24589 | * = 3 ID for particle/resonance in PDG numbering scheme * |
| 24590 | * MODE = 1 initialization and add ID * |
| 24591 | * =-1 initialization and subtract ID * |
| 24592 | * = 2 add ID * |
| 24593 | * =-2 subtract ID * |
| 24594 | * = 3 check flavor cons. * |
| 24595 | * IPOS flag to give position of call of EVTFLC to output * |
| 24596 | * unit in case of violation * |
| 24597 | * This version dated 10.01.95 is written by S. Roesler * |
| 24598 | ************************************************************************ |
| 24599 | |
| 24600 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 24601 | SAVE |
| 24602 | |
| 24603 | PARAMETER ( LINP = 5 , |
| 24604 | & LOUT = 6 , |
| 24605 | & LDAT = 9 ) |
| 24606 | |
| 24607 | PARAMETER (TINY10=1.0D-10) |
| 24608 | |
| 24609 | IREJ = 0 |
| 24610 | |
| 24611 | IF (MODE.EQ.3) THEN |
| 24612 | IF (IFL.NE.0) THEN |
| 24613 | WRITE(LOUT,'(1X,A,I3,A,I3)') |
| 24614 | & 'EVTFLC: flavor-conservation failure at pos. ',IPOS, |
| 24615 | & ' ! IFL = ',IFL |
| 24616 | IFL = 0 |
| 24617 | GOTO 9999 |
| 24618 | ENDIF |
| 24619 | IFL = 0 |
| 24620 | RETURN |
| 24621 | ENDIF |
| 24622 | |
| 24623 | IF (MODE.EQ.1) IFL = 0 |
| 24624 | IF (ID.EQ.0) RETURN |
| 24625 | |
| 24626 | IF (ID1.EQ.1) THEN |
| 24627 | IDD = ABS(ID) |
| 24628 | NQ = 1 |
| 24629 | IF ((IDD.GE.100).AND.(IDD.LT.1000)) NQ = 2 |
| 24630 | IF (IDD.GE.1000) NQ = 3 |
| 24631 | DO 1 I=1,NQ |
| 24632 | IFBAM = IDT_IPDG2B(ID,I,2) |
| 24633 | IF (ABS(IFBAM).EQ.1) THEN |
| 24634 | IFBAM = SIGN(2,IFBAM) |
| 24635 | ELSEIF (ABS(IFBAM).EQ.2) THEN |
| 24636 | IFBAM = SIGN(1,IFBAM) |
| 24637 | ENDIF |
| 24638 | IF (MODE.GT.0) THEN |
| 24639 | IFL = IFL+IFBAM |
| 24640 | ELSE |
| 24641 | IFL = IFL-IFBAM |
| 24642 | ENDIF |
| 24643 | 1 CONTINUE |
| 24644 | RETURN |
| 24645 | ENDIF |
| 24646 | |
| 24647 | IDD = ID |
| 24648 | IF (ID1.EQ.3) IDD = IDT_ICIHAD(ID) |
| 24649 | IF ((ID1.EQ.2).OR.(ID1.EQ.3)) THEN |
| 24650 | DO 2 I=1,3 |
| 24651 | IF (MODE.GT.0) THEN |
| 24652 | IFL = IFL+IDT_IQUARK(I,IDD) |
| 24653 | ELSE |
| 24654 | IFL = IFL-IDT_IQUARK(I,IDD) |
| 24655 | ENDIF |
| 24656 | 2 CONTINUE |
| 24657 | ENDIF |
| 24658 | RETURN |
| 24659 | |
| 24660 | 9999 CONTINUE |
| 24661 | IREJ = 1 |
| 24662 | RETURN |
| 24663 | END |
| 24664 | * |
| 24665 | *===evtchg=============================================================* |
| 24666 | * |
| 24667 | CDECK ID>, DT_EVTCHG |
| 24668 | SUBROUTINE DT_EVTCHG(ID,MODE,IPOS,IREJ) |
| 24669 | |
| 24670 | ************************************************************************ |
| 24671 | * Charge conservation check. * |
| 24672 | * ID identity of particle (PDG-numbering scheme) * |
| 24673 | * MODE = 1 initialization * |
| 24674 | * =-2 subtract ID-charge * |
| 24675 | * = 2 add ID-charge * |
| 24676 | * = 3 check charge cons. * |
| 24677 | * IPOS flag to give position of call of EVTCHG to output * |
| 24678 | * unit in case of violation * |
| 24679 | * This version dated 10.01.95 is written by S. Roesler * |
| 24680 | * Last change: s.r. 21.01.01 * |
| 24681 | ************************************************************************ |
| 24682 | |
| 24683 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 24684 | SAVE |
| 24685 | |
| 24686 | PARAMETER ( LINP = 5 , |
| 24687 | & LOUT = 6 , |
| 24688 | & LDAT = 9 ) |
| 24689 | |
| 24690 | * event history |
| 24691 | |
| 24692 | PARAMETER (NMXHKK=200000) |
| 24693 | |
| 24694 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 24695 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 24696 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 24697 | * particle properties (BAMJET index convention) |
| 24698 | CHARACTER*8 ANAME |
| 24699 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 24700 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 24701 | |
| 24702 | IREJ = 0 |
| 24703 | |
| 24704 | IF (MODE.EQ.1) THEN |
| 24705 | ICH = 0 |
| 24706 | IBAR = 0 |
| 24707 | RETURN |
| 24708 | ENDIF |
| 24709 | |
| 24710 | IF (MODE.EQ.3) THEN |
| 24711 | IF ((ICH.NE.0).OR.(IBAR.NE.0)) THEN |
| 24712 | WRITE(LOUT,'(1X,A,I3,A,2I3,A,I8)') |
| 24713 | & 'EVTCHG: charge/baryo.-cons. failure at pos. ',IPOS, |
| 24714 | & '! ICH/IBAR= ',ICH,IBAR,' event ',NEVHKK |
| 24715 | ICH = 0 |
| 24716 | IBAR = 0 |
| 24717 | GOTO 9999 |
| 24718 | ENDIF |
| 24719 | ICH = 0 |
| 24720 | IBAR = 0 |
| 24721 | RETURN |
| 24722 | ENDIF |
| 24723 | |
| 24724 | IF (ID.EQ.0) RETURN |
| 24725 | |
| 24726 | IDD = IDT_ICIHAD(ID) |
| 24727 | * modification 21.1.01: use intrinsic phojet-functions to determine charge |
| 24728 | * and baryon number |
| 24729 | C IF (IDD.GT.0) THEN |
| 24730 | C IF (MODE.EQ.2) THEN |
| 24731 | C ICH = ICH+IICH(IDD) |
| 24732 | C IBAR = IBAR+IIBAR(IDD) |
| 24733 | C ELSEIF (MODE.EQ.-2) THEN |
| 24734 | C ICH = ICH-IICH(IDD) |
| 24735 | C IBAR = IBAR-IIBAR(IDD) |
| 24736 | C ENDIF |
| 24737 | C ELSE |
| 24738 | C WRITE(LOUT,'(1X,A,3I6)') 'EVTCHG: (IDD = 0 !), IDD,ID=',IDD,ID |
| 24739 | C CALL DT_EVTOUT(4) |
| 24740 | C STOP |
| 24741 | C ENDIF |
| 24742 | IF (MODE.EQ.2) THEN |
| 24743 | ICH = ICH+IPHO_CHR3(ID,1)/3 |
| 24744 | IBAR = IBAR+IPHO_BAR3(ID,1)/3 |
| 24745 | ELSEIF (MODE.EQ.-2) THEN |
| 24746 | ICH = ICH-IPHO_CHR3(ID,1)/3 |
| 24747 | IBAR = IBAR-IPHO_BAR3(ID,1)/3 |
| 24748 | ENDIF |
| 24749 | |
| 24750 | RETURN |
| 24751 | |
| 24752 | 9999 CONTINUE |
| 24753 | IREJ = 1 |
| 24754 | RETURN |
| 24755 | END |
| 24756 | |
| 24757 | ************************************************************************ |
| 24758 | * * |
| 24759 | * 4) Transformations * |
| 24760 | * * |
| 24761 | ************************************************************************ |
| 24762 | * |
| 24763 | *===ltini==============================================================* |
| 24764 | * |
| 24765 | CDECK ID>, DT_LTINI |
| 24766 | SUBROUTINE DT_LTINI(IDPR,IDTA,EPN0,PPN0,ECM0,MODE) |
| 24767 | |
| 24768 | ************************************************************************ |
| 24769 | * Initializations of Lorentz-transformations, calculation of Lorentz- * |
| 24770 | * parameters. * |
| 24771 | * This version dated 13.11.95 is written by S. Roesler. * |
| 24772 | ************************************************************************ |
| 24773 | |
| 24774 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 24775 | SAVE |
| 24776 | |
| 24777 | PARAMETER ( LINP = 5 , |
| 24778 | & LOUT = 6 , |
| 24779 | & LDAT = 9 ) |
| 24780 | |
| 24781 | PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3, |
| 24782 | & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0) |
| 24783 | |
| 24784 | * Lorentz-parameters of the current interaction |
| 24785 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, |
| 24786 | & UMO,PPCM,EPROJ,PPROJ |
| 24787 | * properties of photon/lepton projectiles |
| 24788 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC |
| 24789 | * particle properties (BAMJET index convention) |
| 24790 | CHARACTER*8 ANAME |
| 24791 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 24792 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 24793 | * nucleon-nucleon event-generator |
| 24794 | CHARACTER*8 CMODEL |
| 24795 | LOGICAL LPHOIN |
| 24796 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN |
| 24797 | |
| 24798 | Q2 = VIRT |
| 24799 | IDP = IDPR |
| 24800 | IF (MCGENE.NE.3) THEN |
| 24801 | * lepton-projectiles and PHOJET: initialize real photon instead |
| 24802 | IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR. |
| 24803 | & (IDPR.EQ.10).OR.(IDPR.EQ.11).OR. |
| 24804 | & (IDPR.EQ. 5).OR.(IDPR.EQ. 6)) THEN |
| 24805 | IDP = 7 |
| 24806 | Q2 = ZERO |
| 24807 | ENDIF |
| 24808 | ENDIF |
| 24809 | IDT = IDTA |
| 24810 | EPN = EPN0 |
| 24811 | PPN = PPN0 |
| 24812 | ECM = ECM0 |
| 24813 | AMP = AAM(IDP)-SQRT(ABS(Q2)) |
| 24814 | AMT = AAM(IDT) |
| 24815 | AMP2 = SIGN(AMP**2,AMP) |
| 24816 | AMT2 = AMT**2 |
| 24817 | IF (ECM0.GT.ZERO) THEN |
| 24818 | EPN = (ECM**2-AMP2-AMT2)/(TWO*AMT) |
| 24819 | IF (AMP2.GT.ZERO) THEN |
| 24820 | PPN = SQRT((EPN+AMP)*(EPN-AMP)) |
| 24821 | ELSE |
| 24822 | PPN = SQRT(EPN**2-AMP2) |
| 24823 | ENDIF |
| 24824 | ELSE |
| 24825 | IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN |
| 24826 | IF (IDP.EQ.7) EPN = ABS(EPN) |
| 24827 | IF (EPN.LT.ZERO) EPN = ABS(EPN)+AMP |
| 24828 | IF (AMP2.GT.ZERO) THEN |
| 24829 | PPN = SQRT((EPN+AMP)*(EPN-AMP)) |
| 24830 | ELSE |
| 24831 | PPN = SQRT(EPN**2-AMP2) |
| 24832 | ENDIF |
| 24833 | ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN |
| 24834 | IF (AMP2.GT.ZERO) THEN |
| 24835 | EPN = PPN*SQRT(ONE+(AMP/PPN)**2) |
| 24836 | ELSE |
| 24837 | EPN = SQRT(PPN**2+AMP2) |
| 24838 | ENDIF |
| 24839 | ENDIF |
| 24840 | ECM = SQRT(AMP2+AMT2+TWO*AMT*EPN) |
| 24841 | ENDIF |
| 24842 | UMO = ECM |
| 24843 | EPROJ = EPN |
| 24844 | PPROJ = PPN |
| 24845 | IF (AMP2.GT.ZERO) THEN |
| 24846 | ETARG = (ECM**2-AMP2-AMT2)/(TWO*AMP) |
| 24847 | PTARG = -SQRT((ETARG+AMT)*(ETARG-AMT)) |
| 24848 | ELSE |
| 24849 | ETARG = TINY10 |
| 24850 | PTARG = TINY10 |
| 24851 | ENDIF |
| 24852 | * photon-projectiles (get momentum in cm-frame for virtuality Q^2) |
| 24853 | IF (IDP.EQ.7) THEN |
| 24854 | PGAMM(1) = ZERO |
| 24855 | PGAMM(2) = ZERO |
| 24856 | AMGAM = AMP |
| 24857 | AMGAM2 = AMP2 |
| 24858 | IF (ECM0.GT.ZERO) THEN |
| 24859 | S = ECM0**2 |
| 24860 | ELSE |
| 24861 | IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN |
| 24862 | S = AMGAM2+AMT2+TWO*AMT*ABS(EPN0) |
| 24863 | ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN |
| 24864 | S = AMGAM2+AMT2+TWO*AMT*SQRT(PPN0**2+AMGAM2) |
| 24865 | ENDIF |
| 24866 | ENDIF |
| 24867 | PGAMM(3) = SQRT( (S**2-TWO*AMGAM2*S-TWO*AMT2*S-TWO*AMGAM2*AMT2 |
| 24868 | & +AMGAM2**2+AMT2**2)/(4.0D0*S) ) |
| 24869 | PGAMM(4) = SQRT(AMGAM2+PGAMM(3)**2) |
| 24870 | IF (MODE.EQ.1) THEN |
| 24871 | PNUCL(1) = ZERO |
| 24872 | PNUCL(2) = ZERO |
| 24873 | PNUCL(3) = -PGAMM(3) |
| 24874 | PNUCL(4) = SQRT(S)-PGAMM(4) |
| 24875 | ENDIF |
| 24876 | ENDIF |
| 24877 | IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR. |
| 24878 | & (IDPR.EQ.10).OR.(IDPR.EQ.11)) THEN |
| 24879 | PLEPT0(1) = ZERO |
| 24880 | PLEPT0(2) = ZERO |
| 24881 | * neglect lepton masses |
| 24882 | C AMLPT2 = AAM(IDPR)**2 |
| 24883 | AMLPT2 = ZERO |
| 24884 | * |
| 24885 | IF (ECM0.GT.ZERO) THEN |
| 24886 | S = ECM0**2 |
| 24887 | ELSE |
| 24888 | IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN |
| 24889 | S = AMLPT2+AMT2+TWO*AMT*ABS(EPN0) |
| 24890 | ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN |
| 24891 | S = AMLPT2+AMT2+TWO*AMT*SQRT(PPN0**2+AMLPT2) |
| 24892 | ENDIF |
| 24893 | ENDIF |
| 24894 | PLEPT0(3) = SQRT( (S**2-TWO*AMLPT2*S-TWO*AMT2*S-TWO*AMLPT2*AMT2 |
| 24895 | & +AMLPT2**2+AMT2**2)/(4.0D0*S) ) |
| 24896 | PLEPT0(4) = SQRT(AMLPT2+PLEPT0(3)**2) |
| 24897 | PNUCL(1) = ZERO |
| 24898 | PNUCL(2) = ZERO |
| 24899 | PNUCL(3) = -PLEPT0(3) |
| 24900 | PNUCL(4) = SQRT(S)-PLEPT0(4) |
| 24901 | ENDIF |
| 24902 | * Lorentz-parameter for transformation Lab. - projectile rest system |
| 24903 | IF ((IDP.EQ.7).OR.(AMP.LT.TINY10)) THEN |
| 24904 | GALAB = TINY10 |
| 24905 | BGLAB = TINY10 |
| 24906 | BLAB = TINY10 |
| 24907 | ELSE |
| 24908 | GALAB = EPROJ/AMP |
| 24909 | BGLAB = PPROJ/AMP |
| 24910 | BLAB = BGLAB/GALAB |
| 24911 | ENDIF |
| 24912 | * Lorentz-parameter for transf. proj. rest sys. - nucl.-nucl. cms. |
| 24913 | IF (IDP.EQ.7) THEN |
| 24914 | GACMS(1) = TINY10 |
| 24915 | BGCMS(1) = TINY10 |
| 24916 | ELSE |
| 24917 | GACMS(1) = (ETARG+AMP)/UMO |
| 24918 | BGCMS(1) = PTARG/UMO |
| 24919 | ENDIF |
| 24920 | * Lorentz-parameter for transformation Lab. - nucl.-nucl. cms. |
| 24921 | GACMS(2) = (EPROJ+AMT)/UMO |
| 24922 | BGCMS(2) = PPROJ/UMO |
| 24923 | PPCM = GACMS(2)*PPROJ-BGCMS(2)*EPROJ |
| 24924 | |
| 24925 | EPN0 = EPN |
| 24926 | PPN0 = PPN |
| 24927 | ECM0 = ECM |
| 24928 | |
| 24929 | RETURN |
| 24930 | END |
| 24931 | * |
| 24932 | *===ltrans=============================================================* |
| 24933 | * |
| 24934 | CDECK ID>, DT_LTRANS |
| 24935 | SUBROUTINE DT_LTRANS(PXI,PYI,PZI,PEI,PXO,PYO,PZO,PEO,ID,MODE) |
| 24936 | |
| 24937 | ************************************************************************ |
| 24938 | * Lorentz-transformations. * |
| 24939 | * MODE = 1(-1) projectile rest syst. --> Lab (back) * |
| 24940 | * = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) * |
| 24941 | * = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) * |
| 24942 | * This version dated 01.11.95 is written by S. Roesler. * |
| 24943 | ************************************************************************ |
| 24944 | |
| 24945 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 24946 | SAVE |
| 24947 | |
| 24948 | PARAMETER ( LINP = 5 , |
| 24949 | & LOUT = 6 , |
| 24950 | & LDAT = 9 ) |
| 24951 | |
| 24952 | PARAMETER (TINY3=1.0D-3,ZERO=0.0D0,TWO=2.0D0) |
| 24953 | |
| 24954 | PARAMETER (SQTINF=1.0D+15) |
| 24955 | |
| 24956 | * particle properties (BAMJET index convention) |
| 24957 | CHARACTER*8 ANAME |
| 24958 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 24959 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 24960 | |
| 24961 | PXO = PXI |
| 24962 | PYO = PYI |
| 24963 | CALL DT_LTNUC(PZI,PEI,PZO,PEO,MODE) |
| 24964 | |
| 24965 | * check particle mass for consistency (numerical rounding errors) |
| 24966 | PO = SQRT(PXO*PXO+PYO*PYO+PZO*PZO) |
| 24967 | AMO2 = (PEO-PO)*(PEO+PO) |
| 24968 | AMORQ2 = AAM(ID)**2 |
| 24969 | AMDIF2 = ABS(AMO2-AMORQ2) |
| 24970 | IF ((AMDIF2.GT.TINY3).AND.(PEO.LT.SQTINF).AND.(PO.GT.ZERO)) THEN |
| 24971 | DELTA = (AMORQ2-AMO2)/(TWO*(PEO+PO)) |
| 24972 | PEO = PEO+DELTA |
| 24973 | PO1 = PO -DELTA |
| 24974 | PXO = PXO*PO1/PO |
| 24975 | PYO = PYO*PO1/PO |
| 24976 | PZO = PZO*PO1/PO |
| 24977 | C WRITE(6,*) 'LTRANS corrected', AMDIF2,PZI,PEI,PZO,PEO,MODE,ID |
| 24978 | ENDIF |
| 24979 | |
| 24980 | RETURN |
| 24981 | END |
| 24982 | * |
| 24983 | *===ltnuc==============================================================* |
| 24984 | * |
| 24985 | CDECK ID>, DT_LTNUC |
| 24986 | SUBROUTINE DT_LTNUC(PIN,EIN,POUT,EOUT,MODE) |
| 24987 | |
| 24988 | ************************************************************************ |
| 24989 | * Lorentz-transformations. * |
| 24990 | * PIN longitudnal momentum (input) * |
| 24991 | * EIN energy (input) * |
| 24992 | * POUT transformed long. momentum (output) * |
| 24993 | * EOUT transformed energy (output) * |
| 24994 | * MODE = 1(-1) projectile rest syst. --> Lab (back) * |
| 24995 | * = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) * |
| 24996 | * = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) * |
| 24997 | * This version dated 01.11.95 is written by S. Roesler. * |
| 24998 | ************************************************************************ |
| 24999 | |
| 25000 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 25001 | SAVE |
| 25002 | |
| 25003 | PARAMETER ( LINP = 5 , |
| 25004 | & LOUT = 6 , |
| 25005 | & LDAT = 9 ) |
| 25006 | |
| 25007 | PARAMETER (ZERO=0.0D0) |
| 25008 | |
| 25009 | * Lorentz-parameters of the current interaction |
| 25010 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, |
| 25011 | & UMO,PPCM,EPROJ,PPROJ |
| 25012 | |
| 25013 | BDUM1 = ZERO |
| 25014 | BDUM2 = ZERO |
| 25015 | PDUM1 = ZERO |
| 25016 | PDUM2 = ZERO |
| 25017 | IF (ABS(MODE).EQ.1) THEN |
| 25018 | BG = -SIGN(BGLAB,DBLE(MODE)) |
| 25019 | CALL DT_DALTRA(GALAB,BDUM1,BDUM2,-BG,PDUM1,PDUM2,PIN,EIN, |
| 25020 | & DUM1,DUM2,DUM3,POUT,EOUT) |
| 25021 | ELSEIF (ABS(MODE).EQ.2) THEN |
| 25022 | BG = SIGN(BGCMS(1),DBLE(MODE)) |
| 25023 | CALL DT_DALTRA(GACMS(1),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN, |
| 25024 | & DUM1,DUM2,DUM3,POUT,EOUT) |
| 25025 | ELSEIF (ABS(MODE).EQ.3) THEN |
| 25026 | BG = -SIGN(BGCMS(2),DBLE(MODE)) |
| 25027 | CALL DT_DALTRA(GACMS(2),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN, |
| 25028 | & DUM1,DUM2,DUM3,POUT,EOUT) |
| 25029 | ELSE |
| 25030 | WRITE(LOUT,1000) MODE |
| 25031 | 1000 FORMAT(1X,'LTNUC: not supported mode (MODE = ',I3,')') |
| 25032 | EOUT = EIN |
| 25033 | POUT = PIN |
| 25034 | ENDIF |
| 25035 | |
| 25036 | RETURN |
| 25037 | END |
| 25038 | * |
| 25039 | *===daltra=============================================================* |
| 25040 | * |
| 25041 | CDECK ID>, DT_DALTRA |
| 25042 | SUBROUTINE DT_DALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E) |
| 25043 | |
| 25044 | ************************************************************************ |
| 25045 | * Arbitrary Lorentz-transformation. * |
| 25046 | * Adopted from the original by S. Roesler. This version dated 15.01.95 * |
| 25047 | ************************************************************************ |
| 25048 | |
| 25049 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 25050 | SAVE |
| 25051 | PARAMETER (ONE=1.0D0) |
| 25052 | |
| 25053 | EP = PCX*BGX+PCY*BGY+PCZ*BGZ |
| 25054 | PE = EP/(GA+ONE)+EC |
| 25055 | PX = PCX+BGX*PE |
| 25056 | PY = PCY+BGY*PE |
| 25057 | PZ = PCZ+BGZ*PE |
| 25058 | P = SQRT(PX*PX+PY*PY+PZ*PZ) |
| 25059 | E = GA*EC+EP |
| 25060 | |
| 25061 | RETURN |
| 25062 | END |
| 25063 | * |
| 25064 | *====dtrafo============================================================* |
| 25065 | * |
| 25066 | CDECK ID>, DT_DTRAFO |
| 25067 | SUBROUTINE DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM, |
| 25068 | & PL,CXL,CYL,CZL,EL) |
| 25069 | |
| 25070 | C LORENTZ TRANSFORMATION INTO THE LAB - SYSTEM |
| 25071 | |
| 25072 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 25073 | SAVE |
| 25074 | |
| 25075 | IF (ABS(COD).GT.1.0D0) COD = SIGN(1.0D0,COD) |
| 25076 | SID = SQRT(1.D0-COD*COD) |
| 25077 | PLX = P*SID*COF |
| 25078 | PLY = P*SID*SIF |
| 25079 | PCMZ = P*COD |
| 25080 | PLZ = GAM*PCMZ+BGAM*ECM |
| 25081 | PL = SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ) |
| 25082 | EL = GAM*ECM+BGAM*PCMZ |
| 25083 | C ROTATION INTO THE ORIGINAL DIRECTION |
| 25084 | COZ = PLZ/PL |
| 25085 | SIZ = SQRT(1.D0-COZ**2) |
| 25086 | CALL DT_STTRAN(CX,CY,CZ,COZ,SIZ,SIF,COF,CXL,CYL,CZL) |
| 25087 | |
| 25088 | RETURN |
| 25089 | END |
| 25090 | * |
| 25091 | *====sttran============================================================* |
| 25092 | * |
| 25093 | CDECK ID>, DT_STTRAN |
| 25094 | SUBROUTINE DT_STTRAN(XO,YO,ZO,CDE,SDE,SFE,CFE,X,Y,Z) |
| 25095 | |
| 25096 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 25097 | SAVE |
| 25098 | DATA ANGLSQ/1.D-30/ |
| 25099 | ************************************************************************ |
| 25100 | * VERSION BY J. RANFT * |
| 25101 | * LEIPZIG * |
| 25102 | * * |
| 25103 | * THIS IS A SUBROUTINE OF FLUKA TO GIVE NEW DIRECTION COSINES * |
| 25104 | * * |
| 25105 | * INPUT VARIABLES: * |
| 25106 | * XO,YO,ZO = ORIGINAL DIRECTION COSINES * |
| 25107 | * CDE,SDE = COSINE AND SINE OF THE POLAR (THETA) * |
| 25108 | * ANGLE OF "SCATTERING" * |
| 25109 | * SDE = SINE OF THE POLAR (THETA) ANGLE OF "SCATTERING" * |
| 25110 | * SFE,CFE = SINE AND COSINE OF THE AZIMUTHAL (PHI) ANGLE * |
| 25111 | * OF "SCATTERING" * |
| 25112 | * * |
| 25113 | * OUTPUT VARIABLES: * |
| 25114 | * X,Y,Z = NEW DIRECTION COSINES * |
| 25115 | * * |
| 25116 | * ROTATION OF COORDINATE SYSTEM (SEE CERN 64-47 ) * |
| 25117 | ************************************************************************ |
| 25118 | * |
| 25119 | * |
| 25120 | * Changed by A. Ferrari |
| 25121 | * |
| 25122 | * IF (ABS(XO)-0.0001D0) 1,1,2 |
| 25123 | * 1 IF (ABS(YO)-0.0001D0) 3,3,2 |
| 25124 | * 3 CONTINUE |
| 25125 | A = XO**2 + YO**2 |
| 25126 | IF ( A .LT. ANGLSQ ) THEN |
| 25127 | X=SDE*CFE |
| 25128 | Y=SDE*SFE |
| 25129 | Z=CDE*ZO |
| 25130 | ELSE |
| 25131 | XI=SDE*CFE |
| 25132 | YI=SDE*SFE |
| 25133 | ZI=CDE |
| 25134 | A=SQRT(A) |
| 25135 | X=-YO*XI/A-ZO*XO*YI/A+XO*ZI |
| 25136 | Y=XO*XI/A-ZO*YO*YI/A+YO*ZI |
| 25137 | Z=A*YI+ZO*ZI |
| 25138 | ENDIF |
| 25139 | |
| 25140 | RETURN |
| 25141 | END |
| 25142 | * |
| 25143 | *===mytran=============================================================* |
| 25144 | * |
| 25145 | CDECK ID>, DT_MYTRAN |
| 25146 | SUBROUTINE DT_MYTRAN(IMODE,XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z) |
| 25147 | |
| 25148 | ************************************************************************ |
| 25149 | * This subroutine rotates the coordinate frame * |
| 25150 | * a) theta around y * |
| 25151 | * b) phi around z if IMODE = 1 * |
| 25152 | * * |
| 25153 | * x' cos(ph) -sin(ph) 0 cos(th) 0 sin(th) x * |
| 25154 | * y' = A B = sin(ph) cos(ph) 0 . 0 1 0 y * |
| 25155 | * z' 0 0 1 -sin(th) 0 cos(th) z * |
| 25156 | * * |
| 25157 | * and vice versa if IMODE = 0. * |
| 25158 | * This version dated 5.4.94 is based on the original version DTRAN * |
| 25159 | * by J. Ranft and is written by S. Roesler. * |
| 25160 | ************************************************************************ |
| 25161 | |
| 25162 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 25163 | SAVE |
| 25164 | |
| 25165 | PARAMETER ( LINP = 5 , |
| 25166 | & LOUT = 6 , |
| 25167 | & LDAT = 9 ) |
| 25168 | |
| 25169 | IF (IMODE.EQ.1) THEN |
| 25170 | X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO |
| 25171 | Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO |
| 25172 | Z=-SDE *XO +CDE *ZO |
| 25173 | ELSE |
| 25174 | X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO |
| 25175 | Y= -SFE*XO+CFE*YO |
| 25176 | Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO |
| 25177 | ENDIF |
| 25178 | RETURN |
| 25179 | END |
| 25180 | * |
| 25181 | *===lt2lab=============================================================* |
| 25182 | * |
| 25183 | CDECK ID>, DT_LT2LAO |
| 25184 | SUBROUTINE DT_LT2LAO |
| 25185 | |
| 25186 | ************************************************************************ |
| 25187 | * Lorentz-transformation to lab-system. This subroutine scans DTEVT1 * |
| 25188 | * for final state particles/fragments defined in nucleon-nucleon-cms * |
| 25189 | * and transforms them back to the lab. * |
| 25190 | * This version dated 16.11.95 is written by S. Roesler * |
| 25191 | ************************************************************************ |
| 25192 | |
| 25193 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 25194 | SAVE |
| 25195 | |
| 25196 | PARAMETER ( LINP = 5 , |
| 25197 | & LOUT = 6 , |
| 25198 | & LDAT = 9 ) |
| 25199 | |
| 25200 | * event history |
| 25201 | |
| 25202 | PARAMETER (NMXHKK=200000) |
| 25203 | |
| 25204 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 25205 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 25206 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 25207 | * extended event history |
| 25208 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 25209 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 25210 | & IHIST(2,NMXHKK) |
| 25211 | |
| 25212 | NEND = NHKK |
| 25213 | NPOINT(5) = NHKK+1 |
| 25214 | IF ( (NPOINT(4).EQ.0).OR.(NEND.LT.NPOINT(4)) ) RETURN |
| 25215 | DO 1 I=NPOINT(4),NEND |
| 25216 | C DO 1 I=1,NEND |
| 25217 | IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR. |
| 25218 | & (ISTHKK(I).EQ.1001)) THEN |
| 25219 | CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3) |
| 25220 | NOB = NOBAM(I) |
| 25221 | CALL DT_EVTPUT(ISTHKK(I),IDHKK(I),I,0,PHKK(1,I),PHKK(2,I), |
| 25222 | & PZ,PE,IDRES(I),IDXRES(I),IDCH(I)) |
| 25223 | IF ((ISTHKK(I).EQ.1000).OR.(ISTHKK(I).EQ.1001)) THEN |
| 25224 | ISTHKK(I) = 3*ISTHKK(I) |
| 25225 | NOBAM(NHKK) = NOB |
| 25226 | ELSE |
| 25227 | IF (ISTHKK(I).EQ.-1) NOBAM(NHKK) = NOB |
| 25228 | ISTHKK(I) = SIGN(3,ISTHKK(I)) |
| 25229 | ENDIF |
| 25230 | JDAHKK(1,I) = NHKK |
| 25231 | ENDIF |
| 25232 | 1 CONTINUE |
| 25233 | |
| 25234 | RETURN |
| 25235 | END |
| 25236 | * |
| 25237 | *===lt2lab=============================================================* |
| 25238 | * |
| 25239 | CDECK ID>, DT_LT2LAB |
| 25240 | SUBROUTINE DT_LT2LAB |
| 25241 | |
| 25242 | ************************************************************************ |
| 25243 | * Lorentz-transformation to lab-system. This subroutine scans DTEVT1 * |
| 25244 | * for final state particles/fragments defined in nucleon-nucleon-cms * |
| 25245 | * and transforms them to the lab. * |
| 25246 | * This version dated 07.01.96 is written by S. Roesler * |
| 25247 | ************************************************************************ |
| 25248 | |
| 25249 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 25250 | SAVE |
| 25251 | |
| 25252 | PARAMETER ( LINP = 5 , |
| 25253 | & LOUT = 6 , |
| 25254 | & LDAT = 9 ) |
| 25255 | |
| 25256 | * event history |
| 25257 | |
| 25258 | PARAMETER (NMXHKK=200000) |
| 25259 | |
| 25260 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 25261 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 25262 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 25263 | * extended event history |
| 25264 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 25265 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 25266 | & IHIST(2,NMXHKK) |
| 25267 | |
| 25268 | IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN |
| 25269 | DO 1 I=NPOINT(4),NHKK |
| 25270 | IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR. |
| 25271 | & (ISTHKK(I).EQ.1001)) THEN |
| 25272 | CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3) |
| 25273 | PHKK(3,I) = PZ |
| 25274 | PHKK(4,I) = PE |
| 25275 | ENDIF |
| 25276 | 1 CONTINUE |
| 25277 | |
| 25278 | RETURN |
| 25279 | END |
| 25280 | |
| 25281 | ************************************************************************ |
| 25282 | * * |
| 25283 | * 5) Sampling from distributions * |
| 25284 | * * |
| 25285 | ************************************************************************ |
| 25286 | * |
| 25287 | *===npoiss=============================================================* |
| 25288 | * |
| 25289 | CDECK ID>, IDT_NPOISS |
| 25290 | INTEGER FUNCTION IDT_NPOISS(AVN) |
| 25291 | |
| 25292 | ************************************************************************ |
| 25293 | * Sample according to Poisson distribution with Poisson parameter AVN. * |
| 25294 | * The original version written by J. Ranft. * |
| 25295 | * This version dated 11.1.95 is written by S. Roesler. * |
| 25296 | ************************************************************************ |
| 25297 | |
| 25298 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 25299 | SAVE |
| 25300 | |
| 25301 | PARAMETER ( LINP = 5 , |
| 25302 | & LOUT = 6 , |
| 25303 | & LDAT = 9 ) |
| 25304 | |
| 25305 | EXPAVN = EXP(-AVN) |
| 25306 | K = 1 |
| 25307 | A = 1.0D0 |
| 25308 | |
| 25309 | 10 CONTINUE |
| 25310 | A = DT_RNDM(A)*A |
| 25311 | IF (A.GE.EXPAVN) THEN |
| 25312 | K = K+1 |
| 25313 | GOTO 10 |
| 25314 | ENDIF |
| 25315 | IDT_NPOISS = K-1 |
| 25316 | |
| 25317 | RETURN |
| 25318 | END |
| 25319 | * |
| 25320 | *===sampxb=============================================================* |
| 25321 | * |
| 25322 | CDECK ID>, DT_SAMPXB |
| 25323 | DOUBLE PRECISION FUNCTION DT_SAMPXB(X1,X2,B) |
| 25324 | |
| 25325 | ************************************************************************ |
| 25326 | * Sampling from f(x)=1./SQRT(X**2+B**2) between x1 and x2. * |
| 25327 | * Processed by S. Roesler, 6.5.95 * |
| 25328 | ************************************************************************ |
| 25329 | |
| 25330 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 25331 | SAVE |
| 25332 | PARAMETER (TWO=2.0D0) |
| 25333 | |
| 25334 | A1 = LOG(X1+SQRT(X1**2+B**2)) |
| 25335 | A2 = LOG(X2+SQRT(X2**2+B**2)) |
| 25336 | AN = A2-A1 |
| 25337 | A = AN*DT_RNDM(A1)+A1 |
| 25338 | BB = EXP(A) |
| 25339 | DT_SAMPXB = (BB**2-B**2)/(TWO*BB) |
| 25340 | |
| 25341 | RETURN |
| 25342 | END |
| 25343 | * |
| 25344 | *===sampex=============================================================* |
| 25345 | * |
| 25346 | CDECK ID>, DT_SAMPEX |
| 25347 | DOUBLE PRECISION FUNCTION DT_SAMPEX(X1,X2) |
| 25348 | |
| 25349 | ************************************************************************ |
| 25350 | * Sampling from f(x)=1./x between x1 and x2. * |
| 25351 | * Processed by S. Roesler, 6.5.95 * |
| 25352 | ************************************************************************ |
| 25353 | |
| 25354 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 25355 | SAVE |
| 25356 | PARAMETER (ONE=1.0D0) |
| 25357 | |
| 25358 | R = DT_RNDM(X1) |
| 25359 | AL1 = LOG(X1) |
| 25360 | AL2 = LOG(X2) |
| 25361 | DT_SAMPEX = EXP((ONE-R)*AL1+R*AL2) |
| 25362 | |
| 25363 | RETURN |
| 25364 | END |
| 25365 | * |
| 25366 | *===samsqx=============================================================* |
| 25367 | * |
| 25368 | CDECK ID>, DT_SAMSQX |
| 25369 | DOUBLE PRECISION FUNCTION DT_SAMSQX(X1,X2) |
| 25370 | |
| 25371 | ************************************************************************ |
| 25372 | * Sampling from f(x)=1./x^0.5 between x1 and x2. * |
| 25373 | * Processed by S. Roesler, 6.5.95 * |
| 25374 | ************************************************************************ |
| 25375 | |
| 25376 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 25377 | SAVE |
| 25378 | PARAMETER (ONE=1.0D0) |
| 25379 | |
| 25380 | R = DT_RNDM(X1) |
| 25381 | DT_SAMSQX = (R*SQRT(X2)+(ONE-R)*SQRT(X1))**2 |
| 25382 | |
| 25383 | RETURN |
| 25384 | END |
| 25385 | * |
| 25386 | *===samplw=============================================================* |
| 25387 | * |
| 25388 | CDECK ID>, DT_SAMPLW |
| 25389 | DOUBLE PRECISION FUNCTION DT_SAMPLW(XMIN,XMAX,B) |
| 25390 | |
| 25391 | ************************************************************************ |
| 25392 | * Sampling from f(x)=1/x^b between x_min and x_max. * |
| 25393 | * S. Roesler, 18.4.98 * |
| 25394 | ************************************************************************ |
| 25395 | |
| 25396 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 25397 | SAVE |
| 25398 | PARAMETER (ONE=1.0D0) |
| 25399 | |
| 25400 | R = DT_RNDM(B) |
| 25401 | IF (B.EQ.ONE) THEN |
| 25402 | DT_SAMPLW = EXP(R*LOG(XMAX)+(ONE-R)*LOG(XMIN)) |
| 25403 | ELSE |
| 25404 | ONEMB = ONE-B |
| 25405 | DT_SAMPLW = (R*XMAX**ONEMB+(ONE-R)*XMIN**ONEMB)**(ONE/ONEMB) |
| 25406 | ENDIF |
| 25407 | |
| 25408 | RETURN |
| 25409 | END |
| 25410 | * |
| 25411 | *===betrej=============================================================* |
| 25412 | * |
| 25413 | CDECK ID>, DT_BETREJ |
| 25414 | DOUBLE PRECISION FUNCTION DT_BETREJ(GAM,ETA,XMIN,XMAX) |
| 25415 | |
| 25416 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 25417 | SAVE |
| 25418 | |
| 25419 | PARAMETER ( LINP = 5 , |
| 25420 | & LOUT = 6 , |
| 25421 | & LDAT = 9 ) |
| 25422 | |
| 25423 | PARAMETER (ONE=1.0D0) |
| 25424 | |
| 25425 | IF (XMIN.GE.XMAX)THEN |
| 25426 | WRITE (LOUT,500) XMIN,XMAX |
| 25427 | 500 FORMAT(1X,'DT_BETREJ: XMIN<XMAX execution stopped ',2F10.5) |
| 25428 | STOP |
| 25429 | ENDIF |
| 25430 | |
| 25431 | 10 CONTINUE |
| 25432 | XX = XMIN+(XMAX-XMIN)*DT_RNDM(ETA) |
| 25433 | BETMAX = XMIN**(GAM-ONE)*(ONE-XMIN)**(ETA-ONE) |
| 25434 | YY = BETMAX*DT_RNDM(XX) |
| 25435 | BETXX = XX**(GAM-ONE)*(ONE-XX)**(ETA-ONE) |
| 25436 | IF (YY.GT.BETXX) GOTO 10 |
| 25437 | DT_BETREJ = XX |
| 25438 | |
| 25439 | RETURN |
| 25440 | END |
| 25441 | * |
| 25442 | *===dgamrn=============================================================* |
| 25443 | * |
| 25444 | CDECK ID>, DT_DGAMRN |
| 25445 | DOUBLE PRECISION FUNCTION DT_DGAMRN(ALAM,ETA) |
| 25446 | |
| 25447 | ************************************************************************ |
| 25448 | * Sampling from Gamma-distribution. * |
| 25449 | * F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA) * |
| 25450 | * Processed by S. Roesler, 6.5.95 * |
| 25451 | ************************************************************************ |
| 25452 | |
| 25453 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 25454 | SAVE |
| 25455 | PARAMETER (ZERO=0.0D0,TINY9=1.0D-9,ONE=1.0D0) |
| 25456 | |
| 25457 | NCOU = 0 |
| 25458 | N = INT(ETA) |
| 25459 | F = ETA-DBLE(N) |
| 25460 | IF (F.EQ.ZERO) GOTO 20 |
| 25461 | 10 R = DT_RNDM(F) |
| 25462 | NCOU = NCOU+1 |
| 25463 | IF (NCOU.GE.11) GOTO 20 |
| 25464 | IF (R.LT.F/(F+2.71828D0)) GOTO 30 |
| 25465 | YYY = LOG(DT_RNDM(R)+TINY9)/F |
| 25466 | IF (ABS(YYY).GT.50.0D0) GOTO 20 |
| 25467 | Y = EXP(YYY) |
| 25468 | IF (LOG(DT_RNDM(Y)+TINY9).GT.-Y) GOTO 10 |
| 25469 | GOTO 40 |
| 25470 | 20 Y = 0.0D0 |
| 25471 | GOTO 50 |
| 25472 | 30 Y = ONE-LOG(DT_RNDM(Y)+TINY9) |
| 25473 | IF (DT_RNDM(R).GT.Y**(F-ONE)) GOTO 10 |
| 25474 | 40 IF (N.EQ.0) GOTO 70 |
| 25475 | 50 Z = 1.0D0 |
| 25476 | DO 60 I = 1,N |
| 25477 | 60 Z = Z*DT_RNDM(Z) |
| 25478 | Y = Y-LOG(Z+TINY9) |
| 25479 | 70 DT_DGAMRN = Y/ALAM |
| 25480 | |
| 25481 | RETURN |
| 25482 | END |
| 25483 | * |
| 25484 | *===dbetar=============================================================* |
| 25485 | * |
| 25486 | CDECK ID>, DT_DBETAR |
| 25487 | DOUBLE PRECISION FUNCTION DT_DBETAR(GAM,ETA) |
| 25488 | |
| 25489 | ************************************************************************ |
| 25490 | * Sampling from Beta -distribution between 0.0 and 1.0 * |
| 25491 | * F(X)=X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM)/(GAMM(GAM)*GAMM(ETA))* |
| 25492 | * Processed by S. Roesler, 6.5.95 * |
| 25493 | ************************************************************************ |
| 25494 | |
| 25495 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 25496 | SAVE |
| 25497 | |
| 25498 | Y = DT_DGAMRN(1.0D0,GAM) |
| 25499 | Z = DT_DGAMRN(1.0D0,ETA) |
| 25500 | DT_DBETAR = Y/(Y+Z) |
| 25501 | |
| 25502 | RETURN |
| 25503 | END |
| 25504 | * |
| 25505 | *===rannor=============================================================* |
| 25506 | * |
| 25507 | CDECK ID>, DT_RANNOR |
| 25508 | SUBROUTINE DT_RANNOR(X,Y) |
| 25509 | |
| 25510 | ************************************************************************ |
| 25511 | * Sampling from Gaussian distribution. * |
| 25512 | * Processed by S. Roesler, 6.5.95 * |
| 25513 | ************************************************************************ |
| 25514 | |
| 25515 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 25516 | SAVE |
| 25517 | PARAMETER (TINY10=1.0D-10) |
| 25518 | |
| 25519 | CALL DT_DSFECF(SFE,CFE) |
| 25520 | V = MAX(TINY10,DT_RNDM(X)) |
| 25521 | A = SQRT(-2.D0*LOG(V)) |
| 25522 | X = A*SFE |
| 25523 | Y = A*CFE |
| 25524 | |
| 25525 | RETURN |
| 25526 | END |
| 25527 | * |
| 25528 | *===dpoli==============================================================* |
| 25529 | * |
| 25530 | CDECK ID>, DT_DPOLI |
| 25531 | SUBROUTINE DT_DPOLI(CS,SI) |
| 25532 | |
| 25533 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 25534 | SAVE |
| 25535 | |
| 25536 | U = DT_RNDM(CS) |
| 25537 | CS = DT_RNDM(U) |
| 25538 | IF (U.LT.0.5D0) CS=-CS |
| 25539 | SI = SQRT(1.0D0-CS*CS+1.0D-10) |
| 25540 | |
| 25541 | RETURN |
| 25542 | END |
| 25543 | * |
| 25544 | *===dsfecf=============================================================* |
| 25545 | * |
| 25546 | CDECK ID>, DT_DSFECF |
| 25547 | SUBROUTINE DT_DSFECF(SFE,CFE) |
| 25548 | |
| 25549 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 25550 | SAVE |
| 25551 | PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0) |
| 25552 | |
| 25553 | 1 CONTINUE |
| 25554 | X = DT_RNDM(SFE) |
| 25555 | Y = DT_RNDM(X) |
| 25556 | XX = X*X |
| 25557 | YY = Y*Y |
| 25558 | XY = XX+YY |
| 25559 | IF (XY.GT.ONE) GOTO 1 |
| 25560 | CFE = (XX-YY)/XY |
| 25561 | SFE = TWO*X*Y/XY |
| 25562 | IF (DT_RNDM(X).LT.OHALF) SFE = -SFE |
| 25563 | RETURN |
| 25564 | END |
| 25565 | * |
| 25566 | *===raco===============================================================* |
| 25567 | * |
| 25568 | CDECK ID>, DT_RACO |
| 25569 | SUBROUTINE DT_RACO(WX,WY,WZ) |
| 25570 | |
| 25571 | ************************************************************************ |
| 25572 | * Direction cosines of random uniform (isotropic) direction in three * |
| 25573 | * dimensional space * |
| 25574 | * Processed by S. Roesler, 20.11.95 * |
| 25575 | ************************************************************************ |
| 25576 | |
| 25577 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 25578 | SAVE |
| 25579 | PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0) |
| 25580 | |
| 25581 | 10 CONTINUE |
| 25582 | X = TWO*DT_RNDM(WX)-ONE |
| 25583 | Y = DT_RNDM(X) |
| 25584 | X2 = X*X |
| 25585 | Y2 = Y*Y |
| 25586 | IF (X2+Y2.GT.ONE) GOTO 10 |
| 25587 | |
| 25588 | CFE = (X2-Y2)/(X2+Y2) |
| 25589 | SFE = TWO*X*Y/(X2+Y2) |
| 25590 | * z = 1/2 [ 1 + cos (theta) ] |
| 25591 | Z = DT_RNDM(X) |
| 25592 | * 1/2 sin (theta) |
| 25593 | WZ = SQRT(Z*(ONE-Z)) |
| 25594 | WX = TWO*WZ*CFE |
| 25595 | WY = TWO*WZ*SFE |
| 25596 | WZ = TWO*Z-ONE |
| 25597 | |
| 25598 | RETURN |
| 25599 | END |
| 25600 | |
| 25601 | ************************************************************************ |
| 25602 | * * |
| 25603 | * 6) Special functions, algorithms and service routines * |
| 25604 | * * |
| 25605 | ************************************************************************ |
| 25606 | * |
| 25607 | *===ylamb==============================================================* |
| 25608 | * |
| 25609 | CDECK ID>, DT_YLAMB |
| 25610 | DOUBLE PRECISION FUNCTION DT_YLAMB(X,Y,Z) |
| 25611 | |
| 25612 | ************************************************************************ |
| 25613 | * * |
| 25614 | * auxiliary function for three particle decay mode * |
| 25615 | * (standard LAMBDA**(1/2) function) * |
| 25616 | * * |
| 25617 | * Adopted from an original version written by R. Engel. * |
| 25618 | * This version dated 12.12.94 is written by S. Roesler. * |
| 25619 | ************************************************************************ |
| 25620 | |
| 25621 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 25622 | SAVE |
| 25623 | |
| 25624 | YZ = Y-Z |
| 25625 | XLAM = X*X-2.D0*X*(Y+Z)+YZ*YZ |
| 25626 | IF (XLAM.LE.0.D0) XLAM = ABS(XLAM) |
| 25627 | DT_YLAMB = SQRT(XLAM) |
| 25628 | |
| 25629 | RETURN |
| 25630 | END |
| 25631 | * |
| 25632 | *===sort1==============================================================* |
| 25633 | * |
| 25634 | CDECK ID>, DT_SORT |
| 25635 | SUBROUTINE DT_SORT(A,N,I0,I1,MODE) |
| 25636 | |
| 25637 | ************************************************************************ |
| 25638 | * This subroutine sorts entries in A in increasing/decreasing order * |
| 25639 | * of A(3,i). * |
| 25640 | * MODE = 1 increasing in A(3,i=1..N) * |
| 25641 | * = 2 decreasing in A(3,i=1..N) * |
| 25642 | * This version dated 21.04.95 is revised by S. Roesler * |
| 25643 | ************************************************************************ |
| 25644 | |
| 25645 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 25646 | SAVE |
| 25647 | |
| 25648 | DIMENSION A(3,N) |
| 25649 | |
| 25650 | M = I1 |
| 25651 | 10 CONTINUE |
| 25652 | M = I1-1 |
| 25653 | IF (M.LE.0) RETURN |
| 25654 | L = 0 |
| 25655 | DO 20 I=I0,M |
| 25656 | J = I+1 |
| 25657 | IF (MODE.EQ.1) THEN |
| 25658 | IF (A(3,I).LE.A(3,J)) GOTO 20 |
| 25659 | ELSE |
| 25660 | IF (A(3,I).GE.A(3,J)) GOTO 20 |
| 25661 | ENDIF |
| 25662 | B = A(3,I) |
| 25663 | C = A(1,I) |
| 25664 | D = A(2,I) |
| 25665 | A(3,I) = A(3,J) |
| 25666 | A(2,I) = A(2,J) |
| 25667 | A(1,I) = A(1,J) |
| 25668 | A(3,J) = B |
| 25669 | A(1,J) = C |
| 25670 | A(2,J) = D |
| 25671 | L = 1 |
| 25672 | 20 CONTINUE |
| 25673 | IF (L.EQ.1) GOTO 10 |
| 25674 | |
| 25675 | RETURN |
| 25676 | END |
| 25677 | * |
| 25678 | *===sort1==============================================================* |
| 25679 | * |
| 25680 | CDECK ID>, DT_SORT1 |
| 25681 | SUBROUTINE DT_SORT1(A,IDX,N,I0,I1,MODE) |
| 25682 | |
| 25683 | ************************************************************************ |
| 25684 | * This subroutine sorts entries in A in increasing/decreasing order * |
| 25685 | * of A(i). * |
| 25686 | * MODE = 1 increasing in A(i=1..N) * |
| 25687 | * = 2 decreasing in A(i=1..N) * |
| 25688 | * This version dated 21.04.95 is revised by S. Roesler * |
| 25689 | ************************************************************************ |
| 25690 | |
| 25691 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 25692 | SAVE |
| 25693 | |
| 25694 | DIMENSION A(N),IDX(N) |
| 25695 | |
| 25696 | M = I1 |
| 25697 | 10 CONTINUE |
| 25698 | M = I1-1 |
| 25699 | IF (M.LE.0) RETURN |
| 25700 | L = 0 |
| 25701 | DO 20 I=I0,M |
| 25702 | J = I+1 |
| 25703 | IF (MODE.EQ.1) THEN |
| 25704 | IF (A(I).LE.A(J)) GOTO 20 |
| 25705 | ELSE |
| 25706 | IF (A(I).GE.A(J)) GOTO 20 |
| 25707 | ENDIF |
| 25708 | B = A(I) |
| 25709 | A(I) = A(J) |
| 25710 | A(J) = B |
| 25711 | IX = IDX(I) |
| 25712 | IDX(I) = IDX(J) |
| 25713 | IDX(J) = IX |
| 25714 | L = 1 |
| 25715 | 20 CONTINUE |
| 25716 | IF (L.EQ.1) GOTO 10 |
| 25717 | |
| 25718 | RETURN |
| 25719 | END |
| 25720 | * |
| 25721 | *===xtime==============================================================* |
| 25722 | * |
| 25723 | CDECK ID>, DT_XTIME |
| 25724 | SUBROUTINE DT_XTIME |
| 25725 | |
| 25726 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 25727 | SAVE |
| 25728 | |
| 25729 | PARAMETER ( LINP = 5 , |
| 25730 | & LOUT = 6 , |
| 25731 | & LDAT = 9 ) |
| 25732 | |
| 25733 | CHARACTER DAT*9,TIM*11 |
| 25734 | |
| 25735 | DAT = ' ' |
| 25736 | TIM = ' ' |
| 25737 | C CALL GETDAT(IYEAR,IMONTH,IDAY) |
| 25738 | C CALL GETTIM(IHOUR,IMINUT,ISECND,IHSCND) |
| 25739 | |
| 25740 | C CALL DATE(DAT) |
| 25741 | C CALL TIME(TIM) |
| 25742 | C WRITE(LOUT,1000) DAT,TIM |
| 25743 | 1000 FORMAT(/,2X,'Date: ',A9,3X,'Time: ',A11,/) |
| 25744 | |
| 25745 | RETURN |
| 25746 | END |
| 25747 | |
| 25748 | ************************************************************************ |
| 25749 | * * |
| 25750 | * 7) Random number generator package * |
| 25751 | * * |
| 25752 | * THIS IS A PACKAGE CONTAINING A RANDOM NUMBER GENERATOR AND * |
| 25753 | * SERVICE ROUTINES. * |
| 25754 | * THE ALGORITHM IS FROM * |
| 25755 | * 'TOWARD A UNVERSAL RANDOM NUMBER GENERATOR' * |
| 25756 | * G.MARSAGLIA, A.ZAMAN ; FSU-SCRI-87-50 * |
| 25757 | * IMPLEMENTATION BY K. HAHN DEC. 88, * |
| 25758 | * THIS GENERATOR SHOULD NOT DEPEND ON THE HARD WARE ( IF A REAL HAS * |
| 25759 | * AT LEAST 24 SIGNIFICANT BITS IN INTERNAL REPRESENTATION ), * |
| 25760 | * THE PERIOD IS ABOUT 2**144, * |
| 25761 | * TIME FOR ONE CALL AT IBM-XT IS ABOUT 0.7 MILLISECONDS, * |
| 25762 | * THE PACKAGE CONTAINS * |
| 25763 | * FUNCTION DT_RNDM(I) : GENERATOR * |
| 25764 | * SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB4): INITIALIZATION * |
| 25765 | * SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) : PUT SEED TO GENERATOR * |
| 25766 | * SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) : TAKE SEED FROM GENERATOR * |
| 25767 | * SUBROUTINE DT_RNDMTE(IO) : TEST OF GENERATOR * |
| 25768 | *--- * |
| 25769 | * FUNCTION DT_RNDM(I) * |
| 25770 | * GIVES UNIFORMLY DISTRIBUTED RANDOM NUMBERS IN (0..1) * |
| 25771 | * I - DUMMY VARIABLE, NOT USED * |
| 25772 | * SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1) * |
| 25773 | * INITIALIZES THE GENERATOR, MUST BE CALLED BEFORE USING DT_RNDM * |
| 25774 | * NA1,NA2,NA3,NB1 - VALUES FOR INITIALIZING THE GENERATOR * |
| 25775 | * NA? MUST BE IN 1..178 AND NOT ALL 1 * |
| 25776 | * 12,34,56 ARE THE STANDARD VALUES * |
| 25777 | * NB1 MUST BE IN 1..168 * |
| 25778 | * 78 IS THE STANDARD VALUE * |
| 25779 | * SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) * |
| 25780 | * PUTS SEED TO GENERATOR ( BRINGS GENERATOR IN THE SAME STATUS * |
| 25781 | * AS AFTER THE LAST DT_RNDMOU CALL ) * |
| 25782 | * U(97),C,CD,CM,I,J - SEED VALUES AS TAKEN FROM DT_RNDMOU * |
| 25783 | * SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) * |
| 25784 | * TAKES SEED FROM GENERATOR * |
| 25785 | * U(97),C,CD,CM,I,J - SEED VALUES * |
| 25786 | * SUBROUTINE DT_RNDMTE(IO) * |
| 25787 | * TEST OF THE GENERATOR * |
| 25788 | * IO - DEFINES OUTPUT * |
| 25789 | * = 0 OUTPUT ONLY IF AN ERROR IS DETECTED * |
| 25790 | * = 1 OUTPUT INDEPENDEND ON AN ERROR * |
| 25791 | * DT_RNDMTE USES DT_RNDMIN AND DT_RNDMOU TO BRING GENERATOR TO * |
| 25792 | * SAME STATUS * |
| 25793 | * AS BEFORE CALL OF DT_RNDMTE * |
| 25794 | ************************************************************************ |
| 25795 | * |
| 25796 | *===rndm===============================================================* |
| 25797 | * |
| 25798 | CDECK ID>, DT_RNDM |
| 25799 | DOUBLE PRECISION FUNCTION DT_RNDM(VDUMMY) |
| 25800 | |
| 25801 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 25802 | SAVE |
| 25803 | |
| 25804 | * counter of calls to random number generator |
| 25805 | * uncomment if needed |
| 25806 | C COMMON /DTRNCT/ IRNCT0,IRNCT1 |
| 25807 | C LOGICAL LFIRST |
| 25808 | C DATA LFIRST /.TRUE./ |
| 25809 | |
| 25810 | * counter of calls to random number generator |
| 25811 | * uncomment if needed |
| 25812 | C IF (LFIRST) THEN |
| 25813 | C IRNCT0 = 0 |
| 25814 | C IRNCT1 = 0 |
| 25815 | C LFIRST = .FALSE. |
| 25816 | C ENDIF |
| 25817 | |
| 25818 | DT_RNDM = FLRNDM(VDUMMY) |
| 25819 | * counter of calls to random number generator |
| 25820 | * uncomment if needed |
| 25821 | C IRNCT1 = IRNCT1+1 |
| 25822 | |
| 25823 | RETURN |
| 25824 | END |
| 25825 | * |
| 25826 | *===rndmst=============================================================* |
| 25827 | * |
| 25828 | CDECK ID>, DT_RNDMST |
| 25829 | SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1) |
| 25830 | |
| 25831 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 25832 | SAVE |
| 25833 | |
| 25834 | * random number generator |
| 25835 | COMMON /DTRAND/ U(97),C,CD,CM,I,J |
| 25836 | |
| 25837 | MA1 = NA1 |
| 25838 | MA2 = NA2 |
| 25839 | MA3 = NA3 |
| 25840 | MB1 = NB1 |
| 25841 | I = 97 |
| 25842 | J = 33 |
| 25843 | DO 20 II2 = 1,97 |
| 25844 | S = 0 |
| 25845 | T = 0.5D0 |
| 25846 | DO 10 II1 = 1,24 |
| 25847 | MAT = MOD(MOD(MA1*MA2,179)*MA3,179) |
| 25848 | MA1 = MA2 |
| 25849 | MA2 = MA3 |
| 25850 | MA3 = MAT |
| 25851 | MB1 = MOD(53*MB1+1,169) |
| 25852 | IF ( MOD(MB1*MAT,64).GE.32 ) S = S+T |
| 25853 | 10 T = 0.5D0*T |
| 25854 | 20 U(II2) = S |
| 25855 | C = 362436.0D0/16777216.0D0 |
| 25856 | CD = 7654321.0D0/16777216.0D0 |
| 25857 | CM = 16777213.0D0/16777216.0D0 |
| 25858 | RETURN |
| 25859 | END |
| 25860 | * |
| 25861 | *===rndmin=============================================================* |
| 25862 | * |
| 25863 | CDECK ID>, DT_RNDMIN |
| 25864 | SUBROUTINE DT_RNDMIN(UIN,CIN,CDIN,CMIN,IIN,JIN) |
| 25865 | |
| 25866 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 25867 | SAVE |
| 25868 | |
| 25869 | * random number generator |
| 25870 | COMMON /DTRAND/ U(97),C,CD,CM,I,J |
| 25871 | |
| 25872 | DIMENSION UIN(97) |
| 25873 | |
| 25874 | DO 10 KKK = 1,97 |
| 25875 | 10 U(KKK) = UIN(KKK) |
| 25876 | C = CIN |
| 25877 | CD = CDIN |
| 25878 | CM = CMIN |
| 25879 | I = IIN |
| 25880 | J = JIN |
| 25881 | |
| 25882 | RETURN |
| 25883 | END |
| 25884 | * |
| 25885 | *===rndmou=============================================================* |
| 25886 | * |
| 25887 | CDECK ID>, DT_RNDMOU |
| 25888 | SUBROUTINE DT_RNDMOU(UOUT,COUT,CDOUT,CMOUT,IOUT,JOUT) |
| 25889 | |
| 25890 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 25891 | SAVE |
| 25892 | |
| 25893 | * random number generator |
| 25894 | COMMON /DTRAND/ U(97),C,CD,CM,I,J |
| 25895 | |
| 25896 | DIMENSION UOUT(97) |
| 25897 | |
| 25898 | DO 10 KKK = 1,97 |
| 25899 | 10 UOUT(KKK) = U(KKK) |
| 25900 | COUT = C |
| 25901 | CDOUT = CD |
| 25902 | CMOUT = CM |
| 25903 | IOUT = I |
| 25904 | JOUT = J |
| 25905 | |
| 25906 | RETURN |
| 25907 | END |
| 25908 | * |
| 25909 | *===rndmte=============================================================* |
| 25910 | * |
| 25911 | CDECK ID>, DT_RNDMTE |
| 25912 | SUBROUTINE DT_RNDMTE(IO) |
| 25913 | |
| 25914 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 25915 | SAVE |
| 25916 | |
| 25917 | DIMENSION UU(97),U(6),X(6),D(6) |
| 25918 | DATA U / 6533892.D0, 14220222.D0, 7275067.D0, 6172232.D0, |
| 25919 | +8354498.D0, 10633180.D0/ |
| 25920 | |
| 25921 | CALL DT_RNDMOU(UU,CC,CCD,CCM,II,JJ) |
| 25922 | CALL DT_RNDMST(12,34,56,78) |
| 25923 | DO 10 II1 = 1,20000 |
| 25924 | 10 XX = DT_RNDM(XX) |
| 25925 | SD = 0.0D0 |
| 25926 | DO 20 II2 = 1,6 |
| 25927 | X(II2) = 4096.D0*(4096.D0*DT_RNDM(SD)) |
| 25928 | D(II2) = X(II2)-U(II2) |
| 25929 | 20 SD = SD+D(II2) |
| 25930 | CALL DT_RNDMIN(UU,CC,CCD,CCM,II,JJ) |
| 25931 | **sr 24.01.95 |
| 25932 | C IF ( IO.EQ. 1.OR. SD.NE.0. 0) WRITE(6,500) (U(I),X(I),D(I),I=1,6) |
| 25933 | IF ((IO.EQ.1).OR.(SD.NE.0.0)) THEN |
| 25934 | C WRITE(6,1000) |
| 25935 | 1000 FORMAT(/,/,1X,'DT_RNDMTE: Test of random-number generator...', |
| 25936 | & ' passed') |
| 25937 | ENDIF |
| 25938 | ** |
| 25939 | RETURN |
| 25940 | 500 FORMAT(' === TEST OF THE RANDOM-GENERATOR ===',/, |
| 25941 | &' EXPECTED VALUE CALCULATED VALUE DIFFERENCE',/, 6(F17. |
| 25942 | &1,F20.1,F15.3,/), ' === END OF TEST ;', |
| 25943 | &' GENERATOR HAS THE SAME STATUS AS BEFORE CALLING DT_RNDMTE') |
| 25944 | END |
| 25945 | * |
| 25946 | * |
| 25947 | *===title==============================================================* |
| 25948 | * |
| 25949 | CDECK ID>, DT_TITLE |
| 25950 | SUBROUTINE DT_TITLE |
| 25951 | |
| 25952 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 25953 | SAVE |
| 25954 | |
| 25955 | PARAMETER ( LINP = 5 , |
| 25956 | & LOUT = 6 , |
| 25957 | & LDAT = 9 ) |
| 25958 | |
| 25959 | CHARACTER*6 CVERSI |
| 25960 | CHARACTER*11 CCHANG |
| 25961 | DATA CVERSI,CCHANG /'3.0-4 ','18 Sep 2001'/ |
| 25962 | |
| 25963 | CALL DT_XTIME |
| 25964 | WRITE(LOUT,1000) CVERSI,CCHANG |
| 25965 | 1000 FORMAT(1X,'+-------------------------------------------------', |
| 25966 | & '----------------------+',/, |
| 25967 | & 1X,'|',71X,'|',/, |
| 25968 | & 1X,'|',26X,'DPMJET version ',A6,24X,'|',/, |
| 25969 | & 1X,'|',71X,'|',/, |
| 25970 | & 1X,'|',22X,'(Last change: ',A11,')',23X,'|',/, |
| 25971 | & 1X,'|',71X,'|',/, |
| 25972 | & 1X,'|',12X,'Authors: Stefan Roesler (CERN)',27X,'|',/, |
| 25973 | & 1X,'|',21X,'Ralph Engel (Bartol Res. Inst.)',14X,'|',/, |
| 25974 | & 1X,'|',21X,'Johannes Ranft (Siegen Univ.)',19X,'|',/, |
| 25975 | & 1X,'|',71X,'|',/, |
| 25976 | & 1X,'|',12X,'http://home.cern.ch/~sroesler/dpmjet3.html', |
| 25977 | & 17X,'|',/, |
| 25978 | & 1X,'|',71X,'|',/, |
| 25979 | & 1X,'+-------------------------------------------------', |
| 25980 | & '----------------------+',/, |
| 25981 | & 1X,'| Please send suggestions, bug reports, etc. to: ', |
| 25982 | & 'Stefan.Roesler@cern.ch |',/, |
| 25983 | & 1X,'+-------------------------------------------------', |
| 25984 | & '----------------------+',/) |
| 25985 | |
| 25986 | RETURN |
| 25987 | END |
| 25988 | * |
| 25989 | *===evtini=============================================================* |
| 25990 | * |
| 25991 | CDECK ID>, DT_EVTINI |
| 25992 | SUBROUTINE DT_EVTINI |
| 25993 | |
| 25994 | ************************************************************************ |
| 25995 | * Initialization of DTEVT1. * |
| 25996 | * This version dated 15.01.94 is written by S. Roesler * |
| 25997 | ************************************************************************ |
| 25998 | |
| 25999 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 26000 | SAVE |
| 26001 | |
| 26002 | PARAMETER ( LINP = 5 , |
| 26003 | & LOUT = 6 , |
| 26004 | & LDAT = 9 ) |
| 26005 | |
| 26006 | * event history |
| 26007 | |
| 26008 | PARAMETER (NMXHKK=200000) |
| 26009 | |
| 26010 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 26011 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 26012 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 26013 | * extended event history |
| 26014 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 26015 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 26016 | & IHIST(2,NMXHKK) |
| 26017 | * event flag |
| 26018 | COMMON /DTEVNO/ NEVENT,ICASCA |
| 26019 | |
| 26020 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 26021 | |
| 26022 | * emulsion treatment |
| 26023 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), |
| 26024 | & NCOMPO,IEMUL |
| 26025 | |
| 26026 | * initialization of DTEVT1/DTEVT2 |
| 26027 | NEND = NHKK |
| 26028 | IF (NEVENT.EQ.1) NEND = NMXHKK |
| 26029 | NHKK = 0 |
| 26030 | NEVHKK = NEVENT |
| 26031 | DO 1 I=1,NEND |
| 26032 | ISTHKK(I) = 0 |
| 26033 | IDHKK(I) = 0 |
| 26034 | JMOHKK(1,I) = 0 |
| 26035 | JMOHKK(2,I) = 0 |
| 26036 | JDAHKK(1,I) = 0 |
| 26037 | JDAHKK(2,I) = 0 |
| 26038 | IDRES(I) = 0 |
| 26039 | IDXRES(I) = 0 |
| 26040 | NOBAM(I) = 0 |
| 26041 | IDCH(I) = 0 |
| 26042 | IHIST(1,I) = 0 |
| 26043 | IHIST(2,I) = 0 |
| 26044 | DO 2 J=1,4 |
| 26045 | PHKK(J,I) = 0.0D0 |
| 26046 | VHKK(J,I) = 0.0D0 |
| 26047 | WHKK(J,I) = 0.0D0 |
| 26048 | 2 CONTINUE |
| 26049 | PHKK(5,I) = 0.0D0 |
| 26050 | 1 CONTINUE |
| 26051 | DO 3 I=1,10 |
| 26052 | NPOINT(I) = 0 |
| 26053 | 3 CONTINUE |
| 26054 | CALL DT_CHASTA(-1) |
| 26055 | |
| 26056 | C* initialization of DTLTRA |
| 26057 | C IF (NCOMPO.GT.0) CALL DT_LTINI(ID,EPN,PPN,ECM) |
| 26058 | |
| 26059 | RETURN |
| 26060 | END |
| 26061 | * |
| 26062 | *===statis=============================================================* |
| 26063 | * |
| 26064 | CDECK ID>, DT_STATIS |
| 26065 | SUBROUTINE DT_STATIS(MODE) |
| 26066 | |
| 26067 | ************************************************************************ |
| 26068 | * Initialization and output of run-statistics. * |
| 26069 | * MODE = 1 initialization * |
| 26070 | * = 2 output * |
| 26071 | * This version dated 23.01.94 is written by S. Roesler * |
| 26072 | ************************************************************************ |
| 26073 | |
| 26074 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 26075 | SAVE |
| 26076 | |
| 26077 | PARAMETER ( LINP = 5 , |
| 26078 | & LOUT = 6 , |
| 26079 | & LDAT = 9 ) |
| 26080 | |
| 26081 | PARAMETER (TINY3=1.0D-3) |
| 26082 | |
| 26083 | * statistics |
| 26084 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, |
| 26085 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), |
| 26086 | & ICEVTG(8,0:30) |
| 26087 | * rejection counter |
| 26088 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, |
| 26089 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, |
| 26090 | & IREXCI(3),IRDIFF(2),IRINC |
| 26091 | * central particle production, impact parameter biasing |
| 26092 | COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR |
| 26093 | * various options for treatment of partons (DTUNUC 1.x) |
| 26094 | * (chain recombination, Cronin,..) |
| 26095 | LOGICAL LCO2CR,LINTPT |
| 26096 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, |
| 26097 | & LCO2CR,LINTPT |
| 26098 | * nucleon-nucleon event-generator |
| 26099 | CHARACTER*8 CMODEL |
| 26100 | LOGICAL LPHOIN |
| 26101 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN |
| 26102 | * flags for particle decays |
| 26103 | COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20), |
| 26104 | & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20), |
| 26105 | & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0 |
| 26106 | * diquark-breaking mechanism |
| 26107 | COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3 |
| 26108 | |
| 26109 | DIMENSION PP(4),PT(4) |
| 26110 | |
| 26111 | GOTO (1,2) MODE |
| 26112 | |
| 26113 | * initialization |
| 26114 | 1 CONTINUE |
| 26115 | |
| 26116 | * initialize statistics counter |
| 26117 | ICREQU = 0 |
| 26118 | ICSAMP = 0 |
| 26119 | ICCPRO = 0 |
| 26120 | ICDPR = 0 |
| 26121 | ICDTA = 0 |
| 26122 | ICRJSS = 0 |
| 26123 | ICVV2S = 0 |
| 26124 | DO 10 I=1,9 |
| 26125 | ICRES(I) = 0 |
| 26126 | ICCHAI(1,I) = 0 |
| 26127 | ICCHAI(2,I) = 0 |
| 26128 | 10 CONTINUE |
| 26129 | * initialize rejection counter |
| 26130 | IRPT = 0 |
| 26131 | IRHHA = 0 |
| 26132 | LOMRES = 0 |
| 26133 | LOBRES = 0 |
| 26134 | IRFRAG = 0 |
| 26135 | IREVT = 0 |
| 26136 | IRRES(1) = 0 |
| 26137 | IRRES(2) = 0 |
| 26138 | IRCHKI(1) = 0 |
| 26139 | IRCHKI(2) = 0 |
| 26140 | IRCRON(1) = 0 |
| 26141 | IRCRON(2) = 0 |
| 26142 | IRCRON(3) = 0 |
| 26143 | IRDIFF(1) = 0 |
| 26144 | IRDIFF(2) = 0 |
| 26145 | IRINC = 0 |
| 26146 | DO 11 I=1,5 |
| 26147 | ICDIFF(I) = 0 |
| 26148 | 11 CONTINUE |
| 26149 | DO 12 I=1,8 |
| 26150 | DO 13 J=0,30 |
| 26151 | ICEVTG(I,J) = 0 |
| 26152 | 13 CONTINUE |
| 26153 | 12 CONTINUE |
| 26154 | |
| 26155 | RETURN |
| 26156 | |
| 26157 | * output |
| 26158 | 2 CONTINUE |
| 26159 | |
| 26160 | * statistics counter |
| 26161 | WRITE(LOUT,1000) |
| 26162 | 1000 FORMAT(/,/,1X,'STATIS:',20X,'statistics of the run',/, |
| 26163 | & 28X,'---------------------') |
| 26164 | WRITE(LOUT,1001) ICREQU,ICSAMP,DBLE(ICSAMP)/DBLE(ICREQU) |
| 26165 | 1001 FORMAT(/,1X,'number of events requested / sampled',13X, |
| 26166 | & I8,' / ',I8,/,1X,'number of samp. evts per requested ', |
| 26167 | & 'event',11X,F9.1) |
| 26168 | IF (ICDIFF(1).NE.0) THEN |
| 26169 | WRITE(LOUT,1009) ICDIFF |
| 26170 | 1009 FORMAT(/,1X,'diffractive events: total ',I8,/,49X, |
| 26171 | & 'low mass high mass',/,24X,'single diffraction', |
| 26172 | & 7X,I8,4X,I8,/,24X,'double diffraction',7X,I8,4X,I8) |
| 26173 | ENDIF |
| 26174 | IF (ICENTR.GT.0) THEN |
| 26175 | WRITE(LOUT,1002) DBLE(ICCPRO)/DBLE(ICSAMP), |
| 26176 | & DBLE(ICSAMP)/DBLE(ICCPRO) |
| 26177 | 1002 FORMAT(/,1X,'central production:',/,2X,'mean number', |
| 26178 | & ' of sampled Glauber-events per event',9X,F9.1,/, |
| 26179 | & 2X,'fraction of production cross section',21X,F10.6) |
| 26180 | ENDIF |
| 26181 | WRITE(LOUT,1003) DBLE(ICDPR)/DBLE(ICSAMP), |
| 26182 | & DBLE(ICDTA)/DBLE(ICSAMP) |
| 26183 | 1003 FORMAT(/,54X,'proj. targ.',/,1X,'average number of wounded', |
| 26184 | & ' nucleons after x-sampling',2(4X,F6.2)) |
| 26185 | |
| 26186 | IF (MCGENE.EQ.1) THEN |
| 26187 | WRITE(LOUT,1004) DBLE(ICRJSS)/DBLE(ICSAMP) |
| 26188 | 1004 FORMAT(/,1X,'mean number of sea-sea chain rejections per', |
| 26189 | & ' event',3X,F9.1) |
| 26190 | IF (ISICHA.EQ.1) THEN |
| 26191 | WRITE(LOUT,1005) DBLE(ICVV2S)/DBLE(ICSAMP) |
| 26192 | 1005 FORMAT(/,1X,'Reggeon contribution:',/,1X,'mean number ', |
| 26193 | & 'of single chains per event',13X,F9.1) |
| 26194 | ENDIF |
| 26195 | WRITE(LOUT,1006) |
| 26196 | 1006 FORMAT(/,1X,'chain system statistics: (per event)',/, |
| 26197 | & 23X,'mean number of chains mean number of chains',/, |
| 26198 | & 23X,'sampled hadronized having mass of a reso.') |
| 26199 | WRITE(LOUT,1007) (DBLE(ICCHAI(1,J))/(2.0D0*DBLE(ICSAMP)), |
| 26200 | & DBLE(ICCHAI(2,J))/(2.0D0*DBLE(ICREQU)), |
| 26201 | & DBLE(ICRES(J))/(2.0D0*DBLE(ICREQU)),J=1,8), |
| 26202 | & DBLE(ICCHAI(2,9))/MAX(DBLE(ICCHAI(1,9)),TINY3) |
| 26203 | 1007 FORMAT(1X,'sea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/, |
| 26204 | & 1X,'disea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/, |
| 26205 | & 1X,'sea - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/, |
| 26206 | & 1X,'sea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/, |
| 26207 | & 1X,'disea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/, |
| 26208 | & 1X,'valence - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/, |
| 26209 | & 1X,'valence - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/, |
| 26210 | & 1X,'valence - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/, |
| 26211 | & 1X,'fused chains ',18X,F4.1,17X,F4.1,/) |
| 26212 | WRITE(LOUT,1008) |
| 26213 | & (DBLE(IRCRON(I))/MAX(DBLE(IRCRON(1)),TINY3),I=2,3), |
| 26214 | & DBLE(IRPT)/DBLE(ICREQU),(DBLE(IRRES(I))/DBLE(ICREQU),I=1,2), |
| 26215 | & DBLE(LOMRES)/DBLE(ICREQU),DBLE(LOBRES)/DBLE(ICREQU), |
| 26216 | & (DBLE(IRCHKI(I))/DBLE(ICREQU),I=1,2), |
| 26217 | & (DBLE(IRDIFF(I))/DBLE(ICREQU),I=1,2), |
| 26218 | & DBLE(IRHHA)/DBLE(ICREQU), |
| 26219 | & DBLE(IRFRAG)/DBLE(ICREQU),DBLE(IREVT)/DBLE(ICREQU), |
| 26220 | & (DBLE(IREXCI(I))/DBLE(ICREQU),I=1,2),IREXCI(3) |
| 26221 | 1008 FORMAT(/,1X,'Rejection counter: (NEVT = no. of events)',/,/, |
| 26222 | & 1X,'Cronin-effect (CRONIN)',15X,'IRCRON(2)/IRCRON(1) = ', |
| 26223 | & F7.2,/,38X,'IRCRON(3)/IRCRON(1) = ',F7.2,/,1X, |
| 26224 | & 'Intrins. p_t (GETSPT)',21X,'IRPT /NEVT = ',F7.2,/, |
| 26225 | & 1X,'Chain mass corr. for resonances (EVTRES)',2X, |
| 26226 | & 'IRRES(1) /NEVT = ',F7.2,/,33X,'(CH2RES) IRRES(2) /', |
| 26227 | & 'NEVT = ',F7.2,/,43X,'LOMRES /NEVT = ',F7.2,/, |
| 26228 | & 43X,'LOBRES /NEVT = ',F7.2,/,1X,'Kinem. corr. of', |
| 26229 | & ' 2-chain systems (CHKINE) IRCHKI(1)/NEVT = ',F7.2,/, |
| 26230 | & 43X,'IRCHKI(2)/NEVT = ',F7.2,/,1X,'Diffraction',31X, |
| 26231 | & 'IRDIFF(1)/NEVT = ',F7.2,/,43X,'IRDIFF(2)/NEVT = ', |
| 26232 | & F7.2,/,1X,'Total no. of rej.', |
| 26233 | & ' in chain-systems treatment (GETCSY)',/,43X, |
| 26234 | & 'IRHHA /NEVT = ',F7.2,/,1X,'Fragmentation (EVTFRA)', |
| 26235 | & ' (not yet used!)',4X,'IRFRAG /NEVT = ',F7.2,/, |
| 26236 | & 1X,'Total no. of rej. in DPM-treatment of one event', |
| 26237 | & ' (EVENTA)',/,43X,'IREVT /NEVT = ',F7.2,/,1X, |
| 26238 | & 'Treatment of final nucleon conf.',10X,'IREXCI(1)/NEVT = ' |
| 26239 | & ,F7.2,/,43X,'IREXCI(2)/NEVT = ',F7.2,/,48X, |
| 26240 | & 'IREXCI(3) = ',I5,/) |
| 26241 | ELSEIF (MCGENE.EQ.2) THEN |
| 26242 | C *** Commented by Chiara |
| 26243 | C WRITE(LOUT,1010) ELOJET |
| 26244 | C 1010 FORMAT(/,/,1X,'PHOJET-treatment of chain systems above ', |
| 26245 | C & F4.1,' GeV') |
| 26246 | C WRITE(LOUT,1011) |
| 26247 | C 1011 FORMAT(/,1X,'1. chain system statistics - total numbers:',/, |
| 26248 | C & 30X,'--------------',/,/,12X,'s-s',5X,'d-s',5X,'s-d', |
| 26249 | C & 5X,'s-v',5X,'d-v',5X,'v-s',5X,'v-d',5X,'v-v') |
| 26250 | C WRITE(LOUT,1012) ((ICEVTG(I,J),I=1,8),J=0,1), |
| 26251 | C & (INT(ICCHAI(2,I)/2.0D0),I=1,8), |
| 26252 | C & (ICEVTG(I,2),I=1,8),(ICEVTG(I,29),I=1,8), |
| 26253 | C & ((ICEVTG(I,J),I=1,8),J=3,7), |
| 26254 | C & ((ICEVTG(I,J),I=1,8),J=19,21), |
| 26255 | C & (ICEVTG(I,8),I=1,8), |
| 26256 | C & ((ICEVTG(I,J),I=1,8),J=22,24), |
| 26257 | C & (ICEVTG(I,9),I=1,8), |
| 26258 | C & ((ICEVTG(I,J),I=1,8),J=25,28), |
| 26259 | C & ((ICEVTG(I,J),I=1,8),J=10,18) |
| 26260 | C 1012 FORMAT(/,1X,'req.to.',8I8,/,/,1X,'low rq.',8I8,/,1X,'low ac.', |
| 26261 | C & 8I8,/,/,1X,'PHOJET ',8I8,/,' sngl ',8I8,/,/, |
| 26262 | C & ' no-dif.',8I8,/, |
| 26263 | C & ' el-sca.',8I8,/,' qel-sc.',8I8,/,' dbl-Po.',8I8,/, |
| 26264 | C & ' diff-1 ',8I8,/,' low ',8I8,/,' high ',8I8,/, |
| 26265 | C & ' h-diff',8I8,/,' diff-2 ',8I8,/,' low ',8I8,/, |
| 26266 | C & ' high ',8I8,/,' h-diff',8I8,/,' dbl-di.',8I8,/, |
| 26267 | C & ' lo-lo ',8I8,/,' hi-hi ',8I8,/,' lo-hi ',8I8,/, |
| 26268 | C & ' hi-lo ',8I8,/, |
| 26269 | C & ' dir-ga.',8I8,/,/,' dir-1 ',8I8,/,' dir-2 ',8I8,/, |
| 26270 | C & ' dbl-dir',8I8,/,' s-Pom. ',8I8,/,' h-Pom. ',8I8,/, |
| 26271 | C & ' s-Reg. ',8I8,/,' enh-trg',8I8,/,' enh-log',8I8) |
| 26272 | C WRITE(LOUT,1013) |
| 26273 | C 1013 FORMAT(/,1X,'2. chain system statistics -', |
| 26274 | C & ' mean numbers per evt:',/,30X,'---------------------', |
| 26275 | C & /,/,16X,'s-s',7X,'d-s',7X,'s-d') |
| 26276 | C WRITE(LOUT,1014) |
| 26277 | C & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=0,1), |
| 26278 | C & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=1,3), |
| 26279 | C & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=2,18) |
| 26280 | C 1014 FORMAT(/,1X,'req.to. ',3E10.2,/,/,1X,'low rq. ',3E10.2,/, |
| 26281 | C & 1X,'low ac. ',3E10.2,/,/,1X,'PHOJET ',3E10.2,/,/, |
| 26282 | C & ' no-dif. ',3E10.2,/,' el-sca. ',3E10.2,/, |
| 26283 | C & ' qel-sc. ',3E10.2,/,' dbl-Po. ',3E10.2,/, |
| 26284 | C & ' diff-1 ',3E10.2,/,' diff-2 ',3E10.2,/, |
| 26285 | C & ' dbl-di. ',3E10.2,/,' dir-ga. ',3E10.2,/,/, |
| 26286 | C & ' dir-1 ',3E10.2,/,' dir-2 ',3E10.2,/, |
| 26287 | C & ' dbl-dir ',3E10.2,/,' s-Pom. ',3E10.2,/, |
| 26288 | C & ' h-Pom. ',3E10.2,/,' s-Reg. ',3E10.2,/, |
| 26289 | C & ' enh-trg ',3E10.2,/,' enh-log ',3E10.2) |
| 26290 | C WRITE(LOUT,1015) |
| 26291 | C 1015 FORMAT(/,16X,'s-v',7X,'d-v',7X,'v-s',7X,'v-d',7X,'v-v') |
| 26292 | C WRITE(LOUT,1016) |
| 26293 | C & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=0,1), |
| 26294 | C & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=4,8), |
| 26295 | C & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=2,18) |
| 26296 | C 1016 FORMAT(/,1X,'req.to. ',5E10.2,/,/,1X,'low rq. ',5E10.2,/, |
| 26297 | C & 1X,'low ac. ',5E10.2,/,/,1X,'PHOJET ',5E10.2,/,/, |
| 26298 | C & ' no-dif. ',5E10.2,/,' el-sca. ',5E10.2,/, |
| 26299 | C & ' qel-sc. ',5E10.2,/,' dbl-Po. ',5E10.2,/, |
| 26300 | C & ' diff-1 ',5E10.2,/,' diff-2 ',5E10.2,/, |
| 26301 | C & ' dbl-di. ',5E10.2,/,' dir-ga. ',5E10.2,/,/, |
| 26302 | C & ' dir-1 ',5E10.2,/,' dir-2 ',5E10.2,/, |
| 26303 | C & ' dbl-dir ',5E10.2,/,' s-Pom. ',5E10.2,/, |
| 26304 | C & ' h-Pom. ',5E10.2,/,' s-Reg. ',5E10.2,/, |
| 26305 | C & ' enh-trg ',5E10.2,/,' enh-log ',5E10.2) |
| 26306 | |
| 26307 | ENDIF |
| 26308 | CALL DT_CHASTA(1) |
| 26309 | |
| 26310 | IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0) |
| 26311 | & .OR.(PDBSEA(3).GT.0.0D0)) THEN |
| 26312 | WRITE(LOUT,*)'YGS1S,YGS2S,YUS1S,YUS2S', |
| 26313 | & DBRKA(1,1)+DBRKA(2,1),DBRKA(1,2)+DBRKA(2,2), |
| 26314 | & DBRKA(1,3)+DBRKA(2,3),DBRKA(1,4)+DBRKA(2,4) |
| 26315 | WRITE(LOUT,*)'YGS1R,YGS2R,YUS1R,YUS2R', |
| 26316 | & DBRKR(1,1)+DBRKR(2,1),DBRKR(1,2)+DBRKR(2,2), |
| 26317 | & DBRKR(1,3)+DBRKR(2,3),DBRKR(1,4)+DBRKR(2,4) |
| 26318 | WRITE(LOUT,*)'YGSA1S,YGSA2S,YUSA1S,YUSA2S', |
| 26319 | & DBRKA(1,5)+DBRKA(2,5),DBRKA(1,6)+DBRKA(2,6), |
| 26320 | & DBRKA(1,7)+DBRKA(2,7),DBRKA(1,8)+DBRKA(2,8) |
| 26321 | WRITE(LOUT,*)'YGSA1R,YGSA2R,YUSA1R,YUSA2R', |
| 26322 | & DBRKR(1,5)+DBRKR(2,5),DBRKR(1,6)+DBRKR(2,6), |
| 26323 | & DBRKR(1,7)+DBRKR(2,7),DBRKR(1,8)+DBRKR(2,8) |
| 26324 | WRITE(LOUT,*)'YG31S,YG32S,YU31S,YU32S', |
| 26325 | & DBRKA(3,1),DBRKA(3,2), |
| 26326 | & DBRKA(3,3),DBRKA(3,4) |
| 26327 | WRITE(LOUT,*)'YG31R,YG32R,YU31R,YU32R', |
| 26328 | & DBRKR(3,1),DBRKR(3,2), |
| 26329 | & DBRKR(3,3),DBRKR(3,4) |
| 26330 | WRITE(LOUT,*)'YG3A1S,YG3A2S,YU3A1S,YU3A2S', |
| 26331 | & DBRKA(3,5),DBRKA(3,6), |
| 26332 | & DBRKA(3,7),DBRKA(3,8) |
| 26333 | WRITE(LOUT,*)'YG3A1R,YG3A2R,YU3A1R,YU3A2R', |
| 26334 | & DBRKR(3,5),DBRKR(3,6), |
| 26335 | & DBRKR(3,7),DBRKR(3,8) |
| 26336 | ENDIF |
| 26337 | |
| 26338 | FAC = 1.0D0 |
| 26339 | IF (MCGENE.EQ.2) THEN |
| 26340 | |
| 26341 | C CALL PHO_PHIST(-2,SIGMAX) |
| 26342 | CALL PHO_EVENT(-2,PP,PT,FAC,IREJ1) |
| 26343 | |
| 26344 | ENDIF |
| 26345 | |
| 26346 | CALL DT_XTIME |
| 26347 | |
| 26348 | RETURN |
| 26349 | END |
| 26350 | * |
| 26351 | *===evtout=============================================================* |
| 26352 | * |
| 26353 | CDECK ID>, DT_EVTOUT |
| 26354 | SUBROUTINE DT_EVTOUT(MODE) |
| 26355 | |
| 26356 | ************************************************************************ |
| 26357 | * MODE = 1 plot content of complete DTEVT1 to out. unit * |
| 26358 | * 3 plot entries of extended DTEVT1 (DTEVT2) * |
| 26359 | * 4 plot entries of DTEVT1 and DTEVT2 * |
| 26360 | * This version dated 11.12.94 is written by S. Roesler * |
| 26361 | ************************************************************************ |
| 26362 | |
| 26363 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 26364 | SAVE |
| 26365 | |
| 26366 | PARAMETER ( LINP = 5 , |
| 26367 | & LOUT = 6 , |
| 26368 | & LDAT = 9 ) |
| 26369 | |
| 26370 | * event history |
| 26371 | |
| 26372 | PARAMETER (NMXHKK=200000) |
| 26373 | |
| 26374 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 26375 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 26376 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 26377 | |
| 26378 | DIMENSION IRANGE(NMXHKK) |
| 26379 | |
| 26380 | IF (MODE.EQ.2) RETURN |
| 26381 | |
| 26382 | CALL DT_EVTPLO(IRANGE,MODE) |
| 26383 | |
| 26384 | RETURN |
| 26385 | END |
| 26386 | * |
| 26387 | *===evtplo=============================================================* |
| 26388 | * |
| 26389 | CDECK ID>, DT_EVTPLO |
| 26390 | SUBROUTINE DT_EVTPLO(IRANGE,MODE) |
| 26391 | |
| 26392 | ************************************************************************ |
| 26393 | * MODE = 1 plot content of complete DTEVT1 to out. unit * |
| 26394 | * 2 plot entries of DTEVT1 given by IRANGE * |
| 26395 | * 3 plot entries of extended DTEVT1 (DTEVT2) * |
| 26396 | * 4 plot entries of DTEVT1 and DTEVT2 * |
| 26397 | * 5 plot rejection counter * |
| 26398 | * This version dated 11.12.94 is written by S. Roesler * |
| 26399 | ************************************************************************ |
| 26400 | |
| 26401 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 26402 | SAVE |
| 26403 | |
| 26404 | PARAMETER ( LINP = 5 , |
| 26405 | & LOUT = 6 , |
| 26406 | & LDAT = 9 ) |
| 26407 | |
| 26408 | CHARACTER*16 CHAU |
| 26409 | |
| 26410 | * event history |
| 26411 | |
| 26412 | PARAMETER (NMXHKK=200000) |
| 26413 | |
| 26414 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 26415 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 26416 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 26417 | * extended event history |
| 26418 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 26419 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 26420 | & IHIST(2,NMXHKK) |
| 26421 | * rejection counter |
| 26422 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, |
| 26423 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, |
| 26424 | & IREXCI(3),IRDIFF(2),IRINC |
| 26425 | |
| 26426 | DIMENSION IRANGE(NMXHKK) |
| 26427 | |
| 26428 | IF ((MODE.EQ.1).OR.(MODE.EQ.4)) THEN |
| 26429 | WRITE(LOUT,1000) |
| 26430 | 1000 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTEVT1/',/, |
| 26431 | & 15X,' --------------------------',/,/, |
| 26432 | & ' ST ID M1 M2 D1 D2 PX PY', |
| 26433 | & ' PZ E M',/) |
| 26434 | DO 1 I=1,NHKK |
| 26435 | WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I), |
| 26436 | & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I), |
| 26437 | & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I), |
| 26438 | & PHKK(5,I) |
| 26439 | C WRITE(LOUT,1011) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I), |
| 26440 | C & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I), |
| 26441 | C & PHKK(3,I),PHKK(4,I) |
| 26442 | C WRITE(LOUT,'(4E15.4)') |
| 26443 | C & VHKK(1,I),VHKK(2,I),VHKK(3,I),VHKK(4,I) |
| 26444 | 1001 FORMAT(I5,I5,I6,4I5,3F7.3,F8.3,F8.4) |
| 26445 | 1011 FORMAT(I5,I5,I6,4I5,2E15.5) |
| 26446 | 1 CONTINUE |
| 26447 | WRITE(LOUT,*) |
| 26448 | C DO 4 I=1,NHKK |
| 26449 | C WRITE(LOUT,1006) I,ISTHKK(I), |
| 26450 | C & VHKK(1,I),VHKK(2,I),VHKK(3,I),WHKK(1,I), |
| 26451 | C & WHKK(2,I),WHKK(3,I) |
| 26452 | C1006 FORMAT(1X,I4,I6,6E10.3) |
| 26453 | C 4 CONTINUE |
| 26454 | ENDIF |
| 26455 | |
| 26456 | IF (MODE.EQ.2) THEN |
| 26457 | WRITE(LOUT,1000) |
| 26458 | NC = 0 |
| 26459 | 2 CONTINUE |
| 26460 | NC = NC+1 |
| 26461 | IF (IRANGE(NC).EQ.-100) GOTO 9999 |
| 26462 | I = IRANGE(NC) |
| 26463 | WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I), |
| 26464 | & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I), |
| 26465 | & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I), |
| 26466 | & PHKK(5,I) |
| 26467 | GOTO 2 |
| 26468 | ENDIF |
| 26469 | |
| 26470 | IF ((MODE.EQ.3).OR.(MODE.EQ.4)) THEN |
| 26471 | WRITE(LOUT,1002) |
| 26472 | 1002 FORMAT(/,1X,'EVTPLO:',14X, |
| 26473 | & ' content of COMMON /DTEVT1/,/DTEVT2/',/, |
| 26474 | & 15X,' -----------------------------------',/,/, |
| 26475 | & ' ST ID M1 M2 D1 D2 IDR IDXR', |
| 26476 | & ' NOBAM IDCH M',/) |
| 26477 | DO 3 I=1,NHKK |
| 26478 | C IF ((ISTHKK(I).GT.10).OR.(ISTHKK(I).EQ.1)) THEN |
| 26479 | KF = IDHKK(I) |
| 26480 | IDCHK = KF/10000 |
| 26481 | IF ((((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND. |
| 26482 | & (KF.NE.80000)).OR.(IDHKK(I).EQ.99999)) KF = 92 |
| 26483 | |
| 26484 | CALL PYNAME(KF,CHAU) |
| 26485 | |
| 26486 | WRITE(LOUT,1003) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I), |
| 26487 | & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I), |
| 26488 | & IDRES(I),IDXRES(I),NOBAM(I),IDCH(I), |
| 26489 | & PHKK(5,I),CHAU |
| 26490 | 1003 FORMAT(I5,I5,I6,4I5,4I4,F8.4,2X,A) |
| 26491 | C ENDIF |
| 26492 | 3 CONTINUE |
| 26493 | ENDIF |
| 26494 | |
| 26495 | IF (MODE.EQ.5) THEN |
| 26496 | WRITE(LOUT,1004) |
| 26497 | 1004 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTREJC/',/, |
| 26498 | & 15X,' --------------------------',/) |
| 26499 | WRITE(LOUT,1005) IRPT,IRHHA,IRRES,LOMRES,LOBRES,IREMC,IRFRAG, |
| 26500 | & IRSEA,IRCRON |
| 26501 | 1005 FORMAT(1X,'IRPT = ',I5,' IRHHA = ',I5,/, |
| 26502 | & 1X,'IRRES = ',2I5,' LOMRES = ',I5,' LOBRES = ',I5,/, |
| 26503 | & 1X,'IREMC = ',10I5,/, |
| 26504 | & 1X,'IRFRAG = ',I5,' IRSEA = ',I5,' IRCRON = ',I5,/) |
| 26505 | ENDIF |
| 26506 | |
| 26507 | 9999 RETURN |
| 26508 | END |
| 26509 | * |
| 26510 | *===evtput=============================================================* |
| 26511 | * |
| 26512 | CDECK ID>, DT_EVTPUT |
| 26513 | SUBROUTINE DT_EVTPUT(IST,ID,M1,M2,PX,PY,PZ,E,IDR,IDXR,IDC) |
| 26514 | |
| 26515 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 26516 | SAVE |
| 26517 | |
| 26518 | PARAMETER ( LINP = 5 , |
| 26519 | & LOUT = 6 , |
| 26520 | & LDAT = 9 ) |
| 26521 | |
| 26522 | PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,TINY3=1.0D-3, |
| 26523 | & TINY2=1.0D-2,SQTINF=1.0D+15,ZERO=0.0D0) |
| 26524 | |
| 26525 | * event history |
| 26526 | |
| 26527 | PARAMETER (NMXHKK=200000) |
| 26528 | |
| 26529 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 26530 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 26531 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 26532 | * extended event history |
| 26533 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 26534 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 26535 | & IHIST(2,NMXHKK) |
| 26536 | * Lorentz-parameters of the current interaction |
| 26537 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, |
| 26538 | & UMO,PPCM,EPROJ,PPROJ |
| 26539 | * particle properties (BAMJET index convention) |
| 26540 | CHARACTER*8 ANAME |
| 26541 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 26542 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 26543 | |
| 26544 | C IF (MODE.GT.100) THEN |
| 26545 | C WRITE(LOUT,'(1X,A,I5,A,I5)') |
| 26546 | C & 'EVTPUT: reset NHKK = ',NHKK,' to NHKK =',NHKK-MODE+100 |
| 26547 | C NHKK = NHKK-MODE+100 |
| 26548 | C RETURN |
| 26549 | C ENDIF |
| 26550 | MO1 = M1 |
| 26551 | MO2 = M2 |
| 26552 | NHKK = NHKK+1 |
| 26553 | |
| 26554 | IF (NHKK.GT.NMXHKK) THEN |
| 26555 | WRITE(LOUT,1000) NHKK |
| 26556 | 1000 FORMAT(1X,'EVTPUT: NHKK exeeds NMXHKK = ',I7, |
| 26557 | & '! program execution stopped..') |
| 26558 | STOP |
| 26559 | ENDIF |
| 26560 | IF (M1.LT.0) MO1 = NHKK+M1 |
| 26561 | IF (M2.LT.0) MO2 = NHKK+M2 |
| 26562 | ISTHKK(NHKK) = IST |
| 26563 | IDHKK(NHKK) = ID |
| 26564 | JMOHKK(1,NHKK) = MO1 |
| 26565 | JMOHKK(2,NHKK) = MO2 |
| 26566 | JDAHKK(1,NHKK) = 0 |
| 26567 | JDAHKK(2,NHKK) = 0 |
| 26568 | IDRES(NHKK) = IDR |
| 26569 | IDXRES(NHKK) = IDXR |
| 26570 | IDCH(NHKK) = IDC |
| 26571 | ** here we need to do something.. |
| 26572 | IF (ID.EQ.88888) THEN |
| 26573 | IDMO1 = ABS(IDHKK(MO1)) |
| 26574 | IDMO2 = ABS(IDHKK(MO2)) |
| 26575 | IF ((IDMO1.LT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 3 |
| 26576 | IF ((IDMO1.LT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 4 |
| 26577 | IF ((IDMO1.GT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 5 |
| 26578 | IF ((IDMO1.GT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 6 |
| 26579 | ELSE |
| 26580 | NOBAM(NHKK) = 0 |
| 26581 | ENDIF |
| 26582 | IDBAM(NHKK) = IDT_ICIHAD(ID) |
| 26583 | IF (MO1.GT.0) THEN |
| 26584 | IF (JDAHKK(1,MO1).NE.0) THEN |
| 26585 | JDAHKK(2,MO1) = NHKK |
| 26586 | ELSE |
| 26587 | JDAHKK(1,MO1) = NHKK |
| 26588 | ENDIF |
| 26589 | ENDIF |
| 26590 | IF (MO2.GT.0) THEN |
| 26591 | IF (JDAHKK(1,MO2).NE.0) THEN |
| 26592 | JDAHKK(2,MO2) = NHKK |
| 26593 | ELSE |
| 26594 | JDAHKK(1,MO2) = NHKK |
| 26595 | ENDIF |
| 26596 | ENDIF |
| 26597 | C IF ((IDBAM(NHKK).GT.0).AND.(IDBAM(NHKK).NE.7)) THEN |
| 26598 | C PTOT = SQRT(PX**2+PY**2+PZ**2) |
| 26599 | C AM0 = SQRT(ABS( (E-PTOT)*(E+PTOT) )) |
| 26600 | C AMRQ = AAM(IDBAM(NHKK)) |
| 26601 | C AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ) |
| 26602 | C IF ((ABS(AMDIF2).GT.TINY3).AND.(E.LT.SQTINF).AND. |
| 26603 | C & (PTOT.GT.ZERO)) THEN |
| 26604 | C DELTA = -AMDIF2/(2.0D0*(E+PTOT)) |
| 26605 | CC DELTA = (AMRQ2-AM2)/(2.0D0*(E+PTOT)) |
| 26606 | C E = E+DELTA |
| 26607 | C PTOT1 = PTOT-DELTA |
| 26608 | C PX = PX*PTOT1/PTOT |
| 26609 | C PY = PY*PTOT1/PTOT |
| 26610 | C PZ = PZ*PTOT1/PTOT |
| 26611 | C ENDIF |
| 26612 | C ENDIF |
| 26613 | PHKK(1,NHKK) = PX |
| 26614 | PHKK(2,NHKK) = PY |
| 26615 | PHKK(3,NHKK) = PZ |
| 26616 | PHKK(4,NHKK) = E |
| 26617 | PTOT = SQRT( PX**2+PY**2+PZ**2 ) |
| 26618 | IF ((IDHKK(NHKK).GE.22).AND.(IDHKK(NHKK).LE.24)) THEN |
| 26619 | PHKK(5,NHKK) = PHKK(4,NHKK)**2-PTOT**2 |
| 26620 | PHKK(5,NHKK) = SIGN(SQRT(ABS(PHKK(5,NHKK))),PHKK(5,NHKK)) |
| 26621 | ELSE |
| 26622 | PHKK(5,NHKK) = (PHKK(4,NHKK)-PTOT)*(PHKK(4,NHKK)+PTOT) |
| 26623 | C IF ((PHKK(5,NHKK).LT.0.0D0).AND.(ABS(PHKK(5,NHKK)).GT.TINY4)) |
| 26624 | C & WRITE(LOUT,'(1X,A,G10.3)') |
| 26625 | C & 'EVTPUT: negative mass**2 ',PHKK(5,NHKK) |
| 26626 | PHKK(5,NHKK) = SQRT(ABS(PHKK(5,NHKK))) |
| 26627 | ENDIF |
| 26628 | IDCHK = ID/10000 |
| 26629 | IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.(ID.NE.80000)) THEN |
| 26630 | * special treatment for chains: |
| 26631 | * z coordinate of chain in Lab = pos. of target nucleon |
| 26632 | * time of chain-creation in Lab = time of passage of projectile |
| 26633 | * nucleus at pos. of taget nucleus |
| 26634 | C VHKK(1,NHKK) = 0.5D0*(VHKK(1,MO1)+VHKK(1,MO2)) |
| 26635 | C VHKK(2,NHKK) = 0.5D0*(VHKK(2,MO1)+VHKK(2,MO2)) |
| 26636 | VHKK(1,NHKK) = VHKK(1,MO2) |
| 26637 | VHKK(2,NHKK) = VHKK(2,MO2) |
| 26638 | VHKK(3,NHKK) = VHKK(3,MO2) |
| 26639 | VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB |
| 26640 | C WHKK(1,NHKK) = 0.5D0*(WHKK(1,MO1)+WHKK(1,MO2)) |
| 26641 | C WHKK(2,NHKK) = 0.5D0*(WHKK(2,MO1)+WHKK(2,MO2)) |
| 26642 | WHKK(1,NHKK) = WHKK(1,MO1) |
| 26643 | WHKK(2,NHKK) = WHKK(2,MO1) |
| 26644 | WHKK(3,NHKK) = WHKK(3,MO1) |
| 26645 | WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB |
| 26646 | ELSE |
| 26647 | IF (MO1.GT.0) THEN |
| 26648 | DO 1 I=1,4 |
| 26649 | VHKK(I,NHKK) = VHKK(I,MO1) |
| 26650 | WHKK(I,NHKK) = WHKK(I,MO1) |
| 26651 | 1 CONTINUE |
| 26652 | ELSE |
| 26653 | DO 2 I=1,4 |
| 26654 | VHKK(I,NHKK) = ZERO |
| 26655 | WHKK(I,NHKK) = ZERO |
| 26656 | 2 CONTINUE |
| 26657 | ENDIF |
| 26658 | ENDIF |
| 26659 | |
| 26660 | RETURN |
| 26661 | END |
| 26662 | * |
| 26663 | *===chasta=============================================================* |
| 26664 | * |
| 26665 | CDECK ID>, DT_CHASTA |
| 26666 | SUBROUTINE DT_CHASTA(MODE) |
| 26667 | |
| 26668 | ************************************************************************ |
| 26669 | * This subroutine performs CHAin STAtistics and checks sequence of * |
| 26670 | * partons in dtevt1 and sorts them with projectile partons coming * |
| 26671 | * first if necessary. * |
| 26672 | * * |
| 26673 | * This version dated 8.5.00 is written by S. Roesler. * |
| 26674 | ************************************************************************ |
| 26675 | |
| 26676 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 26677 | SAVE |
| 26678 | |
| 26679 | PARAMETER ( LINP = 5 , |
| 26680 | & LOUT = 6 , |
| 26681 | & LDAT = 9 ) |
| 26682 | |
| 26683 | CHARACTER*5 CCHTYP |
| 26684 | |
| 26685 | * event history |
| 26686 | |
| 26687 | PARAMETER (NMXHKK=200000) |
| 26688 | |
| 26689 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 26690 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 26691 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 26692 | * extended event history |
| 26693 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 26694 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 26695 | & IHIST(2,NMXHKK) |
| 26696 | * pointer to chains in hkkevt common (used by qq-breaking mechanisms) |
| 26697 | PARAMETER (MAXCHN=10000) |
| 26698 | COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN |
| 26699 | |
| 26700 | DIMENSION ICHCFG(10,10,9,2),ICHTYP(5,5), |
| 26701 | & CCHTYP(9),ICHSTA(10),ITOT(10) |
| 26702 | DATA ICHCFG /1800*0/ |
| 26703 | DATA (ICHTYP(1,K),K=1,5) / 0, 1, 3, 0, 0/ |
| 26704 | DATA (ICHTYP(2,K),K=1,5) / 2, 0, 0, 5, 0/ |
| 26705 | DATA (ICHTYP(3,K),K=1,5) / 4, 0, 0, 7, 0/ |
| 26706 | DATA (ICHTYP(4,K),K=1,5) / 0, 6, 8, 0, 0/ |
| 26707 | DATA (ICHTYP(5,K),K=1,5) / 0, 0, 0, 0, 9/ |
| 26708 | DATA ICHSTA / 21, 22, 31, 32, 41, 42, 51, 52, 61, 62/ |
| 26709 | DATA CCHTYP / ' q aq','aq q ',' q d ',' d q ','aq ad', |
| 26710 | & 'ad aq',' d ad','ad d ',' g g '/ |
| 26711 | * |
| 26712 | * initialization |
| 26713 | * |
| 26714 | IF (MODE.EQ.-1) THEN |
| 26715 | NCHAIN = 0 |
| 26716 | * |
| 26717 | * loop over DTEVT1 and analyse chain configurations |
| 26718 | * |
| 26719 | ELSEIF (MODE.EQ.0) THEN |
| 26720 | DO 21 IDX=NPOINT(3),NHKK |
| 26721 | IDCHK = IDHKK(IDX)/10000 |
| 26722 | IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND. |
| 26723 | & (IDHKK(IDX).NE.80000).AND. |
| 26724 | & (ISTHKK(IDX).NE.2).AND.(IDRES(IDX).EQ.0)) THEN |
| 26725 | IF (JMOHKK(1,IDX).GT.JMOHKK(2,IDX)) THEN |
| 26726 | WRITE(LOUT,*) ' CHASTA: JMOHKK(1,x) > JMOHKK(2,x) ', |
| 26727 | & ' at entry ',IDX |
| 26728 | GOTO 21 |
| 26729 | ENDIF |
| 26730 | * |
| 26731 | IST1 = ABS(ISTHKK(JMOHKK(1,IDX))) |
| 26732 | IST2 = ABS(ISTHKK(JMOHKK(2,IDX))) |
| 26733 | IMO1 = IST1/10 |
| 26734 | IMO1 = IST1-10*IMO1 |
| 26735 | IMO2 = IST2/10 |
| 26736 | IMO2 = IST2-10*IMO2 |
| 26737 | * swop parton entries if necessary since we need projectile partons |
| 26738 | * to come first in the common |
| 26739 | IF (IMO1.GT.IMO2) THEN |
| 26740 | NPTN = JMOHKK(2,IDX)-JMOHKK(1,IDX)+1 |
| 26741 | DO 22 K=1,NPTN/2 |
| 26742 | I0 = JMOHKK(1,IDX)-1+K |
| 26743 | I1 = JMOHKK(2,IDX)+1-K |
| 26744 | ITMP = ISTHKK(I0) |
| 26745 | ISTHKK(I0) = ISTHKK(I1) |
| 26746 | ISTHKK(I1) = ITMP |
| 26747 | ITMP = IDHKK(I0) |
| 26748 | IDHKK(I0) = IDHKK(I1) |
| 26749 | IDHKK(I1) = ITMP |
| 26750 | IF (JDAHKK(1,JMOHKK(1,I0)).EQ.I0) |
| 26751 | & JDAHKK(1,JMOHKK(1,I0)) = I1 |
| 26752 | IF (JDAHKK(2,JMOHKK(1,I0)).EQ.I0) |
| 26753 | & JDAHKK(2,JMOHKK(1,I0)) = I1 |
| 26754 | IF (JDAHKK(1,JMOHKK(2,I0)).EQ.I0) |
| 26755 | & JDAHKK(1,JMOHKK(2,I0)) = I1 |
| 26756 | IF (JDAHKK(2,JMOHKK(2,I0)).EQ.I0) |
| 26757 | & JDAHKK(2,JMOHKK(2,I0)) = I1 |
| 26758 | IF (JDAHKK(1,JMOHKK(1,I1)).EQ.I1) |
| 26759 | & JDAHKK(1,JMOHKK(1,I1)) = I0 |
| 26760 | IF (JDAHKK(2,JMOHKK(1,I1)).EQ.I1) |
| 26761 | & JDAHKK(2,JMOHKK(1,I1)) = I0 |
| 26762 | IF (JDAHKK(1,JMOHKK(2,I1)).EQ.I1) |
| 26763 | & JDAHKK(1,JMOHKK(2,I1)) = I0 |
| 26764 | IF (JDAHKK(2,JMOHKK(2,I1)).EQ.I1) |
| 26765 | & JDAHKK(2,JMOHKK(2,I1)) = I0 |
| 26766 | ITMP = JMOHKK(1,I0) |
| 26767 | JMOHKK(1,I0) = JMOHKK(1,I1) |
| 26768 | JMOHKK(1,I1) = ITMP |
| 26769 | ITMP = JMOHKK(2,I0) |
| 26770 | JMOHKK(2,I0) = JMOHKK(2,I1) |
| 26771 | JMOHKK(2,I1) = ITMP |
| 26772 | ITMP = JDAHKK(1,I0) |
| 26773 | JDAHKK(1,I0) = JDAHKK(1,I1) |
| 26774 | JDAHKK(1,I1) = ITMP |
| 26775 | ITMP = JDAHKK(2,I0) |
| 26776 | JDAHKK(2,I0) = JDAHKK(2,I1) |
| 26777 | JDAHKK(2,I1) = ITMP |
| 26778 | DO 23 J=1,4 |
| 26779 | RTMP1 = PHKK(J,I0) |
| 26780 | RTMP2 = VHKK(J,I0) |
| 26781 | RTMP3 = WHKK(J,I0) |
| 26782 | PHKK(J,I0) = PHKK(J,I1) |
| 26783 | VHKK(J,I0) = VHKK(J,I1) |
| 26784 | WHKK(J,I0) = WHKK(J,I1) |
| 26785 | PHKK(J,I1) = RTMP1 |
| 26786 | VHKK(J,I1) = RTMP2 |
| 26787 | WHKK(J,I1) = RTMP3 |
| 26788 | 23 CONTINUE |
| 26789 | RTMP1 = PHKK(5,I0) |
| 26790 | PHKK(5,I0) = PHKK(5,I1) |
| 26791 | PHKK(5,I1) = RTMP1 |
| 26792 | ITMP = IDRES(I0) |
| 26793 | IDRES(I0) = IDRES(I1) |
| 26794 | IDRES(I1) = ITMP |
| 26795 | ITMP = IDXRES(I0) |
| 26796 | IDXRES(I0) = IDXRES(I1) |
| 26797 | IDXRES(I1) = ITMP |
| 26798 | ITMP = NOBAM(I0) |
| 26799 | NOBAM(I0) = NOBAM(I1) |
| 26800 | NOBAM(I1) = ITMP |
| 26801 | ITMP = IDBAM(I0) |
| 26802 | IDBAM(I0) = IDBAM(I1) |
| 26803 | IDBAM(I1) = ITMP |
| 26804 | ITMP = IDCH(I0) |
| 26805 | IDCH(I0) = IDCH(I1) |
| 26806 | IDCH(I1) = ITMP |
| 26807 | ITMP = IHIST(1,I0) |
| 26808 | IHIST(1,I0) = IHIST(1,I1) |
| 26809 | IHIST(1,I1) = ITMP |
| 26810 | ITMP = IHIST(2,I0) |
| 26811 | IHIST(2,I0) = IHIST(2,I1) |
| 26812 | IHIST(2,I1) = ITMP |
| 26813 | 22 CONTINUE |
| 26814 | ENDIF |
| 26815 | IST1 = ABS(ISTHKK(JMOHKK(1,IDX))) |
| 26816 | IST2 = ABS(ISTHKK(JMOHKK(2,IDX))) |
| 26817 | * |
| 26818 | * parton 1 (projectile side) |
| 26819 | IF (IST1.EQ.21) THEN |
| 26820 | IDX1 = 1 |
| 26821 | ELSEIF (IST1.EQ.22) THEN |
| 26822 | IDX1 = 2 |
| 26823 | ELSEIF (IST1.EQ.31) THEN |
| 26824 | IDX1 = 3 |
| 26825 | ELSEIF (IST1.EQ.32) THEN |
| 26826 | IDX1 = 4 |
| 26827 | ELSEIF (IST1.EQ.41) THEN |
| 26828 | IDX1 = 5 |
| 26829 | ELSEIF (IST1.EQ.42) THEN |
| 26830 | IDX1 = 6 |
| 26831 | ELSEIF (IST1.EQ.51) THEN |
| 26832 | IDX1 = 7 |
| 26833 | ELSEIF (IST1.EQ.52) THEN |
| 26834 | IDX1 = 8 |
| 26835 | ELSEIF (IST1.EQ.61) THEN |
| 26836 | IDX1 = 9 |
| 26837 | ELSEIF (IST1.EQ.62) THEN |
| 26838 | IDX1 = 10 |
| 26839 | ELSE |
| 26840 | c WRITE(LOUT,*) |
| 26841 | c & ' CHASTA: unknown parton status flag (', |
| 26842 | c & IST1,') at entry ',JMOHKK(1,IDX),'(',IDX,')' |
| 26843 | GOTO 21 |
| 26844 | ENDIF |
| 26845 | ID = IDHKK(JMOHKK(1,IDX)) |
| 26846 | IF (ABS(ID).LE.4) THEN |
| 26847 | IF (ID.GT.0) THEN |
| 26848 | ITYP1 = 1 |
| 26849 | ELSE |
| 26850 | ITYP1 = 2 |
| 26851 | ENDIF |
| 26852 | ELSEIF (ABS(ID).GE.1000) THEN |
| 26853 | IF (ID.GT.0) THEN |
| 26854 | ITYP1 = 3 |
| 26855 | ELSE |
| 26856 | ITYP1 = 4 |
| 26857 | ENDIF |
| 26858 | ELSEIF (ID.EQ.21) THEN |
| 26859 | ITYP1 = 5 |
| 26860 | ELSE |
| 26861 | WRITE(LOUT,*) |
| 26862 | & ' CHASTA: inconsistent parton identity (', |
| 26863 | & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')' |
| 26864 | GOTO 21 |
| 26865 | ENDIF |
| 26866 | * |
| 26867 | * parton 2 (target side) |
| 26868 | IF (IST2.EQ.21) THEN |
| 26869 | IDX2 = 1 |
| 26870 | ELSEIF (IST2.EQ.22) THEN |
| 26871 | IDX2 = 2 |
| 26872 | ELSEIF (IST2.EQ.31) THEN |
| 26873 | IDX2 = 3 |
| 26874 | ELSEIF (IST2.EQ.32) THEN |
| 26875 | IDX2 = 4 |
| 26876 | ELSEIF (IST2.EQ.41) THEN |
| 26877 | IDX2 = 5 |
| 26878 | ELSEIF (IST2.EQ.42) THEN |
| 26879 | IDX2 = 6 |
| 26880 | ELSEIF (IST2.EQ.51) THEN |
| 26881 | IDX2 = 7 |
| 26882 | ELSEIF (IST2.EQ.52) THEN |
| 26883 | IDX2 = 8 |
| 26884 | ELSEIF (IST2.EQ.61) THEN |
| 26885 | IDX2 = 9 |
| 26886 | ELSEIF (IST2.EQ.62) THEN |
| 26887 | IDX2 = 10 |
| 26888 | ELSE |
| 26889 | c WRITE(LOUT,*) |
| 26890 | c & ' CHASTA: unknown parton status flag (', |
| 26891 | c & IST2,') at entry ',JMOHKK(2,IDX),'(',IDX,')' |
| 26892 | GOTO 21 |
| 26893 | ENDIF |
| 26894 | ID = IDHKK(JMOHKK(2,IDX)) |
| 26895 | IF (ABS(ID).LE.4) THEN |
| 26896 | IF (ID.GT.0) THEN |
| 26897 | ITYP2 = 1 |
| 26898 | ELSE |
| 26899 | ITYP2 = 2 |
| 26900 | ENDIF |
| 26901 | ELSEIF (ABS(ID).GE.1000) THEN |
| 26902 | IF (ID.GT.0) THEN |
| 26903 | ITYP2 = 3 |
| 26904 | ELSE |
| 26905 | ITYP2 = 4 |
| 26906 | ENDIF |
| 26907 | ELSEIF (ID.EQ.21) THEN |
| 26908 | ITYP2 = 5 |
| 26909 | ELSE |
| 26910 | WRITE(LOUT,*) |
| 26911 | & ' CHASTA: inconsistent parton identity (', |
| 26912 | & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')' |
| 26913 | GOTO 21 |
| 26914 | ENDIF |
| 26915 | * |
| 26916 | * fill counter |
| 26917 | ITYPE = ICHTYP(ITYP1,ITYP2) |
| 26918 | IF (ITYPE.NE.0) THEN |
| 26919 | ICHCFG(IDX1,IDX2,ITYPE,1) =ICHCFG(IDX1,IDX2,ITYPE,1)+1 |
| 26920 | NGLUON = JMOHKK(2,IDX)-JMOHKK(1,IDX)-1 |
| 26921 | ICHCFG(IDX1,IDX2,ITYPE,2) = |
| 26922 | & ICHCFG(IDX1,IDX2,ITYPE,2)+NGLUON |
| 26923 | |
| 26924 | NCHAIN = NCHAIN+1 |
| 26925 | IF (NCHAIN.GT.MAXCHN) THEN |
| 26926 | WRITE(LOUT,*) ' CHASTA: NCHAIN > MAXCHN ! ', |
| 26927 | & NCHAIN,MAXCHN |
| 26928 | STOP |
| 26929 | ENDIF |
| 26930 | IDXCHN(1,NCHAIN) = IDX |
| 26931 | IDXCHN(2,NCHAIN) = ITYPE |
| 26932 | ELSE |
| 26933 | WRITE(LOUT,*) |
| 26934 | & ' CHASTA: inconsistent chain at entry ',IDX |
| 26935 | GOTO 21 |
| 26936 | ENDIF |
| 26937 | ENDIF |
| 26938 | 21 CONTINUE |
| 26939 | * |
| 26940 | * write statistics to output unit |
| 26941 | * |
| 26942 | ELSEIF (MODE.EQ.1) THEN |
| 26943 | C *** Commented by Chiara |
| 26944 | C WRITE(LOUT,'(/,A)') ' CHASTA: generated chain configurations' |
| 26945 | DO 31 I=1,10 |
| 26946 | C WRITE(LOUT,'(/,2A)') |
| 26947 | C & ' -----------------------------------------', |
| 26948 | C & '------------------------------------' |
| 26949 | C WRITE(LOUT,'(2A)') |
| 26950 | C & ' p\\t 21 22 31 32 41', |
| 26951 | C & ' 42 51 52 61 62' |
| 26952 | C WRITE(LOUT,'(2A)') |
| 26953 | C & ' -----------------------------------------', |
| 26954 | C & '------------------------------------' |
| 26955 | DO 32 J=1,10 |
| 26956 | ITOT(J) = 0 |
| 26957 | DO 33 K=1,9 |
| 26958 | ITOT(J) = ITOT(J)+ICHCFG(I,J,K,1) |
| 26959 | 33 CONTINUE |
| 26960 | 32 CONTINUE |
| 26961 | C *** Commented by Chiara |
| 26962 | c WRITE(LOUT,'(1X,I2,5X,10I7,/)') ICHSTA(I),(ITOT(J),J=1,10) |
| 26963 | DO 34 K=1,9 |
| 26964 | ISUM = 0 |
| 26965 | DO 35 J=1,10 |
| 26966 | ISUM = ISUM+ICHCFG(I,J,K,1) |
| 26967 | 35 CONTINUE |
| 26968 | C *** Commented by Chiara |
| 26969 | C IF (ISUM.GT.0) |
| 26970 | C & WRITE(LOUT,'(1X,A5,2X,10I7)') |
| 26971 | C & CCHTYP(K),(ICHCFG(I,J,K,1),J=1,10) |
| 26972 | 34 CONTINUE |
| 26973 | C WRITE(LOUT,'(2A)') |
| 26974 | C & ' -----------------------------------------', |
| 26975 | C & '-------------------------------' |
| 26976 | 31 CONTINUE |
| 26977 | * |
| 26978 | ELSE |
| 26979 | WRITE(LOUT,*) ' CHASTA: MODE ',MODE,' not supported !' |
| 26980 | STOP |
| 26981 | ENDIF |
| 26982 | |
| 26983 | RETURN |
| 26984 | END |
| 26985 | * |
| 26986 | *===pohist=============================================================* |
| 26987 | * |
| 26988 | |
| 26989 | CDECK ID>, PHO_PHIST |
| 26990 | SUBROUTINE PHO_PHIST(IMODE,WEIGHT) |
| 26991 | |
| 26992 | IMPLICIT DOUBLE PRECISION (A-H,O-X,Z) |
| 26993 | SAVE |
| 26994 | |
| 26995 | PARAMETER ( LINP = 5 , |
| 26996 | & LOUT = 6 , |
| 26997 | & LDAT = 9 ) |
| 26998 | |
| 26999 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 27000 | |
| 27001 | * Glauber formalism: cross sections |
| 27002 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, |
| 27003 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), |
| 27004 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), |
| 27005 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), |
| 27006 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), |
| 27007 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), |
| 27008 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), |
| 27009 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), |
| 27010 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), |
| 27011 | & BSLOPE,NEBINI,NQBINI |
| 27012 | |
| 27013 | ILAB = 0 |
| 27014 | IF (IMODE.EQ.10) THEN |
| 27015 | IMODE = 1 |
| 27016 | ILAB = 1 |
| 27017 | ENDIF |
| 27018 | IF (ABS(IMODE).LT.1000) THEN |
| 27019 | * PHOJET-statistics |
| 27020 | C CALL POHISX(IMODE,WEIGHT) |
| 27021 | IF (IMODE.EQ.-1) THEN |
| 27022 | MODE = 1 |
| 27023 | XSTOT(1,1,1) = WEIGHT |
| 27024 | ENDIF |
| 27025 | IF (IMODE.EQ. 1) MODE = 2 |
| 27026 | IF (IMODE.EQ.-2) MODE = 3 |
| 27027 | IF (MODE.EQ.2) CALL DT_SWPPHO(ILAB) |
| 27028 | C IF (MODE.EQ.3) WRITE(LOUT,*) |
| 27029 | C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization' |
| 27030 | CALL DT_HISTOG(MODE) |
| 27031 | CALL DT_USRHIS(MODE) |
| 27032 | ELSE |
| 27033 | * DTUNUC-statistics |
| 27034 | MODE = IMODE/1000 |
| 27035 | C IF (MODE.EQ.3) WRITE(LOUT,*) |
| 27036 | C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization' |
| 27037 | CALL DT_HISTOG(MODE) |
| 27038 | CALL DT_USRHIS(MODE) |
| 27039 | ENDIF |
| 27040 | |
| 27041 | RETURN |
| 27042 | END |
| 27043 | * |
| 27044 | *===swppho=============================================================* |
| 27045 | * |
| 27046 | CDECK ID>, DT_SWPPHO |
| 27047 | SUBROUTINE DT_SWPPHO(ILAB) |
| 27048 | |
| 27049 | IMPLICIT DOUBLE PRECISION (A-H,O-X,Z) |
| 27050 | SAVE |
| 27051 | |
| 27052 | PARAMETER ( LINP = 5 , |
| 27053 | & LOUT = 6 , |
| 27054 | & LDAT = 9 ) |
| 27055 | |
| 27056 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14) |
| 27057 | |
| 27058 | LOGICAL LSTART |
| 27059 | |
| 27060 | * event history |
| 27061 | |
| 27062 | PARAMETER (NMXHKK=200000) |
| 27063 | |
| 27064 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 27065 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 27066 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 27067 | * extended event history |
| 27068 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 27069 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 27070 | & IHIST(2,NMXHKK) |
| 27071 | * flags for input different options |
| 27072 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 27073 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 27074 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 27075 | * properties of photon/lepton projectiles |
| 27076 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC |
| 27077 | |
| 27078 | **PHOJET105a |
| 27079 | C PARAMETER (NMXHEP=2000) |
| 27080 | C COMMON/HEPEVS/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP), |
| 27081 | C &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP) |
| 27082 | C COMMON /GLOCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2) |
| 27083 | C COMMON /PLASAV/ PLAB |
| 27084 | **PHOJET110 |
| 27085 | |
| 27086 | C standard particle data interface |
| 27087 | INTEGER NMXHEP |
| 27088 | |
| 27089 | PARAMETER (NMXHEP=4000) |
| 27090 | |
| 27091 | INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP |
| 27092 | DOUBLE PRECISION PHEP,VHEP |
| 27093 | COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP), |
| 27094 | & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP), |
| 27095 | & VHEP(4,NMXHEP) |
| 27096 | C extension to standard particle data interface (PHOJET specific) |
| 27097 | INTEGER IMPART,IPHIST,ICOLOR |
| 27098 | COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP) |
| 27099 | |
| 27100 | C global event kinematics and particle IDs |
| 27101 | INTEGER IFPAP,IFPAB |
| 27102 | DOUBLE PRECISION ECM,PCM,PMASS,PVIRT |
| 27103 | COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2) |
| 27104 | ** |
| 27105 | DATA ICOUNT/0/ |
| 27106 | |
| 27107 | DATA LSTART /.TRUE./ |
| 27108 | |
| 27109 | C IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0).AND.LSTART) THEN |
| 27110 | IF ((IFRAME.EQ.1).AND.LSTART) THEN |
| 27111 | UMO = ECM |
| 27112 | ELA = ZERO |
| 27113 | PLA = ZERO |
| 27114 | IDP = IDT_ICIHAD(IFPAP(1)) |
| 27115 | IDT = IDT_ICIHAD(IFPAP(2)) |
| 27116 | VIRT = PVIRT(1) |
| 27117 | CALL DT_LTINI(IDP,IDT,ELA,PLA,UMO,0) |
| 27118 | PLAB = PLA |
| 27119 | LSTART = .FALSE. |
| 27120 | ENDIF |
| 27121 | |
| 27122 | NHKK = 0 |
| 27123 | ICOUNT = ICOUNT+1 |
| 27124 | C NEVHKK = NEVHEP |
| 27125 | NEVHKK = ICOUNT |
| 27126 | IF (MOD(ICOUNT,500).EQ.0) WRITE(LOUT,*)' SWPPHO: event # ',ICOUNT |
| 27127 | DO 1 I=3,NHEP |
| 27128 | IF (ISTHEP(I).EQ.1) THEN |
| 27129 | NHKK = NHKK+1 |
| 27130 | ISTHKK(NHKK) = 1 |
| 27131 | IDHKK(NHKK) = IDHEP(I) |
| 27132 | JMOHKK(1,NHKK) = 0 |
| 27133 | JMOHKK(2,NHKK) = 0 |
| 27134 | JDAHKK(1,NHKK) = 0 |
| 27135 | JDAHKK(2,NHKK) = 0 |
| 27136 | DO 2 K=1,4 |
| 27137 | PHKK(K,NHKK) = PHEP(K,I) |
| 27138 | VHKK(K,NHKK) = ZERO |
| 27139 | WHKK(K,NHKK) = ZERO |
| 27140 | 2 CONTINUE |
| 27141 | IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0)) |
| 27142 | & CALL DT_LTNUC(PHEP(3,I),PHEP(4,I), |
| 27143 | & PHKK(3,NHKK),PHKK(4,NHKK),-3) |
| 27144 | PHKK(5,NHKK) = PHEP(5,I) |
| 27145 | IDRES(NHKK) = 0 |
| 27146 | IDXRES(NHKK) = 0 |
| 27147 | NOBAM(NHKK) = 0 |
| 27148 | IDBAM(NHKK) = IDT_ICIHAD(IDHEP(I)) |
| 27149 | IDCH(NHKK) = 0 |
| 27150 | ENDIF |
| 27151 | 1 CONTINUE |
| 27152 | |
| 27153 | RETURN |
| 27154 | END |
| 27155 | * |
| 27156 | *===histog=============================================================* |
| 27157 | * |
| 27158 | CDECK ID>, DT_HISTOG |
| 27159 | SUBROUTINE DT_HISTOG(MODE) |
| 27160 | |
| 27161 | ************************************************************************ |
| 27162 | * This version dated 25.03.96 is written by S. Roesler * |
| 27163 | ************************************************************************ |
| 27164 | |
| 27165 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 27166 | SAVE |
| 27167 | |
| 27168 | PARAMETER ( LINP = 5 , |
| 27169 | & LOUT = 6 , |
| 27170 | & LDAT = 9 ) |
| 27171 | |
| 27172 | LOGICAL LFSP,LRNL |
| 27173 | |
| 27174 | * event history |
| 27175 | |
| 27176 | PARAMETER (NMXHKK=200000) |
| 27177 | |
| 27178 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 27179 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 27180 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 27181 | * extended event history |
| 27182 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 27183 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 27184 | & IHIST(2,NMXHKK) |
| 27185 | * event flag used for histograms |
| 27186 | COMMON /DTNORM/ ICEVT,IEVHKK |
| 27187 | * flags for activated histograms |
| 27188 | COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL |
| 27189 | |
| 27190 | IEVHKK = NEVHKK |
| 27191 | GOTO (1,2,3) MODE |
| 27192 | |
| 27193 | *------------------------------------------------------------------ |
| 27194 | * initialization |
| 27195 | 1 CONTINUE |
| 27196 | ICEVT = 0 |
| 27197 | IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,1) |
| 27198 | IF (IHISPP(2).EQ.1) CALL DT_HIMULT(1) |
| 27199 | |
| 27200 | RETURN |
| 27201 | *------------------------------------------------------------------ |
| 27202 | * filling of histogram with event-record |
| 27203 | 2 CONTINUE |
| 27204 | ICEVT = ICEVT+1 |
| 27205 | |
| 27206 | DO 20 I=1,NHKK |
| 27207 | CALL DT_SWPFSP(I,LFSP,LRNL) |
| 27208 | IF (LFSP) THEN |
| 27209 | IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,2) |
| 27210 | IF (IHISPP(2).EQ.1) CALL DT_HIMULT(2) |
| 27211 | ENDIF |
| 27212 | IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,5) |
| 27213 | 20 CONTINUE |
| 27214 | IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,4) |
| 27215 | |
| 27216 | RETURN |
| 27217 | *------------------------------------------------------------------ |
| 27218 | * output |
| 27219 | 3 CONTINUE |
| 27220 | IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,3) |
| 27221 | IF (IHISPP(2).EQ.1) CALL DT_HIMULT(3) |
| 27222 | |
| 27223 | RETURN |
| 27224 | END |
| 27225 | * |
| 27226 | *===swpfsp=============================================================* |
| 27227 | * |
| 27228 | CDECK ID>, DT_SWPFSP |
| 27229 | SUBROUTINE DT_SWPFSP(IDX,LFSP,LRNL) |
| 27230 | |
| 27231 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 27232 | SAVE |
| 27233 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14) |
| 27234 | PARAMETER (TWOPI=6.283185307179586476925286766559D+00, |
| 27235 | & PI =TWOPI/TWO, |
| 27236 | & BOG =TWOPI/360.0D0) |
| 27237 | |
| 27238 | * event history |
| 27239 | |
| 27240 | PARAMETER (NMXHKK=200000) |
| 27241 | |
| 27242 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 27243 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 27244 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 27245 | * extended event history |
| 27246 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 27247 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 27248 | & IHIST(2,NMXHKK) |
| 27249 | * particle properties (BAMJET index convention) |
| 27250 | CHARACTER*8 ANAME |
| 27251 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 27252 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 27253 | * Lorentz-parameters of the current interaction |
| 27254 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, |
| 27255 | & UMO,PPCM,EPROJ,PPROJ |
| 27256 | * flags for input different options |
| 27257 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 27258 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 27259 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 27260 | |
| 27261 | INCLUDE './flukapro/(DIMPAR)' |
| 27262 | INCLUDE './flukapro/(PAREVT)' |
| 27263 | |
| 27264 | * temporary storage for one final state particle |
| 27265 | LOGICAL LFRAG,LGREY,LBLACK |
| 27266 | COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN, |
| 27267 | & SINTHE,COSTHE,THETA,THECMS, |
| 27268 | & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF, |
| 27269 | & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF, |
| 27270 | & LFRAG,LGREY,LBLACK |
| 27271 | |
| 27272 | LOGICAL LFSP,LRNL |
| 27273 | |
| 27274 | LFSP = .FALSE. |
| 27275 | LRNL = .FALSE. |
| 27276 | ISTRNL = 1000 |
| 27277 | MULDEF = 1 |
| 27278 | IF (LEVPRT) ISTRNL = 1001 |
| 27279 | |
| 27280 | IF (ABS(ISTHKK(IDX)).EQ.1) THEN |
| 27281 | IST = ISTHKK(IDX) |
| 27282 | IDPDG = IDHKK(IDX) |
| 27283 | LFRAG = .FALSE. |
| 27284 | IF (IDHKK(IDX).LT.80000) THEN |
| 27285 | IDBJT = IDBAM(IDX) |
| 27286 | IBARY = IIBAR(IDBJT) |
| 27287 | ICHAR = IICH(IDBJT) |
| 27288 | AMASS = AAM(IDBJT) |
| 27289 | ELSEIF (IDHKK(IDX).EQ.80000) THEN |
| 27290 | IDBJT = 0 |
| 27291 | IBARY = IDRES(IDX) |
| 27292 | ICHAR = IDXRES(IDX) |
| 27293 | AMASS = PHKK(5,IDX) |
| 27294 | INUT = IBARY-ICHAR |
| 27295 | IF ((ICHAR.EQ.1).AND.(INUT.EQ.1)) IDBJT = 116 |
| 27296 | IF ((ICHAR.EQ.1).AND.(INUT.EQ.2)) IDBJT = 117 |
| 27297 | IF ((ICHAR.EQ.2).AND.(INUT.EQ.1)) IDBJT = 118 |
| 27298 | IF ((ICHAR.EQ.2).AND.(INUT.EQ.2)) IDBJT = 119 |
| 27299 | IF (IDBJT.EQ.0) LFRAG = .TRUE. |
| 27300 | ELSE |
| 27301 | GOTO 9999 |
| 27302 | ENDIF |
| 27303 | PE = PHKK(4,IDX) |
| 27304 | PX = PHKK(1,IDX) |
| 27305 | PY = PHKK(2,IDX) |
| 27306 | PZ = PHKK(3,IDX) |
| 27307 | PT2 = PX**2+PY**2 |
| 27308 | PT = SQRT(PT2) |
| 27309 | PTOT = SQRT(PT2+PZ**2) |
| 27310 | SINTHE = PT/MAX(PTOT,TINY14) |
| 27311 | COSTHE = PZ/MAX(PTOT,TINY14) |
| 27312 | IF (COSTHE.GT.ONE) THEN |
| 27313 | THETA = ZERO |
| 27314 | ELSEIF (COSTHE.LT.-ONE) THEN |
| 27315 | THETA = TWOPI/2.0D0 |
| 27316 | ELSE |
| 27317 | THETA = ACOS(COSTHE) |
| 27318 | ENDIF |
| 27319 | EKIN = PE-AMASS |
| 27320 | **sr 15.4.96 new E_t-definition |
| 27321 | IF (IBARY.GT.0) THEN |
| 27322 | ET = EKIN*SINTHE |
| 27323 | ELSEIF (IBARY.LT.0) THEN |
| 27324 | ET = (EKIN+TWO*AMASS)*SINTHE |
| 27325 | ELSE |
| 27326 | ET = PE*SINTHE |
| 27327 | ENDIF |
| 27328 | ** |
| 27329 | XLAB = PZ/MAX(PPROJ,TINY14) |
| 27330 | C XLAB = PE/MAX(EPROJ,TINY14) |
| 27331 | BETA = SQRT(ABS( (ONE-AMASS/MAX(PE,TINY14)) |
| 27332 | & *(ONE+AMASS/MAX(PE,TINY14)) )) |
| 27333 | PPLUS = PE+PZ |
| 27334 | PMINUS = PE-PZ |
| 27335 | IF (PMINUS.GT.TINY14) THEN |
| 27336 | YY = 0.5D0*LOG(ABS(PPLUS/PMINUS)) |
| 27337 | ELSE |
| 27338 | YY = 100.0D0 |
| 27339 | ENDIF |
| 27340 | IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN |
| 27341 | ETA = -LOG(TAN(THETA/TWO)) |
| 27342 | ELSE |
| 27343 | ETA = 100.0D0 |
| 27344 | ENDIF |
| 27345 | IF (IFRAME.EQ.1) THEN |
| 27346 | CALL DT_LTNUC(PZ,PE,PZCMS,EECMS,3) |
| 27347 | PPLUS = EECMS+PZCMS |
| 27348 | PMINUS = EECMS-PZCMS |
| 27349 | IF ((PPLUS*PMINUS).GT.TINY14) THEN |
| 27350 | YYCMS = 0.5D0*LOG(ABS(PPLUS/PMINUS)) |
| 27351 | ELSE |
| 27352 | YYCMS = 100.0D0 |
| 27353 | ENDIF |
| 27354 | PTOTCM = SQRT(PT2+PZCMS**2) |
| 27355 | COSTH = PZCMS/MAX(PTOTCM,TINY14) |
| 27356 | IF (COSTH.GT.ONE) THEN |
| 27357 | THECMS = ZERO |
| 27358 | ELSEIF (COSTH.LT.-ONE) THEN |
| 27359 | THECMS = TWOPI/2.0D0 |
| 27360 | ELSE |
| 27361 | THECMS = ACOS(COSTH) |
| 27362 | ENDIF |
| 27363 | IF ((THECMS.GT.TINY14).AND.((PI-THECMS).GT.TINY14)) THEN |
| 27364 | ETACMS = -LOG(TAN(THECMS/TWO)) |
| 27365 | ELSE |
| 27366 | ETACMS = 100.0D0 |
| 27367 | ENDIF |
| 27368 | XF = PZCMS/MAX(PPCM,TINY14) |
| 27369 | THECMS = THECMS/BOG |
| 27370 | ELSE |
| 27371 | PZCMS = PZ |
| 27372 | EECMS = PE |
| 27373 | YYCMS = YY |
| 27374 | ETACMS = ETA |
| 27375 | XF = XLAB |
| 27376 | THECMS = THETA/BOG |
| 27377 | ENDIF |
| 27378 | THETA = THETA/BOG |
| 27379 | |
| 27380 | * set flag for "grey/black" |
| 27381 | LGREY = .FALSE. |
| 27382 | LBLACK = .FALSE. |
| 27383 | EK = EKIN |
| 27384 | IF (IDHKK(IDX).EQ.80000) EK = EKIN/DBLE(IBARY) |
| 27385 | IF (MULDEF.EQ.1) THEN |
| 27386 | * EMU01-Def. |
| 27387 | IF ( ( (IDBJT.EQ. 1).AND.(EK.GT. 26.0D-3).AND. |
| 27388 | & (EK.LE.375.0D-3) ).OR. |
| 27389 | & ( (IDBJT.EQ.13).AND.(EK.GT. 12.0D-3).AND. |
| 27390 | & (EK.LE. 56.0D-3) ).OR. |
| 27391 | & ( (IDBJT.EQ.14).AND.(EK.GT. 12.0D-3).AND. |
| 27392 | & (EK.LE. 56.0D-3) ).OR. |
| 27393 | & ( (IDBJT.EQ.15).AND.(EK.GT. 20.0D-3).AND. |
| 27394 | & (EK.LE.198.0D-3) ).OR. |
| 27395 | & ( (IDBJT.EQ.16).AND.(EK.GT. 20.0D-3).AND. |
| 27396 | & (EK.LE.198.0D-3) ).OR. |
| 27397 | & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND. |
| 27398 | & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND. |
| 27399 | & (IDBJT.NE.16).AND. |
| 27400 | & (BETA.GT.0.23D0).AND.(BETA.LE.0.70D0) ) ) |
| 27401 | & LGREY = .TRUE. |
| 27402 | IF ( ( (IDBJT.EQ. 1).AND.(EK.LE. 26.0D-3) ).OR. |
| 27403 | & ( (IDBJT.EQ.13).AND.(EK.LE. 12.0D-3) ).OR. |
| 27404 | & ( (IDBJT.EQ.14).AND.(EK.LE. 12.0D-3) ).OR. |
| 27405 | & ( (IDBJT.EQ.15).AND.(EK.LE. 20.0D-3) ).OR. |
| 27406 | & ( (IDBJT.EQ.16).AND.(EK.LE. 20.0D-3) ).OR. |
| 27407 | & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND. |
| 27408 | & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND. |
| 27409 | & (IDBJT.NE.16).AND.(BETA.LE.0.23D0) ) ) |
| 27410 | & LBLACK = .TRUE. |
| 27411 | ELSE |
| 27412 | * common Def. |
| 27413 | IF ((BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)) LGREY=.TRUE. |
| 27414 | IF (BETA.LE.0.23D0) LBLACK=.TRUE. |
| 27415 | ENDIF |
| 27416 | LFSP = .TRUE. |
| 27417 | ELSEIF (ABS(ISTHKK(IDX)).EQ.ISTRNL) THEN |
| 27418 | IST = ISTHKK(IDX) |
| 27419 | IDPDG = IDHKK(IDX) |
| 27420 | LFRAG = .TRUE. |
| 27421 | IDBJT = 0 |
| 27422 | IBARY = IDRES(IDX) |
| 27423 | ICHAR = IDXRES(IDX) |
| 27424 | AMASS = PHKK(5,IDX) |
| 27425 | PE = PHKK(4,IDX) |
| 27426 | PX = PHKK(1,IDX) |
| 27427 | PY = PHKK(2,IDX) |
| 27428 | PZ = PHKK(3,IDX) |
| 27429 | PT2 = PX**2+PY**2 |
| 27430 | PT = SQRT(PT2) |
| 27431 | PTOT = SQRT(PT2+PZ**2) |
| 27432 | SINTHE = PT/MAX(PTOT,TINY14) |
| 27433 | COSTHE = PZ/MAX(PTOT,TINY14) |
| 27434 | IF (COSTHE.GT.ONE) THEN |
| 27435 | THETA = ZERO |
| 27436 | ELSEIF (COSTHE.LT.-ONE) THEN |
| 27437 | THETA = TWOPI/2.0D0 |
| 27438 | ELSE |
| 27439 | THETA = ACOS(COSTHE) |
| 27440 | ENDIF |
| 27441 | EKIN = PE-AMASS |
| 27442 | **sr 15.4.96 new E_t-definition |
| 27443 | C ET = PE*SINTHE |
| 27444 | ET = EKIN*SINTHE |
| 27445 | ** |
| 27446 | IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN |
| 27447 | ETA = -LOG(TAN(THETA/TWO)) |
| 27448 | ELSE |
| 27449 | ETA = 100.0D0 |
| 27450 | ENDIF |
| 27451 | THETA = THETA/BOG |
| 27452 | LRNL = .TRUE. |
| 27453 | ENDIF |
| 27454 | |
| 27455 | 9999 CONTINUE |
| 27456 | RETURN |
| 27457 | END |
| 27458 | * |
| 27459 | *===himult=============================================================* |
| 27460 | * |
| 27461 | CDECK ID>, DT_HIMULT |
| 27462 | SUBROUTINE DT_HIMULT(MODE) |
| 27463 | |
| 27464 | ************************************************************************ |
| 27465 | * Tables of average energies/multiplicities. * |
| 27466 | * This version dated 30.08.2000 is written by S. Roesler * |
| 27467 | ************************************************************************ |
| 27468 | |
| 27469 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 27470 | SAVE |
| 27471 | |
| 27472 | PARAMETER ( LINP = 5 , |
| 27473 | & LOUT = 6 , |
| 27474 | & LDAT = 9 ) |
| 27475 | |
| 27476 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14) |
| 27477 | |
| 27478 | PARAMETER (SWMEXP=1.7D0) |
| 27479 | |
| 27480 | CHARACTER*8 ANAMEH(4) |
| 27481 | |
| 27482 | * particle properties (BAMJET index convention) |
| 27483 | CHARACTER*8 ANAME |
| 27484 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 27485 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 27486 | * temporary storage for one final state particle |
| 27487 | LOGICAL LFRAG,LGREY,LBLACK |
| 27488 | COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN, |
| 27489 | & SINTHE,COSTHE,THETA,THECMS, |
| 27490 | & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF, |
| 27491 | & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF, |
| 27492 | & LFRAG,LGREY,LBLACK |
| 27493 | * event flag used for histograms |
| 27494 | COMMON /DTNORM/ ICEVT,IEVHKK |
| 27495 | * Lorentz-parameters of the current interaction |
| 27496 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, |
| 27497 | & UMO,PPCM,EPROJ,PPROJ |
| 27498 | |
| 27499 | PARAMETER (NOPART=210) |
| 27500 | DIMENSION AVMULT(4,NOPART),AVE(4,NOPART),AVSWM(4,NOPART), |
| 27501 | & AVPT(4,NOPART),IAVPT(4,NOPART) |
| 27502 | DATA ANAMEH /'DEUTERON','3-H ','3-HE ','4-HE '/ |
| 27503 | |
| 27504 | GOTO (1,2,3) MODE |
| 27505 | |
| 27506 | *------------------------------------------------------------------ |
| 27507 | * initialization |
| 27508 | 1 CONTINUE |
| 27509 | DO 10 I=1,NOPART |
| 27510 | DO 11 J=1,4 |
| 27511 | AVMULT(J,I) = ZERO |
| 27512 | AVE(J,I) = ZERO |
| 27513 | AVSWM(J,I) = ZERO |
| 27514 | AVPT(J,I) = ZERO |
| 27515 | IAVPT(J,I) = 0 |
| 27516 | 11 CONTINUE |
| 27517 | 10 CONTINUE |
| 27518 | |
| 27519 | RETURN |
| 27520 | |
| 27521 | *------------------------------------------------------------------ |
| 27522 | * filling of histogram with event-record |
| 27523 | 2 CONTINUE |
| 27524 | IF (PE.LT.0.0D0) THEN |
| 27525 | WRITE(LOUT,*) ' HIMULT: PE < 0 ! ',PE |
| 27526 | RETURN |
| 27527 | ENDIF |
| 27528 | IF (.NOT.LFRAG) THEN |
| 27529 | IVEL = 2 |
| 27530 | IF (LGREY) IVEL = 3 |
| 27531 | IF (LBLACK) IVEL = 4 |
| 27532 | AVE(1,IDBJT) = AVE(1,IDBJT) +PE |
| 27533 | AVE(IVEL,IDBJT) = AVE(IVEL,IDBJT)+PE |
| 27534 | AVPT(1,IDBJT) = AVPT(1,IDBJT) +PT |
| 27535 | AVPT(IVEL,IDBJT) = AVPT(IVEL,IDBJT)+PT |
| 27536 | IAVPT(1,IDBJT) = IAVPT(1,IDBJT) +1 |
| 27537 | IAVPT(IVEL,IDBJT) = IAVPT(IVEL,IDBJT)+1 |
| 27538 | AVSWM(1,IDBJT) = AVSWM(1,IDBJT) +PE**SWMEXP |
| 27539 | AVSWM(IVEL,IDBJT) = AVSWM(IVEL,IDBJT)+PE**SWMEXP |
| 27540 | AVMULT(1,IDBJT) = AVMULT(1,IDBJT) +ONE |
| 27541 | AVMULT(IVEL,IDBJT) = AVMULT(IVEL,IDBJT)+ONE |
| 27542 | IF (IDBJT.LT.116) THEN |
| 27543 | * total energy, multiplicity |
| 27544 | AVE(1,30) = AVE(1,30) +PE |
| 27545 | AVE(IVEL,30) = AVE(IVEL,30)+PE |
| 27546 | AVPT(1,30) = AVPT(1,30) +PT |
| 27547 | AVPT(IVEL,30) = AVPT(IVEL,30)+PT |
| 27548 | IAVPT(1,30) = IAVPT(1,30) +1 |
| 27549 | IAVPT(IVEL,30) = IAVPT(IVEL,30)+1 |
| 27550 | AVSWM(1,30) = AVSWM(1,30)+PE**SWMEXP |
| 27551 | AVSWM(IVEL,30) = AVSWM(IVEL,30)+PE**SWMEXP |
| 27552 | AVMULT(1,30) = AVMULT(1,30) +ONE |
| 27553 | AVMULT(IVEL,30) = AVMULT(IVEL,30)+ONE |
| 27554 | * charged energy, multiplicity |
| 27555 | IF (ICHAR.LT.0) THEN |
| 27556 | AVE(1,26) = AVE(1,26) +PE |
| 27557 | AVE(IVEL,26) = AVE(IVEL,26)+PE |
| 27558 | AVPT(1,26) = AVPT(1,26) +PT |
| 27559 | AVPT(IVEL,26) = AVPT(IVEL,26)+PT |
| 27560 | IAVPT(1,26) = IAVPT(1,26) +1 |
| 27561 | IAVPT(IVEL,26) = IAVPT(IVEL,26)+1 |
| 27562 | AVSWM(1,26) = AVSWM(1,26) +PE**SWMEXP |
| 27563 | AVSWM(IVEL,26) = AVSWM(IVEL,26)+PE**SWMEXP |
| 27564 | AVMULT(1,26) = AVMULT(1,26) +ONE |
| 27565 | AVMULT(IVEL,26) = AVMULT(IVEL,26)+ONE |
| 27566 | ENDIF |
| 27567 | IF (ICHAR.NE.0) THEN |
| 27568 | AVE(1,27) = AVE(1,27) +PE |
| 27569 | AVE(IVEL,27) = AVE(IVEL,27)+PE |
| 27570 | AVPT(1,27) = AVPT(1,27) +PT |
| 27571 | AVPT(IVEL,27) = AVPT(IVEL,27)+PT |
| 27572 | IAVPT(1,27) = IAVPT(1,27) +1 |
| 27573 | IAVPT(IVEL,27) = IAVPT(IVEL,27)+1 |
| 27574 | AVSWM(1,27) = AVSWM(1,27) +PE**SWMEXP |
| 27575 | AVSWM(IVEL,27) = AVSWM(IVEL,27)+PE**SWMEXP |
| 27576 | AVMULT(1,27) = AVMULT(1,27) +ONE |
| 27577 | AVMULT(IVEL,27) = AVMULT(IVEL,27)+ONE |
| 27578 | ENDIF |
| 27579 | ENDIF |
| 27580 | ENDIF |
| 27581 | |
| 27582 | RETURN |
| 27583 | |
| 27584 | *------------------------------------------------------------------ |
| 27585 | * output |
| 27586 | 3 CONTINUE |
| 27587 | WRITE(LOUT,3000) |
| 27588 | 3000 FORMAT(/,1X,'HIMULT:',21X,'particle - statistics',/, |
| 27589 | & 29X,'---------------------',/) |
| 27590 | PRINT*,' MULDEF = ',MULDEF |
| 27591 | IF (MULDEF.EQ.1) THEN |
| 27592 | WRITE(LOUT,'(1X,A,/)') 'fast/grey/black: EMU-def.' |
| 27593 | ELSE |
| 27594 | BETGRE = 0.7D0 |
| 27595 | BETBLC = 0.23D0 |
| 27596 | WRITE(LOUT,3002) BETGRE,BETGRE,BETBLC,BETBLC |
| 27597 | 3002 FORMAT(1X,'fast: beta > ',F4.2,' grey: ',F4.2,' > beta > ' |
| 27598 | & ,F4.2,' black: beta < ',F4.2,/) |
| 27599 | ENDIF |
| 27600 | WRITE(LOUT,3003) SWMEXP |
| 27601 | 3003 FORMAT(1X,'particle |',12X,'average multiplicity',/, |
| 27602 | & 13X,'| total fast', |
| 27603 | C & ' grey black K f(',F3.1,')',/,1X, |
| 27604 | & ' grey black <pt> f(',F3.1,')',/,1X, |
| 27605 | & '------------+--------------', |
| 27606 | & '-------------------------------------------------') |
| 27607 | DO 30 I=1,NOPART |
| 27608 | DO 31 J=1,4 |
| 27609 | AVMULT(J,I) = AVMULT(J,I)/DBLE(MAX(ICEVT,1)) |
| 27610 | AVE(J,I) = AVE(J,I)/DBLE(MAX(ICEVT,1))/EPROJ |
| 27611 | AVPT(J,I) = AVPT(J,I)/DBLE(MAX(IAVPT(J,I),1)) |
| 27612 | AVSWM(J,I) = AVSWM(J,I)/DBLE(MAX(ICEVT,1))/EPROJ**SWMEXP |
| 27613 | 31 CONTINUE |
| 27614 | IF (I.LE.115) THEN |
| 27615 | WRITE(LOUT,3004) ANAME(I),I, |
| 27616 | & AVMULT(1,I),AVMULT(2,I), |
| 27617 | & AVMULT(3,I),AVMULT(4,I), |
| 27618 | C & AVE(1,I),AVSWM(1,I) |
| 27619 | & AVPT(1,I),AVSWM(1,I) |
| 27620 | ELSEIF (I.LE.119) THEN |
| 27621 | WRITE(LOUT,3004) ANAMEH(I-115),I, |
| 27622 | & AVMULT(1,I),AVMULT(2,I), |
| 27623 | & AVMULT(3,I),AVMULT(4,I), |
| 27624 | C & AVE(1,I),AVSWM(1,I) |
| 27625 | & AVPT(1,I),AVSWM(1,I) |
| 27626 | ENDIF |
| 27627 | 3004 FORMAT(1X,A8,I4,'| ',2F13.6,2F9.5,2F9.5) |
| 27628 | 30 CONTINUE |
| 27629 | **temporary |
| 27630 | C WRITE(LOUT,'(A,F7.3)') ' number of charged heavy particles: ', |
| 27631 | C & AVMULT(3,27)+AVMULT(4,27) |
| 27632 | ** |
| 27633 | |
| 27634 | RETURN |
| 27635 | END |
| 27636 | * |
| 27637 | *===histat=============================================================* |
| 27638 | * |
| 27639 | CDECK ID>, DT_HISTAT |
| 27640 | SUBROUTINE DT_HISTAT(IDX,MODE) |
| 27641 | |
| 27642 | ************************************************************************ |
| 27643 | * This version dated 26.02.96 is written by S. Roesler * |
| 27644 | ************************************************************************ |
| 27645 | |
| 27646 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 27647 | SAVE |
| 27648 | |
| 27649 | PARAMETER ( LINP = 5 , |
| 27650 | & LOUT = 6 , |
| 27651 | & LDAT = 9 ) |
| 27652 | |
| 27653 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14) |
| 27654 | PARAMETER (NDIM=199) |
| 27655 | |
| 27656 | * event history |
| 27657 | |
| 27658 | PARAMETER (NMXHKK=200000) |
| 27659 | |
| 27660 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 27661 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 27662 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 27663 | * extended event history |
| 27664 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 27665 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 27666 | & IHIST(2,NMXHKK) |
| 27667 | * particle properties (BAMJET index convention) |
| 27668 | CHARACTER*8 ANAME |
| 27669 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 27670 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 27671 | |
| 27672 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 27673 | |
| 27674 | * Glauber formalism: cross sections |
| 27675 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, |
| 27676 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), |
| 27677 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), |
| 27678 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), |
| 27679 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), |
| 27680 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), |
| 27681 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), |
| 27682 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), |
| 27683 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), |
| 27684 | & BSLOPE,NEBINI,NQBINI |
| 27685 | * emulsion treatment |
| 27686 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), |
| 27687 | & NCOMPO,IEMUL |
| 27688 | * properties of interacting particles |
| 27689 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG |
| 27690 | * rejection counter |
| 27691 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, |
| 27692 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, |
| 27693 | & IREXCI(3),IRDIFF(2),IRINC |
| 27694 | * statistics: residual nuclei |
| 27695 | COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2), |
| 27696 | & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2), |
| 27697 | & NINCST(2,4),NINCEV(2), |
| 27698 | & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2), |
| 27699 | & NRESPB(2),NRESCH(2),NRESEV(4), |
| 27700 | & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240), |
| 27701 | & NEVAFI(2,2) |
| 27702 | * parameter for intranuclear cascade |
| 27703 | LOGICAL LPAULI |
| 27704 | COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI |
| 27705 | |
| 27706 | INCLUDE './flukapro/(DIMPAR)' |
| 27707 | INCLUDE './flukapro/(PAREVT)' |
| 27708 | INCLUDE './flukapro/(FRBKCM)' |
| 27709 | INCLUDE './flukapro/(EVAPAR)' |
| 27710 | |
| 27711 | * temporary storage for one final state particle |
| 27712 | LOGICAL LFRAG,LGREY,LBLACK |
| 27713 | COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN, |
| 27714 | & SINTHE,COSTHE,THETA,THECMS, |
| 27715 | & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF, |
| 27716 | & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF, |
| 27717 | & LFRAG,LGREY,LBLACK |
| 27718 | * event flag used for histograms |
| 27719 | COMMON /DTNORM/ ICEVT,IEVHKK |
| 27720 | * statistics: double-Pomeron exchange |
| 27721 | COMMON /DTFLG2/ INTFLG,IPOPO |
| 27722 | |
| 27723 | DIMENSION EMUSAM(NCOMPX) |
| 27724 | |
| 27725 | CHARACTER*13 CMSG(3) |
| 27726 | DATA CMSG /'not requested','not requested','not requested'/ |
| 27727 | |
| 27728 | GOTO (1,2,3,4,5) MODE |
| 27729 | |
| 27730 | *------------------------------------------------------------------ |
| 27731 | * initialization |
| 27732 | 1 CONTINUE |
| 27733 | * emulsion treatment |
| 27734 | IF (NCOMPO.GT.0) THEN |
| 27735 | DO 10 I=1,NCOMPX |
| 27736 | EMUSAM(I) = ZERO |
| 27737 | 10 CONTINUE |
| 27738 | ENDIF |
| 27739 | * common /DTSTA2/, statistics on i.n.c., residual nuclei, evap. |
| 27740 | NINCGE = 0 |
| 27741 | DO 11 I=1,2 |
| 27742 | EXCDPM(I) = ZERO |
| 27743 | EXCDPM(I+2) = ZERO |
| 27744 | EXCEVA(I) = ZERO |
| 27745 | NINCWO(I) = 0 |
| 27746 | NINCEV(I) = 0 |
| 27747 | NRESTO(I) = 0 |
| 27748 | NRESPR(I) = 0 |
| 27749 | NRESNU(I) = 0 |
| 27750 | NRESBA(I) = 0 |
| 27751 | NRESPB(I) = 0 |
| 27752 | NRESCH(I) = 0 |
| 27753 | NRESEV(I) = 0 |
| 27754 | NRESEV(I+2) = 0 |
| 27755 | NEVAGA(I) = 0 |
| 27756 | NEVAHT(I) = 0 |
| 27757 | NEVAFI(1,I) = 0 |
| 27758 | NEVAFI(2,I) = 0 |
| 27759 | DO 12 J=1,6 |
| 27760 | IF (J.LE.2) NINCHR(I,J) = 0 |
| 27761 | IF (J.LE.3) NINCCO(I,J) = 0 |
| 27762 | IF (J.LE.4) NINCST(I,J) = 0 |
| 27763 | NEVA(I,J) = 0 |
| 27764 | 12 CONTINUE |
| 27765 | DO 13 J=1,210 |
| 27766 | NEVAHY(1,I,J) = 0 |
| 27767 | NEVAHY(2,I,J) = 0 |
| 27768 | 13 CONTINUE |
| 27769 | 11 CONTINUE |
| 27770 | MAXGEN = 0 |
| 27771 | **dble Po statistics. |
| 27772 | KPOPO = 0 |
| 27773 | |
| 27774 | RETURN |
| 27775 | *------------------------------------------------------------------ |
| 27776 | * filling of histogram with event-record |
| 27777 | 2 CONTINUE |
| 27778 | IF (IST.EQ.-1) THEN |
| 27779 | IF (.NOT.LFRAG) THEN |
| 27780 | IF (IDPDG.EQ.2212) THEN |
| 27781 | NEVA(NOBAM(IDX),1) = NEVA(NOBAM(IDX),1)+1 |
| 27782 | ELSEIF (IDPDG.EQ.2112) THEN |
| 27783 | NEVA(NOBAM(IDX),2) = NEVA(NOBAM(IDX),2)+1 |
| 27784 | ELSEIF (IDPDG.EQ.22) THEN |
| 27785 | NEVAGA(NOBAM(IDX)) = NEVAGA(NOBAM(IDX))+1 |
| 27786 | ELSEIF (IDPDG.EQ.80000) THEN |
| 27787 | IF (IDBJT.EQ.116) THEN |
| 27788 | NEVA(NOBAM(IDX),3) = NEVA(NOBAM(IDX),3)+1 |
| 27789 | ELSEIF (IDBJT.EQ.117) THEN |
| 27790 | NEVA(NOBAM(IDX),4) = NEVA(NOBAM(IDX),4)+1 |
| 27791 | ELSEIF (IDBJT.EQ.118) THEN |
| 27792 | NEVA(NOBAM(IDX),5) = NEVA(NOBAM(IDX),5)+1 |
| 27793 | ELSEIF (IDBJT.EQ.119) THEN |
| 27794 | NEVA(NOBAM(IDX),6) = NEVA(NOBAM(IDX),6)+1 |
| 27795 | ENDIF |
| 27796 | ENDIF |
| 27797 | ELSE |
| 27798 | * heavy fragments (here: fission products only) |
| 27799 | NEVAHY(NOBAM(IDX),1,IBARY) = NEVAHY(NOBAM(IDX),1,IBARY)+1 |
| 27800 | NEVAHY(NOBAM(IDX),2,ICHAR) = NEVAHY(NOBAM(IDX),2,ICHAR)+1 |
| 27801 | NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1 |
| 27802 | ENDIF |
| 27803 | ELSEIF ((IST.EQ.1).AND.(.NOT.LFRAG)) THEN |
| 27804 | IF (IDCH(IDX).GT.MAXGEN) MAXGEN = IDCH(IDX) |
| 27805 | ENDIF |
| 27806 | |
| 27807 | RETURN |
| 27808 | *------------------------------------------------------------------ |
| 27809 | * output |
| 27810 | 3 CONTINUE |
| 27811 | |
| 27812 | **dble Po statistics. |
| 27813 | C WRITE(LOUT,'(1X,A,2I7,2E12.4)') |
| 27814 | C & '# evts. / # dble-Po. evts / s_in / s_popo :', |
| 27815 | C & ICEVT,KPOPO,XSPRO(1,1,1),XSPRO(1,1,1)*DBLE(KPOPO)/DBLE(ICEVT) |
| 27816 | |
| 27817 | * emulsion treatment |
| 27818 | IF (NCOMPO.GT.0) THEN |
| 27819 | WRITE(LOUT,3000) |
| 27820 | 3000 FORMAT(/,1X,'HISTAT:',14X,'statistics - target emulsion',/, |
| 27821 | & 22X,'----------------------------',/,/,19X, |
| 27822 | & 'mass charge fraction',/,39X, |
| 27823 | & 'input treated',/) |
| 27824 | DO 30 I=1,NCOMPO |
| 27825 | WRITE(LOUT,3013) I,IEMUMA(I),IEMUCH(I),EMUFRA(I), |
| 27826 | & EMUSAM(I)/DBLE(ICEVT) |
| 27827 | 3013 FORMAT(12X,I2,1X,2I8,6X,F7.3,5X,F7.3) |
| 27828 | 30 CONTINUE |
| 27829 | ENDIF |
| 27830 | |
| 27831 | * i.n.c. statistics: output |
| 27832 | WRITE(LOUT,3001) ICEVT,NRESEV(2),IRINC |
| 27833 | 3001 FORMAT(/,1X,'HISTAT:',14X,'statistics - intranuclear cascade',/, |
| 27834 | & 22X,'---------------------------------',/,/,1X, |
| 27835 | & 'no. of events for normalization: (accepted final events,', |
| 27836 | & ' evt)',4X,I6,/,34X,'(events before evap.-step, evt1)',I6, |
| 27837 | & /,1X,'no. of rejected events due to intranuclear', |
| 27838 | & ' cascade',15X,I6,/) |
| 27839 | ICEV = MAX(ICEVT,1) |
| 27840 | ICEV1 = ICEV |
| 27841 | IF (LEVPRT) ICEV1 = MAX(NRESEV(2),1) |
| 27842 | WRITE(LOUT,3002) |
| 27843 | & (DBLE(NINCWO(I))/DBLE(ICEV),I=1,2), |
| 27844 | & ((DBLE(NINCST(I,J))/DBLE(ICEV),I=1,2),J=1,4), |
| 27845 | & KTAUGE,DBLE(NINCGE)/DBLE(ICEV), |
| 27846 | & (DBLE(NINCCO(I,1)+NINCCO(I,2)+NINCCO(I,3))/DBLE(ICEV1),I=1,2), |
| 27847 | & (DBLE(NINCCO(I,2))/DBLE(ICEV1),I=1,2), |
| 27848 | & (DBLE(NINCCO(I,3))/DBLE(ICEV1),I=1,2), |
| 27849 | & (DBLE(NINCCO(I,1))/DBLE(ICEV1),I=1,2) |
| 27850 | 3002 FORMAT(1X,'no. of wounded nucl. in proj./ target (mean per evt)', |
| 27851 | & 5X,F6.2,' /',F6.2,/,1X,'no. of particles unable to escape', |
| 27852 | & ' proj./ target (mean per evt)',/,8X,'baryons: pos. ', |
| 27853 | & F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3,/,8X, |
| 27854 | & 'mesons: pos. ',F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3, |
| 27855 | & /,1X,'maximum no. of generations treated (maximum allowed:' |
| 27856 | & ,I4,')',/,43X,'(mean per evt)',5X,F6.2,/,1X,'no. of sec.', |
| 27857 | & ' interactions in proj./ target (mean per evt1)', |
| 27858 | & F7.3,' /',F7.3,/,8X,'out of which by inelastic', |
| 27859 | & ' interactions',12X,F7.3,' /',F7.3,/,21X,'by elastic ', |
| 27860 | & 'interactions',14X,F7.3,' /',F7.3,/,21X,'by absorption ', |
| 27861 | & '(ap, K-, pi- only) ',F7.3,' /',F7.3,/) |
| 27862 | WRITE(LOUT,3003) NRESEV(2),NRESEV(4),IREXCI, |
| 27863 | & IREXCI(1)+IREXCI(2)+IREXCI(3) |
| 27864 | 3003 FORMAT(/,1X,'HISTAT:',14X,'statistics - residual nuclei, ', |
| 27865 | & 'evaporation',/,22X,'-----------------------------', |
| 27866 | & '------------',/,/,1X,'no. of events for normal.: ', |
| 27867 | & '(events handled by FICONF, evt)',7X,I6,/,28X,'(events', |
| 27868 | & ' passing the evap.-step, evt1) ',I6,/,1X,'no. of', |
| 27869 | & ' rejected events (',I4,',',I4,',',I4,')',22X,I6,/) |
| 27870 | |
| 27871 | WRITE(LOUT,3004) |
| 27872 | 3004 FORMAT(/,22X,'1) before evaporation-step:',/) |
| 27873 | ICEV = MAX(NRESEV(2),1) |
| 27874 | WRITE(LOUT,3005) |
| 27875 | & (DBLE(NRESTO(I))/DBLE(ICEV),I=1,2), |
| 27876 | & (DBLE(NRESPR(I))/DBLE(ICEV),I=1,2), |
| 27877 | & (DBLE(NRESNU(I))/DBLE(ICEV),I=1,2), |
| 27878 | & (DBLE(NRESBA(I))/DBLE(ICEV),I=1,2), |
| 27879 | & (DBLE(NRESPB(I))/DBLE(ICEV),I=1,2), |
| 27880 | & (DBLE(NRESCH(I))/DBLE(ICEV),I=1,2), |
| 27881 | & (EXCDPM(I)/DBLE(ICEV),I=1,2), |
| 27882 | & (EXCDPM(I+2)/DBLE(ICEV),I=1,2) |
| 27883 | 3005 FORMAT(1X,'residual nuclei: (mean values per evt)',12X, |
| 27884 | & 'proj. / target',/,/,8X,'total number of particles',15X, |
| 27885 | & 2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X, |
| 27886 | & 'neutrons',18X,2F9.3,/,22X,'baryons',19X,2F9.3,/,22X, |
| 27887 | & 'pos. baryons',14X,2F9.3,/,8X,'total charge',28X,2F9.3,/, |
| 27888 | & /,8X,'excitation energy (bef. evap.-step) ',2E11.3,/, |
| 27889 | & 8X,'excitation energy per nucleon ',2E11.3,/,/) |
| 27890 | |
| 27891 | * evaporation / fission / fragmentation statistics: output |
| 27892 | ICEV = MAX(NRESEV(2),1) |
| 27893 | ICEV1 = MAX(NRESEV(4),1) |
| 27894 | NTEVA1 = |
| 27895 | & NEVA(1,1)+NEVA(1,2)+NEVA(1,3)+NEVA(1,4)+NEVA(1,5)+NEVA(1,6) |
| 27896 | NTEVA2 = |
| 27897 | & NEVA(2,1)+NEVA(2,2)+NEVA(2,3)+NEVA(2,4)+NEVA(2,5)+NEVA(2,6) |
| 27898 | IF (LEVPRT) THEN |
| 27899 | IF (IFISS.EQ.1) CMSG(1) = 'requested ' |
| 27900 | IF (LFRMBK) CMSG(2) = 'requested ' |
| 27901 | IF (LDEEXG) CMSG(3) = 'requested ' |
| 27902 | WRITE(LOUT,3006) |
| 27903 | & CMSG, |
| 27904 | & DBLE(NTEVA1)/DBLE(ICEV1),DBLE(NTEVA2)/DBLE(ICEV1), |
| 27905 | & (DBLE(NEVA(I,1))/DBLE(ICEV1),I=1,2), |
| 27906 | & (DBLE(NEVA(I,2))/DBLE(ICEV1),I=1,2), |
| 27907 | & (DBLE(NEVA(I,3))/DBLE(ICEV1),I=1,2), |
| 27908 | & (DBLE(NEVA(I,4))/DBLE(ICEV1),I=1,2), |
| 27909 | & (DBLE(NEVA(I,5))/DBLE(ICEV1),I=1,2), |
| 27910 | & (DBLE(NEVA(I,6))/DBLE(ICEV1),I=1,2), |
| 27911 | & (DBLE(NEVAGA(I))/DBLE(ICEV1),I=1,2), |
| 27912 | & (DBLE(NEVAHT(I))/DBLE(ICEV1),I=1,2) |
| 27913 | 3006 FORMAT(22X,'2) after evaporation-step:',/,/,1X,'Fission:', |
| 27914 | & 13X,A13,/,1X,'Fermi-Break-up:',6X,A13,/,1X,'Gamma-', |
| 27915 | & 'deexcitation:',2X,A13,/,/, |
| 27916 | & 1X,'evaporation/deexcitation: (mean values per evt1) ', |
| 27917 | & 'proj. / target',/,/,8X,'total number of evap. particles', |
| 27918 | & 9X,2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X, |
| 27919 | & 'neutrons',18X,2F9.3,/,22X,'deuterons',17X,2F9.3,/,22X, |
| 27920 | & '3-H',23X,2F9.3,/,22X,'3-He',22X,2F9.3,/,22X,'4-He',22X, |
| 27921 | & 2F9.3,/,8X,'nucl. deexcit. gammas',19X,2F9.3,/,8X, |
| 27922 | & 'heavy fragments',25X,2F9.3,/) |
| 27923 | IF (IFISS.EQ.1) THEN |
| 27924 | WRITE(LOUT,3007) NEVAFI(1,1),NEVAFI(1,2), |
| 27925 | & NEVAFI(2,1),NEVAFI(2,2), |
| 27926 | & DBLE(NEVAFI(2,1))/DBLE(MAX(NEVAFI(1,1),1))*100.0D0, |
| 27927 | & DBLE(NEVAFI(2,2))/DBLE(MAX(NEVAFI(1,2),1))*100.0D0 |
| 27928 | 3007 FORMAT(1X,'Fission: total number of events',14X,2I9,/ |
| 27929 | & 12X,'out of which fission occured',8X,2I9,/, |
| 27930 | & 50X,'(',F5.2,'%) (',F5.2,'%)',/) |
| 27931 | ENDIF |
| 27932 | C IF ((LFRMBK).OR.(IFISS.EQ.1)) THEN |
| 27933 | C WRITE(LOUT,3008) |
| 27934 | C3008 FORMAT(1X,'heavy fragments - statistics:',7X,'charge', |
| 27935 | C & ' proj. / target',/) |
| 27936 | C DO 31 I=1,210 |
| 27937 | C IF ((NEVAHY(1,2,I).NE.0).OR.(NEVAHY(2,2,I).NE.0)) THEN |
| 27938 | C WRITE(LOUT,3009) I, |
| 27939 | C & (DBLE(NEVAHY(K,2,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2) |
| 27940 | C3009 FORMAT(38X,I3,3X,2E12.3) |
| 27941 | C ENDIF |
| 27942 | C 31 CONTINUE |
| 27943 | C WRITE(LOUT,3010) |
| 27944 | C3010 FORMAT(1X,'heavy fragments - statistics:',7X,'mass ', |
| 27945 | C & ' proj. / target',/) |
| 27946 | C DO 32 I=1,210 |
| 27947 | C IF ((NEVAHY(1,1,I).NE.0).OR.(NEVAHY(2,1,I).NE.0)) THEN |
| 27948 | C WRITE(LOUT,3011) I, |
| 27949 | C & (DBLE(NEVAHY(K,1,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2) |
| 27950 | C3011 FORMAT(38X,I3,3X,2E12.3) |
| 27951 | C ENDIF |
| 27952 | C 32 CONTINUE |
| 27953 | C WRITE(LOUT,*) |
| 27954 | C ENDIF |
| 27955 | ELSE |
| 27956 | WRITE(LOUT,3012) |
| 27957 | 3012 FORMAT(22X,'2) after evaporation-step:',/,/,1X, |
| 27958 | & 'Evaporation: not requested',/) |
| 27959 | ENDIF |
| 27960 | |
| 27961 | RETURN |
| 27962 | *------------------------------------------------------------------ |
| 27963 | * filling of histogram with event-record |
| 27964 | 4 CONTINUE |
| 27965 | * emulsion treatment |
| 27966 | IF (NCOMPO.GT.0) THEN |
| 27967 | DO 40 I=1,NCOMPO |
| 27968 | IF (IT.EQ.IEMUMA(I)) THEN |
| 27969 | EMUSAM(I) = EMUSAM(I)+ONE |
| 27970 | ENDIF |
| 27971 | 40 CONTINUE |
| 27972 | ENDIF |
| 27973 | NINCGE = NINCGE+MAXGEN |
| 27974 | MAXGEN = 0 |
| 27975 | **dble Po statistics. |
| 27976 | IF (IPOPO.EQ.1) KPOPO = KPOPO+1 |
| 27977 | |
| 27978 | RETURN |
| 27979 | *------------------------------------------------------------------ |
| 27980 | * filling of histogram with event-record |
| 27981 | 5 CONTINUE |
| 27982 | IF ((ISTHKK(IDX).EQ.15).OR.(ISTHKK(IDX).EQ.16)) THEN |
| 27983 | IB = IIBAR(IDBAM(IDX)) |
| 27984 | IC = IICH(IDBAM(IDX)) |
| 27985 | J = ISTHKK(IDX)-14 |
| 27986 | IF ( ((ABS(IB).EQ.1).AND.(IC.EQ.1)).OR.(IC.EQ.0) ) THEN |
| 27987 | NINCST(J,1) = NINCST(J,1)+1 |
| 27988 | ELSEIF ((ABS(IB).EQ.1).AND.(IC.EQ.-1)) THEN |
| 27989 | NINCST(J,2) = NINCST(J,2)+1 |
| 27990 | ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ. 1)) THEN |
| 27991 | NINCST(J,3) = NINCST(J,3)+1 |
| 27992 | ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ.-1)) THEN |
| 27993 | NINCST(J,4) = NINCST(J,4)+1 |
| 27994 | ENDIF |
| 27995 | ELSEIF (ISTHKK(IDX).EQ.17) THEN |
| 27996 | NINCWO(1) = NINCWO(1)+1 |
| 27997 | ELSEIF (ISTHKK(IDX).EQ.18) THEN |
| 27998 | NINCWO(2) = NINCWO(2)+1 |
| 27999 | ELSEIF (ISTHKK(IDX).EQ.1001) THEN |
| 28000 | IB = IDRES(IDX) |
| 28001 | IC = IDXRES(IDX) |
| 28002 | IF (IC.GT.0) THEN |
| 28003 | NEVAHY(NOBAM(IDX),1,IB) = NEVAHY(NOBAM(IDX),1,IB)+1 |
| 28004 | NEVAHY(NOBAM(IDX),2,IC) = NEVAHY(NOBAM(IDX),2,IC)+1 |
| 28005 | ENDIF |
| 28006 | NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1 |
| 28007 | ENDIF |
| 28008 | |
| 28009 | RETURN |
| 28010 | END |
| 28011 | * |
| 28012 | *===newhgr=============================================================* |
| 28013 | * |
| 28014 | CDECK ID>, DT_NEWHGR |
| 28015 | SUBROUTINE DT_NEWHGR(XLIM1,XLIM2,XLIM3,XLIMB,IBIN,IREFN) |
| 28016 | |
| 28017 | ************************************************************************ |
| 28018 | * * |
| 28019 | * Histogram initialization. * |
| 28020 | * * |
| 28021 | * input: XLIM1/XLIM2 lower/upper edge of histogram-window * |
| 28022 | * XLIM3 bin size * |
| 28023 | * IBIN > 0 number of bins in equidistant lin. binning * |
| 28024 | * = -1 reset histograms * |
| 28025 | * < -1 |IBIN| number of bins in equidistant log. * |
| 28026 | * binning or log. binning in user def. struc. * |
| 28027 | * XLIMB(*) user defined bin structure * |
| 28028 | * * |
| 28029 | * The bin structure is sensitive to * |
| 28030 | * XLIM1, XLIM3, IBIN if XLIM3 > 0 (lin.) * |
| 28031 | * XLIM1, XLIM2, IBIN if XLIM3 = 0 (lin. & log.) * |
| 28032 | * XLIMB, IBIN if XLIM3 < 0 * |
| 28033 | * * |
| 28034 | * * |
| 28035 | * output: IREFN histogram index * |
| 28036 | * (= -1 for inconsistent histogr. request) * |
| 28037 | * * |
| 28038 | * This subroutine is based on a original version by R. Engel. * |
| 28039 | * This version dated 22.4.95 is written by S. Roesler. * |
| 28040 | ************************************************************************ |
| 28041 | |
| 28042 | IMPLICIT DOUBLE PRECISION(A-H,O-Z) |
| 28043 | SAVE |
| 28044 | |
| 28045 | PARAMETER ( LINP = 5 , |
| 28046 | & LOUT = 6 , |
| 28047 | & LDAT = 9 ) |
| 28048 | |
| 28049 | LOGICAL LSTART |
| 28050 | |
| 28051 | PARAMETER (ZERO = 0.0D0, |
| 28052 | & TINY = 1.0D-10) |
| 28053 | |
| 28054 | DIMENSION XLIMB(*) |
| 28055 | |
| 28056 | * histograms |
| 28057 | |
| 28058 | PARAMETER (NHIS=150, NDIM=250) |
| 28059 | |
| 28060 | COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS), |
| 28061 | & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL |
| 28062 | * auxiliary common for histograms |
| 28063 | COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS) |
| 28064 | |
| 28065 | DATA LSTART /.TRUE./ |
| 28066 | |
| 28067 | * reset histogram counter |
| 28068 | IF (LSTART.OR.(IBIN.EQ.-1)) THEN |
| 28069 | IHISL = 0 |
| 28070 | IF (IBIN.EQ.-1) RETURN |
| 28071 | LSTART = .FALSE. |
| 28072 | ENDIF |
| 28073 | |
| 28074 | IHIS = IHISL+1 |
| 28075 | * check for maximum number of allowed histograms |
| 28076 | IF (IHIS.GT.NHIS) THEN |
| 28077 | WRITE(LOUT,1003) IHIS,NHIS,IHIS |
| 28078 | 1003 FORMAT(1X,'NEWHGR: warning! number of histograms (', |
| 28079 | & I4,') exceeds array size (',I4,')',/,21X, |
| 28080 | & 'histogram',I3,' skipped!') |
| 28081 | GOTO 9999 |
| 28082 | ENDIF |
| 28083 | |
| 28084 | IREFN = IHIS |
| 28085 | IBINS(IHIS) = ABS(IBIN) |
| 28086 | * check requested number of bins |
| 28087 | IF (IBINS(IHIS).GE.NDIM) THEN |
| 28088 | WRITE(LOUT,1000) IBIN,NDIM,NDIM |
| 28089 | 1000 FORMAT(1X,'NEWHGR: warning! number of bins (', |
| 28090 | & I3,') exceeds array size (',I3,')',/,21X, |
| 28091 | & 'and will be reset to ',I3) |
| 28092 | IBINS(IHIS) = NDIM |
| 28093 | ENDIF |
| 28094 | IF (IBINS(IHIS).EQ.0) THEN |
| 28095 | WRITE(LOUT,1001) IBIN,IHIS |
| 28096 | 1001 FORMAT(1X,'NEWHGR: warning! inconsistent number of', |
| 28097 | & ' bins (',I3,')',/,21X,'histogram',I3,' skipped!') |
| 28098 | GOTO 9999 |
| 28099 | ENDIF |
| 28100 | |
| 28101 | * initialize arrays |
| 28102 | DO 1 I=1,NDIM |
| 28103 | DO 2 K=1,3 |
| 28104 | HIST(K,IHIS,I) = ZERO |
| 28105 | HIST(K+3,IHIS,I) = ZERO |
| 28106 | TMPHIS(K,IHIS,I) = ZERO |
| 28107 | 2 CONTINUE |
| 28108 | HIST(7,IHIS,I) = ZERO |
| 28109 | 1 CONTINUE |
| 28110 | DENTRY(1,IHIS)= ZERO |
| 28111 | DENTRY(2,IHIS)= ZERO |
| 28112 | OVERF(IHIS) = ZERO |
| 28113 | UNDERF(IHIS) = ZERO |
| 28114 | TMPUFL(IHIS) = ZERO |
| 28115 | TMPOFL(IHIS) = ZERO |
| 28116 | |
| 28117 | * bin str. sensitive to lower edge, bin size, and numb. of bins |
| 28118 | IF (XLIM3.GT.ZERO) THEN |
| 28119 | DO 3 K=1,IBINS(IHIS)+1 |
| 28120 | HIST(1,IHIS,K) = XLIM1+DBLE(K-1)*XLIM3 |
| 28121 | 3 CONTINUE |
| 28122 | ISWI(IHIS) = 1 |
| 28123 | * bin str. sensitive to lower/upper edge and numb. of bins |
| 28124 | ELSEIF (XLIM3.EQ.ZERO) THEN |
| 28125 | * linear binning |
| 28126 | IF (IBIN.GT.0) THEN |
| 28127 | XLOW = XLIM1 |
| 28128 | XHI = XLIM2 |
| 28129 | IF (XLIM2.LE.XLIM1) THEN |
| 28130 | WRITE(LOUT,1002) XLIM1,XLIM2 |
| 28131 | 1002 FORMAT(1X,'NEWHGR: warning! inconsistent x-range', |
| 28132 | & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')') |
| 28133 | GOTO 9999 |
| 28134 | ENDIF |
| 28135 | ISWI(IHIS) = 1 |
| 28136 | ELSEIF (IBIN.LT.-1) THEN |
| 28137 | * logarithmic binning |
| 28138 | IF ((XLIM1.LE.ZERO).OR.(XLIM2.LE.ZERO)) THEN |
| 28139 | WRITE(LOUT,1004) XLIM1,XLIM2 |
| 28140 | 1004 FORMAT(1X,'NEWHGR: warning! inconsistent log. ', |
| 28141 | & 'binning',/,21X,'(XLIM1,XLIM2 = ',2E11.4,')') |
| 28142 | GOTO 9999 |
| 28143 | ENDIF |
| 28144 | IF (XLIM2.LE.XLIM1) THEN |
| 28145 | WRITE(LOUT,1005) XLIM1,XLIM2 |
| 28146 | 1005 FORMAT(1X,'NEWHGR: warning! inconsistent x-range', |
| 28147 | & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')') |
| 28148 | GOTO 9999 |
| 28149 | ENDIF |
| 28150 | XLOW = LOG10(XLIM1) |
| 28151 | XHI = LOG10(XLIM2) |
| 28152 | ISWI(IHIS) = 3 |
| 28153 | ENDIF |
| 28154 | DX = ABS(XHI-XLOW)/DBLE(MAX(IBINS(IHIS),1)) |
| 28155 | DO 4 K=1,IBINS(IHIS)+1 |
| 28156 | HIST(1,IHIS,K) = XLOW+DBLE(K-1)*DX |
| 28157 | 4 CONTINUE |
| 28158 | ELSE |
| 28159 | * user defined bin structure |
| 28160 | DO 5 K=1,IBINS(IHIS)+1 |
| 28161 | IF (IBIN.GT.0) THEN |
| 28162 | HIST(1,IHIS,K) = XLIMB(K) |
| 28163 | ISWI(IHIS) = 2 |
| 28164 | ELSEIF (IBIN.LT.-1) THEN |
| 28165 | HIST(1,IHIS,K) = LOG10(XLIMB(K)) |
| 28166 | ISWI(IHIS) = 4 |
| 28167 | ENDIF |
| 28168 | 5 CONTINUE |
| 28169 | ENDIF |
| 28170 | |
| 28171 | * histogram accepted |
| 28172 | IHISL = IHIS |
| 28173 | |
| 28174 | RETURN |
| 28175 | |
| 28176 | 9999 CONTINUE |
| 28177 | IREFN = -1 |
| 28178 | RETURN |
| 28179 | END |
| 28180 | * |
| 28181 | *===filhgr=============================================================* |
| 28182 | * |
| 28183 | CDECK ID>, DT_FILHGR |
| 28184 | SUBROUTINE DT_FILHGR(XI,YI,IHIS,NEVT) |
| 28185 | |
| 28186 | ************************************************************************ |
| 28187 | * * |
| 28188 | * Scoring for histogram IHIS. * |
| 28189 | * * |
| 28190 | * This subroutine is based on a original version by R. Engel. * |
| 28191 | * This version dated 23.4.95 is written by S. Roesler. * |
| 28192 | ************************************************************************ |
| 28193 | |
| 28194 | IMPLICIT DOUBLE PRECISION(A-H,O-Z) |
| 28195 | SAVE |
| 28196 | |
| 28197 | PARAMETER ( LINP = 5 , |
| 28198 | & LOUT = 6 , |
| 28199 | & LDAT = 9 ) |
| 28200 | |
| 28201 | PARAMETER (ZERO = 0.0D0, |
| 28202 | & ONE = 1.0D0, |
| 28203 | & TINY = 1.0D-10) |
| 28204 | |
| 28205 | * histograms |
| 28206 | |
| 28207 | PARAMETER (NHIS=150, NDIM=250) |
| 28208 | |
| 28209 | COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS), |
| 28210 | & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL |
| 28211 | * auxiliary common for histograms |
| 28212 | COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS) |
| 28213 | |
| 28214 | DATA NCEVT /1/ |
| 28215 | |
| 28216 | X = XI |
| 28217 | Y = YI |
| 28218 | |
| 28219 | * dump content of temorary arrays into histograms |
| 28220 | IF ((NEVT.NE.NCEVT).OR.(NEVT.LT.0)) THEN |
| 28221 | CALL DT_EVTHIS(IDUM) |
| 28222 | NCEVT = NEVT |
| 28223 | ENDIF |
| 28224 | |
| 28225 | * check histogram index |
| 28226 | IF (IHIS.EQ.-1) RETURN |
| 28227 | IF ((IHIS.LT.1).OR.(IHIS.GT.IHISL)) THEN |
| 28228 | C WRITE(LOUT,1000) IHIS,IHISL |
| 28229 | 1000 FORMAT(1X,'FILHGR: warning! histogram index',I4, |
| 28230 | & ' out of range (1..',I3,')') |
| 28231 | RETURN |
| 28232 | ENDIF |
| 28233 | |
| 28234 | IF ((ISWI(IHIS).EQ.1).OR.(ISWI(IHIS).EQ.3)) THEN |
| 28235 | * bin structure not explicitly given |
| 28236 | IF ((ISWI(IHIS).EQ.3).AND.(X.GT.ZERO)) X = LOG10(X) |
| 28237 | DX = ABS(HIST(1,IHIS,2)-HIST(1,IHIS,1)) |
| 28238 | IF (X.LT.HIST(1,IHIS,1)) THEN |
| 28239 | I1 = 0 |
| 28240 | ELSE |
| 28241 | I1 = INT( (X-HIST(1,IHIS,1))/MAX(DX,TINY) )+1 |
| 28242 | ENDIF |
| 28243 | |
| 28244 | ELSEIF ((ISWI(IHIS).EQ.2).OR.(ISWI(IHIS).EQ.4)) THEN |
| 28245 | * user defined bin structure |
| 28246 | IF ((ISWI(IHIS).EQ.4).AND.(X.GT.ZERO)) X = LOG10(X) |
| 28247 | IF (X.LT.HIST(1,IHIS,1)) THEN |
| 28248 | I1 = 0 |
| 28249 | ELSE IF (X.GT.HIST(1,IHIS,IBINS(IHIS)+1)) THEN |
| 28250 | I1 = IBINS(IHIS)+1 |
| 28251 | ELSE |
| 28252 | * binary sort algorithm |
| 28253 | KMIN = 0 |
| 28254 | KMAX = IBINS(IHIS)+1 |
| 28255 | 1 CONTINUE |
| 28256 | IF ((KMAX-KMIN).EQ.1) GOTO 2 |
| 28257 | KK = (KMAX+KMIN)/2 |
| 28258 | IF (X.LE.HIST(1,IHIS,KK)) THEN |
| 28259 | KMAX=KK |
| 28260 | ELSE |
| 28261 | KMIN=KK |
| 28262 | ENDIF |
| 28263 | GOTO 1 |
| 28264 | 2 CONTINUE |
| 28265 | I1 = KMIN |
| 28266 | ENDIF |
| 28267 | |
| 28268 | ELSE |
| 28269 | WRITE(LOUT,1001) |
| 28270 | 1001 FORMAT(1X,'FILHGR: warning! histogram not initialized') |
| 28271 | RETURN |
| 28272 | ENDIF |
| 28273 | |
| 28274 | * scoring |
| 28275 | IF (I1.LE.0) THEN |
| 28276 | TMPUFL(IHIS) = TMPUFL(IHIS)+ONE |
| 28277 | ELSEIF (I1.LE.IBINS(IHIS)) THEN |
| 28278 | TMPHIS(1,IHIS,I1) = TMPHIS(1,IHIS,I1)+ONE |
| 28279 | IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN |
| 28280 | TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+10**X |
| 28281 | ELSE |
| 28282 | TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+X |
| 28283 | ENDIF |
| 28284 | TMPHIS(3,IHIS,I1) = TMPHIS(3,IHIS,I1)+Y |
| 28285 | ELSE |
| 28286 | TMPOFL(IHIS) = TMPOFL(IHIS)+ONE |
| 28287 | ENDIF |
| 28288 | |
| 28289 | RETURN |
| 28290 | END |
| 28291 | * |
| 28292 | *===evthis=============================================================* |
| 28293 | * |
| 28294 | CDECK ID>, DT_EVTHIS |
| 28295 | SUBROUTINE DT_EVTHIS(NEVT) |
| 28296 | |
| 28297 | ************************************************************************ |
| 28298 | * Dump content of temorary histograms into /DTHIS1/. This subroutine * |
| 28299 | * is called after each event and for the last event before any call * |
| 28300 | * to OUTHGR. * |
| 28301 | * NEVT number of events dumped, this is only needed to * |
| 28302 | * get the normalization after the last event * |
| 28303 | * This version dated 23.4.95 is written by S. Roesler. * |
| 28304 | ************************************************************************ |
| 28305 | |
| 28306 | IMPLICIT DOUBLE PRECISION(A-H,O-Z) |
| 28307 | SAVE |
| 28308 | |
| 28309 | PARAMETER ( LINP = 5 , |
| 28310 | & LOUT = 6 , |
| 28311 | & LDAT = 9 ) |
| 28312 | |
| 28313 | LOGICAL LNOETY |
| 28314 | |
| 28315 | PARAMETER (ZERO = 0.0D0, |
| 28316 | & ONE = 1.0D0, |
| 28317 | & TINY = 1.0D-10) |
| 28318 | |
| 28319 | * histograms |
| 28320 | |
| 28321 | PARAMETER (NHIS=150, NDIM=250) |
| 28322 | |
| 28323 | COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS), |
| 28324 | & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL |
| 28325 | * auxiliary common for histograms |
| 28326 | COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS) |
| 28327 | |
| 28328 | DATA NCEVT /0/ |
| 28329 | |
| 28330 | NCEVT = NCEVT+1 |
| 28331 | NEVT = NCEVT |
| 28332 | |
| 28333 | DO 1 I=1,IHISL |
| 28334 | LNOETY = .TRUE. |
| 28335 | DO 2 J=1,IBINS(I) |
| 28336 | IF (TMPHIS(1,I,J).GT.ZERO) THEN |
| 28337 | LNOETY = .FALSE. |
| 28338 | HIST(2,I,J) = HIST(2,I,J)+ONE |
| 28339 | HIST(7,I,J) = HIST(7,I,J)+TMPHIS(1,I,J) |
| 28340 | DENTRY(2,I) = DENTRY(2,I)+TMPHIS(1,I,J) |
| 28341 | AVX = TMPHIS(2,I,J)/TMPHIS(1,I,J) |
| 28342 | HIST(3,I,J) = HIST(3,I,J)+TMPHIS(3,I,J)*AVX |
| 28343 | HIST(4,I,J) = HIST(4,I,J)+TMPHIS(3,I,J)*AVX**2 |
| 28344 | HIST(5,I,J) = HIST(5,I,J)+TMPHIS(3,I,J) |
| 28345 | HIST(6,I,J) = HIST(6,I,J)+TMPHIS(3,I,J)**2 |
| 28346 | TMPHIS(1,I,J) = ZERO |
| 28347 | TMPHIS(2,I,J) = ZERO |
| 28348 | TMPHIS(3,I,J) = ZERO |
| 28349 | ENDIF |
| 28350 | 2 CONTINUE |
| 28351 | IF (LNOETY) THEN |
| 28352 | IF (TMPUFL(I).GT.ZERO) THEN |
| 28353 | UNDERF(I) = UNDERF(I)+ONE |
| 28354 | TMPUFL(I) = ZERO |
| 28355 | ELSEIF (TMPOFL(I).GT.ZERO) THEN |
| 28356 | OVERF(I) = OVERF(I)+ONE |
| 28357 | TMPOFL(I) = ZERO |
| 28358 | ENDIF |
| 28359 | ELSE |
| 28360 | DENTRY(1,I) = DENTRY(1,I)+ONE |
| 28361 | ENDIF |
| 28362 | 1 CONTINUE |
| 28363 | |
| 28364 | RETURN |
| 28365 | END |
| 28366 | * |
| 28367 | *===outhgr=============================================================* |
| 28368 | * |
| 28369 | CDECK ID>, DT_OUTHGR |
| 28370 | SUBROUTINE DT_OUTHGR(I1,I2,I3,I4,I5,I6,CHEAD,IHEAD,NEVTS,FAC, |
| 28371 | & ILOGY,INORM,NMODE) |
| 28372 | |
| 28373 | ************************************************************************ |
| 28374 | * * |
| 28375 | * Plot histogram(s) to standard output unit * |
| 28376 | * * |
| 28377 | * I1..6 indices of histograms to be plotted * |
| 28378 | * CHEAD,IHEAD header string,integer * |
| 28379 | * NEVTS number of events * |
| 28380 | * FAC scaling factor * |
| 28381 | * ILOGY = 1 logarithmic y-axis * |
| 28382 | * INORM normalization * |
| 28383 | * = 0 no further normalization (FAC is obsolete) * |
| 28384 | * = 1 per event and bin width * |
| 28385 | * = 2 per entry and bin width * |
| 28386 | * = 3 per bin entry * |
| 28387 | * = 4 per event and "bin width" x1^2...x2^2 * |
| 28388 | * = 5 per event and "log. bin width" ln x1..ln x2 * |
| 28389 | * = 6 per event * |
| 28390 | * MODE = 0 no output but normalization applied * |
| 28391 | * = 1 all valid histograms separately (small frame) * |
| 28392 | * all valid histograms separately (small frame) * |
| 28393 | * = -1 and tables as histograms * |
| 28394 | * = 2 all valid histograms (one plot, wide frame) * |
| 28395 | * all valid histograms (one plot, wide frame) * |
| 28396 | * = -2 and tables as histograms * |
| 28397 | * * |
| 28398 | * * |
| 28399 | * Note: All histograms to be plotted with one call to this * |
| 28400 | * subroutine and |MODE|=2 must have the same bin structure! * |
| 28401 | * There is no test included ensuring this fact. * |
| 28402 | * * |
| 28403 | * This version dated 23.4.95 is written by S. Roesler. * |
| 28404 | ************************************************************************ |
| 28405 | |
| 28406 | IMPLICIT DOUBLE PRECISION(A-H,O-Z) |
| 28407 | SAVE |
| 28408 | |
| 28409 | PARAMETER ( LINP = 5 , |
| 28410 | & LOUT = 6 , |
| 28411 | & LDAT = 9 ) |
| 28412 | |
| 28413 | CHARACTER*72 CHEAD |
| 28414 | |
| 28415 | PARAMETER (ZERO = 0.0D0, |
| 28416 | & IZERO = 0, |
| 28417 | & ONE = 1.0D0, |
| 28418 | & TWO = 2.0D0, |
| 28419 | & OHALF = 0.5D0, |
| 28420 | & EPS = 1.0D-5, |
| 28421 | & TINY = 1.0D-8, |
| 28422 | & SMALL = -1.0D8, |
| 28423 | & RLARGE = 1.0D8 ) |
| 28424 | |
| 28425 | * histograms |
| 28426 | |
| 28427 | PARAMETER (NHIS=150, NDIM=250) |
| 28428 | |
| 28429 | COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS), |
| 28430 | & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL |
| 28431 | |
| 28432 | PARAMETER (NDIM2 = 2*NDIM) |
| 28433 | DIMENSION XX(NDIM2),YY(NDIM2) |
| 28434 | |
| 28435 | PARAMETER (NHISTO = 6) |
| 28436 | DIMENSION YY1(NDIM,NHISTO),XX1(NDIM,NHISTO),IDX1(NHISTO), |
| 28437 | & IDX(NHISTO) |
| 28438 | |
| 28439 | CHARACTER*43 CNORM(0:8) |
| 28440 | DATA CNORM /'no further normalization ', |
| 28441 | & 'per event and bin width ', |
| 28442 | & 'per entry1 and bin width ', |
| 28443 | & 'per bin entry ', |
| 28444 | & 'per event and "bin width" x1^2...x2^2 ', |
| 28445 | & 'per event and "log. bin width" ln x1..ln x2', |
| 28446 | & 'per event ', |
| 28447 | & 'per bin entry1 ', |
| 28448 | & 'per entry2 and bin width '/ |
| 28449 | |
| 28450 | IDX1(1) = I1 |
| 28451 | IDX1(2) = I2 |
| 28452 | IDX1(3) = I3 |
| 28453 | IDX1(4) = I4 |
| 28454 | IDX1(5) = I5 |
| 28455 | IDX1(6) = I6 |
| 28456 | |
| 28457 | MODE = NMODE |
| 28458 | |
| 28459 | * initialization if "wide frame" is requested |
| 28460 | IF (ABS(MODE).EQ.2) THEN |
| 28461 | DO 1 I=1,NHISTO |
| 28462 | DO 2 J=1,NDIM |
| 28463 | XX1(J,I) = ZERO |
| 28464 | YY1(J,I) = ZERO |
| 28465 | 2 CONTINUE |
| 28466 | 1 CONTINUE |
| 28467 | ENDIF |
| 28468 | |
| 28469 | * plot header |
| 28470 | WRITE(LOUT,'(/1X,A,I3,/,1X,70A1)') CHEAD,IHEAD,('=',II=1,70) |
| 28471 | |
| 28472 | * check histogram indices |
| 28473 | NHI = 0 |
| 28474 | DO 3 I=1,NHISTO |
| 28475 | IF ((IDX1(I).GE.1).AND.(IDX1(I).LE.IHISL)) THEN |
| 28476 | IF (ISWI(IDX1(I)).NE.0) THEN |
| 28477 | IF (DENTRY(1,IDX1(I)).LT.ONE) THEN |
| 28478 | WRITE(LOUT,1000) |
| 28479 | & IDX1(I),UNDERF(IDX1(I)),OVERF(IDX1(I)) |
| 28480 | 1000 FORMAT(/,1X,'OUTHGR: warning! no entries in', |
| 28481 | & ' histogram ',I3,/,21X,'underflows:',F10.0, |
| 28482 | & ' overflows: ',F10.0) |
| 28483 | ELSE |
| 28484 | NHI = NHI+1 |
| 28485 | IDX(NHI) = IDX1(I) |
| 28486 | ENDIF |
| 28487 | ENDIF |
| 28488 | ENDIF |
| 28489 | 3 CONTINUE |
| 28490 | IF (NHI.EQ.0) THEN |
| 28491 | WRITE(LOUT,1001) |
| 28492 | 1001 FORMAT(/,1X,'OUTHGR: warning! histogram indices not valid') |
| 28493 | RETURN |
| 28494 | ENDIF |
| 28495 | |
| 28496 | * check normalization request |
| 28497 | IF ( ((FAC.EQ.ZERO).AND.(INORM.NE.0)).OR. |
| 28498 | & ((NEVTS.LT.1).AND.((INORM.EQ.1).OR.(INORM.EQ.4).OR. |
| 28499 | & (INORM.EQ.5).OR.(INORM.EQ.6))).OR. |
| 28500 | & (INORM.LT.0).OR.(INORM.GT.8) ) THEN |
| 28501 | WRITE(LOUT,1002) NEVTS,INORM,FAC |
| 28502 | 1002 FORMAT(/,1X,'OUTHGR: warning! normalization request not ', |
| 28503 | & 'valid',/,21X,'NEVTS = ',I7,4X,'INORM = ',I2,4X, |
| 28504 | & 'FAC = ',E11.4) |
| 28505 | RETURN |
| 28506 | ENDIF |
| 28507 | |
| 28508 | WRITE(LOUT,'(/,1X,A,I8)') 'number of events:',NEVTS |
| 28509 | |
| 28510 | * apply normalization |
| 28511 | DO 4 N=1,NHI |
| 28512 | |
| 28513 | I = IDX(N) |
| 28514 | |
| 28515 | IF (ISWI(I).EQ.1) THEN |
| 28516 | WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I) |
| 28517 | 1003 FORMAT(/,1X,'histo.',I4,', linear binning from',2X,E10.4, |
| 28518 | & ' to',2X,E10.4,',',2X,I3,' bins') |
| 28519 | ELSEIF (ISWI(I).EQ.2) THEN |
| 28520 | WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I) |
| 28521 | WRITE(LOUT,1007) |
| 28522 | 1007 FORMAT(1X,'user defined bin structure') |
| 28523 | ELSEIF (ISWI(I).EQ.3) THEN |
| 28524 | WRITE(LOUT,1004) |
| 28525 | & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I) |
| 28526 | 1004 FORMAT(/,1X,'histo.',I4,', logar. binning from',2X,E10.4, |
| 28527 | & ' to',2X,E10.4,',',2X,I3,' bins') |
| 28528 | ELSEIF (ISWI(I).EQ.4) THEN |
| 28529 | WRITE(LOUT,1004) |
| 28530 | & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I) |
| 28531 | WRITE(LOUT,1007) |
| 28532 | ELSE |
| 28533 | WRITE(LOUT,1008) ISWI(I) |
| 28534 | 1008 FORMAT(/,1X,'warning! inconsistent bin structure flag ',I4) |
| 28535 | ENDIF |
| 28536 | WRITE(LOUT,1005) DENTRY(1,I),DENTRY(2,I),UNDERF(I),OVERF(I) |
| 28537 | 1005 FORMAT(13X,'entries:',2F9.0,' underfl.:',F8.0, |
| 28538 | & ' overfl.:',F8.0) |
| 28539 | WRITE(LOUT,1009) CNORM(INORM) |
| 28540 | 1009 FORMAT(1X,'normalization: ',A,/) |
| 28541 | |
| 28542 | DO 5 K=1,IBINS(I) |
| 28543 | CALL DT_GETBIN(I,K,NEVTS,INORM,XLOW,XHI,XMEAN,YMEAN,YERR) |
| 28544 | YMEAN = FAC*YMEAN |
| 28545 | YERR = FAC*YERR |
| 28546 | WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,YERR,HIST(2,I,K) |
| 28547 | WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,YERR,HIST(2,I,K) |
| 28548 | 1006 FORMAT(1X,5E11.3) |
| 28549 | * small frame |
| 28550 | II = 2*K |
| 28551 | XX(II-1) = HIST(1,I,K) |
| 28552 | XX(II) = HIST(1,I,K+1) |
| 28553 | YY(II-1) = YMEAN |
| 28554 | YY(II) = YMEAN |
| 28555 | * wide frame |
| 28556 | XX1(K,N) = XMEAN |
| 28557 | IF ((ISWI(I).EQ.3).OR.(ISWI(I).EQ.4)) |
| 28558 | & XX1(K,N) = LOG10(XMEAN) |
| 28559 | YY1(K,N) = YMEAN |
| 28560 | 5 CONTINUE |
| 28561 | |
| 28562 | * plot small frame |
| 28563 | IF (ABS(MODE).EQ.1) THEN |
| 28564 | IBIN2 = 2*IBINS(I) |
| 28565 | WRITE(LOUT,'(/,1X,A)') 'Preview:' |
| 28566 | IF(ILOGY.EQ.1) THEN |
| 28567 | CALL DT_XGLOGY(IBIN2,1,XX,YY,YY) |
| 28568 | ELSE |
| 28569 | CALL DT_XGRAPH(IBIN2,1,XX,YY,YY) |
| 28570 | ENDIF |
| 28571 | ENDIF |
| 28572 | |
| 28573 | 4 CONTINUE |
| 28574 | |
| 28575 | * plot wide frame |
| 28576 | IF (ABS(MODE).EQ.2) THEN |
| 28577 | WRITE(LOUT,'(/,1X,A)') 'Preview:' |
| 28578 | NSIZE = NDIM*NHISTO |
| 28579 | DXLOW = HIST(1,IDX(1),1) |
| 28580 | DDX = ABS(HIST(1,IDX(1),2)-HIST(1,IDX(1),1)) |
| 28581 | YLOW = RLARGE |
| 28582 | YHI = SMALL |
| 28583 | DO 6 I=1,NHISTO |
| 28584 | DO 7 J=1,NDIM |
| 28585 | IF (YY1(J,I).LT.YLOW) THEN |
| 28586 | IF (ILOGY.EQ.1) THEN |
| 28587 | IF (YY1(J,I).GT.ZERO) YLOW = YY1(J,I) |
| 28588 | ELSE |
| 28589 | YLOW = YY1(J,I) |
| 28590 | ENDIF |
| 28591 | ENDIF |
| 28592 | IF (YY1(J,I).GT.YHI) YHI = YY1(J,I) |
| 28593 | 7 CONTINUE |
| 28594 | 6 CONTINUE |
| 28595 | DY = (YHI-YLOW)/DBLE(NDIM) |
| 28596 | IF (DY.LE.ZERO) THEN |
| 28597 | WRITE(LOUT,'(1X,A,6I4,A,2E12.4)') |
| 28598 | & 'OUTHGR: warning! zero bin width for histograms ', |
| 28599 | & IDX,': ',YLOW,YHI |
| 28600 | RETURN |
| 28601 | ENDIF |
| 28602 | IF (ILOGY.EQ.1) THEN |
| 28603 | YLOW = LOG10(YLOW) |
| 28604 | DY = (LOG10(YHI)-YLOW)/100.0D0 |
| 28605 | DO 8 I=1,NHISTO |
| 28606 | DO 9 J=1,NDIM |
| 28607 | IF (YY1(J,I).LE.ZERO) THEN |
| 28608 | YY1(J,I) = YLOW |
| 28609 | ELSE |
| 28610 | YY1(J,I) = LOG10(YY1(J,I)) |
| 28611 | ENDIF |
| 28612 | 9 CONTINUE |
| 28613 | 8 CONTINUE |
| 28614 | ENDIF |
| 28615 | CALL DT_SRPLOT(XX1,YY1,NSIZE,NHISTO,NDIM,DXLOW,DDX,YLOW,DY) |
| 28616 | ENDIF |
| 28617 | |
| 28618 | RETURN |
| 28619 | END |
| 28620 | * |
| 28621 | *===getbin=============================================================* |
| 28622 | * |
| 28623 | CDECK ID>, DT_GETBIN |
| 28624 | SUBROUTINE DT_GETBIN(IHIS,IBIN,KEVT,NORM,XLOW,XHI, |
| 28625 | & XMEAN,YMEAN,YERR) |
| 28626 | |
| 28627 | ************************************************************************ |
| 28628 | * This version dated 23.4.95 is written by S. Roesler. * |
| 28629 | ************************************************************************ |
| 28630 | |
| 28631 | IMPLICIT DOUBLE PRECISION(A-H,O-Z) |
| 28632 | SAVE |
| 28633 | |
| 28634 | PARAMETER ( LINP = 5 , |
| 28635 | & LOUT = 6 , |
| 28636 | & LDAT = 9 ) |
| 28637 | |
| 28638 | PARAMETER (ZERO = 0.0D0, |
| 28639 | & ONE = 1.0D0, |
| 28640 | & TINY35 = 1.0D-35) |
| 28641 | |
| 28642 | * histograms |
| 28643 | |
| 28644 | PARAMETER (NHIS=150, NDIM=250) |
| 28645 | |
| 28646 | COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS), |
| 28647 | & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL |
| 28648 | |
| 28649 | XLOW = HIST(1,IHIS,IBIN) |
| 28650 | XHI = HIST(1,IHIS,IBIN+1) |
| 28651 | IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN |
| 28652 | XLOW = 10**XLOW |
| 28653 | XHI = 10**XHI |
| 28654 | ENDIF |
| 28655 | IF (NORM.EQ.2) THEN |
| 28656 | DX = XHI-XLOW |
| 28657 | NEVT = INT(DENTRY(1,IHIS)) |
| 28658 | ELSEIF (NORM.EQ.3) THEN |
| 28659 | DX = ONE |
| 28660 | NEVT = INT(HIST(2,IHIS,IBIN)) |
| 28661 | ELSEIF (NORM.EQ.4) THEN |
| 28662 | DX = XHI**2-XLOW**2 |
| 28663 | NEVT = KEVT |
| 28664 | ELSEIF (NORM.EQ.5) THEN |
| 28665 | DX = LOG(ABS(XHI))-LOG(ABS(XLOW)) |
| 28666 | NEVT = KEVT |
| 28667 | ELSEIF (NORM.EQ.6) THEN |
| 28668 | DX = ONE |
| 28669 | NEVT = KEVT |
| 28670 | ELSEIF (NORM.EQ.7) THEN |
| 28671 | DX = ONE |
| 28672 | NEVT = INT(HIST(7,IHIS,IBIN)) |
| 28673 | ELSEIF (NORM.EQ.8) THEN |
| 28674 | DX = XHI-XLOW |
| 28675 | NEVT = INT(DENTRY(2,IHIS)) |
| 28676 | ELSE |
| 28677 | DX = ABS(XHI-XLOW) |
| 28678 | NEVT = KEVT |
| 28679 | ENDIF |
| 28680 | IF (ABS(DX).LT.TINY35) DX = ONE |
| 28681 | NEVT = MAX(NEVT,1) |
| 28682 | YMEAN = HIST(5,IHIS,IBIN)/DX/DBLE(NEVT) |
| 28683 | YMEAN2 = HIST(6,IHIS,IBIN)/DX**2/DBLE(NEVT) |
| 28684 | YERR = SQRT(ABS(YMEAN2-YMEAN**2))/SQRT(DBLE(NEVT)) |
| 28685 | YSUM = HIST(5,IHIS,IBIN) |
| 28686 | IF (ABS(YSUM).LT.TINY35) YSUM = ONE |
| 28687 | C XMEAN = HIST(3,IHIS,IBIN)/YSUM/MAX(HIST(2,IHIS,IBIN),ONE) |
| 28688 | XMEAN = HIST(3,IHIS,IBIN)/YSUM |
| 28689 | IF (XMEAN.EQ.ZERO) XMEAN = XLOW |
| 28690 | |
| 28691 | RETURN |
| 28692 | END |
| 28693 | * |
| 28694 | *===joihis=============================================================* |
| 28695 | * |
| 28696 | CDECK ID>, DT_JOIHIS |
| 28697 | SUBROUTINE DT_JOIHIS(IH1,IH2,COPER,FAC1,FAC2,KEVT,NORM,ILOGY,MODE) |
| 28698 | |
| 28699 | ************************************************************************ |
| 28700 | * * |
| 28701 | * Operation on histograms. * |
| 28702 | * * |
| 28703 | * input: IH1,IH2 histogram indices to be joined * |
| 28704 | * COPER character defining the requested operation, * |
| 28705 | * i.e. '+', '-', '*', '/' * |
| 28706 | * FAC1,FAC2 factors for joining, i.e. * |
| 28707 | * FAC1*histo1 COPER FAC2*histo2 * |
| 28708 | * * |
| 28709 | * This version dated 23.4.95 is written by S. Roesler. * |
| 28710 | ************************************************************************ |
| 28711 | |
| 28712 | IMPLICIT DOUBLE PRECISION(A-H,O-Z) |
| 28713 | SAVE |
| 28714 | |
| 28715 | PARAMETER ( LINP = 5 , |
| 28716 | & LOUT = 6 , |
| 28717 | & LDAT = 9 ) |
| 28718 | |
| 28719 | CHARACTER COPER*1 |
| 28720 | |
| 28721 | PARAMETER (ZERO = 0.0D0, |
| 28722 | & ONE = 1.0D0, |
| 28723 | & OHALF = 0.5D0, |
| 28724 | & TINY8 = 1.0D-8, |
| 28725 | & SMALL = -1.0D8, |
| 28726 | & RLARGE = 1.0D8 ) |
| 28727 | |
| 28728 | * histograms |
| 28729 | |
| 28730 | PARAMETER (NHIS=150, NDIM=250) |
| 28731 | |
| 28732 | COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS), |
| 28733 | & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL |
| 28734 | |
| 28735 | PARAMETER (NDIM2 = 2*NDIM) |
| 28736 | DIMENSION XX(NDIM2),YY(NDIM2),YY1(NDIM),XX1(NDIM) |
| 28737 | |
| 28738 | CHARACTER*43 CNORM(0:6) |
| 28739 | DATA CNORM /'no further normalization ', |
| 28740 | & 'per event and bin width ', |
| 28741 | & 'per entry and bin width ', |
| 28742 | & 'per bin entry ', |
| 28743 | & 'per event and "bin width" x1^2...x2^2 ', |
| 28744 | & 'per event and "log. bin width" ln x1..ln x2', |
| 28745 | & 'per event '/ |
| 28746 | |
| 28747 | * check histogram indices |
| 28748 | IF ((IH1.LT. 1).OR.(IH2.LT. 1).OR. |
| 28749 | & (IH1.GT.IHISL).OR.(IH2.GT.IHISL)) THEN |
| 28750 | WRITE(LOUT,1000) IH1,IH2,IHISL |
| 28751 | 1000 FORMAT(1X,'JOIHIS: warning! inconsistent histogram ', |
| 28752 | & 'indices (',I3,',',I3,'),',/,21X,'valid range: 1,',I3) |
| 28753 | GOTO 9999 |
| 28754 | ENDIF |
| 28755 | |
| 28756 | * check bin structure of histograms to be joined |
| 28757 | IF (IBINS(IH1).NE.IBINS(IH2)) THEN |
| 28758 | WRITE(LOUT,1001) IH1,IH2,IBINS(IH1),IBINS(IH2) |
| 28759 | 1001 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3, |
| 28760 | & ' and ',I3,' failed',/,21X, |
| 28761 | & 'due to different numbers of bins (',I3,',',I3,')') |
| 28762 | GOTO 9999 |
| 28763 | ENDIF |
| 28764 | DO 1 K=1,IBINS(IH1)+1 |
| 28765 | IF (ABS(HIST(1,IH1,K)-HIST(1,IH2,K)).GT.TINY8) THEN |
| 28766 | WRITE(LOUT,1002) IH1,IH2,K,HIST(1,IH1,K),HIST(1,IH2,K) |
| 28767 | 1002 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3, |
| 28768 | & ' and ',I3,' failed at bin edge ',I3,/,21X, |
| 28769 | & 'X1,X2 = ',2E11.4) |
| 28770 | GOTO 9999 |
| 28771 | ENDIF |
| 28772 | 1 CONTINUE |
| 28773 | |
| 28774 | WRITE(LOUT,1003) IH1,IH2,COPER,FAC1,FAC2 |
| 28775 | 1003 FORMAT(1X,'JOIHIS: joining histograms ',I3,',',I3,' with ', |
| 28776 | & 'operation ',A,/,11X,'and factors ',2E11.4) |
| 28777 | WRITE(LOUT,1004) CNORM(NORM) |
| 28778 | 1004 FORMAT(1X,'normalization: ',A,/) |
| 28779 | |
| 28780 | DO 2 K=1,IBINS(IH1) |
| 28781 | CALL DT_GETBIN(IH1,K,KEVT,NORM,XLOW1,XHI1,XMEAN1,YMEAN1,YERR1) |
| 28782 | CALL DT_GETBIN(IH2,K,KEVT,NORM,XLOW2,XHI2,XMEAN2,YMEAN2,YERR2) |
| 28783 | XLOW = XLOW1 |
| 28784 | XHI = XHI1 |
| 28785 | XMEAN = OHALF*(XMEAN1+XMEAN2) |
| 28786 | IF (COPER.EQ.'+') THEN |
| 28787 | YMEAN = FAC1*YMEAN1+FAC2*YMEAN2 |
| 28788 | ELSEIF (COPER.EQ.'*') THEN |
| 28789 | YMEAN = FAC1*YMEAN1*FAC2*YMEAN2 |
| 28790 | ELSEIF (COPER.EQ.'/') THEN |
| 28791 | IF (YMEAN2.EQ.ZERO) THEN |
| 28792 | YMEAN = ZERO |
| 28793 | ELSE |
| 28794 | IF (FAC2.EQ.ZERO) FAC2 = ONE |
| 28795 | YMEAN = FAC1*YMEAN1/(FAC2*YMEAN2) |
| 28796 | ENDIF |
| 28797 | ELSE |
| 28798 | GOTO 9998 |
| 28799 | ENDIF |
| 28800 | WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K) |
| 28801 | WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K) |
| 28802 | 1006 FORMAT(1X,5E11.3) |
| 28803 | * small frame |
| 28804 | II = 2*K |
| 28805 | XX(II-1) = HIST(1,IH1,K) |
| 28806 | XX(II) = HIST(1,IH1,K+1) |
| 28807 | YY(II-1) = YMEAN |
| 28808 | YY(II) = YMEAN |
| 28809 | * wide frame |
| 28810 | XX1(K) = XMEAN |
| 28811 | IF ((ISWI(IH1).EQ.3).OR.(ISWI(IH1).EQ.4)) XX1(K) = LOG10(XMEAN) |
| 28812 | YY1(K) = YMEAN |
| 28813 | 2 CONTINUE |
| 28814 | |
| 28815 | * plot small frame |
| 28816 | IF (ABS(MODE).EQ.1) THEN |
| 28817 | IBIN2 = 2*IBINS(IH1) |
| 28818 | WRITE(LOUT,'(/,1X,A)') 'Preview:' |
| 28819 | IF(ILOGY.EQ.1) THEN |
| 28820 | CALL DT_XGLOGY(IBIN2,1,XX,YY,YY) |
| 28821 | ELSE |
| 28822 | CALL DT_XGRAPH(IBIN2,1,XX,YY,YY) |
| 28823 | ENDIF |
| 28824 | ENDIF |
| 28825 | |
| 28826 | * plot wide frame |
| 28827 | IF (ABS(MODE).EQ.2) THEN |
| 28828 | WRITE(LOUT,'(/,1X,A)') 'Preview:' |
| 28829 | NSIZE = NDIM |
| 28830 | DXLOW = HIST(1,IH1,1) |
| 28831 | DDX = ABS(HIST(1,IH1,2)-HIST(1,IH1,1)) |
| 28832 | YLOW = RLARGE |
| 28833 | YHI = SMALL |
| 28834 | DO 3 I=1,NDIM |
| 28835 | IF (YY1(I).LT.YLOW) THEN |
| 28836 | IF (ILOGY.EQ.1) THEN |
| 28837 | IF (YY1(I).GT.ZERO) YLOW = YY1(I) |
| 28838 | ELSE |
| 28839 | YLOW = YY1(I) |
| 28840 | ENDIF |
| 28841 | ENDIF |
| 28842 | IF (YY1(I).GT.YHI) YHI = YY1(I) |
| 28843 | 3 CONTINUE |
| 28844 | DY = (YHI-YLOW)/DBLE(NDIM) |
| 28845 | IF (DY.LE.ZERO) THEN |
| 28846 | WRITE(LOUT,'(1X,A,2I4,A,2E12.4)') |
| 28847 | & 'JOIHIS: warning! zero bin width for histograms ', |
| 28848 | & IH1,IH2,': ',YLOW,YHI |
| 28849 | RETURN |
| 28850 | ENDIF |
| 28851 | IF (ILOGY.EQ.1) THEN |
| 28852 | YLOW = LOG10(YLOW) |
| 28853 | DY = (LOG10(YHI)-YLOW)/100.0D0 |
| 28854 | DO 4 I=1,NDIM |
| 28855 | IF (YY1(I).LE.ZERO) THEN |
| 28856 | YY1(I) = YLOW |
| 28857 | ELSE |
| 28858 | YY1(I) = LOG10(YY1(I)) |
| 28859 | ENDIF |
| 28860 | 4 CONTINUE |
| 28861 | ENDIF |
| 28862 | CALL DT_SRPLOT(XX1,YY1,NSIZE,1,NDIM,DXLOW,DDX,YLOW,DY) |
| 28863 | ENDIF |
| 28864 | |
| 28865 | RETURN |
| 28866 | |
| 28867 | 9998 CONTINUE |
| 28868 | WRITE(LOUT,1005) COPER |
| 28869 | 1005 FORMAT(1X,'JOIHIS: unknown operation ',A) |
| 28870 | |
| 28871 | 9999 CONTINUE |
| 28872 | RETURN |
| 28873 | END |
| 28874 | * |
| 28875 | *===qgraph=============================================================* |
| 28876 | * |
| 28877 | CDECK ID>, DT_XGRAPH |
| 28878 | SUBROUTINE DT_XGRAPH(N,IARG,X,Y1,Y2) |
| 28879 | C*********************************************************************** |
| 28880 | C |
| 28881 | C calculate quasi graphic picture with 25 lines and 79 columns |
| 28882 | C ranges will be chosen automatically |
| 28883 | C |
| 28884 | C input N dimension of input fields |
| 28885 | C IARG number of curves (fields) to plot |
| 28886 | C X field of X |
| 28887 | C Y1 field of Y1 |
| 28888 | C Y2 field of Y2 |
| 28889 | C |
| 28890 | C This subroutine is written by R. Engel. |
| 28891 | C*********************************************************************** |
| 28892 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 28893 | SAVE |
| 28894 | |
| 28895 | PARAMETER ( LINP = 5 , |
| 28896 | & LOUT = 6 , |
| 28897 | & LDAT = 9 ) |
| 28898 | |
| 28899 | C |
| 28900 | DIMENSION X(N),Y1(N),Y2(N) |
| 28901 | PARAMETER (EPS=1.D-30) |
| 28902 | PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20) |
| 28903 | CHARACTER SYMB(5) |
| 28904 | CHARACTER COL(0:149,0:49) |
| 28905 | C |
| 28906 | DATA SYMB /'0','e','z','#','x'/ |
| 28907 | C |
| 28908 | ISPALT=IBREIT-10 |
| 28909 | C |
| 28910 | C*** automatic range fitting |
| 28911 | C |
| 28912 | XMAX=X(1) |
| 28913 | XMIN=X(1) |
| 28914 | DO 600 I=1,N |
| 28915 | XMAX=MAX(X(I),XMAX) |
| 28916 | XMIN=MIN(X(I),XMIN) |
| 28917 | 600 CONTINUE |
| 28918 | XZOOM=(XMAX-XMIN)/DBLE(ISPALT) |
| 28919 | C |
| 28920 | ITEST=0 |
| 28921 | DO 1100 K=0,IZEIL-1 |
| 28922 | ITEST=ITEST+1 |
| 28923 | IF (ITEST.EQ.IYRAST) THEN |
| 28924 | DO 1010 L=1,ISPALT-1 |
| 28925 | COL(L,K)='-' |
| 28926 | 1010 CONTINUE |
| 28927 | COL(ISPALT,K)='+' |
| 28928 | ITEST=0 |
| 28929 | DO 1020 L=0,ISPALT-1,IXRAST |
| 28930 | COL(L,K)='+' |
| 28931 | 1020 CONTINUE |
| 28932 | ELSE |
| 28933 | DO 1030 L=1,ISPALT-1 |
| 28934 | COL(L,K)=' ' |
| 28935 | 1030 CONTINUE |
| 28936 | DO 1040 L=0,ISPALT-1,IXRAST |
| 28937 | COL(L,K)='|' |
| 28938 | 1040 CONTINUE |
| 28939 | COL(ISPALT,K)='|' |
| 28940 | ENDIF |
| 28941 | 1100 CONTINUE |
| 28942 | C |
| 28943 | C*** plot curve Y1 |
| 28944 | C |
| 28945 | YMAX=Y1(1) |
| 28946 | YMIN=Y1(1) |
| 28947 | DO 500 I=1,N |
| 28948 | YMAX=MAX(Y1(I),YMAX) |
| 28949 | YMIN=MIN(Y1(I),YMIN) |
| 28950 | 500 CONTINUE |
| 28951 | IF(IARG.GT.1) THEN |
| 28952 | DO 550 I=1,N |
| 28953 | YMAX=MAX(Y2(I),YMAX) |
| 28954 | YMIN=MIN(Y2(I),YMIN) |
| 28955 | 550 CONTINUE |
| 28956 | ENDIF |
| 28957 | YMAX=(YMAX-YMIN)/40.0D0+YMAX |
| 28958 | YMIN=YMIN-(YMAX-YMIN)/40.0D0 |
| 28959 | YZOOM=(YMAX-YMIN)/DBLE(IZEIL) |
| 28960 | IF(YZOOM.LT.EPS) THEN |
| 28961 | WRITE(LOUT,'(1X,A)') |
| 28962 | & 'XGRAPH:WARNING: MIN = MAX, OUTPUT SUPPRESSED' |
| 28963 | RETURN |
| 28964 | ENDIF |
| 28965 | C |
| 28966 | C*** plot curve Y1 |
| 28967 | C |
| 28968 | ILAST=-1 |
| 28969 | LLAST=-1 |
| 28970 | DO 1200 K=1,N |
| 28971 | L=NINT((X(K)-XMIN)/XZOOM) |
| 28972 | I=NINT((YMAX-Y1(K))/YZOOM) |
| 28973 | IF(ILAST.GE.0) THEN |
| 28974 | LD = L-LLAST |
| 28975 | ID = I-ILAST |
| 28976 | DO 55 II=0,LD,SIGN(1,LD) |
| 28977 | DO 66 KK=0,ID,SIGN(1,ID) |
| 28978 | COL(II+LLAST,KK+ILAST)=SYMB(1) |
| 28979 | 66 CONTINUE |
| 28980 | 55 CONTINUE |
| 28981 | ELSE |
| 28982 | COL(L,I)=SYMB(1) |
| 28983 | ENDIF |
| 28984 | ILAST = I |
| 28985 | LLAST = L |
| 28986 | 1200 CONTINUE |
| 28987 | C |
| 28988 | IF(IARG.GT.1) THEN |
| 28989 | C |
| 28990 | C*** plot curve Y2 |
| 28991 | C |
| 28992 | DO 1250 K=1,N |
| 28993 | L=NINT((X(K)-XMIN)/XZOOM) |
| 28994 | I=NINT((YMAX-Y2(K))/YZOOM) |
| 28995 | COL(L,I)=SYMB(2) |
| 28996 | 1250 CONTINUE |
| 28997 | ENDIF |
| 28998 | C |
| 28999 | C*** write it |
| 29000 | C |
| 29001 | WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT) |
| 29002 | C |
| 29003 | C*** write range of X |
| 29004 | C |
| 29005 | XZOOM = (XMAX-XMIN)/DBLE(7) |
| 29006 | WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7) |
| 29007 | C |
| 29008 | DO 1300 K=0,IZEIL-1 |
| 29009 | YPOS=YMAX-((DBLE(K)+0.5D0)*YZOOM) |
| 29010 | WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT) |
| 29011 | 110 FORMAT(1X,1PE9.2,70A1) |
| 29012 | 1300 CONTINUE |
| 29013 | C |
| 29014 | C*** write range of X |
| 29015 | C |
| 29016 | XZOOM = (XMAX-XMIN)/DBLE(7) |
| 29017 | WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7) |
| 29018 | WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT) |
| 29019 | 120 FORMAT(6X,7(1PE10.3)) |
| 29020 | END |
| 29021 | * |
| 29022 | *===qglogy=============================================================* |
| 29023 | * |
| 29024 | CDECK ID>, DT_XGLOGY |
| 29025 | SUBROUTINE DT_XGLOGY(N,IARG,X,Y1,Y2) |
| 29026 | C*********************************************************************** |
| 29027 | C |
| 29028 | C calculate quasi graphic picture with 25 lines and 79 columns |
| 29029 | C logarithmic y axis |
| 29030 | C ranges will be chosen automatically |
| 29031 | C |
| 29032 | C input N dimension of input fields |
| 29033 | C IARG number of curves (fields) to plot |
| 29034 | C X field of X |
| 29035 | C Y1 field of Y1 |
| 29036 | C Y2 field of Y2 |
| 29037 | C |
| 29038 | C This subroutine is written by R. Engel. |
| 29039 | C*********************************************************************** |
| 29040 | C |
| 29041 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 29042 | SAVE |
| 29043 | |
| 29044 | PARAMETER ( LINP = 5 , |
| 29045 | & LOUT = 6 , |
| 29046 | & LDAT = 9 ) |
| 29047 | |
| 29048 | DIMENSION X(N),Y1(N),Y2(N) |
| 29049 | PARAMETER (EPS=1.D-30) |
| 29050 | PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20) |
| 29051 | CHARACTER SYMB(5) |
| 29052 | CHARACTER COL(0:149,0:49) |
| 29053 | PARAMETER (DEPS = 1.D-10) |
| 29054 | C |
| 29055 | DATA SYMB /'0','e','z','#','x'/ |
| 29056 | C |
| 29057 | ISPALT=IBREIT-10 |
| 29058 | C |
| 29059 | C*** automatic range fitting |
| 29060 | C |
| 29061 | XMAX=X(1) |
| 29062 | XMIN=X(1) |
| 29063 | DO 600 I=1,N |
| 29064 | XMAX=MAX(X(I),XMAX) |
| 29065 | XMIN=MIN(X(I),XMIN) |
| 29066 | 600 CONTINUE |
| 29067 | XZOOM=(XMAX-XMIN)/DBLE(ISPALT) |
| 29068 | C |
| 29069 | ITEST=0 |
| 29070 | DO 1100 K=0,IZEIL-1 |
| 29071 | ITEST=ITEST+1 |
| 29072 | IF (ITEST.EQ.IYRAST) THEN |
| 29073 | DO 1010 L=1,ISPALT-1 |
| 29074 | COL(L,K)='-' |
| 29075 | 1010 CONTINUE |
| 29076 | COL(ISPALT,K)='+' |
| 29077 | ITEST=0 |
| 29078 | DO 1020 L=0,ISPALT-1,IXRAST |
| 29079 | COL(L,K)='+' |
| 29080 | 1020 CONTINUE |
| 29081 | ELSE |
| 29082 | DO 1030 L=1,ISPALT-1 |
| 29083 | COL(L,K)=' ' |
| 29084 | 1030 CONTINUE |
| 29085 | DO 1040 L=0,ISPALT-1,IXRAST |
| 29086 | COL(L,K)='|' |
| 29087 | 1040 CONTINUE |
| 29088 | COL(ISPALT,K)='|' |
| 29089 | ENDIF |
| 29090 | 1100 CONTINUE |
| 29091 | C |
| 29092 | C*** plot curve Y1 |
| 29093 | C |
| 29094 | YMAX=Y1(1) |
| 29095 | YMIN=MAX(Y1(1),EPS) |
| 29096 | DO 500 I=1,N |
| 29097 | YMAX =MAX(Y1(I),YMAX) |
| 29098 | IF(Y1(I).GT.EPS) THEN |
| 29099 | IF(YMIN.EQ.EPS) THEN |
| 29100 | YMIN = Y1(I)/10.D0 |
| 29101 | ELSE |
| 29102 | YMIN = MIN(Y1(I),YMIN) |
| 29103 | ENDIF |
| 29104 | ENDIF |
| 29105 | 500 CONTINUE |
| 29106 | IF(IARG.GT.1) THEN |
| 29107 | DO 550 I=1,N |
| 29108 | YMAX=MAX(Y2(I),YMAX) |
| 29109 | IF(Y2(I).GT.EPS) THEN |
| 29110 | IF(YMIN.EQ.EPS) THEN |
| 29111 | YMIN = Y2(I) |
| 29112 | ELSE |
| 29113 | YMIN = MIN(Y2(I),YMIN) |
| 29114 | ENDIF |
| 29115 | ENDIF |
| 29116 | 550 CONTINUE |
| 29117 | ENDIF |
| 29118 | C |
| 29119 | DO 560 I=1,N |
| 29120 | Y1(I) = MAX(Y1(I),YMIN) |
| 29121 | 560 CONTINUE |
| 29122 | IF(IARG.GT.1) THEN |
| 29123 | DO 570 I=1,N |
| 29124 | Y2(I) = MAX(Y2(I),YMIN) |
| 29125 | 570 CONTINUE |
| 29126 | ENDIF |
| 29127 | C |
| 29128 | IF(YMAX.LE.YMIN) THEN |
| 29129 | WRITE(LOUT,'(/1X,A,2E12.3,/)') |
| 29130 | & 'XGLOGY:ERROR:YMIN,YMAX ',YMIN,YMAX |
| 29131 | WRITE(LOUT,'(1X,A)') 'MIN = MAX, OUTPUT SUPPRESSED' |
| 29132 | RETURN |
| 29133 | ENDIF |
| 29134 | C |
| 29135 | YMA=(LOG10(YMAX)-LOG10(YMIN))/20.0D0+LOG10(YMAX) |
| 29136 | YMI=LOG10(YMIN)-(LOG10(YMAX)-LOG10(YMIN))/20.0D0 |
| 29137 | YZOOM=(YMA-YMI)/DBLE(IZEIL) |
| 29138 | IF(YZOOM.LT.EPS) THEN |
| 29139 | WRITE(LOUT,'(1X,A)') |
| 29140 | & 'XGLOGY:WARNING: MIN = MAX, OUTPUT SUPPRESSED' |
| 29141 | RETURN |
| 29142 | ENDIF |
| 29143 | C |
| 29144 | C*** plot curve Y1 |
| 29145 | C |
| 29146 | ILAST=-1 |
| 29147 | LLAST=-1 |
| 29148 | DO 1200 K=1,N |
| 29149 | L=NINT((X(K)-XMIN)/XZOOM) |
| 29150 | I=NINT((YMA-LOG10(Y1(K)))/YZOOM) |
| 29151 | IF(ILAST.GE.0) THEN |
| 29152 | LD = L-LLAST |
| 29153 | ID = I-ILAST |
| 29154 | DO 55 II=0,LD,SIGN(1,LD) |
| 29155 | DO 66 KK=0,ID,SIGN(1,ID) |
| 29156 | COL(II+LLAST,KK+ILAST)=SYMB(1) |
| 29157 | 66 CONTINUE |
| 29158 | 55 CONTINUE |
| 29159 | ELSE |
| 29160 | COL(L,I)=SYMB(1) |
| 29161 | ENDIF |
| 29162 | ILAST = I |
| 29163 | LLAST = L |
| 29164 | 1200 CONTINUE |
| 29165 | C |
| 29166 | IF(IARG.GT.1) THEN |
| 29167 | C |
| 29168 | C*** plot curve Y2 |
| 29169 | C |
| 29170 | DO 1250 K=1,N |
| 29171 | L=NINT((X(K)-XMIN)/XZOOM) |
| 29172 | I=NINT((YMA-LOG10(Y2(K)))/YZOOM) |
| 29173 | COL(L,I)=SYMB(2) |
| 29174 | 1250 CONTINUE |
| 29175 | ENDIF |
| 29176 | C |
| 29177 | C*** write it |
| 29178 | C |
| 29179 | WRITE(LOUT,'(2X,A)') '(LOGARITHMIC Y AXIS)' |
| 29180 | WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT) |
| 29181 | C |
| 29182 | C*** write range of X |
| 29183 | C |
| 29184 | XZOOM1 = (XMAX-XMIN)/DBLE(7) |
| 29185 | WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7) |
| 29186 | C |
| 29187 | DO 1300 K=0,IZEIL-1 |
| 29188 | YPOS=10.D0**(YMA-((DBLE(K)+0.5D0)*YZOOM)) |
| 29189 | WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT) |
| 29190 | 110 FORMAT(1X,1PE9.2,70A1) |
| 29191 | 1300 CONTINUE |
| 29192 | C |
| 29193 | C*** write range of X |
| 29194 | C |
| 29195 | WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7) |
| 29196 | WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT) |
| 29197 | 120 FORMAT(6X,7(1PE10.3)) |
| 29198 | C |
| 29199 | END |
| 29200 | * |
| 29201 | *===plot===============================================================* |
| 29202 | * |
| 29203 | CDECK ID>, DT_SRPLOT |
| 29204 | SUBROUTINE DT_SRPLOT(X,Y,N,M,MM,XO,DX,YO,DY) |
| 29205 | |
| 29206 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 29207 | SAVE |
| 29208 | |
| 29209 | PARAMETER ( LINP = 5 , |
| 29210 | & LOUT = 6 , |
| 29211 | & LDAT = 9 ) |
| 29212 | |
| 29213 | * |
| 29214 | * initial version |
| 29215 | * J. Ranft, (FORTRAN-Programmierung,J.R.,Teubner, Leipzig, 72) |
| 29216 | * This is a subroutine of fluka to plot Y across the page |
| 29217 | * as a function of X down the page. Up to 37 curves can be |
| 29218 | * plotted in the same picture with different plotting characters. |
| 29219 | * Output of first 10 overprinted characters addad by FB 88 |
| 29220 | * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - |
| 29221 | * |
| 29222 | * Input Variables: |
| 29223 | * X = array containing the values of X |
| 29224 | * Y = array containing the values of Y |
| 29225 | * N = number of values in X and in Y |
| 29226 | * can exceed the fixed number of lines |
| 29227 | * M = number of different curves X,Y are containing |
| 29228 | * MM = number of points in each curve i.e. N=M*MM |
| 29229 | * XO = smallest value of X to be plotted |
| 29230 | * DX = increment of X between subsequent lines |
| 29231 | * YO = smallest value of Y to be plotted |
| 29232 | * DY = increment of Y between subsequent character spaces |
| 29233 | * |
| 29234 | * other variables used inside: |
| 29235 | * XX = numbers along the X-coordinate axis |
| 29236 | * YY = numbers along the Y-coordinate axis |
| 29237 | * LL = ten lines temporary storage for the plot |
| 29238 | * L = character set used to plot different curves |
| 29239 | * LOV = memorizes overprinted symbols |
| 29240 | * the first 10 overprinted symbols are printed on |
| 29241 | * the end of the line to avoid ambiguities |
| 29242 | * (added by FB as considered quite helpful) |
| 29243 | * |
| 29244 | ********************************************************************* |
| 29245 | * |
| 29246 | DIMENSION XX(61),YY(61),LL(101,10) |
| 29247 | DIMENSION X(N),Y(N),L(40),LOV(40,10) |
| 29248 | DATA L/ |
| 29249 | 11H*,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1HZ, |
| 29250 | 21H+,1HA,1HO,1HB,1HC,1HD,1HE,1HF,1HG,1HH, |
| 29251 | 31HI,1HJ,1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR, |
| 29252 | 41HS,1HT,1HU,1HV,1HW,1HX,1HY,1H1,1H-,1H / |
| 29253 | * |
| 29254 | * |
| 29255 | MN=51 |
| 29256 | DO 10 I=1,MN |
| 29257 | AI=I-1 |
| 29258 | 10 XX(I)=XO+AI*DX |
| 29259 | DO 20 I=1,11 |
| 29260 | AI=I-1 |
| 29261 | 20 YY(I)=YO+10.0D0*AI*DY |
| 29262 | WRITE(LOUT, 500) (YY(I),I=1,11) |
| 29263 | MMN=MN-1 |
| 29264 | * |
| 29265 | * |
| 29266 | DO 90 JJ=1,MMN,10 |
| 29267 | JJJ=JJ-1 |
| 29268 | DO 30 I=1,101 |
| 29269 | DO 30 J=1,10 |
| 29270 | 30 LL(I,J)=L(40) |
| 29271 | DO 40 I=1,101 |
| 29272 | 40 LL(I,1)=L(39) |
| 29273 | DO 50 I=1,101,10 |
| 29274 | DO 50 J=1,10 |
| 29275 | 50 LL(I,J)=L(38) |
| 29276 | DO 60 I=1,40 |
| 29277 | DO 60 J=1,10 |
| 29278 | 60 LOV(I,J)=L(40) |
| 29279 | * |
| 29280 | * |
| 29281 | DO 70 I=1,M |
| 29282 | DO 70 J=1,MM |
| 29283 | II=J+(I-1)*MM |
| 29284 | AIX=(X(II)-(XO-DX/2.0D0))/DX+1.0D0 |
| 29285 | AIY=(Y(II)-(YO-DY/2.0D0))/DY+1.0D0 |
| 29286 | AIX=AIX-DBLE(JJJ) |
| 29287 | * changed Sept.88 by FB to avoid INTEGER OVERFLOW |
| 29288 | IF( AIX .GT. 1.D0.AND. AIX .LT. 11.D0.AND. AIY .GT. 1.D0.AND |
| 29289 | + . AIY .LT. 102.D0) THEN |
| 29290 | IX=INT(AIX) |
| 29291 | IY=INT(AIY) |
| 29292 | IF( IX.GT. 0.AND. IX.LE. 10.AND. IY.GT. 0.AND. IY.LE. 101) |
| 29293 | + THEN |
| 29294 | IF(LL(IY,IX).NE.L(38).AND.LL(IY,IX).NE.L(39)) LOV(I,IX) |
| 29295 | + =LL(IY,IX) |
| 29296 | LL(IY,IX)=L(I) |
| 29297 | ENDIF |
| 29298 | ENDIF |
| 29299 | 70 CONTINUE |
| 29300 | * |
| 29301 | * |
| 29302 | DO 80 I=1,10 |
| 29303 | II=I+JJJ |
| 29304 | III=II+1 |
| 29305 | WRITE(LOUT,510) XX(II),XX(III) , (LL(J,I),J=1,101) , |
| 29306 | & (LOV(J,I),J=1,10) |
| 29307 | 80 CONTINUE |
| 29308 | 90 CONTINUE |
| 29309 | * |
| 29310 | * |
| 29311 | WRITE(LOUT, 520) |
| 29312 | WRITE(LOUT, 500) (YY(I),I=1,11) |
| 29313 | RETURN |
| 29314 | * |
| 29315 | 500 FORMAT(11X,11(1PE10.2),11HOVERPRINTED) |
| 29316 | 510 FORMAT(1X,2(1PE10.2),101A1,1H ,10A1) |
| 29317 | 520 FORMAT(20X,10('1---------'),'1') |
| 29318 | END |
| 29319 | * |
| 29320 | *===defset=============================================================* |
| 29321 | * |
| 29322 | CDECK ID>, DT_DEFSET |
| 29323 | BLOCK DATA DT_DEFSET |
| 29324 | |
| 29325 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 29326 | SAVE |
| 29327 | |
| 29328 | * flags for input different options |
| 29329 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 29330 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 29331 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 29332 | |
| 29333 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) |
| 29334 | |
| 29335 | * emulsion treatment |
| 29336 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), |
| 29337 | & NCOMPO,IEMUL |
| 29338 | |
| 29339 | * / DTFLG1 / |
| 29340 | DATA IFRAG / 2, 1 / |
| 29341 | DATA IRESCO / 1 / |
| 29342 | DATA IMSHL / 1 / |
| 29343 | DATA IRESRJ / 0 / |
| 29344 | DATA IOULEV / -1, -1, -1, -1, -1, -1 / |
| 29345 | DATA LEMCCK / .FALSE. / |
| 29346 | DATA LHADRO / .FALSE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE., |
| 29347 | & .TRUE.,.TRUE.,.TRUE./ |
| 29348 | DATA LSEADI / .TRUE. / |
| 29349 | DATA LEVAPO / .TRUE. / |
| 29350 | DATA IFRAME / 1 / |
| 29351 | * Introduced by Chiara -> Forcing CMS-system |
| 29352 | * DATA IFRAME / 2 / |
| 29353 | DATA ITRSPT / 0 / |
| 29354 | |
| 29355 | * / DTCOMP / |
| 29356 | DATA EMUFRA / NCOMPX*0.0D0 / |
| 29357 | DATA IEMUMA / NCOMPX*1 / |
| 29358 | DATA IEMUCH / NCOMPX*1 / |
| 29359 | DATA NCOMPO / 0 / |
| 29360 | DATA IEMUL / 0 / |
| 29361 | |
| 29362 | END |
| 29363 | * |
| 29364 | * |
| 29365 | *===hadprp=============================================================* |
| 29366 | * |
| 29367 | CDECK ID>, DT_HADPRP |
| 29368 | BLOCK DATA DT_HADPRP |
| 29369 | |
| 29370 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 29371 | SAVE |
| 29372 | |
| 29373 | * auxiliary common for reggeon exchange (DTUNUC 1.x) |
| 29374 | COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6), |
| 29375 | & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6), |
| 29376 | & IQTCHR(-6:6),MQUARK(3,39) |
| 29377 | * hadron index conversion (BAMJET <--> PDG) |
| 29378 | COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22), |
| 29379 | & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19), |
| 29380 | & IAMCIN(210) |
| 29381 | * names of hadrons used in input-cards |
| 29382 | CHARACTER*8 BTYPE |
| 29383 | COMMON /DTPAIN/ BTYPE(30) |
| 29384 | |
| 29385 | * / DTQUAR / |
| 29386 | *----------------------------------------------------------------------* |
| 29387 | * * |
| 29388 | * Quark content of particles: * |
| 29389 | * index quark el. charge bar. charge isospin isospin3 * |
| 29390 | * 1 = u 2/3 1/3 1/2 1/2 * |
| 29391 | * -1 = ubar -2/3 -1/3 1/2 -1/2 * |
| 29392 | * 2 = d -1/3 1/3 1/2 -1/2 * |
| 29393 | * -2 = dbar 1/3 -1/3 1/2 1/2 * |
| 29394 | * 3 = s -1/3 1/3 0 0 * |
| 29395 | * -3 = sbar 1/3 -1/3 0 0 * |
| 29396 | * 4 = c 2/3 1/3 0 0 * |
| 29397 | * -4 = cbar -2/3 -1/3 0 0 * |
| 29398 | * 5 = b -1/3 1/3 0 0 * |
| 29399 | * -5 = bbar 1/3 -1/3 0 0 * |
| 29400 | * 6 = t 2/3 1/3 0 0 * |
| 29401 | * -6 = tbar -2/3 -1/3 0 0 * |
| 29402 | * * |
| 29403 | * Mquark = particle quark composition (Paprop numbering) * |
| 29404 | * Iqechr = electric charge ( in 1/3 unit ) * |
| 29405 | * Iqbchr = baryonic charge ( in 1/3 unit ) * |
| 29406 | * Iqichr = isospin ( in 1/2 unit ), z component * |
| 29407 | * Iqschr = strangeness * |
| 29408 | * Iqcchr = charm * |
| 29409 | * Iquchr = beauty * |
| 29410 | * Iqtchr = ...... * |
| 29411 | * * |
| 29412 | *----------------------------------------------------------------------* |
| 29413 | DATA IQECHR / -2, 1, -2, 1, 1, -2, 0, 2, -1, -1, 2, -1, 2 / |
| 29414 | DATA IQBCHR / 6*-1, 0, 6*1 / |
| 29415 | DATA IQICHR / 4*0, 1, -1, 0, 1, -1, 4*0 / |
| 29416 | DATA IQSCHR / 3*0, 1, 5*0, -1, 3*0 / |
| 29417 | DATA IQCCHR / 2*0, -1, 7*0, 1, 2*0 / |
| 29418 | DATA IQUCHR / 0, 1, 9*0, -1, 0 / |
| 29419 | DATA IQTCHR / -1, 11*0, 1 / |
| 29420 | DATA MQUARK / |
| 29421 | & 2, 1, 1, -2,-1,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 29422 | & 0, 0, 0, 0, 0, 0, 2, 2, 1, -2,-2,-1, 0, 0, 0, |
| 29423 | & 0, 0, 0, 0, 0, 0, 1,-2, 0, 2,-1, 0, 1,-3, 0, |
| 29424 | & 3,-1, 0, 1, 2, 3, -1,-2,-3, 0, 0, 0, 2, 2, 3, |
| 29425 | & 1, 1, 3, 1, 2, 3, 1,-1, 0, 2,-3, 0, 3,-2, 0, |
| 29426 | & 2,-2, 0, 3,-3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 29427 | & -1,-1,-3, -1,-2,-3, -2,-2,-3, 1, 3, 3, -1,-3,-3, |
| 29428 | & 2, 3, 3, -2,-3,-3, 3, 3, 3, -3,-3,-3 / |
| 29429 | |
| 29430 | * / DTHAIC / |
| 29431 | * (renamed) (HAdron InDex COnversion) |
| 29432 | * translation table version filled up by r.e. 25.01.94 * |
| 29433 | DATA IAMCIN / |
| 29434 | &2212,-2212,11,-11,12, -12,22,2112,-2112,-13, |
| 29435 | &13,130,211,-211,321, -321,3122,-3122,310,3112, |
| 29436 | &3222,3212,111,311,-311, 0,0,0,0,0, |
| 29437 | &221,213,113,-213,223, 323,313,-323,-313,10323, |
| 29438 | &10313,-10323,-10313,30323,30313, -30323,-30313,3224,3214,3114, |
| 29439 | &3216,3218,2224,2214,2114, 1114,12224,12214,12114,11114, |
| 29440 | &99999,99999,22212,22112,32124, 31214,-2224,-2214,-2114,-1114, |
| 29441 | &-12224,-12214,-12114,-11114,-2124, -1214,4*99999, |
| 29442 | &5*99999, 5*99999, |
| 29443 | &4*99999,331, 333,3322,3312,-3222,-3212, |
| 29444 | &-3112,-3322,-3312,3224,3214, 3114,3324,3314,3334,-3224, |
| 29445 | &-3214,-3114,-3324,-3314,-3334, 421,411,-411,-421,431, |
| 29446 | &-431,441,423,413,-413, -423,433,-433,20443,443, |
| 29447 | &-15,15,16,-16,14, -14,4122,4232,4132,4222, |
| 29448 | &4212,4112,3*99999, 3*99999,-4122,-4232, |
| 29449 | &-4132,-4222,-4212,-4112,99999, 5*99999, |
| 29450 | &5*99999, 5*99999, |
| 29451 | &10*99999, |
| 29452 | &5*99999 , 20211,20111,-20211,99999,20321, |
| 29453 | &-20321,20311,-20311,7*99999 , |
| 29454 | &7*99999,12212,12112,99999/ |
| 29455 | |
| 29456 | * / DTHAIC / |
| 29457 | * (HAdron InDex COnversion) |
| 29458 | DATA (IPDG2(1,K),K=1,7) |
| 29459 | & / -11, -12, -13, -15, -16, -14, 0/ |
| 29460 | DATA (IBAM2(1,K),K=1,7) |
| 29461 | & / 4, 6, 10, 131, 134, 136, 0/ |
| 29462 | DATA (IPDG2(2,K),K=1,7) |
| 29463 | & / 11, 12, 22, 13, 15, 16, 14/ |
| 29464 | DATA (IBAM2(2,K),K=1,7) |
| 29465 | & / 3, 5, 7, 11, 132, 133, 135/ |
| 29466 | DATA (IPDG3(1,K),K=1,22) |
| 29467 | & / -211, -321, -311, -213, -323, -313, -411, -421, |
| 29468 | & -431, -413, -423, -433, 0, 0, 0, 0, |
| 29469 | & 0, 0, 0, 0, 0, 0/ |
| 29470 | DATA (IBAM3(1,K),K=1,22) |
| 29471 | & / 14, 16, 25, 34, 38, 39, 118, 119, |
| 29472 | & 121, 125, 126, 128, 0, 0, 0, 0, |
| 29473 | & 0, 0, 0, 0, 0, 0/ |
| 29474 | DATA (IPDG3(2,K),K=1,22) |
| 29475 | & / 130, 211, 321, 310, 111, 311, 221, 213, |
| 29476 | & 113, 223, 323, 313, 331, 333, 421, 411, |
| 29477 | & 431, 441, 423, 413, 433, 443/ |
| 29478 | DATA (IBAM3(2,K),K=1,22) |
| 29479 | & / 12, 13, 15, 19, 23, 24, 31, 32, |
| 29480 | & 33, 35, 36, 37, 95, 96, 116, 117, |
| 29481 | & 120, 122, 123, 124, 127, 130/ |
| 29482 | DATA (IPDG4(1,K),K=1,29) |
| 29483 | & / -2212, -2112, -3122, -2224, -2214, -2114, -1114, -2124, |
| 29484 | & -1214, -3222, -3212, -3112, -3322, -3312, -3224, -3214, |
| 29485 | & -3114, -3324, -3314, -3334, -4122, -4232, -4132, -4222, |
| 29486 | & -4212, -4112, 0, 0, 0/ |
| 29487 | DATA (IBAM4(1,K),K=1,29) |
| 29488 | & / 2, 9, 18, 67, 68, 69, 70, 75, |
| 29489 | & 76, 99, 100, 101, 102, 103, 110, 111, |
| 29490 | & 112, 113, 114, 115, 149, 150, 151, 152, |
| 29491 | & 153, 154, 0, 0, 0/ |
| 29492 | DATA (IPDG4(2,K),K=1,29) |
| 29493 | & / 2212, 2112, 3122, 3112, 3222, 3212, 3224, 3214, |
| 29494 | & 3114, 3216, 3218, 2224, 2214, 2114, 1114, 3322, |
| 29495 | & 3312, 3224, 3214, 3114, 3324, 3314, 3334, 4122, |
| 29496 | & 4232, 4132, 4222, 4212, 4112/ |
| 29497 | DATA (IBAM4(2,K),K=1,29) |
| 29498 | & / 1, 8, 17, 20, 21, 22, 48, 49, |
| 29499 | & 50, 51, 52, 53, 54, 55, 56, 97, |
| 29500 | & 98, 104, 105, 106, 107, 108, 109, 137, |
| 29501 | & 138, 139, 140, 141, 142/ |
| 29502 | DATA (IPDG5(1,K),K=1,19) |
| 29503 | & /-10323,-10313,-30323,-30313,-12224,-12214,-12114,-11114, |
| 29504 | & -20211,-20321,-20311, 0, 0, 0, 0, 0, |
| 29505 | & 0, 0, 0/ |
| 29506 | DATA (IBAM5(1,K),K=1,19) |
| 29507 | & / 42, 43, 46, 47, 71, 72, 73, 74, |
| 29508 | & 188, 191, 193, 0, 0, 0, 0, 0, |
| 29509 | & 0, 0, 0/ |
| 29510 | DATA (IPDG5(2,K),K=1,19) |
| 29511 | & / 10323, 10313, 30323, 30313, 12224, 12214, 12114, 11114, |
| 29512 | & 22212, 22112, 32124, 31214, 20443, 20211, 20111, 20321, |
| 29513 | & 20311, 12212, 12112/ |
| 29514 | DATA (IBAM5(2,K),K=1,19) |
| 29515 | & / 40, 41, 44, 45, 57, 58, 59, 60, |
| 29516 | & 63, 64, 65, 66, 129, 186, 187, 190, |
| 29517 | & 192, 208, 209/ |
| 29518 | |
| 29519 | * / DTPAIN / |
| 29520 | * internal particle names |
| 29521 | DATA BTYPE / 'PROTON ' , 'APROTON ' , 'ELECTRON' , 'POSITRON' , |
| 29522 | &'NEUTRIE ' , 'ANEUTRIE' , 'PHOTON ' , 'NEUTRON ' , 'ANEUTRON' , |
| 29523 | &'MUON+ ' , 'MUON- ' , 'KAONLONG' , 'PION+ ' , 'PION- ' , |
| 29524 | &'KAON+ ' , 'KAON- ' , 'LAMBDA ' , 'ALAMBDA ' , 'KAONSHRT' , |
| 29525 | &'SIGMA- ' , 'SIGMA+ ' , 'SIGMAZER' , 'PIZERO ' , 'KAONZERO' , |
| 29526 | &'AKAONZER' , 'NEUTRIM ' , 'ANEUTRIM' , 'NEUTRIT ' , 'ANEUTRIT' , |
| 29527 | &'BLANK ' / |
| 29528 | |
| 29529 | END |
| 29530 | * |
| 29531 | *===blkd46=============================================================* |
| 29532 | * |
| 29533 | CDECK ID>, DT_BLKD46 |
| 29534 | BLOCK DATA DT_BLKD46 |
| 29535 | |
| 29536 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 29537 | SAVE |
| 29538 | |
| 29539 | PARAMETER ( AMELCT = 0.51099906 D-03 ) |
| 29540 | PARAMETER ( AMMUON = 0.105658389 D+00 ) |
| 29541 | |
| 29542 | * particle properties (BAMJET index convention) |
| 29543 | CHARACTER*8 ANAME |
| 29544 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 29545 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 29546 | |
| 29547 | * / DTPART / |
| 29548 | * Particle masses Engel version JETSET compatible |
| 29549 | DATA (AAM(K),K=1,85) / |
| 29550 | & .9383D+00, .9383D+00, AMELCT , AMELCT , .0000D+00, |
| 29551 | & .0000D+00, .0000D+00, .9396D+00, .9396D+00, AMMUON , |
| 29552 | & AMMUON , .4977D+00, .1396D+00, .1396D+00, .4936D+00, |
| 29553 | & .4936D+00, .1116D+01, .1116D+01, .4977D+00, .1197D+01, |
| 29554 | & .1189D+01, .1193D+01, .1350D+00, .4977D+00, .4977D+00, |
| 29555 | & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00, |
| 29556 | & .5488D+00, .7669D+00, .7700D+00, .7669D+00, .7820D+00, |
| 29557 | & .8921D+00, .8962D+00, .8921D+00, .8962D+00, .1300D+01, |
| 29558 | & .1300D+01, .1300D+01, .1300D+01, .1421D+01, .1421D+01, |
| 29559 | & .1421D+01, .1421D+01, .1383D+01, .1384D+01, .1387D+01, |
| 29560 | & .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01, |
| 29561 | & .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01, |
| 29562 | & .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01, |
| 29563 | & .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01, |
| 29564 | & .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01, |
| 29565 | & .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00, |
| 29566 | & .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01 / |
| 29567 | DATA (AAM(K),K=86,183) / |
| 29568 | & .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01, |
| 29569 | & .1700D+01, .1700D+01, .1820D+01, .2030D+01, .9575D+00, |
| 29570 | & .1019D+01, .1315D+01, .1321D+01, .1189D+01, .1193D+01, |
| 29571 | & .1197D+01, .1315D+01, .1321D+01, .1383D+01, .1384D+01, |
| 29572 | & .1387D+01, .1532D+01, .1535D+01, .1672D+01, .1383D+01, |
| 29573 | & .1384D+01, .1387D+01, .1532D+01, .1535D+01, .1672D+01, |
| 29574 | & .1865D+01, .1869D+01, .1869D+01, .1865D+01, .1969D+01, |
| 29575 | & .1969D+01, .2980D+01, .2007D+01, .2010D+01, .2010D+01, |
| 29576 | & .2007D+01, .2113D+01, .2113D+01, .3686D+01, .3097D+01, |
| 29577 | & .1784D+01, .1784D+01, .0000D+00, .0000D+00, .0000D+00, |
| 29578 | & .0000D+00, .2285D+01, .2460D+01, .2460D+01, .2452D+01, |
| 29579 | & .2453D+01, .2454D+01, .2560D+01, .2560D+01, .2730D+01, |
| 29580 | & .3610D+01, .3610D+01, .3790D+01, .2285D+01, .2460D+01, |
| 29581 | & .2460D+01, .2452D+01, .2453D+01, .2454D+01, .2560D+01, |
| 29582 | & .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01, |
| 29583 | & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01, |
| 29584 | & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01, |
| 29585 | & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01, |
| 29586 | & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01, |
| 29587 | & .1250D+01, .1250D+01, .1250D+01 / |
| 29588 | DATA (AAM ( I ), I = 184,210 ) / |
| 29589 | & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00, |
| 29590 | & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00, |
| 29591 | & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00, |
| 29592 | & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00, |
| 29593 | & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00, |
| 29594 | & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00, |
| 29595 | & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00, |
| 29596 | & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00, |
| 29597 | & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/ |
| 29598 | * Particle mean lives |
| 29599 | DATA (TAU(K),K=1,183) / |
| 29600 | & .1000D+19, .1000D+19, .1000D+19, .1000D+19, .1000D+19, |
| 29601 | & .1000D+19, .1000D+19, .9180D+03, .9180D+03, .2200D-05, |
| 29602 | & .2200D-05, .5200D-07, .2600D-07, .2600D-07, .1200D-07, |
| 29603 | & .1200D-07, .2600D-09, .2600D-09, .9000D-10, .1500D-09, |
| 29604 | & .8000D-10, .5000D-14, .8000D-16, .0000D+00, .0000D+00, |
| 29605 | & 70*.0000D+00, |
| 29606 | & .0000D+00, .3000D-09, .1700D-09, .8000D-10, .1000D-13, |
| 29607 | & .1500D-09, .3000D-09, .1700D-09, .0000D+00, .0000D+00, |
| 29608 | & .0000D+00, .0000D+00, .0000D+00, .1000D-09, .0000D+00, |
| 29609 | & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .1000D-09, |
| 29610 | & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00, |
| 29611 | & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00, |
| 29612 | & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00, |
| 29613 | & .9000D-11, .9000D-11, .9000D-11, .9000D-11, .1000D+19, |
| 29614 | & .1000D+19, .0000D+00, .0000D+00, .0000D+00, .0000D+00, |
| 29615 | & 40*.0000D+00, |
| 29616 | & .0000D+00, .0000D+00, .0000D+00 / |
| 29617 | DATA ( TAU ( I ), I = 184,210 ) / |
| 29618 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, |
| 29619 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, |
| 29620 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, |
| 29621 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, |
| 29622 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, |
| 29623 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, |
| 29624 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, |
| 29625 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, |
| 29626 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00/ |
| 29627 | * Resonance width Gamma in GeV |
| 29628 | DATA (GA(K),K= 1,85) / |
| 29629 | & 30*.0000D+00, |
| 29630 | & .8500D-06, .1520D+00, .1520D+00, .1520D+00, .1000D-01, |
| 29631 | & .7900D-01, .7900D-01, .7900D-01, .7900D-01, .4500D+00, |
| 29632 | & .4500D+00, .4500D+00, .4500D+00, .1080D+00, .1080D+00, |
| 29633 | & .1080D+00, .1080D+00, .5000D-01, .5000D-01, .5000D-01, |
| 29634 | & .8500D-01, .1800D+00, .1150D+00, .1150D+00, .1150D+00, |
| 29635 | & .1150D+00, .2000D+00, .2000D+00, .2000D+00, .2000D+00, |
| 29636 | & .2000D+00, .2000D+00, .1000D+00, .1000D+00, .2000D+00, |
| 29637 | & .2000D+00, .1150D+00, .1150D+00, .1150D+00, .1150D+00, |
| 29638 | & .2000D+00, .2000D+00, .2000D+00, .2000D+00, .1000D+00, |
| 29639 | & .1000D+00, .2000D+00, .1000D+00, .1000D+00, .1000D+00, |
| 29640 | & .1000D+00, .1000D+00, .1000D+00, .1000D+00, .2000D+00 / |
| 29641 | DATA (GA(K),K= 86,183) / |
| 29642 | & .2000D+00, .2000D+00, .2000D+00, .1500D+00, .1500D+00, |
| 29643 | & .1500D+00, .1500D+00, .8500D-01, .1800D+00, .2000D-02, |
| 29644 | & .4000D-02, .0000D+00, .0000D+00, .0000D+00, .0000D+00, |
| 29645 | & .0000D+00, .0000D+00, .0000D+00, .3400D-01, .3400D-01, |
| 29646 | & .3600D-01, .9000D-02, .9000D-02, .0000D+00, .3400D-01, |
| 29647 | & .3400D-01, .3600D-01, .9000D-02, .9000D-02, .0000D+00, |
| 29648 | & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00, |
| 29649 | & .0000D+00, .0000D+00, .5000D-02, .2000D-02, .2000D-02, |
| 29650 | & .5000D-02, .2000D-02, .2000D-02, .2000D-03, .7000D-03, |
| 29651 | & 50*.0000D+00, |
| 29652 | & .3000D+00, .3000D+00, .3000D+00 / |
| 29653 | DATA ( GA ( I ), I = 184,210 ) / |
| 29654 | & 2.00000000000000D-01, 2.00000000000000D-01, 3.00000000000000D-01, |
| 29655 | & 3.00000000000000D-01, 3.00000000000000D-01, 2.70000000000000D-01, |
| 29656 | & 2.50000000000000D-01, 2.50000000000000D-01, 2.50000000000000D-01, |
| 29657 | & 2.50000000000000D-01, 1.50000000000000D-01, 1.50000000000000D-01, |
| 29658 | & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01, |
| 29659 | & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01, |
| 29660 | & 6.00000000000000D-02, 6.00000000000000D-02, 6.00000000000000D-02, |
| 29661 | & 6.00000000000000D-02, 5.50000000000000D-02, 5.50000000000000D-02, |
| 29662 | & 2.00000000000000D-01, 2.00000000000000D-01, 0.00000000000000D+00/ |
| 29663 | * Particle names |
| 29664 | * S+1385+Sigma+(1385) L02030+Lambda0(2030) |
| 29665 | * Rho77=Rho(770) Om783=Omega(783) K*14=K*(1420) and so on |
| 29666 | * designation N*@@ means N*@1(@2) |
| 29667 | DATA (ANAME(K),K=1,85) / |
| 29668 | & 'P ','AP ','E- ','E+ ','NUE ', |
| 29669 | & 'ANUE ','GAM ','NEU ','ANEU ','MUE+ ', |
| 29670 | & 'MUE- ','K0L ','PI+ ','PI- ','K+ ', |
| 29671 | & 'K- ','LAM ','ALAM ','K0S ','SIGM- ', |
| 29672 | & 'SIGM+ ','SIGM0 ','PI0 ','K0 ','AK0 ', |
| 29673 | & 'BLANK ','BLANK ','BLANK ','BLANK ','BLANK ', |
| 29674 | & 'ETA550 ','RHO+77 ','RHO077 ','RHO-77 ','OM0783 ', |
| 29675 | & 'K*+892 ','K*0892 ','K*-892 ','AK*089 ','KA+125 ', |
| 29676 | & 'KA0125 ','KA-125 ','AKA012 ','K*+142 ','K*0142 ', |
| 29677 | & 'K*-142 ','AK*014 ','S+1385 ','S01385 ','S-1385 ', |
| 29678 | & 'L01820 ','L02030 ','N*++12 ','N*+ 12 ','N*012 ', |
| 29679 | & 'N*-12 ','N*++16 ','N*+16 ','N*016 ','N*-16 ', |
| 29680 | & 'N*+14 ','N*014 ','N*+15 ','N*015 ','N*+18 ', |
| 29681 | & 'N*018 ','AN--12 ','AN*-12 ','AN*012 ','AN*+12 ', |
| 29682 | & 'AN--16 ','AN*-16 ','AN*016 ','AN*+16 ','AN*-15 ', |
| 29683 | & 'AN*015 ','DE*=24 ','RPI+49 ','RPI049 ','RPI-49 ', |
| 29684 | & 'PIN++ ','PIN+0 ','PIN+- ','PIN-0 ','PPPI ' / |
| 29685 | DATA (ANAME(K),K=86,183) / |
| 29686 | & 'PNPI ','APPPI ','APNPI ','K+PPI ','K-PPI ', |
| 29687 | & 'K+NPI ','K-NPI ','S+1820 ','S-2030 ','ETA* ', |
| 29688 | & 'PHI ','TETA0 ','TETA- ','ASIG- ','ASIG0 ', |
| 29689 | & 'ASIG+ ','ATETA0 ','ATETA+ ','SIG*+ ','SIG*0 ', |
| 29690 | & 'SIG*- ','TETA*0 ','TETA* ','OMEGA- ','ASIG*- ', |
| 29691 | & 'ASIG*0 ','ASIG*+ ','ATET*0 ','ATET*+ ','OMEGA+ ', |
| 29692 | & 'D0 ','D+ ','D- ','AD0 ','F+ ', |
| 29693 | & 'F- ','ETAC ','D*0 ','D*+ ','D*- ', |
| 29694 | & 'AD*0 ','F*+ ','F*- ','PSI ','JPSI ', |
| 29695 | & 'TAU+ ','TAU- ','NUET ','ANUET ','NUEM ', |
| 29696 | & 'ANUEM ','C0+ ','A+ ','A0 ','C1++ ', |
| 29697 | & 'C1+ ','C10 ','S+ ','S0 ','T0 ', |
| 29698 | & 'XU++ ','XD+ ','XS+ ','AC0- ','AA- ', |
| 29699 | & 'AA0 ','AC1-- ','AC1- ','AC10 ','AS- ', |
| 29700 | & 'AS0 ','AT0 ','AXU-- ','AXD- ','AXS ', |
| 29701 | & 'C1*++ ','C1*+ ','C1*0 ','S*+ ','S*0 ', |
| 29702 | & 'T*0 ','XU*++ ','XD*+ ','XS*+ ','TETA++ ', |
| 29703 | & 'AC1*-- ','AC1*- ','AC1*0 ','AS*- ','AS*0 ', |
| 29704 | & 'AT*0 ','AXU*-- ','AXD*- ','AXS*- ','ATET-- ', |
| 29705 | & 'RO ','R+ ','R- ' / |
| 29706 | DATA ( ANAME ( I ), I = 184,210 ) / |
| 29707 | &'AN*-14 ','AN*014 ','PI+130 ','PI0130 ','PI-130 ','F01400 ', |
| 29708 | &'K*+146 ','K*-146 ','K*0146 ','AK0146 ','L01600 ','AL0160 ', |
| 29709 | &'S+1660 ','S01660 ','S-1660 ','AS-166 ','AS0166 ','AS+166 ', |
| 29710 | &'X01950 ','X-1950 ','AX0195 ','AX+195 ','OM-225 ','AOM+22 ', |
| 29711 | &'N*+14 ','N*014 ','BLANK '/ |
| 29712 | * Charge of particles and resonances |
| 29713 | DATA (IICH ( I ), I = 1,210 ) / |
| 29714 | & 1, -1, -1, 1, 0, 0, 0, 0, 0, 1, -1, 0, 1, -1, 1, |
| 29715 | & -1, 0, 0, 0, -1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 29716 | & 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0, |
| 29717 | & -1, 0, 1, 0, -1, 0, 0, 2, 1, 0, -1, 2, 1, 0, -1, |
| 29718 | & 1, 0, 1, 0, 1, 0, -2, -1, 0, 1, -2, -1, 0, 1, -1, |
| 29719 | & 0, 1, 1, 0, -1, 2, 1, 0, -1, 2, 1, 0, -1, 2, 0, |
| 29720 | & 1, -1, 1, -1, 0, 0, 0, -1, -1, 0, 1, 0, 1, 1, 0, |
| 29721 | & -1, 0, -1, -1, -1, 0, 1, 0, 1, 1, 0, 1, -1, 0, 1, |
| 29722 | & -1, 0, 0, 1, -1, 0, 1, -1, 0, 0, 1, -1, 0, 0, 0, |
| 29723 | & 0, 1, 1, 0, 2, 1, 0, 1, 0, 0, 2, 1, 1, -1, -1, |
| 29724 | & 0, -2, -1, 0, -1, 0, 0, -2, -1, -1, 2, 1, 0, 1, 0, |
| 29725 | & 0, 2, 1, 1, 2, -2, -1, 0, -1, 0, 0, -2, -1, -1, -2, |
| 29726 | & 0, 1, -1, -1, 0, 1, 0, -1, 0, 1, -1, 0, 0, 0, 0, |
| 29727 | & 1, 0, -1, -1, 0, 1, 0, -1, 0, 1, -1, 1, 1, 0, 0/ |
| 29728 | * Particle baryonic charges |
| 29729 | DATA (IIBAR ( I ), I = 1,210 ) / |
| 29730 | & 1, -1, 0, 0, 0, 0, 0, 1, -1, 0, 0, 0, 0, 0, 0, |
| 29731 | & 0, 1, -1, 0, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, |
| 29732 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 29733 | & 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, |
| 29734 | & 1, 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1, |
| 29735 | & -1, 2, 0, 0, 0, 1, 1, 1, 1, 2, 2, 0, 0, 1, 1, |
| 29736 | & 1, 1, 1, 1, 0, 0, 1, 1, -1, -1, -1, -1, -1, 1, 1, |
| 29737 | & 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, 0, 0, 0, 0, 0, |
| 29738 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 29739 | & 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, -1, -1, |
| 29740 | & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 1, 1, 1, 1, 1, |
| 29741 | & 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, |
| 29742 | & 0, 0, 0, -1, -1, 0, 0, 0, 0, 0, 0, 0, 0, 1, -1, |
| 29743 | & 1, 1, 1, -1, -1, -1, 1, 1, -1, -1, 1, -1, 1, 1, 0/ |
| 29744 | * First number of decay channels used for resonances |
| 29745 | * and decaying particles |
| 29746 | DATA K1/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 16, 17, |
| 29747 | & 18, 24, 30, 34, 38, 40, 41, 43, 44, 136, 138, 330, 327, 328, |
| 29748 | & 2*330, 46, 51, 52, 54, 55, 58, |
| 29749 | * 50 |
| 29750 | & 60, 62, 64, 66, 68, 70, 72, 74, 82, 90, 98, 106, 109, 112, 114, |
| 29751 | & 123, 140, 141, 143, 145, 146, 150, 157, 164, 168, 174, 180, 187, |
| 29752 | & 194, 202, 210, 211, 213, 215, 216, 220, 227, 234, 238, 245, 252, |
| 29753 | * 85 |
| 29754 | & 254, 255, 256, 257, 259, 262, 265, 267, 269, 272, 276, 279, 282, |
| 29755 | & 286, 290, 293, 299, 331, 335, 339, 340, 341, 343, 344, 345, 346, |
| 29756 | & 347, 350, 353, 356, 358, 360, 363, 366, 369, 372, 374, 376, 379, |
| 29757 | & 383, 385, 387, 391, 394, 397, 400, 402, 405, 408, 410, 412, 414, |
| 29758 | & 417, 420, 425, 430, 431, 432, 433, 434, 448, 452, 457, 458, 459, |
| 29759 | & 460, 461, 462, 466, 468, 470, 472, 486, 490, 495, 496, 497, 498, |
| 29760 | & 499, 500, 504, 506, 508, 510, 511, 512, 513, 514, 515, 516, 517, |
| 29761 | & 518, 519, 522, 523, 524, 525, 526, 527, 528, 529, 530, 531, 534, |
| 29762 | & 537, 539, 541, 547, 553, 558, 563, 568, 572, 573, 574, 575, 576, |
| 29763 | & 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588, 589, |
| 29764 | & 590, 596, 602 / |
| 29765 | * Last number of decay channels used for resonances |
| 29766 | * and decaying particles |
| 29767 | DATA K2/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 15, 16, 17, |
| 29768 | & 23, 29, 31, 35, 39, 40, 42, 43, 45, 137, 139, 330, 327, 328, |
| 29769 | & 2* 330, 50, 51, 53, 54, 57, |
| 29770 | * 50 |
| 29771 | & 59, 61, 63, 65, 67, 69, 71, 73, 81, 89, 97, 105, 108, 111, 113, |
| 29772 | & 122, 135, 140, 142, 144, 145, 149, 156, 163, 167, 173, 179, 186, |
| 29773 | & 193, 201, 209, 210, 212, 214, 215, 219, 226, 233, 237, 244, 251, |
| 29774 | * 85 |
| 29775 | & 253, 254, 255, 256, 258, 261, 264, 266, 268, 271, 275, 278, 281, |
| 29776 | & 285, 289, 292, 298, 307, 334, 338, 339, 340, 342, 343, 344, 345, |
| 29777 | & 346, 349, 352, 355, 357, 359, 362, 365, 368, 371, 373, 375, 378, |
| 29778 | & 382, 384, 386, 390, 393, 396, 399, 401, 404, 407, 409, 411, 413, |
| 29779 | & 416, 419, 424, 429, 430, 431, 432, 433, 447, 451, 456, 457, 458, |
| 29780 | & 459, 460, 461, 465, 467, 469, 471, 485, 489, 494, 495, 496, 497, |
| 29781 | & 498, 499, 503, 505, 507, 509, 510, 511, 512, 513, 514, 515, 516, |
| 29782 | & 517, 518, 521, 522, 523, 524, 525, 526, 527, 528, 529, 530, 533, |
| 29783 | & 536, 538, 540, 546, 552, 557, 562, 567, 571, 572, 573, 574, 575, |
| 29784 | & 576, 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588, |
| 29785 | & 589, 595, 601, 602 / |
| 29786 | |
| 29787 | END |
| 29788 | * |
| 29789 | *===blkd47=============================================================* |
| 29790 | * |
| 29791 | CDECK ID>, DT_BLKD47 |
| 29792 | BLOCK DATA DT_BLKD47 |
| 29793 | |
| 29794 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 29795 | SAVE |
| 29796 | |
| 29797 | * HADRIN: decay channel information |
| 29798 | PARAMETER (IDMAX9=602) |
| 29799 | CHARACTER*8 ZKNAME |
| 29800 | COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3) |
| 29801 | |
| 29802 | * Name of decay channel |
| 29803 | * Designation N*@ means N*@1(1236) |
| 29804 | * @1=# means ++, @1 = = means -- |
| 29805 | * Designation P+/0/- means Pi+/Pi0/Pi- , respectively |
| 29806 | DATA (ZKNAME(K),K= 1, 85) / |
| 29807 | & 'P ','AP ','E- ','E+ ','NUE ', |
| 29808 | & 'ANUE ','GAM ','PE-NUE ','APEANU ','EANUNU ', |
| 29809 | & 'E-NUAN ','3PI0 ','PI+-0 ','PIMUNU ','PIE-NU ', |
| 29810 | & 'MU+NUE ','MU-NUE ','MU+NUE ','PI+PI0 ','PI++- ', |
| 29811 | & 'PI+00 ','M+P0NU ','E+P0NU ','MU-NU ','PI-0 ', |
| 29812 | & 'PI+-- ','PI-00 ','M-P0NU ','E-P0NU ','PPI- ', |
| 29813 | & 'NPI0 ','PD-NUE ','PM-NUE ','APPI+ ','ANPI0 ', |
| 29814 | & 'APE+NU ','APM+NU ','PI+PI- ','PI0PI0 ','NPI- ', |
| 29815 | & 'PPI0 ','NPI+ ','LAGA ','GAGA ','GAE+E- ', |
| 29816 | & 'GAGA ','GAGAP0 ','PI000 ','PI+-0 ','PI+-GA ', |
| 29817 | & 'PI+0 ','PI+- ','PI00 ','PI-0 ','PI+-0 ', |
| 29818 | & 'PI+- ','PI0GA ','K+PI0 ','K0PI+ ','KOPI0 ', |
| 29819 | & 'K+PI- ','K-PI0 ','AK0PI- ','AK0PI0 ','K-PI+ ', |
| 29820 | & 'K+PI0 ','K0PI+ ','K0PI0 ','K+PI- ','K-PI0 ', |
| 29821 | & 'K0PI- ','AK0PI0 ','K-PI+ ','K+PI0 ','K0PI+ ', |
| 29822 | & 'K+89P0 ','K08PI+ ','K+RO77 ','K0RO+7 ','K+OM07 ', |
| 29823 | & 'K+E055 ','K0PI0 ','K+PI+ ','K089P0 ','K+8PI- ' / |
| 29824 | DATA (ZKNAME(K),K= 86,170) / |
| 29825 | & 'K0R077 ','K+R-77 ','K+R-77 ','K0OM07 ','K0E055 ', |
| 29826 | & 'K-PI0 ','K0PI- ','K-89P0 ','AK08P- ','K-R077 ', |
| 29827 | & 'AK0R-7 ','K-OM07 ','K-E055 ','AK0PI0 ','K-PI+ ', |
| 29828 | & 'AK08P0 ','K-8PI+ ','AK0R07 ','AK0OM7 ','AK0E05 ', |
| 29829 | & 'LA0PI+ ','SI0PI+ ','SI+PI0 ','LA0PI0 ','SI+PI- ', |
| 29830 | & 'SI-PI+ ','LA0PI- ','SI0PI- ','NEUAK0 ','PK- ', |
| 29831 | & 'SI+PI- ','SI0PI0 ','SI-PI+ ','LA0ET0 ','S+1PI- ', |
| 29832 | & 'S-1PI+ ','SO1PI0 ','NEUAK0 ','PK- ','LA0PI0 ', |
| 29833 | & 'LA0OM0 ','LA0RO0 ','SI+RO- ','SI-RO+ ','SI0RO0 ', |
| 29834 | & 'LA0ET0 ','SI0ET0 ','SI+PI- ','SI-PI+ ','SI0PI0 ', |
| 29835 | & 'K0S ','K0L ','K0S ','K0L ','P PI+ ', |
| 29836 | & 'P PI0 ','N PI+ ','P PI- ','N PI0 ','N PI- ', |
| 29837 | & 'P PI+ ','N*#PI0 ','N*+PI+ ','PRHO+ ','P PI0 ', |
| 29838 | & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ', |
| 29839 | & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ', |
| 29840 | & 'N*-PI+ ','PRHO- ','NRHO0 ','N PI- ','N*0PI- ', |
| 29841 | & 'N*-PI0 ','NRHO- ','PETA0 ','N*#PI- ','N*+PI0 ' / |
| 29842 | DATA (ZKNAME(K),K=171,255) / |
| 29843 | & 'N*0PI+ ','PRHO0 ','NRHO+ ','NETA0 ','N*+PI- ', |
| 29844 | & 'N*0PI0 ','N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ', |
| 29845 | & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ', |
| 29846 | & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ', |
| 29847 | & 'N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ','N PI+ ', |
| 29848 | & 'PRHO0 ','NRHO+ ','LAMK+ ','S+ K0 ','S0 K+ ', |
| 29849 | & 'PETA0 ','P PI- ','N PI0 ','PRHO- ','NRHO0 ', |
| 29850 | & 'LAMK0 ','S0 K0 ','S- K+ ','NETA/ ','APPI- ', |
| 29851 | & 'APPI0 ','ANPI- ','APPI+ ','ANPI0 ','ANPI+ ', |
| 29852 | & 'APPI- ','AN*=P0 ','AN*-P- ','APRHO- ','APPI0 ', |
| 29853 | & 'ANPI- ','AN*=P+ ','AN*-P0 ','AN*0P- ','APRHO0 ', |
| 29854 | & 'ANRHO- ','APPI+ ','ANPI0 ','AN*-P+ ','AN*0P0 ', |
| 29855 | & 'AN*+P- ','APRHO+ ','ANRHO0 ','ANPI+ ','AN*0P+ ', |
| 29856 | & 'AN*+P0 ','ANRHO+ ','APPI0 ','ANPI- ','AN*=P+ ', |
| 29857 | & 'AN*-P0 ','AN*0P- ','APRHO0 ','ANRHO- ','APPI+, ', |
| 29858 | & 'ANPI0 ','AN*-P+ ','AN*0P0 ','AN*+P- ','APRHO+ ', |
| 29859 | & 'ANRHO0 ','PN*014 ','NN*=14 ','PI+0 ','PI+- ' / |
| 29860 | DATA (ZKNAME(K),K=256,340) / |
| 29861 | & 'PI-0 ','P+0 ','N++ ','P+- ','P00 ', |
| 29862 | & 'N+0 ','N+- ','N00 ','P-0 ','N-0 ', |
| 29863 | & 'P-- ','PPPI0 ','PNPI+ ','PNPI0 ','PPPI- ', |
| 29864 | & 'NNPI+ ','APPPI0 ','APNPI+ ','ANNPI0 ','ANPPI- ', |
| 29865 | & 'APNPI0 ','APPPI- ','ANNPI- ','K+PPI0 ','K+NPI+ ', |
| 29866 | & 'K0PPI0 ','K-PPI0 ','K-NPI+ ','AKPPI- ','AKNPI0 ', |
| 29867 | & 'K+NPI0 ','K+PPI- ','K0PPI0 ','K0NPI+ ','K-NPI0 ', |
| 29868 | & 'K-PPI- ','AKNPI- ','PAK0 ','SI+PI0 ','SI0PI+ ', |
| 29869 | & 'SI+ETA ','S+1PI0 ','S01PI+ ','NEUK- ','LA0PI- ', |
| 29870 | & 'SI-OM0 ','LA0RO- ','SI0RO- ','SI-RO0 ','SI-ET0 ', |
| 29871 | & 'SI0PI- ','SI-0 ','BLANC ','BLANC ','BLANC ', |
| 29872 | & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ', |
| 29873 | & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ', |
| 29874 | & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ', |
| 29875 | & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ', |
| 29876 | & 'EPI+- ','EPI00 ','GAPI+- ','GAGA* ','K+- ', |
| 29877 | & 'KLKS ','PI+-0 ','EGA ','LPI0 ','LPI ' / |
| 29878 | DATA (ZKNAME(K),K=341,425) / |
| 29879 | & 'APPI0 ','ANPI- ','ALAGA ','ANPI ','ALPI0 ', |
| 29880 | & 'ALPI+ ','LAPI+ ','SI+PI0 ','SI0PI+ ','LAPI0 ', |
| 29881 | & 'SI+PI- ','SI-PI+ ','LAPI- ','SI-PI0 ','SI0PI- ', |
| 29882 | & 'TE0PI0 ','TE-PI+ ','TE0PI- ','TE-PI0 ','TE0PI ', |
| 29883 | & 'TE-PI ','LAK- ','ALPI- ','AS-PI0 ','AS0PI- ', |
| 29884 | & 'ALPI0 ','AS+PI- ','AS-PI+ ','ALPI+ ','AS+PI0 ', |
| 29885 | & 'AS0PI+ ','AT0PI0 ','AT+PI- ','AT0PI+ ','AT+PI0 ', |
| 29886 | & 'AT0PI ','AT+PI ','ALK+ ','K-PI+ ','K-PI+0 ', |
| 29887 | & 'K0PI+- ','K0PI0 ','K-PI++ ','AK0PI+ ','K+PI-- ', |
| 29888 | & 'K0PI- ','K+PI- ','K+PI-0 ','AKPI-+ ','AK0PI0 ', |
| 29889 | & 'ETAPIF ','K++- ','K+AK0 ','ETAPI- ','K--+ ', |
| 29890 | & 'K-K0 ','PI00 ','PI+- ','GAGA ','D0PI0 ', |
| 29891 | & 'D0GA ','D0PI+ ','D+PI0 ','DFGA ','AD0PI- ', |
| 29892 | & 'D-PI0 ','D-GA ','AD0PI0 ','AD0GA ','F+GA ', |
| 29893 | & 'F+GA ','F-GA ','F-GA ','PSPI+- ','PSPI00 ', |
| 29894 | & 'PSETA ','E+E- ','MUE+- ','PI+-0 ','M+NN ', |
| 29895 | & 'E+NN ','RHO+NT ','PI+ANT ','K*+ANT ','M-NN ' / |
| 29896 | DATA (ZKNAME(K),K=426,510) / |
| 29897 | & 'E-NN ','RHO-NT ','PI-NT ','K*-NT ','NUET ', |
| 29898 | & 'ANUET ','NUEM ','ANUEM ','SI+ETA ','SI+ET* ', |
| 29899 | & 'PAK0 ','TET0K+ ','SI*+ET ','N*+AK0 ','N*++K- ', |
| 29900 | & 'LAMRO+ ','SI0RO+ ','SI+RO0 ','SI+OME ','PAK*0 ', |
| 29901 | & 'N*+AK* ','N*++K* ','SI+AK0 ','TET0PI ','SI+AK* ', |
| 29902 | & 'TET0RO ','SI0AK* ','SI+K*- ','TET0OM ','TET-RO ', |
| 29903 | & 'SI*0AK ','C0+PI+ ','C0+PI0 ','C0+PI- ','A+GAM ', |
| 29904 | & 'A0GAM ','TET0AK ','TET0K* ','OM-RO+ ','OM-PI+ ', |
| 29905 | & 'C1++AK ','A+PI+ ','C0+AK0 ','A0PI+ ','A+AK0 ', |
| 29906 | & 'T0PI+ ','ASI-ET ','ASI-E* ','APK0 ','ATET0K ', |
| 29907 | & 'ASI*-E ','AN*-K0 ','AN*--K ','ALAMRO ','ASI0RO ', |
| 29908 | & 'ASI-RO ','ASI-OM ','APK*0 ','AN*-K* ','AN*--K ', |
| 29909 | & 'ASI-K0 ','ATETPI ','ASI-K* ','ATETRO ','ASI0K* ', |
| 29910 | & 'ASI-K* ','ATE0OM ','ATE+RO ','ASI*0K ','AC-PI- ', |
| 29911 | & 'AC-PI0 ','AC-PI+ ','AA-GAM ','AA0GAM ','ATET0K ', |
| 29912 | & 'ATE0K* ','AOM+RO ','AOM+PI ','AC1--K ','AA-PI- ', |
| 29913 | & 'AC0-K0 ','AA0PI- ','AA-K0 ','AT0PI- ','C1++GA ' / |
| 29914 | DATA (ZKNAME(K),K=511,540) / |
| 29915 | & 'C1++GA ','C10GAM ','S+GAM ','S0GAM ','T0GAM ', |
| 29916 | & 'XU++GA ','XD+GAM ','XS+GAM ','A+AKPI ','T02PI+ ', |
| 29917 | & 'C1++2K ','AC1--G ','AC1-GA ','AC10GA ','AS-GAM ', |
| 29918 | & 'AS0GAM ','AT0GAM ','AXU--G ','AXD-GA ','AXS-GA ', |
| 29919 | & 'AA-KPI ','AT02PI ','AC1--K ','RH-PI+ ','RH+PI- ', |
| 29920 | & 'RH3PI0 ','RH0PI+ ','RH+PI0 ','RH0PI- ','RH-PI0 ' / |
| 29921 | DATA (ZKNAME(I),I=541,602)/ |
| 29922 | & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHO0','ANRHO-','ANETA ', |
| 29923 | & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0','RH0PI+','RH+PI0', |
| 29924 | & '3PI+00','3PI-++','F0PI+ ','RH+PI-','RH0PI0','3PI000','3PI0+-', |
| 29925 | & 'F0PI0 ','RH0PI-','RH-PI0','3PI-00','3PI--+','F0PI- ','PI0PI0', |
| 29926 | & 'PI+PI-','K+K- ','K0AK0 ','L01600','AL0160','K*+146','K*-146', |
| 29927 | & 'K*0146','AK0146','S+1660','S01660','S-1660','AS-166','AS0166', |
| 29928 | & 'AS+166','X01690','X-1690','AX0169','AX+169','OM-225','AOM+22', |
| 29929 | & 'N*PPI0','N*NPI+','N*P2P0','N*PP+-','N*D+P0','N*D0P+','N*NPI0', |
| 29930 | & 'N*PPI-','N*N2P0','N*NP+-','N*D+P-','N*D0P0','BLANK '/ |
| 29931 | * Weight of decay channel |
| 29932 | DATA (WT(K),K= 1, 85) / |
| 29933 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, |
| 29934 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, |
| 29935 | & .1000D+01, .2100D+00, .1200D+00, .2700D+00, .4000D+00, |
| 29936 | & .1000D+01, .1000D+01, .6400D+00, .2100D+00, .6000D-01, |
| 29937 | & .2000D-01, .3000D-01, .4000D-01, .6400D+00, .2100D+00, |
| 29938 | & .6000D-01, .2000D-01, .3000D-01, .4000D-01, .6400D+00, |
| 29939 | & .3600D+00, .0000D+00, .0000D+00, .6400D+00, .3600D+00, |
| 29940 | & .0000D+00, .0000D+00, .6900D+00, .3100D+00, .1000D+01, |
| 29941 | & .5200D+00, .4800D+00, .1000D+01, .9900D+00, .1000D-01, |
| 29942 | & .3800D+00, .3000D-01, .3000D+00, .2400D+00, .5000D-01, |
| 29943 | & .1000D+01, .1000D+01, .0000D+00, .1000D+01, .9000D+00, |
| 29944 | & .1000D-01, .9000D-01, .3300D+00, .6700D+00, .3300D+00, |
| 29945 | & .6700D+00, .3300D+00, .6700D+00, .3300D+00, .6700D+00, |
| 29946 | & .3300D+00, .6700D+00, .3300D+00, .6700D+00, .3300D+00, |
| 29947 | & .6700D+00, .3300D+00, .6700D+00, .1900D+00, .3800D+00, |
| 29948 | & .9000D-01, .2000D+00, .3000D-01, .4000D-01, .5000D-01, |
| 29949 | & .2000D-01, .1900D+00, .3800D+00, .9000D-01, .2000D+00 / |
| 29950 | DATA (WT(K),K= 86,170) / |
| 29951 | & .3000D-01, .4000D-01, .5000D-01, .2000D-01, .1900D+00, |
| 29952 | & .3800D+00, .9000D-01, .2000D+00, .3000D-01, .4000D-01, |
| 29953 | & .5000D-01, .2000D-01, .1900D+00, .3800D+00, .9000D-01, |
| 29954 | & .2000D+00, .3000D-01, .4000D-01, .5000D-01, .2000D-01, |
| 29955 | & .8800D+00, .6000D-01, .6000D-01, .8800D+00, .6000D-01, |
| 29956 | & .6000D-01, .8800D+00, .1200D+00, .1900D+00, .1900D+00, |
| 29957 | & .1600D+00, .1600D+00, .1700D+00, .3000D-01, .3000D-01, |
| 29958 | & .3000D-01, .4000D-01, .1000D+00, .1000D+00, .2000D+00, |
| 29959 | & .1200D+00, .1000D+00, .4000D-01, .4000D-01, .5000D-01, |
| 29960 | & .7500D-01, .7500D-01, .3000D-01, .3000D-01, .4000D-01, |
| 29961 | & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01, |
| 29962 | & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01, |
| 29963 | & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00, |
| 29964 | & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00, |
| 29965 | & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01, |
| 29966 | & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00, |
| 29967 | & .2700D+00, .3000D+00, .4000D+00, .2000D+00, .1250D+00 / |
| 29968 | DATA (WT(K),K=171,255) / |
| 29969 | & .7500D-01, .7500D-01, .1250D+00, .4000D+00, .7500D-01, |
| 29970 | & .1250D+00, .2000D+00, .1250D+00, .7500D-01, .1800D+00, |
| 29971 | & .3700D+00, .1300D+00, .8000D-01, .4000D-01, .7000D-01, |
| 29972 | & .1300D+00, .3700D+00, .1800D+00, .4000D-01, .8000D-01, |
| 29973 | & .1300D+00, .1300D+00, .7000D-01, .7000D-01, .1300D+00, |
| 29974 | & .2300D+00, .4700D+00, .5000D-01, .2000D-01, .1000D-01, |
| 29975 | & .2000D-01, .1300D+00, .7000D-01, .4700D+00, .2300D+00, |
| 29976 | & .5000D-01, .1000D-01, .2000D-01, .2000D-01, .1000D+01, |
| 29977 | & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01, |
| 29978 | & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00, |
| 29979 | & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00, |
| 29980 | & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01, |
| 29981 | & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00, |
| 29982 | & .2700D+00, .3000D+00, .1800D+00, .3700D+00, .1300D+00, |
| 29983 | & .8000D-01, .4000D-01, .7000D-01, .1300D+00, .3700D+00, |
| 29984 | & .1800D+00, .4000D-01, .8000D-01, .1300D+00, .1300D+00, |
| 29985 | & .7000D-01, .5000D+00, .5000D+00, .1000D+01, .1000D+01 / |
| 29986 | DATA (WT(K),K=256,340) / |
| 29987 | & .1000D+01, .8000D+00, .2000D+00, .6000D+00, .3000D+00, |
| 29988 | & .1000D+00, .6000D+00, .3000D+00, .1000D+00, .8000D+00, |
| 29989 | & .2000D+00, .3300D+00, .6700D+00, .6600D+00, .1700D+00, |
| 29990 | & .1700D+00, .3200D+00, .1700D+00, .3200D+00, .1900D+00, |
| 29991 | & .3300D+00, .3300D+00, .3400D+00, .3000D+00, .5000D-01, |
| 29992 | & .6500D+00, .3800D+00, .1200D+00, .3800D+00, .1200D+00, |
| 29993 | & .3800D+00, .1200D+00, .3800D+00, .1200D+00, .3000D+00, |
| 29994 | & .5000D-01, .6500D+00, .3800D+00, .2500D+00, .2500D+00, |
| 29995 | & .2000D-01, .5000D-01, .5000D-01, .2000D+00, .2000D+00, |
| 29996 | & .1200D+00, .1000D+00, .7000D-01, .7000D-01, .1400D+00, |
| 29997 | & .5000D-01, .5000D-01, .1000D+01, .1000D+01, .1000D+01, |
| 29998 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, |
| 29999 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, |
| 30000 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, |
| 30001 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, |
| 30002 | & .4800D+00, .2400D+00, .2600D+00, .2000D-01, .4700D+00, |
| 30003 | & .3500D+00, .1500D+00, .3000D-01, .1000D+01, .1000D+01 / |
| 30004 | DATA (WT(K),K=341,425) / |
| 30005 | & .5200D+00, .4800D+00, .1000D+01, .1000D+01, .1000D+01, |
| 30006 | & .1000D+01, .9000D+00, .5000D-01, .5000D-01, .9000D+00, |
| 30007 | & .5000D-01, .5000D-01, .9000D+00, .5000D-01, .5000D-01, |
| 30008 | & .3300D+00, .6700D+00, .6700D+00, .3300D+00, .2500D+00, |
| 30009 | & .2500D+00, .5000D+00, .9000D+00, .5000D-01, .5000D-01, |
| 30010 | & .9000D+00, .5000D-01, .5000D-01, .9000D+00, .5000D-01, |
| 30011 | & .5000D-01, .3300D+00, .6700D+00, .6700D+00, .3300D+00, |
| 30012 | & .2500D+00, .2500D+00, .5000D+00, .1000D+00, .5000D+00, |
| 30013 | & .1600D+00, .2400D+00, .7000D+00, .3000D+00, .7000D+00, |
| 30014 | & .3000D+00, .1000D+00, .5000D+00, .1600D+00, .2400D+00, |
| 30015 | & .3000D+00, .4000D+00, .3000D+00, .3000D+00, .4000D+00, |
| 30016 | & .3000D+00, .4900D+00, .4900D+00, .2000D-01, .5500D+00, |
| 30017 | & .4500D+00, .6800D+00, .3000D+00, .2000D-01, .6800D+00, |
| 30018 | & .3000D+00, .2000D-01, .5500D+00, .4500D+00, .9000D+00, |
| 30019 | & .1000D+00, .9000D+00, .1000D+00, .6000D+00, .3000D+00, |
| 30020 | & .1000D+00, .1000D+00, .1000D+00, .8000D+00, .2800D+00, |
| 30021 | & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .2800D+00 / |
| 30022 | DATA (WT(K),K=426,510) / |
| 30023 | & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .1000D+01, |
| 30024 | & .1000D+01, .1000D+01, .1000D+01, .2000D-01, .3000D-01, |
| 30025 | & .7000D-01, .2000D-01, .2000D-01, .4000D-01, .1300D+00, |
| 30026 | & .7000D-01, .6000D-01, .6000D-01, .2000D+00, .1400D+00, |
| 30027 | & .4000D-01, .1000D+00, .2500D+00, .3000D-01, .3000D+00, |
| 30028 | & .4200D+00, .2200D+00, .3500D+00, .1900D+00, .1600D+00, |
| 30029 | & .8000D-01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, |
| 30030 | & .1000D+01, .3700D+00, .2000D+00, .3600D+00, .7000D-01, |
| 30031 | & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00, |
| 30032 | & .5000D+00, .2000D-01, .3000D-01, .7000D-01, .2000D-01, |
| 30033 | & .2000D-01, .4000D-01, .1300D+00, .7000D-01, .6000D-01, |
| 30034 | & .6000D-01, .2000D+00, .1400D+00, .4000D-01, .1000D+00, |
| 30035 | & .2500D+00, .3000D-01, .3000D+00, .4200D+00, .2200D+00, |
| 30036 | & .3500D+00, .1900D+00, .1600D+00, .8000D-01, .1000D+01, |
| 30037 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .3700D+00, |
| 30038 | & .2000D+00, .3600D+00, .7000D-01, .5000D+00, .5000D+00, |
| 30039 | & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01 / |
| 30040 | DATA (WT(K),K=511,540) / |
| 30041 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, |
| 30042 | & .1000D+01, .1000D+01, .1000D+01, .3000D+00, .3000D+00, |
| 30043 | & .4000D+00, .1000D+01, .1000D+01, .1000D+01, .1000D+01, |
| 30044 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, |
| 30045 | & .3000D+00, .3000D+00, .4000D+00, .3300D+00, .3300D+00, |
| 30046 | & .3400D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00 / |
| 30047 | C |
| 30048 | DATA (WT(I),I=541,602) / .0D+00, .3334D+00, .2083D+00, 2*.125D+00, |
| 30049 | & .2083D+00, .0D+00, .125D+00, .2083D+00, .3334D+00, .2083D+00, |
| 30050 | & .125D+00, 0.2D+00, 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00, |
| 30051 | & 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00, 0.2D+00, 0.3D+00, |
| 30052 | & 0.3D+00, 0.0D+00, 0.31D+00, 0.62D+00, 0.035D+00, 0.035D+00, |
| 30053 | & 18*1.D+00, 0.5D+00, 0.16D+00, 2*0.12D+00, 2*0.05D+00, 0.5D+00, |
| 30054 | & 0.16D+00, 2*0.12D+00, 2*0.05D+00, 1.D+00 / |
| 30055 | * Particle numbers in decay channel |
| 30056 | DATA (NZK(K,1),K= 1,170) / |
| 30057 | & 1, 2, 3, 4, 5, 6, 7, 1, 2, 4, |
| 30058 | & 3, 23, 13, 13, 13, 10, 11, 10, 13, 13, |
| 30059 | & 13, 10, 4, 11, 14, 14, 14, 11, 3, 1, |
| 30060 | & 8, 1, 1, 2, 9, 2, 2, 13, 23, 8, |
| 30061 | & 1, 8, 17, 7, 7, 7, 23, 23, 13, 13, |
| 30062 | & 13, 13, 23, 14, 13, 13, 23, 15, 24, 24, |
| 30063 | & 15, 16, 25, 25, 16, 15, 24, 24, 15, 16, |
| 30064 | & 24, 25, 16, 15, 24, 36, 37, 15, 24, 15, |
| 30065 | & 15, 24, 15, 37, 36, 24, 15, 24, 24, 16, |
| 30066 | & 24, 38, 39, 16, 25, 16, 16, 25, 16, 39, |
| 30067 | & 38, 25, 16, 25, 25, 17, 22, 21, 17, 21, |
| 30068 | & 20, 17, 22, 8, 1, 21, 22, 20, 17, 48, |
| 30069 | & 50, 49, 8, 1, 17, 17, 17, 21, 20, 22, |
| 30070 | & 17, 22, 21, 20, 22, 19, 12, 19, 12, 1, |
| 30071 | & 1, 8, 1, 8, 8, 1, 53, 54, 1, 1, |
| 30072 | & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55, |
| 30073 | & 56, 1, 8, 8, 55, 56, 8, 1, 53, 54 / |
| 30074 | DATA (NZK(K,1),K=171,340) / |
| 30075 | & 55, 1, 8, 8, 54, 55, 56, 1, 8, 1, |
| 30076 | & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55, |
| 30077 | & 56, 1, 8, 1, 8, 1, 8, 17, 21, 22, |
| 30078 | & 1, 1, 8, 1, 8, 17, 22, 20, 8, 2, |
| 30079 | & 2, 9, 2, 9, 9, 2, 67, 68, 2, 2, |
| 30080 | & 9, 67, 68, 69, 2, 9, 2, 9, 68, 69, |
| 30081 | & 70, 2, 9, 9, 69, 70, 9, 2, 9, 67, |
| 30082 | & 68, 69, 2, 9, 2, 9, 68, 69, 70, 2, |
| 30083 | & 9, 1, 8, 13, 13, 14, 1, 8, 1, 1, |
| 30084 | & 8, 8, 8, 1, 8, 1, 1, 1, 1, 1, |
| 30085 | & 8, 2, 2, 9, 9, 2, 2, 9, 15, 15, |
| 30086 | & 24, 16, 16, 25, 25, 15, 15, 24, 24, 16, |
| 30087 | & 16, 25, 1, 21, 22, 21, 48, 49, 8, 17, |
| 30088 | & 20, 17, 22, 20, 20, 22, 20, 0, 0, 0, |
| 30089 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 30090 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 30091 | & 31, 31, 13, 7, 15, 12, 13, 31, 17, 17 / |
| 30092 | DATA (NZK(K,1),K=341,510) / |
| 30093 | & 2, 9, 18, 9, 18, 18, 17, 21, 22, 17, |
| 30094 | & 21, 20, 17, 20, 22, 97, 98, 97, 98, 97, |
| 30095 | & 98, 17, 18, 99, 100, 18, 101, 99, 18, 101, |
| 30096 | & 100, 102, 103, 102, 103, 102, 103, 18, 16, 16, |
| 30097 | & 24, 24, 16, 25, 15, 24, 15, 15, 25, 25, |
| 30098 | & 31, 15, 15, 31, 16, 16, 23, 13, 7, 116, |
| 30099 | & 116, 116, 117, 117, 119, 118, 118, 119, 119, 120, |
| 30100 | & 120, 121, 121, 130, 130, 130, 4, 10, 13, 10, |
| 30101 | & 4, 32, 13, 36, 11, 3, 34, 14, 38, 133, |
| 30102 | & 134, 135, 136, 21, 21, 1, 97, 104, 54, 53, |
| 30103 | & 17, 22, 21, 21, 1, 54, 53, 21, 97, 21, |
| 30104 | & 97, 22, 21, 97, 98, 105, 137, 137, 137, 138, |
| 30105 | & 139, 97, 97, 109, 109, 140, 138, 137, 139, 138, |
| 30106 | & 145, 99, 99, 2, 102, 110, 68, 67, 18, 100, |
| 30107 | & 99, 99, 2, 68, 67, 99, 102, 99, 102, 100, |
| 30108 | & 99, 102, 103, 111, 149, 149, 149, 150, 151, 113, |
| 30109 | & 113, 115, 115, 152, 150, 149, 151, 150, 157, 140 / |
| 30110 | DATA (NZK(K,1),K=511,540) / |
| 30111 | & 141, 142, 143, 144, 145, 146, 147, 148, 138, 145, |
| 30112 | & 140, 152, 153, 154, 155, 156, 157, 158, 159, 160, |
| 30113 | & 150, 157, 152, 34, 32, 33, 33, 32, 33, 34 / |
| 30114 | DATA (NZK(I,1),I=541,602) / 2, 67, 68, 69, 2, 9, 9, 68, 69, |
| 30115 | & 70, 2, 9, 33, 32, 13, 14, 189, 32, 34, 23, 23, 189, 33, 34, 14, |
| 30116 | & 14, 189, 23, 13, 15, 24, 36, 38, 37, 39, 194, 195, 196, 197, |
| 30117 | & 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 1, 8, 1, 1, 54, |
| 30118 | & 55, 8, 1, 8, 8, 54, 55, 210/ |
| 30119 | DATA (NZK(K,2),K= 1,170) / |
| 30120 | & 0, 0, 0, 0, 0, 0, 0, 3, 4, 6, |
| 30121 | & 5, 23, 14, 11, 3, 5, 5, 5, 23, 13, |
| 30122 | & 23, 23, 23, 5, 23, 13, 23, 23, 23, 14, |
| 30123 | & 23, 3, 11, 13, 23, 4, 10, 14, 23, 14, |
| 30124 | & 23, 13, 7, 7, 4, 7, 7, 23, 14, 14, |
| 30125 | & 23, 14, 23, 23, 14, 14, 7, 23, 13, 23, |
| 30126 | & 14, 23, 14, 23, 13, 23, 13, 23, 14, 23, |
| 30127 | & 14, 23, 13, 23, 13, 23, 13, 33, 32, 35, |
| 30128 | & 31, 23, 14, 23, 14, 33, 34, 35, 31, 23, |
| 30129 | & 14, 23, 14, 33, 34, 35, 31, 23, 13, 23, |
| 30130 | & 13, 33, 32, 35, 31, 13, 13, 23, 23, 14, |
| 30131 | & 13, 14, 14, 25, 16, 14, 23, 13, 31, 14, |
| 30132 | & 13, 23, 25, 16, 23, 35, 33, 34, 32, 33, |
| 30133 | & 31, 31, 14, 13, 23, 0, 0, 0, 0, 13, |
| 30134 | & 23, 13, 14, 23, 14, 13, 23, 13, 78, 23, |
| 30135 | & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23, |
| 30136 | & 13, 80, 79, 14, 14, 23, 80, 31, 14, 23 / |
| 30137 | DATA (NZK(K,2),K=171,340) / |
| 30138 | & 13, 79, 78, 31, 14, 23, 13, 80, 79, 23, |
| 30139 | & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23, |
| 30140 | & 13, 80, 79, 23, 13, 33, 32, 15, 24, 15, |
| 30141 | & 31, 14, 23, 34, 33, 24, 24, 15, 31, 14, |
| 30142 | & 23, 14, 13, 23, 13, 14, 23, 14, 80, 23, |
| 30143 | & 14, 13, 23, 14, 79, 80, 13, 23, 13, 23, |
| 30144 | & 14, 78, 79, 13, 13, 23, 78, 23, 14, 13, |
| 30145 | & 23, 14, 79, 80, 13, 23, 13, 23, 14, 78, |
| 30146 | & 79, 62, 61, 23, 14, 23, 13, 13, 13, 23, |
| 30147 | & 13, 13, 23, 14, 14, 14, 1, 8, 8, 1, |
| 30148 | & 8, 1, 8, 8, 1, 8, 1, 8, 1, 8, |
| 30149 | & 1, 1, 8, 1, 8, 8, 1, 1, 8, 8, |
| 30150 | & 1, 8, 25, 23, 13, 31, 23, 13, 16, 14, |
| 30151 | & 35, 34, 34, 33, 31, 14, 23, 0, 0, 0, |
| 30152 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 30153 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 30154 | & 13, 23, 14, 7, 16, 19, 14, 7, 23, 14 / |
| 30155 | DATA (NZK(K,2),K=341,510) / |
| 30156 | & 23, 14, 7, 13, 23, 13, 13, 23, 13, 23, |
| 30157 | & 14, 13, 14, 23, 14, 23, 13, 14, 23, 14, |
| 30158 | & 23, 16, 14, 23, 14, 23, 14, 13, 13, 23, |
| 30159 | & 13, 23, 14, 13, 23, 13, 23, 15, 13, 13, |
| 30160 | & 13, 23, 13, 13, 14, 14, 14, 14, 14, 23, |
| 30161 | & 13, 16, 25, 14, 15, 24, 23, 14, 7, 23, |
| 30162 | & 7, 13, 23, 7, 14, 23, 7, 23, 7, 7, |
| 30163 | & 7, 7, 7, 13, 23, 31, 3, 11, 14, 135, |
| 30164 | & 5, 134, 134, 134, 136, 6, 133, 133, 133, 0, |
| 30165 | & 0, 0, 0, 31, 95, 25, 15, 31, 95, 16, |
| 30166 | & 32, 32, 33, 35, 39, 39, 38, 25, 13, 39, |
| 30167 | & 32, 39, 38, 35, 32, 39, 13, 23, 14, 7, |
| 30168 | & 7, 25, 37, 32, 13, 25, 13, 25, 13, 25, |
| 30169 | & 13, 31, 95, 24, 16, 31, 24, 15, 34, 34, |
| 30170 | & 33, 35, 37, 37, 36, 24, 14, 37, 34, 37, |
| 30171 | & 36, 35, 34, 37, 14, 23, 13, 7, 7, 24, |
| 30172 | & 39, 34, 14, 24, 14, 24, 14, 24, 14, 7 / |
| 30173 | DATA (NZK(K,2),K=511,540) / |
| 30174 | & 7, 7, 7, 7, 7, 7, 7, 7, 25, 13, |
| 30175 | & 25, 7, 7, 7, 7, 7, 7, 7, 7, 7, |
| 30176 | & 24, 14, 24, 13, 14, 23, 13, 23, 14, 23 / |
| 30177 | DATA (NZK(I,2),I=541,602) / 31, 13, 23, 14, 79, 80, 31, 13, 23, |
| 30178 | & 14, 78, 79, 13, 23, 23, 13, 13, 14, 13, 23, 13, 23, 14, 23, 23, |
| 30179 | & 14, 14, 23, 14, 16, 25, |
| 30180 | & 4*23, 14*0, 23, 13, 23, 13, 23, 13, 23, 14, |
| 30181 | & 23, 13, 14, 23, 0 / |
| 30182 | DATA (NZK(K,3),K= 1,170) / |
| 30183 | & 0, 0, 0, 0, 0, 0, 0, 5, 6, 5, |
| 30184 | & 6, 23, 23, 5, 5, 0, 0, 0, 0, 14, |
| 30185 | & 23, 5, 5, 0, 0, 14, 23, 5, 5, 0, |
| 30186 | & 0, 5, 5, 0, 0, 5, 5, 0, 0, 0, |
| 30187 | & 0, 0, 0, 0, 3, 0, 7, 23, 23, 7, |
| 30188 | & 0, 0, 0, 0, 23, 0, 0, 0, 0, 0, |
| 30189 | & 110*0 / |
| 30190 | DATA (NZK(K,3),K=171,340) / |
| 30191 | & 80*0, |
| 30192 | & 0, 0, 0, 0, 0, 0, 23, 13, 14, 23, |
| 30193 | & 23, 14, 23, 23, 23, 14, 23, 13, 23, 14, |
| 30194 | & 13, 23, 13, 23, 14, 23, 14, 14, 23, 13, |
| 30195 | & 13, 23, 13, 14, 23, 23, 14, 23, 13, 23, |
| 30196 | & 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, |
| 30197 | & 30*0, |
| 30198 | & 14, 23, 7, 0, 0, 0, 23, 0, 0, 0 / |
| 30199 | DATA (NZK(K,3),K=341,510) / |
| 30200 | & 30*0, |
| 30201 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 23, |
| 30202 | & 14, 0, 13, 0, 14, 0, 0, 23, 13, 0, |
| 30203 | & 0, 15, 0, 0, 16, 0, 0, 0, 0, 0, |
| 30204 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 30205 | & 0, 0, 0, 14, 23, 0, 0, 0, 23, 134, |
| 30206 | & 134, 0, 0, 0, 133, 133, 0, 0, 0, 0, |
| 30207 | & 80*0 / |
| 30208 | DATA (NZK(K,3),K=511,540) / |
| 30209 | & 0, 0, 0, 0, 0, 0, 0, 0, 13, 13, |
| 30210 | & 25, 0, 0, 0, 0, 0, 0, 0, 0, 0, |
| 30211 | & 14, 14, 24, 0, 0, 0, 0, 0, 0, 0 / |
| 30212 | DATA (NZK(I,3),I=541,602) / 12*0, 2*0, 23, 13, 0, 2*0, 23, 14, 0, |
| 30213 | & 2*0, 23, 13, 0, 4*0, 18*0, 2*0, 23, 14, 2*0, 2*0, 23, 14, 2*0, 0/ |
| 30214 | |
| 30215 | END |
| 30216 | |
| 30217 | * |
| 30218 | *====phoini============================================================* |
| 30219 | * |
| 30220 | CDECK ID>, DT_XHOINI |
| 30221 | SUBROUTINE DT_XHOINI |
| 30222 | C SUBROUTINE DT_PHOINI |
| 30223 | |
| 30224 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 30225 | SAVE |
| 30226 | |
| 30227 | PARAMETER ( LINP = 5 , |
| 30228 | & LOUT = 6 , |
| 30229 | & LDAT = 9 ) |
| 30230 | |
| 30231 | RETURN |
| 30232 | END |
| 30233 | * |
| 30234 | *====eventb============================================================* |
| 30235 | * |
| 30236 | CDECK ID>, DT_XVENTB |
| 30237 | SUBROUTINE DT_XVENTB(NCSY,IREJ) |
| 30238 | C SUBROUTINE DT_EVENTB(NCSY,IREJ) |
| 30239 | |
| 30240 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 30241 | SAVE |
| 30242 | |
| 30243 | PARAMETER ( LINP = 5 , |
| 30244 | & LOUT = 6 , |
| 30245 | & LDAT = 9 ) |
| 30246 | |
| 30247 | WRITE(LOUT,1000) |
| 30248 | 1000 FORMAT(1X,'EVENTB: PHOJET-package requested but not linked!') |
| 30249 | STOP |
| 30250 | |
| 30251 | END |
| 30252 | * |
| 30253 | *===event==============================================================* |
| 30254 | * |
| 30255 | CDECK ID>, DT_XVENT |
| 30256 | SUBROUTINE DT_XVENT(IDUM,PP,PT,DUM,IREJ) |
| 30257 | C SUBROUTINE EVENT(IDUM,PP,PT,DUM,IREJ) |
| 30258 | |
| 30259 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 30260 | SAVE |
| 30261 | |
| 30262 | DIMENSION PP(4),PT(4) |
| 30263 | |
| 30264 | RETURN |
| 30265 | END |
| 30266 | * |
| 30267 | *===pohisx=============================================================* |
| 30268 | * |
| 30269 | CDECK ID>, DT_XOHISX |
| 30270 | SUBROUTINE DT_XOHISX(I,X) |
| 30271 | C SUBROUTINE POHISX(I,X) |
| 30272 | |
| 30273 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 30274 | SAVE |
| 30275 | |
| 30276 | RETURN |
| 30277 | END |
| 30278 | * |
| 30279 | *===poluhi=============================================================* |
| 30280 | * |
| 30281 | **PHOJET105a |
| 30282 | C SUBROUTINE XOLUHI(I,X) |
| 30283 | **PHOJET112 |
| 30284 | |
| 30285 | CDECK ID>, PHO_LHIST |
| 30286 | SUBROUTINE PHO_LHIST(I,X) |
| 30287 | |
| 30288 | ** |
| 30289 | |
| 30290 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 30291 | SAVE |
| 30292 | |
| 30293 | RETURN |
| 30294 | END |
| 30295 | * |
| 30296 | CDECK ID>, PDFSET |
| 30297 | C********************************************************************** |
| 30298 | C |
| 30299 | C dummy subroutines, remove to link PDFLIB |
| 30300 | C |
| 30301 | C********************************************************************** |
| 30302 | SUBROUTINE PDFSET(PARAM,VALUE) |
| 30303 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 30304 | DIMENSION PARAM(20),VALUE(20) |
| 30305 | CHARACTER*20 PARAM |
| 30306 | END |
| 30307 | CDECK ID>, STRUCTM |
| 30308 | SUBROUTINE STRUCTM(XI,SCALE2,UV,DV,US,DS,SS,CS,BS,TS,GL) |
| 30309 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 30310 | END |
| 30311 | CDECK ID>, STRUCTP |
| 30312 | SUBROUTINE STRUCTP(XI,SCALE2,P2,IP2,UV,DV,US,DS,SS,CS,BS,TS,GL) |
| 30313 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 30314 | END |
| 30315 | * |
| 30316 | *===diqbrk=============================================================* |
| 30317 | * |
| 30318 | CDECK ID>, DT_DIQBRK |
| 30319 | SUBROUTINE DT_XIQBRK |
| 30320 | C SUBROUTINE DT_DIQBRK |
| 30321 | |
| 30322 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 30323 | SAVE |
| 30324 | |
| 30325 | STOP 'diquark-breaking not implemeted !' |
| 30326 | |
| 30327 | RETURN |
| 30328 | END |
| 30329 | * |
| 30330 | *===pho_rndm===========================================================* |
| 30331 | * |
| 30332 | CDECK ID>, PHO_RNDM |
| 30333 | DOUBLE PRECISION FUNCTION PHO_RNDM(DUMMY) |
| 30334 | |
| 30335 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 30336 | SAVE |
| 30337 | |
| 30338 | PHO_RNDM = DT_RNDM(DUMMY) |
| 30339 | |
| 30340 | RETURN |
| 30341 | END |
| 30342 | * |
| 30343 | *===pyr================================================================* |
| 30344 | * |
| 30345 | CDECK ID>, PYR |
| 30346 | DOUBLE PRECISION FUNCTION PYR(IDUMMY) |
| 30347 | |
| 30348 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 30349 | SAVE |
| 30350 | |
| 30351 | DUMMY = DBLE(IDUMMY) |
| 30352 | PYR = DT_RNDM(DUMMY) |
| 30353 | |
| 30354 | RETURN |
| 30355 | END |
| 30356 | * |
| 30357 | *===elhain=============================================================* |
| 30358 | * |
| 30359 | CDECK ID>, DT_ELHAIN |
| 30360 | SUBROUTINE DT_ELHAIN(IP,PLA,ELAB,CX,CY,CZ,IT,IREJ) |
| 30361 | |
| 30362 | ************************************************************************ |
| 30363 | * Elastic hadron-hadron scattering. * |
| 30364 | * This is a revised version of the original. * |
| 30365 | * This version dated 03.04.98 is written by S. Roesler * |
| 30366 | ************************************************************************ |
| 30367 | |
| 30368 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 30369 | SAVE |
| 30370 | |
| 30371 | PARAMETER ( LINP = 5 , |
| 30372 | & LOUT = 6 , |
| 30373 | & LDAT = 9 ) |
| 30374 | |
| 30375 | PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0, |
| 30376 | & TINY10=1.0D-10) |
| 30377 | |
| 30378 | PARAMETER (ENNTHR = 3.5D0) |
| 30379 | PARAMETER (PLOWH=0.01D0,PHIH=9.0D0, |
| 30380 | & BLOWB=0.05D0,BHIB=0.2D0, |
| 30381 | & BLOWM=0.1D0, BHIM=2.0D0) |
| 30382 | |
| 30383 | * particle properties (BAMJET index convention) |
| 30384 | CHARACTER*8 ANAME |
| 30385 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 30386 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 30387 | * final state from HADRIN interaction |
| 30388 | PARAMETER (MAXFIN=10) |
| 30389 | COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN), |
| 30390 | & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH |
| 30391 | |
| 30392 | C DATA TSLOPE /10.0D0/ |
| 30393 | |
| 30394 | IREJ = 0 |
| 30395 | |
| 30396 | 1 CONTINUE |
| 30397 | |
| 30398 | PLAB = SQRT( (ELAB-AAM(IP))*(ELAB+AAM(IP)) ) |
| 30399 | EKIN = ELAB-AAM(IP) |
| 30400 | * kinematical quantities in cms of the hadrons |
| 30401 | AMP2 = AAM(IP)**2 |
| 30402 | AMT2 = AAM(IT)**2 |
| 30403 | S = AMP2+AMT2+TWO*ELAB*AAM(IT) |
| 30404 | ECM = SQRT(S) |
| 30405 | ECMP = OHALF*ECM+(AMP2-AMT2)/(TWO*ECM) |
| 30406 | PCM = SQRT( (ECMP-AAM(IP))*(ECMP+AAM(IP)) ) |
| 30407 | |
| 30408 | * nucleon-nucleon scattering at E_kin<3.5: use DT_TSAMCS(HETC-KFA) |
| 30409 | IF ( ((IP.EQ.1).OR.(IP.EQ.8)).AND. |
| 30410 | & ((IT.EQ.1).OR.(IT.EQ.8)).AND.(EKIN.LT.ENNTHR) ) THEN |
| 30411 | * TSAMCS treats pp and np only, therefore change pn into np and |
| 30412 | * nn into pp |
| 30413 | IF (IT.EQ.1) THEN |
| 30414 | KPROJ = IP |
| 30415 | ELSE |
| 30416 | KPROJ = 8 |
| 30417 | IF (IP.EQ.8) KPROJ = 1 |
| 30418 | ENDIF |
| 30419 | CALL DT_TSAMCS(KPROJ,EKIN,CTCMS) |
| 30420 | T = TWO*PCM**2*(CTCMS-ONE) |
| 30421 | |
| 30422 | * very crude treatment otherwise: sample t from exponential dist. |
| 30423 | ELSE |
| 30424 | * momentum transfer t |
| 30425 | TMAX = TWO*TWO*PCM**2 |
| 30426 | RR = (PLAB-PLOWH)/(PHIH-PLOWH) |
| 30427 | IF (IIBAR(IP).NE.0) THEN |
| 30428 | TSLOPE = BLOWB+RR*(BHIB-BLOWB) |
| 30429 | ELSE |
| 30430 | TSLOPE = BLOWM+RR*(BHIM-BLOWM) |
| 30431 | ENDIF |
| 30432 | FMAX = EXP(-TSLOPE*TMAX)-ONE |
| 30433 | R = DT_RNDM(RR) |
| 30434 | T = LOG(ONE+R*FMAX+TINY10)/TSLOPE |
| 30435 | IF (T.GT.ZERO) T = LOG(ONE+R*FMAX)/TSLOPE |
| 30436 | ENDIF |
| 30437 | |
| 30438 | * target hadron in Lab after scattering |
| 30439 | ELRH(2) = (TWO*AMT2-T)/(TWO*AAM(IT)) |
| 30440 | PLRH(2) = SQRT( ABS(ELRH(2)-AAM(IT))*(ELRH(2)+AAM(IT)) ) |
| 30441 | IF (PLRH(2).LE.TINY10) THEN |
| 30442 | C WRITE(*,*)'ELHAIN: T,PLRH(2) ',T,PLRH(2) |
| 30443 | GOTO 1 |
| 30444 | ENDIF |
| 30445 | * projectile hadron in Lab after scattering |
| 30446 | ELRH(1) = ELAB+AAM(IT)-ELRH(2) |
| 30447 | PLRH(1) = SQRT( ABS(ELRH(1)-AAM(IP))*(ELRH(1)+AAM(IP)) ) |
| 30448 | * scattering angle of projectile in Lab |
| 30449 | CTLABP = (T-TWO*AMP2+TWO*ELAB*ELRH(1))/(TWO*PLAB*PLRH(1)) |
| 30450 | STLABP = SQRT( (ONE-CTLABP)*(ONE+CTLABP) ) |
| 30451 | CALL DT_DSFECF(SPLABP,CPLABP) |
| 30452 | * direction cosines of projectile in Lab |
| 30453 | CALL DT_STTRAN(CX,CY,CZ,CTLABP,STLABP,SPLABP,CPLABP, |
| 30454 | & CXRH(1),CYRH(1),CZRH(1)) |
| 30455 | * scattering angle of target in Lab |
| 30456 | PLLABT = PLAB-CTLABP*PLRH(1) |
| 30457 | CTLABT = PLLABT/PLRH(2) |
| 30458 | STLABT = SQRT( (ONE-CTLABT)*(ONE+CTLABT) ) |
| 30459 | * direction cosines of target in Lab |
| 30460 | CALL DT_STTRAN(CX,CY,CZ,CTLABT,STLABT,-SPLABP,-CPLABP, |
| 30461 | & CXRH(2),CYRH(2),CZRH(2)) |
| 30462 | * fill /HNFSPA/ |
| 30463 | IRH = 2 |
| 30464 | ITRH(1) = IP |
| 30465 | ITRH(2) = IT |
| 30466 | |
| 30467 | RETURN |
| 30468 | END |
| 30469 | * |
| 30470 | *===tsamcs=============================================================* |
| 30471 | * |
| 30472 | CDECK ID>, DT_TSAMCS |
| 30473 | SUBROUTINE DT_TSAMCS(KPROJ,EKIN,CST) |
| 30474 | |
| 30475 | ************************************************************************ |
| 30476 | * Sampling of cos(theta) for nucleon-proton scattering according to * |
| 30477 | * hetkfa2/bertini parametrization. * |
| 30478 | * This is a revised version of the original (HJM 24/10/88) * |
| 30479 | * This version dated 28.10.95 is written by S. Roesler * |
| 30480 | ************************************************************************ |
| 30481 | |
| 30482 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 30483 | SAVE |
| 30484 | |
| 30485 | PARAMETER ( LINP = 5 , |
| 30486 | & LOUT = 6 , |
| 30487 | & LDAT = 9 ) |
| 30488 | |
| 30489 | PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0, |
| 30490 | & TINY10=1.0D-10) |
| 30491 | |
| 30492 | DIMENSION DCLIN(195),DCHN(143),DCHNA(36),DCHNB(60) |
| 30493 | DIMENSION PDCI(60),PDCH(55) |
| 30494 | |
| 30495 | DATA (DCLIN(I),I=1,80) / |
| 30496 | & 5.000D-01, 1.000D+00, 0.000D+00, 1.000D+00, 0.000D+00, |
| 30497 | & 4.993D-01, 9.881D-01, 5.963D-02, 9.851D-01, 5.945D-02, |
| 30498 | & 4.936D-01, 8.955D-01, 5.224D-01, 8.727D-01, 5.091D-01, |
| 30499 | & 4.889D-01, 8.228D-01, 8.859D-01, 7.871D-01, 8.518D-01, |
| 30500 | & 4.874D-01, 7.580D-01, 1.210D+00, 7.207D-01, 1.117D+00, |
| 30501 | & 4.912D-01, 6.969D-01, 1.516D+00, 6.728D-01, 1.309D+00, |
| 30502 | & 5.075D-01, 6.471D-01, 1.765D+00, 6.667D-01, 1.333D+00, |
| 30503 | & 5.383D-01, 6.054D-01, 1.973D+00, 7.059D-01, 1.176D+00, |
| 30504 | & 5.397D-01, 5.990D-01, 2.005D+00, 7.023D-01, 1.191D+00, |
| 30505 | & 5.336D-01, 6.083D-01, 1.958D+00, 6.959D-01, 1.216D+00, |
| 30506 | & 5.317D-01, 6.075D-01, 1.962D+00, 6.897D-01, 1.241D+00, |
| 30507 | & 5.300D-01, 6.016D-01, 1.992D+00, 6.786D-01, 1.286D+00, |
| 30508 | & 5.281D-01, 6.063D-01, 1.969D+00, 6.786D-01, 1.286D+00, |
| 30509 | & 5.280D-01, 5.960D-01, 2.020D+00, 6.667D-01, 1.333D+00, |
| 30510 | & 5.273D-01, 5.920D-01, 2.040D+00, 6.604D-01, 1.358D+00, |
| 30511 | & 5.273D-01, 5.862D-01, 2.069D+00, 6.538D-01, 1.385D+00/ |
| 30512 | DATA (DCLIN(I),I=81,160) / |
| 30513 | & 5.223D-01, 5.980D-01, 2.814D+00, 6.538D-01, 1.385D+00, |
| 30514 | & 5.202D-01, 5.969D-01, 2.822D+00, 6.471D-01, 1.412D+00, |
| 30515 | & 5.183D-01, 5.881D-01, 2.883D+00, 6.327D-01, 1.469D+00, |
| 30516 | & 5.159D-01, 5.866D-01, 2.894D+00, 6.250D-01, 1.500D+00, |
| 30517 | & 5.133D-01, 5.850D-01, 2.905D+00, 6.170D-01, 1.532D+00, |
| 30518 | & 5.106D-01, 5.833D-01, 2.917D+00, 6.087D-01, 1.565D+00, |
| 30519 | & 5.084D-01, 5.801D-01, 2.939D+00, 6.000D-01, 1.600D+00, |
| 30520 | & 5.063D-01, 5.763D-01, 2.966D+00, 5.909D-01, 1.636D+00, |
| 30521 | & 5.036D-01, 5.730D-01, 2.989D+00, 5.814D-01, 1.674D+00, |
| 30522 | & 5.014D-01, 5.683D-01, 3.022D+00, 5.714D-01, 1.714D+00, |
| 30523 | & 4.986D-01, 5.641D-01, 3.051D+00, 5.610D-01, 1.756D+00, |
| 30524 | & 4.964D-01, 5.580D-01, 3.094D+00, 5.500D-01, 1.800D+00, |
| 30525 | & 4.936D-01, 5.573D-01, 3.099D+00, 5.431D-01, 1.827D+00, |
| 30526 | & 4.909D-01, 5.509D-01, 3.144D+00, 5.313D-01, 1.875D+00, |
| 30527 | & 4.885D-01, 5.512D-01, 3.142D+00, 5.263D-01, 1.895D+00, |
| 30528 | & 4.857D-01, 5.437D-01, 3.194D+00, 5.135D-01, 1.946D+00/ |
| 30529 | DATA (DCLIN(I),I=161,195) / |
| 30530 | & 4.830D-01, 5.353D-01, 3.253D+00, 5.000D-01, 2.000D+00, |
| 30531 | & 4.801D-01, 5.323D-01, 3.274D+00, 4.915D-01, 2.034D+00, |
| 30532 | & 4.770D-01, 5.228D-01, 3.341D+00, 4.767D-01, 2.093D+00, |
| 30533 | & 4.738D-01, 5.156D-01, 3.391D+00, 4.643D-01, 2.143D+00, |
| 30534 | & 4.701D-01, 5.010D-01, 3.493D+00, 4.444D-01, 2.222D+00, |
| 30535 | & 4.672D-01, 4.990D-01, 3.507D+00, 4.375D-01, 2.250D+00, |
| 30536 | & 4.634D-01, 4.856D-01, 3.601D+00, 4.194D-01, 2.323D+00/ |
| 30537 | |
| 30538 | DATA PDCI / |
| 30539 | & 4.400D+02, 1.896D-01, 1.931D-01, 1.982D-01, 1.015D-01, |
| 30540 | & 1.029D-01, 4.180D-02, 4.228D-02, 4.282D-02, 4.350D-02, |
| 30541 | & 2.204D-02, 2.236D-02, 5.900D+02, 1.433D-01, 1.555D-01, |
| 30542 | & 1.774D-01, 1.000D-01, 1.128D-01, 5.132D-02, 5.600D-02, |
| 30543 | & 6.158D-02, 6.796D-02, 3.660D-02, 3.820D-02, 6.500D+02, |
| 30544 | & 1.192D-01, 1.334D-01, 1.620D-01, 9.527D-02, 1.141D-01, |
| 30545 | & 5.283D-02, 5.952D-02, 6.765D-02, 7.878D-02, 4.796D-02, |
| 30546 | & 6.957D-02, 8.000D+02, 4.872D-02, 6.694D-02, 1.152D-01, |
| 30547 | & 9.348D-02, 1.368D-01, 6.912D-02, 7.953D-02, 9.577D-02, |
| 30548 | & 1.222D-01, 7.755D-02, 9.525D-02, 1.000D+03, 3.997D-02, |
| 30549 | & 5.456D-02, 9.804D-02, 8.084D-02, 1.208D-01, 6.520D-02, |
| 30550 | & 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02, 1.093D-01/ |
| 30551 | |
| 30552 | DATA PDCH / |
| 30553 | & 1.000D+03, 9.453D-02, 9.804D-02, 8.084D-02, 1.208D-01, |
| 30554 | & 6.520D-02, 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02, |
| 30555 | & 1.093D-01, 1.400D+03, 1.072D-01, 7.450D-02, 6.645D-02, |
| 30556 | & 1.136D-01, 6.750D-02, 8.580D-02, 1.110D-01, 1.530D-01, |
| 30557 | & 1.010D-01, 1.350D-01, 2.170D+03, 4.004D-02, 3.013D-02, |
| 30558 | & 2.664D-02, 5.511D-02, 4.240D-02, 7.660D-02, 1.364D-01, |
| 30559 | & 2.300D-01, 1.670D-01, 2.010D-01, 2.900D+03, 1.870D-02, |
| 30560 | & 1.804D-02, 1.320D-02, 2.970D-02, 2.860D-02, 5.160D-02, |
| 30561 | & 1.020D-01, 2.400D-01, 2.250D-01, 3.370D-01, 4.400D+03, |
| 30562 | & 1.196D-03, 8.784D-03, 1.517D-02, 2.874D-02, 2.488D-02, |
| 30563 | & 4.464D-02, 8.330D-02, 2.008D-01, 2.360D-01, 3.567D-01/ |
| 30564 | |
| 30565 | DATA (DCHN(I),I=1,90) / |
| 30566 | & 4.770D-01, 4.750D-01, 4.715D-01, 4.685D-01, 4.650D-01, |
| 30567 | & 4.610D-01, 4.570D-01, 4.550D-01, 4.500D-01, 4.450D-01, |
| 30568 | & 4.405D-01, 4.350D-01, 4.300D-01, 4.250D-01, 4.200D-01, |
| 30569 | & 4.130D-01, 4.060D-01, 4.000D-01, 3.915D-01, 3.840D-01, |
| 30570 | & 3.760D-01, 3.675D-01, 3.580D-01, 3.500D-01, 3.400D-01, |
| 30571 | & 3.300D-01, 3.200D-01, 3.100D-01, 3.000D-01, 2.900D-01, |
| 30572 | & 2.800D-01, 2.700D-01, 2.600D-01, 2.500D-01, 2.400D-01, |
| 30573 | & 2.315D-01, 2.240D-01, 2.150D-01, 2.060D-01, 2.000D-01, |
| 30574 | & 1.915D-01, 1.850D-01, 1.780D-01, 1.720D-01, 1.660D-01, |
| 30575 | & 1.600D-01, 1.550D-01, 1.500D-01, 1.450D-01, 1.400D-01, |
| 30576 | & 1.360D-01, 1.320D-01, 1.280D-01, 1.250D-01, 1.210D-01, |
| 30577 | & 1.180D-01, 1.150D-01, 1.120D-01, 1.100D-01, 1.070D-01, |
| 30578 | & 1.050D-01, 1.030D-01, 1.010D-01, 9.900D-02, 9.700D-02, |
| 30579 | & 9.550D-02, 9.480D-02, 9.400D-02, 9.200D-02, 9.150D-02, |
| 30580 | & 9.100D-02, 9.000D-02, 8.990D-02, 8.900D-02, 8.850D-02, |
| 30581 | & 8.750D-02, 8.700D-02, 8.650D-02, 8.550D-02, 8.500D-02, |
| 30582 | & 8.499D-02, 8.450D-02, 8.350D-02, 8.300D-02, 8.250D-02, |
| 30583 | & 8.150D-02, 8.100D-02, 8.030D-02, 8.000D-02, 7.990D-02/ |
| 30584 | DATA (DCHN(I),I=91,143) / |
| 30585 | & 7.980D-02, 7.950D-02, 7.900D-02, 7.860D-02, 7.800D-02, |
| 30586 | & 7.750D-02, 7.650D-02, 7.620D-02, 7.600D-02, 7.550D-02, |
| 30587 | & 7.530D-02, 7.500D-02, 7.499D-02, 7.498D-02, 7.480D-02, |
| 30588 | & 7.450D-02, 7.400D-02, 7.350D-02, 7.300D-02, 7.250D-02, |
| 30589 | & 7.230D-02, 7.200D-02, 7.100D-02, 7.050D-02, 7.020D-02, |
| 30590 | & 7.000D-02, 6.999D-02, 6.995D-02, 6.993D-02, 6.991D-02, |
| 30591 | & 6.990D-02, 6.870D-02, 6.850D-02, 6.800D-02, 6.780D-02, |
| 30592 | & 6.750D-02, 6.700D-02, 6.650D-02, 6.630D-02, 6.600D-02, |
| 30593 | & 6.550D-02, 6.525D-02, 6.510D-02, 6.500D-02, 6.499D-02, |
| 30594 | & 6.498D-02, 6.496D-02, 6.494D-02, 6.493D-02, 6.490D-02, |
| 30595 | & 6.488D-02, 6.485D-02, 6.480D-02/ |
| 30596 | |
| 30597 | DATA DCHNA / |
| 30598 | & 6.300D+02, 7.810D-02, 1.421D-01, 1.979D-01, 2.479D-01, |
| 30599 | & 3.360D-01, 5.400D-01, 7.236D-01, 1.000D+00, 1.540D+03, |
| 30600 | & 2.225D-01, 3.950D-01, 5.279D-01, 6.298D-01, 7.718D-01, |
| 30601 | & 9.405D-01, 9.835D-01, 1.000D+00, 2.560D+03, 2.625D-01, |
| 30602 | & 4.550D-01, 5.963D-01, 7.020D-01, 8.380D-01, 9.603D-01, |
| 30603 | & 9.903D-01, 1.000D+00, 3.520D+03, 4.250D-01, 6.875D-01, |
| 30604 | & 8.363D-01, 9.163D-01, 9.828D-01, 1.000D+00, 1.000D+00, |
| 30605 | & 1.000D+00/ |
| 30606 | |
| 30607 | DATA DCHNB / |
| 30608 | & 6.300D+02, 3.800D-02, 7.164D-02, 1.275D-01, 2.171D-01, |
| 30609 | & 3.227D-01, 4.091D-01, 5.051D-01, 6.061D-01, 7.074D-01, |
| 30610 | & 8.434D-01, 1.000D+00, 2.040D+03, 1.200D-01, 2.115D-01, |
| 30611 | & 3.395D-01, 5.295D-01, 7.251D-01, 8.511D-01, 9.487D-01, |
| 30612 | & 9.987D-01, 1.000D+00, 1.000D+00, 1.000D+00, 2.200D+03, |
| 30613 | & 1.344D-01, 2.324D-01, 3.754D-01, 5.674D-01, 7.624D-01, |
| 30614 | & 8.896D-01, 9.808D-01, 1.000D+00, 1.000D+00, 1.000D+00, |
| 30615 | & 1.000D+00, 2.850D+03, 2.330D-01, 4.130D-01, 6.610D-01, |
| 30616 | & 9.010D-01, 9.970D-01, 1.000D+00, 1.000D+00, 1.000D+00, |
| 30617 | & 1.000D+00, 1.000D+00, 1.000D+00, 3.500D+03, 3.300D-01, |
| 30618 | & 5.450D-01, 7.950D-01, 1.000D+00, 1.000D+00, 1.000D+00, |
| 30619 | & 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00/ |
| 30620 | |
| 30621 | CST = ONE |
| 30622 | IF (EKIN.GT.3.5D0) RETURN |
| 30623 | C |
| 30624 | IF(KPROJ.EQ.8) GOTO 101 |
| 30625 | IF(KPROJ.EQ.1) GOTO 102 |
| 30626 | C* INVALID REACTION |
| 30627 | WRITE(LOUT,'(A,I5/A)') |
| 30628 | & ' INVALID PARTICLE TYPE IN DNUPRE - KPROJ=',KPROJ, |
| 30629 | & ' COS(THETA) = 1D0 RETURNED' |
| 30630 | RETURN |
| 30631 | C-------------------------------- NP ELASTIC SCATTERING---------- |
| 30632 | 101 CONTINUE |
| 30633 | IF (EKIN.GT.0.740D0)GOTO 1000 |
| 30634 | IF (EKIN.LT.0.300D0)THEN |
| 30635 | C EKIN .LT. 300 MEV |
| 30636 | IDAT=1 |
| 30637 | ELSE |
| 30638 | C 300 MEV < EKIN < 740 MEV |
| 30639 | IDAT=6 |
| 30640 | END IF |
| 30641 | C |
| 30642 | ENER=EKIN |
| 30643 | IE=INT(ABS(ENER/0.020D0)) |
| 30644 | UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0 |
| 30645 | C FORWARD/BACKWARD DECISION |
| 30646 | K=IDAT+5*IE |
| 30647 | BWFW=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K) |
| 30648 | IF (DT_RNDM(CST).LT.BWFW)THEN |
| 30649 | VALUE2=-1D0 |
| 30650 | K=K+1 |
| 30651 | ELSE |
| 30652 | VALUE2=1D0 |
| 30653 | K=K+3 |
| 30654 | END IF |
| 30655 | C |
| 30656 | COEF=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K) |
| 30657 | RND=DT_RNDM(COEF) |
| 30658 | C |
| 30659 | IF(RND.LT.COEF)THEN |
| 30660 | CST=DT_RNDM(RND) |
| 30661 | CST=CST*VALUE2 |
| 30662 | ELSE |
| 30663 | R1=DT_RNDM(CST) |
| 30664 | R2=DT_RNDM(R1) |
| 30665 | R3=DT_RNDM(R2) |
| 30666 | R4=DT_RNDM(R3) |
| 30667 | C |
| 30668 | IF(VALUE2.GT.0.0)THEN |
| 30669 | CST=MAX(R1,R2,R3,R4) |
| 30670 | GOTO 1500 |
| 30671 | ELSE |
| 30672 | R5=DT_RNDM(R4) |
| 30673 | C |
| 30674 | IF (IDAT.EQ.1)THEN |
| 30675 | CST=-MAX(R1,R2,R3,R4,R5) |
| 30676 | ELSE |
| 30677 | R6=DT_RNDM(R5) |
| 30678 | R7=DT_RNDM(R6) |
| 30679 | CST=-MAX(R1,R2,R3,R4,R5,R6,R7) |
| 30680 | END IF |
| 30681 | C |
| 30682 | END IF |
| 30683 | C |
| 30684 | END IF |
| 30685 | C |
| 30686 | GOTO 1500 |
| 30687 | C |
| 30688 | C******** EKIN .GT. 0.74 GEV |
| 30689 | C |
| 30690 | 1000 ENER=EKIN - 0.66D0 |
| 30691 | C IE=ABS(ENER/0.02) |
| 30692 | IE=INT(ENER/0.02D0) |
| 30693 | EMEV=EKIN*1D3 |
| 30694 | C |
| 30695 | UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0 |
| 30696 | K=IE |
| 30697 | BWFW=(DCHN(K+1)-DCHN(K))*UNIV + DCHN(K) |
| 30698 | RND=DT_RNDM(BWFW) |
| 30699 | C FORWARD NEUTRON |
| 30700 | IF (RND.GE.BWFW)THEN |
| 30701 | DO 1200 K=10,36,9 |
| 30702 | IF (DCHNA(K).GT.EMEV) THEN |
| 30703 | UNIVE=(EMEV-DCHNA(K-9))/(DCHNA(K)-DCHNA(K-9)) |
| 30704 | UNIV=DT_RNDM(UNIVE) |
| 30705 | DO 1100 I=1,8 |
| 30706 | II=K+I |
| 30707 | P=(DCHNA(II)-DCHNA(II-9))*UNIVE + DCHNA(II-9) |
| 30708 | C |
| 30709 | IF (P.GT.UNIV)THEN |
| 30710 | UNIV=DT_RNDM(UNIVE) |
| 30711 | FLTI=DBLE(I)-UNIV |
| 30712 | GOTO(290,290,290,290,330,340,350,360) I |
| 30713 | END IF |
| 30714 | 1100 CONTINUE |
| 30715 | END IF |
| 30716 | 1200 CONTINUE |
| 30717 | C |
| 30718 | ELSE |
| 30719 | C BACKWARD NEUTRON |
| 30720 | DO 1400 K=13,60,12 |
| 30721 | IF (DCHNB(K).GT.EMEV) THEN |
| 30722 | UNIVE=(EMEV-DCHNB(K-12))/(DCHNB(K)-DCHNB(K-12)) |
| 30723 | UNIV=DT_RNDM(UNIVE) |
| 30724 | DO 1300 I=1,11 |
| 30725 | II=K+I |
| 30726 | P=(DCHNB(II)-DCHNB(II-12))*UNIVE + DCHNB(II-12) |
| 30727 | C |
| 30728 | IF (P.GT.UNIV)THEN |
| 30729 | UNIV=DT_RNDM(P) |
| 30730 | FLTI=DBLE(I)-UNIV |
| 30731 | GOTO(120,120,140,150,160,160,180,190,200,210,220) I |
| 30732 | END IF |
| 30733 | 1300 CONTINUE |
| 30734 | END IF |
| 30735 | 1400 CONTINUE |
| 30736 | END IF |
| 30737 | C |
| 30738 | 120 CST=1.0D-2*FLTI-1.0D0 |
| 30739 | GOTO 1500 |
| 30740 | 140 CST=2.0D-2*UNIV-0.98D0 |
| 30741 | GOTO 1500 |
| 30742 | 150 CST=4.0D-2*UNIV-0.96D0 |
| 30743 | GOTO 1500 |
| 30744 | 160 CST=6.0D-2*FLTI-1.16D0 |
| 30745 | GOTO 1500 |
| 30746 | 180 CST=8.0D-2*UNIV-0.80D0 |
| 30747 | GOTO 1500 |
| 30748 | 190 CST=1.0D-1*UNIV-0.72D0 |
| 30749 | GOTO 1500 |
| 30750 | 200 CST=1.2D-1*UNIV-0.62D0 |
| 30751 | GOTO 1500 |
| 30752 | 210 CST=2.0D-1*UNIV-0.50D0 |
| 30753 | GOTO 1500 |
| 30754 | 220 CST=3.0D-1*(UNIV-1.0D0) |
| 30755 | GOTO 1500 |
| 30756 | C |
| 30757 | 290 CST=1.0D0-2.5d-2*FLTI |
| 30758 | GOTO 1500 |
| 30759 | 330 CST=0.85D0+0.5D-1*UNIV |
| 30760 | GOTO 1500 |
| 30761 | 340 CST=0.70D0+1.5D-1*UNIV |
| 30762 | GOTO 1500 |
| 30763 | 350 CST=0.50D0+2.0D-1*UNIV |
| 30764 | GOTO 1500 |
| 30765 | 360 CST=0.50D0*UNIV |
| 30766 | C |
| 30767 | 1500 RETURN |
| 30768 | C |
| 30769 | C----------------------------------- PP ELASTIC SCATTERING ------- |
| 30770 | C |
| 30771 | 102 CONTINUE |
| 30772 | EMEV=EKIN*1D3 |
| 30773 | C |
| 30774 | IF (EKIN.LE.0.500D0) THEN |
| 30775 | RND=DT_RNDM(EMEV) |
| 30776 | CST=2.0D0*RND-1.0D0 |
| 30777 | RETURN |
| 30778 | C |
| 30779 | ELSEIF (EKIN.LT.1.0D0) THEN |
| 30780 | DO 2200 K=13,60,12 |
| 30781 | IF (PDCI(K).GT.EMEV) THEN |
| 30782 | UNIVE=(EMEV-PDCI(K-12))/(PDCI(K)-PDCI(K-12)) |
| 30783 | UNIV=DT_RNDM(UNIVE) |
| 30784 | SUM=0 |
| 30785 | DO 2100 I=1,11 |
| 30786 | II=K+I |
| 30787 | SUM=SUM + (PDCI(II)-PDCI(II-12))*UNIVE + PDCI(II-12) |
| 30788 | C |
| 30789 | IF (UNIV.LT.SUM)THEN |
| 30790 | UNIV=DT_RNDM(SUM) |
| 30791 | FLTI=DBLE(I)-UNIV |
| 30792 | GOTO(55,55,55,60,60,65,65,65,65,70,70) I |
| 30793 | END IF |
| 30794 | 2100 CONTINUE |
| 30795 | END IF |
| 30796 | 2200 CONTINUE |
| 30797 | ELSE |
| 30798 | DO 2400 K=12,55,11 |
| 30799 | IF (PDCH(K).GT.EMEV) THEN |
| 30800 | UNIVE=(EMEV-PDCH(K-11))/(PDCH(K)-PDCH(K-11)) |
| 30801 | UNIV=DT_RNDM(UNIVE) |
| 30802 | SUM=0.0D0 |
| 30803 | DO 2300 I=1,10 |
| 30804 | II=K+I |
| 30805 | SUM=SUM + (PDCH(II)-PDCH(II-11))*UNIVE + PDCH(II-11) |
| 30806 | C |
| 30807 | IF (UNIV.LT.SUM)THEN |
| 30808 | UNIV=DT_RNDM(SUM) |
| 30809 | FLTI=UNIV+DBLE(I) |
| 30810 | GOTO(50,55,60,60,65,65,65,65,70,70) I |
| 30811 | END IF |
| 30812 | 2300 CONTINUE |
| 30813 | END IF |
| 30814 | 2400 CONTINUE |
| 30815 | END IF |
| 30816 | C |
| 30817 | 50 CST=0.4D0*UNIV |
| 30818 | GOTO 2500 |
| 30819 | 55 CST=0.2D0*FLTI |
| 30820 | GOTO 2500 |
| 30821 | 60 CST=0.3D0+0.1D0*FLTI |
| 30822 | GOTO 2500 |
| 30823 | 65 CST=0.6D0+0.04D0*FLTI |
| 30824 | GOTO 2500 |
| 30825 | 70 CST=0.78D0+0.02D0*FLTI |
| 30826 | C |
| 30827 | 2500 CONTINUE |
| 30828 | IF (DT_RNDM(CST).GT.0.5D0) CST=-CST |
| 30829 | C |
| 30830 | RETURN |
| 30831 | END |
| 30832 | * |
| 30833 | *===dhadri=============================================================* |
| 30834 | * |
| 30835 | CDECK ID>, DT_DHADRI |
| 30836 | SUBROUTINE DT_DHADRI(N,PLAB,ELAB,CX,CY,CZ,ITTA) |
| 30837 | |
| 30838 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 30839 | SAVE |
| 30840 | |
| 30841 | PARAMETER ( LINP = 5 , |
| 30842 | & LOUT = 6 , |
| 30843 | & LDAT = 9 ) |
| 30844 | |
| 30845 | C |
| 30846 | C----------------------------- |
| 30847 | C*** INPUT VARIABLES LIST: |
| 30848 | C*** SAMPLING OF HADRON NUCLEON INTERACTION FOR (ABOUT) 0.1 LE PLAB LE 6 |
| 30849 | C*** GEV/C LABORATORY MOMENTUM REGION |
| 30850 | C*** N - PROJECTILE HADRON INDEX |
| 30851 | C*** PLAB - LABORATORY MOMENTUM OF N (GEV/C) |
| 30852 | C*** ELAB - LABORATORY ENERGY OF N (GEV) |
| 30853 | C*** CX,CY,CZ - DIRECTION COSINES OF N IN THE LABORATORY SYSTEM |
| 30854 | C*** ITTA - TARGET NUCLEON INDEX |
| 30855 | C*** OUTPUT VARIABLES LIST OF PARTICLE CHARACTERISTICS IN /FINLSP/ |
| 30856 | C IR COUNTS THE NUMBER OF PRODUCED PARTICLES |
| 30857 | C*** ITR - PARTICLE INDEX, CXR,CYR,CZR - DIRECTION COSINES (LAB. SYST.) |
| 30858 | C*** ELR,PLR LAB. ENERGY AND LAB. MOMENTUM OF THE SAMPLED PARTICLE |
| 30859 | C*** RESPECT., UNITS (GEV/C AND GEV) |
| 30860 | C---------------------------- |
| 30861 | |
| 30862 | COMMON /HNGAMR/ REDU,AMO,AMM(15) |
| 30863 | COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17) |
| 30864 | COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184), |
| 30865 | & NRK(2,268),NURE(30,2) |
| 30866 | * particle properties (BAMJET index convention), |
| 30867 | * (dublicate of DTPART for HADRIN) |
| 30868 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), |
| 30869 | & K1H(110),K2H(110) |
| 30870 | COMMON /HNSPLI/ WTI(460),NZKI(460,3) |
| 30871 | COMMON /HNMETL/ CXS(149),CYS(149),CZS(149),ELS(149),PLS(149), |
| 30872 | & ITS(149),IS |
| 30873 | COMMON /HNDRUN/ RUNTES,EFTES |
| 30874 | * particle properties (BAMJET index convention) |
| 30875 | CHARACTER*8 ANAME |
| 30876 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 30877 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 30878 | * final state from HADRIN interaction |
| 30879 | PARAMETER (MAXFIN=10) |
| 30880 | COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN), |
| 30881 | & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH |
| 30882 | |
| 30883 | DIMENSION ITPRF(110) |
| 30884 | DATA NNN/0/ |
| 30885 | DATA UMODA/0./ |
| 30886 | DATA ITPRF/-1,-1,5*1,-1,-1,1,1,1,-1,-1,-1,-1,6*1,-1,-1,-1,85*1/ |
| 30887 | LOWP=0 |
| 30888 | IF (N.LE.0.OR.N.GE.111)N=1 |
| 30889 | IF (ITPRF( N ).GT.0 .OR. ITTA.GT.8) THEN |
| 30890 | GOTO 280 |
| 30891 | * WRITE (6,1000) |
| 30892 | * + ' FALSE USE OF THE PARTICLE TYPE INDEX: N, ITTA', N, ITTA |
| 30893 | * STOP |
| 30894 | *1000 FORMAT (3(5H ****/),A,2I4,3(5H ****/)) |
| 30895 | * + 45H FALSE USE OF THE PARTICLE TYPE INDEX, N,LUE ,I4,3(5H ****/)) |
| 30896 | ENDIF |
| 30897 | IATMPT=0 |
| 30898 | IF (ABS(PLAB-5.0D0).LT.4.99999D0) GO TO 20 |
| 30899 | C IF(IPRI.GE.1) WRITE (6,1010) PLAB |
| 30900 | C STOP |
| 30901 | 1010 FORMAT ( ' PROJECTILE HADRON MOMENTUM OUTSIDE OF THE |
| 30902 | + ALLOWED REGION, PLAB=',1E15.5) |
| 30903 | |
| 30904 | 20 CONTINUE |
| 30905 | UMODAT=N*1.11111D0+ITTA*2.19291D0 |
| 30906 | IF(UMODAT.NE.UMODA) CALL DT_DCALUM(N,ITTA) |
| 30907 | UMODA=UMODAT |
| 30908 | 30 IATMPT=0 |
| 30909 | LOWP=LOWP+1 |
| 30910 | 40 CONTINUE |
| 30911 | IMACH=0 |
| 30912 | REDU=2.0D0 |
| 30913 | IF (LOWP.GT.20) THEN |
| 30914 | C WRITE(LOUT,*) ' jump 1' |
| 30915 | GO TO 280 |
| 30916 | ENDIF |
| 30917 | NNN=N |
| 30918 | IF (NNN.EQ.N) GO TO 50 |
| 30919 | RUNTES=0.0D0 |
| 30920 | EFTES=0.0D0 |
| 30921 | 50 CONTINUE |
| 30922 | IS=1 |
| 30923 | IRH=0 |
| 30924 | IST=1 |
| 30925 | NSTAB=23 |
| 30926 | IRE=NURE(N,1) |
| 30927 | IF(ITTA.GT.1) IRE=NURE(N,2) |
| 30928 | C |
| 30929 | C----------------------------- |
| 30930 | C*** IE,AMT,ECM,SI DETERMINATION |
| 30931 | C---------------------------- |
| 30932 | CALL DT_DSIGIN(IRE,PLAB,N,IE,AMT ,AMN,ECM,SI,ITTA) |
| 30933 | IANTH=-1 |
| 30934 | **sr |
| 30935 | C IF (AMH(1).NE.0.93828D0) IANTH=1 |
| 30936 | IF (AMH(1).NE.0.9383D0) IANTH=1 |
| 30937 | ** |
| 30938 | IF (IANTH.GE.0) SI=1.0D0 |
| 30939 | ECMMH=ECM |
| 30940 | C |
| 30941 | C----------------------------- |
| 30942 | C ENERGY INDEX |
| 30943 | C IRE CHARACTERIZES THE REACTION |
| 30944 | C IE IS THE ENERGY INDEX |
| 30945 | C---------------------------- |
| 30946 | IF (SI.LT.1.D-6) THEN |
| 30947 | C WRITE(LOUT,*) ' jump 2' |
| 30948 | GO TO 280 |
| 30949 | ENDIF |
| 30950 | IF (N.LE.NSTAB) GO TO 60 |
| 30951 | RUNTES=RUNTES+1.0D0 |
| 30952 | IF (RUNTES.LT.20.D0) WRITE(LOUT,1020)N |
| 30953 | 1020 FORMAT(3H N=,I10,30H THE PROEKTILE IS A RESONANCE ) |
| 30954 | IF(IBARH(N).EQ.1) N=8 |
| 30955 | IF(IBARH(N).EQ.-1) N=9 |
| 30956 | 60 CONTINUE |
| 30957 | IMACH=IMACH+1 |
| 30958 | **sr 19.2.97: loop for direct channel suppression |
| 30959 | C IF (IMACH.GT.10) THEN |
| 30960 | IF (IMACH.GT.1000) THEN |
| 30961 | ** |
| 30962 | C WRITE(LOUT,*) ' jump 3' |
| 30963 | GO TO 280 |
| 30964 | ENDIF |
| 30965 | ECM =ECMMH |
| 30966 | AMN2=AMN**2 |
| 30967 | AMT2=AMT**2 |
| 30968 | ECMN=(ECM**2+AMN2-AMT2)/(2.0D0*ECM ) |
| 30969 | IF(ECMN.LE.AMN) ECMN=AMN |
| 30970 | PCMN=SQRT(ECMN**2-AMN2) |
| 30971 | GAM=(ELAB+AMT)/ECM |
| 30972 | BGAM=PLAB/ECM |
| 30973 | IF (IANTH.GE.0) ECM=2.1D0 |
| 30974 | C |
| 30975 | C----------------------------- |
| 30976 | C*** RANDOM CHOICE OF REACTION CHANNEL |
| 30977 | C---------------------------- |
| 30978 | IST=0 |
| 30979 | VV=DT_RNDM(AMN2) |
| 30980 | VV=VV-1.D-17 |
| 30981 | C |
| 30982 | C----------------------------- |
| 30983 | C*** PLACE REDUCED VERSION |
| 30984 | C---------------------------- |
| 30985 | IIEI=IEII(IRE) |
| 30986 | IDWK=IEII(IRE+1)-IIEI |
| 30987 | IIWK=IRII(IRE) |
| 30988 | IIKI=IKII(IRE) |
| 30989 | C |
| 30990 | C----------------------------- |
| 30991 | C*** SHRINKAGE TO THE CONSIDERED ENERGY REGION FOR THE USE OF WEIGHTS |
| 30992 | C---------------------------- |
| 30993 | HECM=ECM |
| 30994 | HUMO=2.0D0*UMO(IIEI+IDWK)-UMO(IIEI+IDWK-1) |
| 30995 | IF (HUMO.LT.ECM) ECM=HUMO |
| 30996 | C |
| 30997 | C----------------------------- |
| 30998 | C*** INTERPOLATION PREPARATION |
| 30999 | C---------------------------- |
| 31000 | ECMO=UMO(IE) |
| 31001 | ECM1=UMO(IE-1) |
| 31002 | DECM=ECMO-ECM1 |
| 31003 | DEC=ECMO-ECM |
| 31004 | C |
| 31005 | C----------------------------- |
| 31006 | C*** RANDOM LOOP |
| 31007 | C---------------------------- |
| 31008 | IK=0 |
| 31009 | WKK=0.0D0 |
| 31010 | WICOR=0.0D0 |
| 31011 | 70 IK=IK+1 |
| 31012 | IWK=IIWK+(IK-1)*IDWK+IE-IIEI |
| 31013 | WOK=WK(IWK) |
| 31014 | WDK=WOK-WK(IWK-1) |
| 31015 | C |
| 31016 | C----------------------------- |
| 31017 | C*** TESTVARIABLE WICO/WICOR: IF CHANNEL IK HAS THE SAME WEIGHTS LIKE IK |
| 31018 | C GO TO NEXT CHANNEL, BECAUSE WKK((IK))-WKK((IK-1))=0, IK CAN NOT |
| 31019 | C CONTRIBUTE |
| 31020 | C---------------------------- |
| 31021 | IF (PLAB.LT.PLABF(IIEI+2)) WDK=0.0D0 |
| 31022 | WICO=WOK*1.23459876D0+WDK*1.735218469D0 |
| 31023 | IF (WICO.EQ.WICOR) GO TO 70 |
| 31024 | IF (UMO(IIEI+IDWK).LT.HECM) WDK=0.0D0 |
| 31025 | WICOR=WICO |
| 31026 | C |
| 31027 | C----------------------------- |
| 31028 | C*** INTERPOLATION IN CHANNEL WEIGHTS |
| 31029 | C---------------------------- |
| 31030 | EKLIM=-THRESH(IIKI+IK) |
| 31031 | IELIM=IDT_IEFUND(EKLIM,IRE) |
| 31032 | DELIM=UMO(IELIM)+EKLIM |
| 31033 | *+1.D-16 |
| 31034 | DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0 |
| 31035 | IF (DELIM*DELIM-DETE*DETE) 90,90,80 |
| 31036 | 80 DECC=DELIM |
| 31037 | GO TO 100 |
| 31038 | 90 DECC=DECM |
| 31039 | 100 CONTINUE |
| 31040 | WKK=WOK-WDK*DEC/(DECC+1.D-9) |
| 31041 | C |
| 31042 | C----------------------------- |
| 31043 | C*** RANDOM CHOICE |
| 31044 | C---------------------------- |
| 31045 | C |
| 31046 | IF (VV.GT.WKK) GO TO 70 |
| 31047 | C |
| 31048 | C***IK IS THE REACTION CHANNEL |
| 31049 | C---------------------------- |
| 31050 | INRK=IKII(IRE)+IK |
| 31051 | ECM=HECM |
| 31052 | I1001 =0 |
| 31053 | C |
| 31054 | 110 CONTINUE |
| 31055 | IT1=NRK(1,INRK) |
| 31056 | AM1=DT_DAMG(IT1) |
| 31057 | IT2=NRK(2,INRK) |
| 31058 | AM2=DT_DAMG(IT2) |
| 31059 | AMS=AM1+AM2 |
| 31060 | I1001=I1001+1 |
| 31061 | IF (I1001.GT.50) GO TO 60 |
| 31062 | C |
| 31063 | IF (IT2*AMS.GT.IT2*ECM) GO TO 110 |
| 31064 | IT11=IT1 |
| 31065 | IT22=IT2 |
| 31066 | IF (IANTH.GE.0) ECM=ELAB+AMT+0.00001D0 |
| 31067 | AM11=AM1 |
| 31068 | AM22=AM2 |
| 31069 | IF (IT2.GT.0) GO TO 120 |
| 31070 | **sr 19.2.97: supress direct channel for pp-collisions |
| 31071 | IF ((N.EQ.1).AND.(ITTA.EQ.1).AND.(IT2.LE.0)) THEN |
| 31072 | RR = DT_RNDM(AM11) |
| 31073 | IF (RR.LE.0.75D0) GOTO 60 |
| 31074 | ENDIF |
| 31075 | ** |
| 31076 | C |
| 31077 | C----------------------------- |
| 31078 | C INCLUSION OF DIRECT RESONANCES |
| 31079 | C RANDOM CHOICE OF DECAY CHANNELS OF THE DIRECT RESONANCE IT1 |
| 31080 | C------------------------ |
| 31081 | KZ1=K1H(IT1) |
| 31082 | IST=IST+1 |
| 31083 | IECO=0 |
| 31084 | ECO=ECM |
| 31085 | GAM=(ELAB+AMT)/ECO |
| 31086 | BGAM=PLAB/ECO |
| 31087 | CXS(1)=CX |
| 31088 | CYS(1)=CY |
| 31089 | CZS(1)=CZ |
| 31090 | GO TO 170 |
| 31091 | 120 CONTINUE |
| 31092 | WW=DT_RNDM(ECO) |
| 31093 | IF(WW.LT. 0.5D0) GO TO 130 |
| 31094 | IT1=IT22 |
| 31095 | IT2=IT11 |
| 31096 | AM1=AM22 |
| 31097 | AM2=AM11 |
| 31098 | 130 CONTINUE |
| 31099 | C |
| 31100 | C----------------------------- |
| 31101 | C THE FIRST PARTICLE IS DEFINED TO BE THE FORWARD GOING ONE AT SMALL T |
| 31102 | IBN=IBARH(N) |
| 31103 | IB1=IBARH(IT1) |
| 31104 | IT11=IT1 |
| 31105 | IT22=IT2 |
| 31106 | AM11=AM1 |
| 31107 | AM22=AM2 |
| 31108 | IF(IB1.EQ.IBN) GO TO 140 |
| 31109 | IT1=IT22 |
| 31110 | IT2=IT11 |
| 31111 | AM1=AM22 |
| 31112 | AM2=AM11 |
| 31113 | 140 CONTINUE |
| 31114 | C----------------------------- |
| 31115 | C***IT1,IT2 ARE THE CREATED PARTICLES |
| 31116 | C***MOMENTA AND DIRECTION COSINA IN THE CM - SYSTEM |
| 31117 | C------------------------ |
| 31118 | CALL DT_DTWOPA(ECM1,ECM2,PCM1,PCM2,COD1,COD2,COF1,COF2,SIF1,SIF2, |
| 31119 | *IT1,IT2,ECM,ECMN,PCMN,N,AM1,AM2) |
| 31120 | IST=IST+1 |
| 31121 | ITS(IST)=IT1 |
| 31122 | AMM(IST)=AM1 |
| 31123 | C |
| 31124 | C----------------------------- |
| 31125 | C***TRANSFORMATION INTO LAB SYSTEM AND ROTATION |
| 31126 | C---------------------------- |
| 31127 | CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD1,COF1,SIF1, |
| 31128 | &PCM1,ECM1,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST)) |
| 31129 | IST=IST+1 |
| 31130 | ITS(IST)=IT2 |
| 31131 | AMM(IST)=AM2 |
| 31132 | CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD2,COF2,SIF2, |
| 31133 | *PCM2,ECM2,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST)) |
| 31134 | 150 CONTINUE |
| 31135 | C |
| 31136 | C----------------------------- |
| 31137 | C***TEST STABLE OR UNSTABLE |
| 31138 | C---------------------------- |
| 31139 | IF(ITS(IST).GT.NSTAB) GO TO 160 |
| 31140 | IRH=IRH+1 |
| 31141 | C |
| 31142 | C----------------------------- |
| 31143 | C***IRH IS THE NUMBER OF THE FINAL STABLE PARTICLE |
| 31144 | C---------------------------- |
| 31145 | C* IF (REDU.LT.0.D0) GO TO 1009 |
| 31146 | ITRH(IRH)=ITS(IST) |
| 31147 | PLRH(IRH)=PLS(IST) |
| 31148 | CXRH(IRH)=CXS(IST) |
| 31149 | CYRH(IRH)=CYS(IST) |
| 31150 | CZRH(IRH)=CZS(IST) |
| 31151 | ELRH(IRH)=ELS(IST) |
| 31152 | IST=IST-1 |
| 31153 | IF(IST.GE.1) GO TO 150 |
| 31154 | GO TO 260 |
| 31155 | 160 CONTINUE |
| 31156 | C |
| 31157 | C RANDOM CHOICE OF DECAY CHANNELS |
| 31158 | C---------------------------- |
| 31159 | C |
| 31160 | IT=ITS(IST) |
| 31161 | ECO=AMM(IST) |
| 31162 | GAM=ELS(IST)/ECO |
| 31163 | BGAM=PLS(IST)/ECO |
| 31164 | IECO=0 |
| 31165 | KZ1=K1H(IT) |
| 31166 | 170 CONTINUE |
| 31167 | IECO=IECO+1 |
| 31168 | VV=DT_RNDM(GAM) |
| 31169 | VV=VV-1.D-17 |
| 31170 | IIK=KZ1-1 |
| 31171 | 180 IIK=IIK+1 |
| 31172 | IF (VV.GT.WTI(IIK)) GO TO 180 |
| 31173 | C |
| 31174 | C IIK IS THE DECAY CHANNEL |
| 31175 | C---------------------------- |
| 31176 | IT1=NZKI(IIK,1) |
| 31177 | I310=0 |
| 31178 | 190 CONTINUE |
| 31179 | I310=I310+1 |
| 31180 | AM1=DT_DAMG(IT1) |
| 31181 | IT2=NZKI(IIK,2) |
| 31182 | AM2=DT_DAMG(IT2) |
| 31183 | IF (IT2-1.LT.0) GO TO 240 |
| 31184 | IT3=NZKI(IIK,3) |
| 31185 | AM3=DT_DAMG(IT3) |
| 31186 | AMS=AM1+AM2+AM3 |
| 31187 | C |
| 31188 | C IF IIK-KIN.LIM.GT.ACTUAL TOTAL CM-ENERGY, DO AGAIN RANDOM IIK-CHOICE |
| 31189 | C---------------------------- |
| 31190 | IF (IECO.LE.10) GO TO 200 |
| 31191 | IATMPT=IATMPT+1 |
| 31192 | IF(IATMPT.GT.3) THEN |
| 31193 | C WRITE(LOUT,*) ' jump 4' |
| 31194 | GO TO 280 |
| 31195 | ENDIF |
| 31196 | GO TO 40 |
| 31197 | 200 CONTINUE |
| 31198 | IF (I310.GT.50) GO TO 170 |
| 31199 | IF (AMS.GT.ECO) GO TO 190 |
| 31200 | C |
| 31201 | C FOR THE DECAY CHANNEL |
| 31202 | C IT1,IT2, IT3 ARE THE PRODUCED PARTICLES FROM IT |
| 31203 | C---------------------------- |
| 31204 | IF (REDU.LT.0.D0) GO TO 30 |
| 31205 | ITWTHC=0 |
| 31206 | REDU=2.0D0 |
| 31207 | IF(IT3.EQ.0) GO TO 220 |
| 31208 | 210 CONTINUE |
| 31209 | ITWTH=1 |
| 31210 | CALL DT_DTHREP(ECO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,SIF1, |
| 31211 | *COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3) |
| 31212 | GO TO 230 |
| 31213 | 220 CALL DT_DTWOPD(ECO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1, |
| 31214 | &COD2,COF2,SIF2,AM1,AM2) |
| 31215 | ITWTH=-1 |
| 31216 | IT3=0 |
| 31217 | 230 CONTINUE |
| 31218 | ITWTHC=ITWTHC+1 |
| 31219 | IF (REDU.GT.0.D0) GO TO 240 |
| 31220 | REDU=2.0D0 |
| 31221 | IF (ITWTHC.GT.100) GO TO 30 |
| 31222 | IF (ITWTH) 220,220,210 |
| 31223 | 240 CONTINUE |
| 31224 | ITS(IST )=IT1 |
| 31225 | IF (IT2-1.LT.0) GO TO 250 |
| 31226 | ITS(IST+1) =IT2 |
| 31227 | ITS(IST+2)=IT3 |
| 31228 | RX=CXS(IST) |
| 31229 | RY=CYS(IST) |
| 31230 | RZ=CZS(IST) |
| 31231 | AMM(IST)=AM1 |
| 31232 | CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD1,COF1,SIF1,PCM1,ECM1, |
| 31233 | *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST)) |
| 31234 | IST=IST+1 |
| 31235 | AMM(IST)=AM2 |
| 31236 | CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD2,COF2,SIF2,PCM2,ECM2, |
| 31237 | *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST)) |
| 31238 | IF (IT3.LE.0) GO TO 250 |
| 31239 | IST=IST+1 |
| 31240 | AMM(IST)=AM3 |
| 31241 | CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD3,COF3,SIF3,PCM3,ECM3, |
| 31242 | *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST)) |
| 31243 | 250 CONTINUE |
| 31244 | GO TO 150 |
| 31245 | 260 CONTINUE |
| 31246 | 270 CONTINUE |
| 31247 | RETURN |
| 31248 | 280 CONTINUE |
| 31249 | C |
| 31250 | C---------------------------- |
| 31251 | C |
| 31252 | C ZERO CROSS SECTION CASE |
| 31253 | C---------------------------- |
| 31254 | C |
| 31255 | IRH=1 |
| 31256 | ITRH(1)=N |
| 31257 | CXRH(1)=CX |
| 31258 | CYRH(1)=CY |
| 31259 | CZRH(1)=CZ |
| 31260 | ELRH(1)=ELAB |
| 31261 | PLRH(1)=PLAB |
| 31262 | RETURN |
| 31263 | END |
| 31264 | * |
| 31265 | *===runtt==============================================================* |
| 31266 | * |
| 31267 | CDECK ID>, DT_RUNTT |
| 31268 | BLOCK DATA DT_RUNTT |
| 31269 | |
| 31270 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 31271 | SAVE |
| 31272 | |
| 31273 | COMMON /HNDRUN/ RUNTES,EFTES |
| 31274 | |
| 31275 | DATA RUNTES,EFTES /100.D0,100.D0/ |
| 31276 | |
| 31277 | END |
| 31278 | * |
| 31279 | *===noname=============================================================* |
| 31280 | * |
| 31281 | CDECK ID>, DT_NONAME |
| 31282 | BLOCK DATA DT_NONAME |
| 31283 | |
| 31284 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 31285 | SAVE |
| 31286 | |
| 31287 | * slope parameters for HADRIN interactions |
| 31288 | COMMON /HNSLOP/ SM(25),BBM(25),BBB(25) |
| 31289 | COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17) |
| 31290 | |
| 31291 | C DATAS DATAS DATAS DATAS DATAS |
| 31292 | C****** ********* |
| 31293 | DATA IKII/ 0, 15, 41, 67, 82, 93, 110, 133, 148, 159, 172, 183, |
| 31294 | & 207, 224, 241, 252, 268 / |
| 31295 | DATA IEII/ 0, 21, 46, 71, 92, 109, 126, 143, 160, 173, 186, 199, |
| 31296 | & 220, 241, 262, 279, 296 / |
| 31297 | DATA IRII/ 0, 315, 965, 1615, 1930, 2117, 2406, 2797, 3052, 3195, |
| 31298 | & 3364, 3507, 4011, 4368, 4725, 4912, 5184/ |
| 31299 | |
| 31300 | C |
| 31301 | C MASSES FOR THE SLOPE B(M) IN GEV |
| 31302 | C SLOPE B(M) FOR AN MESONIC SYSTEM |
| 31303 | C SLOPE B(M) FOR A BARYONIC SYSTEM |
| 31304 | |
| 31305 | * |
| 31306 | DATA SM,BBM,BBB/ 0.8D0, 0.85D0, 0.9D0, 0.95D0, 1.D0, |
| 31307 | & 1.05D0, 1.1D0, 1.15D0, 1.2D0, 1.25D0, |
| 31308 | & 1.3D0, 1.35D0, 1.4D0, 1.45D0, 1.5D0, |
| 31309 | & 1.55D0, 1.6D0, 1.65D0, 1.7D0, 1.75D0, |
| 31310 | & 1.8D0, 1.85D0, 1.9D0, 1.95D0, 2.D0, |
| 31311 | & 15.6D0, 14.95D0, 14.3D0, 13.65D0, 13.D0, |
| 31312 | & 12.35D0, 11.7D0, 10.85D0, 10.D0, 9.15D0, |
| 31313 | & 8.3D0, 7.8D0, 7.3D0, 7.25D0, 7.2D0, |
| 31314 | & 6.95D0, 6.7D0, 6.6D0, 6.5D0, 6.3D0, |
| 31315 | & 6.1D0, 5.85D0, 5.6D0, 5.35D0, 5.1D0, |
| 31316 | & 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, |
| 31317 | & 14.2D0, 13.4D0, 12.6D0, |
| 31318 | & 11.8D0, 11.2D0, 10.6D0, 9.8D0, 9.D0, |
| 31319 | & 8.25D0, 7.5D0, 6.25D0, 5.D0, 4.5D0, 5*4.D0 / |
| 31320 | * |
| 31321 | END |
| 31322 | * |
| 31323 | *===damg===============================================================* |
| 31324 | * |
| 31325 | CDECK ID>, DT_DAMG |
| 31326 | DOUBLE PRECISION FUNCTION DT_DAMG(IT) |
| 31327 | |
| 31328 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 31329 | SAVE |
| 31330 | |
| 31331 | * particle properties (BAMJET index convention), |
| 31332 | * (dublicate of DTPART for HADRIN) |
| 31333 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), |
| 31334 | & K1H(110),K2H(110) |
| 31335 | |
| 31336 | DIMENSION GASUNI(14) |
| 31337 | DATA GASUNI/ |
| 31338 | *-1.D0,-.98D0,-.95D0,-.87D0,-.72D0,-.48D0, |
| 31339 | *-.17D0,.17D0,.48D0,.72D0,.87D0,.95D0,.98D0,1.D0/ |
| 31340 | DATA GAUNO/2.352D0/ |
| 31341 | DATA GAUNON/2.4D0/ |
| 31342 | DATA IO/14/ |
| 31343 | DATA NSTAB/23/ |
| 31344 | |
| 31345 | I=1 |
| 31346 | IF (IT.LE.0) GO TO 30 |
| 31347 | IF (IT.LE.NSTAB) GO TO 20 |
| 31348 | DGAUNI=GAUNO*GAUNON/DBLE(IO-1) |
| 31349 | VV=DT_RNDM(DGAUNI) |
| 31350 | VV=VV*2.0D0-1.0D0+1.D-16 |
| 31351 | 10 CONTINUE |
| 31352 | VO=GASUNI(I) |
| 31353 | I=I+1 |
| 31354 | V1=GASUNI(I) |
| 31355 | IF (VV.GT.V1) GO TO 10 |
| 31356 | UNIGA=DGAUNI*(DBLE(I)-2.0D0+(VV-VO+1.D-16)/ |
| 31357 | & (V1-VO)-(DBLE(IO)-1.0D0)*0.5D0) |
| 31358 | DAM=GAH(IT)*UNIGA/GAUNO |
| 31359 | AAM=AMH(IT)+DAM |
| 31360 | DT_DAMG=AAM |
| 31361 | RETURN |
| 31362 | 20 CONTINUE |
| 31363 | DT_DAMG=AMH(IT) |
| 31364 | RETURN |
| 31365 | 30 CONTINUE |
| 31366 | DT_DAMG=0.0D0 |
| 31367 | RETURN |
| 31368 | END |
| 31369 | * |
| 31370 | *===dcalum=============================================================* |
| 31371 | * |
| 31372 | CDECK ID>, DT_DCALUM |
| 31373 | SUBROUTINE DT_DCALUM(N,ITTA) |
| 31374 | |
| 31375 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 31376 | SAVE |
| 31377 | |
| 31378 | C*** C.M.S.-ENERGY AND REACTION CHANNEL THRESHOLD CALCULATION |
| 31379 | |
| 31380 | * particle properties (BAMJET index convention), |
| 31381 | * (dublicate of DTPART for HADRIN) |
| 31382 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), |
| 31383 | & K1H(110),K2H(110) |
| 31384 | COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17) |
| 31385 | COMMON /HNSPLI/ WTI(460),NZKI(460,3) |
| 31386 | COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184), |
| 31387 | & NRK(2,268),NURE(30,2) |
| 31388 | |
| 31389 | IRE=NURE(N,ITTA/8+1) |
| 31390 | IEO=IEII(IRE)+1 |
| 31391 | IEE=IEII(IRE +1) |
| 31392 | AM1=AMH(N ) |
| 31393 | AM12=AM1**2 |
| 31394 | AM2=AMH(ITTA) |
| 31395 | AM22=AM2**2 |
| 31396 | DO 10 IE=IEO,IEE |
| 31397 | PLAB2=PLABF(IE)**2 |
| 31398 | ELAB=SQRT(AM12+AM22+2.0D0*SQRT(PLAB2+AM12)*AM2) |
| 31399 | UMO(IE)=ELAB |
| 31400 | 10 CONTINUE |
| 31401 | IKO=IKII(IRE)+1 |
| 31402 | IKE=IKII(IRE +1) |
| 31403 | UMOO=UMO(IEO) |
| 31404 | DO 30 IK=IKO,IKE |
| 31405 | IF(NRK(2,IK).GT.0) GO TO 30 |
| 31406 | IKI=NRK(1,IK) |
| 31407 | AMSS=5.0D0 |
| 31408 | K11=K1H(IKI) |
| 31409 | K22=K2H(IKI) |
| 31410 | DO 20 IK1=K11,K22 |
| 31411 | IN=NZKI(IK1,1) |
| 31412 | AMS=AMH(IN) |
| 31413 | IN=NZKI(IK1,2) |
| 31414 | IF(IN.GT.0)AMS=AMS+AMH(IN) |
| 31415 | IN=NZKI(IK1,3) |
| 31416 | IF(IN.GT.0) AMS=AMS+AMH(IN) |
| 31417 | IF (AMS.LT.AMSS) AMSS=AMS |
| 31418 | 20 CONTINUE |
| 31419 | IF(UMOO.LT.AMSS) UMOO=AMSS |
| 31420 | THRESH(IK)=UMOO |
| 31421 | 30 CONTINUE |
| 31422 | RETURN |
| 31423 | END |
| 31424 | * |
| 31425 | *===dchanh=============================================================* |
| 31426 | * |
| 31427 | CDECK ID>, DT_DCHANH |
| 31428 | SUBROUTINE DT_DCHANH |
| 31429 | |
| 31430 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 31431 | SAVE |
| 31432 | |
| 31433 | PARAMETER ( LINP = 5 , |
| 31434 | & LOUT = 6 , |
| 31435 | & LDAT = 9 ) |
| 31436 | |
| 31437 | * particle properties (BAMJET index convention), |
| 31438 | * (dublicate of DTPART for HADRIN) |
| 31439 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), |
| 31440 | & K1H(110),K2H(110) |
| 31441 | COMMON /HNSPLI/ WTI(460),NZKI(460,3) |
| 31442 | COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17) |
| 31443 | COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184), |
| 31444 | & NRK(2,268),NURE(30,2) |
| 31445 | |
| 31446 | DIMENSION HWT(460),HWK(40),SI(5184) |
| 31447 | EQUIVALENCE (WK(1),SI(1)) |
| 31448 | C-------------------- |
| 31449 | C*** USE ONLY FOR DATAPREPARATION OF PURE HADRIN |
| 31450 | C*** CALCULATION OF REACTION- AND DECAY-CHANNEL-WEIGHTS, |
| 31451 | C*** THRESHOLD ENERGIES+MOMENTA OF REACTION CHNLS. |
| 31452 | C*** CHANGE OF WT- AND WK-INPUTDATA INTO WEIGHTS FOR THE M.-C.-PROCEDURE |
| 31453 | C*** (ADDED ONE TO EACH OTHER FOR CORRESPONDING CHANNELS) |
| 31454 | C-------------------------- |
| 31455 | IREG=16 |
| 31456 | DO 90 IRE=1,IREG |
| 31457 | IWKO=IRII(IRE) |
| 31458 | IEE=IEII(IRE+1)-IEII(IRE) |
| 31459 | IKE=IKII(IRE+1)-IKII(IRE) |
| 31460 | IEO=IEII(IRE)+1 |
| 31461 | IIKA=IKII(IRE) |
| 31462 | * modifications to suppress elestic scattering 24/07/91 |
| 31463 | DO 80 IE=1,IEE |
| 31464 | SIS=1.D-14 |
| 31465 | SINORC=0.0D0 |
| 31466 | DO 10 IK=1,IKE |
| 31467 | IWK=IWKO+IEE*(IK-1)+IE |
| 31468 | IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0 |
| 31469 | SIS=SIS+SI(IWK)*SINORC |
| 31470 | 10 CONTINUE |
| 31471 | SIIN(IEO+IE-1)=SIS |
| 31472 | SIO=0.D0 |
| 31473 | IF (SIS.GE.1.D-12) GO TO 20 |
| 31474 | SIS=1.D0 |
| 31475 | SIO=1.D0 |
| 31476 | 20 CONTINUE |
| 31477 | SINORC=0.0D0 |
| 31478 | DO 30 IK=1,IKE |
| 31479 | IWK=IWKO+IEE*(IK-1)+IE |
| 31480 | IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0 |
| 31481 | SIO=SIO+SI(IWK)*SINORC/SIS |
| 31482 | HWK(IK)=SIO |
| 31483 | 30 CONTINUE |
| 31484 | DO 40 IK=1,IKE |
| 31485 | IWK=IWKO+IEE*(IK-1)+IE |
| 31486 | 40 WK(IWK)=HWK(IK) |
| 31487 | IIKI=IKII(IRE) |
| 31488 | DO 70 IK=1,IKE |
| 31489 | AM111=0.D0 |
| 31490 | INRK1=NRK(1,IIKI+IK) |
| 31491 | IF (INRK1.GT.0) AM111=AMH(INRK1) |
| 31492 | AM222=0.D0 |
| 31493 | INRK2=NRK(2,IIKI+IK) |
| 31494 | IF (INRK2.GT.0) AM222=AMH(INRK2) |
| 31495 | THRESH(IIKI+IK)=AM111 +AM222 |
| 31496 | IF (INRK2-1.GE.0) GO TO 60 |
| 31497 | INRKK=K1H(INRK1) |
| 31498 | AMSS=5.D0 |
| 31499 | INRKO=K2H(INRK1) |
| 31500 | DO 50 INRK1=INRKK,INRKO |
| 31501 | INZK1=NZKI(INRK1,1) |
| 31502 | INZK2=NZKI(INRK1,2) |
| 31503 | INZK3=NZKI(INRK1,3) |
| 31504 | IF (INZK1.LE.0.OR.INZK1.GT.110) GO TO 50 |
| 31505 | IF (INZK2.LE.0.OR.INZK2.GT.110) GO TO 50 |
| 31506 | IF (INZK3.LE.0.OR.INZK3.GT.110) GO TO 50 |
| 31507 | C WRITE (6,310)INRK1,INZK1,INZK2,INZK3 |
| 31508 | 1000 FORMAT (4I10) |
| 31509 | AMS=AMH(INZK1)+AMH(INZK2) |
| 31510 | IF (INZK3-1.GE.0) AMS=AMS+AMH(INZK3) |
| 31511 | IF (AMSS.GT.AMS) AMSS=AMS |
| 31512 | 50 CONTINUE |
| 31513 | AMS=AMSS |
| 31514 | IF (AMS.LT.UMO(IEO)) AMS=UMO(IEO) |
| 31515 | THRESH(IIKI+IK)=AMS |
| 31516 | 60 CONTINUE |
| 31517 | 70 CONTINUE |
| 31518 | 80 CONTINUE |
| 31519 | 90 CONTINUE |
| 31520 | DO 100 J=1,460 |
| 31521 | 100 HWT(J)=0.D0 |
| 31522 | DO 120 I=1,110 |
| 31523 | IK1=K1H(I) |
| 31524 | IK2=K2H(I) |
| 31525 | HV=0.D0 |
| 31526 | IF (IK2.GT.460)IK2=460 |
| 31527 | IF (IK1.LE.0)IK1=1 |
| 31528 | DO 110 J=IK1,IK2 |
| 31529 | HV=HV+WTI(J) |
| 31530 | HWT(J)=HV |
| 31531 | JI=J |
| 31532 | 110 CONTINUE |
| 31533 | IF (ABS(HV-1.0D0).GT.1.D-4) WRITE(LOUT,1010)I,JI,HV |
| 31534 | 1010 FORMAT (35H ERROR IN HWT, FALSE USE OF CHANWH ,2I6,F10.2) |
| 31535 | 120 CONTINUE |
| 31536 | DO 130 J=1,460 |
| 31537 | 130 WTI(J)=HWT(J) |
| 31538 | RETURN |
| 31539 | END |
| 31540 | * |
| 31541 | *===dhadde=============================================================* |
| 31542 | * |
| 31543 | CDECK ID>, DT_DHADDE |
| 31544 | SUBROUTINE DT_DHADDE |
| 31545 | |
| 31546 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 31547 | SAVE |
| 31548 | |
| 31549 | * particle properties (BAMJET index convention) |
| 31550 | CHARACTER*8 ANAME |
| 31551 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), |
| 31552 | & IICH(210),IIBAR(210),K1(210),K2(210) |
| 31553 | * HADRIN: decay channel information |
| 31554 | PARAMETER (IDMAX9=602) |
| 31555 | CHARACTER*8 ZKNAME |
| 31556 | COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3) |
| 31557 | * particle properties (BAMJET index convention), |
| 31558 | * (dublicate of DTPART for HADRIN) |
| 31559 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), |
| 31560 | & K1H(110),K2H(110) |
| 31561 | COMMON /HNSPLI/ WTI(460),NZKI(460,3) |
| 31562 | * decay channel information for HADRIN |
| 31563 | COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16), |
| 31564 | & K1Z(16),K2Z(16),WTZ(153),II22, |
| 31565 | & NZK1(153),NZK2(153),NZK3(153) |
| 31566 | |
| 31567 | DATA IRETUR/0/ |
| 31568 | |
| 31569 | IRETUR=IRETUR+1 |
| 31570 | AMH(31)=0.48D0 |
| 31571 | IF (IRETUR.GT.1) RETURN |
| 31572 | DO 10 I=1,94 |
| 31573 | AMH(I) = AAM(I) |
| 31574 | GAH(I) = GA(I) |
| 31575 | TAUH(I) = TAU(I) |
| 31576 | ICHH(I) = IICH(I) |
| 31577 | IBARH(I) = IIBAR(I) |
| 31578 | K1H(I) = K1(I) |
| 31579 | K2H(I) = K2(I) |
| 31580 | 10 CONTINUE |
| 31581 | **sr |
| 31582 | C AMH(1)=0.93828D0 |
| 31583 | AMH(1)=0.9383D0 |
| 31584 | ** |
| 31585 | AMH(2)=AMH(1) |
| 31586 | DO 20 I=26,30 |
| 31587 | K1H(I)=452 |
| 31588 | K2H(I)=452 |
| 31589 | 20 CONTINUE |
| 31590 | DO 30 I=1,307 |
| 31591 | WTI(I) = WT(I) |
| 31592 | NZKI(I,1) = NZK(I,1) |
| 31593 | NZKI(I,2) = NZK(I,2) |
| 31594 | NZKI(I,3) = NZK(I,3) |
| 31595 | 30 CONTINUE |
| 31596 | DO 40 I=1,16 |
| 31597 | L=I+94 |
| 31598 | AMH(L)=AMZ(I) |
| 31599 | GAH( L)=GAZ(I) |
| 31600 | TAUH( L)=TAUZ(I) |
| 31601 | ICHH( L)=ICHZ(I) |
| 31602 | IBARH( L)=IBARZ(I) |
| 31603 | K1H( L)=K1Z(I) |
| 31604 | K2H( L)=K2Z(I) |
| 31605 | 40 CONTINUE |
| 31606 | DO 50 I=1,153 |
| 31607 | L=I+307 |
| 31608 | WTI(L) = WTZ(I) |
| 31609 | NZKI(L,3) = NZK3(I) |
| 31610 | NZKI(L,2) = NZK2(I) |
| 31611 | NZKI(L,1) = NZK1(I) |
| 31612 | 50 CONTINUE |
| 31613 | RETURN |
| 31614 | END |
| 31615 | * |
| 31616 | *===iefund=============================================================* |
| 31617 | * |
| 31618 | CDECK ID>, IDT_IEFUND |
| 31619 | INTEGER FUNCTION IDT_IEFUND(PL,IRE) |
| 31620 | |
| 31621 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 31622 | SAVE |
| 31623 | |
| 31624 | C*****IEFUN CALCULATES A MOMENTUM INDEX |
| 31625 | |
| 31626 | PARAMETER ( LINP = 5 , |
| 31627 | & LOUT = 6 , |
| 31628 | & LDAT = 9 ) |
| 31629 | |
| 31630 | COMMON /HNDRUN/ RUNTES,EFTES |
| 31631 | COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17) |
| 31632 | COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184), |
| 31633 | & NRK(2,268),NURE(30,2) |
| 31634 | |
| 31635 | IPLA=IEII(IRE)+1 |
| 31636 | *+1 |
| 31637 | IPLE=IEII(IRE+1) |
| 31638 | IF (PL.LT.0.) GO TO 30 |
| 31639 | DO 10 I=IPLA,IPLE |
| 31640 | J=I-IPLA+1 |
| 31641 | IF (PL.LE.PLABF(I)) GO TO 60 |
| 31642 | 10 CONTINUE |
| 31643 | I=IPLE |
| 31644 | IF ( EFTES.GT.40.D0) GO TO 20 |
| 31645 | EFTES=EFTES+1.0D0 |
| 31646 | WRITE(LOUT,1000)PL,J |
| 31647 | 20 CONTINUE |
| 31648 | GO TO 70 |
| 31649 | 30 CONTINUE |
| 31650 | DO 40 I=IPLA,IPLE |
| 31651 | J=I-IPLA+1 |
| 31652 | IF (-PL.LE.UMO(I)) GO TO 60 |
| 31653 | 40 CONTINUE |
| 31654 | I=IPLE |
| 31655 | IF ( EFTES.GT.40.D0) GO TO 50 |
| 31656 | EFTES=EFTES+1.0D0 |
| 31657 | WRITE(LOUT,1000)PL,I |
| 31658 | 50 CONTINUE |
| 31659 | 60 CONTINUE |
| 31660 | 70 CONTINUE |
| 31661 | IDT_IEFUND=I |
| 31662 | RETURN |
| 31663 | 1000 FORMAT(14H PLAB OR -ECM=,E12.4,27H IS OUT OF CONSIDERED RANGE , |
| 31664 | +7H IEFUN=,I5) |
| 31665 | END |
| 31666 | * |
| 31667 | *===dsigin=============================================================* |
| 31668 | * |
| 31669 | CDECK ID>, DT_DSIGIN |
| 31670 | SUBROUTINE DT_DSIGIN(IRE ,PLAB,N,IE ,AMT ,AMN,ECM ,SI ,ITAR) |
| 31671 | |
| 31672 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 31673 | SAVE |
| 31674 | |
| 31675 | * particle properties (BAMJET index convention), |
| 31676 | * (dublicate of DTPART for HADRIN) |
| 31677 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), |
| 31678 | & K1H(110),K2H(110) |
| 31679 | COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17) |
| 31680 | COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184), |
| 31681 | & NRK(2,268),NURE(30,2) |
| 31682 | |
| 31683 | IE=IDT_IEFUND(PLAB,IRE) |
| 31684 | IF (IE.LE.IEII(IRE)) IE=IE+1 |
| 31685 | AMT=AMH(ITAR) |
| 31686 | AMN=AMH(N) |
| 31687 | AMN2=AMN*AMN |
| 31688 | AMT2=AMT*AMT |
| 31689 | ECM=SQRT(AMN2+AMT2+2.0D0*AMT*SQRT(AMN2+PLAB**2)) |
| 31690 | C*** INTERPOLATION PREPARATION |
| 31691 | ECMO=UMO(IE) |
| 31692 | ECM1=UMO(IE-1) |
| 31693 | DECM=ECMO-ECM1 |
| 31694 | DEC=ECMO-ECM |
| 31695 | IIKI=IKII(IRE)+1 |
| 31696 | EKLIM=-THRESH(IIKI) |
| 31697 | WOK=SIIN(IE) |
| 31698 | WDK=WOK-SIIN(IE-1) |
| 31699 | IF (ECM.GT.ECMO) WDK=0.0D0 |
| 31700 | C*** INTERPOLATION IN CHANNEL WEIGHTS |
| 31701 | IELIM=IDT_IEFUND(EKLIM,IRE) |
| 31702 | DELIM=UMO(IELIM)+EKLIM |
| 31703 | *+1.D-16 |
| 31704 | DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0 |
| 31705 | IF (DELIM*DELIM-DETE*DETE) 20,20,10 |
| 31706 | 10 DECC=DELIM |
| 31707 | GO TO 30 |
| 31708 | 20 DECC=DECM |
| 31709 | 30 CONTINUE |
| 31710 | WKK=WOK-WDK*DEC/(DECC+1.D-9) |
| 31711 | IF (WKK.LT.0.0D0) WKK=0.0D0 |
| 31712 | SI=WKK+1.D-12 |
| 31713 | IF (-EKLIM.GT.ECM) SI=1.D-14 |
| 31714 | RETURN |
| 31715 | END |
| 31716 | * |
| 31717 | *===dtchoi=============================================================* |
| 31718 | * |
| 31719 | CDECK ID>, DT_DTCHOI |
| 31720 | SUBROUTINE DT_DTCHOI(T,P,PP,E,EE,I,II,N,AM1,AM2) |
| 31721 | |
| 31722 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 31723 | SAVE |
| 31724 | |
| 31725 | C **************************** |
| 31726 | C TCHOIC CALCULATES A RANDOM VALUE |
| 31727 | C FOR THE FOUR-MOMENTUM-TRANSFER T |
| 31728 | C **************************** |
| 31729 | |
| 31730 | * particle properties (BAMJET index convention), |
| 31731 | * (dublicate of DTPART for HADRIN) |
| 31732 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), |
| 31733 | & K1H(110),K2H(110) |
| 31734 | * slope parameters for HADRIN interactions |
| 31735 | COMMON /HNSLOP/ SM(25),BBM(25),BBB(25) |
| 31736 | |
| 31737 | AMA=AM1 |
| 31738 | AMB=AM2 |
| 31739 | IF (I.GT.30.AND.II.GT.30) GO TO 20 |
| 31740 | III=II |
| 31741 | AM3=AM2 |
| 31742 | IF (I.LE.30) GO TO 10 |
| 31743 | III=I |
| 31744 | AM3=AM1 |
| 31745 | 10 CONTINUE |
| 31746 | GO TO 30 |
| 31747 | 20 CONTINUE |
| 31748 | III=II |
| 31749 | AM3=AM2 |
| 31750 | IF (AMA.LE.AMB) GO TO 30 |
| 31751 | III=I |
| 31752 | AM3=AM1 |
| 31753 | 30 CONTINUE |
| 31754 | IB=IBARH(III) |
| 31755 | AMA=AM3 |
| 31756 | K=INT((AMA-0.75D0)/0.05D0) |
| 31757 | IF (K-2.LT.0) K=1 |
| 31758 | IF (K-26.GE.0) K=25 |
| 31759 | IF (IB)50,40,50 |
| 31760 | 40 BM=BBM(K) |
| 31761 | GO TO 60 |
| 31762 | 50 BM=BBB(K) |
| 31763 | 60 CONTINUE |
| 31764 | C NORMALIZATION |
| 31765 | TMIN=-2.0D0*(E*EE-P*PP)+AMH(N)**2+AM1 **2 |
| 31766 | TMAX=-2.0D0*(E*EE+P*PP)+AMH(N)**2+AM1 **2 |
| 31767 | VB=DT_RNDM(TMIN) |
| 31768 | **sr test |
| 31769 | C IF (VB.LT.0.2D0) BM=BM*0.1 |
| 31770 | C **0.5 |
| 31771 | BM = BM*5.05D0 |
| 31772 | ** |
| 31773 | TMI=BM*TMIN |
| 31774 | TMA=BM*TMAX |
| 31775 | ETMA=0.D0 |
| 31776 | IF (ABS(TMA).GT.120.D0) GO TO 70 |
| 31777 | ETMA=EXP(TMA) |
| 31778 | 70 CONTINUE |
| 31779 | AN=(1.0D0/BM)*(EXP(TMI)-ETMA) |
| 31780 | C*** RANDOM CHOICE OF THE T - VALUE |
| 31781 | R=DT_RNDM(TMI) |
| 31782 | T=(1.0D0/BM)*LOG(ETMA+R*AN*BM) |
| 31783 | RETURN |
| 31784 | END |
| 31785 | * |
| 31786 | *===dtwopa=============================================================* |
| 31787 | * |
| 31788 | CDECK ID>, DT_DTWOPA |
| 31789 | SUBROUTINE DT_DTWOPA(E1,E2,P1,P2,COD1,COD2,COF1,COF2,SIF1,SIF2, |
| 31790 | &IT1,IT2,UMOO,ECM,P,N,AM1,AM2) |
| 31791 | |
| 31792 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 31793 | SAVE |
| 31794 | |
| 31795 | C ****************************************************** |
| 31796 | C QUASI TWO PARTICLE PRODUCTION |
| 31797 | C TWOPAR CALCULATES THE ENERGYS AND THE MOMENTA |
| 31798 | C FOR THE CREATED PARTICLES OR RESONANCES IT1 AND IT2 |
| 31799 | C IN THE CM - SYSTEM |
| 31800 | C COD1,COD2,COF1,COF2,SIF1,SIF2 ARE THE ANGLES FOR |
| 31801 | C SPHERICAL COORDINATES |
| 31802 | C ****************************************************** |
| 31803 | |
| 31804 | * particle properties (BAMJET index convention), |
| 31805 | * (dublicate of DTPART for HADRIN) |
| 31806 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), |
| 31807 | & K1H(110),K2H(110) |
| 31808 | |
| 31809 | AMA=AM1 |
| 31810 | AMB=AM2 |
| 31811 | AMA2=AMA*AMA |
| 31812 | E1=((UMOO-AMB)*(UMOO+AMB) + AMA2)/(2.0D0*UMOO) |
| 31813 | E2=UMOO - E1 |
| 31814 | IF (E1.LT.AMA*1.00001D0) E1=AMA*1.00001D0 |
| 31815 | AMTE=(E1-AMA)*(E1+AMA) |
| 31816 | AMTE=AMTE+1.D-18 |
| 31817 | P1=SQRT(AMTE) |
| 31818 | P2=P1 |
| 31819 | C / P2 / = / P1 / BUT OPPOSITE DIRECTIONS |
| 31820 | C DETERMINATION OF THE ANGLES |
| 31821 | C COS(THETA1)=COD1 COS(THETA2)=COD2 |
| 31822 | C SIN(PHI1)=SIF1 SIN(PHI2)=SIF2 |
| 31823 | C COS(PHI1)=COF1 COS(PHI2)=COF2 |
| 31824 | C PHI IS UNIFORMLY DISTRIBUTED IN ( 0,2*PI ) |
| 31825 | CALL DT_DSFECF(COF1,SIF1) |
| 31826 | COF2=-COF1 |
| 31827 | SIF2=-SIF1 |
| 31828 | C CALCULATION OF THETA1 |
| 31829 | CALL DT_DTCHOI(TR,P,P1,ECM,E1,IT1,IT2,N,AM1,AM2) |
| 31830 | COD1=(TR-AMA2-AMH(N)*AMH(N)+2.0D0*ECM*E1)/(2.0D0*P*P1+1.D-18) |
| 31831 | IF (COD1.GT.0.9999999D0) COD1=0.9999999D0 |
| 31832 | COD2=-COD1 |
| 31833 | RETURN |
| 31834 | END |
| 31835 | * |
| 31836 | *===zk=================================================================* |
| 31837 | * |
| 31838 | CDECK ID>, DT_ZK |
| 31839 | BLOCK DATA DT_ZK |
| 31840 | |
| 31841 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 31842 | SAVE |
| 31843 | |
| 31844 | * decay channel information for HADRIN |
| 31845 | COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16), |
| 31846 | & K1Z(16),K2Z(16),WTZ(153),II22, |
| 31847 | & NZK1(153),NZK2(153),NZK3(153) |
| 31848 | * decay channel information for HADRIN |
| 31849 | CHARACTER*8 ANAMZ,ZKNAM4,ZKNAM5,ZKNAM6 |
| 31850 | COMMON /HNADDN/ ANAMZ(16),ZKNAM4(9),ZKNAM5(90),ZKNAM6(54) |
| 31851 | |
| 31852 | * Particle masses in GeV * |
| 31853 | DATA AMZ/ 3*2.2D0, 0.9576D0, 3*1.887D0, 2.4D0, 2.03D0, 2*1.44D0, |
| 31854 | & 2*1.7D0, 3*0.D0/ |
| 31855 | * Resonance width Gamma in GeV * |
| 31856 | DATA GAZ/ 3*.2D0, .1D0, 4*.2D0, .18D0, 2*.2D0, 2*.15D0, 3*0.D0 / |
| 31857 | * Mean life time in seconds * |
| 31858 | DATA TAUZ / 16*0.D0 / |
| 31859 | * Charge of particles and resonances * |
| 31860 | DATA ICHZ/ 0, 1, 3*0, 1, -1, 0, 1, -1, 0, 0, 1 , 3*0 / |
| 31861 | * Baryonic charge * |
| 31862 | DATA IBARZ/ 2, 7*0, 1, -1, -1, 1, 1, 3*0 / |
| 31863 | * First number of decay channels used for resonances * |
| 31864 | * and decaying particles * |
| 31865 | DATA K1Z/ 308,310,313,317,322,365,393,421,425,434,440,446,449, |
| 31866 | & 3*460/ |
| 31867 | * Last number of decay channels used for resonances * |
| 31868 | * and decaying particles * |
| 31869 | DATA K2Z/ 309,312,316,321,364,392,420,424,433,439,445,448,451, |
| 31870 | & 3*460/ |
| 31871 | * Weight of decay channel * |
| 31872 | DATA WTZ/ .17D0, .83D0, 2*.33D0, .34D0, .17D0, 2*.33D0, .17D0, |
| 31873 | & .01D0, .13D0, .36D0, .27D0, .23D0, .0014D0, .0029D0, .0014D0, |
| 31874 | & .0029D0, 4*.0007D0, .0517D0, .0718D0, .0144D0, .0431D0, .0359D0, |
| 31875 | & .0718D0, .0014D0, .0273D0, .0014D0, .0431D0, 2*.0129D0, .0259D0, |
| 31876 | & .0517D0, .0359D0, .0014D0, 2*.0144D0, .0129D0, .0014D0, .0259D0, |
| 31877 | & .0359D0, .0072D0, .0474D0, .0948D0, .0259D0, .0072D0, .0144D0, |
| 31878 | & .0287D0, .0431D0, .0144D0, .0287D0, .0474D0, .0144D0, .0075D0, |
| 31879 | & .0057D0, .0019D0, .0038D0, .0095D0, 2*.0014D0, .0191D0, .0572D0, |
| 31880 | & .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0, .0686D0,.0172D0, |
| 31881 | & .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0, .0190D0, |
| 31882 | & .0057D0, .0019D0, .0038D0, .0095D0, .0014D0, .0014D0, .0191D0, |
| 31883 | & .0572D0, .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0,.0686D0, |
| 31884 | & .0172D0, .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0, |
| 31885 | & .0190D0, 4*.25D0, 2*.2D0, .12D0, .1D0, .07D0, .07D0, .14D0, |
| 31886 | & 2*.05D0, .0D0, .3334D0, .2083D0, 2*.125D0, .2083D0, .0D0, .125D0, |
| 31887 | & .2083D0, .3334D0, .2083D0, .125D0, .3D0, .05D0, .65D0, .3D0, |
| 31888 | & .05D0, .65D0, 9*1.D0 / |
| 31889 | * Particle numbers in decay channel * |
| 31890 | DATA NZK1/ 8, 1, 2, 9, 1, 2, 9, 2, 9, 7, 13, 31, 15, 24, 23, 13, |
| 31891 | & 23, 13, 2*23, 14, 13, 23, 31, 98, 2*33, 32, 23, 14, 13, 35, 2*23, |
| 31892 | & 14, 13, 33, 23, 98, 31, 23, 14, 13, 35, 2*33, 32, 23, 35, 33, 32, |
| 31893 | & 98, 5*35, 4*13, 23, 13, 98, 32, 33, 23, 13, 23, 13, 14, 13, 32, |
| 31894 | & 13, 98, 23, 13, 2*32, 13, 33, 32, 98, 2*35, 4*14, 23, 14, 98, |
| 31895 | & 2*34, 23, 14, 23, 2*14, 13, 34, 14, 98, 23, 14, 2*34, 14, 33, 32, |
| 31896 | & 98, 2*35, 104, 61, 105, 62, 1, 17, 21, 17, 22, 2*21, 22, 21, 2, |
| 31897 | & 67, 68, 69, 2, 2*9, 68, 69, 70, 2, 9, 2*24, 15, 2*25, 16, 9*0/ |
| 31898 | DATA NZK2/ 2*8, 1, 8, 9, 2*8, 2*1, 7, 14, 13, 16, 25, 23, 14, 23, |
| 31899 | & 14, 31, 33, 32, 34, 35, 31, 23, 31, 33, 34, 31, 32, 34, 31, 33, |
| 31900 | & 32, 2*33, 35, 31, 33, 31, 33, 32, 34, 35, 31, 33, 34, 35, 31, |
| 31901 | & 4*33, 32, 3*35, 2*23, 13, 31, 32, 33, 13, 31, 32, 2*31, 32, 33, |
| 31902 | & 32, 32, 35, 31, 2*32, 33, 31, 33, 35, 33, 3*32, 35, 2*23, 14, |
| 31903 | & 31, 34, 33, 14, 31, 33, 2*31, 34, 32, 33, 34, 35, 31, 2*34, 33, |
| 31904 | & 31, 33, 35, 33, 2*34, 33, 35, 1, 2, 8, 9, 25, 13, 35, 2*32, 33, |
| 31905 | & 31, 13, 23, 31, 13, 23, 14, 79, 80, 31, 13, 23, 14, 78, 79, 8, |
| 31906 | & 1, 8, 1, 8, 1, 9*0 / |
| 31907 | DATA NZK3/ 23, 14, 2*13, 23, 13, 2*23, 14, 0, 7, 14, 4*0, 2*23, |
| 31908 | & 10*0, 33, 2*31, 0, 33, 34, 32, 34, 0, 35, 0, 31, 3*35, 0, 3*31, |
| 31909 | & 35, 31, 33, 34, 31, 33, 34, 31, 33, 35, 0, 23, 14, 6*0, 32, 3*33, |
| 31910 | & 32, 34, 0, 35, 0, 2*35, 2*31, 35, 32, 34, 31, 33, 32, 0, 23, 13, |
| 31911 | & 6*0, 34, 2*33, 34, 33, 34, 0, 35, 0,2*35, 2*31, 35, 2*34, 31, |
| 31912 | & 2*34, 25*0, 23, 2*14, 23, 2*13, 9*0 / |
| 31913 | * Particle names * |
| 31914 | DATA ANAMZ / 'NNPI', 'ANPPI', 'ANNPI', ' ETS ',' PAP ',' PAN ', |
| 31915 | & 'APN', 'DEO ', 'S+2030', 'AN*-14', 'AN*014','KONPI ','AKOPPI', |
| 31916 | & 3*'BLANK' / |
| 31917 | * Name of decay channel * |
| 31918 | DATA ZKNAM4/'NNPI0','PNPI-','APPPI+','ANNPI+','ANPPI0','APNPI+', |
| 31919 | & 'ANNPI0','APPPI0','ANPPI-'/ |
| 31920 | DATA ZKNAM5/' GAGA ','P+P-GA','ETP+P-','K+K- ','K0AK0 ', |
| 31921 | & ' POPO ',' P+P- ','POPOPO','P+P0P-','P0ET ','&0R0 ','P-R+ ', |
| 31922 | & 'P+R- ','POOM ',' ETET ','ETSP0 ','R0ET ',' R0R0 ','R+R- ', |
| 31923 | & 'P0ETR0','P-ETR+','P+ETR-',' OMET ','P0R0R0','P0R+R-','P-R+R0', |
| 31924 | & 'P+R-R0','R0OM ','P0ETOM','ETSR0 ','ETETET','P0R0OM','P-R+OM', |
| 31925 | & 'P+R-OM','OMOM ','R0ETET','R0R0ET','R+R-ET','P0OMOM','OMETET', |
| 31926 | & 'R0R0R0','R+R0R-','ETSRET','OMR0R0','OMR+R-','OMOMET','OMOMR0', |
| 31927 | & 'OMOMOM', |
| 31928 | & ' P+PO ','P+POPO','P+P+P-','P+ET ','P0R+ ','P+R0 ','ETSP+ ', |
| 31929 | & 'R+ET ',' R0R+ ','POETR+','P+ETR0','POR+R-','P+R0R0','P-R+R+', |
| 31930 | & 'P+R-R+','R+OM ','P+ETOM','ETSR+ ','POR+OM','P+R0OM','R+ETET', |
| 31931 | & 'R+R0ET','P+OMOM','R0R0R+','R+R+R-','ETSR+E','OMR+R0','OMOMR+', |
| 31932 | & 'P-PO ','P-POPO','P-P-P+','P-ET ','POR- ','P-R0 ','ETSP- ', |
| 31933 | & 'R-ET ','R-R0 ','POETR-','P-ETR0','POR-R0','P-R+R-','P-R0R0'/ |
| 31934 | DATA ZKNAM6/'P+R-R-','R-OM ','P-ETOM','ETSR- ','POR-OM','P-R0OM', |
| 31935 | & 'R-ETET','R-R0ET','P-OMOM','R0R0R-','R+R-R-','ETSR-E','OMR0R-', |
| 31936 | & 'OMOMR-', 'PAN-14','APN+14','NAN014','ANN014','PAKO ','LPI+ ', |
| 31937 | & 'SI+OM','LAMRO+','SI0RO+','SI+RO0','SI+ETA','SI0PI+','SI+PI0', |
| 31938 | & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHOO','ANRHO-','ANETA ', |
| 31939 | & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0', |
| 31940 | & 'KONPIO','KOPPI-','K+NPI-','AKOPPO','AKONP+','K-PPI+', |
| 31941 | & 9*'BLANK'/ |
| 31942 | *= end*block.zk * |
| 31943 | END |
| 31944 | * |
| 31945 | *===blkd43=============================================================* |
| 31946 | * |
| 31947 | CDECK ID>, DT_BLKD43 |
| 31948 | BLOCK DATA DT_BLKD43 |
| 31949 | |
| 31950 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 31951 | SAVE |
| 31952 | |
| 31953 | *$ CREATE REAC.ADD |
| 31954 | *COPY REAC |
| 31955 | * |
| 31956 | *=== reac =============================================================* |
| 31957 | * |
| 31958 | *----------------------------------------------------------------------* |
| 31959 | * * |
| 31960 | * Created on 10 december 1991 by Alfredo Ferrari & Paola Sala * |
| 31961 | * Infn - Milan * |
| 31962 | * * |
| 31963 | * Last change on 10-dec-91 by Alfredo Ferrari * |
| 31964 | * * |
| 31965 | * This is the original common reac of Hadrin * |
| 31966 | * * |
| 31967 | *----------------------------------------------------------------------* |
| 31968 | * |
| 31969 | COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184), |
| 31970 | & NRK(2,268),NURE(30,2) |
| 31971 | |
| 31972 | DIMENSION |
| 31973 | & UMOPI(92), UMOKC(68), UMOP(39), UMON(63), UMOK0(34), |
| 31974 | & PLAPI(92), PLAKC(68), PLAP(39), PLAN(63), PLAK0(34), |
| 31975 | & SPIKP1(315), SPIKPU(278), SPIKPV(372), |
| 31976 | & SPIKPW(278), SPIKPX(372), SPIKP4(315), |
| 31977 | & SPIKP5(187), SPIKP6(289), |
| 31978 | & SKMPEL(102), SPIKP7(289), SKMNEL(68), SPIKP8(187), |
| 31979 | & SPIKP9(143), SPIKP0(169), SPKPV(143), |
| 31980 | & SAPPEL(105), SPIKPE(399), SAPNEL(84), SPIKPZ(273), |
| 31981 | & SANPEL(84) , SPIKPF(273), |
| 31982 | & SPKP15(187), SPKP16(272), |
| 31983 | & NRKPI(164), NRKKC(132), NRKP(70), NRKN(116), NRKK0(54), |
| 31984 | & NURELN(60) |
| 31985 | * |
| 31986 | DIMENSION NRKLIN(532) |
| 31987 | EQUIVALENCE (NRK(1,1), NRKLIN(1)) |
| 31988 | EQUIVALENCE ( UMO( 1), UMOPI(1)), ( UMO( 93), UMOKC(1)) |
| 31989 | EQUIVALENCE ( UMO(161), UMOP(1)), ( UMO(200), UMON(1)) |
| 31990 | EQUIVALENCE ( UMO(263), UMOK0(1)) |
| 31991 | EQUIVALENCE ( PLABF( 1), PLAPI(1)), ( PLABF( 93), PLAKC(1)) |
| 31992 | EQUIVALENCE ( PLABF(161), PLAP(1)), ( PLABF(200), PLAN(1)) |
| 31993 | EQUIVALENCE ( PLABF(263), PLAK0(1)) |
| 31994 | EQUIVALENCE ( WK( 1), SPIKP1(1)), ( WK( 316), SPIKPU(1)) |
| 31995 | EQUIVALENCE ( WK( 594), SPIKPV(1)), ( WK( 966), SPIKPW(1)) |
| 31996 | EQUIVALENCE ( WK(1244), SPIKPX(1)), ( WK(1616), SPIKP4(1)) |
| 31997 | EQUIVALENCE ( WK(1931), SPIKP5(1)), ( WK(2118), SPIKP6(1)) |
| 31998 | EQUIVALENCE ( WK(2407), SKMPEL(1)), ( WK(2509), SPIKP7(1)) |
| 31999 | EQUIVALENCE ( WK(2798), SKMNEL(1)), ( WK(2866), SPIKP8(1)) |
| 32000 | EQUIVALENCE ( WK(3053), SPIKP9(1)), ( WK(3196), SPIKP0(1)) |
| 32001 | EQUIVALENCE ( WK(3365), SPKPV(1)), ( WK(3508), SAPPEL(1)) |
| 32002 | EQUIVALENCE ( WK(3613), SPIKPE(1)), ( WK(4012), SAPNEL(1)) |
| 32003 | EQUIVALENCE ( WK(4096), SPIKPZ(1)), ( WK(4369), SANPEL(1)) |
| 32004 | EQUIVALENCE ( WK(4453), SPIKPF(1)), ( WK(4726), SPKP15(1)) |
| 32005 | EQUIVALENCE ( WK(4913), SPKP16(1)) |
| 32006 | EQUIVALENCE (NRK(1,1), NRKLIN(1)) |
| 32007 | EQUIVALENCE (NRKLIN( 1), NRKPI(1)), (NRKLIN( 165), NRKKC(1)) |
| 32008 | EQUIVALENCE (NRKLIN( 297), NRKP(1)), (NRKLIN( 367), NRKN(1)) |
| 32009 | EQUIVALENCE (NRKLIN( 483), NRKK0(1)) |
| 32010 | EQUIVALENCE (NURE(1,1), NURELN(1)) |
| 32011 | * |
| 32012 | **** pi- p data * |
| 32013 | **** pi+ n data * |
| 32014 | DATA PLAPI / 0.D0, .3D0, .5D0, .6D0, .7D0, .8D0, .9D0, .95D0,1.D0, |
| 32015 | & 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0, |
| 32016 | & 3.D0, 3.5D0, 4.D0, 0.D0, .285D0, .4D0, .45D0, .5D0, .6D0, .7D0, |
| 32017 | & .75D0, .8D0, .85D0, .9D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, |
| 32018 | & 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0, |
| 32019 | & .285D0, .4D0, .45D0, .5D0, .6D0, .7D0, .75D0, .8D0, .85D0, .9D0, |
| 32020 | & 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0, |
| 32021 | & 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0, .3D0, .5D0, .6D0, .7D0, |
| 32022 | & .8D0, .9D0, .95D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, |
| 32023 | & 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0 / |
| 32024 | DATA PLAKC / |
| 32025 | & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0, |
| 32026 | & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0, |
| 32027 | & 3.51D0, 3.84D0, 4.16D0, 4.49D0, |
| 32028 | & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0, |
| 32029 | & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0, |
| 32030 | & 3.51D0, 3.84D0, 4.16D0, 4.49D0, |
| 32031 | & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0, |
| 32032 | & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0, |
| 32033 | & 3.51D0, 3.84D0, 4.16D0, 4.49D0, |
| 32034 | & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0, |
| 32035 | & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0, |
| 32036 | & 3.51D0, 3.84D0, 4.16D0, 4.49D0/ |
| 32037 | DATA PLAK0 / |
| 32038 | & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0, |
| 32039 | & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0, |
| 32040 | & 3.51D0, 3.84D0, 4.16D0, 4.49D0, |
| 32041 | & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0, |
| 32042 | & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0, |
| 32043 | & 3.51D0, 3.84D0, 4.16D0, 4.49D0/ |
| 32044 | * pp pn np nn * |
| 32045 | DATA PLAP / |
| 32046 | & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0, |
| 32047 | & 3.43D0, 3.75D0, 4.07D0, 4.43D0, |
| 32048 | & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0, |
| 32049 | & 3.43D0, 3.75D0, 4.07D0, 4.43D0, |
| 32050 | & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0, |
| 32051 | & 3.43D0, 3.75D0, 4.07D0, 4.43D0 / |
| 32052 | * app apn anp ann * |
| 32053 | DATA PLAN / |
| 32054 | & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0, |
| 32055 | & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0, |
| 32056 | & 3.43D0, 3.75D0, 4.07D0, 4.43D0, |
| 32057 | & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0, |
| 32058 | & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0, |
| 32059 | & 3.43D0, 3.75D0, 4.07D0, 4.43D0, |
| 32060 | & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0, |
| 32061 | & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0, |
| 32062 | & 3.43D0, 3.75D0, 4.07D0, 4.43D0 / |
| 32063 | DATA SIIN / 296*0.D0 / |
| 32064 | DATA UMOPI/ 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0, |
| 32065 | & 1.557D0,1.615D0,1.6435D0, |
| 32066 | & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0, |
| 32067 | & 2.286D0,2.366D0,2.482D0,2.56D0, |
| 32068 | & 2.735D0,2.90D0, |
| 32069 | & 1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0, |
| 32070 | & 1.496D0,1.527D0,1.557D0, |
| 32071 | & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0, |
| 32072 | & 2.071D0,2.159D0,2.286D0,2.366D0, |
| 32073 | & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0, |
| 32074 | & 1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0, |
| 32075 | & 1.496D0,1.527D0,1.557D0, |
| 32076 | & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0, |
| 32077 | & 2.071D0,2.159D0,2.286D0,2.366D0, |
| 32078 | & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0, |
| 32079 | & 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0, |
| 32080 | & 1.557D0,1.615D0,1.6435D0, |
| 32081 | & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0, |
| 32082 | & 2.286D0,2.366D0,2.482D0,2.56D0, |
| 32083 | & 2.735D0, 2.90D0/ |
| 32084 | DATA UMOKC/ 1.44D0, |
| 32085 | & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0, |
| 32086 | & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0, |
| 32087 | & 3.1D0,1.44D0, |
| 32088 | & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0, |
| 32089 | & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0, |
| 32090 | & 3.1D0,1.44D0, |
| 32091 | & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0, |
| 32092 | & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0, |
| 32093 | & 3.1D0,1.44D0, |
| 32094 | & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0, |
| 32095 | & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0, |
| 32096 | & 3.1D0/ |
| 32097 | DATA UMOK0/ 1.44D0, |
| 32098 | & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0, |
| 32099 | & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0, |
| 32100 | & 3.1D0,1.44D0, |
| 32101 | & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0, |
| 32102 | & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0, |
| 32103 | & 3.1D0/ |
| 32104 | * pp pn np nn * |
| 32105 | DATA UMOP/ |
| 32106 | & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0, |
| 32107 | & 3.D0,3.1D0,3.2D0, |
| 32108 | & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0, |
| 32109 | & 3.D0,3.1D0,3.2D0, |
| 32110 | & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0, |
| 32111 | & 3.D0,3.1D0,3.2D0/ |
| 32112 | * app apn anp ann * |
| 32113 | DATA UMON / |
| 32114 | & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0, |
| 32115 | & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0, |
| 32116 | & 3.D0,3.1D0,3.2D0, |
| 32117 | & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0, |
| 32118 | & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0, |
| 32119 | & 3.D0,3.1D0,3.2D0, |
| 32120 | & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0, |
| 32121 | & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0, |
| 32122 | & 3.D0,3.1D0,3.2D0/ |
| 32123 | **** reaction channel state particles * |
| 32124 | DATA NRKPI / 13, 1, 15, 21, 81, 0, 13, 54, 23, 53, 13, 63, 13, 58, |
| 32125 | & 23, 57, 13, 65, 1, 32, 53, 31, 54, 32, 53, 33, 53, 35, 63, 32, |
| 32126 | & 13, 8, 23, 1, 17, 15, 21, 24, 22, 15, 82, 0, 61, 0, 13, 55, 23, |
| 32127 | & 54, 14, 53, 13, 64, 23, 63, 13, 59, 23, 58, 14, 57, 13, 66, 23, |
| 32128 | & 65, 1, 31, 8, 32, 1, 33, 1, 35, 54, 31, 55, 32, 54, 33, 53, 34, |
| 32129 | & 54, 35, 14, 1, 23, 8, 17, 24, 20, 15, 22, 24, 83, 0, 62, 0, 14, |
| 32130 | & 54, 23, 55, 13, 56, 14, 63, 23, 64, 14, 58, 23, 59, 13, 60, 14, |
| 32131 | & 65, 23, 66, 8, 31, 1, 34, 8, 33, 8, 35, 55, 31, 54, 34, 55, 33, |
| 32132 | & 56, 32, 55, 35, 14, 8, 24, 20, 84, 0, 14, 55, 23, 56, 14, 64, 14, |
| 32133 | & 59, 23, 60, 14, 66, 8, 34, 56, 31, 55, 34, 56, 33, 56, 35, 64,34/ |
| 32134 | DATA NRKKC/ 15, 1, 89, 0, 24, 53, 15, 54, 1, 36, 1, 40, 1, 44, 36, |
| 32135 | & 63, 15, 63, 45, 53, 44, 54, 15, 8, 24, 1, 91, 0, 24, 54, 15, 55, |
| 32136 | & 8, 36, 1, 37, 8, 40, 1, 41, 8, 44, 1, 45, 36, 64, 37, 63, 15, 64, |
| 32137 | & 24, 63, 45, 54, 44, 55, 16, 1, 25, 8, 17, 23, 21, 14, 20, |
| 32138 | & 13, 22, 23, 90, 0, 38, 1, 39, 8, 16, 54, 25, 55, 1, 42, 8, 43, |
| 32139 | & 16, 63, 25, 64, 39, 64, 38, 63, 46, 54, 47, 55, 8, 47, 1, 46, 52, |
| 32140 | & 0, 51, 0, 16, 8, 17, 14, 20, 23, 22, 14, 92, 0, 8, 38, 16, 55, |
| 32141 | & 25, 56, 8, 42, 16, 64, 38, 64, 46, 55, 47, 56, 8, 46, 94, 0 / |
| 32142 | * * |
| 32143 | * k0 p k0 n ak0 p ak/ n * |
| 32144 | * * |
| 32145 | DATA NRKK0 / 24, 8, 106, 0, 15, 56, 24, 55, 37, 8, 41, 8, 45, 8, |
| 32146 | & 37, 64, 24, 64, 44, 56, 45, 55, 25, 1, 17, 13, 22, 13, 21, 23, |
| 32147 | & 107, 0, 39, 1, 25, 54, 16, 53, 43, 1, 25, 63, 39, 63, 47, 54, 46, |
| 32148 | & 53, 47, 1, 103, 0, 93, 0/ |
| 32149 | * pp pn np nn * |
| 32150 | DATA NRKP / 1, 1, 85, 0, 8, 53, 1, 54, 1, 63, 8, 57, 1, 58, 2*54, |
| 32151 | & 53, 55, 63, 54, 64, 53, 1, 8, 86, 0, 8, 54, 1, 55, 8, 63, 1, 64, |
| 32152 | & 8, 58, 1, 59, 64, 54, 63, 55, 54, 55, 53, 56, 77, 0, 2*8, 95, 0, |
| 32153 | & 8, 55, 1, 56, 8, 64, 8, 59, 1, 60, 2*55, 54, 56, 64, 55, 63, 56 / |
| 32154 | * app apn anp ann * |
| 32155 | DATA NRKN/ 1, 2, 17, 18, 15, 16, 8, 9, 13, 14, 99, 0, 87, 0, 1, |
| 32156 | & 68, 8, 69, 2, 54, 9, 55, 102, 0, 2, 63, 9, 64, 1, 75, 8, 76, 53, |
| 32157 | & 67, 54, 68, 55, 69, 56, 70, 63, 68, 64, 69, 75, 54, 76, 55, 2, 8, |
| 32158 | & 18, 20, 16, 24, 14, 23, 101, 0, 88, 0, 2, 55, 9, 56, 1, 67, 8, |
| 32159 | & 68, 2, 64, 8, 75, 2, 59, 8, 72, 68, 55, 67, 54, 69, 56, 1, 9, 18, |
| 32160 | & 21, 15, 25, 13, 23, 100, 0, 96, 0, 2, 53, 9, 54, 1, 69, 8, 70, 1, |
| 32161 | & 76, 9, 63, 1, 73, 9, 58, 55, 70, 53, 68, 54, 69 / |
| 32162 | **** channel cross section * |
| 32163 | DATA SPIKP1/ 0.D0, 300.D0, 40.D0, 20.D0, 13.D0,8.5D0,8.D0, 9.5D0, |
| 32164 | & 12.D0,14.D0,15.5D0,20.D0,17.D0,13.D0,10.D0,9.D0,8.5D0,8.D0,7.8D0, |
| 32165 | & 7.3D0, 6.7D0, 9*0.D0,.23D0,.35D0,.7D0,.52D0,.4D0,.3D0,.2D0,.15D0, |
| 32166 | & .13D0, .11D0, .09D0, .07D0, 0.D0, .033D0,.8D0,1.35D0,1.35D0,.5D0, |
| 32167 | & 15*0.D0, 3*0.D0,.00D0,0.80D0,2.2D0,3.6D0,4.6D0,4.7D0,3.5D0,2.4D0, |
| 32168 | &1.8D0,1.4D0,.75D0,.47D0,.25D0,.13D0,.08D0,6*0.D0,0.D0,1.2D0,3.3D0, |
| 32169 | & 5.4D0,6.9D0,7.3D0,5.3D0,3.6D0,2.7D0,2.2D0,1.1D0,.73D0,.4D0,.22D0, |
| 32170 | & .12D0,9*0.D0,.0D0,0.D0,2.0D0,4.4D0,6.8D0,9.9D0,7.9D0,6.0D0,3.8D0, |
| 32171 | &2.5D0,2.D0,1.4D0,1.D0,.6D0,.35D0,10*0.D0,.25D0,.55D0,.75D0,1.25D0, |
| 32172 | & 1.9D0,2.D0,1.8D0,1.5D0,1.25D0,1.D0,.8D0,6*0.D0,4*0.D0,.4D0,.85D0, |
| 32173 | & 1.1D0, 1.85D0, 2.8D0, 3.D0,2.7D0,2.2D0,1.85D0,1.5D0,1.2D0,6*0.D0, |
| 32174 | & 6*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0, 5.6D0, |
| 32175 | & 5.2D0, 6*0.D0, 2*0.D0, .0D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0, |
| 32176 | & 2.75D0, 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 6*0.D0, 3*0.D0, |
| 32177 | & .0D0, .45D0, 1.4D0, 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0, |
| 32178 | & 8*0.D0, 5*0.D0, .0D0, .0D0, .6D0, .8D0, .95D0, .8D0, .7D0, .6D0, |
| 32179 | & .5D0, .4D0, 6*0.D0, 5*0.D0, .0D0, .00D0, .85D0, 1.2D0, 1.4D0, |
| 32180 | & 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 6*0.D0, 5*0.D0, .0D0, .00D0, |
| 32181 | & 1.D0, 1.5D0, 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 6*0.D0, |
| 32182 | & 10*0.D0, .5D0, 2.0D0, 3.3D0, 5.4D0, 7.D0 / |
| 32183 | **** pi+ n data * |
| 32184 | DATA SPIKPU/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 20.D0, |
| 32185 | & 20.D0, 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0, |
| 32186 | & 10.D0, 10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0, |
| 32187 | & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0, |
| 32188 | & 4.2D0, 7.5D0, 3.4D0, 2.5D0, 2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0, |
| 32189 | & .6D0, .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0, |
| 32190 | & .48D0, .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0, |
| 32191 | & .065D0, .05D0, .04D0, 12*0.D0, .2D0, .25D0, .25D0, .2D0, .1D0, |
| 32192 | & .08D0, .06D0, .045D0, .03D0, .02D0, .01D0, .005D0, .003D0, |
| 32193 | & 12*0.D0, .3D0, .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0, |
| 32194 | & .09D0, .08D0, .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0, |
| 32195 | & 3.1D0, 4.5D0, 2.D0, 18*0.D0, 3*.0D0, 0.D0, 0.D0, 4.0D0, 11.D0, |
| 32196 | & 11.4D0, 10.3D0, 7.5D0, 6.8D0, 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0, |
| 32197 | & .35D0, 13*0.D0, .1D0, .34D0, .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0, |
| 32198 | & 2.3D0, 1.6D0, .95D0, .45D0, .28D0, .15D0, 10*0.D0, 2*0.D0, .17D0, |
| 32199 | & .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0, 6.2D0, 4.4D0, 3.D0, 1.8D0, |
| 32200 | & .9D0, .53D0, .28D0, 10*0.D0, 2*0.D0, .25D0, .82D0, |
| 32201 | & 1.3D0, 1.9D0, 2.8D0, 5.5D0 , 8.D0, 5.7D0, 3.9D0, 2.35D0, 1.15D0, |
| 32202 | & .69D0, .37D0, 10*0.D0, 7*0.D0, .0D0, .34D0, 1.5D0, 3.47D0, |
| 32203 | & 5.87D0, 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/ |
| 32204 | * |
| 32205 | DATA SPIKPV/ 7*0.D0, .00D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0, |
| 32206 | & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 6*0.D0, 10*0.D0, .2D0, |
| 32207 | & .6D0, .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0, |
| 32208 | & 1.D0, .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0, |
| 32209 | & 3.5D0, 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0, |
| 32210 | & .31D0, .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0, |
| 32211 | & .23D0, 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0, |
| 32212 | & 5.D0, 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0, |
| 32213 | & 2.5D0, 3*0.D0, 3*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0, |
| 32214 | & 1.5D0, 1.1D0, .8D0, .7D0, .55D0, .3D0, 10*0.D0, 9*0.D0, .1D0, |
| 32215 | & .4D0, 1.D0, 1.4D0, 2.2D0, 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0, |
| 32216 | & .8D0, .6D0, .4D0, 12*0.D0, .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0, |
| 32217 | & 3.8D0, 3.3D0, 2.45D0, 2.05D0, 1.65D0, 1.2D0, .9D0, .6D0, 3*0.D0, |
| 32218 | & 9*0.D0, .10D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0, |
| 32219 | & 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, 13*0.D0, .2D0, .5D0, .7D0, |
| 32220 | & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, |
| 32221 | & 17*0.D0, .2D0, .5D0, .85D0, 2.D0, 2.15D0, 2.05D0, 1.75D0, 1.D0, |
| 32222 | & 17*0.D0, .13D0, .33D0, .57D0, 1.33D0, 1.43D0, 1.36D0, 1.17D0, |
| 32223 | & .67D0, 17*0.D0, .07D0, .17D0, .28D0, .67D0, .72D0, .69D0, .58D0, |
| 32224 | & .33D0,17*0.D0,.4D0, .7D0, 1.D0, 1.6D0, 1.8D0, 2.3D0,1.9D0,1.7D0 / |
| 32225 | **** pi- p data * |
| 32226 | DATA SPIKPW/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 2*20.D0, |
| 32227 | & 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0, |
| 32228 | & 2*10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0, |
| 32229 | & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0, |
| 32230 | & 4.2D0, 7.5D0, 3.4D0, 2*2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0, .6D0, |
| 32231 | & .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0, .48D0, |
| 32232 | & .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0, .065D0, |
| 32233 | & .05D0, .04D0, 12*0.D0, .2D0, 2*.25D0, .2D0, .1D0, .08D0, .06D0, |
| 32234 | & .045D0, .03D0, .02D0, .01D0, .005D0, .003D0, 12*0.D0, .3D0, |
| 32235 | & .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0, .09D0, .08D0, |
| 32236 | & .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0, 3.1D0, 4.5D0, |
| 32237 | & 2.D0, 23*0.D0, 4.0D0, 11.D0, 11.4D0, 10.3D0, 7.5D0, 6.8D0, |
| 32238 | & 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0, .35D0, 13*0.D0, .1D0, .34D0, |
| 32239 | & .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0, 2.3D0, 1.6D0, .95D0, .45D0, |
| 32240 | & .28D0, .15D0, 12*0.D0, .17D0, .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0, |
| 32241 | & 6.2D0, 4.4D0, 3.D0, 1.8D0, .9D0, .53D0, .28D0, 12*0.D0, .25D0, |
| 32242 | & .82D0, 1.3D0, 1.9D0, 2.8D0, 5.5D0, 8.D0, 5.7D0, 3.9D0, 2.35D0, |
| 32243 | & 1.15D0, .69D0, .37D0, 18*0.D0, .34D0, 1.5D0, 3.47D0, 5.87D0, |
| 32244 | & 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/ |
| 32245 | * |
| 32246 | DATA SPIKPX/ 8*0.D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0, |
| 32247 | & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 16*0.D0, .2D0, .6D0, |
| 32248 | & .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0, 1.D0, |
| 32249 | & .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0, 3.5D0, |
| 32250 | & 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0, .31D0, |
| 32251 | & .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0, .23D0, |
| 32252 | & 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0, 5.D0, |
| 32253 | & 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0, 2.5D0, |
| 32254 | & 6*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0, 1.5D0, 1.1D0, |
| 32255 | & .8D0, .7D0, .55D0, .3D0, 19*0.D0, .1D0, .4D0, 1.D0, 1.4D0, 2.2D0, |
| 32256 | & 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0, .8D0, .6D0, .4D0, 12*0.D0, |
| 32257 | & .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0, 3.8D0, 3.3D0, 2.45D0, 2.05D0, |
| 32258 | & 1.65D0, 1.2D0, .9D0, .6D0, 12*0.D0, .10D0, .2D0, .5D0, .7D0, |
| 32259 | & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, |
| 32260 | & 13*0.D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, |
| 32261 | & 1.35D0, 1.15D0, .95D0, .7D0, 17*0.D0, .2D0, .5D0, .85D0, 2.D0, |
| 32262 | & 2.15D0, 2.05D0, 1.75D0, 1.D0, 17*0.D0, .13D0, .33D0, .57D0, |
| 32263 | & 1.33D0, 1.43D0, 1.36D0, 1.17D0, .67D0, 17*0.D0, .07D0, .17D0, |
| 32264 | & .28D0, .67D0, .72D0, .69D0, .58D0, .33D0, 17*0.D0, .4D0, .7D0, |
| 32265 | & 1.D0, 1.6D0, 1.8D0, 2.3D0, 1.9D0, 1.7D0 / |
| 32266 | **** pi- n data * |
| 32267 | DATA SPIKP4 / 0.D0, 300.D0, 40.D0, 20.D0, 13.D0, 8.5D0, 8.D0, |
| 32268 | & 9.5D0, 12.D0, 14.D0, 15.5D0, 20.D0, 17.D0, 13.D0, 10.D0, 9.D0, |
| 32269 | & 8.5D0, 8.D0, 7.8D0, 7.3D0, 6.7D0, 9*0.D0, .23D0, .35D0, .7D0, |
| 32270 | & .52D0, .4D0, .3D0, .2D0, .15D0, .13D0, .11D0, .09D0, .07D0, 0.D0, |
| 32271 | & .033D0, .8D0, 2*1.35D0, .5D0, 19*0.D0, 0.8D0, 2.2D0, 3.6D0, |
| 32272 | & 4.6D0, 4.7D0, 3.5D0, 2.4D0, 1.8D0, 1.4D0, .75D0, .47D0, .25D0, |
| 32273 | & .13D0, .08D0, 7*0.D0, 1.2D0, 3.3D0, 5.4D0, 6.9D0, 7.3D0, 5.3D0, |
| 32274 | & 3.6D0, 2.7D0, 2.2D0, 1.1D0, .73D0, .4D0, .22D0, .12D0, 11*0.D0, |
| 32275 | & 2.0D0, 4.4D0, 6.8D0, 9.9D0, 7.9D0, 6.0D0, 3.8D0, 2.5D0, 2.D0, |
| 32276 | & 1.4D0, 1.D0, .6D0, .35D0, 10*0.D0, .25D0, .55D0, .75D0, 1.25D0, |
| 32277 | & 1.9D0, 2.D0, 1.8D0, 1.5D0, 1.25D0, 1.D0, .8D0, 10*0.D0, .4D0, |
| 32278 | & .85D0, 1.1D0, 1.85D0, 2.8D0, 3.D0, 2.7D0, 2.2D0, 1.85D0, 1.5D0, |
| 32279 | & 1.2D0, 12*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0, |
| 32280 | & 5.6D0, 5.2D0, 9*0.D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0, 2.75D0, |
| 32281 | & 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 10*0.D0, .45D0, 1.4D0, |
| 32282 | & 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0, 15*0.D0, .6D0, |
| 32283 | & .8D0, .95D0, .8D0, .7D0, .6D0, .5D0, .4D0, 13*0.D0, .85D0, 1.2D0, |
| 32284 | & 1.4D0, 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 13*0.D0, 1.D0, 1.5D0, |
| 32285 | & 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 16*0.D0, .5D0, 2.0D0, |
| 32286 | & 3.3D0, 5.4D0, 7.D0 / |
| 32287 | **** k+ p data * |
| 32288 | DATA SPIKP5/ 0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0, |
| 32289 | & 7.D0, 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0, |
| 32290 | & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 13*0.D0, 0.9D0, |
| 32291 | & 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0, |
| 32292 | & .45D0, .21D0, .2D0, 3*0.D0, .9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, |
| 32293 | & 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0, |
| 32294 | & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0, 1.4D0, |
| 32295 | & 1.2D0, 1.05D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0, 2*1.D0, .9D0, |
| 32296 | & .7D0, .4D0, .3D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.2D0, |
| 32297 | & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, |
| 32298 | & 1.71D0, 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0, |
| 32299 | & 3.5D0, 2.85D0, 2.35D0, 2.01D0, 1.8D0, 12*0.D0, .1D0, .8D0,2.05D0, |
| 32300 | & 3.31D0, 3.5D0, 12*0.D0, .034D0, .2D0, .75D0, 1.04D0, 1.24D0 / |
| 32301 | **** k+ n data * |
| 32302 | DATA SPIKP6/ 0.D0, 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0, |
| 32303 | & 1.5D0, 1.2D0, 1.D0, .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0, |
| 32304 | & 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0, 1.5D0, 1.2D0, 1.D0, |
| 32305 | & .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0, .5D0, 1.3D0, 2.8D0, |
| 32306 | & 2.3D0, 1.6D0, .9D0, 13*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, |
| 32307 | & 2.D0, 1.7D0, 1.5D0,1.2D0,.9D0,.6D0,.45D0,.21D0,.2D0,3*0.D0,0.9D0, |
| 32308 | & 2.5D0, 3.D0, 2.5D0, 2.3D0,2.D0,1.7D0,1.5D0,1.2D0,.9D0,.6D0,.45D0, |
| 32309 | & .21D0, .2D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.D0,1.8D0,1.7D0,1.4D0, |
| 32310 | & 1.2D0,1.15D0,.9D0,.66D0,.5D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.1D0, |
| 32311 | & 1.8D0,1.7D0,1.4D0,1.2D0, 1.15D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0, |
| 32312 | & 2*1.D0, .9D0, .7D0, .4D0, .35D0, .2D0, 9*0.D0, .3D0, 2*1.D0,.9D0, |
| 32313 | & .7D0, .4D0, .35D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.4D0,3.5D0,4.25D0, |
| 32314 | & 4.55D0, 4.85D0, 4.9D0, 9*0.D0, .1D0, 1.D0, 2.4D0, 3.5D0, 4.25D0, |
| 32315 | & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, |
| 32316 | & 1.71D0, 1.6D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0, |
| 32317 | & 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0,4.4D0,4.D0,3.5D0,2.85D0, |
| 32318 | & 2.35D0, 2.01D0, 1.8D0, 6*0.D0, 1.4D0,3.8D0,5.D0,4.7D0,4.4D0,4.D0, |
| 32319 | & 3.5D0,2.85D0,2.35D0,2.01D0,1.8D0,12*0.D0,.1D0,.8D0,2.05D0,3.31D0, |
| 32320 | & 3.5D0, 12*0.D0, .034D0,.2D0,.75D0,1.04D0,1.24D0 / |
| 32321 | **** k- p data * |
| 32322 | DATA SKMPEL/ 0.D0, 35.D0, 22.D0, 25.D0, 17.D0, 9.D0, 9.5D0, 8.D0, |
| 32323 | & 7.D0, 6.5D0, 6.1D0, 5.D0, 4.8D0, 4.6D0, 4.45D0, 4.3D0, 4.2D0, |
| 32324 | & 0.D0, 8.D0, 3.5D0, 8.D0, 3.D0, 1.9D0, 1.7D0, 1.D0, .9D0, .8D0, |
| 32325 | & .75D0, .5D0, .42D0, .38D0, .34D0, .25D0, .2D0, |
| 32326 | & 0.D0, 3.D0, 3.2D0, 3.5D0, 1.5D0, 1.4D0, 1.1D0, .6D0, .5D0, |
| 32327 | & .35D0, .28D0, .25D0, .18D0, .12D0, .1D0, .08D0, .04D0, |
| 32328 | & 0.D0, 8.5D0, 2.4D0, 1.7D0, 1.3D0, 1.3D0, 1.1D0, .5D0, |
| 32329 | & .4D0, .4D0, .35D0, .3D0, .28D0, .2D0, .16D0, .13D0, .11D0, |
| 32330 | & 0.D0, 7.D0, 4.8D0, 1.4D0, 1.9D0, .9D0, .4D0, .2D0, .13D0, |
| 32331 | & .1D0, .08D0, .06D0, .04D0, .02D0, .015D0, .01D0, .01D0, |
| 32332 | & 0.D0, 5.5D0, 1.D0, .8D0, .75D0, .32D0, .2D0, .1D0, .09D0, |
| 32333 | & .08D0, .065D0, .05D0, .04D0, .022D0, .017D0, 2*.01D0/ |
| 32334 | DATA SPIKP7 / 0.D0, .56D0, 1.46D0, 3.16D0, 2.01D0, 1.28D0, .74D0, |
| 32335 | & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, |
| 32336 | & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 4*0.D0, |
| 32337 | & 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0, 1.57D0, |
| 32338 | & 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0, 3.03D0, |
| 32339 | & 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, |
| 32340 | & .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0, 2.8D0, |
| 32341 | & 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, |
| 32342 | & .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, |
| 32343 | & .45D0, .39D0, .22D0, .07D0, 0.D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, |
| 32344 | & 1.01D0, .78D0, .45D0, .39D0, .22D0, .07D0, 0.D0, 6*0.D0, 1.71D0, |
| 32345 | & 4.26D0, 5.6D0, 5.57D0, 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0, |
| 32346 | & 2.25D0, 2.D0, 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0, |
| 32347 | & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0, .22D0, |
| 32348 | & .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 10*0.D0, .22D0, .8D0, |
| 32349 | & .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0, .3D0, .7D0,1.D0, |
| 32350 | & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0, 1.72D0, 2.69D0, |
| 32351 | & 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 9*0.D0, .11D0, 1.72D0, |
| 32352 | & 2.69D0, 3.92D0, 4.76D0, 5.1D0, 5.44D0, 5.3D0, 5*0.D0,9.2D0,4.7D0, |
| 32353 | & 1.9D0, 10*0.D0, 2.5D0, 15.D0, 21.5D0, 15.3D0, 3.D0, 1.5D0, |
| 32354 | & 10*0.D0/ |
| 32355 | ***** k- n data * |
| 32356 | DATA SKMNEL/0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0, |
| 32357 | & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0, |
| 32358 | & 0.D0, 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0, |
| 32359 | & 1.9D0, .9D0, .5D0, .3D0, .24D0, .2D0, .18D0, .1D0, .09D0, |
| 32360 | & 0.D0, 1.8D0, 2.D0, 1.1D0, .9D0, .5D0, .5D0, .4D0, .4D0, |
| 32361 | & .2D0, .1D0, .06D0, .05D0, .04D0, .03D0, .02D0, .02D0, |
| 32362 | & 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0, .7D0, .65D0, |
| 32363 | & .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0, .03D0/ |
| 32364 | DATA SPIKP8/0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0, |
| 32365 | & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, |
| 32366 | & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, |
| 32367 | & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, |
| 32368 | & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0, |
| 32369 | & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, |
| 32370 | & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0, |
| 32371 | & 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, .45D0, |
| 32372 | & .39D0, .22D0, .07D0, 0.D0, |
| 32373 | & 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0, |
| 32374 | & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, |
| 32375 | & 10*0.D0, .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, |
| 32376 | & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, |
| 32377 | & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, |
| 32378 | & 9*0.D0, .11D0, 1.72D0, 2.69D0, 3.92D0, 4.76D0, |
| 32379 | & 5.10D0, 5.44D0, 5.3D0, |
| 32380 | & 4*0.D0, 0.00D0, 9.2D0, 4.7D0, 1.9D0, 9*0.D0/ |
| 32381 | ***** p p data * |
| 32382 | DATA SPIKP9/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0, |
| 32383 | & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0, |
| 32384 | & 0.D0, 3.6D0, 1.7D0, 10*0.D0, |
| 32385 | & .0D0, 0.D0, 8.7D0, 17.7D0, 18.8D0, 15.9D0, |
| 32386 | & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0, |
| 32387 | & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0, |
| 32388 | & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0, |
| 32389 | & 5*0.D0, 4.6D0, 10.2D0, 15.1D0, |
| 32390 | & 16.9D0, 16.5D0, 11.D0, 5.5D0, 3.5D0, |
| 32391 | & 10*0.D0, 4.3D0, 7.6D0, 9.D0, |
| 32392 | & 10*0.D0, 1.7D0, 2.6D0, 3.D0, |
| 32393 | & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0, |
| 32394 | & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0, |
| 32395 | & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0, |
| 32396 | & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/ |
| 32397 | ***** p n data * |
| 32398 | DATA SPIKP0/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0, |
| 32399 | & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0, |
| 32400 | & 0.D0, 1.8D0, .2D0, 12*0.D0, |
| 32401 | & 3.2D0, 6.05D0, 9.9D0, 5.1D0, |
| 32402 | & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0, |
| 32403 | & 2*.0D0, 3.2D0, 6.05D0, 9.9D0, 5.1D0, |
| 32404 | & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0, |
| 32405 | & 5*0.D0, 4.6D0, 10.2D0, 15.1D0, |
| 32406 | & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0, |
| 32407 | & 5*0.D0, 4.6D0, 10.2D0, 15.1D0, |
| 32408 | & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0, |
| 32409 | & 10*0.D0, .7D0, 5.1D0, 8.D0, |
| 32410 | & 10*0.D0, .7D0, 5.1D0, 8.D0, |
| 32411 | & 10*.0D0, .3D0, 2.8D0, 4.7D0, |
| 32412 | & 10*.0D0, .3D0, 2.8D0, 4.7D0, |
| 32413 | & 7*0.D0, 1.2D0, 2.5D0, 3.5D0, 6.D0, 5.3D0, 2.9D0, |
| 32414 | & 7*0.D0, 1.7D0, 3.6D0, 5.4D0, 9.D0, 7.6D0, 4.2D0, |
| 32415 | & 5*0.D0, 7.7D0, 6.1D0, 2.9D0, 5*0.D0/ |
| 32416 | * nn - data * |
| 32417 | * * |
| 32418 | DATA SPKPV/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0, |
| 32419 | & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0, |
| 32420 | & 0.D0, 3.6D0, 1.7D0, 12*0.D0, |
| 32421 | & 8.7D0, 17.7D0, 18.8D0, 15.9D0, |
| 32422 | & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0, |
| 32423 | & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0, |
| 32424 | & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0, |
| 32425 | & 5*0.D0, 4.6D0, 10.2D0, 15.1D0, 16.9D0, 16.5D0, |
| 32426 | & 11.D0, 5.5D0, 3.5D0, |
| 32427 | & 10*0.D0, 4.3D0, 7.6D0, 9.D0, |
| 32428 | & 10*0.D0, 1.7D0, 2.6D0, 3.D0, |
| 32429 | & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0, |
| 32430 | & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0, |
| 32431 | & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0, |
| 32432 | & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/ |
| 32433 | **************** ap - p - data * |
| 32434 | DATA SAPPEL/ 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, |
| 32435 | & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0, |
| 32436 | & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0, |
| 32437 | & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0, |
| 32438 | & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0, |
| 32439 | & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0, |
| 32440 | & 0.D0, 55.D0, 50.D0, 25.D0, 15.D0, 15.D0, 14.D0, 12.D0, |
| 32441 | & 10.D0, 7.D0, 6.D0, 4.D0, 3.3D0, 2.8D0, 2.4D0, 2.D0, 1.8D0, |
| 32442 | & 1.55D0, 1.3D0, .95D0, .75D0, |
| 32443 | & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, |
| 32444 | & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0, |
| 32445 | & .01D0, .008D0, .006D0, .005D0/ |
| 32446 | DATA SPIKPE/0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0, |
| 32447 | & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0, |
| 32448 | & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, |
| 32449 | & 9*0.D0, 2.D0, 2.5D0, .2D0, 19*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0, |
| 32450 | & 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0, .3D0, 1.4D0, |
| 32451 | & 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0, |
| 32452 | & .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, |
| 32453 | & .3D0, 10*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, |
| 32454 | & .6D0, .5D0, .4D0, .3D0, 9*0.D0, .6D0, 2.5D0, 5.D0, 5.2D0, 5.1D0, |
| 32455 | & 5.4D0, 5.8D0, 2.8D0, 2.1D0, 1.8D0, 1.6D0, 1.2D0, 13*0.D0, 1.3D0, |
| 32456 | & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0, |
| 32457 | & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0, |
| 32458 | & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0, |
| 32459 | & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 14*0.D0, .2D0, |
| 32460 | & .5D0, 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, |
| 32461 | & 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0, |
| 32462 | & 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0, 1.6D0, |
| 32463 | & 1.4D0, 1.1D0, .9D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0, |
| 32464 | & .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, |
| 32465 | & 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0 / |
| 32466 | **************** ap - n - data * |
| 32467 | DATA SAPNEL/ |
| 32468 | & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, |
| 32469 | & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0, |
| 32470 | & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0, |
| 32471 | & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, |
| 32472 | & .85D0, 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, |
| 32473 | & .14D0, .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0, |
| 32474 | & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, |
| 32475 | & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0, |
| 32476 | & .01D0, .008D0, .006D0, .005D0 / |
| 32477 | DATA SPIKPZ/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0, |
| 32478 | & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0, |
| 32479 | & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0, |
| 32480 | & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, |
| 32481 | & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, |
| 32482 | & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, |
| 32483 | & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, |
| 32484 | & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, |
| 32485 | & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0, |
| 32486 | & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0, |
| 32487 | & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0, |
| 32488 | & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, |
| 32489 | & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0, |
| 32490 | & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 / |
| 32491 | * * |
| 32492 | * * |
| 32493 | **************** an - p - data * |
| 32494 | * * |
| 32495 | DATA SANPEL/ |
| 32496 | & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, 50.D0, |
| 32497 | & 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0, |
| 32498 | & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0, .05D0, |
| 32499 | & .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0, |
| 32500 | & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0, |
| 32501 | & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0, |
| 32502 | & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, .25D0, |
| 32503 | & .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0, |
| 32504 | & .01D0, .008D0, .006D0, .005D0 / |
| 32505 | DATA SPIKPF/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0, |
| 32506 | & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0, |
| 32507 | & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0, |
| 32508 | & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, |
| 32509 | & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, |
| 32510 | & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, |
| 32511 | & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, |
| 32512 | & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, |
| 32513 | & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0, |
| 32514 | & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0, |
| 32515 | & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0, |
| 32516 | & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, |
| 32517 | & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0, |
| 32518 | & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 / |
| 32519 | **** ko - n - data * |
| 32520 | DATA SPKP15/0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0, 7.D0, |
| 32521 | & 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0, |
| 32522 | & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 10*0.D0, |
| 32523 | & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, |
| 32524 | & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0, |
| 32525 | & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, |
| 32526 | & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0, |
| 32527 | & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0, |
| 32528 | & 1.4D0, 1.2D0, 1.05D0, .9D0, .66D0, .5D0, |
| 32529 | & 7*0.D0, .3D0, 1.D0, 1.D0, .9D0, .7D0, .4D0, .30D0, .2D0, |
| 32530 | & 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.20D0, 4.55D0, |
| 32531 | & 4.85D0, 4.9D0, |
| 32532 | & 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0, 1.6D0, |
| 32533 | & 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0, 3.5D0, |
| 32534 | & 2.85D0, 2.35D0, 2.01D0, 1.8D0, |
| 32535 | & 12*0.D0, .1D0, .8D0, 2.05D0, 3.31D0, 3.5D0, |
| 32536 | & 12*0.D0, .034D0, .20D0, .75D0, 1.04D0, 1.24D0 / |
| 32537 | **** ako - p - data * |
| 32538 | DATA SPKP16/ 0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0, |
| 32539 | & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0, 0.D0, |
| 32540 | & 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0, 1.9D0, .9D0, .5D0, |
| 32541 | & .3D0, .24D0, .2D0, .18D0, .1D0, .09D0, 0.D0, 1.8D0, 2.D0, 1.1D0, |
| 32542 | & .9D0, .5D0, .5D0, .4D0, .4D0, .2D0, .1D0, .06D0, .05D0, .04D0, |
| 32543 | & .03D0, .02D0, .02D0, 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0, |
| 32544 | & .7D0, .65D0, .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0, |
| 32545 | & .03D0, 0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0, |
| 32546 | & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0, |
| 32547 | & 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0, |
| 32548 | & 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, |
| 32549 | & 1.01D0, .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0, |
| 32550 | & 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, |
| 32551 | & .5D0, .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, |
| 32552 | & .45D0, .39D0, .22D0, .07D0, 7*0.D0, 1.71D0, 4.26D0, 5.6D0,5.57D0, |
| 32553 | & 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0, |
| 32554 | & .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0, |
| 32555 | & .3D0, .7D0, 1.D0, 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0, |
| 32556 | & 1.72D0, 2.69D0, 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 5*0.D0, |
| 32557 | & 9.2D0, 4.7D0, 1.9D0, 9*0.D0, .0D0,2.5D0,15.D0, |
| 32558 | & 21.5D0, 15.3D0, 3.D0, 1.5D0, 10*0.D0 / |
| 32559 | DATA NURELN/9, 12, 5*0, 10, 14, 3*0, 1, 3, 5, 7, 6*0, 2, 6, 16, |
| 32560 | & 5*0, 10, 13, 5*0, 11, 12, 3*0, 2, 4, 6, 8, 6*0, 3, 15, 7, 5*0 / |
| 32561 | *= end*block.blkdt3 * |
| 32562 | END |
| 32563 | * |
| 32564 | *===qel_pol============================================================* |
| 32565 | * |
| 32566 | CDECK ID>, DT_QEL_POL |
| 32567 | SUBROUTINE DT_QEL_POL(ENU,LTYP,P21,P22,P23,P24,P25) |
| 32568 | |
| 32569 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 32570 | SAVE |
| 32571 | |
| 32572 | CALL DT_MASS_INI |
| 32573 | CALL DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25) |
| 32574 | |
| 32575 | RETURN |
| 32576 | END |
| 32577 | |
| 32578 | C================================================================== |
| 32579 | C Generation of a Quasi-Elastic neutrino scattering |
| 32580 | C================================================================== |
| 32581 | * |
| 32582 | *===gen_qel============================================================* |
| 32583 | * |
| 32584 | CDECK ID>, DT_GEN_QEL |
| 32585 | SUBROUTINE DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25) |
| 32586 | |
| 32587 | C...Generate a quasi-elastic neutrino/antineutrino |
| 32588 | C. Interaction on a nuclear target |
| 32589 | C. INPUT : LTYP = neutrino type (1,...,6) |
| 32590 | C. ENU (GeV) = neutrino energy |
| 32591 | C---------------------------------------------------- |
| 32592 | |
| 32593 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 32594 | SAVE |
| 32595 | |
| 32596 | PARAMETER ( LINP = 5 , |
| 32597 | & LOUT = 6 , |
| 32598 | & LDAT = 9 ) |
| 32599 | |
| 32600 | PARAMETER (MAXLND=4000) |
| 32601 | COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5) |
| 32602 | |
| 32603 | * nuclear potential |
| 32604 | LOGICAL LFERMI |
| 32605 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, |
| 32606 | & EBINDP(2),EBINDN(2),EPOT(2,210), |
| 32607 | & ETACOU(2),ICOUL,LFERMI |
| 32608 | * steering flags for qel neutrino scattering modules |
| 32609 | COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC |
| 32610 | **sr - removed (not needed) |
| 32611 | C COMMON /CBAD/ LBAD, NBAD |
| 32612 | C COMMON /CNUC/ XMN,XMN2,PFERMI,EFERMI,EBIND,EB2,C0 |
| 32613 | ** |
| 32614 | |
| 32615 | DIMENSION PI(3),PO(3) |
| 32616 | CJR+ |
| 32617 | DATA ININU/0/ |
| 32618 | CJR- |
| 32619 | C REAL*8 DBETA(3) |
| 32620 | C REAL*8 MN(2), ML0(6), ML, ML2, MI, MI2, MF, MF2 |
| 32621 | DIMENSION DBETA(3),DBETB(3),AMN(2),AML0(6) |
| 32622 | DATA AMN /0.93827231D0, 0.93956563D0/ |
| 32623 | DATA AML0 /2*0.51100D-03,2*0.105659D0, 2*1.777D0/ |
| 32624 | DATA INIPRI/0/ |
| 32625 | |
| 32626 | C DATA PFERMI/0.22D0/ |
| 32627 | CGB+...Binding Energy |
| 32628 | DATA EBIND/0.008D0/ |
| 32629 | CGB-... |
| 32630 | |
| 32631 | ININU=ININU+1 |
| 32632 | IF(ININU.EQ.1)NDSIG=0 |
| 32633 | LBAD = 0 |
| 32634 | enu0=enu |
| 32635 | c write(*,*) enu0 |
| 32636 | C...Lepton mass |
| 32637 | AML = AML0(LTYP) ! massa leptoni |
| 32638 | AML2 = AML**2 ! massa leptoni **2 |
| 32639 | C...Particle labels (LUND) |
| 32640 | N = 5 |
| 32641 | K(1,1) = 21 |
| 32642 | K(2,1) = 21 |
| 32643 | K(3,1) = 21 |
| 32644 | K(3,3) = 1 |
| 32645 | K(4,1) = 1 |
| 32646 | K(4,3) = 1 |
| 32647 | K(5,1) = 1 |
| 32648 | K(5,3) = 2 |
| 32649 | K0 = (LTYP-1)/2 ! 2 |
| 32650 | K1 = LTYP/2 ! 2 |
| 32651 | KA = 12 + 2*K0 ! 16 |
| 32652 | IS = -1 + 2*LTYP - 4*K1 ! -1 +10 -8 = 1 |
| 32653 | K(1,2) = IS*KA |
| 32654 | K(4,2) = IS*(KA-1) |
| 32655 | K(3,2) = IS*24 |
| 32656 | LNU = 2 - LTYP + 2*K1 ! 2 - 5 + 2 = - 1 |
| 32657 | IF (LNU .EQ. 2) THEN |
| 32658 | K(2,2) = 2212 |
| 32659 | K(5,2) = 2112 |
| 32660 | AMI = AMN(1) |
| 32661 | AMF = AMN(2) |
| 32662 | CJR+ |
| 32663 | PFERMI=PFERMN(2) |
| 32664 | CJR- |
| 32665 | ELSE |
| 32666 | K(2,2) = 2112 |
| 32667 | K(5,2) = 2212 |
| 32668 | AMI = AMN(2) |
| 32669 | AMF = AMN(1) |
| 32670 | CJR+ |
| 32671 | PFERMI=PFERMP(2) |
| 32672 | CJR- |
| 32673 | ENDIF |
| 32674 | AMI2 = AMI**2 |
| 32675 | AMF2 = AMF**2 |
| 32676 | |
| 32677 | DO IGB=1,5 |
| 32678 | P(3,IGB) = 0. |
| 32679 | P(4,IGB) = 0. |
| 32680 | P(5,IGB) = 0. |
| 32681 | END DO |
| 32682 | |
| 32683 | NTRY = 0 |
| 32684 | CGB+... |
| 32685 | EFMAX = SQRT(PFERMI**2 + AMI2) -AMI ! max. Fermi Energy |
| 32686 | ENWELL = EFMAX + EBIND ! depth of nuclear potential well |
| 32687 | CGB-... |
| 32688 | |
| 32689 | 100 CONTINUE |
| 32690 | |
| 32691 | C...4-momentum initial lepton |
| 32692 | P(1,5) = 0. ! massa |
| 32693 | P(1,4) = ENU0 ! energia |
| 32694 | P(1,1) = 0. ! px |
| 32695 | P(1,2) = 0. ! py |
| 32696 | P(1,3) = ENU0 ! pz |
| 32697 | |
| 32698 | C PF = PFERMI*PYR(0)**(1./3.) |
| 32699 | c write(23,*) PYR(0) |
| 32700 | c write(*,*) 'Pfermi=',PF |
| 32701 | c PF = 0. |
| 32702 | NTRY=NTRY+1 |
| 32703 | C IF(ntry.GT.2) WRITE(*,*) ntry,enu0,k2 |
| 32704 | IF (NTRY .GT. 500) THEN |
| 32705 | LBAD = 1 |
| 32706 | WRITE (LOUT,1001) NBAD, ENU |
| 32707 | RETURN |
| 32708 | ENDIF |
| 32709 | C CT = -1. + 2.*PYR(0) |
| 32710 | c CT = -1. |
| 32711 | C ST = SQRT(1.-CT*CT) |
| 32712 | C F = 2.*3.1415926*PYR(0) |
| 32713 | c F = 0. |
| 32714 | |
| 32715 | C P(2,4) = SQRT(PF*PF + MI2) - EBIND ! energia |
| 32716 | C P(2,1) = PF*ST*COS(F) ! px |
| 32717 | C P(2,2) = PF*ST*SIN(F) ! py |
| 32718 | C P(2,3) = PF*CT ! pz |
| 32719 | C P(2,5) = SQRT(P(2,4)**2-PF*PF) ! massa |
| 32720 | P(2,1) = P21 |
| 32721 | P(2,2) = P22 |
| 32722 | P(2,3) = P23 |
| 32723 | P(2,4) = P24 |
| 32724 | P(2,5) = P25 |
| 32725 | beta1=-p(2,1)/p(2,4) |
| 32726 | beta2=-p(2,2)/p(2,4) |
| 32727 | beta3=-p(2,3)/p(2,4) |
| 32728 | N=2 |
| 32729 | C WRITE(6,*)' before transforming into target rest frame' |
| 32730 | |
| 32731 | CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3) |
| 32732 | |
| 32733 | C print*,' nucl. rest fram ( fermi incl.) prima della rotazione' |
| 32734 | N=5 |
| 32735 | |
| 32736 | phi11=atan(p(1,2)/p(1,3)) |
| 32737 | pi(1)=p(1,1) |
| 32738 | pi(2)=p(1,2) |
| 32739 | pi(3)=p(1,3) |
| 32740 | |
| 32741 | CALL DT_TESTROT(PI,Po,PHI11,1) |
| 32742 | DO ll=1,3 |
| 32743 | IF(abs(po(ll)).LT.1.D-07) po(ll)=0. |
| 32744 | END DO |
| 32745 | c WRITE(*,*) po |
| 32746 | p(1,1)=po(1) |
| 32747 | p(1,2)=po(2) |
| 32748 | p(1,3)=po(3) |
| 32749 | phi12=atan(p(1,1)/p(1,3)) |
| 32750 | |
| 32751 | pi(1)=p(1,1) |
| 32752 | pi(2)=p(1,2) |
| 32753 | pi(3)=p(1,3) |
| 32754 | CALL DT_TESTROT(Pi,Po,PHI12,2) |
| 32755 | DO ll=1,3 |
| 32756 | IF(abs(po(ll)).LT.1.D-07) po(ll)=0. |
| 32757 | END DO |
| 32758 | c WRITE(*,*) po |
| 32759 | p(1,1)=po(1) |
| 32760 | p(1,2)=po(2) |
| 32761 | p(1,3)=po(3) |
| 32762 | |
| 32763 | enu=p(1,4) |
| 32764 | |
| 32765 | C...Kinematical limits in Q**2 |
| 32766 | c S = P(2,5)**2 + 2.*ENU*(P(2,4)-P(2,3)) ! ???? |
| 32767 | S = P(2,5)**2 + 2.*ENU*P(2,5) |
| 32768 | SQS = SQRT(S) ! E centro massa |
| 32769 | IF (SQS .LT. (AML + AMF + 3.E-03)) GOTO 100 |
| 32770 | ELF = (S-AMF2+AML2)/(2.*SQS) ! energia leptone finale p |
| 32771 | PSTAR = (S-P(2,5)**2)/(2.*SQS) ! p* neutrino nel c.m. |
| 32772 | PLF = SQRT(ELF**2-AML2) ! 3-momento leptone finale |
| 32773 | Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF) ! + o - |
| 32774 | Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF) ! according con cos(theta) |
| 32775 | IF (Q2MIN .LT. 0.) Q2MIN = 0. ! ??? non fisico |
| 32776 | |
| 32777 | C...Generate Q**2 |
| 32778 | DSIGMAX = DT_DSQEL_Q2 (LTYP,ENU, Q2MIN) |
| 32779 | 200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0) |
| 32780 | DSIG = DT_DSQEL_Q2 (LTYP,ENU, Q2) |
| 32781 | IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200 |
| 32782 | CALL DT_QGAUS(Q2MIN,Q2MAX,DSIGEV,ENU,LTYP) |
| 32783 | NDSIG=NDSIG+1 |
| 32784 | C WRITE(6,*)' Q2,Q2min,Q2MAX,DSIGEV', |
| 32785 | C &Q2,Q2min,Q2MAX,DSIGEV |
| 32786 | |
| 32787 | C...c.m. frame. Neutrino along z axis |
| 32788 | DETOT = (P(1,4)) + (P(2,4)) ! e totale |
| 32789 | DBETA(1) = ((P(1,1)) + (P(2,1)))/DETOT ! px1+px2/etot = beta_x |
| 32790 | DBETA(2) = ((P(1,2)) + (P(2,2)))/DETOT ! |
| 32791 | DBETA(3) = ((P(1,3)) + (P(2,3)))/DETOT ! |
| 32792 | c WRITE(*,*) |
| 32793 | c WRITE(*,*) |
| 32794 | C WRITE(*,*) 'Input values laboratory frame' |
| 32795 | N=2 |
| 32796 | |
| 32797 | CALL PYROBO(0,0,0.0D0,0.0D0,-DBETA(1),-DBETA(2),-DBETA(3)) |
| 32798 | |
| 32799 | N=5 |
| 32800 | c STHETA = ULANGL(P(1,3),P(1,1)) |
| 32801 | c write(*,*) 'stheta' ,stheta |
| 32802 | c stheta=0. |
| 32803 | c CALL PYROBO (0,0,-STHETA,0.,0.D0,0.D0,0.D0) |
| 32804 | c WRITE(*,*) |
| 32805 | c WRITE(*,*) |
| 32806 | C WRITE(*,*) 'Output values cm frame' |
| 32807 | C...Kinematic in c.m. frame |
| 32808 | CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF) ! cos(theta) cm |
| 32809 | STSTAR = SQRT(1.-CTSTAR**2) |
| 32810 | PHI = 6.28319*PYR(0) ! random phi tra 0 e 2*pi |
| 32811 | P(4,5) = AML ! massa leptone |
| 32812 | P(4,4) = ELF ! e leptone |
| 32813 | P(4,3) = PLF*CTSTAR ! px |
| 32814 | P(4,1) = PLF*STSTAR*COS(PHI) ! py |
| 32815 | P(4,2) = PLF*STSTAR*SIN(PHI) ! pz |
| 32816 | |
| 32817 | P(5,5) = AMF ! barione |
| 32818 | P(5,4) = (S+AMF2-AML2)/(2.*SQS)! e barione |
| 32819 | P(5,3) = -P(4,3) ! px |
| 32820 | P(5,1) = -P(4,1) ! py |
| 32821 | P(5,2) = -P(4,2) ! pz |
| 32822 | |
| 32823 | P(3,5) = -Q2 |
| 32824 | P(3,1) = P(1,1)-P(4,1) |
| 32825 | P(3,2) = P(1,2)-P(4,2) |
| 32826 | P(3,3) = P(1,3)-P(4,3) |
| 32827 | P(3,4) = P(1,4)-P(4,4) |
| 32828 | |
| 32829 | C...Transform back to laboratory frame |
| 32830 | C WRITE(*,*) 'before going back to nucl rest frame' |
| 32831 | c CALL PYROBO (0,0,STHETA,0.,0.D0,0.D0,0.D0) |
| 32832 | N=5 |
| 32833 | |
| 32834 | CALL PYROBO(0,0,0.0D0,0.0D0,DBETA(1),DBETA(2),DBETA(3)) |
| 32835 | |
| 32836 | C WRITE(*,*) 'Now back in nucl rest frame' |
| 32837 | IF(LTYP.GE.3) CALL DT_PREPOLA(Q2,LTYP,ENU) |
| 32838 | |
| 32839 | c******************************************** |
| 32840 | |
| 32841 | DO kw=1,5 |
| 32842 | pi(1)=p(kw,1) |
| 32843 | pi(2)=p(kw,2) |
| 32844 | pi(3)=p(kw,3) |
| 32845 | CALL DT_TESTROT(Pi,Po,PHI12,3) |
| 32846 | DO ll=1,3 |
| 32847 | IF(abs(po(ll)).LT.1.D-07) po(ll)=0. |
| 32848 | END DO |
| 32849 | p(kw,1)=po(1) |
| 32850 | p(kw,2)=po(2) |
| 32851 | p(kw,3)=po(3) |
| 32852 | END DO |
| 32853 | c******************************************** |
| 32854 | |
| 32855 | DO kw=1,5 |
| 32856 | pi(1)=p(kw,1) |
| 32857 | pi(2)=p(kw,2) |
| 32858 | pi(3)=p(kw,3) |
| 32859 | CALL DT_TESTROT(Pi,Po,PHI11,4) |
| 32860 | DO ll=1,3 |
| 32861 | IF(abs(po(ll)).LT.1.D-07) po(ll)=0. |
| 32862 | END DO |
| 32863 | p(kw,1)=po(1) |
| 32864 | p(kw,2)=po(2) |
| 32865 | p(kw,3)=po(3) |
| 32866 | END DO |
| 32867 | |
| 32868 | c******************************************** |
| 32869 | |
| 32870 | C WRITE(*,*) 'Now back in lab frame' |
| 32871 | |
| 32872 | CALL PYROBO(1,5,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3) |
| 32873 | |
| 32874 | CGB+... |
| 32875 | C...test (on final momentum of nucleon) if Fermi-blocking |
| 32876 | C...is operating |
| 32877 | ENUCL = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2 + P(5,5)**2) |
| 32878 | & - P(5,5) |
| 32879 | IF (ENUCL.LT. EFMAX) THEN |
| 32880 | IF(INIPRI.LT.10)THEN |
| 32881 | INIPRI=INIPRI+1 |
| 32882 | C WRITE(6,*)' qel: Pauli ENUCL.LT.EFMAX ', ENUCL,EFMAX |
| 32883 | C...the interaction is not possible due to Pauli-Blocking and |
| 32884 | C...it must be resampled |
| 32885 | ENDIF |
| 32886 | GOTO 100 |
| 32887 | ELSE IF (ENUCL.LT.ENWELL.and.ENUCL.GE.EFMAX) THEN |
| 32888 | IF(INIPRI.LT.10)THEN |
| 32889 | INIPRI=INIPRI+1 |
| 32890 | C WRITE(6,*)' qel: inside ENUCL.LT.ENWELL ', ENUCL,ENWELL |
| 32891 | ENDIF |
| 32892 | C Reject (J:R) here all these events |
| 32893 | C are otherwise rejected in dpmjet |
| 32894 | GOTO 100 |
| 32895 | C...the interaction is possible, but the nucleon remains inside |
| 32896 | C...the nucleus. The nucleus is therefore left excited. |
| 32897 | C...We treat this case as a nucleon with 0 kinetic energy. |
| 32898 | C P(5,5) = AMF |
| 32899 | C P(5,4) = AMF |
| 32900 | C P(5,1) = 0. |
| 32901 | C P(5,2) = 0. |
| 32902 | C P(5,3) = 0. |
| 32903 | ELSE IF (ENUCL.GE.ENWELL) THEN |
| 32904 | C WRITE(6,*)' qel ENUCL.GE.ENWELL ',ENUCL,ENWELL |
| 32905 | C...the interaction is possible, the nucleon can exit the nucleus |
| 32906 | C...but the nuclear well depth must be subtracted. The nucleus could be |
| 32907 | C...left in an excited state. |
| 32908 | Pstart = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2) |
| 32909 | C P(5,4) = ENUCL-ENWELL + AMF |
| 32910 | Pnucl = SQRT(P(5,4)**2-AMF**2) |
| 32911 | C...The 3-momentum is scaled assuming that the direction remains |
| 32912 | C...unaffected |
| 32913 | P(5,1) = P(5,1) * Pnucl/Pstart |
| 32914 | P(5,2) = P(5,2) * Pnucl/Pstart |
| 32915 | P(5,3) = P(5,3) * Pnucl/Pstart |
| 32916 | C WRITE(6,*)' qel new P(5,4) ',P(5,4) |
| 32917 | ENDIF |
| 32918 | CGB-... |
| 32919 | DSIGSU=DSIGSU+DSIGEV |
| 32920 | |
| 32921 | GA=P(4,4)/P(4,5) |
| 32922 | BGX=P(4,1)/P(4,5) |
| 32923 | BGY=P(4,2)/P(4,5) |
| 32924 | BGZ=P(4,3)/P(4,5) |
| 32925 | * |
| 32926 | DBETB(1)=BGX/GA |
| 32927 | DBETB(2)=BGY/GA |
| 32928 | DBETB(3)=BGZ/GA |
| 32929 | IF(NEUDEC.EQ.1.OR.NEUDEC.EQ.2) THEN |
| 32930 | |
| 32931 | CALL PYROBO(6,8,0.0D0,0.0D0,DBETB(1),DBETB(2),DBETB(3)) |
| 32932 | |
| 32933 | ENDIF |
| 32934 | c |
| 32935 | C PRINT*,' FINE EVENTO ' |
| 32936 | enu=enu0 |
| 32937 | RETURN |
| 32938 | |
| 32939 | 1001 FORMAT(2X, 'DT_GEN_QEL : event rejected ', I5, G10.3) |
| 32940 | END |
| 32941 | |
| 32942 | C==================================================================== |
| 32943 | C. Masses |
| 32944 | C==================================================================== |
| 32945 | |
| 32946 | * |
| 32947 | *===mass_ini===========================================================* |
| 32948 | * |
| 32949 | CDECK ID>, DT_MASS_INI |
| 32950 | SUBROUTINE DT_MASS_INI |
| 32951 | C...Initialize the kinematics for the quasi-elastic cross section |
| 32952 | |
| 32953 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 32954 | SAVE |
| 32955 | |
| 32956 | * particle masses used in qel neutrino scattering modules |
| 32957 | COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6), |
| 32958 | & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN, |
| 32959 | & EMPROTSQ,EMNEUTSQ,EMNSQ |
| 32960 | |
| 32961 | EML(1) = 0.51100D-03 ! e- |
| 32962 | EML(2) = EML(1) ! e+ |
| 32963 | EML(3) = 0.105659D0 ! mu- |
| 32964 | EML(4) = EML(3) ! mu+ |
| 32965 | EML(5) = 1.7777D0 ! tau- |
| 32966 | EML(6) = EML(5) ! tau+ |
| 32967 | EMPROT = 0.93827231D0 ! p |
| 32968 | EMNEUT = 0.93956563D0 ! n |
| 32969 | EMPROTSQ = EMPROT**2 |
| 32970 | EMNEUTSQ = EMNEUT**2 |
| 32971 | EMN = (EMPROT + EMNEUT)/2. |
| 32972 | EMNSQ = EMN**2 |
| 32973 | DO J=1,3 |
| 32974 | J0 = 2*(J-1) |
| 32975 | EMN1(J0+1) = EMNEUT |
| 32976 | EMN1(J0+2) = EMPROT |
| 32977 | EMN2(J0+1) = EMPROT |
| 32978 | EMN2(J0+2) = EMNEUT |
| 32979 | ENDDO |
| 32980 | DO J=1,6 |
| 32981 | EMLSQ(J) = EML(J)**2 |
| 32982 | ETQE(J) = ((EMN2(J)+ EML(J))**2-EMN1(J)**2)/(2.*EMN1(J)) |
| 32983 | ENDDO |
| 32984 | RETURN |
| 32985 | END |
| 32986 | * |
| 32987 | *===dsqel_q2===========================================================* |
| 32988 | * |
| 32989 | CDECK ID>, DT_DSQEL_Q2 |
| 32990 | DOUBLE PRECISION FUNCTION DT_DSQEL_Q2 (JTYP,ENU, Q2) |
| 32991 | |
| 32992 | C...differential cross section for Quasi-Elastic scattering |
| 32993 | C. nu + N -> l + N' |
| 32994 | C. From Llewellin Smith Phys.Rep. 3C, 261, (1971). |
| 32995 | C. |
| 32996 | C. INPUT : JTYP = 1,...,6 nu_e, ...., nubar_tau |
| 32997 | C. ENU (GeV) = Neutrino energy |
| 32998 | C. Q2 (GeV**2) = (Transfer momentum)**2 |
| 32999 | C. |
| 33000 | C. OUTPUT : DSQEL_Q2 = differential cross section : |
| 33001 | C. dsigma/dq**2 (10**-38 cm+2/GeV**2) |
| 33002 | C------------------------------------------------------------------ |
| 33003 | |
| 33004 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 33005 | SAVE |
| 33006 | |
| 33007 | * particle masses used in qel neutrino scattering modules |
| 33008 | COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6), |
| 33009 | & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN, |
| 33010 | & EMPROTSQ,EMNEUTSQ,EMNSQ |
| 33011 | **sr - removed (not needed) |
| 33012 | C COMMON /CAXIAL/ FA0, AXIAL2 |
| 33013 | ** |
| 33014 | |
| 33015 | DIMENSION SS(6) |
| 33016 | DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2 |
| 33017 | DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/ |
| 33018 | DATA AXIAL2 /1.03D0/ ! to be checked |
| 33019 | |
| 33020 | FA0=-1.253D0 |
| 33021 | CSI = 3.71D0 ! ??? |
| 33022 | GVE = 1.D0/ (1.D0 + Q2/0.84D0**2)**2 ! G_e(q**2) |
| 33023 | GVM = (1.D0+CSI)*GVE ! G_m (q**2) |
| 33024 | X = Q2/(EMN*EMN) ! emn=massa barione |
| 33025 | XA = X/4.D0 |
| 33026 | FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM) |
| 33027 | FV2 = 1.D0/(1.D0+XA)*(GVM-GVE) |
| 33028 | FA = FA0/(1.D0 + Q2/AXIAL2)**2 |
| 33029 | FFA = FA*FA |
| 33030 | FFV1 = FV1*FV1 |
| 33031 | FFV2 = FV2*FV2 |
| 33032 | RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp) |
| 33033 | A1 = (4.D0+X)*FFA - (4.D0-X)*FFV1 + X*FFV2*(1.D0-XA)+4*X*FV1*FV2 |
| 33034 | A2 = -RM * ((FV1 + FV2)**2 + FFA) |
| 33035 | AA = (XA+0.25D0*RM)*(A1 + A2) |
| 33036 | BB = -X*FA*(FV1 + FV2) |
| 33037 | CC = 0.25D0*(FFA + FFV1 + XA*FFV2) |
| 33038 | SU = (4.D0*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN) |
| 33039 | DT_DSQEL_Q2 = C0*(AA + SS(JTYP)*BB*SU + CC*SU*SU) / (ENU*ENU) ! |
| 33040 | IF(DT_DSQEL_Q2 .LT. 0.D0) DT_DSQEL_Q2 = 0.D0 |
| 33041 | |
| 33042 | RETURN |
| 33043 | END |
| 33044 | * |
| 33045 | *===prepola============================================================* |
| 33046 | * |
| 33047 | CDECK ID>, DT_PREPOLA |
| 33048 | SUBROUTINE DT_PREPOLA(Q2,JTYP,ENU) |
| 33049 | |
| 33050 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 33051 | SAVE |
| 33052 | c |
| 33053 | c By G. Battistoni and E. Scapparone (sept. 1997) |
| 33054 | c According to: |
| 33055 | c Albright & Jarlskog, Nucl Phys B84 (1975) 467 |
| 33056 | c |
| 33057 | c |
| 33058 | |
| 33059 | PARAMETER (MAXLND=4000) |
| 33060 | COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5) |
| 33061 | |
| 33062 | COMMON /QNPOL/ POLARX(4),PMODUL |
| 33063 | * particle masses used in qel neutrino scattering modules |
| 33064 | COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6), |
| 33065 | & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN, |
| 33066 | & EMPROTSQ,EMNEUTSQ,EMNSQ |
| 33067 | * steering flags for qel neutrino scattering modules |
| 33068 | COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC |
| 33069 | **sr - removed (not needed) |
| 33070 | C COMMON /CAXIAL/ FA0, AXIAL2 |
| 33071 | C COMMON /TAUTAU/Q(4,5),ETL,PXL,PYL,PZL, |
| 33072 | C & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN |
| 33073 | ** |
| 33074 | REAL*8 POL(4,4),BB2(3) |
| 33075 | DIMENSION SS(6) |
| 33076 | C DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2 |
| 33077 | DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/ |
| 33078 | **sr uncommented since common block CAXIAL is now commented |
| 33079 | DATA AXIAL2 /1.03D0/ ! to be checked |
| 33080 | ** |
| 33081 | |
| 33082 | RML=P(4,5) |
| 33083 | RMM=0.93960D+00 |
| 33084 | FM2 = RMM**2 |
| 33085 | MPI = 0.135D+00 |
| 33086 | OLDQ2=Q2 |
| 33087 | FA0=-1.253D+00 |
| 33088 | CSI = 3.71D+00 ! |
| 33089 | GVE = 1.D0/ (1.D0 + Q2/(0.84D+00)**2)**2 ! G_e(q**2) |
| 33090 | GVM = (1.D0+CSI)*GVE ! G_m (q**2) |
| 33091 | X = Q2/(EMN*EMN) ! emn=massa barione |
| 33092 | XA = X/4.D0 |
| 33093 | FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM) |
| 33094 | FV2 = 1.D0/(1.D0+XA)*(GVM-GVE) |
| 33095 | FA = FA0/(1.D0 + Q2/AXIAL2**2)**2 |
| 33096 | FFA = FA*FA |
| 33097 | FFV1 = FV1*FV1 |
| 33098 | FFV2 = FV2*FV2 |
| 33099 | FP=2.D0*FA*RMM/(MPI**2 + Q2) |
| 33100 | RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp) |
| 33101 | A1 = (4.D0+X)*FFA-(4.D0-X)*FFV1+X*FFV2*(1.D0-XA)+4.D0*X*FV1*FV2 |
| 33102 | A2 = -RM * ((FV1 + FV2)**2 + FFA) |
| 33103 | AA = (XA+0.25D+00*RM)*(A1 + A2) |
| 33104 | BB = -X*FA*(FV1 + FV2) |
| 33105 | CC = 0.25D+00*(FFA + FFV1 + XA*FFV2) |
| 33106 | SU = (4.D+00*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN) |
| 33107 | |
| 33108 | OMEGA1=FFA+XA*(FFA+(FV1+FV2)**2 ) ! articolo di ll...-smith |
| 33109 | OMEGA2=4.D+00*CC |
| 33110 | OMEGA3=2.D+00*FA*(FV1+FV2) |
| 33111 | OMEGA4P=(-(FV1+FV2)**2-(FA+2*FP)**2+(4.0D+00+ |
| 33112 | 1 (Q2/FM2))*FP**2) |
| 33113 | OMEGA5=OMEGA2 |
| 33114 | OMEGA4=(OMEGA4P-OMEGA2+2*OMEGA5)/4.D+00 |
| 33115 | WW1=2.D+00*OMEGA1*EMN**2 |
| 33116 | WW2=2.D+00*OMEGA2*EMN**2 |
| 33117 | WW3=2.D+00*OMEGA3*EMN**2 |
| 33118 | WW4=2.D+00*OMEGA4*EMN**2 |
| 33119 | WW5=2.D+00*OMEGA5*EMN**2 |
| 33120 | |
| 33121 | DO I=1,3 |
| 33122 | BB2(I)=-P(4,I)/P(4,4) |
| 33123 | END DO |
| 33124 | c WRITE(*,*) |
| 33125 | c WRITE(*,*) |
| 33126 | c WRITE(*,*) 'Prepola: ready to transform to lepton rest frame' |
| 33127 | N=5 |
| 33128 | |
| 33129 | CALL PYROBO(0,0,0.0D0,0.0D0,BB2(1),BB2(2),BB2(3)) |
| 33130 | |
| 33131 | * NOW PARTICLES ARE IN THE SCATTERED LEPTON REST FRAME |
| 33132 | c WRITE(*,*) |
| 33133 | c WRITE(*,*) |
| 33134 | c WRITE(*,*) 'Prepola: now in lepton rest frame' |
| 33135 | EE=ENU |
| 33136 | QM2=Q2+RML**2 |
| 33137 | U=Q2/(2.*RMM) |
| 33138 | FRAC=QM2*WW1 + (2.D+00*EE*(EE-U) - 0.5D+00*QM2)*WW2 - SS(JTYP)* |
| 33139 | + (0.5D+00/(RMM**2))*(2.D+00*RMM*EE*Q2 - U*QM2)*WW3 + |
| 33140 | + ((RML**2)/(2.D+00*FM2))*(QM2*WW4-2.D+00*RMM*EE*WW5) !<=FM2 inv di RMM!! |
| 33141 | |
| 33142 | FACTK=2.D+00*WW1 -WW2 -SS(JTYP)*(EE/RMM)*WW3 +((EE-U)/RMM)*WW5 |
| 33143 | + - ((RML**2)/FM2)*WW4 !<=FM2 inv di RMM!! |
| 33144 | |
| 33145 | FACTP=2.D+00*EE/RMM*WW2 - (QM2/(2.D+00*RMM**2))*(SS(JTYP)*WW3+WW5) |
| 33146 | |
| 33147 | DO I=1,3 |
| 33148 | POL(4,I)=RML*SS(JTYP)*(FACTK*P(1,I)+FACTP*P(2,I))/FRAC |
| 33149 | POLARX(I)=POL(4,I) |
| 33150 | END DO |
| 33151 | |
| 33152 | PMODUL=0.D0 |
| 33153 | DO I=1,3 |
| 33154 | PMODUL=PMODUL+POL(4,I)**2 |
| 33155 | END DO |
| 33156 | |
| 33157 | IF(JTYP.GT.4.AND.NEUDEC.GT.0) THEN |
| 33158 | IF(NEUDEC.EQ.1) THEN |
| 33159 | CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-2),POLARX(3), |
| 33160 | + ETL,PXL,PYL,PZL, |
| 33161 | + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN) |
| 33162 | c |
| 33163 | c Tau has decayed in muon |
| 33164 | c |
| 33165 | ENDIF |
| 33166 | IF(NEUDEC.EQ.2) THEN |
| 33167 | CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-4),POLARX(3), |
| 33168 | + ETL,PXL,PYL,PZL, |
| 33169 | + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN) |
| 33170 | c |
| 33171 | c Tau has decayed in electron |
| 33172 | c |
| 33173 | ENDIF |
| 33174 | K(4,1)=15 |
| 33175 | K(4,4) = 6 |
| 33176 | K(4,5) = 8 |
| 33177 | N=N+3 |
| 33178 | c |
| 33179 | c fill common for muon(electron) |
| 33180 | c |
| 33181 | P(6,1)=PXL |
| 33182 | P(6,2)=PYL |
| 33183 | P(6,3)=PZL |
| 33184 | P(6,4)=ETL |
| 33185 | K(6,1)=1 |
| 33186 | IF(JTYP.EQ.5) THEN |
| 33187 | IF(NEUDEC.EQ.1) THEN |
| 33188 | P(6,5)=EML(JTYP-2) |
| 33189 | K(6,2)=13 |
| 33190 | ELSEIF(NEUDEC.EQ.2) THEN |
| 33191 | P(6,5)=EML(JTYP-4) |
| 33192 | K(6,2)=11 |
| 33193 | ENDIF |
| 33194 | ELSEIF(JTYP.EQ.6) THEN |
| 33195 | IF(NEUDEC.EQ.1) THEN |
| 33196 | K(6,2)=-13 |
| 33197 | ELSEIF(NEUDEC.EQ.2) THEN |
| 33198 | K(6,2)=-11 |
| 33199 | ENDIF |
| 33200 | END IF |
| 33201 | K(6,3)=4 |
| 33202 | K(6,4)=0 |
| 33203 | K(6,5)=0 |
| 33204 | c |
| 33205 | c fill common for tau_(anti)neutrino |
| 33206 | c |
| 33207 | P(7,1)=PXB |
| 33208 | P(7,2)=PYB |
| 33209 | P(7,3)=PZB |
| 33210 | P(7,4)=ETB |
| 33211 | P(7,5)=0. |
| 33212 | K(7,1)=1 |
| 33213 | IF(JTYP.EQ.5) THEN |
| 33214 | K(7,2)=16 |
| 33215 | ELSEIF(JTYP.EQ.6) THEN |
| 33216 | K(7,2)=-16 |
| 33217 | END IF |
| 33218 | K(7,3)=4 |
| 33219 | K(7,4)=0 |
| 33220 | K(7,5)=0 |
| 33221 | c |
| 33222 | c Fill common for muon(electron)_(anti)neutrino |
| 33223 | c |
| 33224 | P(8,1)=PXN |
| 33225 | P(8,2)=PYN |
| 33226 | P(8,3)=PZN |
| 33227 | P(8,4)=ETN |
| 33228 | P(8,5)=0. |
| 33229 | K(8,1)=1 |
| 33230 | IF(JTYP.EQ.5) THEN |
| 33231 | IF(NEUDEC.EQ.1) THEN |
| 33232 | K(8,2)=-14 |
| 33233 | ELSEIF(NEUDEC.EQ.2) THEN |
| 33234 | K(8,2)=-12 |
| 33235 | ENDIF |
| 33236 | ELSEIF(JTYP.EQ.6) THEN |
| 33237 | IF(NEUDEC.EQ.1) THEN |
| 33238 | K(8,2)=14 |
| 33239 | ELSEIF(NEUDEC.EQ.2) THEN |
| 33240 | K(8,2)=12 |
| 33241 | ENDIF |
| 33242 | END IF |
| 33243 | K(8,3)=4 |
| 33244 | K(8,4)=0 |
| 33245 | K(8,5)=0 |
| 33246 | ENDIF |
| 33247 | c WRITE(*,*) |
| 33248 | c WRITE(*,*) |
| 33249 | |
| 33250 | c IF(PMODUL.GE.1.D+00) THEN |
| 33251 | c WRITE(*,*) 'Pol',(POLARX(I),I=1,3) |
| 33252 | c write(*,*) pmodul |
| 33253 | c DO I=1,3 |
| 33254 | c POL(4,I)=POL(4,I)/PMODUL |
| 33255 | c POLARX(I)=POL(4,I) |
| 33256 | c END DO |
| 33257 | c PMODUL=0. |
| 33258 | c DO I=1,3 |
| 33259 | c PMODUL=PMODUL+POL(4,I)**2 |
| 33260 | c END DO |
| 33261 | c WRITE(*,*) 'Pol',(POLARX(I),I=1,3) |
| 33262 | c |
| 33263 | c ENDIF |
| 33264 | |
| 33265 | c WRITE(*,*) 'PMODUL = ',PMODUL |
| 33266 | |
| 33267 | c WRITE(*,*) |
| 33268 | c WRITE(*,*) |
| 33269 | c WRITE(*,*) 'prepola: Now back to nucl rest frame' |
| 33270 | |
| 33271 | CALL PYROBO(1,5,0.0D0,0.0D0,-BB2(1),-BB2(2),-BB2(3)) |
| 33272 | |
| 33273 | XDC = V(4,1)+V(4,5)*P(4,1)/P(4,5) |
| 33274 | YDC = V(4,2)+V(4,5)*P(4,2)/P(4,5) |
| 33275 | ZDC = V(4,3)+V(4,5)*P(4,3)/P(4,5) |
| 33276 | DO NDC =6,8 |
| 33277 | V(NDC,1) = XDC |
| 33278 | V(NDC,2) = YDC |
| 33279 | V(NDC,3) = ZDC |
| 33280 | END DO |
| 33281 | |
| 33282 | RETURN |
| 33283 | END |
| 33284 | * |
| 33285 | *===testrot============================================================* |
| 33286 | * |
| 33287 | CDECK ID>, DT_TESTROT |
| 33288 | SUBROUTINE DT_TESTROT(PI,PO,PHI,MODE) |
| 33289 | |
| 33290 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 33291 | SAVE |
| 33292 | |
| 33293 | DIMENSION ROT(3,3),PI(3),PO(3) |
| 33294 | |
| 33295 | IF (MODE.EQ.1) THEN |
| 33296 | ROT(1,1) = 1.D0 |
| 33297 | ROT(1,2) = 0.D0 |
| 33298 | ROT(1,3) = 0.D0 |
| 33299 | ROT(2,1) = 0.D0 |
| 33300 | ROT(2,2) = COS(PHI) |
| 33301 | ROT(2,3) = -SIN(PHI) |
| 33302 | ROT(3,1) = 0.D0 |
| 33303 | ROT(3,2) = SIN(PHI) |
| 33304 | ROT(3,3) = COS(PHI) |
| 33305 | ELSEIF (MODE.EQ.2) THEN |
| 33306 | ROT(1,1) = 0.D0 |
| 33307 | ROT(1,2) = 1.D0 |
| 33308 | ROT(1,3) = 0.D0 |
| 33309 | ROT(2,1) = COS(PHI) |
| 33310 | ROT(2,2) = 0.D0 |
| 33311 | ROT(2,3) = -SIN(PHI) |
| 33312 | ROT(3,1) = SIN(PHI) |
| 33313 | ROT(3,2) = 0.D0 |
| 33314 | ROT(3,3) = COS(PHI) |
| 33315 | ELSEIF (MODE.EQ.3) THEN |
| 33316 | ROT(1,1) = 0.D0 |
| 33317 | ROT(2,1) = 1.D0 |
| 33318 | ROT(3,1) = 0.D0 |
| 33319 | ROT(1,2) = COS(PHI) |
| 33320 | ROT(2,2) = 0.D0 |
| 33321 | ROT(3,2) = -SIN(PHI) |
| 33322 | ROT(1,3) = SIN(PHI) |
| 33323 | ROT(2,3) = 0.D0 |
| 33324 | ROT(3,3) = COS(PHI) |
| 33325 | ELSEIF (MODE.EQ.4) THEN |
| 33326 | ROT(1,1) = 1.D0 |
| 33327 | ROT(2,1) = 0.D0 |
| 33328 | ROT(3,1) = 0.D0 |
| 33329 | ROT(1,2) = 0.D0 |
| 33330 | ROT(2,2) = COS(PHI) |
| 33331 | ROT(3,2) = -SIN(PHI) |
| 33332 | ROT(1,3) = 0.D0 |
| 33333 | ROT(2,3) = SIN(PHI) |
| 33334 | ROT(3,3) = COS(PHI) |
| 33335 | ELSE |
| 33336 | STOP ' TESTROT: mode not supported!' |
| 33337 | ENDIF |
| 33338 | DO 1 J=1,3 |
| 33339 | PO(J) = ROT(J,1)*PI(1)+ROT(J,2)*PI(2)+ROT(J,3)*PI(3) |
| 33340 | 1 CONTINUE |
| 33341 | |
| 33342 | RETURN |
| 33343 | END |
| 33344 | * |
| 33345 | *===lepdcyp============================================================* |
| 33346 | * |
| 33347 | CDECK ID>, DT_LEPDCYP |
| 33348 | SUBROUTINE DT_LEPDCYP(AMA,AML,POL,ETL,PXL,PYL,PZL, |
| 33349 | & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN) |
| 33350 | C |
| 33351 | C----------------------------------------------------------------- |
| 33352 | C |
| 33353 | C Author :- G. Battistoni 10-NOV-1995 |
| 33354 | C |
| 33355 | C================================================================= |
| 33356 | C |
| 33357 | C Purpose : performs decay of polarized lepton in |
| 33358 | C its rest frame: a => b + l + anti-nu |
| 33359 | C (Example: mu- => nu-mu + e- + anti-nu-e) |
| 33360 | C Polarization is assumed along Z-axis |
| 33361 | C WARNING: |
| 33362 | C 1) b AND anti-nu ARE ASSUMED TO BE NEUTRINOS |
| 33363 | C OF NEGLIGIBLE MASS |
| 33364 | C 2) RADIATIVE CORRECTIONS ARE NOT CONSIDERED |
| 33365 | C IN THIS VERSION |
| 33366 | C |
| 33367 | C Method : modifies phase space distribution obtained |
| 33368 | C by routine EXPLOD using a rejection against the |
| 33369 | C matrix element for unpolarized lepton decay |
| 33370 | C |
| 33371 | C Inputs : Mass of a : AMA |
| 33372 | C Mass of l : AML |
| 33373 | C Polar. of a: POL |
| 33374 | C (Example: fully polar. mu- decay: AMA=AMMUON, AML=AMELCT, |
| 33375 | C POL = -1) |
| 33376 | C |
| 33377 | C Outputs : kinematic variables in the rest frame of decaying lepton |
| 33378 | C ETL,PXL,PYL,PZL 4-moment of l |
| 33379 | C ETB,PXB,PYB,PZB 4-moment of b |
| 33380 | C ETN,PXN,PYN,PZN 4-moment of anti-nu |
| 33381 | C |
| 33382 | C============================================================ |
| 33383 | C + |
| 33384 | C Declarations. |
| 33385 | C - |
| 33386 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 33387 | SAVE |
| 33388 | |
| 33389 | PARAMETER ( LINP = 5 , |
| 33390 | & LOUT = 6 , |
| 33391 | & LDAT = 9 ) |
| 33392 | |
| 33393 | PARAMETER ( KALGNM = 2 ) |
| 33394 | PARAMETER ( ANGLGB = 5.0D-16 ) |
| 33395 | PARAMETER ( ANGLSQ = 2.5D-31 ) |
| 33396 | PARAMETER ( AXCSSV = 0.2D+16 ) |
| 33397 | PARAMETER ( ANDRFL = 1.0D-38 ) |
| 33398 | PARAMETER ( AVRFLW = 1.0D+38 ) |
| 33399 | PARAMETER ( AINFNT = 1.0D+30 ) |
| 33400 | PARAMETER ( AZRZRZ = 1.0D-30 ) |
| 33401 | PARAMETER ( EINFNT = +69.07755278982137 D+00 ) |
| 33402 | PARAMETER ( EZRZRZ = -69.07755278982137 D+00 ) |
| 33403 | PARAMETER ( ONEMNS = 0.999999999999999 D+00 ) |
| 33404 | PARAMETER ( ONEPLS = 1.000000000000001 D+00 ) |
| 33405 | PARAMETER ( CSNNRM = 2.0D-15 ) |
| 33406 | PARAMETER ( DMXTRN = 1.0D+08 ) |
| 33407 | PARAMETER ( ZERZER = 0.D+00 ) |
| 33408 | PARAMETER ( ONEONE = 1.D+00 ) |
| 33409 | PARAMETER ( TWOTWO = 2.D+00 ) |
| 33410 | PARAMETER ( THRTHR = 3.D+00 ) |
| 33411 | PARAMETER ( FOUFOU = 4.D+00 ) |
| 33412 | PARAMETER ( FIVFIV = 5.D+00 ) |
| 33413 | PARAMETER ( SIXSIX = 6.D+00 ) |
| 33414 | PARAMETER ( SEVSEV = 7.D+00 ) |
| 33415 | PARAMETER ( EIGEIG = 8.D+00 ) |
| 33416 | PARAMETER ( ANINEN = 9.D+00 ) |
| 33417 | PARAMETER ( TENTEN = 10.D+00 ) |
| 33418 | PARAMETER ( HLFHLF = 0.5D+00 ) |
| 33419 | PARAMETER ( ONETHI = ONEONE / THRTHR ) |
| 33420 | PARAMETER ( TWOTHI = TWOTWO / THRTHR ) |
| 33421 | PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 ) |
| 33422 | PARAMETER ( ENEPER = 2.7182818284590452354 D+00 ) |
| 33423 | PARAMETER ( SQRENT = 1.6487212707001281468 D+00 ) |
| 33424 | PARAMETER ( CLIGHT = 2.99792458 D+10 ) |
| 33425 | PARAMETER ( AVOGAD = 6.0221367 D+23 ) |
| 33426 | PARAMETER ( AMELGR = 9.1093897 D-28 ) |
| 33427 | PARAMETER ( PLCKBR = 1.05457266 D-27 ) |
| 33428 | PARAMETER ( ELCCGS = 4.8032068 D-10 ) |
| 33429 | PARAMETER ( ELCMKS = 1.60217733 D-19 ) |
| 33430 | PARAMETER ( AMUGRM = 1.6605402 D-24 ) |
| 33431 | PARAMETER ( AMMUMU = 0.113428913 D+00 ) |
| 33432 | PARAMETER ( ALPFSC = 7.2973530791728595 D-03 ) |
| 33433 | PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 ) |
| 33434 | PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 ) |
| 33435 | PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 ) |
| 33436 | PARAMETER ( PLABRC = 0.197327053 D+00 ) |
| 33437 | PARAMETER ( AMELCT = 0.51099906 D-03 ) |
| 33438 | PARAMETER ( AMUGEV = 0.93149432 D+00 ) |
| 33439 | PARAMETER ( AMMUON = 0.105658389 D+00 ) |
| 33440 | PARAMETER ( RCLSEL = 2.8179409183694872 D-13 ) |
| 33441 | PARAMETER ( GEVMEV = 1.0 D+03 ) |
| 33442 | PARAMETER ( EMVGEV = 1.0 D-03 ) |
| 33443 | PARAMETER ( ALGVMV = 6.90775527898214 D+00 ) |
| 33444 | PARAMETER ( RADDEG = 180.D+00 / PIPIPI ) |
| 33445 | PARAMETER ( DEGRAD = PIPIPI / 180.D+00 ) |
| 33446 | C + |
| 33447 | C variables for EXPLOD |
| 33448 | C - |
| 33449 | PARAMETER ( KPMX = 10 ) |
| 33450 | DIMENSION AMEXPL (KPMX), PXEXPL (KPMX), PYEXPL (KPMX), |
| 33451 | & PZEXPL (KPMX), ETEXPL (KPMX) |
| 33452 | C + |
| 33453 | C test variables |
| 33454 | C - |
| 33455 | **sr - removed (not needed) |
| 33456 | C COMMON /GBATNU/ ELERAT,NTRY |
| 33457 | ** |
| 33458 | C + |
| 33459 | C Initializes test variables |
| 33460 | C - |
| 33461 | NTRY = 0 |
| 33462 | ELERAT = 0.D+00 |
| 33463 | C + |
| 33464 | C Maximum value for matrix element |
| 33465 | C - |
| 33466 | ELEMAX = ( AMA**2 + AML**2 )**2 / AMA**2 * ( AMA**2 - AML**2 + |
| 33467 | & SQRT( AMA**4 + AML**4 - 3.D+00 * AMA**2 * AML**2 ) ) |
| 33468 | C + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + |
| 33469 | C Inputs for EXPLOD |
| 33470 | C part. no. 1 is l (e- in mu- decay) |
| 33471 | C part. no. 2 is b (nu-mu in mu- decay) |
| 33472 | C part. no. 3 is anti-nu (anti-nu-e in mu- decay) |
| 33473 | C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - |
| 33474 | NPEXPL = 3 |
| 33475 | ETOTEX = AMA |
| 33476 | AMEXPL(1) = AML |
| 33477 | AMEXPL(2) = 0.D+00 |
| 33478 | AMEXPL(3) = 0.D+00 |
| 33479 | C + |
| 33480 | C phase space distribution |
| 33481 | C - |
| 33482 | 100 CONTINUE |
| 33483 | NTRY = NTRY + 1 |
| 33484 | |
| 33485 | CALL EXPLOD ( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL, |
| 33486 | & PYEXPL, PZEXPL ) |
| 33487 | |
| 33488 | C + |
| 33489 | C Calculates matrix element: |
| 33490 | C 64*GF**2{[P(a)-ama*S(a)]*P(anti-nu)}{P(l)*P(b)} |
| 33491 | C Here CTH is the cosine of the angle between anti-nu and Z axis |
| 33492 | C - |
| 33493 | CTH = PZEXPL(3) / SQRT ( PXEXPL(3)**2 + PYEXPL(3)**2 + |
| 33494 | & PZEXPL(3)**2 ) |
| 33495 | PROD1 = ETEXPL(3) * AMA * (1.D+00 - POL * CTH) |
| 33496 | PROD2 = ETEXPL(1) * ETEXPL(2) - PXEXPL(1)*PXEXPL(2) - |
| 33497 | & PYEXPL(1)*PYEXPL(2) - PZEXPL(1)*PZEXPL(2) |
| 33498 | ELEMAT = 16.D+00 * PROD1 * PROD2 |
| 33499 | IF(ELEMAT.GT.ELEMAX) THEN |
| 33500 | WRITE(LOUT,*) 'Problems in LEPDCY',ELEMAX,ELEMAT |
| 33501 | STOP |
| 33502 | ENDIF |
| 33503 | C + |
| 33504 | C Here performs the rejection |
| 33505 | C - |
| 33506 | TEST = DT_RNDM(ETOTEX) * ELEMAX |
| 33507 | IF ( TEST .GT. ELEMAT ) GO TO 100 |
| 33508 | C + |
| 33509 | C final assignment of variables |
| 33510 | C - |
| 33511 | ELERAT = ELEMAT/ELEMAX |
| 33512 | ETL = ETEXPL(1) |
| 33513 | PXL = PXEXPL(1) |
| 33514 | PYL = PYEXPL(1) |
| 33515 | PZL = PZEXPL(1) |
| 33516 | ETB = ETEXPL(2) |
| 33517 | PXB = PXEXPL(2) |
| 33518 | PYB = PYEXPL(2) |
| 33519 | PZB = PZEXPL(2) |
| 33520 | ETN = ETEXPL(3) |
| 33521 | PXN = PXEXPL(3) |
| 33522 | PYN = PYEXPL(3) |
| 33523 | PZN = PZEXPL(3) |
| 33524 | 999 RETURN |
| 33525 | END |
| 33526 | |
| 33527 | C================================================================== |
| 33528 | C. Generation of Delta resonance events |
| 33529 | C================================================================== |
| 33530 | * |
| 33531 | *===gen_delta==========================================================* |
| 33532 | * |
| 33533 | CDECK ID>, DT_GEN_DELTA |
| 33534 | SUBROUTINE DT_GEN_DELTA(ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25) |
| 33535 | |
| 33536 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 33537 | SAVE |
| 33538 | |
| 33539 | PARAMETER ( LINP = 5 , |
| 33540 | & LOUT = 6 , |
| 33541 | & LDAT = 9 ) |
| 33542 | |
| 33543 | C...Generate a Delta-production neutrino/antineutrino |
| 33544 | C. CC-interaction on a nucleon |
| 33545 | C |
| 33546 | C. INPUT ENU (GeV) = Neutrino Energy |
| 33547 | C. LLEP = neutrino type |
| 33548 | C. LTARG = nucleon target type 1=p, 2=n. |
| 33549 | C. JINT = 1:CC, 2::NC |
| 33550 | C. |
| 33551 | C. OUTPUT PPL(4) 4-monentum of final lepton |
| 33552 | C---------------------------------------------------- |
| 33553 | |
| 33554 | PARAMETER (MAXLND=4000) |
| 33555 | COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5) |
| 33556 | |
| 33557 | **sr - removed (not needed) |
| 33558 | C COMMON /CBAD/ LBAD, NBAD |
| 33559 | ** |
| 33560 | |
| 33561 | DIMENSION PI(3),PO(3) |
| 33562 | C REAL*4 AMD0, AMD, AMN(2), AML0(6), AML, AML2, AMDMIN |
| 33563 | DIMENSION AML0(6),AMN(2) |
| 33564 | DATA AMD0 /1.231/, GAMD /0.12/, DELD/0.169/, AMDMIN/1.084/ |
| 33565 | DATA AMN /0.93827231, 0.93956563/ |
| 33566 | DATA AML0 /2*0.51100E-03,2*0.105659, 2*1.777/ |
| 33567 | |
| 33568 | c WRITE(6,*)' GEN_DEL',ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25 |
| 33569 | LBAD = 0 |
| 33570 | C...Final lepton mass |
| 33571 | IF (JINT.EQ.1) THEN |
| 33572 | AML = AML0(LLEP) |
| 33573 | ELSE |
| 33574 | AML = 0. |
| 33575 | ENDIF |
| 33576 | AML2 = AML**2 |
| 33577 | |
| 33578 | C...Particle labels (LUND) |
| 33579 | N = 5 |
| 33580 | K(1,1) = 21 |
| 33581 | K(2,1) = 21 |
| 33582 | K(3,1) = 21 |
| 33583 | K(4,1) = 1 |
| 33584 | K(3,3) = 1 |
| 33585 | K(4,3) = 1 |
| 33586 | IF (LTARG .EQ. 1) THEN |
| 33587 | K(2,2) = 2212 |
| 33588 | ELSE |
| 33589 | K(2,2) = 2112 |
| 33590 | ENDIF |
| 33591 | K0 = (LLEP-1)/2 |
| 33592 | K1 = LLEP/2 |
| 33593 | KA = 12 + 2*K0 |
| 33594 | IS = -1 + 2*LLEP - 4*K1 |
| 33595 | LNU = 2 - LLEP + 2*K1 |
| 33596 | K(1,2) = IS*KA |
| 33597 | K(5,1) = 1 |
| 33598 | K(5,3) = 2 |
| 33599 | IF (JINT .EQ. 1) THEN ! CC interactions |
| 33600 | K(3,2) = IS*24 |
| 33601 | K(4,2) = IS*(KA-1) |
| 33602 | IF(LNU.EQ.1) THEN |
| 33603 | IF (LTARG .EQ. 1) THEN |
| 33604 | K(5,2) = 2224 |
| 33605 | ELSE |
| 33606 | K(5,2) = 2214 |
| 33607 | ENDIF |
| 33608 | ELSE |
| 33609 | IF (LTARG .EQ. 1) THEN |
| 33610 | K(5,2) = 2114 |
| 33611 | ELSE |
| 33612 | K(5,2) = 1114 |
| 33613 | ENDIF |
| 33614 | ENDIF |
| 33615 | ELSE |
| 33616 | K(3,2) = 23 ! NC (Z0) interactions |
| 33617 | K(4,2) = K(1,2) |
| 33618 | **sr 7.5.00: swop Delta's (bug), Delta+ for proton (LTARG=1), |
| 33619 | * Delta0 for neutron (LTARG=2) |
| 33620 | C IF (LTARG .EQ. 1) THEN |
| 33621 | C K(5,2) = 2114 |
| 33622 | C ELSE |
| 33623 | C K(5,2) = 2214 |
| 33624 | C ENDIF |
| 33625 | IF (LTARG .EQ. 1) THEN |
| 33626 | K(5,2) = 2214 |
| 33627 | ELSE |
| 33628 | K(5,2) = 2114 |
| 33629 | ENDIF |
| 33630 | ** |
| 33631 | ENDIF |
| 33632 | |
| 33633 | C...4-momentum initial lepton |
| 33634 | P(1,5) = 0. |
| 33635 | P(1,4) = ENU |
| 33636 | P(1,1) = 0. |
| 33637 | P(1,2) = 0. |
| 33638 | P(1,3) = ENU |
| 33639 | C...4-momentum initial nucleon |
| 33640 | P(2,5) = AMN(LTARG) |
| 33641 | C P(2,4) = P(2,5) |
| 33642 | C P(2,1) = 0. |
| 33643 | C P(2,2) = 0. |
| 33644 | C P(2,3) = 0. |
| 33645 | P(2,1) = P21 |
| 33646 | P(2,2) = P22 |
| 33647 | P(2,3) = P23 |
| 33648 | P(2,4) = P24 |
| 33649 | P(2,5) = P25 |
| 33650 | N=2 |
| 33651 | beta1=-p(2,1)/p(2,4) |
| 33652 | beta2=-p(2,2)/p(2,4) |
| 33653 | beta3=-p(2,3)/p(2,4) |
| 33654 | N=2 |
| 33655 | |
| 33656 | CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3) |
| 33657 | |
| 33658 | C print*,' nucl. rest fram ( fermi incl.) prima della rotazione' |
| 33659 | |
| 33660 | phi11=atan(p(1,2)/p(1,3)) |
| 33661 | pi(1)=p(1,1) |
| 33662 | pi(2)=p(1,2) |
| 33663 | pi(3)=p(1,3) |
| 33664 | |
| 33665 | CALL DT_TESTROT(PI,Po,PHI11,1) |
| 33666 | DO ll=1,3 |
| 33667 | IF(abs(po(ll)).LT.1.D-07) po(ll)=0. |
| 33668 | END DO |
| 33669 | p(1,1)=po(1) |
| 33670 | p(1,2)=po(2) |
| 33671 | p(1,3)=po(3) |
| 33672 | phi12=atan(p(1,1)/p(1,3)) |
| 33673 | |
| 33674 | pi(1)=p(1,1) |
| 33675 | pi(2)=p(1,2) |
| 33676 | pi(3)=p(1,3) |
| 33677 | CALL DT_TESTROT(Pi,Po,PHI12,2) |
| 33678 | DO ll=1,3 |
| 33679 | IF(abs(po(ll)).LT.1.D-07) po(ll)=0. |
| 33680 | END DO |
| 33681 | p(1,1)=po(1) |
| 33682 | p(1,2)=po(2) |
| 33683 | p(1,3)=po(3) |
| 33684 | |
| 33685 | ENUU=P(1,4) |
| 33686 | |
| 33687 | C...Generate the Mass of the Delta |
| 33688 | NTRY = 0 |
| 33689 | 100 R = PYR(0) |
| 33690 | AMD=AMD0+0.5*GAMD*TAN((2.*R-1.)*ATAN(2.*DELD/GAMD)) |
| 33691 | NTRY = NTRY + 1 |
| 33692 | IF (NTRY .GT. 1000) THEN |
| 33693 | LBAD = 1 |
| 33694 | WRITE (LOUT,1001) NBAD, ENUU,AMD,AMDMIN,AMD0,GAMD,ET |
| 33695 | RETURN |
| 33696 | ENDIF |
| 33697 | IF (AMD .LT. AMDMIN) GOTO 100 |
| 33698 | ET = ((AMD+AML)**2 - AMN(LTARG)**2)/(2.*AMN(LTARG)) |
| 33699 | IF (ENUU .LT. ET) GOTO 100 |
| 33700 | |
| 33701 | C...Kinematical limits in Q**2 |
| 33702 | S = AMN(LTARG)**2 + 2.*AMN(LTARG)*ENUU |
| 33703 | SQS = SQRT(S) |
| 33704 | PSTAR = (S - AMN(LTARG)**2)/(2.*SQS) |
| 33705 | ELF = (S - AMD**2 + AML2)/(2.*SQS) |
| 33706 | PLF = SQRT(ELF**2 - AML2) |
| 33707 | Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF) |
| 33708 | Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF) |
| 33709 | IF (Q2MIN .LT. 0.) Q2MIN = 0. |
| 33710 | |
| 33711 | DSIGMAX = DT_DSIGMA_DELTA(LNU,-Q2MIN, S, AML, AMD) |
| 33712 | 200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0) |
| 33713 | DSIG = DT_DSIGMA_DELTA(LNU,-Q2, S, AML, AMD) |
| 33714 | IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200 |
| 33715 | |
| 33716 | C...Generate the kinematics of the final particles |
| 33717 | EISTAR = (S + AMN(LTARG)**2)/(2.*SQS) |
| 33718 | GAM = EISTAR/AMN(LTARG) |
| 33719 | BET = PSTAR/EISTAR |
| 33720 | CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF) |
| 33721 | EL = GAM*(ELF + BET*PLF*CTSTAR) |
| 33722 | PLZ = GAM*(PLF*CTSTAR + BET*ELF) |
| 33723 | PL = SQRT(EL**2 - AML2) |
| 33724 | PLT = SQRT(MAX(1.D-06,(PL*PL - PLZ*PLZ))) |
| 33725 | PHI = 6.28319*PYR(0) |
| 33726 | P(4,1) = PLT*COS(PHI) |
| 33727 | P(4,2) = PLT*SIN(PHI) |
| 33728 | P(4,3) = PLZ |
| 33729 | P(4,4) = EL |
| 33730 | P(4,5) = AML |
| 33731 | |
| 33732 | C...4-momentum of Delta |
| 33733 | P(5,1) = -P(4,1) |
| 33734 | P(5,2) = -P(4,2) |
| 33735 | P(5,3) = ENUU-P(4,3) |
| 33736 | P(5,4) = ENUU+AMN(LTARG)-P(4,4) |
| 33737 | P(5,5) = AMD |
| 33738 | |
| 33739 | C...4-momentum of intermediate boson |
| 33740 | P(3,5) = -Q2 |
| 33741 | P(3,4) = P(1,4)-P(4,4) |
| 33742 | P(3,1) = P(1,1)-P(4,1) |
| 33743 | P(3,2) = P(1,2)-P(4,2) |
| 33744 | P(3,3) = P(1,3)-P(4,3) |
| 33745 | N=5 |
| 33746 | |
| 33747 | DO kw=1,5 |
| 33748 | pi(1)=p(kw,1) |
| 33749 | pi(2)=p(kw,2) |
| 33750 | pi(3)=p(kw,3) |
| 33751 | CALL DT_TESTROT(Pi,Po,PHI12,3) |
| 33752 | DO ll=1,3 |
| 33753 | IF(abs(po(ll)).LT.1.D-07) po(ll)=0. |
| 33754 | END DO |
| 33755 | p(kw,1)=po(1) |
| 33756 | p(kw,2)=po(2) |
| 33757 | p(kw,3)=po(3) |
| 33758 | END DO |
| 33759 | |
| 33760 | c******************************************** |
| 33761 | |
| 33762 | DO kw=1,5 |
| 33763 | pi(1)=p(kw,1) |
| 33764 | pi(2)=p(kw,2) |
| 33765 | pi(3)=p(kw,3) |
| 33766 | CALL DT_TESTROT(Pi,Po,PHI11,4) |
| 33767 | DO ll=1,3 |
| 33768 | IF(abs(po(ll)).LT.1.D-07) po(ll)=0. |
| 33769 | END DO |
| 33770 | p(kw,1)=po(1) |
| 33771 | p(kw,2)=po(2) |
| 33772 | p(kw,3)=po(3) |
| 33773 | END DO |
| 33774 | c******************************************** |
| 33775 | C transform back into Lab. |
| 33776 | |
| 33777 | CALL PYROBO(0,0,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3) |
| 33778 | |
| 33779 | C WRITE(6,*)' Lab fram ( fermi incl.) ' |
| 33780 | N=5 |
| 33781 | CALL PYEXEC |
| 33782 | |
| 33783 | RETURN |
| 33784 | 1001 FORMAT(2X, 'DT_GEN_DELTA : event rejected ', I5, 6G10.3) |
| 33785 | END |
| 33786 | * |
| 33787 | *===dsigma_delta=======================================================* |
| 33788 | * |
| 33789 | CDECK ID>, DT_DSIGMA_DELTA |
| 33790 | DOUBLE PRECISION FUNCTION DT_DSIGMA_DELTA (LNU, QQ, S, AML, MD) |
| 33791 | |
| 33792 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 33793 | SAVE |
| 33794 | |
| 33795 | C...Reaction nu + N -> lepton + Delta |
| 33796 | C. returns the cross section |
| 33797 | C. dsigma/dt |
| 33798 | C. INPUT LNU = 1, 2 (neutrino-antineutrino) |
| 33799 | C. QQ = t (always negative) GeV**2 |
| 33800 | C. S = (c.m energy)**2 GeV**2 |
| 33801 | C. OUTPUT = 10**-38 cm+2/GeV**2 |
| 33802 | C----------------------------------------------------- |
| 33803 | REAL*8 MN, MN2, MN4, MD,MD2, MD4 |
| 33804 | DATA MN /0.938/ |
| 33805 | DATA PI /3.1415926/ |
| 33806 | |
| 33807 | GF = (1.1664 * 1.97) |
| 33808 | GF2 = GF*GF |
| 33809 | MN2 = MN*MN |
| 33810 | MN4 = MN2*MN2 |
| 33811 | MD2 = MD*MD |
| 33812 | MD4 = MD2*MD2 |
| 33813 | AML2 = AML*AML |
| 33814 | AML4 = AML2*AML2 |
| 33815 | VQ = (MN2 - MD2 - QQ)/2. |
| 33816 | VPI = (MN2 + MD2 - QQ)/2. |
| 33817 | VK = (S + QQ - MN2 - AML2)/2. |
| 33818 | PIK = (S - MN2)/2. |
| 33819 | QK = (AML2 - QQ)/2. |
| 33820 | PIQ = (QQ + MN2 - MD2)/2. |
| 33821 | Q = SQRT(-QQ) |
| 33822 | C3V = 2.07*SQRT(EXP(-6.3*Q)*(1.+9*Q)) |
| 33823 | C3 = SQRT(3.)*C3V/MN |
| 33824 | C4 = -C3/MD ! attenzione al segno |
| 33825 | C5A = 1.18/(1.-QQ/0.4225)**2 |
| 33826 | C32 = C3**2 |
| 33827 | C42 = C4**2 |
| 33828 | C5A2 = C5A**2 |
| 33829 | |
| 33830 | IF (LNU .EQ. 1) THEN |
| 33831 | ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ* |
| 33832 | . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42- |
| 33833 | . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ* |
| 33834 | . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32 |
| 33835 | ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK |
| 33836 | . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2* |
| 33837 | . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD* |
| 33838 | . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ* |
| 33839 | . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ |
| 33840 | . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ- |
| 33841 | . 4.*MN*C3*C5A*MD2*VK*QQ+4.*MN*C3*C5A*MD2*VQ*QK-2.*MD* |
| 33842 | . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD |
| 33843 | . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.* |
| 33844 | . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.* |
| 33845 | . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK-MD* |
| 33846 | . C3*C5A*MD2*PIK*QQ+MD*C3*C5A*MD2*QK*PIQ-3.*MD*C3*C5A |
| 33847 | . *VK*VPI*QQ+MD*C3*C5A*VK*VQ*PIQ+3.*MD*C3*C5A*VPI*VQ* |
| 33848 | . QK-MD*C3*C5A*VQ**2*PIK+C4*C5A*MD2*VK*VPI*QQ+C4*C5A* |
| 33849 | . MD2*VK*VQ*PIQ-C4*C5A*MD2*VPI*VQ*QK-C4*C5A*MD2*VQ**2 |
| 33850 | . *PIK-C4*C5A*MD4*PIK*QQ+C4*C5A*MD4*QK*PIQ-2.*MD2*VK |
| 33851 | . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK* |
| 33852 | . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK |
| 33853 | . *C42-2.*MD2*VPI*QK**2*C32+ANS3 |
| 33854 | ELSE |
| 33855 | ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ* |
| 33856 | . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42- |
| 33857 | . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ* |
| 33858 | . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32 |
| 33859 | ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK |
| 33860 | . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2* |
| 33861 | . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD* |
| 33862 | . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ* |
| 33863 | . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ |
| 33864 | . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ+ |
| 33865 | . 4.*MN*C3*C5A*MD2*VK*QQ-4.*MN*C3*C5A*MD2*VQ*QK-2.*MD* |
| 33866 | . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD |
| 33867 | . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.* |
| 33868 | . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.* |
| 33869 | . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK+MD* |
| 33870 | . C3*C5A*MD2*PIK*QQ-MD*C3*C5A*MD2*QK*PIQ+3.*MD*C3*C5A |
| 33871 | . *VK*VPI*QQ-MD*C3*C5A*VK*VQ*PIQ-3.*MD*C3*C5A*VPI*VQ* |
| 33872 | . QK+MD*C3*C5A*VQ**2*PIK-C4*C5A*MD2*VK*VPI*QQ-C4*C5A* |
| 33873 | . MD2*VK*VQ*PIQ+C4*C5A*MD2*VPI*VQ*QK+C4*C5A*MD2*VQ**2 |
| 33874 | . *PIK+C4*C5A*MD4*PIK*QQ-C4*C5A*MD4*QK*PIQ-2.*MD2*VK |
| 33875 | . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK* |
| 33876 | . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK |
| 33877 | . *C42-2.*MD2*VPI*QK**2*C32+ANS3 |
| 33878 | ENDIF |
| 33879 | ANS1=32.*ANS2 |
| 33880 | ANS=ANS1/(3.*MD2) |
| 33881 | P1CM = (S-MN2)/(2.*SQRT(S)) |
| 33882 | DT_DSIGMA_DELTA = GF2/2. * ANS/(64.*PI*S*P1CM**2) |
| 33883 | |
| 33884 | RETURN |
| 33885 | END |
| 33886 | * |
| 33887 | *===qgaus==============================================================* |
| 33888 | * |
| 33889 | CDECK ID>, DT_QGAUS |
| 33890 | SUBROUTINE DT_QGAUS(A,B,SS,ENU,LTYP) |
| 33891 | |
| 33892 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 33893 | SAVE |
| 33894 | |
| 33895 | DIMENSION X(5),W(5) |
| 33896 | DATA X/.1488743389D0,.4333953941D0, |
| 33897 | & .6794095682D0,.8650633666D0,.9739065285D0 |
| 33898 | */ |
| 33899 | DATA W/.2955242247D0,.2692667193D0, |
| 33900 | & .2190863625D0,.1494513491D0,.0666713443D0 |
| 33901 | */ |
| 33902 | XM=0.5D0*(B+A) |
| 33903 | XR=0.5D0*(B-A) |
| 33904 | SS=0 |
| 33905 | DO 11 J=1,5 |
| 33906 | DX=XR*X(J) |
| 33907 | SS=SS+W(J)*(DT_DSQEL_Q2(LTYP,ENU,XM+DX)+ |
| 33908 | * DT_DSQEL_Q2(LTYP,ENU,XM-DX)) |
| 33909 | 11 CONTINUE |
| 33910 | SS=XR*SS |
| 33911 | |
| 33912 | RETURN |
| 33913 | END |
| 33914 | * |
| 33915 | *===diqbrk=============================================================* |
| 33916 | * |
| 33917 | CDECK ID>, DT_DIQBRK |
| 33918 | SUBROUTINE DT_DIQBRK |
| 33919 | |
| 33920 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 33921 | SAVE |
| 33922 | |
| 33923 | * event history |
| 33924 | |
| 33925 | PARAMETER (NMXHKK=200000) |
| 33926 | |
| 33927 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 33928 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 33929 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 33930 | * extended event history |
| 33931 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 33932 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 33933 | & IHIST(2,NMXHKK) |
| 33934 | * event flag |
| 33935 | COMMON /DTEVNO/ NEVENT,ICASCA |
| 33936 | |
| 33937 | C IF(DT_RNDM(VV).LE.0.5D0)THEN |
| 33938 | C CALL GSQBS1(NHKK) |
| 33939 | C CALL GSQBS2(NHKK) |
| 33940 | C CALL USQBS1(NHKK) |
| 33941 | C CALL USQBS2(NHKK) |
| 33942 | C CALL GSABS1(NHKK) |
| 33943 | C CALL GSABS2(NHKK) |
| 33944 | C CALL USABS1(NHKK) |
| 33945 | C CALL USABS2(NHKK) |
| 33946 | C ELSE |
| 33947 | C CALL GSQBS2(NHKK) |
| 33948 | C CALL GSQBS1(NHKK) |
| 33949 | C CALL USQBS2(NHKK) |
| 33950 | C CALL USQBS1(NHKK) |
| 33951 | C CALL GSABS2(NHKK) |
| 33952 | C CALL GSABS1(NHKK) |
| 33953 | C CALL USABS2(NHKK) |
| 33954 | C CALL USABS1(NHKK) |
| 33955 | C ENDIF |
| 33956 | |
| 33957 | IF(DT_RNDM(VV).LE.0.5D0) THEN |
| 33958 | CALL DT_DBREAK(1) |
| 33959 | CALL DT_DBREAK(2) |
| 33960 | CALL DT_DBREAK(3) |
| 33961 | CALL DT_DBREAK(4) |
| 33962 | CALL DT_DBREAK(5) |
| 33963 | CALL DT_DBREAK(6) |
| 33964 | CALL DT_DBREAK(7) |
| 33965 | CALL DT_DBREAK(8) |
| 33966 | ELSE |
| 33967 | CALL DT_DBREAK(2) |
| 33968 | CALL DT_DBREAK(1) |
| 33969 | CALL DT_DBREAK(4) |
| 33970 | CALL DT_DBREAK(3) |
| 33971 | CALL DT_DBREAK(6) |
| 33972 | CALL DT_DBREAK(5) |
| 33973 | CALL DT_DBREAK(8) |
| 33974 | CALL DT_DBREAK(7) |
| 33975 | ENDIF |
| 33976 | |
| 33977 | RETURN |
| 33978 | END |
| 33979 | C |
| 33980 | C |
| 33981 | C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| 33982 | SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, |
| 33983 | * IP1,IP21,IP22,IPP1,IPP2,IPIP,ISQ,IGCOUN) |
| 33984 | C |
| 33985 | C USQBS-2 diagram (split target diquark) |
| 33986 | C |
| 33987 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 33988 | SAVE |
| 33989 | |
| 33990 | PARAMETER ( LINP = 5 , |
| 33991 | & LOUT = 6 , |
| 33992 | & LDAT = 9 ) |
| 33993 | |
| 33994 | * event history |
| 33995 | |
| 33996 | PARAMETER (NMXHKK=200000) |
| 33997 | |
| 33998 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 33999 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 34000 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 34001 | * extended event history |
| 34002 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 34003 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 34004 | & IHIST(2,NMXHKK) |
| 34005 | * Lorentz-parameters of the current interaction |
| 34006 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, |
| 34007 | & UMO,PPCM,EPROJ,PPROJ |
| 34008 | * diquark-breaking mechanism |
| 34009 | COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3 |
| 34010 | |
| 34011 | C |
| 34012 | PARAMETER (NTMHKK= 300) |
| 34013 | COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT |
| 34014 | +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT |
| 34015 | +(4,NTMHKK) |
| 34016 | *KEEP,XSEADI. |
| 34017 | COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA, |
| 34018 | +SSMIMQ,VVMTHR |
| 34019 | *KEEP,DPRIN. |
| 34020 | COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR |
| 34021 | COMMON /EVFLAG/ NUMEV |
| 34022 | C |
| 34023 | C USQBS-2 diagram (split target diquark) |
| 34024 | C |
| 34025 | C |
| 34026 | C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T) |
| 34027 | C Input chain 2(NC2) sea-antiquark(NC2P)-sea-quark(NC2T) |
| 34028 | C |
| 34029 | C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T |
| 34030 | C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T |
| 34031 | C |
| 34032 | C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2) |
| 34033 | C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5) |
| 34034 | C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8) |
| 34035 | C |
| 34036 | C |
| 34037 | C Put new chains into COMMON /HKKTMP/ |
| 34038 | C |
| 34039 | IIGLU1=NC1T-NC1P-1 |
| 34040 | IIGLU2=NC2T-NC2P-1 |
| 34041 | IGCOUN=0 |
| 34042 | C WRITE(LOUT,*)'MUSQBS2: IIGLU1,IIGLU2 ',IIGLU1,IIGLU2 |
| 34043 | CVQ=1.D0 |
| 34044 | IREJ=0 |
| 34045 | IF(IPIP.EQ.2)THEN |
| 34046 | C IF(NUMEV.EQ.-324)THEN |
| 34047 | C WRITE(LOUT,*)' MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,', |
| 34048 | C * 'IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN)', |
| 34049 | C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, |
| 34050 | C * IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN |
| 34051 | ENDIF |
| 34052 | C |
| 34053 | C |
| 34054 | C |
| 34055 | C determine x-values of NC1T diquark |
| 34056 | XDIQT=PHKK(4,NC1T)*2.D0/UMO |
| 34057 | XVQP=PHKK(4,NC1P)*2.D0/UMO |
| 34058 | C |
| 34059 | C determine x-values of sea quark pair |
| 34060 | C |
| 34061 | IPCO=1 |
| 34062 | ICOU=0 |
| 34063 | 2234 CONTINUE |
| 34064 | ICOU=ICOU+1 |
| 34065 | IF(ICOU.GE.500)THEN |
| 34066 | IREJ=1 |
| 34067 | IF(ISQ.EQ.3)IREJ=3 |
| 34068 | IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 2234 ICOU. GT.500' |
| 34069 | IPCO=0 |
| 34070 | RETURN |
| 34071 | ENDIF |
| 34072 | IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS2 call XSEAPA: UMO,XDIQT,XVQP ', |
| 34073 | * UMO, XDIQT,XVQP |
| 34074 | XSQ=0.D0 |
| 34075 | XSAQ=0.D0 |
| 34076 | **NEW |
| 34077 | C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ) |
| 34078 | IF (IPIP.EQ.1) THEN |
| 34079 | XQMAX = XDIQT/2.0D0 |
| 34080 | XAQMAX = 2.D0*XVQP/3.0D0 |
| 34081 | ELSE |
| 34082 | XQMAX = 2.D0*XVQP/3.0D0 |
| 34083 | XAQMAX = XDIQT/2.0D0 |
| 34084 | ENDIF |
| 34085 | CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ) |
| 34086 | ISAQ = 6+ISQ |
| 34087 | C write(*,*) 'MUSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP |
| 34088 | ** |
| 34089 | IF(IPCO.GE.3) |
| 34090 | & WRITE(LOUT,*)'MUSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ |
| 34091 | IF(IREJ.GE.1)THEN |
| 34092 | IF(IPCO.GE.3) |
| 34093 | & WRITE(LOUT,*)'MUSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ |
| 34094 | IPCO=0 |
| 34095 | RETURN |
| 34096 | ENDIF |
| 34097 | IF(IPIP.EQ.1)THEN |
| 34098 | IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234 |
| 34099 | ELSEIF(IPIP.EQ.2)THEN |
| 34100 | IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234 |
| 34101 | ENDIF |
| 34102 | IF(IPCO.GE.3)THEN |
| 34103 | WRITE(LOUT,'(A,4E12.4)')' MUSQBS2 XDIQT,XVQP,XSQ,XSAQ ', |
| 34104 | * XDIQT,XVQP,XSQ,XSAQ |
| 34105 | ENDIF |
| 34106 | C |
| 34107 | C subtract xsq,xsaq from NC1T diquark and NC1P quark |
| 34108 | C |
| 34109 | C XSQ=0.D0 |
| 34110 | IF(IPIP.EQ.1)THEN |
| 34111 | XDIQT=XDIQT-XSQ |
| 34112 | XVQP =XVQP -XSAQ |
| 34113 | ELSEIF(IPIP.EQ.2)THEN |
| 34114 | XDIQT=XDIQT-XSAQ |
| 34115 | XVQP =XVQP -XSQ |
| 34116 | ENDIF |
| 34117 | IF(IPCO.GE.3) |
| 34118 | & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP |
| 34119 | C |
| 34120 | C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T |
| 34121 | C |
| 34122 | XVTHRO=CVQ/UMO |
| 34123 | IVTHR=0 |
| 34124 | 3466 CONTINUE |
| 34125 | IF(IVTHR.EQ.10)THEN |
| 34126 | IREJ=1 |
| 34127 | IF(ISQ.EQ.3)IREJ=3 |
| 34128 | IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 3466 reject IVTHR 10' |
| 34129 | IPCO=0 |
| 34130 | RETURN |
| 34131 | ENDIF |
| 34132 | IVTHR=IVTHR+1 |
| 34133 | XVTHR=XVTHRO/(201-IVTHR) |
| 34134 | UNOPRV=UNON |
| 34135 | 380 CONTINUE |
| 34136 | IF(XVTHR.GT.0.66D0*XDIQT)THEN |
| 34137 | IREJ=1 |
| 34138 | IF(ISQ.EQ.3)IREJ=3 |
| 34139 | IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 380 XVTHR large ', |
| 34140 | * XVTHR |
| 34141 | IPCO=0 |
| 34142 | RETURN |
| 34143 | ENDIF |
| 34144 | IF(DT_RNDM(V).LT.0.5D0)THEN |
| 34145 | XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT) |
| 34146 | XVTQII=XDIQT-XVTQI |
| 34147 | ELSE |
| 34148 | XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT) |
| 34149 | XVTQI=XDIQT-XVTQII |
| 34150 | ENDIF |
| 34151 | IF(IPCO.GE.3)THEN |
| 34152 | WRITE(LOUT,'(A,2E12.4)')' MUSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII |
| 34153 | ENDIF |
| 34154 | C |
| 34155 | C Prepare 4 momenta of new chains and chain ends |
| 34156 | C |
| 34157 | C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT |
| 34158 | C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT |
| 34159 | C +(4,NTMHKK) |
| 34160 | C |
| 34161 | C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2) |
| 34162 | C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5) |
| 34163 | C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8) |
| 34164 | C |
| 34165 | C SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, |
| 34166 | C * IP1,IP21,IP22,IPP1,IPP2) |
| 34167 | C |
| 34168 | IF(IPIP.EQ.1)THEN |
| 34169 | XSQ1=XSQ |
| 34170 | XSAQ1=XSAQ |
| 34171 | ISQ1=ISQ |
| 34172 | ISAQ1=ISAQ |
| 34173 | ELSEIF(IPIP.EQ.2)THEN |
| 34174 | XSQ1=XSAQ |
| 34175 | XSAQ1=XSQ |
| 34176 | ISQ1=ISAQ |
| 34177 | ISAQ1=ISQ |
| 34178 | ENDIF |
| 34179 | IDHKT(1) =IPP1 |
| 34180 | ISTHKT(1) =951 |
| 34181 | JMOHKT(1,1)=NC2P |
| 34182 | JMOHKT(2,1)=0 |
| 34183 | JDAHKT(1,1)=3+IIGLU1 |
| 34184 | JDAHKT(2,1)=0 |
| 34185 | C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2) |
| 34186 | PHKT(1,1) =PHKK(1,NC2P) |
| 34187 | PHKT(2,1) =PHKK(2,NC2P) |
| 34188 | PHKT(3,1) =PHKK(3,NC2P) |
| 34189 | PHKT(4,1) =PHKK(4,NC2P) |
| 34190 | C PHKT(5,1) =PHKK(5,NC2P) |
| 34191 | XMIST =(PHKT(4,1)**2- |
| 34192 | * PHKT(3,1)**2-PHKT(2,1)**2- |
| 34193 | *PHKT(1,1)**2) |
| 34194 | IF(XMIST.GT.0.D0)THEN |
| 34195 | PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2- |
| 34196 | *PHKT(1,1)**2) |
| 34197 | ELSE |
| 34198 | C WRITE(LOUT,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST |
| 34199 | PHKT(5,1)=0.D0 |
| 34200 | ENDIF |
| 34201 | VHKT(1,1) =VHKK(1,NC2P) |
| 34202 | VHKT(2,1) =VHKK(2,NC2P) |
| 34203 | VHKT(3,1) =VHKK(3,NC2P) |
| 34204 | VHKT(4,1) =VHKK(4,NC2P) |
| 34205 | WHKT(1,1) =WHKK(1,NC2P) |
| 34206 | WHKT(2,1) =WHKK(2,NC2P) |
| 34207 | WHKT(3,1) =WHKK(3,NC2P) |
| 34208 | WHKT(4,1) =WHKK(4,NC2P) |
| 34209 | C Add here IIGLU1 gluons to this chaina |
| 34210 | PG1=0.D0 |
| 34211 | PG2=0.D0 |
| 34212 | PG3=0.D0 |
| 34213 | PG4=0.D0 |
| 34214 | IF(IIGLU1.GE.1)THEN |
| 34215 | JJG=NC1P |
| 34216 | DO 61 IIG=2,2+IIGLU1-1 |
| 34217 | KKG=JJG+IIG-1 |
| 34218 | IDHKT(IIG) =IDHKK(KKG) |
| 34219 | ISTHKT(IIG) =921 |
| 34220 | JMOHKT(1,IIG)=KKG |
| 34221 | JMOHKT(2,IIG)=0 |
| 34222 | JDAHKT(1,IIG)=3+IIGLU1 |
| 34223 | JDAHKT(2,IIG)=0 |
| 34224 | PHKT(1,IIG)=PHKK(1,KKG) |
| 34225 | PG1=PG1+ PHKT(1,IIG) |
| 34226 | PHKT(2,IIG)=PHKK(2,KKG) |
| 34227 | PG2=PG2+ PHKT(2,IIG) |
| 34228 | PHKT(3,IIG)=PHKK(3,KKG) |
| 34229 | PG3=PG3+ PHKT(3,IIG) |
| 34230 | PHKT(4,IIG)=PHKK(4,KKG) |
| 34231 | PG4=PG4+ PHKT(4,IIG) |
| 34232 | PHKT(5,IIG)=PHKK(5,KKG) |
| 34233 | VHKT(1,IIG) =VHKK(1,KKG) |
| 34234 | VHKT(2,IIG) =VHKK(2,KKG) |
| 34235 | VHKT(3,IIG) =VHKK(3,KKG) |
| 34236 | VHKT(4,IIG) =VHKK(4,KKG) |
| 34237 | WHKT(1,IIG) =WHKK(1,KKG) |
| 34238 | WHKT(2,IIG) =WHKK(2,KKG) |
| 34239 | WHKT(3,IIG) =WHKK(3,KKG) |
| 34240 | WHKT(4,IIG) =WHKK(4,KKG) |
| 34241 | 61 CONTINUE |
| 34242 | ENDIF |
| 34243 | IDHKT(2+IIGLU1) =IP21 |
| 34244 | ISTHKT(2+IIGLU1) =952 |
| 34245 | JMOHKT(1,2+IIGLU1)=NC1T |
| 34246 | JMOHKT(2,2+IIGLU1)=0 |
| 34247 | JDAHKT(1,2+IIGLU1)=3+IIGLU1 |
| 34248 | JDAHKT(2,2+IIGLU1)=0 |
| 34249 | PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1) |
| 34250 | PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1) |
| 34251 | PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1) |
| 34252 | PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1) |
| 34253 | C PHKT(5,2) =PHKK(5,NC1T) |
| 34254 | XMIST =(PHKT(4,2+IIGLU1)**2- |
| 34255 | * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2- |
| 34256 | *PHKT(1,2+IIGLU1)**2) |
| 34257 | IF(XMIST.GT.0.D0)THEN |
| 34258 | PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2- |
| 34259 | * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2- |
| 34260 | *PHKT(1,2+IIGLU1)**2) |
| 34261 | ELSE |
| 34262 | C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST |
| 34263 | PHKT(5,5+IIGLU1)=0.D0 |
| 34264 | ENDIF |
| 34265 | VHKT(1,2+IIGLU1) =VHKK(1,NC1T) |
| 34266 | VHKT(2,2+IIGLU1) =VHKK(2,NC1T) |
| 34267 | VHKT(3,2+IIGLU1) =VHKK(3,NC1T) |
| 34268 | VHKT(4,2+IIGLU1) =VHKK(4,NC1T) |
| 34269 | WHKT(1,2+IIGLU1) =WHKK(1,NC1T) |
| 34270 | WHKT(2,2+IIGLU1) =WHKK(2,NC1T) |
| 34271 | WHKT(3,2+IIGLU1) =WHKK(3,NC1T) |
| 34272 | WHKT(4,2+IIGLU1) =WHKK(4,NC1T) |
| 34273 | IDHKT(3+IIGLU1) =88888 |
| 34274 | ISTHKT(3+IIGLU1) =95 |
| 34275 | JMOHKT(1,3+IIGLU1)=1 |
| 34276 | JMOHKT(2,3+IIGLU1)=2+IIGLU1 |
| 34277 | JDAHKT(1,3+IIGLU1)=0 |
| 34278 | JDAHKT(2,3+IIGLU1)=0 |
| 34279 | PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1 |
| 34280 | PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2 |
| 34281 | PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3 |
| 34282 | PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4 |
| 34283 | XMIST |
| 34284 | * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2 |
| 34285 | * -PHKT(3,3+IIGLU1)**2) |
| 34286 | IF(XMIST.GT.0.D0)THEN |
| 34287 | PHKT(5,3+IIGLU1) |
| 34288 | * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2 |
| 34289 | * -PHKT(3,3+IIGLU1)**2) |
| 34290 | ELSE |
| 34291 | C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST |
| 34292 | PHKT(5,5+IIGLU1)=0.D0 |
| 34293 | ENDIF |
| 34294 | IF(IPIP.GE.2)THEN |
| 34295 | C IF(NUMEV.EQ.-324)THEN |
| 34296 | C WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1), |
| 34297 | C * JDAHKT(1,1), |
| 34298 | C *JDAHKT(2,1),(PHKT(III,1),III=1,5) |
| 34299 | DO 71 IIG=2,2+IIGLU1-1 |
| 34300 | C WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG), |
| 34301 | C & JMOHKT(1,IIG),JMOHKT(2,IIG), |
| 34302 | C * JDAHKT(1,IIG), |
| 34303 | C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) |
| 34304 | 71 CONTINUE |
| 34305 | C WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1), |
| 34306 | C * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1), |
| 34307 | C *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5) |
| 34308 | C WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1), |
| 34309 | C * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1), |
| 34310 | C *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5) |
| 34311 | ENDIF |
| 34312 | CHAMAL=CHAM1 |
| 34313 | IF(IPIP.EQ.1)THEN |
| 34314 | IF(IPP1.LE.-3.OR.IP21.GE.3)CHAMAL=CHAM3 |
| 34315 | ELSEIF(IPIP.EQ.2)THEN |
| 34316 | IF(IPP1.GE.3.OR.IP21.LE.-3)CHAMAL=CHAM3 |
| 34317 | ENDIF |
| 34318 | IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN |
| 34319 | C IREJ=1 |
| 34320 | IPCO=0 |
| 34321 | C RETURN |
| 34322 | C WRITE(LOUT,*)' MUSQBS1 jump back from chain 3' |
| 34323 | GO TO 3466 |
| 34324 | ENDIF |
| 34325 | VHKT(1,3+IIGLU1) =VHKK(1,NC1) |
| 34326 | VHKT(2,3+IIGLU1) =VHKK(2,NC1) |
| 34327 | VHKT(3,3+IIGLU1) =VHKK(3,NC1) |
| 34328 | VHKT(4,3+IIGLU1) =VHKK(4,NC1) |
| 34329 | WHKT(1,3+IIGLU1) =WHKK(1,NC1) |
| 34330 | WHKT(2,3+IIGLU1) =WHKK(2,NC1) |
| 34331 | WHKT(3,3+IIGLU1) =WHKK(3,NC1) |
| 34332 | WHKT(4,3+IIGLU1) =WHKK(4,NC1) |
| 34333 | IF(IPIP.EQ.1)THEN |
| 34334 | IDHKT(4+IIGLU1) =-(ISAQ1-6) |
| 34335 | ELSEIF(IPIP.EQ.2)THEN |
| 34336 | IDHKT(4+IIGLU1) =ISAQ1 |
| 34337 | ENDIF |
| 34338 | ISTHKT(4+IIGLU1) =951 |
| 34339 | JMOHKT(1,4+IIGLU1)=NC1P |
| 34340 | JMOHKT(2,4+IIGLU1)=0 |
| 34341 | JDAHKT(1,4+IIGLU1)=6+IIGLU1 |
| 34342 | JDAHKT(2,4+IIGLU1)=0 |
| 34343 | C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5) |
| 34344 | PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1) |
| 34345 | PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1) |
| 34346 | PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1) |
| 34347 | PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1) |
| 34348 | C PHKT(5,4+IIGLU1) =PHKK(5,NC1P) |
| 34349 | XMIST =(PHKT(4,4+IIGLU1)**2- |
| 34350 | * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2- |
| 34351 | *PHKT(1,4+IIGLU1)**2) |
| 34352 | IF(XMIST.GT.0.D0)THEN |
| 34353 | PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2- |
| 34354 | * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2- |
| 34355 | *PHKT(1,4+IIGLU1)**2) |
| 34356 | ELSE |
| 34357 | C WRITE(LOUT,*)'MUSQBS2 parton 4 mass square LT.0 ',XMIST |
| 34358 | PHKT(5,4+IIGLU1)=0.D0 |
| 34359 | ENDIF |
| 34360 | VHKT(1,4+IIGLU1) =VHKK(1,NC1P) |
| 34361 | VHKT(2,4+IIGLU1) =VHKK(2,NC1P) |
| 34362 | VHKT(3,4+IIGLU1) =VHKK(3,NC1P) |
| 34363 | VHKT(4,4+IIGLU1) =VHKK(4,NC1P) |
| 34364 | WHKT(1,4+IIGLU1) =WHKK(1,NC1P) |
| 34365 | WHKT(2,4+IIGLU1) =WHKK(2,NC1P) |
| 34366 | WHKT(3,4+IIGLU1) =WHKK(3,NC1P) |
| 34367 | WHKT(4,4+IIGLU1) =WHKK(4,NC1P) |
| 34368 | IDHKT(5+IIGLU1) =IP22 |
| 34369 | ISTHKT(5+IIGLU1) =952 |
| 34370 | JMOHKT(1,5+IIGLU1)=NC1T |
| 34371 | JMOHKT(2,5+IIGLU1)=0 |
| 34372 | JDAHKT(1,5+IIGLU1)=6+IIGLU1 |
| 34373 | JDAHKT(2,5+IIGLU1)=0 |
| 34374 | PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1) |
| 34375 | PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1) |
| 34376 | PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1) |
| 34377 | PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1) |
| 34378 | C PHKT(5,5+IIGLU1) =PHKK(5,NC1T) |
| 34379 | XMIST =(PHKT(4,5+IIGLU1)**2- |
| 34380 | * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2- |
| 34381 | *PHKT(1,5+IIGLU1)**2) |
| 34382 | IF(XMIST.GT.0.D0)THEN |
| 34383 | PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2- |
| 34384 | * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2- |
| 34385 | *PHKT(1,5+IIGLU1)**2) |
| 34386 | ELSE |
| 34387 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST |
| 34388 | PHKT(5,5+IIGLU1)=0.D0 |
| 34389 | ENDIF |
| 34390 | VHKT(1,5+IIGLU1) =VHKK(1,NC1T) |
| 34391 | VHKT(2,5+IIGLU1) =VHKK(2,NC1T) |
| 34392 | VHKT(3,5+IIGLU1) =VHKK(3,NC1T) |
| 34393 | VHKT(4,5+IIGLU1) =VHKK(4,NC1T) |
| 34394 | WHKT(1,5+IIGLU1) =WHKK(1,NC1T) |
| 34395 | WHKT(2,5+IIGLU1) =WHKK(2,NC1T) |
| 34396 | WHKT(3,5+IIGLU1) =WHKK(3,NC1T) |
| 34397 | WHKT(4,5+IIGLU1) =WHKK(4,NC1T) |
| 34398 | IDHKT(6+IIGLU1) =88888 |
| 34399 | ISTHKT(6+IIGLU1) =95 |
| 34400 | JMOHKT(1,6+IIGLU1)=4+IIGLU1 |
| 34401 | JMOHKT(2,6+IIGLU1)=5+IIGLU1 |
| 34402 | JDAHKT(1,6+IIGLU1)=0 |
| 34403 | JDAHKT(2,6+IIGLU1)=0 |
| 34404 | PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1) |
| 34405 | PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1) |
| 34406 | PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1) |
| 34407 | PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1) |
| 34408 | XMIST |
| 34409 | * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2 |
| 34410 | * -PHKT(3,6+IIGLU1)**2) |
| 34411 | IF(XMIST.GT.0.D0)THEN |
| 34412 | PHKT(5,6+IIGLU1) |
| 34413 | * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2 |
| 34414 | * -PHKT(3,6+IIGLU1)**2) |
| 34415 | ELSE |
| 34416 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST |
| 34417 | PHKT(5,5+IIGLU1)=0.D0 |
| 34418 | ENDIF |
| 34419 | C IF(IPIP.GE.2)THEN |
| 34420 | C IF(NUMEV.EQ.-324)THEN |
| 34421 | C WRITE(6,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1), |
| 34422 | C * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1), |
| 34423 | C *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5) |
| 34424 | C WRITE(6,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1), |
| 34425 | C * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1), |
| 34426 | C *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5) |
| 34427 | C WRITE(6,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1), |
| 34428 | C * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1), |
| 34429 | C *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5) |
| 34430 | C ENDIF |
| 34431 | CHAMAL=CHAM1 |
| 34432 | IF(IPIP.EQ.1)THEN |
| 34433 | IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3 |
| 34434 | ELSEIF(IPIP.EQ.2)THEN |
| 34435 | IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3 |
| 34436 | ENDIF |
| 34437 | IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN |
| 34438 | C IREJ=1 |
| 34439 | IPCO=0 |
| 34440 | C RETURN |
| 34441 | C WRITE(6,*)' MUSQBS1 jump back from chain 6', |
| 34442 | C * CHAMAL,PHKT(5,6+IIGLU1) |
| 34443 | GO TO 3466 |
| 34444 | ENDIF |
| 34445 | VHKT(1,6+IIGLU1) =VHKK(1,NC1) |
| 34446 | VHKT(2,6+IIGLU1) =VHKK(2,NC1) |
| 34447 | VHKT(3,6+IIGLU1) =VHKK(3,NC1) |
| 34448 | VHKT(4,6+IIGLU1) =VHKK(4,NC1) |
| 34449 | WHKT(1,6+IIGLU1) =WHKK(1,NC1) |
| 34450 | WHKT(2,6+IIGLU1) =WHKK(2,NC1) |
| 34451 | WHKT(3,6+IIGLU1) =WHKK(3,NC1) |
| 34452 | WHKT(4,6+IIGLU1) =WHKK(4,NC1) |
| 34453 | C IDHKT(7) =1000*IPP1+100*ISQ+1 |
| 34454 | IDHKT(7+IIGLU1) =IP1 |
| 34455 | ISTHKT(7+IIGLU1) =951 |
| 34456 | JMOHKT(1,7+IIGLU1)=NC1P |
| 34457 | JMOHKT(2,7+IIGLU1)=0 |
| 34458 | **NEW |
| 34459 | C JDAHKT(1,7+IIGLU1)=9+IIGLU1 |
| 34460 | JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2 |
| 34461 | ** |
| 34462 | JDAHKT(2,7+IIGLU1)=0 |
| 34463 | PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1) |
| 34464 | PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1) |
| 34465 | PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1) |
| 34466 | PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1) |
| 34467 | C PHKT(5,7+IIGLU1) =PHKK(5,NC1P) |
| 34468 | XMIST =(PHKT(4,7+IIGLU1)**2- |
| 34469 | * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2- |
| 34470 | *PHKT(1,7+IIGLU1)**2) |
| 34471 | IF(XMIST.GT.0.D0)THEN |
| 34472 | PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2- |
| 34473 | * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2- |
| 34474 | *PHKT(1,7+IIGLU1)**2) |
| 34475 | ELSE |
| 34476 | C WRITE(6,*)'MUSQBS2 parton 7 mass square LT.0 ',XMIST |
| 34477 | PHKT(5,7+IIGLU1)=0.D0 |
| 34478 | ENDIF |
| 34479 | VHKT(1,7+IIGLU1) =VHKK(1,NC1P) |
| 34480 | VHKT(2,7+IIGLU1) =VHKK(2,NC1P) |
| 34481 | VHKT(3,7+IIGLU1) =VHKK(3,NC1P) |
| 34482 | VHKT(4,7+IIGLU1) =VHKK(4,NC1P) |
| 34483 | WHKT(1,7+IIGLU1) =WHKK(1,NC1P) |
| 34484 | WHKT(2,7+IIGLU1) =WHKK(2,NC1P) |
| 34485 | WHKT(3,7+IIGLU1) =WHKK(3,NC1P) |
| 34486 | WHKT(4,7+IIGLU1) =WHKK(4,NC2P) |
| 34487 | C Insert here the IIGLU2 gluons |
| 34488 | PG1=0.D0 |
| 34489 | PG2=0.D0 |
| 34490 | PG3=0.D0 |
| 34491 | PG4=0.D0 |
| 34492 | IF(IIGLU2.GE.1)THEN |
| 34493 | JJG=NC2P |
| 34494 | DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 |
| 34495 | KKG=JJG+IIG-7-IIGLU1 |
| 34496 | IDHKT(IIG) =IDHKK(KKG) |
| 34497 | ISTHKT(IIG) =921 |
| 34498 | JMOHKT(1,IIG)=KKG |
| 34499 | JMOHKT(2,IIG)=0 |
| 34500 | JDAHKT(1,IIG)=9+IIGLU1+IIGLU2 |
| 34501 | JDAHKT(2,IIG)=0 |
| 34502 | PHKT(1,IIG)=PHKK(1,KKG) |
| 34503 | PG1=PG1+ PHKT(1,IIG) |
| 34504 | PHKT(2,IIG)=PHKK(2,KKG) |
| 34505 | PG2=PG2+ PHKT(2,IIG) |
| 34506 | PHKT(3,IIG)=PHKK(3,KKG) |
| 34507 | PG3=PG3+ PHKT(3,IIG) |
| 34508 | PHKT(4,IIG)=PHKK(4,KKG) |
| 34509 | PG4=PG4+ PHKT(4,IIG) |
| 34510 | PHKT(5,IIG)=PHKK(5,KKG) |
| 34511 | VHKT(1,IIG) =VHKK(1,KKG) |
| 34512 | VHKT(2,IIG) =VHKK(2,KKG) |
| 34513 | VHKT(3,IIG) =VHKK(3,KKG) |
| 34514 | VHKT(4,IIG) =VHKK(4,KKG) |
| 34515 | WHKT(1,IIG) =WHKK(1,KKG) |
| 34516 | WHKT(2,IIG) =WHKK(2,KKG) |
| 34517 | WHKT(3,IIG) =WHKK(3,KKG) |
| 34518 | WHKT(4,IIG) =WHKK(4,KKG) |
| 34519 | 81 CONTINUE |
| 34520 | ENDIF |
| 34521 | IF(IPIP.EQ.1)THEN |
| 34522 | IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3 |
| 34523 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103 |
| 34524 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103 |
| 34525 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203 |
| 34526 | ELSEIF(IPIP.EQ.2)THEN |
| 34527 | IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3 |
| 34528 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103 |
| 34529 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103 |
| 34530 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203 |
| 34531 | ENDIF |
| 34532 | ISTHKT(8+IIGLU1+IIGLU2) =952 |
| 34533 | JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T |
| 34534 | JMOHKT(2,8+IIGLU1+IIGLU2)=0 |
| 34535 | JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2 |
| 34536 | JDAHKT(2,8+IIGLU1+IIGLU2)=0 |
| 34537 | PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC2T)+ |
| 34538 | * PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1) |
| 34539 | PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC2T)+ |
| 34540 | * PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1) |
| 34541 | PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC2T)+ |
| 34542 | * PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1) |
| 34543 | PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC2T)+ |
| 34544 | * PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1) |
| 34545 | C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)', |
| 34546 | C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7) |
| 34547 | IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN |
| 34548 | C IREJ=1 |
| 34549 | C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)' |
| 34550 | C * ,PHKT(4,8+IIGLU1+IIGLU2), PHKK(4,NC2T),NC2T |
| 34551 | IPCO=0 |
| 34552 | C RETURN |
| 34553 | GO TO 3466 |
| 34554 | ENDIF |
| 34555 | C PHKT(5,8) =PHKK(5,NC2T) |
| 34556 | XMIST =(PHKT(4,8+IIGLU1+IIGLU2)**2- |
| 34557 | * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2- |
| 34558 | *PHKT(1,8+IIGLU1+IIGLU2)**2) |
| 34559 | IF(XMIST.GT.0.D0)THEN |
| 34560 | PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2- |
| 34561 | * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2- |
| 34562 | *PHKT(1,8+IIGLU1+IIGLU2)**2) |
| 34563 | ELSE |
| 34564 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST |
| 34565 | PHKT(5,5+IIGLU1)=0.D0 |
| 34566 | ENDIF |
| 34567 | VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T) |
| 34568 | VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T) |
| 34569 | VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T) |
| 34570 | VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T) |
| 34571 | WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T) |
| 34572 | WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T) |
| 34573 | WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T) |
| 34574 | WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T) |
| 34575 | IDHKT(9+IIGLU1+IIGLU2) =88888 |
| 34576 | ISTHKT(9+IIGLU1+IIGLU2) =95 |
| 34577 | JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1 |
| 34578 | JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2 |
| 34579 | JDAHKT(1,9+IIGLU1+IIGLU2)=0 |
| 34580 | JDAHKT(2,9+IIGLU1+IIGLU2)=0 |
| 34581 | **NEW |
| 34582 | C PHKT(1,9+IIGLU1+IIGLU2) |
| 34583 | C * =PHKT(1,7+IIGLU1+IIGLU2)+PHKT(1,8+IIGLU1+IIGLU2)+PG1 |
| 34584 | C PHKT(2,9+IIGLU1+IIGLU2) |
| 34585 | C * =PHKT(2,7+IIGLU1+IIGLU2)+PHKT(2,8+IIGLU1+IIGLU2)+PG2 |
| 34586 | C PHKT(3,9+IIGLU1+IIGLU2) |
| 34587 | C * =PHKT(3,7+IIGLU1+IIGLU2)+PHKT(3,8+IIGLU1+IIGLU2)+PG3 |
| 34588 | C PHKT(4,9+IIGLU1+IIGLU2) |
| 34589 | C * =PHKT(4,7+IIGLU1+IIGLU2)+PHKT(4,8+IIGLU1+IIGLU2)+PG4 |
| 34590 | PHKT(1,9+IIGLU1+IIGLU2) |
| 34591 | * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1 |
| 34592 | PHKT(2,9+IIGLU1+IIGLU2) |
| 34593 | * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2 |
| 34594 | PHKT(3,9+IIGLU1+IIGLU2) |
| 34595 | * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3 |
| 34596 | PHKT(4,9+IIGLU1+IIGLU2) |
| 34597 | * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4 |
| 34598 | ** |
| 34599 | XMIST |
| 34600 | * =(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2 |
| 34601 | * -PHKT(2,9+IIGLU1+IIGLU2)**2 |
| 34602 | * -PHKT(3,9+IIGLU1+IIGLU2)**2) |
| 34603 | IF(XMIST.GT.0.D0)THEN |
| 34604 | PHKT(5,9+IIGLU1+IIGLU2) |
| 34605 | * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2 |
| 34606 | * -PHKT(2,9+IIGLU1+IIGLU2)**2 |
| 34607 | * -PHKT(3,9+IIGLU1+IIGLU2)**2) |
| 34608 | ELSE |
| 34609 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST |
| 34610 | PHKT(5,5+IIGLU1)=0.D0 |
| 34611 | ENDIF |
| 34612 | IF(IPIP.GE.2)THEN |
| 34613 | C IF(NUMEV.EQ.-324)THEN |
| 34614 | C WRITE(6,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1), |
| 34615 | C * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1), |
| 34616 | C *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5) |
| 34617 | C DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 |
| 34618 | C WRITE(6,*)IIG,ISTHKT(IIG),IDHKT(IIG),JMOHKT(1,IIG),JMOHKT(2,IIG), |
| 34619 | C * JDAHKT(1,IIG), |
| 34620 | C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) |
| 34621 | C 91 CONTINUE |
| 34622 | C WRITE(6,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2), |
| 34623 | C * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2), |
| 34624 | C *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2), |
| 34625 | C *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5) |
| 34626 | C WRITE(6,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2), |
| 34627 | C * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2), |
| 34628 | C *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2), |
| 34629 | C *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5) |
| 34630 | ENDIF |
| 34631 | CHAMAL=CHAB1 |
| 34632 | IF(IPIP.EQ.1)THEN |
| 34633 | IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3 |
| 34634 | ELSEIF(IPIP.EQ.2)THEN |
| 34635 | IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3 |
| 34636 | ENDIF |
| 34637 | IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN |
| 34638 | C IREJ=1 |
| 34639 | IPCO=0 |
| 34640 | C RETURN |
| 34641 | C WRITE(6,*)' MUSQBS1 jump back from chain 9', |
| 34642 | C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2) |
| 34643 | GO TO 3466 |
| 34644 | ENDIF |
| 34645 | VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1) |
| 34646 | VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1) |
| 34647 | VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1) |
| 34648 | VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1) |
| 34649 | WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1) |
| 34650 | WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1) |
| 34651 | WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1) |
| 34652 | WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1) |
| 34653 | C |
| 34654 | IPCO=0 |
| 34655 | IGCOUN=9+IIGLU1+IIGLU2 |
| 34656 | RETURN |
| 34657 | END |
| 34658 | C |
| 34659 | C |
| 34660 | C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| 34661 | SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, |
| 34662 | * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,ISQ,IGCOUN) |
| 34663 | C |
| 34664 | C GSQBS-2 diagram (split target diquark) |
| 34665 | C |
| 34666 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 34667 | SAVE |
| 34668 | |
| 34669 | PARAMETER ( LINP = 5 , |
| 34670 | & LOUT = 6 , |
| 34671 | & LDAT = 9 ) |
| 34672 | |
| 34673 | * event history |
| 34674 | |
| 34675 | PARAMETER (NMXHKK=200000) |
| 34676 | |
| 34677 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 34678 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 34679 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 34680 | * extended event history |
| 34681 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 34682 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 34683 | & IHIST(2,NMXHKK) |
| 34684 | * Lorentz-parameters of the current interaction |
| 34685 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, |
| 34686 | & UMO,PPCM,EPROJ,PPROJ |
| 34687 | * diquark-breaking mechanism |
| 34688 | COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3 |
| 34689 | |
| 34690 | C |
| 34691 | PARAMETER (NTMHKK= 300) |
| 34692 | COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT |
| 34693 | +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT |
| 34694 | +(4,NTMHKK) |
| 34695 | |
| 34696 | *KEEP,XSEADI. |
| 34697 | COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA, |
| 34698 | +SSMIMQ,VVMTHR |
| 34699 | *KEEP,DPRIN. |
| 34700 | COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR |
| 34701 | C |
| 34702 | C GSQBS-2 diagram (split target diquark) |
| 34703 | C |
| 34704 | C |
| 34705 | C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T) |
| 34706 | C Input chain 2(NC2) valence-diquark(NC2P)-sea-quark(NC2T) |
| 34707 | C |
| 34708 | C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T |
| 34709 | C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T |
| 34710 | C |
| 34711 | C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2) |
| 34712 | C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5) |
| 34713 | C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8) |
| 34714 | C |
| 34715 | C |
| 34716 | C |
| 34717 | C Put new chains into COMMON /HKKTMP/ |
| 34718 | C |
| 34719 | IIGLU1=NC1T-NC1P-1 |
| 34720 | IIGLU2=NC2T-NC2P-1 |
| 34721 | IGCOUN=0 |
| 34722 | C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2 |
| 34723 | CVQ=1.D0 |
| 34724 | IREJ=0 |
| 34725 | C IF(IPIP.EQ.2)THEN |
| 34726 | C WRITE(6,*)' MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,', |
| 34727 | C * 'IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN)', |
| 34728 | C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, |
| 34729 | C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN |
| 34730 | C ENDIF |
| 34731 | C |
| 34732 | C |
| 34733 | C |
| 34734 | C determine x-values of NC1T diquark |
| 34735 | XDIQT=PHKK(4,NC1T)*2.D0/UMO |
| 34736 | XVQP=PHKK(4,NC1P)*2.D0/UMO |
| 34737 | C |
| 34738 | C determine x-values of sea quark pair |
| 34739 | C |
| 34740 | IPCO=1 |
| 34741 | ICOU=0 |
| 34742 | 2234 CONTINUE |
| 34743 | ICOU=ICOU+1 |
| 34744 | IF(ICOU.GE.500)THEN |
| 34745 | IREJ=1 |
| 34746 | IF(ISQ.EQ.3)IREJ=3 |
| 34747 | IF(IPCO.GE.3) |
| 34748 | & WRITE(LOUT,*)' MGSQBS2 Rejection 2234 ICOU. GT.500' |
| 34749 | IPCO=0 |
| 34750 | RETURN |
| 34751 | ENDIF |
| 34752 | IF(IPCO.GE.3) |
| 34753 | & WRITE(LOUT,*)'MGSQBS2 call XSEAPA: UMO,XDIQT,XVQP ', |
| 34754 | * UMO, XDIQT,XVQP |
| 34755 | XSQ=0.D0 |
| 34756 | XSAQ=0.D0 |
| 34757 | **NEW |
| 34758 | C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ) |
| 34759 | IF (IPIP.EQ.1) THEN |
| 34760 | XQMAX = XDIQT/2.0D0 |
| 34761 | XAQMAX = 2.D0*XVQP/3.0D0 |
| 34762 | ELSE |
| 34763 | XQMAX = 2.D0*XVQP/3.0D0 |
| 34764 | XAQMAX = XDIQT/2.0D0 |
| 34765 | ENDIF |
| 34766 | CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ) |
| 34767 | ISAQ = 6+ISQ |
| 34768 | C write(*,*) 'MGSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP |
| 34769 | ** |
| 34770 | IF(IPCO.GE.3) |
| 34771 | & WRITE(LOUT,*)'MGSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ |
| 34772 | IF(IREJ.GE.1)THEN |
| 34773 | IF(IPCO.GE.3) |
| 34774 | & WRITE(LOUT,*)'MGSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ |
| 34775 | IPCO=0 |
| 34776 | RETURN |
| 34777 | ENDIF |
| 34778 | IF(IPIP.EQ.1)THEN |
| 34779 | IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234 |
| 34780 | ELSEIF(IPIP.EQ.2)THEN |
| 34781 | IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234 |
| 34782 | ENDIF |
| 34783 | IF(IPCO.GE.3)THEN |
| 34784 | WRITE(LOUT,'(A,4E12.4)')' MGSQBS2 XDIQT,XVQP,XSQ,XSAQ ', |
| 34785 | * XDIQT,XVQP,XSQ,XSAQ |
| 34786 | ENDIF |
| 34787 | C |
| 34788 | C subtract xsq,xsaq from NC1T diquark and NC1P quark |
| 34789 | C |
| 34790 | C XSQ=0.D0 |
| 34791 | IF(IPIP.EQ.1)THEN |
| 34792 | XDIQT=XDIQT-XSQ |
| 34793 | XVQP =XVQP -XSAQ |
| 34794 | ELSEIF(IPIP.EQ.2)THEN |
| 34795 | XDIQT=XDIQT-XSAQ |
| 34796 | XVQP =XVQP -XSQ |
| 34797 | ENDIF |
| 34798 | IF(IPCO.GE.3) |
| 34799 | & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP |
| 34800 | C |
| 34801 | C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T |
| 34802 | C |
| 34803 | XVTHRO=CVQ/UMO |
| 34804 | IVTHR=0 |
| 34805 | 3466 CONTINUE |
| 34806 | IF(IVTHR.EQ.10)THEN |
| 34807 | IREJ=1 |
| 34808 | IF(ISQ.EQ.3)IREJ=3 |
| 34809 | IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 3466 reject IVTHR 10' |
| 34810 | IPCO=0 |
| 34811 | RETURN |
| 34812 | ENDIF |
| 34813 | IVTHR=IVTHR+1 |
| 34814 | XVTHR=XVTHRO/(201-IVTHR) |
| 34815 | UNOPRV=UNON |
| 34816 | 380 CONTINUE |
| 34817 | IF(XVTHR.GT.0.66D0*XDIQT)THEN |
| 34818 | IREJ=1 |
| 34819 | IF(ISQ.EQ.3)IREJ=3 |
| 34820 | IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 Rejection 380 XVTHR large ', |
| 34821 | * XVTHR |
| 34822 | IPCO=0 |
| 34823 | RETURN |
| 34824 | ENDIF |
| 34825 | IF(DT_RNDM(V).LT.0.5D0)THEN |
| 34826 | XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT) |
| 34827 | XVTQII=XDIQT-XVTQI |
| 34828 | ELSE |
| 34829 | XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT) |
| 34830 | XVTQI=XDIQT-XVTQII |
| 34831 | ENDIF |
| 34832 | IF(IPCO.GE.3)THEN |
| 34833 | WRITE(LOUT,'(A,2E12.4)')' MGSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII |
| 34834 | ENDIF |
| 34835 | C |
| 34836 | C Prepare 4 momenta of new chains and chain ends |
| 34837 | C |
| 34838 | C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT |
| 34839 | C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT |
| 34840 | C +(4,NTMHKK) |
| 34841 | C |
| 34842 | C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2) |
| 34843 | C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5) |
| 34844 | C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8) |
| 34845 | C |
| 34846 | C SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, |
| 34847 | C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IGCOUN) |
| 34848 | C |
| 34849 | IF(IPIP.EQ.1)THEN |
| 34850 | XSQ1=XSQ |
| 34851 | XSAQ1=XSAQ |
| 34852 | ISQ1=ISQ |
| 34853 | ISAQ1=ISAQ |
| 34854 | ELSEIF(IPIP.EQ.2)THEN |
| 34855 | XSQ1=XSAQ |
| 34856 | XSAQ1=XSQ |
| 34857 | ISQ1=ISAQ |
| 34858 | ISAQ1=ISQ |
| 34859 | ENDIF |
| 34860 | KK11=IP21 |
| 34861 | C IDHKT(1) =1000*IPP11+100*IPP12+1 |
| 34862 | KK21=IPP11 |
| 34863 | KK22=IPP12 |
| 34864 | XGIVE=0.D0 |
| 34865 | IF(IPIP.EQ.1)THEN |
| 34866 | IDHKT(4+IIGLU1) =-(ISAQ1-6) |
| 34867 | ELSEIF(IPIP.EQ.2)THEN |
| 34868 | IDHKT(4+IIGLU1) =ISAQ1 |
| 34869 | ENDIF |
| 34870 | ISTHKT(4+IIGLU1) =961 |
| 34871 | JMOHKT(1,4+IIGLU1)=NC1P |
| 34872 | JMOHKT(2,4+IIGLU1)=0 |
| 34873 | JDAHKT(1,4+IIGLU1)=6+IIGLU1 |
| 34874 | JDAHKT(2,4+IIGLU1)=0 |
| 34875 | C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5) |
| 34876 | PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1) |
| 34877 | PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1) |
| 34878 | PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1) |
| 34879 | PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1) |
| 34880 | C PHKT(5,4+IIGLU1) =PHKK(5,NC1P) |
| 34881 | XXMIST=(PHKT(4,4+IIGLU1)**2- |
| 34882 | * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2- |
| 34883 | *PHKT(1,4+IIGLU1)**2) |
| 34884 | IF(XXMIST.GT.0.D0)THEN |
| 34885 | PHKT(5,4+IIGLU1) =SQRT(XXMIST) |
| 34886 | ELSE |
| 34887 | WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST |
| 34888 | XXMIST=ABS(XXMIST) |
| 34889 | PHKT(5,4+IIGLU1) =SQRT(XXMIST) |
| 34890 | ENDIF |
| 34891 | VHKT(1,4+IIGLU1) =VHKK(1,NC1P) |
| 34892 | VHKT(2,4+IIGLU1) =VHKK(2,NC1P) |
| 34893 | VHKT(3,4+IIGLU1) =VHKK(3,NC1P) |
| 34894 | VHKT(4,4+IIGLU1) =VHKK(4,NC1P) |
| 34895 | WHKT(1,4+IIGLU1) =WHKK(1,NC1P) |
| 34896 | WHKT(2,4+IIGLU1) =WHKK(2,NC1P) |
| 34897 | WHKT(3,4+IIGLU1) =WHKK(3,NC1P) |
| 34898 | WHKT(4,4+IIGLU1) =WHKK(4,NC1P) |
| 34899 | IDHKT(5+IIGLU1) =IP22 |
| 34900 | ISTHKT(5+IIGLU1) =962 |
| 34901 | JMOHKT(1,5+IIGLU1)=NC1T |
| 34902 | JMOHKT(2,5+IIGLU1)=0 |
| 34903 | JDAHKT(1,5+IIGLU1)=6+IIGLU1 |
| 34904 | JDAHKT(2,5+IIGLU1)=0 |
| 34905 | PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1) |
| 34906 | PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1) |
| 34907 | PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1) |
| 34908 | PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1) |
| 34909 | C PHKT(5,5+IIGLU1) =PHKK(5,NC1T) |
| 34910 | XXMIST=(PHKT(4,5+IIGLU1)**2- |
| 34911 | * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2- |
| 34912 | *PHKT(1,5+IIGLU1)**2) |
| 34913 | IF(XXMIST.GT.0.D0)THEN |
| 34914 | PHKT(5,5+IIGLU1) =SQRT(XXMIST) |
| 34915 | ELSE |
| 34916 | WRITE(LOUT,*)' MGSQBS2 XXMIST', XXMIST |
| 34917 | XXMIST=ABS(XXMIST) |
| 34918 | PHKT(5,5+IIGLU1) =SQRT(XXMIST) |
| 34919 | ENDIF |
| 34920 | VHKT(1,5+IIGLU1) =VHKK(1,NC1T) |
| 34921 | VHKT(2,5+IIGLU1) =VHKK(2,NC1T) |
| 34922 | VHKT(3,5+IIGLU1) =VHKK(3,NC1T) |
| 34923 | VHKT(4,5+IIGLU1) =VHKK(4,NC1T) |
| 34924 | WHKT(1,5+IIGLU1) =WHKK(1,NC1T) |
| 34925 | WHKT(2,5+IIGLU1) =WHKK(2,NC1T) |
| 34926 | WHKT(3,5+IIGLU1) =WHKK(3,NC1T) |
| 34927 | WHKT(4,5+IIGLU1) =WHKK(4,NC1T) |
| 34928 | IDHKT(6+IIGLU1) =88888 |
| 34929 | ISTHKT(6+IIGLU1) =96 |
| 34930 | JMOHKT(1,6+IIGLU1)=4+IIGLU1 |
| 34931 | JMOHKT(2,6+IIGLU1)=5+IIGLU1 |
| 34932 | JDAHKT(1,6+IIGLU1)=0 |
| 34933 | JDAHKT(2,6+IIGLU1)=0 |
| 34934 | PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1) |
| 34935 | PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1) |
| 34936 | PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1) |
| 34937 | PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1) |
| 34938 | PHKT(5,6+IIGLU1) |
| 34939 | * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2 |
| 34940 | * -PHKT(3,6+IIGLU1)**2) |
| 34941 | CHAMAL=CHAM1 |
| 34942 | IF(IPIP.EQ.1)THEN |
| 34943 | IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3 |
| 34944 | ELSEIF(IPIP.EQ.2)THEN |
| 34945 | IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3 |
| 34946 | ENDIF |
| 34947 | C--------------------------------------------------- |
| 34948 | IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN |
| 34949 | IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN |
| 34950 | C we drop chain 6 and give the energy to chain 3 |
| 34951 | IDHKT(6+IIGLU1)=22888 |
| 34952 | XGIVE=1.D0 |
| 34953 | C WRITE(6,*)' drop chain 6 xgive=1' |
| 34954 | GO TO 7788 |
| 34955 | ELSEIF(IDHKT(4+IIGLU1).EQ.-IP21)THEN |
| 34956 | C we drop chain 6 and give the energy to chain 3 |
| 34957 | C and change KK11 to IDHKT(5) |
| 34958 | IDHKT(6+IIGLU1)=22888 |
| 34959 | XGIVE=1.D0 |
| 34960 | C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(5)' |
| 34961 | KK11=IDHKT(5+IIGLU1) |
| 34962 | GO TO 7788 |
| 34963 | ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP11)THEN |
| 34964 | C we drop chain 6 and give the energy to chain 3 |
| 34965 | C and change KK21 to IDHKT(5+IIGLU1) |
| 34966 | C IDHKT(1) =1000*IPP11+100*IPP12+1 |
| 34967 | IDHKT(6+IIGLU1)=22888 |
| 34968 | XGIVE=1.D0 |
| 34969 | C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(5+IIGLU1)' |
| 34970 | KK21=IDHKT(5+IIGLU1) |
| 34971 | GO TO 7788 |
| 34972 | ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP12)THEN |
| 34973 | C we drop chain 6 and give the energy to chain 3 |
| 34974 | C and change KK22 to IDHKT(5) |
| 34975 | C IDHKT(1) =1000*IPP11+100*IPP12+1 |
| 34976 | IDHKT(6+IIGLU1)=22888 |
| 34977 | XGIVE=1.D0 |
| 34978 | C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(5+IIGLU1)' |
| 34979 | KK22=IDHKT(5+IIGLU1) |
| 34980 | GO TO 7788 |
| 34981 | ENDIF |
| 34982 | C IREJ=1 |
| 34983 | IPCO=0 |
| 34984 | C RETURN |
| 34985 | GO TO 3466 |
| 34986 | ENDIF |
| 34987 | 7788 CONTINUE |
| 34988 | C--------------------------------------------------- |
| 34989 | IF(IPIP.GE.3)THEN |
| 34990 | WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1), |
| 34991 | * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1), |
| 34992 | *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5) |
| 34993 | WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1), |
| 34994 | * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1), |
| 34995 | *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5) |
| 34996 | WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1), |
| 34997 | * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1), |
| 34998 | *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5) |
| 34999 | ENDIF |
| 35000 | VHKT(1,6+IIGLU1) =VHKK(1,NC1) |
| 35001 | VHKT(2,6+IIGLU1) =VHKK(2,NC1) |
| 35002 | VHKT(3,6+IIGLU1) =VHKK(3,NC1) |
| 35003 | VHKT(4,6+IIGLU1) =VHKK(4,NC1) |
| 35004 | WHKT(1,6+IIGLU1) =WHKK(1,NC1) |
| 35005 | WHKT(2,6+IIGLU1) =WHKK(2,NC1) |
| 35006 | WHKT(3,6+IIGLU1) =WHKK(3,NC1) |
| 35007 | WHKT(4,6+IIGLU1) =WHKK(4,NC1) |
| 35008 | C IDHKT(1) =1000*IPP11+100*IPP12+1 |
| 35009 | IF(IPIP.EQ.1)THEN |
| 35010 | IDHKT(1) =1000*KK21+100*KK22+3 |
| 35011 | IF(IDHKT(1).EQ.1203)IDHKT(1)=2103 |
| 35012 | IF(IDHKT(1).EQ.1303)IDHKT(1)=3103 |
| 35013 | IF(IDHKT(1).EQ.2303)IDHKT(1)=3203 |
| 35014 | ELSEIF(IPIP.EQ.2)THEN |
| 35015 | IDHKT(1) =1000*KK21+100*KK22-3 |
| 35016 | IF(IDHKT(1).EQ.-1203)IDHKT(1)=-2103 |
| 35017 | IF(IDHKT(1).EQ.-1303)IDHKT(1)=-3103 |
| 35018 | IF(IDHKT(1).EQ.-2303)IDHKT(1)=-3203 |
| 35019 | ENDIF |
| 35020 | ISTHKT(1) =961 |
| 35021 | JMOHKT(1,1)=NC2P |
| 35022 | JMOHKT(2,1)=0 |
| 35023 | JDAHKT(1,1)=3+IIGLU1 |
| 35024 | JDAHKT(2,1)=0 |
| 35025 | C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2) |
| 35026 | PHKT(1,1) =PHKK(1,NC2P) |
| 35027 | *+XGIVE*PHKT(1,4+IIGLU1) |
| 35028 | PHKT(2,1) =PHKK(2,NC2P) |
| 35029 | *+XGIVE*PHKT(2,4+IIGLU1) |
| 35030 | PHKT(3,1) =PHKK(3,NC2P) |
| 35031 | *+XGIVE*PHKT(3,4+IIGLU1) |
| 35032 | PHKT(4,1) =PHKK(4,NC2P) |
| 35033 | *+XGIVE*PHKT(4,4+IIGLU1) |
| 35034 | C PHKT(5,1) =PHKK(5,NC2P) |
| 35035 | XXMIST=PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2- |
| 35036 | *PHKT(1,1)**2 |
| 35037 | IF(XXMIST.GT.0.D0)THEN |
| 35038 | PHKT(5,1) =SQRT(XXMIST) |
| 35039 | ELSE |
| 35040 | WRITE(LOUT,*)'MGSQBS2',XXMIST |
| 35041 | XXMIST=ABS(XXMIST) |
| 35042 | PHKT(5,1) =SQRT(XXMIST) |
| 35043 | ENDIF |
| 35044 | VHKT(1,1) =VHKK(1,NC2P) |
| 35045 | VHKT(2,1) =VHKK(2,NC2P) |
| 35046 | VHKT(3,1) =VHKK(3,NC2P) |
| 35047 | VHKT(4,1) =VHKK(4,NC2P) |
| 35048 | WHKT(1,1) =WHKK(1,NC2P) |
| 35049 | WHKT(2,1) =WHKK(2,NC2P) |
| 35050 | WHKT(3,1) =WHKK(3,NC2P) |
| 35051 | WHKT(4,1) =WHKK(4,NC2P) |
| 35052 | C Add here IIGLU1 gluons to this chaina |
| 35053 | PG1=0.D0 |
| 35054 | PG2=0.D0 |
| 35055 | PG3=0.D0 |
| 35056 | PG4=0.D0 |
| 35057 | IF(IIGLU1.GE.1)THEN |
| 35058 | JJG=NC1P |
| 35059 | DO 61 IIG=2,2+IIGLU1-1 |
| 35060 | KKG=JJG+IIG-1 |
| 35061 | IDHKT(IIG) =IDHKK(KKG) |
| 35062 | ISTHKT(IIG) =921 |
| 35063 | JMOHKT(1,IIG)=KKG |
| 35064 | JMOHKT(2,IIG)=0 |
| 35065 | JDAHKT(1,IIG)=3+IIGLU1 |
| 35066 | JDAHKT(2,IIG)=0 |
| 35067 | PHKT(1,IIG)=PHKK(1,KKG) |
| 35068 | PG1=PG1+ PHKT(1,IIG) |
| 35069 | PHKT(2,IIG)=PHKK(2,KKG) |
| 35070 | PG2=PG2+ PHKT(2,IIG) |
| 35071 | PHKT(3,IIG)=PHKK(3,KKG) |
| 35072 | PG3=PG3+ PHKT(3,IIG) |
| 35073 | PHKT(4,IIG)=PHKK(4,KKG) |
| 35074 | PG4=PG4+ PHKT(4,IIG) |
| 35075 | PHKT(5,IIG)=PHKK(5,KKG) |
| 35076 | VHKT(1,IIG) =VHKK(1,KKG) |
| 35077 | VHKT(2,IIG) =VHKK(2,KKG) |
| 35078 | VHKT(3,IIG) =VHKK(3,KKG) |
| 35079 | VHKT(4,IIG) =VHKK(4,KKG) |
| 35080 | WHKT(1,IIG) =WHKK(1,KKG) |
| 35081 | WHKT(2,IIG) =WHKK(2,KKG) |
| 35082 | WHKT(3,IIG) =WHKK(3,KKG) |
| 35083 | WHKT(4,IIG) =WHKK(4,KKG) |
| 35084 | 61 CONTINUE |
| 35085 | ENDIF |
| 35086 | C IDHKT(2) =IP21 |
| 35087 | IDHKT(2+IIGLU1) =KK11 |
| 35088 | ISTHKT(2+IIGLU1) =962 |
| 35089 | JMOHKT(1,2+IIGLU1)=NC1T |
| 35090 | JMOHKT(2,2+IIGLU1)=0 |
| 35091 | JDAHKT(1,2+IIGLU1)=3+IIGLU1 |
| 35092 | JDAHKT(2,2+IIGLU1)=0 |
| 35093 | PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1) |
| 35094 | C * +0.5D0*PHKK(1,NC2T) |
| 35095 | *+XGIVE*PHKT(1,5+IIGLU1) |
| 35096 | PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1) |
| 35097 | C *+0.5D0*PHKK(2,NC2T) |
| 35098 | *+XGIVE*PHKT(2,5+IIGLU1) |
| 35099 | PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1) |
| 35100 | C *+0.5D0*PHKK(3,NC2T) |
| 35101 | *+XGIVE*PHKT(3,5+IIGLU1) |
| 35102 | PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1) |
| 35103 | C *+0.5D0*PHKK(4,NC2T) |
| 35104 | *+XGIVE*PHKT(4,5+IIGLU1) |
| 35105 | C PHKT(5,2) =PHKK(5,NC1T) |
| 35106 | XXMIST=(PHKT(4,2+IIGLU1)**2- |
| 35107 | * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2- |
| 35108 | *PHKT(1,2+IIGLU1)**2) |
| 35109 | IF(XXMIST.GT.0.D0)THEN |
| 35110 | PHKT(5,2+IIGLU1) =SQRT(XXMIST) |
| 35111 | ELSE |
| 35112 | WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST |
| 35113 | XXMIST=ABS(XXMIST) |
| 35114 | PHKT(5,2+IIGLU1) =SQRT(XXMIST) |
| 35115 | ENDIF |
| 35116 | VHKT(1,2+IIGLU1) =VHKK(1,NC1T) |
| 35117 | VHKT(2,2+IIGLU1) =VHKK(2,NC1T) |
| 35118 | VHKT(3,2+IIGLU1) =VHKK(3,NC1T) |
| 35119 | VHKT(4,2+IIGLU1) =VHKK(4,NC1T) |
| 35120 | WHKT(1,2+IIGLU1) =WHKK(1,NC1T) |
| 35121 | WHKT(2,2+IIGLU1) =WHKK(2,NC1T) |
| 35122 | WHKT(3,2+IIGLU1) =WHKK(3,NC1T) |
| 35123 | WHKT(4,2+IIGLU1) =WHKK(4,NC1T) |
| 35124 | IDHKT(3+IIGLU1) =88888 |
| 35125 | ISTHKT(3+IIGLU1) =96 |
| 35126 | JMOHKT(1,3+IIGLU1)=1 |
| 35127 | JMOHKT(2,3+IIGLU1)=2+IIGLU1 |
| 35128 | JDAHKT(1,3+IIGLU1)=0 |
| 35129 | JDAHKT(2,3+IIGLU1)=0 |
| 35130 | PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1 |
| 35131 | PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2 |
| 35132 | PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3 |
| 35133 | PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4 |
| 35134 | PHKT(5,3+IIGLU1) |
| 35135 | * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2 |
| 35136 | * -PHKT(3,3+IIGLU1)**2) |
| 35137 | IF(IPIP.EQ.3)THEN |
| 35138 | WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1), |
| 35139 | * JDAHKT(1,1), |
| 35140 | *JDAHKT(2,1),(PHKT(III,1),III=1,5) |
| 35141 | DO 71 IIG=2,2+IIGLU1-1 |
| 35142 | WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG), |
| 35143 | & JMOHKT(1,IIG),JMOHKT(2,IIG), |
| 35144 | * JDAHKT(1,IIG), |
| 35145 | *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) |
| 35146 | 71 CONTINUE |
| 35147 | WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1), |
| 35148 | * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1), |
| 35149 | *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5) |
| 35150 | WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1), |
| 35151 | * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1), |
| 35152 | *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5) |
| 35153 | ENDIF |
| 35154 | CHAMAL=CHAB1 |
| 35155 | IF(IPIP.EQ.1)THEN |
| 35156 | IF(IPP11.GE.3.OR.IPP12.GE.3.OR.IP21.GE.3)CHAMAL=CHAB3 |
| 35157 | ELSEIF(IPIP.EQ.2)THEN |
| 35158 | IF(IPP11.LE.-3.OR.IPP12.LE.-3.OR.IP21.LE.-3)CHAMAL=CHAB3 |
| 35159 | ENDIF |
| 35160 | IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN |
| 35161 | C IREJ=1 |
| 35162 | IPCO=0 |
| 35163 | C RETURN |
| 35164 | GO TO 3466 |
| 35165 | ENDIF |
| 35166 | VHKT(1,3+IIGLU1) =VHKK(1,NC1) |
| 35167 | VHKT(2,3+IIGLU1) =VHKK(2,NC1) |
| 35168 | VHKT(3,3+IIGLU1) =VHKK(3,NC1) |
| 35169 | VHKT(4,3+IIGLU1) =VHKK(4,NC1) |
| 35170 | WHKT(1,3+IIGLU1) =WHKK(1,NC1) |
| 35171 | WHKT(2,3+IIGLU1) =WHKK(2,NC1) |
| 35172 | WHKT(3,3+IIGLU1) =WHKK(3,NC1) |
| 35173 | WHKT(4,3+IIGLU1) =WHKK(4,NC1) |
| 35174 | C IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+1 |
| 35175 | IDHKT(7+IIGLU1) =IP1 |
| 35176 | ISTHKT(7+IIGLU1) =961 |
| 35177 | JMOHKT(1,7+IIGLU1)=NC1P |
| 35178 | JMOHKT(2,7+IIGLU1)=0 |
| 35179 | JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2 |
| 35180 | JDAHKT(2,7+IIGLU1)=0 |
| 35181 | PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1) |
| 35182 | PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1) |
| 35183 | PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1) |
| 35184 | PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1) |
| 35185 | C PHKT(5,7+IIGLU1) =PHKK(5,NC1P) |
| 35186 | XXMIST=(PHKT(4,7+IIGLU1)**2- |
| 35187 | * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2- |
| 35188 | *PHKT(1,7+IIGLU1)**2) |
| 35189 | IF(XXMIST.GT.0.D0)THEN |
| 35190 | PHKT(5,7+IIGLU1) =SQRT(XXMIST) |
| 35191 | ELSE |
| 35192 | WRITE(LOUT,*)' MGSQBS2, XXMIST',XXMIST |
| 35193 | XXMIST=ABS(XXMIST) |
| 35194 | PHKT(5,7+IIGLU1) =SQRT(XXMIST) |
| 35195 | ENDIF |
| 35196 | VHKT(1,7+IIGLU1) =VHKK(1,NC1P) |
| 35197 | VHKT(2,7+IIGLU1) =VHKK(2,NC1P) |
| 35198 | VHKT(3,7+IIGLU1) =VHKK(3,NC1P) |
| 35199 | VHKT(4,7+IIGLU1) =VHKK(4,NC1P) |
| 35200 | WHKT(1,7+IIGLU1) =WHKK(1,NC1P) |
| 35201 | WHKT(2,7+IIGLU1) =WHKK(2,NC1P) |
| 35202 | WHKT(3,7+IIGLU1) =WHKK(3,NC1P) |
| 35203 | WHKT(4,7+IIGLU1) =WHKK(4,NC2P) |
| 35204 | C IDHKT(7) =1000*IPP1+100*ISQ+1 |
| 35205 | C Insert here the IIGLU2 gluons |
| 35206 | PG1=0.D0 |
| 35207 | PG2=0.D0 |
| 35208 | PG3=0.D0 |
| 35209 | PG4=0.D0 |
| 35210 | IF(IIGLU2.GE.1)THEN |
| 35211 | JJG=NC2P |
| 35212 | DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 |
| 35213 | KKG=JJG+IIG-7-IIGLU1 |
| 35214 | IDHKT(IIG) =IDHKK(KKG) |
| 35215 | ISTHKT(IIG) =921 |
| 35216 | JMOHKT(1,IIG)=KKG |
| 35217 | JMOHKT(2,IIG)=0 |
| 35218 | JDAHKT(1,IIG)=9+IIGLU1+IIGLU2 |
| 35219 | JDAHKT(2,IIG)=0 |
| 35220 | PHKT(1,IIG)=PHKK(1,KKG) |
| 35221 | PG1=PG1+ PHKT(1,IIG) |
| 35222 | PHKT(2,IIG)=PHKK(2,KKG) |
| 35223 | PG2=PG2+ PHKT(2,IIG) |
| 35224 | PHKT(3,IIG)=PHKK(3,KKG) |
| 35225 | PG3=PG3+ PHKT(3,IIG) |
| 35226 | PHKT(4,IIG)=PHKK(4,KKG) |
| 35227 | PG4=PG4+ PHKT(4,IIG) |
| 35228 | PHKT(5,IIG)=PHKK(5,KKG) |
| 35229 | VHKT(1,IIG) =VHKK(1,KKG) |
| 35230 | VHKT(2,IIG) =VHKK(2,KKG) |
| 35231 | VHKT(3,IIG) =VHKK(3,KKG) |
| 35232 | VHKT(4,IIG) =VHKK(4,KKG) |
| 35233 | WHKT(1,IIG) =WHKK(1,KKG) |
| 35234 | WHKT(2,IIG) =WHKK(2,KKG) |
| 35235 | WHKT(3,IIG) =WHKK(3,KKG) |
| 35236 | WHKT(4,IIG) =WHKK(4,KKG) |
| 35237 | 81 CONTINUE |
| 35238 | ENDIF |
| 35239 | IF(IPIP.EQ.1)THEN |
| 35240 | IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3 |
| 35241 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103 |
| 35242 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103 |
| 35243 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203 |
| 35244 | ELSEIF(IPIP.EQ.2)THEN |
| 35245 | **NEW |
| 35246 | C IDHKT(8) =1000*IPP2+100*(-ISQ1+6)-3 |
| 35247 | IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3 |
| 35248 | ** |
| 35249 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103 |
| 35250 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103 |
| 35251 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203 |
| 35252 | ENDIF |
| 35253 | ISTHKT(8+IIGLU1+IIGLU2) =962 |
| 35254 | JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T |
| 35255 | JMOHKT(2,8+IIGLU1+IIGLU2)=0 |
| 35256 | JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2 |
| 35257 | JDAHKT(2,8+IIGLU1+IIGLU2)=0 |
| 35258 | C PHKT(1,8) =0.5D0*PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ/(XDIQT+XSQ) |
| 35259 | C PHKT(2,8) =0.5D0*PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ/(XDIQT+XSQ) |
| 35260 | C PHKT(3,8) =0.5D0*PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ/(XDIQT+XSQ) |
| 35261 | C PHKT(4,8) =0.5D0*PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ/(XDIQT+XSQ) |
| 35262 | PHKT(1,8+IIGLU1+IIGLU2) = |
| 35263 | * PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1) |
| 35264 | PHKT(2,8+IIGLU1+IIGLU2) = |
| 35265 | * PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1) |
| 35266 | PHKT(3,8+IIGLU1+IIGLU2) = |
| 35267 | * PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1) |
| 35268 | PHKT(4,8+IIGLU1+IIGLU2) = |
| 35269 | * PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1) |
| 35270 | C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)', |
| 35271 | C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7) |
| 35272 | IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN |
| 35273 | C IREJ=1 |
| 35274 | C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)' |
| 35275 | IPCO=0 |
| 35276 | C RETURN |
| 35277 | GO TO 3466 |
| 35278 | ENDIF |
| 35279 | C PHKT(5,8) =PHKK(5,NC2T) |
| 35280 | PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2- |
| 35281 | * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2- |
| 35282 | *PHKT(1,8+IIGLU1+IIGLU2)**2) |
| 35283 | VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T) |
| 35284 | VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T) |
| 35285 | VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T) |
| 35286 | VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T) |
| 35287 | WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T) |
| 35288 | WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T) |
| 35289 | WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T) |
| 35290 | WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T) |
| 35291 | IDHKT(9+IIGLU1+IIGLU2) =88888 |
| 35292 | ISTHKT(9+IIGLU1+IIGLU2) =96 |
| 35293 | JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1 |
| 35294 | JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2 |
| 35295 | JDAHKT(1,9+IIGLU1+IIGLU2)=0 |
| 35296 | JDAHKT(2,9+IIGLU1+IIGLU2)=0 |
| 35297 | PHKT(1,9+IIGLU1+IIGLU2) |
| 35298 | * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1 |
| 35299 | PHKT(2,9+IIGLU1+IIGLU2) |
| 35300 | * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2 |
| 35301 | PHKT(3,9+IIGLU1+IIGLU2) |
| 35302 | * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3 |
| 35303 | PHKT(4,9+IIGLU1+IIGLU2) |
| 35304 | * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4 |
| 35305 | PHKT(5,9+IIGLU1+IIGLU2) |
| 35306 | * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2- |
| 35307 | * PHKT(2,9+IIGLU1+IIGLU2)**2 |
| 35308 | * -PHKT(3,9+IIGLU1+IIGLU2)**2) |
| 35309 | IF(IPIP.GE.3)THEN |
| 35310 | WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1), |
| 35311 | * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1), |
| 35312 | *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5) |
| 35313 | DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 |
| 35314 | WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG), |
| 35315 | & JMOHKT(1,IIG),JMOHKT(2,IIG), |
| 35316 | * JDAHKT(1,IIG), |
| 35317 | *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) |
| 35318 | 91 CONTINUE |
| 35319 | WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2), |
| 35320 | * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2), |
| 35321 | *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2), |
| 35322 | *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5) |
| 35323 | WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2), |
| 35324 | * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2), |
| 35325 | *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2), |
| 35326 | *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5) |
| 35327 | ENDIF |
| 35328 | CHAMAL=CHAB1 |
| 35329 | IF(IPIP.EQ.1)THEN |
| 35330 | IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3 |
| 35331 | ELSEIF(IPIP.EQ.2)THEN |
| 35332 | IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3 |
| 35333 | ENDIF |
| 35334 | IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN |
| 35335 | C IREJ=1 |
| 35336 | IPCO=0 |
| 35337 | C RETURN |
| 35338 | GO TO 3466 |
| 35339 | ENDIF |
| 35340 | VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1) |
| 35341 | VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1) |
| 35342 | VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1) |
| 35343 | VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1) |
| 35344 | WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1) |
| 35345 | WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1) |
| 35346 | WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1) |
| 35347 | WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1) |
| 35348 | C |
| 35349 | IPCO=0 |
| 35350 | IGCOUN=9+IIGLU1+IIGLU2 |
| 35351 | RETURN |
| 35352 | END |
| 35353 | C |
| 35354 | C |
| 35355 | C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| 35356 | SUBROUTINE MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, |
| 35357 | * IP11,IP12,IP2,IPP1,IPP2,IPIP,ISQ,IGCOUN) |
| 35358 | C |
| 35359 | C USQBS-1 diagram (split projectile diquark) |
| 35360 | C |
| 35361 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 35362 | SAVE |
| 35363 | |
| 35364 | PARAMETER ( LINP = 5 , |
| 35365 | & LOUT = 6 , |
| 35366 | & LDAT = 9 ) |
| 35367 | |
| 35368 | * event history |
| 35369 | |
| 35370 | PARAMETER (NMXHKK=200000) |
| 35371 | |
| 35372 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 35373 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 35374 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 35375 | * extended event history |
| 35376 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 35377 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 35378 | & IHIST(2,NMXHKK) |
| 35379 | * Lorentz-parameters of the current interaction |
| 35380 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, |
| 35381 | & UMO,PPCM,EPROJ,PPROJ |
| 35382 | * diquark-breaking mechanism |
| 35383 | COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3 |
| 35384 | |
| 35385 | C |
| 35386 | PARAMETER (NTMHKK= 300) |
| 35387 | COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT |
| 35388 | +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT |
| 35389 | +(4,NTMHKK) |
| 35390 | *KEEP,XSEADI. |
| 35391 | COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA, |
| 35392 | +SSMIMQ,VVMTHR |
| 35393 | *KEEP,DPRIN. |
| 35394 | COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR |
| 35395 | COMMON /EVFLAG/ NUMEV |
| 35396 | C |
| 35397 | C USQBS-1 diagram (split projectile diquark) |
| 35398 | C |
| 35399 | C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T) |
| 35400 | C Input chain 2(NC2) sea-quark(NC2P)-sea-antiquark(NC2T) |
| 35401 | C |
| 35402 | C Create quark(qsP)-antiquark(aqsT) pair, energy from NC1P and NC1T |
| 35403 | C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P |
| 35404 | C |
| 35405 | C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2) |
| 35406 | C 6 valence quark(vq2P 4)-sea-quark(aqsT 5) |
| 35407 | C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8) |
| 35408 | C |
| 35409 | C Put new chains into COMMON /HKKTMP/ |
| 35410 | C |
| 35411 | IIGLU1=NC1T-NC1P-1 |
| 35412 | IIGLU2=NC2T-NC2P-1 |
| 35413 | IGCOUN=0 |
| 35414 | C WRITE(6,*)'MUSQBS1: IIGLU1,IIGLU2,IPIP ',IIGLU1,IIGLU2,IPIP |
| 35415 | CVQ=1.D0 |
| 35416 | IREJ=0 |
| 35417 | IF(IPIP.EQ.3)THEN |
| 35418 | C IF(NUMEV.EQ.-324)THEN |
| 35419 | WRITE(LOUT,*)' MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,', |
| 35420 | * ' IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN)', |
| 35421 | *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, |
| 35422 | * IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN |
| 35423 | ENDIF |
| 35424 | C |
| 35425 | C |
| 35426 | C |
| 35427 | C determine x-values of NC1P diquark |
| 35428 | XDIQP=PHKK(4,NC1P)*2.D0/UMO |
| 35429 | XVQT=PHKK(4,NC1T)*2.D0/UMO |
| 35430 | C |
| 35431 | C determine x-values of sea quark pair |
| 35432 | C |
| 35433 | IPCO=1 |
| 35434 | ICOU=0 |
| 35435 | 2234 CONTINUE |
| 35436 | ICOU=ICOU+1 |
| 35437 | IF(ICOU.GE.500)THEN |
| 35438 | IREJ=1 |
| 35439 | IF(ISQ.EQ.3)IREJ=3 |
| 35440 | IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 2234 ICOU. GT.100' |
| 35441 | IPCO=0 |
| 35442 | RETURN |
| 35443 | ENDIF |
| 35444 | IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 call XSEAPA: UMO,XDIQP,XVQT ', |
| 35445 | * UMO, XDIQP,XVQT |
| 35446 | XSQ=0.D0 |
| 35447 | XSAQ=0.D0 |
| 35448 | **NEW |
| 35449 | C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ) |
| 35450 | IF (IPIP.EQ.1) THEN |
| 35451 | XQMAX = XDIQP/2.0D0 |
| 35452 | XAQMAX = 2.D0*XVQT/3.0D0 |
| 35453 | ELSE |
| 35454 | XQMAX = 2.D0*XVQT/3.0D0 |
| 35455 | XAQMAX = XDIQP/2.0D0 |
| 35456 | ENDIF |
| 35457 | CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ) |
| 35458 | ISAQ = 6+ISQ |
| 35459 | C write(*,*) 'MUSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT |
| 35460 | ** |
| 35461 | IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ |
| 35462 | IF(IREJ.GE.1)THEN |
| 35463 | IF(IPCO.GE.3) |
| 35464 | & WRITE(LOUT,*)'MUSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ |
| 35465 | IPCO=0 |
| 35466 | RETURN |
| 35467 | ENDIF |
| 35468 | IF(IPIP.EQ.1)THEN |
| 35469 | IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234 |
| 35470 | ELSEIF(IPIP.EQ.2)THEN |
| 35471 | IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234 |
| 35472 | ENDIF |
| 35473 | IF(IPCO.GE.3)THEN |
| 35474 | WRITE(LOUT,'(A,4E12.4)')' MUSQBS1 XDIQP,XVQT,XSQ,XSAQ ', |
| 35475 | * XDIQP,XVQT,XSQ,XSAQ |
| 35476 | ENDIF |
| 35477 | C |
| 35478 | C subtract xsq,xsaq from NC1P diquark and NC1T quark |
| 35479 | C |
| 35480 | C XSQ=0.D0 |
| 35481 | IF(IPIP.EQ.1)THEN |
| 35482 | XDIQP=XDIQP-XSQ |
| 35483 | XVQT =XVQT -XSAQ |
| 35484 | ELSEIF(IPIP.EQ.2)THEN |
| 35485 | XDIQP=XDIQP-XSAQ |
| 35486 | XVQT =XVQT -XSQ |
| 35487 | ENDIF |
| 35488 | IF(IPCO.GE.3) |
| 35489 | & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT |
| 35490 | C |
| 35491 | C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P |
| 35492 | C |
| 35493 | XVTHRO=CVQ/UMO |
| 35494 | IVTHR=0 |
| 35495 | 3466 CONTINUE |
| 35496 | IF(IVTHR.EQ.10)THEN |
| 35497 | IREJ=1 |
| 35498 | IF(ISQ.EQ.3)IREJ=3 |
| 35499 | IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 3466 reject IVTHR 10' |
| 35500 | IPCO=0 |
| 35501 | RETURN |
| 35502 | ENDIF |
| 35503 | IVTHR=IVTHR+1 |
| 35504 | XVTHR=XVTHRO/(201-IVTHR) |
| 35505 | UNOPRV=UNON |
| 35506 | 380 CONTINUE |
| 35507 | IF(XVTHR.GT.0.66D0*XDIQP)THEN |
| 35508 | IREJ=1 |
| 35509 | IF(ISQ.EQ.3)IREJ=3 |
| 35510 | IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 380 XVTHR large ', |
| 35511 | * XVTHR |
| 35512 | IPCO=0 |
| 35513 | RETURN |
| 35514 | ENDIF |
| 35515 | IF(DT_RNDM(V).LT.0.5D0)THEN |
| 35516 | XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP) |
| 35517 | XVPQII=XDIQP-XVPQI |
| 35518 | ELSE |
| 35519 | XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP) |
| 35520 | XVPQI=XDIQP-XVPQII |
| 35521 | ENDIF |
| 35522 | IF(IPCO.GE.3)THEN |
| 35523 | WRITE(LOUT,'(A,2E12.4)')' MUSQBS1:XVPQI,XVPQII ',XVPQI,XVPQII |
| 35524 | ENDIF |
| 35525 | C |
| 35526 | C Prepare 4 momenta of new chains and chain ends |
| 35527 | C |
| 35528 | C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT |
| 35529 | C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT |
| 35530 | C +(4,NTMHKK) |
| 35531 | C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2) |
| 35532 | C 6 valence quark(vq2P 4)-sea-quark(aqsT 5) |
| 35533 | C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8) |
| 35534 | IF(IPIP.EQ.1)THEN |
| 35535 | XSQ1=XSQ |
| 35536 | XSAQ1=XSAQ |
| 35537 | ISQ1=ISQ |
| 35538 | ISAQ1=ISAQ |
| 35539 | ELSEIF(IPIP.EQ.2)THEN |
| 35540 | XSQ1=XSAQ |
| 35541 | XSAQ1=XSQ |
| 35542 | ISQ1=ISAQ |
| 35543 | ISAQ1=ISQ |
| 35544 | ENDIF |
| 35545 | IDHKT(1) =IP11 |
| 35546 | ISTHKT(1) =931 |
| 35547 | JMOHKT(1,1)=NC1P |
| 35548 | JMOHKT(2,1)=0 |
| 35549 | JDAHKT(1,1)=3+IIGLU1 |
| 35550 | JDAHKT(2,1)=0 |
| 35551 | C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2) |
| 35552 | PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1) |
| 35553 | PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1) |
| 35554 | PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1) |
| 35555 | PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1) |
| 35556 | C PHKT(5,1) =PHKK(5,NC1P) |
| 35557 | XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2- |
| 35558 | *PHKT(1,1)**2) |
| 35559 | IF(XMIST.GE.0.D0)THEN |
| 35560 | PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2- |
| 35561 | *PHKT(1,1)**2) |
| 35562 | ELSE |
| 35563 | C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST |
| 35564 | PHKT(5,1)=0.D0 |
| 35565 | ENDIF |
| 35566 | VHKT(1,1) =VHKK(1,NC1P) |
| 35567 | VHKT(2,1) =VHKK(2,NC1P) |
| 35568 | VHKT(3,1) =VHKK(3,NC1P) |
| 35569 | VHKT(4,1) =VHKK(4,NC1P) |
| 35570 | WHKT(1,1) =WHKK(1,NC1P) |
| 35571 | WHKT(2,1) =WHKK(2,NC1P) |
| 35572 | WHKT(3,1) =WHKK(3,NC1P) |
| 35573 | WHKT(4,1) =WHKK(4,NC1P) |
| 35574 | C Add here IIGLU1 gluons to this chaina |
| 35575 | PG1=0.D0 |
| 35576 | PG2=0.D0 |
| 35577 | PG3=0.D0 |
| 35578 | PG4=0.D0 |
| 35579 | IF(IIGLU1.GE.1)THEN |
| 35580 | JJG=NC1P |
| 35581 | DO 61 IIG=2,2+IIGLU1-1 |
| 35582 | KKG=JJG+IIG-1 |
| 35583 | IDHKT(IIG) =IDHKK(KKG) |
| 35584 | ISTHKT(IIG) =921 |
| 35585 | JMOHKT(1,IIG)=KKG |
| 35586 | JMOHKT(2,IIG)=0 |
| 35587 | JDAHKT(1,IIG)=3+IIGLU1 |
| 35588 | JDAHKT(2,IIG)=0 |
| 35589 | PHKT(1,IIG)=PHKK(1,KKG) |
| 35590 | PG1=PG1+ PHKT(1,IIG) |
| 35591 | PHKT(2,IIG)=PHKK(2,KKG) |
| 35592 | PG2=PG2+ PHKT(2,IIG) |
| 35593 | PHKT(3,IIG)=PHKK(3,KKG) |
| 35594 | PG3=PG3+ PHKT(3,IIG) |
| 35595 | PHKT(4,IIG)=PHKK(4,KKG) |
| 35596 | PG4=PG4+ PHKT(4,IIG) |
| 35597 | PHKT(5,IIG)=PHKK(5,KKG) |
| 35598 | VHKT(1,IIG) =VHKK(1,KKG) |
| 35599 | VHKT(2,IIG) =VHKK(2,KKG) |
| 35600 | VHKT(3,IIG) =VHKK(3,KKG) |
| 35601 | VHKT(4,IIG) =VHKK(4,KKG) |
| 35602 | WHKT(1,IIG) =WHKK(1,KKG) |
| 35603 | WHKT(2,IIG) =WHKK(2,KKG) |
| 35604 | WHKT(3,IIG) =WHKK(3,KKG) |
| 35605 | WHKT(4,IIG) =WHKK(4,KKG) |
| 35606 | 61 CONTINUE |
| 35607 | ENDIF |
| 35608 | IDHKT(2+IIGLU1) =IPP2 |
| 35609 | ISTHKT(2+IIGLU1) =932 |
| 35610 | JMOHKT(1,2+IIGLU1)=NC2T |
| 35611 | JMOHKT(2,2+IIGLU1)=0 |
| 35612 | JDAHKT(1,2+IIGLU1)=3+IIGLU1 |
| 35613 | JDAHKT(2,2+IIGLU1)=0 |
| 35614 | PHKT(1,2+IIGLU1) =PHKK(1,NC2T) |
| 35615 | PHKT(2,2+IIGLU1) =PHKK(2,NC2T) |
| 35616 | PHKT(3,2+IIGLU1) =PHKK(3,NC2T) |
| 35617 | PHKT(4,2+IIGLU1) =PHKK(4,NC2T) |
| 35618 | C PHKT(5,2+IIGLU1) =PHKK(5,NC2T) |
| 35619 | XMIST=(PHKT(4,2+IIGLU1)**2- |
| 35620 | * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2- |
| 35621 | *PHKT(1,2+IIGLU1)**2) |
| 35622 | IF(XMIST.GT.0.D0)THEN |
| 35623 | PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2- |
| 35624 | * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2- |
| 35625 | *PHKT(1,2+IIGLU1)**2) |
| 35626 | ELSE |
| 35627 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST |
| 35628 | PHKT(5,2+IIGLU1)=0.D0 |
| 35629 | ENDIF |
| 35630 | VHKT(1,2+IIGLU1) =VHKK(1,NC2T) |
| 35631 | VHKT(2,2+IIGLU1) =VHKK(2,NC2T) |
| 35632 | VHKT(3,2+IIGLU1) =VHKK(3,NC2T) |
| 35633 | VHKT(4,2+IIGLU1) =VHKK(4,NC2T) |
| 35634 | WHKT(1,2+IIGLU1) =WHKK(1,NC2T) |
| 35635 | WHKT(2,2+IIGLU1) =WHKK(2,NC2T) |
| 35636 | WHKT(3,2+IIGLU1) =WHKK(3,NC2T) |
| 35637 | WHKT(4,2+IIGLU1) =WHKK(4,NC2T) |
| 35638 | IDHKT(3+IIGLU1) =88888 |
| 35639 | ISTHKT(3+IIGLU1) =94 |
| 35640 | JMOHKT(1,3+IIGLU1)=1 |
| 35641 | JMOHKT(2,3+IIGLU1)=2+IIGLU1 |
| 35642 | JDAHKT(1,3+IIGLU1)=0 |
| 35643 | JDAHKT(2,3+IIGLU1)=0 |
| 35644 | PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1 |
| 35645 | PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2 |
| 35646 | PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3 |
| 35647 | PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4 |
| 35648 | XMIST |
| 35649 | * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2 |
| 35650 | * -PHKT(3,3+IIGLU1)**2) |
| 35651 | IF(XMIST.GE.0.D0)THEN |
| 35652 | PHKT(5,3+IIGLU1) |
| 35653 | * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2 |
| 35654 | * -PHKT(3,3+IIGLU1)**2) |
| 35655 | ELSE |
| 35656 | C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST |
| 35657 | PHKT(5,1)=0.D0 |
| 35658 | ENDIF |
| 35659 | IF(IPIP.GE.3)THEN |
| 35660 | C IF(NUMEV.EQ.-324)THEN |
| 35661 | WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1), |
| 35662 | * JMOHKT(2,1),JDAHKT(1,1), |
| 35663 | *JDAHKT(2,1),(PHKT(III,1),III=1,5) |
| 35664 | DO 71 IIG=2,2+IIGLU1-1 |
| 35665 | WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG), |
| 35666 | & JMOHKT(1,IIG),JMOHKT(2,IIG), |
| 35667 | * JDAHKT(1,IIG), |
| 35668 | *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) |
| 35669 | 71 CONTINUE |
| 35670 | WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1), |
| 35671 | * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1), |
| 35672 | *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5) |
| 35673 | WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1), |
| 35674 | * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1), |
| 35675 | *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5) |
| 35676 | ENDIF |
| 35677 | CHAMAL=CHAM1 |
| 35678 | IF(IPIP.EQ.1)THEN |
| 35679 | IF(IP11.GE.3.OR.IPP2.GE.3)CHAMAL=CHAM3 |
| 35680 | ELSEIF(IPIP.EQ.2)THEN |
| 35681 | IF(IP11.LE.-3.OR.IPP2.LE.-3)CHAMAL=CHAM3 |
| 35682 | ENDIF |
| 35683 | IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN |
| 35684 | C IREJ=1 |
| 35685 | IPCO=0 |
| 35686 | C RETURN |
| 35687 | C WRITE(6,*)' MUSQBS1 jump back from chain 3' |
| 35688 | GO TO 3466 |
| 35689 | ENDIF |
| 35690 | VHKT(1,3+IIGLU1) =VHKK(1,NC1) |
| 35691 | VHKT(2,3+IIGLU1) =VHKK(2,NC1) |
| 35692 | VHKT(3,3+IIGLU1) =VHKK(3,NC1) |
| 35693 | VHKT(4,3+IIGLU1) =VHKK(4,NC1) |
| 35694 | WHKT(1,3+IIGLU1) =WHKK(1,NC1) |
| 35695 | WHKT(2,3+IIGLU1) =WHKK(2,NC1) |
| 35696 | WHKT(3,3+IIGLU1) =WHKK(3,NC1) |
| 35697 | WHKT(4,3+IIGLU1) =WHKK(4,NC1) |
| 35698 | IDHKT(4+IIGLU1) =IP12 |
| 35699 | ISTHKT(4+IIGLU1) =931 |
| 35700 | JMOHKT(1,4+IIGLU1)=NC1P |
| 35701 | JMOHKT(2,4+IIGLU1)=0 |
| 35702 | JDAHKT(1,4+IIGLU1)=6+IIGLU1 |
| 35703 | JDAHKT(2,4+IIGLU1)=0 |
| 35704 | C create chain 6 valence quark(vq2P 4)-sea-quark(aqsT 5) |
| 35705 | PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1) |
| 35706 | PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1) |
| 35707 | PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1) |
| 35708 | PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1) |
| 35709 | C PHKT(5,4+IIGLU1) =PHKK(5,NC1P) |
| 35710 | XMIST =(PHKT(4,4+IIGLU1)**2- |
| 35711 | * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2- |
| 35712 | *PHKT(1,4+IIGLU1)**2) |
| 35713 | IF(XMIST.GT.0.D0)THEN |
| 35714 | PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2- |
| 35715 | * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2- |
| 35716 | *PHKT(1,4+IIGLU1)**2) |
| 35717 | ELSE |
| 35718 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST |
| 35719 | PHKT(5,4+IIGLU1)=0.D0 |
| 35720 | ENDIF |
| 35721 | VHKT(1,4+IIGLU1) =VHKK(1,NC1P) |
| 35722 | VHKT(2,4+IIGLU1) =VHKK(2,NC1P) |
| 35723 | VHKT(3,4+IIGLU1) =VHKK(3,NC1P) |
| 35724 | VHKT(4,4+IIGLU1) =VHKK(4,NC1P) |
| 35725 | WHKT(1,4+IIGLU1) =WHKK(1,NC1P) |
| 35726 | WHKT(2,4+IIGLU1) =WHKK(2,NC1P) |
| 35727 | WHKT(3,4+IIGLU1) =WHKK(3,NC1P) |
| 35728 | WHKT(4,4+IIGLU1) =WHKK(4,NC1P) |
| 35729 | IF(IPIP.EQ.1)THEN |
| 35730 | IDHKT(5+IIGLU1) =-(ISAQ1-6) |
| 35731 | ELSEIF(IPIP.EQ.2)THEN |
| 35732 | IDHKT(5+IIGLU1) =ISAQ1 |
| 35733 | ENDIF |
| 35734 | ISTHKT(5+IIGLU1) =932 |
| 35735 | JMOHKT(1,5+IIGLU1)=NC1T |
| 35736 | JMOHKT(2,5+IIGLU1)=0 |
| 35737 | JDAHKT(1,5+IIGLU1)=6+IIGLU1 |
| 35738 | JDAHKT(2,5+IIGLU1)=0 |
| 35739 | PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1) |
| 35740 | PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1) |
| 35741 | PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1) |
| 35742 | PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1) |
| 35743 | C IF( PHKT(4,5).EQ.0.D0)THEN |
| 35744 | C IREJ=1 |
| 35745 | CIPCO=0 |
| 35746 | CRETURN |
| 35747 | C ENDIF |
| 35748 | C PHKT(5,5) =PHKK(5,NC1T) |
| 35749 | XMIST=(PHKT(4,5+IIGLU1)**2- |
| 35750 | * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2- |
| 35751 | *PHKT(1,5+IIGLU1)**2) |
| 35752 | IF(XMIST.GT.0.D0)THEN |
| 35753 | PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2- |
| 35754 | * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2- |
| 35755 | *PHKT(1,5+IIGLU1)**2) |
| 35756 | ELSE |
| 35757 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST |
| 35758 | PHKT(5,5+IIGLU1)=0.D0 |
| 35759 | ENDIF |
| 35760 | VHKT(1,5+IIGLU1) =VHKK(1,NC1T) |
| 35761 | VHKT(2,5+IIGLU1) =VHKK(2,NC1T) |
| 35762 | VHKT(3,5+IIGLU1) =VHKK(3,NC1T) |
| 35763 | VHKT(4,5+IIGLU1) =VHKK(4,NC1T) |
| 35764 | WHKT(1,5+IIGLU1) =WHKK(1,NC1T) |
| 35765 | WHKT(2,5+IIGLU1) =WHKK(2,NC1T) |
| 35766 | WHKT(3,5+IIGLU1) =WHKK(3,NC1T) |
| 35767 | WHKT(4,5+IIGLU1) =WHKK(4,NC1T) |
| 35768 | IDHKT(6+IIGLU1) =88888 |
| 35769 | ISTHKT(6+IIGLU1) =94 |
| 35770 | JMOHKT(1,6+IIGLU1)=4+IIGLU1 |
| 35771 | JMOHKT(2,6+IIGLU1)=5+IIGLU1 |
| 35772 | JDAHKT(1,6+IIGLU1)=0 |
| 35773 | JDAHKT(2,6+IIGLU1)=0 |
| 35774 | PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1) |
| 35775 | PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1) |
| 35776 | PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1) |
| 35777 | PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1) |
| 35778 | XMIST |
| 35779 | * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2 |
| 35780 | * -PHKT(3,6+IIGLU1)**2) |
| 35781 | IF(XMIST.GE.0.D0)THEN |
| 35782 | PHKT(5,6+IIGLU1) |
| 35783 | * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2 |
| 35784 | * -PHKT(3,6+IIGLU1)**2) |
| 35785 | ELSE |
| 35786 | C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST |
| 35787 | PHKT(5,1)=0.D0 |
| 35788 | ENDIF |
| 35789 | C IF(IPIP.EQ.3)THEN |
| 35790 | CHAMAL=CHAM1 |
| 35791 | IF(IPIP.EQ.1)THEN |
| 35792 | IF(IP12.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3 |
| 35793 | ELSEIF(IPIP.EQ.2)THEN |
| 35794 | IF(IP12.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3 |
| 35795 | ENDIF |
| 35796 | IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN |
| 35797 | C IREJ=1 |
| 35798 | IPCO=0 |
| 35799 | C RETURN |
| 35800 | C WRITE(6,*)' MGSQBS1 jump back from chain 6', |
| 35801 | C * CHAMAL,PHKT(5,6+IIGLU1) |
| 35802 | GO TO 3466 |
| 35803 | ENDIF |
| 35804 | IF(IPIP.GE.3)THEN |
| 35805 | C IF(NUMEV.EQ.-324)THEN |
| 35806 | WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1), |
| 35807 | * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1), |
| 35808 | *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5) |
| 35809 | WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1), |
| 35810 | * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1), |
| 35811 | *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5) |
| 35812 | WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1), |
| 35813 | * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1), |
| 35814 | *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5) |
| 35815 | ENDIF |
| 35816 | VHKT(1,6+IIGLU1) =VHKK(1,NC1) |
| 35817 | VHKT(2,6+IIGLU1) =VHKK(2,NC1) |
| 35818 | VHKT(3,6+IIGLU1) =VHKK(3,NC1) |
| 35819 | VHKT(4,6+IIGLU1) =VHKK(4,NC1) |
| 35820 | WHKT(1,6+IIGLU1) =WHKK(1,NC1) |
| 35821 | WHKT(2,6+IIGLU1) =WHKK(2,NC1) |
| 35822 | WHKT(3,6+IIGLU1) =WHKK(3,NC1) |
| 35823 | WHKT(4,6+IIGLU1) =WHKK(4,NC1) |
| 35824 | IF(IPIP.EQ.1)THEN |
| 35825 | IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+3 |
| 35826 | IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103 |
| 35827 | IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103 |
| 35828 | IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203 |
| 35829 | ELSEIF(IPIP.EQ.2)THEN |
| 35830 | IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3 |
| 35831 | IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103 |
| 35832 | IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103 |
| 35833 | IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203 |
| 35834 | C WRITE(6,*)'IDHKT(7+IIGLU1),IPP1,ISQ1',IDHKT(7+IIGLU1),IPP1,ISQ1 |
| 35835 | ENDIF |
| 35836 | ISTHKT(7+IIGLU1) =931 |
| 35837 | JMOHKT(1,7+IIGLU1)=NC2P |
| 35838 | JMOHKT(2,7+IIGLU1)=0 |
| 35839 | JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2 |
| 35840 | JDAHKT(2,7+IIGLU1)=0 |
| 35841 | C create chain 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8) |
| 35842 | PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1) |
| 35843 | PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1) |
| 35844 | PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1) |
| 35845 | PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1) |
| 35846 | C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)', |
| 35847 | C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7) |
| 35848 | IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN |
| 35849 | C IREJ=1 |
| 35850 | C WRITE(6,*)'reject PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P)' |
| 35851 | IPCO=0 |
| 35852 | C RETURN |
| 35853 | GO TO 3466 |
| 35854 | ENDIF |
| 35855 | C PHKT(5,7) =PHKK(5,NC2P) |
| 35856 | PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2- |
| 35857 | * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2- |
| 35858 | *PHKT(1,7+IIGLU1)**2) |
| 35859 | VHKT(1,7+IIGLU1) =VHKK(1,NC2P) |
| 35860 | VHKT(2,7+IIGLU1) =VHKK(2,NC2P) |
| 35861 | VHKT(3,7+IIGLU1) =VHKK(3,NC2P) |
| 35862 | VHKT(4,7+IIGLU1) =VHKK(4,NC2P) |
| 35863 | WHKT(1,7+IIGLU1) =WHKK(1,NC2P) |
| 35864 | WHKT(2,7+IIGLU1) =WHKK(2,NC2P) |
| 35865 | WHKT(3,7+IIGLU1) =WHKK(3,NC2P) |
| 35866 | WHKT(4,7+IIGLU1) =WHKK(4,NC2P) |
| 35867 | C Insert here the IIGLU2 gluons |
| 35868 | PG1=0.D0 |
| 35869 | PG2=0.D0 |
| 35870 | PG3=0.D0 |
| 35871 | PG4=0.D0 |
| 35872 | IF(IIGLU2.GE.1)THEN |
| 35873 | JJG=NC2P |
| 35874 | DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 |
| 35875 | KKG=JJG+IIG-7-IIGLU1 |
| 35876 | IDHKT(IIG) =IDHKK(KKG) |
| 35877 | ISTHKT(IIG) =921 |
| 35878 | JMOHKT(1,IIG)=KKG |
| 35879 | JMOHKT(2,IIG)=0 |
| 35880 | JDAHKT(1,IIG)=9+IIGLU1+IIGLU2 |
| 35881 | JDAHKT(2,IIG)=0 |
| 35882 | PHKT(1,IIG)=PHKK(1,KKG) |
| 35883 | PG1=PG1+ PHKT(1,IIG) |
| 35884 | PHKT(2,IIG)=PHKK(2,KKG) |
| 35885 | PG2=PG2+ PHKT(2,IIG) |
| 35886 | PHKT(3,IIG)=PHKK(3,KKG) |
| 35887 | PG3=PG3+ PHKT(3,IIG) |
| 35888 | PHKT(4,IIG)=PHKK(4,KKG) |
| 35889 | PG4=PG4+ PHKT(4,IIG) |
| 35890 | PHKT(5,IIG)=PHKK(5,KKG) |
| 35891 | VHKT(1,IIG) =VHKK(1,KKG) |
| 35892 | VHKT(2,IIG) =VHKK(2,KKG) |
| 35893 | VHKT(3,IIG) =VHKK(3,KKG) |
| 35894 | VHKT(4,IIG) =VHKK(4,KKG) |
| 35895 | WHKT(1,IIG) =WHKK(1,KKG) |
| 35896 | WHKT(2,IIG) =WHKK(2,KKG) |
| 35897 | WHKT(3,IIG) =WHKK(3,KKG) |
| 35898 | WHKT(4,IIG) =WHKK(4,KKG) |
| 35899 | 81 CONTINUE |
| 35900 | ENDIF |
| 35901 | IDHKT(8+IIGLU1+IIGLU2) =IP2 |
| 35902 | ISTHKT(8+IIGLU1+IIGLU2) =932 |
| 35903 | JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T |
| 35904 | JMOHKT(2,8+IIGLU1+IIGLU2)=0 |
| 35905 | JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2 |
| 35906 | JDAHKT(2,8+IIGLU1+IIGLU2)=0 |
| 35907 | PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT) |
| 35908 | PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT) |
| 35909 | PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT) |
| 35910 | PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT) |
| 35911 | C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T) |
| 35912 | XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2- |
| 35913 | * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2- |
| 35914 | *PHKT(1,8+IIGLU1+IIGLU2)**2) |
| 35915 | IF(XMIST.GT.0.D0)THEN |
| 35916 | PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2- |
| 35917 | * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2- |
| 35918 | *PHKT(1,8+IIGLU1+IIGLU2)**2) |
| 35919 | ELSE |
| 35920 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST |
| 35921 | PHKT(5,8+IIGLU1+IIGLU2)=0.D0 |
| 35922 | ENDIF |
| 35923 | VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T) |
| 35924 | VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T) |
| 35925 | VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T) |
| 35926 | VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T) |
| 35927 | WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T) |
| 35928 | WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T) |
| 35929 | WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T) |
| 35930 | WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T) |
| 35931 | IDHKT(9+IIGLU1+IIGLU2) =88888 |
| 35932 | ISTHKT(9+IIGLU1+IIGLU2) =94 |
| 35933 | JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1 |
| 35934 | JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2 |
| 35935 | JDAHKT(1,9+IIGLU1+IIGLU2)=0 |
| 35936 | JDAHKT(2,9+IIGLU1+IIGLU2)=0 |
| 35937 | PHKT(1,9+IIGLU1+IIGLU2) |
| 35938 | * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1 |
| 35939 | PHKT(2,9+IIGLU1+IIGLU2) |
| 35940 | * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2 |
| 35941 | PHKT(3,9+IIGLU1+IIGLU2) |
| 35942 | * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3 |
| 35943 | PHKT(4,9+IIGLU1+IIGLU2) |
| 35944 | * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4 |
| 35945 | XMIST |
| 35946 | *=(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2 |
| 35947 | * -PHKT(2,9+IIGLU1+IIGLU2)**2 |
| 35948 | * -PHKT(3,9+IIGLU1+IIGLU2)**2) |
| 35949 | IF(XMIST.GE.0.D0)THEN |
| 35950 | PHKT(5,9+IIGLU1+IIGLU2) |
| 35951 | *=SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2 |
| 35952 | * -PHKT(2,9+IIGLU1+IIGLU2)**2 |
| 35953 | * -PHKT(3,9+IIGLU1+IIGLU2)**2) |
| 35954 | ELSE |
| 35955 | C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST |
| 35956 | PHKT(5,1)=0.D0 |
| 35957 | ENDIF |
| 35958 | IF(IPIP.GE.3)THEN |
| 35959 | C IF(NUMEV.EQ.-324)THEN |
| 35960 | WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1), |
| 35961 | * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1), |
| 35962 | *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5) |
| 35963 | DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 |
| 35964 | WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG), |
| 35965 | & JMOHKT(1,IIG),JMOHKT(2,IIG), |
| 35966 | * JDAHKT(1,IIG), |
| 35967 | *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) |
| 35968 | 91 CONTINUE |
| 35969 | WRITE(LOUT,*)8+IIGLU1+IIGLU2, |
| 35970 | * ISTHKT(8+IIGLU1+IIGLU2),IDHKT(8+IIGLU1+IIGLU2), |
| 35971 | * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2), |
| 35972 | *JDAHKT(1,8+IIGLU1+IIGLU2), |
| 35973 | *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5) |
| 35974 | WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2), |
| 35975 | * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2), |
| 35976 | *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2), |
| 35977 | *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5) |
| 35978 | ENDIF |
| 35979 | CHAMAL=CHAB1 |
| 35980 | IF(IPIP.EQ.1)THEN |
| 35981 | IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3 |
| 35982 | ELSEIF(IPIP.EQ.2)THEN |
| 35983 | IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3 |
| 35984 | ENDIF |
| 35985 | IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN |
| 35986 | C IREJ=1 |
| 35987 | IPCO=0 |
| 35988 | C RETURN |
| 35989 | C WRITE(6,*)' MGSQBS1 jump back from chain 9', |
| 35990 | C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2) |
| 35991 | GO TO 3466 |
| 35992 | ENDIF |
| 35993 | VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1) |
| 35994 | VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1) |
| 35995 | VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1) |
| 35996 | VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1) |
| 35997 | WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1) |
| 35998 | WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1) |
| 35999 | WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1) |
| 36000 | WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1) |
| 36001 | C |
| 36002 | IPCO=0 |
| 36003 | IGCOUN=9+IIGLU1+IIGLU2 |
| 36004 | RETURN |
| 36005 | END |
| 36006 | C |
| 36007 | C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| 36008 | SUBROUTINE MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, |
| 36009 | * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,ISQ,IGCOUN) |
| 36010 | C |
| 36011 | C GSQBS-1 diagram (split projectile diquark) |
| 36012 | C |
| 36013 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 36014 | SAVE |
| 36015 | |
| 36016 | PARAMETER ( LINP = 5 , |
| 36017 | & LOUT = 6 , |
| 36018 | & LDAT = 9 ) |
| 36019 | |
| 36020 | * event history |
| 36021 | |
| 36022 | PARAMETER (NMXHKK=200000) |
| 36023 | |
| 36024 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 36025 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 36026 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 36027 | * extended event history |
| 36028 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 36029 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 36030 | & IHIST(2,NMXHKK) |
| 36031 | * Lorentz-parameters of the current interaction |
| 36032 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, |
| 36033 | & UMO,PPCM,EPROJ,PPROJ |
| 36034 | * diquark-breaking mechanism |
| 36035 | COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3 |
| 36036 | |
| 36037 | C |
| 36038 | PARAMETER (NTMHKK= 300) |
| 36039 | COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT |
| 36040 | +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT |
| 36041 | +(4,NTMHKK) |
| 36042 | *KEEP,XSEADI. |
| 36043 | COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA, |
| 36044 | +SSMIMQ,VVMTHR |
| 36045 | *KEEP,DPRIN. |
| 36046 | COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR |
| 36047 | C |
| 36048 | C GSQBS-1 diagram (split projectile diquark) |
| 36049 | C |
| 36050 | C |
| 36051 | C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T) |
| 36052 | C Input chain 2(NC2) sea-quark(NC2P)-valence-diquark(NC2T) |
| 36053 | C |
| 36054 | C Create quark(qs)-antiquark(aqs) pair energy from NC1P and NC1T |
| 36055 | C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P |
| 36056 | C |
| 36057 | C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2) |
| 36058 | C 6 valence quark(vq2P 4)-sea-quark(aqsP 5) |
| 36059 | C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8) |
| 36060 | C |
| 36061 | C Put new chains into COMMON /HKKTMP/ |
| 36062 | C |
| 36063 | IIGLU1=NC1T-NC1P-1 |
| 36064 | IIGLU2=NC2T-NC2P-1 |
| 36065 | IGCOUN=0 |
| 36066 | C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2 |
| 36067 | CVQ=1.D0 |
| 36068 | NNNC1=IDHKK(NC1)/1000 |
| 36069 | MMMC1=IDHKK(NC1)-NNNC1*1000 |
| 36070 | KKKC1=ISTHKK(NC1) |
| 36071 | NNNC2=IDHKK(NC2)/1000 |
| 36072 | MMMC2=IDHKK(NC2)-NNNC2*1000 |
| 36073 | KKKC2=ISTHKK(NC2) |
| 36074 | IREJ=0 |
| 36075 | IF(IPIP.EQ.3)THEN |
| 36076 | WRITE(LOUT,*)' MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,', |
| 36077 | * ' IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN)', |
| 36078 | *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, |
| 36079 | * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN |
| 36080 | ENDIF |
| 36081 | C |
| 36082 | C |
| 36083 | C |
| 36084 | C determine x-values of NC1P diquark |
| 36085 | XDIQP=PHKK(4,NC1P)*2.D0/UMO |
| 36086 | XVQT=PHKK(4,NC1T)*2.D0/UMO |
| 36087 | C |
| 36088 | C determine x-values of sea quark pair |
| 36089 | C |
| 36090 | IPCO=1 |
| 36091 | ICOU=0 |
| 36092 | 2234 CONTINUE |
| 36093 | ICOU=ICOU+1 |
| 36094 | IF(ICOU.GE.500)THEN |
| 36095 | IREJ=1 |
| 36096 | IF(ISQ.EQ.3)IREJ=3 |
| 36097 | IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 Rejection 2234 ICOU. GT.100' |
| 36098 | IPCO=0 |
| 36099 | RETURN |
| 36100 | ENDIF |
| 36101 | IF(IPCO.GE.3)WRITE(LOUT,*)'MGSQBS1 call XSEAPA: UMO,XDIQP,XVQT ', |
| 36102 | * UMO, XDIQP,XVQT |
| 36103 | XSQ=0.D0 |
| 36104 | XSAQ=0.D0 |
| 36105 | **NEW |
| 36106 | C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ) |
| 36107 | IF (IPIP.EQ.1) THEN |
| 36108 | XQMAX = XDIQP/2.0D0 |
| 36109 | XAQMAX = 2.D0*XVQT/3.0D0 |
| 36110 | ELSE |
| 36111 | XQMAX = 2.D0*XVQT/3.0D0 |
| 36112 | XAQMAX = XDIQP/2.0D0 |
| 36113 | ENDIF |
| 36114 | CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ) |
| 36115 | ISAQ = 6+ISQ |
| 36116 | C write(*,*) 'MGSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT |
| 36117 | ** |
| 36118 | IF(IPCO.GE.3) |
| 36119 | & WRITE(LOUT,*)'MGSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ |
| 36120 | IF(IREJ.GE.1)THEN |
| 36121 | IF(IPCO.GE.3) |
| 36122 | & WRITE(LOUT,*)'MGSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ |
| 36123 | IPCO=0 |
| 36124 | RETURN |
| 36125 | ENDIF |
| 36126 | IF(IPIP.EQ.1)THEN |
| 36127 | IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234 |
| 36128 | ELSEIF(IPIP.EQ.2)THEN |
| 36129 | IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234 |
| 36130 | ENDIF |
| 36131 | IF(IPCO.GE.3)THEN |
| 36132 | WRITE(LOUT,'(A,4E12.4)')' MGSQBS1 XDIQP,XVQT,XSQ,XSAQ ', |
| 36133 | * XDIQP,XVQT,XSQ,XSAQ |
| 36134 | ENDIF |
| 36135 | C |
| 36136 | C subtract xsq,xsaq from NC1P diquark and NC1T quark |
| 36137 | C |
| 36138 | C XSQ=0.D0 |
| 36139 | IF(IPIP.EQ.1)THEN |
| 36140 | XDIQP=XDIQP-XSQ |
| 36141 | **NEW |
| 36142 | C IF (XDIQP.LT.0.0D0) WRITE(*,*) ' mgsqbs1: XDIQP<0!!',XDIQP |
| 36143 | ** |
| 36144 | XVQT =XVQT -XSAQ |
| 36145 | ELSEIF(IPIP.EQ.2)THEN |
| 36146 | XDIQP=XDIQP-XSAQ |
| 36147 | XVQT =XVQT -XSQ |
| 36148 | ENDIF |
| 36149 | IF(IPCO.GE.3) |
| 36150 | & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT |
| 36151 | C |
| 36152 | C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P |
| 36153 | C |
| 36154 | XVTHRO=CVQ/UMO |
| 36155 | IVTHR=0 |
| 36156 | 3466 CONTINUE |
| 36157 | IF(IVTHR.EQ.10)THEN |
| 36158 | IREJ=1 |
| 36159 | IF(ISQ.EQ.3)IREJ=3 |
| 36160 | IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 3466 reject IVTHR 10' |
| 36161 | IPCO=0 |
| 36162 | RETURN |
| 36163 | ENDIF |
| 36164 | IVTHR=IVTHR+1 |
| 36165 | XVTHR=XVTHRO/(201-IVTHR) |
| 36166 | UNOPRV=UNON |
| 36167 | 380 CONTINUE |
| 36168 | IF(XVTHR.GT.0.66D0*XDIQP)THEN |
| 36169 | IREJ=1 |
| 36170 | IF(ISQ.EQ.3)IREJ=3 |
| 36171 | IF(IPCO.GE.3) |
| 36172 | & WRITE(LOUT,*)' MGSQBS1 Rejection 380 XVTHR large ', |
| 36173 | * XVTHR |
| 36174 | IPCO=0 |
| 36175 | RETURN |
| 36176 | ENDIF |
| 36177 | IF(DT_RNDM(V).LT.0.5D0)THEN |
| 36178 | XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP) |
| 36179 | XVPQII=XDIQP-XVPQI |
| 36180 | ELSE |
| 36181 | XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP) |
| 36182 | XVPQI=XDIQP-XVPQII |
| 36183 | ENDIF |
| 36184 | IF(IPCO.GE.3)THEN |
| 36185 | WRITE(LOUT,'(A,4E12.4)')' MGSQBS1:XVTHR,XDIQP,XVPQI,XVPQII ', |
| 36186 | * XVTHR,XDIQP,XVPQI,XVPQII |
| 36187 | ENDIF |
| 36188 | C |
| 36189 | C Prepare 4 momenta of new chains and chain ends |
| 36190 | C |
| 36191 | C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT |
| 36192 | C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT |
| 36193 | C +(4,NTMHKK) |
| 36194 | C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2) |
| 36195 | C 6 valence quark(vq2P 4)-sea-quark(aqsP 5) |
| 36196 | C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8) |
| 36197 | IF(IPIP.EQ.1)THEN |
| 36198 | XSQ1=XSQ |
| 36199 | XSAQ1=XSAQ |
| 36200 | ISQ1=ISQ |
| 36201 | ISAQ1=ISAQ |
| 36202 | ELSEIF(IPIP.EQ.2)THEN |
| 36203 | XSQ1=XSAQ |
| 36204 | XSAQ1=XSQ |
| 36205 | ISQ1=ISAQ |
| 36206 | ISAQ1=ISQ |
| 36207 | ENDIF |
| 36208 | KK11=IP11 |
| 36209 | C IDHKT(2) =1000*IPP21+100*IPP22+1 |
| 36210 | KK21= IPP21 |
| 36211 | KK22= IPP22 |
| 36212 | XGIVE=0.D0 |
| 36213 | IDHKT(4+IIGLU1) =IP12 |
| 36214 | ISTHKT(4+IIGLU1) =921 |
| 36215 | JMOHKT(1,4+IIGLU1)=NC1P |
| 36216 | JMOHKT(2,4+IIGLU1)=0 |
| 36217 | JDAHKT(1,4+IIGLU1)=6+IIGLU1 |
| 36218 | JDAHKT(2,4+IIGLU1)=0 |
| 36219 | **NEW |
| 36220 | IF ((XDIQP.LT.0.0D0).OR.(XVPQII.LT.0.0D0).OR. |
| 36221 | & (XSQ1.LT.0.0D0)) WRITE(LOUT,*) ' mgsqbs1: ',XDIQP,XVPQII,XSQ1 |
| 36222 | ** |
| 36223 | PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1) |
| 36224 | PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1) |
| 36225 | PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1) |
| 36226 | PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1) |
| 36227 | C PHKT(5,4+IIGLU1) =PHKK(5,NC1P) |
| 36228 | XXMIST=(PHKT(4,4+IIGLU1)**2- |
| 36229 | * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2- |
| 36230 | * PHKT(1,4+IIGLU1)**2) |
| 36231 | IF(XXMIST.GT.0.D0)THEN |
| 36232 | PHKT(5,4+IIGLU1) =SQRT(XXMIST) |
| 36233 | ELSE |
| 36234 | WRITE(LOUT,*)'MGSQBS1 XXMIST',XXMIST |
| 36235 | XXMIST=ABS(XXMIST) |
| 36236 | PHKT(5,4+IIGLU1) =SQRT(XXMIST) |
| 36237 | ENDIF |
| 36238 | VHKT(1,4+IIGLU1) =VHKK(1,NC1P) |
| 36239 | VHKT(2,4+IIGLU1) =VHKK(2,NC1P) |
| 36240 | VHKT(3,4+IIGLU1) =VHKK(3,NC1P) |
| 36241 | VHKT(4,4+IIGLU1) =VHKK(4,NC1P) |
| 36242 | WHKT(1,4+IIGLU1) =WHKK(1,NC1P) |
| 36243 | WHKT(2,4+IIGLU1) =WHKK(2,NC1P) |
| 36244 | WHKT(3,4+IIGLU1) =WHKK(3,NC1P) |
| 36245 | WHKT(4,4+IIGLU1) =WHKK(4,NC1P) |
| 36246 | IF(IPIP.EQ.1)THEN |
| 36247 | IDHKT(5+IIGLU1) =-(ISAQ1-6) |
| 36248 | ELSEIF(IPIP.EQ.2)THEN |
| 36249 | IDHKT(5+IIGLU1) =ISAQ1 |
| 36250 | ENDIF |
| 36251 | ISTHKT(5+IIGLU1) =922 |
| 36252 | JMOHKT(1,5+IIGLU1)=NC1T |
| 36253 | JMOHKT(2,5+IIGLU1)=0 |
| 36254 | JDAHKT(1,5+IIGLU1)=6+IIGLU1 |
| 36255 | JDAHKT(2,5+IIGLU1)=0 |
| 36256 | **NEW |
| 36257 | IF ((XSAQ1.LT.0.0D0).OR.(XVQT .LT.0.0D0)) |
| 36258 | & WRITE(LOUT,*) ' mgsqbs2: ',XSAQ1,XVQT |
| 36259 | ** |
| 36260 | PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1) |
| 36261 | PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1) |
| 36262 | PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1) |
| 36263 | PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1) |
| 36264 | C PHKT(5,5+IIGLU1) =PHKK(5,NC1T) |
| 36265 | XMIST=(PHKT(4,5+IIGLU1)**2- |
| 36266 | * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2- |
| 36267 | *PHKT(1,5+IIGLU1)**2) |
| 36268 | IF(XMIST.GT.0.D0)THEN |
| 36269 | PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2- |
| 36270 | * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2- |
| 36271 | *PHKT(1,5+IIGLU1)**2) |
| 36272 | ELSE |
| 36273 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST |
| 36274 | PHKT(5,5+IIGLU1)=0.D0 |
| 36275 | ENDIF |
| 36276 | VHKT(1,5+IIGLU1) =VHKK(1,NC1T) |
| 36277 | VHKT(2,5+IIGLU1) =VHKK(2,NC1T) |
| 36278 | VHKT(3,5+IIGLU1) =VHKK(3,NC1T) |
| 36279 | VHKT(4,5+IIGLU1) =VHKK(4,NC1T) |
| 36280 | WHKT(1,5+IIGLU1) =WHKK(1,NC1T) |
| 36281 | WHKT(2,5+IIGLU1) =WHKK(2,NC1T) |
| 36282 | WHKT(3,5+IIGLU1) =WHKK(3,NC1T) |
| 36283 | WHKT(4,5+IIGLU1) =WHKK(4,NC1T) |
| 36284 | IDHKT(6+IIGLU1) =88888 |
| 36285 | C IDHKT(6) =1000*NNNC1+MMMC1 |
| 36286 | ISTHKT(6+IIGLU1) =93 |
| 36287 | C ISTHKT(6) =KKKC1 |
| 36288 | JMOHKT(1,6+IIGLU1)=4+IIGLU1 |
| 36289 | JMOHKT(2,6+IIGLU1)=5+IIGLU1 |
| 36290 | JDAHKT(1,6+IIGLU1)=0 |
| 36291 | JDAHKT(2,6+IIGLU1)=0 |
| 36292 | PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1) |
| 36293 | PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1) |
| 36294 | PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1) |
| 36295 | PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1) |
| 36296 | PHKT(5,6+IIGLU1) |
| 36297 | * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2 |
| 36298 | * -PHKT(3,6+IIGLU1)**2) |
| 36299 | CHAMAL=CHAM1 |
| 36300 | IF(IPIP.EQ.1)THEN |
| 36301 | IF(IP12.GE.3.OR.ISAQ.GE.9)CHAMAL=CHAM3 |
| 36302 | ELSEIF(IPIP.EQ.2)THEN |
| 36303 | IF(IP12.LE.-3.OR.ISAQ.GE.3)CHAMAL=CHAM3 |
| 36304 | ENDIF |
| 36305 | IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN |
| 36306 | IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN |
| 36307 | C we drop chain 6 and give the energy to chain 3 |
| 36308 | IDHKT(6+IIGLU1)=33888 |
| 36309 | XGIVE=1.D0 |
| 36310 | C WRITE(6,*)' drop chain 6 xgive=1' |
| 36311 | GO TO 7788 |
| 36312 | ELSEIF(IDHKT(5+IIGLU1).EQ.-IP11)THEN |
| 36313 | C we drop chain 6 and give the energy to chain 3 |
| 36314 | C and change KK11 to IDHKT(4) |
| 36315 | IDHKT(6+IIGLU1)=33888 |
| 36316 | XGIVE=1.D0 |
| 36317 | C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(4+IIGLU1)' |
| 36318 | KK11=IDHKT(4+IIGLU1) |
| 36319 | GO TO 7788 |
| 36320 | ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP21)THEN |
| 36321 | C we drop chain 6 and give the energy to chain 3 |
| 36322 | C and change KK21 to IDHKT(4) |
| 36323 | C IDHKT(2) =1000*IPP21+100*IPP22+1 |
| 36324 | IDHKT(6+IIGLU1)=33888 |
| 36325 | XGIVE=1.D0 |
| 36326 | C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(4+IIGLU1)' |
| 36327 | KK21=IDHKT(4+IIGLU1) |
| 36328 | GO TO 7788 |
| 36329 | ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP22)THEN |
| 36330 | C we drop chain 6 and give the energy to chain 3 |
| 36331 | C and change KK22 to IDHKT(4) |
| 36332 | C IDHKT(2) =1000*IPP21+100*IPP22+1 |
| 36333 | IDHKT(6+IIGLU1)=33888 |
| 36334 | XGIVE=1.D0 |
| 36335 | C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(4+IIGLU1)' |
| 36336 | KK22=IDHKT(4+IIGLU1) |
| 36337 | GO TO 7788 |
| 36338 | ENDIF |
| 36339 | C IREJ=1 |
| 36340 | IPCO=0 |
| 36341 | C RETURN |
| 36342 | C WRITE(6,*)' MGSQBS1 jump back from chain 6' |
| 36343 | GO TO 3466 |
| 36344 | ENDIF |
| 36345 | 7788 CONTINUE |
| 36346 | IF(IPIP.GE.3)THEN |
| 36347 | WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1), |
| 36348 | * JMOHKT(1,4+IIGLU1), |
| 36349 | * JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1), |
| 36350 | *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5) |
| 36351 | WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1), |
| 36352 | * JMOHKT(1,5+IIGLU1), |
| 36353 | * JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1), |
| 36354 | *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5) |
| 36355 | WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1), |
| 36356 | * JMOHKT(1,6+IIGLU1), |
| 36357 | * JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1), |
| 36358 | *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5) |
| 36359 | ENDIF |
| 36360 | VHKT(1,6+IIGLU1) =VHKK(1,NC1) |
| 36361 | VHKT(2,6+IIGLU1) =VHKK(2,NC1) |
| 36362 | VHKT(3,6+IIGLU1) =VHKK(3,NC1) |
| 36363 | VHKT(4,6+IIGLU1) =VHKK(4,NC1) |
| 36364 | WHKT(1,6+IIGLU1) =WHKK(1,NC1) |
| 36365 | WHKT(2,6+IIGLU1) =WHKK(2,NC1) |
| 36366 | WHKT(3,6+IIGLU1) =WHKK(3,NC1) |
| 36367 | WHKT(4,6+IIGLU1) =WHKK(4,NC1) |
| 36368 | C IDHKT(1) =IP11 |
| 36369 | IDHKT(1) =KK11 |
| 36370 | ISTHKT(1) =921 |
| 36371 | JMOHKT(1,1)=NC1P |
| 36372 | JMOHKT(2,1)=0 |
| 36373 | JDAHKT(1,1)=3+IIGLU1 |
| 36374 | JDAHKT(2,1)=0 |
| 36375 | PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1) |
| 36376 | C * +0.5D0*PHKK(1,NC2P) |
| 36377 | *+XGIVE*PHKT(1,4+IIGLU1) |
| 36378 | PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1) |
| 36379 | C * +0.5D0*PHKK(2,NC2P) |
| 36380 | *+XGIVE*PHKT(2,4+IIGLU1) |
| 36381 | PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1) |
| 36382 | C * +0.5D0*PHKK(3,NC2P) |
| 36383 | *+XGIVE*PHKT(3,4+IIGLU1) |
| 36384 | PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1) |
| 36385 | C * +0.5D0*PHKK(4,NC2P) |
| 36386 | *+XGIVE*PHKT(4,4+IIGLU1) |
| 36387 | C PHKT(5,1) =PHKK(5,NC1P) |
| 36388 | XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2- |
| 36389 | *PHKT(1,1)**2) |
| 36390 | IF(XMIST.GE.0.D0)THEN |
| 36391 | PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2- |
| 36392 | *PHKT(1,1)**2) |
| 36393 | ELSE |
| 36394 | C WRITE(6,*)'MGSQBS1 parton 1 mass square LT.0 ',XMIST |
| 36395 | PHKT(5,1)=0.D0 |
| 36396 | ENDIF |
| 36397 | VHKT(1,1) =VHKK(1,NC1P) |
| 36398 | VHKT(2,1) =VHKK(2,NC1P) |
| 36399 | VHKT(3,1) =VHKK(3,NC1P) |
| 36400 | VHKT(4,1) =VHKK(4,NC1P) |
| 36401 | WHKT(1,1) =WHKK(1,NC1P) |
| 36402 | WHKT(2,1) =WHKK(2,NC1P) |
| 36403 | WHKT(3,1) =WHKK(3,NC1P) |
| 36404 | WHKT(4,1) =WHKK(4,NC1P) |
| 36405 | C Add here IIGLU1 gluons to this chaina |
| 36406 | PG1=0.D0 |
| 36407 | PG2=0.D0 |
| 36408 | PG3=0.D0 |
| 36409 | PG4=0.D0 |
| 36410 | IF(IIGLU1.GE.1)THEN |
| 36411 | JJG=NC1P |
| 36412 | DO 61 IIG=2,2+IIGLU1-1 |
| 36413 | KKG=JJG+IIG-1 |
| 36414 | IDHKT(IIG) =IDHKK(KKG) |
| 36415 | ISTHKT(IIG) =921 |
| 36416 | JMOHKT(1,IIG)=KKG |
| 36417 | JMOHKT(2,IIG)=0 |
| 36418 | JDAHKT(1,IIG)=3+IIGLU1 |
| 36419 | JDAHKT(2,IIG)=0 |
| 36420 | PHKT(1,IIG)=PHKK(1,KKG) |
| 36421 | PG1=PG1+ PHKT(1,IIG) |
| 36422 | PHKT(2,IIG)=PHKK(2,KKG) |
| 36423 | PG2=PG2+ PHKT(2,IIG) |
| 36424 | PHKT(3,IIG)=PHKK(3,KKG) |
| 36425 | PG3=PG3+ PHKT(3,IIG) |
| 36426 | PHKT(4,IIG)=PHKK(4,KKG) |
| 36427 | PG4=PG4+ PHKT(4,IIG) |
| 36428 | PHKT(5,IIG)=PHKK(5,KKG) |
| 36429 | VHKT(1,IIG) =VHKK(1,KKG) |
| 36430 | VHKT(2,IIG) =VHKK(2,KKG) |
| 36431 | VHKT(3,IIG) =VHKK(3,KKG) |
| 36432 | VHKT(4,IIG) =VHKK(4,KKG) |
| 36433 | WHKT(1,IIG) =WHKK(1,KKG) |
| 36434 | WHKT(2,IIG) =WHKK(2,KKG) |
| 36435 | WHKT(3,IIG) =WHKK(3,KKG) |
| 36436 | WHKT(4,IIG) =WHKK(4,KKG) |
| 36437 | 61 CONTINUE |
| 36438 | ENDIF |
| 36439 | C IDHKT(2) =1000*IPP21+100*IPP22+1 |
| 36440 | IF(IPIP.EQ.1)THEN |
| 36441 | IDHKT(2+IIGLU1) =1000*KK21+100*KK22+3 |
| 36442 | IF(IDHKT(2+IIGLU1).EQ.1203)IDHKT(2+IIGLU1)=2103 |
| 36443 | IF(IDHKT(2+IIGLU1).EQ.1303)IDHKT(2+IIGLU1)=3103 |
| 36444 | IF(IDHKT(2+IIGLU1).EQ.2303)IDHKT(2+IIGLU1)=3203 |
| 36445 | ELSEIF(IPIP.EQ.2)THEN |
| 36446 | IDHKT(2+IIGLU1) =1000*KK21+100*KK22-3 |
| 36447 | IF(IDHKT(2+IIGLU1).EQ.-1203)IDHKT(2+IIGLU1)=-2103 |
| 36448 | IF(IDHKT(2+IIGLU1).EQ.-1303)IDHKT(2+IIGLU1)=-3103 |
| 36449 | IF(IDHKT(2+IIGLU1).EQ.-2303)IDHKT(2+IIGLU1)=-3203 |
| 36450 | ENDIF |
| 36451 | ISTHKT(2+IIGLU1) =922 |
| 36452 | JMOHKT(1,2+IIGLU1)=NC2T |
| 36453 | JMOHKT(2,2+IIGLU1)=0 |
| 36454 | JDAHKT(1,2+IIGLU1)=3+IIGLU1 |
| 36455 | JDAHKT(2,2+IIGLU1)=0 |
| 36456 | PHKT(1,2+IIGLU1) =PHKK(1,NC2T) |
| 36457 | *+XGIVE*PHKT(1,5+IIGLU1) |
| 36458 | PHKT(2,2+IIGLU1) =PHKK(2,NC2T) |
| 36459 | *+XGIVE*PHKT(2,5+IIGLU1) |
| 36460 | PHKT(3,2+IIGLU1) =PHKK(3,NC2T) |
| 36461 | *+XGIVE*PHKT(3,5+IIGLU1) |
| 36462 | PHKT(4,2+IIGLU1) =PHKK(4,NC2T) |
| 36463 | *+XGIVE*PHKT(4,5+IIGLU1) |
| 36464 | C PHKT(5,2) =PHKK(5,NC2T) |
| 36465 | XMIST=(PHKT(4,2+IIGLU1)**2- |
| 36466 | * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2- |
| 36467 | *PHKT(1,2+IIGLU1)**2) |
| 36468 | IF(XMIST.GT.0.D0)THEN |
| 36469 | PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2- |
| 36470 | * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2- |
| 36471 | *PHKT(1,2+IIGLU1)**2) |
| 36472 | ELSE |
| 36473 | C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST |
| 36474 | PHKT(5,2+IIGLU1)=0.D0 |
| 36475 | ENDIF |
| 36476 | VHKT(1,2+IIGLU1) =VHKK(1,NC2T) |
| 36477 | VHKT(2,2+IIGLU1) =VHKK(2,NC2T) |
| 36478 | VHKT(3,2+IIGLU1) =VHKK(3,NC2T) |
| 36479 | VHKT(4,2+IIGLU1) =VHKK(4,NC2T) |
| 36480 | WHKT(1,2+IIGLU1) =WHKK(1,NC2T) |
| 36481 | WHKT(2,2+IIGLU1) =WHKK(2,NC2T) |
| 36482 | WHKT(3,2+IIGLU1) =WHKK(3,NC2T) |
| 36483 | WHKT(4,2+IIGLU1) =WHKK(4,NC2T) |
| 36484 | IDHKT(3+IIGLU1) =88888 |
| 36485 | C IDHKT(3) =1000*NNNC1+MMMC1+10 |
| 36486 | ISTHKT(3+IIGLU1) =93 |
| 36487 | C ISTHKT(3) =KKKC1 |
| 36488 | JMOHKT(1,3+IIGLU1)=1 |
| 36489 | JMOHKT(2,3+IIGLU1)=2+IIGLU1 |
| 36490 | JDAHKT(1,3+IIGLU1)=0 |
| 36491 | JDAHKT(2,3+IIGLU1)=0 |
| 36492 | PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1 |
| 36493 | PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2 |
| 36494 | PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3 |
| 36495 | PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4 |
| 36496 | PHKT(5,3+IIGLU1) |
| 36497 | * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2 |
| 36498 | * -PHKT(3,3+IIGLU1)**2) |
| 36499 | IF(IPIP.GE.3)THEN |
| 36500 | WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1), |
| 36501 | * JDAHKT(1,1), |
| 36502 | *JDAHKT(2,1),(PHKT(III,1),III=1,5) |
| 36503 | DO 71 IIG=2,2+IIGLU1-1 |
| 36504 | WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG), |
| 36505 | & JMOHKT(1,IIG),JMOHKT(2,IIG), |
| 36506 | * JDAHKT(1,IIG), |
| 36507 | *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) |
| 36508 | 71 CONTINUE |
| 36509 | WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1), |
| 36510 | & IDHKT(2),JMOHKT(1,2+IIGLU1), |
| 36511 | * JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1), |
| 36512 | *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5) |
| 36513 | WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1), |
| 36514 | * JMOHKT(1,3+IIGLU1), |
| 36515 | * JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1), |
| 36516 | *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5) |
| 36517 | ENDIF |
| 36518 | CHAMAL=CHAB1 |
| 36519 | **NEW |
| 36520 | C IF(IPIP.EQ.1)THEN |
| 36521 | C IF(IPP21.GE.3.OR.IPP22.GE.3.OR.IP11.GE.3)CHAMAL=CHAB3 |
| 36522 | C ELSEIF(IPIP.EQ.2)THEN |
| 36523 | C IF(IPP21.LE.-3.OR.IPP22.LE.-3.OR.IP11.LE.-3)CHAMAL=CHAB3 |
| 36524 | C ENDIF |
| 36525 | IF(IPIP.EQ.1)THEN |
| 36526 | IF(KK21.GE.3.OR.KK22.GE.3.OR.KK11.GE.3)CHAMAL=CHAB3 |
| 36527 | ELSEIF(IPIP.EQ.2)THEN |
| 36528 | IF(KK21.LE.-3.OR.KK22.LE.-3.OR.KK11.LE.-3)CHAMAL=CHAB3 |
| 36529 | ENDIF |
| 36530 | ** |
| 36531 | IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN |
| 36532 | C IREJ=1 |
| 36533 | IPCO=0 |
| 36534 | C RETURN |
| 36535 | C WRITE(6,*)' MGSQBS1 jump back from chain 3' |
| 36536 | GO TO 3466 |
| 36537 | ENDIF |
| 36538 | VHKT(1,3+IIGLU1) =VHKK(1,NC1) |
| 36539 | VHKT(2,3+IIGLU1) =VHKK(2,NC1) |
| 36540 | VHKT(3,3+IIGLU1) =VHKK(3,NC1) |
| 36541 | VHKT(4,3+IIGLU1) =VHKK(4,NC1) |
| 36542 | WHKT(1,3+IIGLU1) =WHKK(1,NC1) |
| 36543 | WHKT(2,3+IIGLU1) =WHKK(2,NC1) |
| 36544 | WHKT(3,3+IIGLU1) =WHKK(3,NC1) |
| 36545 | WHKT(4,3+IIGLU1) =WHKK(4,NC1) |
| 36546 | IF(IPIP.EQ.1)THEN |
| 36547 | IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ1+3 |
| 36548 | IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103 |
| 36549 | IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103 |
| 36550 | IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203 |
| 36551 | ELSEIF(IPIP.EQ.2)THEN |
| 36552 | IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3 |
| 36553 | IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103 |
| 36554 | IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103 |
| 36555 | IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203 |
| 36556 | C WRITE(6,*)'IDHKT(7),IPP1,ISQ1',IDHKT(7),IPP1,ISQ1 |
| 36557 | ENDIF |
| 36558 | ISTHKT(7+IIGLU1) =921 |
| 36559 | JMOHKT(1,7+IIGLU1)=NC2P |
| 36560 | JMOHKT(2,7+IIGLU1)=0 |
| 36561 | JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2 |
| 36562 | JDAHKT(2,7+IIGLU1)=0 |
| 36563 | C PHKT(1,7) =0.5D0*PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ/(XDIQP+XSQ) |
| 36564 | C PHKT(2,7) =0.5D0*PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ/(XDIQP+XSQ) |
| 36565 | C PHKT(3,7) =0.5D0*PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ/(XDIQP+XSQ) |
| 36566 | C PHKT(4,7+IIGLU1) =0.5D0*PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ/(XDIQP+XSQ) |
| 36567 | **NEW |
| 36568 | IF ((XSQ1 .LT.0.0D0).OR.(XDIQP .LT.0.0D0)) |
| 36569 | & WRITE(LOUT,*) ' mgsqbs3: ',XSQ1,XDIQP |
| 36570 | ** |
| 36571 | PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1) |
| 36572 | PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1) |
| 36573 | PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1) |
| 36574 | PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1) |
| 36575 | C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)', |
| 36576 | C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7) |
| 36577 | IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN |
| 36578 | C IREJ=1 |
| 36579 | C WRITE(6,*)'reject PHKT(4,7).GE. PHKK(4,NC1P)' |
| 36580 | IPCO=0 |
| 36581 | C RETURN |
| 36582 | GO TO 3466 |
| 36583 | ENDIF |
| 36584 | C PHKT(5,7) =PHKK(5,NC2P) |
| 36585 | PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2- |
| 36586 | * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2- |
| 36587 | *PHKT(1,7+IIGLU1)**2) |
| 36588 | VHKT(1,7+IIGLU1) =VHKK(1,NC2P) |
| 36589 | VHKT(2,7+IIGLU1) =VHKK(2,NC2P) |
| 36590 | VHKT(3,7+IIGLU1) =VHKK(3,NC2P) |
| 36591 | VHKT(4,7+IIGLU1) =VHKK(4,NC2P) |
| 36592 | WHKT(1,7+IIGLU1) =WHKK(1,NC2P) |
| 36593 | WHKT(2,7+IIGLU1) =WHKK(2,NC2P) |
| 36594 | WHKT(3,7+IIGLU1) =WHKK(3,NC2P) |
| 36595 | WHKT(4,7+IIGLU1) =WHKK(4,NC2P) |
| 36596 | C Insert here the IIGLU2 gluons |
| 36597 | PG1=0.D0 |
| 36598 | PG2=0.D0 |
| 36599 | PG3=0.D0 |
| 36600 | PG4=0.D0 |
| 36601 | IF(IIGLU2.GE.1)THEN |
| 36602 | JJG=NC2P |
| 36603 | DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 |
| 36604 | KKG=JJG+IIG-7-IIGLU1 |
| 36605 | IDHKT(IIG) =IDHKK(KKG) |
| 36606 | ISTHKT(IIG) =921 |
| 36607 | JMOHKT(1,IIG)=KKG |
| 36608 | JMOHKT(2,IIG)=0 |
| 36609 | JDAHKT(1,IIG)=9+IIGLU1+IIGLU2 |
| 36610 | JDAHKT(2,IIG)=0 |
| 36611 | PHKT(1,IIG)=PHKK(1,KKG) |
| 36612 | PG1=PG1+ PHKT(1,IIG) |
| 36613 | PHKT(2,IIG)=PHKK(2,KKG) |
| 36614 | PG2=PG2+ PHKT(2,IIG) |
| 36615 | PHKT(3,IIG)=PHKK(3,KKG) |
| 36616 | PG3=PG3+ PHKT(3,IIG) |
| 36617 | PHKT(4,IIG)=PHKK(4,KKG) |
| 36618 | PG4=PG4+ PHKT(4,IIG) |
| 36619 | PHKT(5,IIG)=PHKK(5,KKG) |
| 36620 | VHKT(1,IIG) =VHKK(1,KKG) |
| 36621 | VHKT(2,IIG) =VHKK(2,KKG) |
| 36622 | VHKT(3,IIG) =VHKK(3,KKG) |
| 36623 | VHKT(4,IIG) =VHKK(4,KKG) |
| 36624 | WHKT(1,IIG) =WHKK(1,KKG) |
| 36625 | WHKT(2,IIG) =WHKK(2,KKG) |
| 36626 | WHKT(3,IIG) =WHKK(3,KKG) |
| 36627 | WHKT(4,IIG) =WHKK(4,KKG) |
| 36628 | 81 CONTINUE |
| 36629 | ENDIF |
| 36630 | IDHKT(8+IIGLU1+IIGLU2) =IP2 |
| 36631 | ISTHKT(8+IIGLU1+IIGLU2) =922 |
| 36632 | JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T |
| 36633 | JMOHKT(2,8+IIGLU1+IIGLU2)=0 |
| 36634 | JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2 |
| 36635 | JDAHKT(2,8+IIGLU1+IIGLU2)=0 |
| 36636 | **NEW |
| 36637 | IF ((XVQT.LT.0.0D0).OR.(XSAQ1 .LT.0.0D0)) |
| 36638 | & WRITE(LOUT,*) ' mgsqbs4: ',XVQT,XSAQ1 |
| 36639 | ** |
| 36640 | PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT) |
| 36641 | PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT) |
| 36642 | PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT) |
| 36643 | PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT) |
| 36644 | C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T) |
| 36645 | XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2- |
| 36646 | * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2- |
| 36647 | *PHKT(1,8+IIGLU1+IIGLU2)**2) |
| 36648 | IF(XMIST.GT.0.D0)THEN |
| 36649 | PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2- |
| 36650 | * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2- |
| 36651 | *PHKT(1,8+IIGLU1+IIGLU2)**2) |
| 36652 | ELSE |
| 36653 | C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST |
| 36654 | PHKT(5,8+IIGLU1+IIGLU2)=0.D0 |
| 36655 | ENDIF |
| 36656 | VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T) |
| 36657 | VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T) |
| 36658 | VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T) |
| 36659 | VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T) |
| 36660 | WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T) |
| 36661 | WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T) |
| 36662 | WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T) |
| 36663 | WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T) |
| 36664 | IDHKT(9+IIGLU1+IIGLU2) =88888 |
| 36665 | C IDHKT(9) =1000*NNNC2+MMMC2+10 |
| 36666 | ISTHKT(9+IIGLU1+IIGLU2) =93 |
| 36667 | C ISTHKT(9) =KKKC2 |
| 36668 | JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1 |
| 36669 | JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2 |
| 36670 | JDAHKT(1,9+IIGLU1+IIGLU2)=0 |
| 36671 | JDAHKT(2,9+IIGLU1+IIGLU2)=0 |
| 36672 | PHKT(1,9+IIGLU1+IIGLU2) =PHKT(1,7+IIGLU1) |
| 36673 | * +PHKT(1,8+IIGLU1+IIGLU2)+PG1 |
| 36674 | PHKT(2,9+IIGLU1+IIGLU2) =PHKT(2,7+IIGLU1) |
| 36675 | * +PHKT(2,8+IIGLU1+IIGLU2)+PG2 |
| 36676 | PHKT(3,9+IIGLU1+IIGLU2) =PHKT(3,7+IIGLU1) |
| 36677 | * +PHKT(3,8+IIGLU1+IIGLU2)+PG3 |
| 36678 | PHKT(4,9+IIGLU1+IIGLU2) =PHKT(4,7+IIGLU1) |
| 36679 | * +PHKT(4,8+IIGLU1+IIGLU2)+PG4 |
| 36680 | PHKT(5,9+IIGLU1+IIGLU2) |
| 36681 | * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2- |
| 36682 | * PHKT(2,9+IIGLU1+IIGLU2)**2 |
| 36683 | * -PHKT(3,9+IIGLU1+IIGLU2)**2) |
| 36684 | IF(IPIP.GE.3)THEN |
| 36685 | WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1), |
| 36686 | * JMOHKT(1,7+IIGLU1), |
| 36687 | * JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1), |
| 36688 | *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5) |
| 36689 | DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 |
| 36690 | WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG), |
| 36691 | & JMOHKT(1,IIG),JMOHKT(2,IIG), |
| 36692 | * JDAHKT(1,IIG), |
| 36693 | *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) |
| 36694 | 91 CONTINUE |
| 36695 | WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2), |
| 36696 | * IDHKT(8+IIGLU1+IIGLU2), |
| 36697 | * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2), |
| 36698 | * JDAHKT(1,8+IIGLU1+IIGLU2), |
| 36699 | *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5) |
| 36700 | WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2), |
| 36701 | * IDHKT(9+IIGLU1+IIGLU2), |
| 36702 | * JMOHKT(1,9+IIGLU1+IIGLU2),JMOHKT(2,9+IIGLU1+IIGLU2), |
| 36703 | * JDAHKT(1,9+IIGLU1+IIGLU2), |
| 36704 | *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5) |
| 36705 | ENDIF |
| 36706 | CHAMAL=CHAB1 |
| 36707 | IF(IPIP.EQ.1)THEN |
| 36708 | IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3 |
| 36709 | ELSEIF(IPIP.EQ.2)THEN |
| 36710 | IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3 |
| 36711 | ENDIF |
| 36712 | IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN |
| 36713 | C IREJ=1 |
| 36714 | IPCO=0 |
| 36715 | C RETURN |
| 36716 | C WRITE(6,*)' MGSQBS1 jump back from chain 9', |
| 36717 | C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2) |
| 36718 | GO TO 3466 |
| 36719 | ENDIF |
| 36720 | VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1) |
| 36721 | VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1) |
| 36722 | VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1) |
| 36723 | VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1) |
| 36724 | WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1) |
| 36725 | WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1) |
| 36726 | WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1) |
| 36727 | WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1) |
| 36728 | C |
| 36729 | IGCOUN=9+IIGLU1+IIGLU2 |
| 36730 | IPCO=0 |
| 36731 | RETURN |
| 36732 | END |
| 36733 | C |
| 36734 | C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| 36735 | C |
| 36736 | SUBROUTINE HKKHKT(I,J) |
| 36737 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 36738 | SAVE |
| 36739 | |
| 36740 | * event history |
| 36741 | |
| 36742 | PARAMETER (NMXHKK=200000) |
| 36743 | |
| 36744 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 36745 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 36746 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 36747 | * extended event history |
| 36748 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 36749 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 36750 | & IHIST(2,NMXHKK) |
| 36751 | |
| 36752 | PARAMETER (NTMHKK= 300) |
| 36753 | COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT |
| 36754 | +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT |
| 36755 | +(4,NTMHKK) |
| 36756 | C |
| 36757 | ISTHKK(I) =ISTHKT(J) |
| 36758 | IDHKK(I) =IDHKT(J) |
| 36759 | C IF(J.EQ.3.OR.J.EQ.6.OR.J.EQ.9)THEN |
| 36760 | IF(IDHKK(I).EQ.88888)THEN |
| 36761 | C JMOHKK(1,I)=I-2 |
| 36762 | C JMOHKK(2,I)=I-1 |
| 36763 | JMOHKK(1,I)=I-(J-JMOHKT(1,J)) |
| 36764 | JMOHKK(2,I)=I-(J-JMOHKT(2,J)) |
| 36765 | ELSE |
| 36766 | JMOHKK(1,I)=JMOHKT(1,J) |
| 36767 | JMOHKK(2,I)=JMOHKT(2,J) |
| 36768 | ENDIF |
| 36769 | JDAHKK(1,I)=JDAHKT(1,J) |
| 36770 | JDAHKK(2,I)=JDAHKT(2,J) |
| 36771 | C IF(J.EQ.1.OR.J.EQ.4.OR.J.EQ.7)THEN |
| 36772 | C JDAHKK(1,I)=I+2 |
| 36773 | C ELSEIF(J.EQ.2.OR.J.EQ.5.OR.J.EQ.8)THEN |
| 36774 | C JDAHKK(1,I)=I+1 |
| 36775 | C ENDIF |
| 36776 | IF(JDAHKT(1,J).GT.0)THEN |
| 36777 | JDAHKK(1,I)=I+(JDAHKT(1,J)-J) |
| 36778 | ENDIF |
| 36779 | PHKK(1,I) =PHKT(1,J) |
| 36780 | PHKK(2,I) =PHKT(2,J) |
| 36781 | PHKK(3,I) =PHKT(3,J) |
| 36782 | PHKK(4,I) =PHKT(4,J) |
| 36783 | PHKK(5,I) =PHKT(5,J) |
| 36784 | VHKK(1,I) =VHKT(1,J) |
| 36785 | VHKK(2,I) =VHKT(2,J) |
| 36786 | VHKK(3,I) =VHKT(3,J) |
| 36787 | VHKK(4,I) =VHKT(4,J) |
| 36788 | WHKK(1,I) =WHKT(1,J) |
| 36789 | WHKK(2,I) =WHKT(2,J) |
| 36790 | WHKK(3,I) =WHKT(3,J) |
| 36791 | WHKK(4,I) =WHKT(4,J) |
| 36792 | RETURN |
| 36793 | END |
| 36794 | * |
| 36795 | *===dbreak=============================================================* |
| 36796 | * |
| 36797 | CDECK ID>, DT_DBREAK |
| 36798 | SUBROUTINE DT_DBREAK(MODE) |
| 36799 | |
| 36800 | ************************************************************************ |
| 36801 | * This is the steering subroutine for the different diquark breaking * |
| 36802 | * mechanisms. * |
| 36803 | * * |
| 36804 | * MODE = 1 breaking of projectile diquark in qq-q chain using * |
| 36805 | * a sea quark (q-qq chain) of the same projectile * |
| 36806 | * = 2 breaking of target diquark in q-qq chain using * |
| 36807 | * a sea quark (qq-q chain) of the same target * |
| 36808 | * = 3 breaking of projectile diquark in qq-q chain using * |
| 36809 | * a sea quark (q-aq chain) of the same projectile * |
| 36810 | * = 4 breaking of target diquark in q-qq chain using * |
| 36811 | * a sea quark (aq-q chain) of the same target * |
| 36812 | * = 5 breaking of projectile anti-diquark in aqaq-aq chain using * |
| 36813 | * a sea anti-quark (aq-aqaq chain) of the same projectile * |
| 36814 | * = 6 breaking of target anti-diquark in aq-aqaq chain using * |
| 36815 | * a sea anti-quark (aqaq-aq chain) of the same target * |
| 36816 | * = 7 breaking of projectile anti-diquark in aqaq-aq chain using * |
| 36817 | * a sea anti-quark (aq-q chain) of the same projectile * |
| 36818 | * = 8 breaking of target anti-diquark in aq-aqaq chain using * |
| 36819 | * a sea anti-quark (q-aq chain) of the same target * |
| 36820 | * * |
| 36821 | * Original version by J. Ranft. * |
| 36822 | * This version dated 17.5.00 is written by S. Roesler. * |
| 36823 | ************************************************************************ |
| 36824 | |
| 36825 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 36826 | SAVE |
| 36827 | |
| 36828 | PARAMETER ( LINP = 5 , |
| 36829 | & LOUT = 6 , |
| 36830 | & LDAT = 9 ) |
| 36831 | |
| 36832 | * event history |
| 36833 | |
| 36834 | PARAMETER (NMXHKK=200000) |
| 36835 | |
| 36836 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), |
| 36837 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), |
| 36838 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) |
| 36839 | * extended event history |
| 36840 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), |
| 36841 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), |
| 36842 | & IHIST(2,NMXHKK) |
| 36843 | * flags for input different options |
| 36844 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO |
| 36845 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), |
| 36846 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT |
| 36847 | * pointer to chains in hkkevt common (used by qq-breaking mechanisms) |
| 36848 | PARAMETER (MAXCHN=10000) |
| 36849 | COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN |
| 36850 | * diquark-breaking mechanism |
| 36851 | COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3 |
| 36852 | * flags for particle decays |
| 36853 | COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20), |
| 36854 | & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20), |
| 36855 | & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0 |
| 36856 | |
| 36857 | * |
| 36858 | * chain identifiers |
| 36859 | * ( 1 = q-aq, 2 = aq-q, 3 = q-qq, 4 = qq-q, |
| 36860 | * 5 = aq-adq, 6 = adq-aq, 7 = dq-adq, 8 = adq-dq ) |
| 36861 | DIMENSION IDCHN1(8),IDCHN2(8) |
| 36862 | DATA IDCHN1 / 4, 3, 4, 3, 6, 5, 6, 5/ |
| 36863 | DATA IDCHN2 / 3, 4, 1, 2, 5, 6, 2, 1/ |
| 36864 | * |
| 36865 | * parton identifiers |
| 36866 | * ( +-21/22 = valence, +-31/32 = Glauber-sea, +-41/42 = Pomeron (diff), |
| 36867 | * +-51/52 = unitarity-sea, +-61/62 = gluons ) |
| 36868 | DIMENSION ISP1P(8,3),ISP1T(8,3),ISP2P(8,3),ISP2T(8,3) |
| 36869 | DATA ISP1P / 21, 21, 21, 21, 21, 21, 21, 21, |
| 36870 | & 31, 31, 31, 31, 31, 31, 31, 31, |
| 36871 | & 41, 41, 41, 41, 51, 51, 51, 51/ |
| 36872 | DATA ISP1T / 22, 22, 22, 22, 22, 22, 22, 22, |
| 36873 | & 32, 32, 32, 32, 32, 32, 32, 32, |
| 36874 | & 42, 42, 42, 42, 52, 52, 52, 52/ |
| 36875 | DATA ISP2P / 31, 21, 31, 31, 21, 21, 21, 21, |
| 36876 | & 51, 31, 41, 41, 31, 31, 31, 31, |
| 36877 | & 0, 41, 51, 51, 51, 51, 51, 51/ |
| 36878 | DATA ISP2T / 22, 32, 32, 32, 22, 22, 22, 22, |
| 36879 | & 32, 52, 42, 42, 32, 32, 32, 32, |
| 36880 | & 42, 0, 52, 52, 52, 52, 52, 52/ |
| 36881 | |
| 36882 | IF (NCHAIN.LE.0) RETURN |
| 36883 | DO 1 I=1,NCHAIN |
| 36884 | IDX1 = IDXCHN(1,I) |
| 36885 | IS1P = ABS(ISTHKK(JMOHKK(1,IDX1))) |
| 36886 | IS1T = ABS(ISTHKK(JMOHKK(2,IDX1))) |
| 36887 | IF ( (IDXCHN(2,I).EQ.IDCHN1(MODE)) |
| 36888 | & .AND. |
| 36889 | & ((IS1P.EQ.ISP1P(MODE,1)).OR.(IS1P.EQ.ISP1P(MODE,2)).OR. |
| 36890 | & (IS1P.EQ.ISP1P(MODE,3))) |
| 36891 | & .AND. |
| 36892 | & ((IS1T.EQ.ISP1T(MODE,1)).OR.(IS1T.EQ.ISP1T(MODE,2)).OR. |
| 36893 | & (IS1T.EQ.ISP1T(MODE,3))) |
| 36894 | & ) THEN |
| 36895 | DO 2 J=1,NCHAIN |
| 36896 | IDX2 = IDXCHN(1,J) |
| 36897 | IS2P = ABS(ISTHKK(JMOHKK(1,IDX2))) |
| 36898 | IS2T = ABS(ISTHKK(JMOHKK(2,IDX2))) |
| 36899 | IF ( (IDXCHN(2,J).EQ.IDCHN2(MODE)) |
| 36900 | & .AND. |
| 36901 | & ((IS2P.EQ.ISP2P(MODE,1)).OR.(IS2P.EQ.ISP2P(MODE,2)) |
| 36902 | & .OR.(IS2P.EQ.ISP2P(MODE,3))) |
| 36903 | & .AND. |
| 36904 | & ((IS2T.EQ.ISP2T(MODE,1)).OR.(IS2T.EQ.ISP2T(MODE,2)) |
| 36905 | & .OR.(IS2T.EQ.ISP2T(MODE,3))) |
| 36906 | & ) THEN |
| 36907 | * find mother nucleons of the diquark to be splitted and of the |
| 36908 | * sea-quark and reject this combination if it is not the same |
| 36909 | IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR. |
| 36910 | & (MODE.EQ.5).OR.(MODE.EQ.7)) THEN |
| 36911 | IANCES = 1 |
| 36912 | ELSE |
| 36913 | IANCES = 2 |
| 36914 | ENDIF |
| 36915 | IDXMO1 = JMOHKK(IANCES,IDX1) |
| 36916 | 4 CONTINUE |
| 36917 | IF ((JMOHKK(1,IDXMO1).NE.0).AND. |
| 36918 | & (JMOHKK(2,IDXMO1).NE.0)) THEN |
| 36919 | IANC = IANCES |
| 36920 | ELSE |
| 36921 | IANC = 1 |
| 36922 | ENDIF |
| 36923 | IF (JMOHKK(IANC,IDXMO1).NE.0) THEN |
| 36924 | IDXMO1 = JMOHKK(IANC,IDXMO1) |
| 36925 | GOTO 4 |
| 36926 | ENDIF |
| 36927 | IDXMO2 = JMOHKK(IANCES,IDX2) |
| 36928 | 5 CONTINUE |
| 36929 | IF ((JMOHKK(1,IDXMO2).NE.0).AND. |
| 36930 | & (JMOHKK(2,IDXMO2).NE.0)) THEN |
| 36931 | IANC = IANCES |
| 36932 | ELSE |
| 36933 | IANC = 1 |
| 36934 | ENDIF |
| 36935 | IF (JMOHKK(IANC,IDXMO2).NE.0) THEN |
| 36936 | IDXMO2 = JMOHKK(IANC,IDXMO2) |
| 36937 | GOTO 5 |
| 36938 | ENDIF |
| 36939 | IF (IDXMO1.NE.IDXMO2) GOTO 2 |
| 36940 | * quark content of projectile parton |
| 36941 | IP1 = IDHKK(JMOHKK(1,IDX1)) |
| 36942 | IP11 = IP1/1000 |
| 36943 | IP12 = (IP1-1000*IP11)/100 |
| 36944 | IP2 = IDHKK(JMOHKK(2,IDX1)) |
| 36945 | IP21 = IP2/1000 |
| 36946 | IP22 = (IP2-1000*IP21)/100 |
| 36947 | * quark content of target parton |
| 36948 | IT1 = IDHKK(JMOHKK(1,IDX2)) |
| 36949 | IT11 = IT1/1000 |
| 36950 | IT12 = (IT1-1000*IT11)/100 |
| 36951 | IT2 = IDHKK(JMOHKK(2,IDX2)) |
| 36952 | IT21 = IT2/1000 |
| 36953 | IT22 = (IT2-1000*IT21)/100 |
| 36954 | * split diquark and form new chains |
| 36955 | IF (MODE.EQ.1) THEN |
| 36956 | IF (IT1.EQ.4) GOTO 2 |
| 36957 | CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), |
| 36958 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, |
| 36959 | & IP11,IP12,IP2,IT1,IT21,IT22,1,IPQ,IGCOUN) |
| 36960 | ELSEIF (MODE.EQ.2) THEN |
| 36961 | IF (IT2.EQ.4) GOTO 2 |
| 36962 | CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), |
| 36963 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, |
| 36964 | & IP1,IP21,IP22,IT11,IT12,IT2,1,IPQ,IGCOUN) |
| 36965 | ELSEIF (MODE.EQ.3) THEN |
| 36966 | IF (IT1.EQ.4) GOTO 2 |
| 36967 | CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), |
| 36968 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, |
| 36969 | & IP11,IP12,IP2,IT1,IT2,1,IPQ,IGCOUN) |
| 36970 | ELSEIF (MODE.EQ.4) THEN |
| 36971 | IF (IT2.EQ.4) GOTO 2 |
| 36972 | CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), |
| 36973 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, |
| 36974 | & IP1,IP21,IP22,IT1,IT2,1,IPQ,IGCOUN) |
| 36975 | ELSEIF (MODE.EQ.5) THEN |
| 36976 | CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), |
| 36977 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, |
| 36978 | & IP11,IP12,IP2,IT1,IT21,IT22,2,IPQ,IGCOUN) |
| 36979 | ELSEIF (MODE.EQ.6) THEN |
| 36980 | CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), |
| 36981 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, |
| 36982 | & IP1,IP21,IP22,IT11,IT12,IT2,2,IPQ,IGCOUN) |
| 36983 | ELSEIF (MODE.EQ.7) THEN |
| 36984 | CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), |
| 36985 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, |
| 36986 | & IP11,IP12,IP2,IT1,IT2,2,IPQ,IGCOUN) |
| 36987 | ELSEIF (MODE.EQ.8) THEN |
| 36988 | CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), |
| 36989 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, |
| 36990 | & IP1,IP21,IP22,IT1,IT2,2,IPQ,IGCOUN) |
| 36991 | ENDIF |
| 36992 | IF (IREJ.GE.1) THEN |
| 36993 | if ((ipq.lt.0).or.(ipq.ge.4)) |
| 36994 | & write(LOUT,*) 'ipq !!!',ipq,mode |
| 36995 | DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0 |
| 36996 | * accept or reject new chains corresponding to PDBSEA |
| 36997 | ELSE |
| 36998 | IF ((IPQ.EQ.1).OR.(IPQ.EQ.2)) THEN |
| 36999 | ACC = DBRKA(1,MODE)+DBRKA(2,MODE) |
| 37000 | REJ = DBRKR(1,MODE)+DBRKR(2,MODE) |
| 37001 | ELSEIF (IPQ.EQ.3) THEN |
| 37002 | ACC = DBRKA(3,MODE) |
| 37003 | REJ = DBRKR(3,MODE) |
| 37004 | ELSE |
| 37005 | WRITE(LOUT,*) ' inconsistent IPQ ! ',IPQ |
| 37006 | STOP |
| 37007 | ENDIF |
| 37008 | IF (ACC/(ACC+REJ).LE.PDBSEA(IPQ)) THEN |
| 37009 | DBRKA(IPQ,MODE) = DBRKA(IPQ,MODE)+1.0D0 |
| 37010 | IACC = 1 |
| 37011 | ELSE |
| 37012 | DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0 |
| 37013 | IACC = 0 |
| 37014 | ENDIF |
| 37015 | * new chains have been accepted and are now copied into HKKEVT |
| 37016 | IF (IACC.EQ.1) THEN |
| 37017 | IF (LEMCCK) THEN |
| 37018 | CALL DT_EVTEMC(PHKK(1,IDX1),PHKK(2,IDX1), |
| 37019 | & PHKK(3,IDX1),PHKK(4,IDX1), |
| 37020 | & 1,IDUM1,IDUM2) |
| 37021 | CALL DT_EVTEMC(PHKK(1,IDX2),PHKK(2,IDX2), |
| 37022 | & PHKK(3,IDX2),PHKK(4,IDX2), |
| 37023 | & 2,IDUM1,IDUM2) |
| 37024 | ENDIF |
| 37025 | IDHKK(IDX1) = 99888 |
| 37026 | IDHKK(IDX2) = 99888 |
| 37027 | IDXCHN(2,I) = -1 |
| 37028 | IDXCHN(2,J) = -1 |
| 37029 | DO 3 K=1,IGCOUN |
| 37030 | NHKK = NHKK+1 |
| 37031 | CALL HKKHKT(NHKK,K) |
| 37032 | IF ((LEMCCK).AND.(IDHKK(NHKK).EQ.88888))THEN |
| 37033 | PX = -PHKK(1,NHKK) |
| 37034 | PY = -PHKK(2,NHKK) |
| 37035 | PZ = -PHKK(3,NHKK) |
| 37036 | PE = -PHKK(4,NHKK) |
| 37037 | CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2) |
| 37038 | ENDIF |
| 37039 | 3 CONTINUE |
| 37040 | IF (LEMCCK) THEN |
| 37041 | CHKLEV = 0.1D0 |
| 37042 | CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,9000, |
| 37043 | & IREJ) |
| 37044 | IF (IREJ.NE.0) CALL DT_EVTOUT(4) |
| 37045 | ENDIF |
| 37046 | GOTO 1 |
| 37047 | ENDIF |
| 37048 | ENDIF |
| 37049 | ENDIF |
| 37050 | 2 CONTINUE |
| 37051 | ENDIF |
| 37052 | 1 CONTINUE |
| 37053 | RETURN |
| 37054 | END |
| 37055 | * |
| 37056 | *===cqpair=============================================================* |
| 37057 | * |
| 37058 | CDECK ID>, DT_CQPAIR |
| 37059 | SUBROUTINE DT_CQPAIR(XQMAX,XAQMAX,XQ,XAQ,IFLV,IREJ) |
| 37060 | |
| 37061 | ************************************************************************ |
| 37062 | * This subroutine Creates a Quark-antiquark PAIR from the sea. * |
| 37063 | * * |
| 37064 | * XQMAX maxium energy fraction of quark (input) * |
| 37065 | * XAQMAX maxium energy fraction of antiquark (input) * |
| 37066 | * XQ energy fraction of quark (output) * |
| 37067 | * XAQ energy fraction of antiquark (output) * |
| 37068 | * IFLV quark flavour (- antiquark flavor) (output) * |
| 37069 | * * |
| 37070 | * This version dated 14.5.00 is written by S. Roesler. * |
| 37071 | ************************************************************************ |
| 37072 | |
| 37073 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 37074 | SAVE |
| 37075 | |
| 37076 | PARAMETER ( LINP = 5 , |
| 37077 | & LOUT = 6 , |
| 37078 | & LDAT = 9 ) |
| 37079 | |
| 37080 | * Lorentz-parameters of the current interaction |
| 37081 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, |
| 37082 | & UMO,PPCM,EPROJ,PPROJ |
| 37083 | |
| 37084 | * |
| 37085 | IREJ = 0 |
| 37086 | XQ = 0.0D0 |
| 37087 | XAQ = 0.0D0 |
| 37088 | * |
| 37089 | * sample quark flavour |
| 37090 | * |
| 37091 | * set seasq here (the one from DTCHAI should be used in the future) |
| 37092 | SEASQ = 0.5D0 |
| 37093 | IFLV = INT(1.0D0+DT_RNDM(XQMAX)*(2.0D0+SEASQ)) |
| 37094 | * |
| 37095 | * sample energy fractions of sea pair |
| 37096 | * we first sample the energy fraction of a gluon and then split the gluon |
| 37097 | * |
| 37098 | * maximum energy fraction of the gluon forced via input |
| 37099 | XGMAXI = XQMAX+XAQMAX |
| 37100 | * minimum energy fraction of the gluon |
| 37101 | XTHR1 = 4.0D0 /UMO**2 |
| 37102 | XTHR2 = 0.54D0/UMO**1.5D0 |
| 37103 | XGMIN = MAX(XTHR1,XTHR2) |
| 37104 | * maximum energy fraction of the gluon |
| 37105 | XGMAX = 0.3D0 |
| 37106 | XGMAX = MIN(XGMAXI,XGMAX) |
| 37107 | IF (XGMIN.GE.XGMAX) THEN |
| 37108 | IREJ = 1 |
| 37109 | RETURN |
| 37110 | ENDIF |
| 37111 | * |
| 37112 | * sample energy fraction of the gluon |
| 37113 | NLOOP = 0 |
| 37114 | 1 CONTINUE |
| 37115 | NLOOP = NLOOP+1 |
| 37116 | IF (NLOOP.GE.50) THEN |
| 37117 | IREJ = 1 |
| 37118 | RETURN |
| 37119 | ENDIF |
| 37120 | XGLUON = DT_SAMSQX(XGMIN,XGMAX) |
| 37121 | EGLUON = XGLUON*UMO/2.0D0 |
| 37122 | * |
| 37123 | * split gluon into q-aq pair (we follow PHOJET's subroutine PHO_GLU2QU) |
| 37124 | ZMIN = MIN(0.1D0,0.5D0/EGLUON) |
| 37125 | ZMAX = 1.0D0-ZMIN |
| 37126 | RZ = DT_RNDM(ZMAX) |
| 37127 | XHLP = ((1.0D0-RZ)*ZMIN**3+RZ*ZMAX**3)**0.33333 |
| 37128 | RQ = DT_RNDM(ZMAX) |
| 37129 | IF (RQ.LT.0.5D0) THEN |
| 37130 | XQ = XGLUON*XHLP |
| 37131 | XAQ = XGLUON-XQ |
| 37132 | ELSE |
| 37133 | XAQ = XGLUON*XHLP |
| 37134 | XQ = XGLUON-XAQ |
| 37135 | ENDIF |
| 37136 | IF ((XQ.GT.XQMAX).OR.(XAQ.GT.XAQMAX)) GOTO 1 |
| 37137 | |
| 37138 | RETURN |
| 37139 | END |
git://git.uio.no / u / mrichter / AliRoot.git / blame