]>
Commit | Line | Data |
---|---|---|
7b076c76 | 1 | *$ CREATE DT_INIT.FOR |
2 | *COPY DT_INIT | |
3 | * | |
4 | * +-------------------------------------------------------------+ | |
5 | * | | | |
6 | * | | | |
7 | * | DPMJET 3.0 | | |
8 | * | | | |
9 | * | | | |
10 | * | S. Roesler+), R. Engel#), J. Ranft*) | | |
11 | * | | | |
12 | * | +) CERN, SC-RP | | |
13 | * | CH-1211 Geneva 23, Switzerland | | |
14 | * | Email: Stefan.Roesler@cern.ch | | |
15 | * | | | |
16 | * | #) Institut fuer Kernphysik | | |
17 | * | Forschungszentrum Karlsruhe | | |
18 | * | D-76021 Karlsruhe, Germany | | |
19 | * | | | |
20 | * | *) University of Siegen, Dept. of Physics | | |
21 | * | D-57068 Siegen, Germany | | |
22 | * | | | |
23 | * | | | |
24 | * | http://home.cern.ch/sroesler/dpmjet3.html | | |
25 | * | | | |
26 | * | | | |
27 | * | Monte Carlo models used for event generation: | | |
28 | * | PHOJET 1.12, JETSET 7.4 and LEPTO 6.5.1 | | |
29 | * | | | |
30 | * +-------------------------------------------------------------+ | |
31 | * | |
32 | * | |
33 | *===init===============================================================* | |
34 | * | |
35 | SUBROUTINE DT_INIT(NCASES,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR, | |
36 | & IDP,IGLAU) | |
37 | ||
38 | ************************************************************************ | |
39 | * Initialization of event generation * | |
40 | * This version dated 7.4.98 is written by S. Roesler. * | |
41 | * * | |
42 | * Last change 27.12.2006 by S. Roesler. * | |
43 | ************************************************************************ | |
44 | ||
45 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
46 | SAVE | |
47 | ||
48 | PARAMETER ( LINP = 10 , | |
49 | & LOUT = 6 , | |
50 | & LDAT = 9 ) | |
51 | PARAMETER (ZERO=0.0D0,ONE=1.0D0) | |
52 | ||
53 | * particle properties (BAMJET index convention) | |
54 | CHARACTER*8 ANAME | |
55 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
56 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
57 | ||
58 | * names of hadrons used in input-cards | |
59 | CHARACTER*8 BTYPE | |
60 | COMMON /DTPAIN/ BTYPE(30) | |
61 | ||
62 | * INCLUDE '(DIMPAR)' | |
63 | * DIMPAR taken from FLUKA | |
64 | PARAMETER ( MXXRGN =20000 ) | |
65 | PARAMETER ( MXXMDF = 710 ) | |
66 | PARAMETER ( MXXMDE = 702 ) | |
67 | PARAMETER ( MFSTCK =40000 ) | |
68 | PARAMETER ( MESTCK = 100 ) | |
69 | PARAMETER ( MOSTCK = 2000 ) | |
70 | PARAMETER ( MXPRSN = 100 ) | |
71 | PARAMETER ( MXPDPM = 800 ) | |
72 | PARAMETER ( MXPSCS =30000 ) | |
73 | PARAMETER ( MXGLWN = 300 ) | |
74 | PARAMETER ( MXOUTU = 50 ) | |
75 | PARAMETER ( NALLWP = 64 ) | |
76 | PARAMETER ( NELEMX = 80 ) | |
77 | PARAMETER ( MPDPDX = 18 ) | |
78 | PARAMETER ( MXHTTR = 260 ) | |
79 | PARAMETER ( MXSEAX = 20 ) | |
80 | PARAMETER ( MXHTNC = MXSEAX + 1 ) | |
81 | PARAMETER ( ICOMAX = 2400 ) | |
82 | PARAMETER ( ICHMAX = ICOMAX + MXXMDF ) | |
83 | PARAMETER ( NSTBIS = 304 ) | |
84 | PARAMETER ( NQSTIS = 46 ) | |
85 | PARAMETER ( NTSTIS = NSTBIS + NQSTIS ) | |
86 | PARAMETER ( MXPABL = 120 ) | |
87 | PARAMETER ( IDMAXP = 450 ) | |
88 | PARAMETER ( IDMXDC = 2000 ) | |
89 | PARAMETER ( MXMCIN = 410 ) | |
90 | PARAMETER ( IHYPMX = 4 ) | |
91 | PARAMETER ( MKBMX1 = 11 ) | |
92 | PARAMETER ( MKBMX2 = 11 ) | |
93 | PARAMETER ( MXIRRD = 2500 ) | |
94 | PARAMETER ( MXTRDC = 1500 ) | |
95 | PARAMETER ( NKTL = 17 ) | |
96 | PARAMETER ( NBLNMX = 40000000 ) | |
97 | ||
98 | * INCLUDE '(PAREVT)' | |
99 | * PAREVT taken from FLUKA | |
100 | PARAMETER ( FRDIFF = 0.2D+00 ) | |
101 | PARAMETER ( ETHSEA = 1.0D+00 ) | |
102 | * | |
103 | LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX, | |
104 | & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI, | |
105 | & LNUCRI, LPEANU, LEVBME, LPHDRC, LATMSS, LISMRS, LCHDCY, | |
106 | & LCHDCR, LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN | |
107 | COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC, | |
108 | & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY, | |
109 | & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV, | |
110 | & LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LEVBME, | |
111 | & LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR, | |
112 | & LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN | |
113 | ||
114 | * INCLUDE '(EVAFLG)' | |
115 | * EVAFLG taken from FLUKA | |
116 | LOGICAL LOLDEV, LUFULL, LNWLOW, LASMEN, LGMCMP, LGDRFT, LDSCLV, | |
117 | & LDSCGM, LNDSLD, LMNJPR, LBRPEN, LNWBRP, LIFKEY, LOLDSM, | |
118 | & LNAIPR, LGUSPR, LFLKCO, LLVMOD, LHVEVP, LHVECN, LHVCAL, | |
119 | & LHVRAL, LHVSGF, LTMCRR, LBZZCR, LQCSKP, LEEXLV, LGEXLV | |
120 | COMMON / EVAFLG / BRPNFR (0:2), EBRPFR (0:2), EMVBRP (0:2), | |
121 | & FDSCST, | |
122 | & ILVMOD, JLVMOD, JSIPFL, IMSSFR, JMSSFR, IEVFSS, MXAHEV, | |
123 | & MXZHEV, IFHVFL, IFKYMX, IGMCMP, MPMODE, MSMODE, MUMODE, | |
124 | & MFMODE, MEMODE, MRMODE, ITMCRR, IASYCR, IFSBCR, IFSSBR, | |
125 | & LOLDEV, LUFULL, LNWLOW, LASMEN, LGMCMP, LGDRFT, LDSCLV, | |
126 | & LDSCGM, LNDSLD, LMNJPR, LBRPEN, LNWBRP, LIFKEY, LOLDSM, | |
127 | & LNAIPR, LGUSPR, LFLKCO, LLVMOD, LHVEVP, LHVECN, LHVCAL, | |
128 | & LHVRAL, LHVSGF, LTMCRR, LBZZCR, LQCSKP, LEEXLV, LGEXLV | |
129 | ||
130 | * INCLUDE '(FRBKCM)' | |
131 | * FRBKCM taken from FLUKA | |
132 | * Maximum number of fragments to be emitted: | |
133 | PARAMETER ( MXFFBK = 6 ) | |
134 | PARAMETER ( MXZFBK = 10 ) | |
135 | PARAMETER ( MXNFBK = 12 ) | |
136 | PARAMETER ( MXAFBK = 16 ) | |
137 | PARAMETER ( MXASST = 25 ) | |
138 | PARAMETER ( NXAFBK = MXAFBK + 1 ) | |
139 | PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 + MXASST - NXAFBK ) | |
140 | PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 + MXASST - NXAFBK ) | |
141 | PARAMETER ( MXPSST = 700 ) | |
142 | * Maximum number of pre-computed break-up combinations | |
143 | PARAMETER ( MXPPFB = 42500 ) | |
144 | * Maximum number of break-up combinations, including special | |
145 | * run-time ones: | |
146 | PARAMETER ( MXPSFB = 43000 ) | |
147 | * Base for J multiplicity encoding: | |
148 | PARAMETER ( IBFRBK = 73 ) | |
149 | * Maximum Ibfrbk exponent to avoid overflow of I*4(roughly at 2.1x10^9) | |
150 | * it must be (Ibfrbk-1) + (Ibfrbk-1)*Ibfrbk + (Ibfrbk-1)*Ibfrbk^2 + ... | |
151 | * ... + (Ibfrbk-1)*Ibfrbk^Jpwfbx < 2100000000, | |
152 | * --> Ibfrbk^(Jpwfbx+1) < 2100000000 | |
153 | PARAMETER ( JPWFBX = 4 ) | |
154 | LOGICAL LFRMBK, LNCMSS | |
155 | COMMON / FRBKCM / AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST), | |
156 | & WEIFBK (MXPSST), GAMFBK (MXPSST), EXFRBK (MXPSFB), | |
157 | & SDMFBK (MXPSFB), COUFBK (MXPSFB), CENFBK (MXPSFB), | |
158 | & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK, FRBKLS, | |
159 | & IFRBKN (MXPSST), IFRBKZ (MXPSST), | |
160 | & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST), | |
161 | & IPSIND (0:NXNFBK,0:NXZFBK,2), JPSIND (0:MXASST), | |
162 | & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK), | |
163 | & IFBCHA (9,MXPSFB), IPOSST, IPOSFB, IFBSTF, IFBPSF, | |
164 | & IFBFRB, IFBCHN, IFBNC1, IFBNC2, NBUFBK, LFRMBK, LNCMSS | |
165 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
166 | ||
167 | * emulsion treatment | |
168 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
169 | & NCOMPO,IEMUL | |
170 | ||
171 | * Glauber formalism: parameters | |
172 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), | |
173 | & BMAX(NCOMPX),BSTEP(NCOMPX), | |
174 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), | |
175 | & NSITEB,NSTATB | |
176 | ||
177 | * Glauber formalism: cross sections | |
178 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
179 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
180 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
181 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
182 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
183 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
184 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
185 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
186 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
187 | & BSLOPE,NEBINI,NQBINI | |
188 | ||
189 | * interface HADRIN-DPM | |
190 | COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA | |
191 | ||
192 | * central particle production, impact parameter biasing | |
193 | COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR | |
194 | ||
195 | * parameter for intranuclear cascade | |
196 | LOGICAL LPAULI | |
197 | COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI | |
198 | ||
199 | * various options for treatment of partons (DTUNUC 1.x) | |
200 | * (chain recombination, Cronin,..) | |
201 | LOGICAL LCO2CR,LINTPT | |
202 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, | |
203 | & LCO2CR,LINTPT | |
204 | ||
205 | * threshold values for x-sampling (DTUNUC 1.x) | |
206 | COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA, | |
207 | & SSMIMQ,VVMTHR | |
208 | ||
209 | * flags for input different options | |
210 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
211 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
212 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
213 | ||
214 | * nuclear potential | |
215 | LOGICAL LFERMI | |
216 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, | |
217 | & EBINDP(2),EBINDN(2),EPOT(2,210), | |
218 | & ETACOU(2),ICOUL,LFERMI | |
219 | ||
220 | * n-n cross section fluctuations | |
221 | PARAMETER (NBINS = 1000) | |
222 | COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT | |
223 | ||
224 | * flags for particle decays | |
225 | COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20), | |
226 | & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20), | |
227 | & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0 | |
228 | ||
229 | * diquark-breaking mechanism | |
230 | COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3 | |
231 | ||
232 | * nucleon-nucleon event-generator | |
233 | CHARACTER*8 CMODEL | |
234 | LOGICAL LPHOIN | |
235 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
236 | ||
237 | * properties of interacting particles | |
238 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
239 | ||
240 | * properties of photon/lepton projectiles | |
241 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC | |
242 | ||
243 | * flags for diffractive interactions (DTUNUC 1.x) | |
244 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF | |
245 | ||
246 | * parameters for hA-diffraction | |
247 | COMMON /DTDIHA/ DIBETA,DIALPH | |
248 | ||
249 | * Lorentz-parameters of the current interaction | |
250 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
251 | & UMO,PPCM,EPROJ,PPROJ | |
252 | ||
253 | * kinematical cuts for lepton-nucleus interactions | |
254 | COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX, | |
255 | & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI | |
256 | ||
257 | * VDM parameter for photon-nucleus interactions | |
258 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
259 | ||
260 | * Glauber formalism: flags and parameters for statistics | |
261 | LOGICAL LPROD | |
262 | CHARACTER*8 CGLB | |
263 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD | |
264 | ||
265 | * cuts for variable energy runs | |
266 | COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI | |
267 | ||
268 | * flags for activated histograms | |
269 | COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL | |
270 | ||
271 | COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) | |
272 | COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5) | |
273 | ||
274 | * LEPTO | |
275 | **LUND single / double precision | |
276 | REAL CUT,PARL,TMPX,TMPY,TMPW2,TMPQ2,TMPU | |
277 | COMMON /LEPTOU/ CUT(14),LST(40),PARL(30), | |
278 | & TMPX,TMPY,TMPW2,TMPQ2,TMPU | |
279 | ||
280 | * LEPTO | |
281 | REAL RPPN | |
282 | COMMON /LEPTOI/ RPPN,LEPIN,INTER | |
283 | ||
284 | * steering flags for qel neutrino scattering modules | |
285 | COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC | |
286 | ||
287 | * event flag | |
288 | COMMON /DTEVNO/ NEVENT,ICASCA | |
289 | ||
290 | INTEGER PYCOMP | |
291 | ||
292 | C DIMENSION XPARA(5) | |
293 | DIMENSION XDUMB(40),IPRANG(5) | |
294 | ||
295 | PARAMETER (MXCARD=58) | |
296 | CHARACTER*78 CLINE,CTITLE | |
297 | CHARACTER*60 CWHAT | |
298 | CHARACTER*8 BLANK,SDUM | |
299 | CHARACTER*10 CODE,CODEWD | |
300 | CHARACTER*72 HEADER | |
301 | LOGICAL LSTART,LEINP,LXSTAB | |
302 | DIMENSION WHAT(6),CODE(MXCARD) | |
303 | DATA CODE/ | |
304 | & 'TITLE ','PROJPAR ','TARPAR ','ENERGY ', | |
305 | & 'MOMENTUM ','CMENERGY ','EMULSION ','FERMI ', | |
306 | & 'TAUFOR ','PAULI ','COULOMB ','HADRIN ', | |
307 | & 'EVAP ','EMCCHECK ','MODEL ','PHOINPUT ', | |
308 | & 'GLAUBERI ','FLUCTUAT ','CENTRAL ','RECOMBIN ', | |
309 | & 'COMBIJET ','XCUTS ','INTPT ','CRONINPT ', | |
310 | & 'SEADISTR ','SEASU3 ','DIQUARKS ','RESONANC ', | |
311 | & 'DIFFRACT ','SINGLECH ','NOFRAGME ','HADRONIZE ', | |
312 | & 'POPCORN ','PARDECAY ','BEAM ','LUND-MSTU ', | |
313 | & 'LUND-MSTJ ','LUND-MDCY ','LUND-PARJ ','LUND-PARU ', | |
314 | & 'OUTLEVEL ','FRAME ','L-TAG ','L-ETAG ', | |
315 | & 'ECMS-CUT ','VDM-PAR1 ','HISTOGRAM ','XS-TABLE ', | |
316 | & 'GLAUB-PAR ','GLAUB-INI ','VDM-PAR2 ','XS-QELPRO ', | |
317 | & 'RNDMINIT ','LEPTO-CUT ','LEPTO-LST ','LEPTO-PARL', | |
318 | & 'START ','STOP '/ | |
319 | DATA BLANK /' '/ | |
320 | ||
321 | DATA LSTART,LXSTAB,IFIRST /.TRUE.,.FALSE.,1/ | |
322 | DATA CMEOLD /0.0D0/ | |
323 | ||
324 | *--------------------------------------------------------------------- | |
325 | * at the first call of INIT: initialize event generation | |
326 | EPNSAV = EPN | |
327 | IF (LSTART) THEN | |
328 | CALL DT_TITLE | |
329 | * initialization and test of the random number generator | |
330 | IF (ITRSPT.NE.1) THEN | |
331 | ||
332 | IJKLIN = -1 | |
333 | INSEED = 1 | |
334 | ISEED1 = 0 | |
335 | ISEED2 = 0 | |
336 | CALL RNINIT (INSEED,IJKLIN,ISEED1,ISEED2) | |
337 | ||
338 | ENDIF | |
339 | * initialization of BAMJET, DECAY and HADRIN | |
340 | CALL DT_DDATAR | |
341 | CALL DT_DHADDE | |
342 | CALL DT_DCHANT | |
343 | CALL DT_DCHANH | |
344 | * set default values for input variables | |
345 | CALL DT_DEFAUL(EPN,PPN) | |
346 | IGLAU = 0 | |
347 | IXSQEL = 0 | |
348 | * flag for collision energy input | |
349 | LEINP = .FALSE. | |
350 | LSTART = .FALSE. | |
351 | ENDIF | |
352 | ||
353 | *--------------------------------------------------------------------- | |
354 | 10 CONTINUE | |
355 | ||
356 | * bypass reading input cards (e.g. for use with Fluka) | |
357 | * in this case Epn is expected to carry the beam momentum | |
358 | IF (NCASES.EQ.-1) THEN | |
359 | IP = NPMASS | |
360 | IPZ = NPCHAR | |
361 | PPN = EPNSAV | |
362 | EPN = ZERO | |
363 | CMENER = ZERO | |
364 | LEINP = .TRUE. | |
365 | MKCRON = 0 | |
366 | WHAT(1) = 1 | |
367 | WHAT(2) = 0 | |
368 | CODEWD = 'START ' | |
369 | GOTO 900 | |
370 | ENDIF | |
371 | ||
372 | * read control card from input-unit LINP | |
373 | READ(LINP,'(A78)',END=9999) CLINE | |
374 | IF (CLINE(1:1).EQ.'*') THEN | |
375 | * comment-line | |
376 | WRITE(LOUT,'(A78)') CLINE | |
377 | GOTO 10 | |
378 | ENDIF | |
379 | C READ(CLINE,1000,END=9999) CODEWD,(WHAT(I),I=1,6),SDUM | |
380 | C1000 FORMAT(A10,6E10.0,A8) | |
381 | DO 1008 I=1,6 | |
382 | WHAT(I) = ZERO | |
383 | 1008 CONTINUE | |
384 | READ(CLINE,1006,END=9999) CODEWD,CWHAT,SDUM | |
385 | 1006 FORMAT(A10,A60,A8) | |
386 | READ(CWHAT,*,END=1007) (WHAT(I),I=1,6) | |
387 | 1007 CONTINUE | |
388 | WRITE(LOUT,1001) CODEWD,(WHAT(I),I=1,6),SDUM | |
389 | 1001 FORMAT(A10,6G10.3,A8) | |
390 | ||
391 | 900 CONTINUE | |
392 | ||
393 | * check for valid control card and get card index | |
394 | ICW = 0 | |
395 | DO 11 I=1,MXCARD | |
396 | IF (CODEWD.EQ.CODE(I)) ICW = I | |
397 | 11 CONTINUE | |
398 | IF (ICW.EQ.0) THEN | |
399 | WRITE(LOUT,1002) CODEWD | |
400 | 1002 FORMAT(/,1X,'---> ',A10,': invalid control-card !',/) | |
401 | GOTO 10 | |
402 | ENDIF | |
403 | ||
404 | GOTO( | |
405 | *------------------------------------------------------------ | |
406 | * TITLE , PROJPAR , TARPAR , ENERGY , MOMENTUM, | |
407 | & 100 , 110 , 120 , 130 , 140 , | |
408 | * | |
409 | *------------------------------------------------------------ | |
410 | * CMENERGY, EMULSION, FERMI , TAUFOR , PAULI , | |
411 | & 150 , 160 , 170 , 180 , 190 , | |
412 | * | |
413 | *------------------------------------------------------------ | |
414 | * COULOMB , HADRIN , EVAP , EMCCHECK, MODEL , | |
415 | & 200 , 210 , 220 , 230 , 240 , | |
416 | * | |
417 | *------------------------------------------------------------ | |
418 | * PHOINPUT, GLAUBERI, FLUCTUAT, CENTRAL , RECOMBIN, | |
419 | & 250 , 260 , 270 , 280 , 290 , | |
420 | * | |
421 | *------------------------------------------------------------ | |
422 | * COMBIJET, XCUTS , INTPT , CRONINPT, SEADISTR, | |
423 | & 300 , 310 , 320 , 330 , 340 , | |
424 | * | |
425 | *------------------------------------------------------------ | |
426 | * SEASU3 , DIQUARKS, RESONANC, DIFFRACT, SINGLECH, | |
427 | & 350 , 360 , 370 , 380 , 390 , | |
428 | * | |
429 | *------------------------------------------------------------ | |
430 | * NOFRAGME, HADRONIZE, POPCORN , PARDECAY, BEAM , | |
431 | & 400 , 410 , 420 , 430 , 440 , | |
432 | * | |
433 | *------------------------------------------------------------ | |
434 | * LUND-MSTU, LUND-MSTJ, LUND-MDCY, LUND-PARJ, LUND-PARU, | |
435 | & 450 , 451 , 452 , 460 , 470 , | |
436 | * | |
437 | *------------------------------------------------------------ | |
438 | * OUTLEVEL, FRAME , L-TAG , L-ETAG , ECMS-CUT, | |
439 | & 480 , 490 , 500 , 510 , 520 , | |
440 | * | |
441 | *------------------------------------------------------------ | |
442 | * VDM-PAR1, HISTOGRAM, XS-TABLE , GLAUB-PAR, GLAUB-INI, | |
443 | & 530 , 540 , 550 , 560 , 565 , | |
444 | * | |
445 | *------------------------------------------------------------ | |
446 | * , , VDM-PAR2, XS-QELPRO, RNDMINIT , | |
447 | & 570 , 580 , 590 , | |
448 | * | |
449 | *------------------------------------------------------------ | |
450 | * LEPTO-CUT, LEPTO-LST,LEPTO-PARL, START , STOP ) | |
451 | & 600 , 610 , 620 , 630 , 640 ) , ICW | |
452 | * | |
453 | *------------------------------------------------------------ | |
454 | ||
455 | GOTO 10 | |
456 | ||
457 | ********************************************************************* | |
458 | * * | |
459 | * control card: codewd = TITLE * | |
460 | * * | |
461 | * what (1..6), sdum no meaning * | |
462 | * * | |
463 | * Note: The control-card following this must consist of * | |
464 | * a string of characters usually giving the title of * | |
465 | * the run. * | |
466 | * * | |
467 | ********************************************************************* | |
468 | ||
469 | 100 CONTINUE | |
470 | READ(LINP,'(A78)') CTITLE | |
471 | WRITE(LOUT,'(//,5X,A78,//)') CTITLE | |
472 | GOTO 10 | |
473 | ||
474 | ********************************************************************* | |
475 | * * | |
476 | * control card: codewd = PROJPAR * | |
477 | * * | |
478 | * what (1) = mass number of projectile nucleus default: 1 * | |
479 | * what (2) = charge of projectile nucleus default: 1 * | |
480 | * what (3..6) no meaning * | |
481 | * sdum projectile particle code word * | |
482 | * * | |
483 | * Note: If sdum is defined what (1..2) have no meaning. * | |
484 | * * | |
485 | ********************************************************************* | |
486 | ||
487 | 110 CONTINUE | |
488 | IF (SDUM.EQ.BLANK) THEN | |
489 | IP = INT(WHAT(1)) | |
490 | IPZ = INT(WHAT(2)) | |
491 | IJPROJ = 1 | |
492 | IBPROJ = 1 | |
493 | ELSE | |
494 | IJPROJ = 0 | |
495 | DO 111 II=1,30 | |
496 | IF (SDUM.EQ.BTYPE(II)) THEN | |
497 | IP = 1 | |
498 | IPZ = 1 | |
499 | IF (II.EQ.26) THEN | |
500 | IJPROJ = 135 | |
501 | ELSEIF (II.EQ.27) THEN | |
502 | IJPROJ = 136 | |
503 | ELSEIF (II.EQ.28) THEN | |
504 | IJPROJ = 133 | |
505 | ELSEIF (II.EQ.29) THEN | |
506 | IJPROJ = 134 | |
507 | ELSE | |
508 | IJPROJ = II | |
509 | ENDIF | |
510 | IBPROJ = IIBAR(IJPROJ) | |
511 | * photon | |
512 | IF ((IJPROJ.EQ.7).AND.(WHAT(1).GT.ZERO)) VIRT = WHAT(1) | |
513 | * lepton | |
514 | IF (((IJPROJ.EQ. 3).OR.(IJPROJ.EQ. 4).OR. | |
515 | & (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11)).AND. | |
516 | & (WHAT(1).GT.ZERO)) Q2HI = WHAT(1) | |
517 | ENDIF | |
518 | 111 CONTINUE | |
519 | IF (IJPROJ.EQ.0) THEN | |
520 | WRITE(LOUT,1110) | |
521 | 1110 FORMAT(/,1X,'invalid PROJPAR card !',/) | |
522 | GOTO 9999 | |
523 | ENDIF | |
524 | ENDIF | |
525 | GOTO 10 | |
526 | ||
527 | ********************************************************************* | |
528 | * * | |
529 | * control card: codewd = TARPAR * | |
530 | * * | |
531 | * what (1) = mass number of target nucleus default: 1 * | |
532 | * what (2) = charge of target nucleus default: 1 * | |
533 | * what (3..6) no meaning * | |
534 | * sdum target particle code word * | |
535 | * * | |
536 | * Note: If sdum is defined what (1..2) have no meaning. * | |
537 | * * | |
538 | ********************************************************************* | |
539 | ||
540 | 120 CONTINUE | |
541 | IF (SDUM.EQ.BLANK) THEN | |
542 | IT = INT(WHAT(1)) | |
543 | ITZ = INT(WHAT(2)) | |
544 | IJTARG = 1 | |
545 | IBTARG = 1 | |
546 | ELSE | |
547 | IJTARG = 0 | |
548 | DO 121 II=1,30 | |
549 | IF (SDUM.EQ.BTYPE(II)) THEN | |
550 | IT = 1 | |
551 | ITZ = 1 | |
552 | IJTARG = II | |
553 | IBTARG = IIBAR(IJTARG) | |
554 | ENDIF | |
555 | 121 CONTINUE | |
556 | IF (IJTARG.EQ.0) THEN | |
557 | WRITE(LOUT,1120) | |
558 | 1120 FORMAT(/,1X,'invalid TARPAR card !',/) | |
559 | GOTO 9999 | |
560 | ENDIF | |
561 | ENDIF | |
562 | GOTO 10 | |
563 | ||
564 | ********************************************************************* | |
565 | * * | |
566 | * control card: codewd = ENERGY * | |
567 | * * | |
568 | * what (1) = energy (GeV) of projectile in Lab. * | |
569 | * if what(1) < 0: |what(1)| = kinetic energy * | |
570 | * default: 200 GeV * | |
571 | * if |what(2)| > 0: min. energy for variable * | |
572 | * energy runs * | |
573 | * what (2) = max. energy for variable energy runs * | |
574 | * if what(2) < 0: |what(2)| = kinetic energy * | |
575 | * * | |
576 | ********************************************************************* | |
577 | ||
578 | 130 CONTINUE | |
579 | EPN = WHAT(1) | |
580 | PPN = ZERO | |
581 | CMENER = ZERO | |
582 | IF ((ABS(WHAT(2)).GT.ZERO).AND. | |
583 | & (ABS(WHAT(2)).GT.ABS(WHAT(1)))) THEN | |
584 | VARELO = WHAT(1) | |
585 | VAREHI = WHAT(2) | |
586 | EPN = VAREHI | |
587 | ENDIF | |
588 | LEINP = .TRUE. | |
589 | GOTO 10 | |
590 | ||
591 | ********************************************************************* | |
592 | * * | |
593 | * control card: codewd = MOMENTUM * | |
594 | * * | |
595 | * what (1) = momentum (GeV/c) of projectile in Lab. * | |
596 | * default: 200 GeV/c * | |
597 | * what (2..6), sdum no meaning * | |
598 | * * | |
599 | ********************************************************************* | |
600 | ||
601 | 140 CONTINUE | |
602 | EPN = ZERO | |
603 | PPN = WHAT(1) | |
604 | CMENER = ZERO | |
605 | LEINP = .TRUE. | |
606 | GOTO 10 | |
607 | ||
608 | ********************************************************************* | |
609 | * * | |
610 | * control card: codewd = CMENERGY * | |
611 | * * | |
612 | * what (1) = energy in nucleon-nucleon cms. * | |
613 | * default: none * | |
614 | * what (2..6), sdum no meaning * | |
615 | * * | |
616 | ********************************************************************* | |
617 | ||
618 | 150 CONTINUE | |
619 | EPN = ZERO | |
620 | PPN = ZERO | |
621 | CMENER = WHAT(1) | |
622 | LEINP = .TRUE. | |
623 | GOTO 10 | |
624 | ||
625 | ********************************************************************* | |
626 | * * | |
627 | * control card: codewd = EMULSION * | |
628 | * * | |
629 | * definition of nuclear emulsions * | |
630 | * * | |
631 | * what(1) mass number of emulsion component * | |
632 | * what(2) charge of emulsion component * | |
633 | * what(3) fraction of events in which a scattering on a * | |
634 | * nucleus of this properties is performed * | |
635 | * what(4,5,6) as what(1,2,3) but for another component * | |
636 | * default: no emulsion * | |
637 | * sdum no meaning * | |
638 | * * | |
639 | * Note: If this input-card is once used with valid parameters * | |
640 | * TARPAR is obsolete. * | |
641 | * Not the absolute values of the fractions are important * | |
642 | * but only the ratios of fractions of different comp. * | |
643 | * This control card can be repeatedly used to define * | |
644 | * emulsions consisting of up to 10 elements. * | |
645 | * * | |
646 | ********************************************************************* | |
647 | ||
648 | 160 CONTINUE | |
649 | IF ((WHAT(1).GT.ZERO).AND.(WHAT(2).GT.ZERO) | |
650 | & .AND.(ABS(WHAT(3)).GT.ZERO)) THEN | |
651 | NCOMPO = NCOMPO+1 | |
652 | IF (NCOMPO.GT.NCOMPX) THEN | |
653 | WRITE(LOUT,1600) | |
654 | STOP | |
655 | ENDIF | |
656 | IEMUMA(NCOMPO) = INT(WHAT(1)) | |
657 | IEMUCH(NCOMPO) = INT(WHAT(2)) | |
658 | EMUFRA(NCOMPO) = WHAT(3) | |
659 | IEMUL = 1 | |
660 | C CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO)) | |
661 | ENDIF | |
662 | IF ((WHAT(4).GT.ZERO).AND.(WHAT(5).GT.ZERO) | |
663 | & .AND.(ABS(WHAT(6)).GT.ZERO)) THEN | |
664 | NCOMPO = NCOMPO+1 | |
665 | IF (NCOMPO.GT.NCOMPX) THEN | |
666 | WRITE(LOUT,1001) | |
667 | STOP | |
668 | ENDIF | |
669 | IEMUMA(NCOMPO) = INT(WHAT(4)) | |
670 | IEMUCH(NCOMPO) = INT(WHAT(5)) | |
671 | EMUFRA(NCOMPO) = WHAT(6) | |
672 | C CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO)) | |
673 | ENDIF | |
674 | 1600 FORMAT(1X,'too many emulsion components - program stopped') | |
675 | GOTO 10 | |
676 | ||
677 | ********************************************************************* | |
678 | * * | |
679 | * control card: codewd = FERMI * | |
680 | * * | |
681 | * what (1) = -1 Fermi-motion of nucleons not treated * | |
682 | * default: 1 * | |
683 | * what (2) = scale factor for Fermi-momentum * | |
684 | * default: 0.75 * | |
685 | * what (3..6), sdum no meaning * | |
686 | * * | |
687 | ********************************************************************* | |
688 | ||
689 | 170 CONTINUE | |
690 | IF (WHAT(1).EQ.-1.0D0) THEN | |
691 | LFERMI = .FALSE. | |
692 | ELSE | |
693 | LFERMI = .TRUE. | |
694 | ENDIF | |
695 | XMOD = WHAT(2) | |
696 | IF (XMOD.GE.ZERO) FERMOD = XMOD | |
697 | GOTO 10 | |
698 | ||
699 | ********************************************************************* | |
700 | * * | |
701 | * control card: codewd = TAUFOR * | |
702 | * * | |
703 | * formation time supressed intranuclear cascade * | |
704 | * * | |
705 | * what (1) formation time (in fm/c) * | |
706 | * note: what(1)=10. corresponds roughly to an * | |
707 | * average formation time of 1 fm/c * | |
708 | * default: 5. fm/c * | |
709 | * what (2) number of generations followed * | |
710 | * default: 25 * | |
711 | * what (3) = 1. p_t-dependent formation zone * | |
712 | * = 2. constant formation zone * | |
713 | * default: 1 * | |
714 | * what (4) modus of selection of nucleus where the * | |
715 | * cascade if followed first * | |
716 | * = 1. proj./target-nucleus with probab. 1/2 * | |
717 | * = 2. nucleus with highest mass * | |
718 | * = 3. proj. nucleus if particle is moving in pos. z * | |
719 | * targ. nucleus if particle is moving in neg. z * | |
720 | * default: 1 * | |
721 | * what (5..6), sdum no meaning * | |
722 | * * | |
723 | ********************************************************************* | |
724 | ||
725 | 180 CONTINUE | |
726 | TAUFOR = WHAT(1) | |
727 | KTAUGE = INT(WHAT(2)) | |
728 | INCMOD = 1 | |
729 | IF ((WHAT(3).GE.1.0D0).AND.(WHAT(3).LE.2.0D0)) | |
730 | & ITAUVE = INT(WHAT(3)) | |
731 | IF ((WHAT(4).GE.1.0D0).AND.(WHAT(4).LE.3.0D0)) | |
732 | & INCMOD = INT(WHAT(4)) | |
733 | GOTO 10 | |
734 | ||
735 | ********************************************************************* | |
736 | * * | |
737 | * control card: codewd = PAULI * | |
738 | * * | |
739 | * what (1) = -1 Pauli's principle for secondary * | |
740 | * interactions not treated * | |
741 | * default: 1 * | |
742 | * what (2..6), sdum no meaning * | |
743 | * * | |
744 | ********************************************************************* | |
745 | ||
746 | 190 CONTINUE | |
747 | IF (WHAT(1).EQ.-1.0D0) THEN | |
748 | LPAULI = .FALSE. | |
749 | ELSE | |
750 | LPAULI = .TRUE. | |
751 | ENDIF | |
752 | GOTO 10 | |
753 | ||
754 | ********************************************************************* | |
755 | * * | |
756 | * control card: codewd = COULOMB * | |
757 | * * | |
758 | * what (1) = -1. Coulomb-energy treatment switched off * | |
759 | * default: 1 * | |
760 | * what (2..6), sdum no meaning * | |
761 | * * | |
762 | ********************************************************************* | |
763 | ||
764 | 200 CONTINUE | |
765 | ICOUL = 1 | |
766 | IF (WHAT(1).EQ.-1.0D0) THEN | |
767 | ICOUL = 0 | |
768 | ELSE | |
769 | ICOUL = 1 | |
770 | ENDIF | |
771 | GOTO 10 | |
772 | ||
773 | ********************************************************************* | |
774 | * * | |
775 | * control card: codewd = HADRIN * | |
776 | * * | |
777 | * HADRIN module * | |
778 | * * | |
779 | * what (1) = 0. elastic/inelastic interactions with probab. * | |
780 | * as defined by cross-sections * | |
781 | * = 1. inelastic interactions forced * | |
782 | * = 2. elastic interactions forced * | |
783 | * default: 1 * | |
784 | * what (2) upper threshold in total energy (GeV) below * | |
785 | * which interactions are sampled by HADRIN * | |
786 | * default: 5. GeV * | |
787 | * what (3..6), sdum no meaning * | |
788 | * * | |
789 | ********************************************************************* | |
790 | ||
791 | 210 CONTINUE | |
792 | IWHAT = INT(WHAT(1)) | |
793 | IF ((IWHAT.GE.0).AND.(IWHAT.LE.2)) INTHAD = IWHAT | |
794 | IF ((WHAT(2).GT.ZERO).AND.(WHAT(2).LT.15.0D0)) EHADTH = WHAT(2) | |
795 | GOTO 10 | |
796 | ||
797 | ********************************************************************* | |
798 | * * | |
799 | * control card: codewd = EVAP * | |
800 | * * | |
801 | * evaporation module * | |
802 | * * | |
803 | * what (1) =< -1 ==> evaporation is switched off * | |
804 | * >= 1 ==> evaporation is performed * | |
805 | * * | |
806 | * what (1) = i1 + i2*10 + i3*100 + i4*10000 * | |
807 | * (i1, i2, i3, i4 >= 0 ) * | |
808 | * * | |
809 | * i1 is the flag for selecting the T=0 level density option used * | |
810 | * = 1: standard EVAP level densities with Cook pairing * | |
811 | * energies * | |
812 | * = 2: Z,N-dependent Gilbert & Cameron level densities * | |
813 | * (default) * | |
814 | * = 3: Julich A-dependent level densities * | |
815 | * = 4: Z,N-dependent Brancazio & Cameron level densities * | |
816 | * * | |
817 | * i2 >= 1: high energy fission activated * | |
818 | * (default high energy fission activated) * | |
819 | * * | |
820 | * i3 = 0: No energy dependence for level densities * | |
821 | * = 1: Standard Ignyatuk (1975, 1st) energy dependence * | |
822 | * for level densities (default) * | |
823 | * = 2: Standard Ignyatuk (1975, 1st) energy dependence * | |
824 | * for level densities with NOT used set of parameters * | |
825 | * = 3: Standard Ignyatuk (1975, 1st) energy dependence * | |
826 | * for level densities with NOT used set of parameters * | |
827 | * = 4: Second Ignyatuk (1975, 2nd) energy dependence * | |
828 | * for level densities * | |
829 | * = 5: Second Ignyatuk (1975, 2nd) energy dependence * | |
830 | * for level densities with fit 1 Iljinov & Mebel set of * | |
831 | * parameters * | |
832 | * = 6: Second Ignyatuk (1975, 2nd) energy dependence * | |
833 | * for level densities with fit 2 Iljinov & Mebel set of * | |
834 | * parameters * | |
835 | * = 7: Second Ignyatuk (1975, 2nd) energy dependence * | |
836 | * for level densities with fit 3 Iljinov & Mebel set of * | |
837 | * parameters * | |
838 | * = 8: Second Ignyatuk (1975, 2nd) energy dependence * | |
839 | * for level densities with fit 4 Iljinov & Mebel set of * | |
840 | * parameters * | |
841 | * * | |
842 | * i4 >= 1: Original Gilbert and Cameron pairing energies used * | |
843 | * (default Cook's modified pairing energies) * | |
844 | * * | |
845 | * what (2) = ig + 10 * if (ig and if must have the same sign) * | |
846 | * * | |
847 | * ig =< -1 ==> deexcitation gammas are not produced * | |
848 | * (if the evaporation step is not performed * | |
849 | * they are never produced) * | |
850 | * if =< -1 ==> Fermi Break Up is not invoked * | |
851 | * (if the evaporation step is not performed * | |
852 | * it is never invoked) * | |
853 | * The default is: deexcitation gamma produced and Fermi break up * | |
854 | * activated for the new preequilibrium, not * | |
855 | * activated otherwise. * | |
856 | * what (3..6), sdum no meaning * | |
857 | * * | |
858 | ********************************************************************* | |
859 | ||
860 | 220 CONTINUE | |
861 | IF (WHAT(1).LE.-1.0D0) THEN | |
862 | LEVPRT = .FALSE. | |
863 | LDEEXG = .FALSE. | |
864 | LHEAVY = .FALSE. | |
865 | GOTO 10 | |
866 | ENDIF | |
867 | WHTSAV = WHAT (1) | |
868 | IF ( NINT (WHAT (1)) .GE. 10000 ) THEN | |
869 | LLVMOD = .FALSE. | |
870 | JLVHLP = NINT (WHAT (1)) / 10000 | |
871 | WHAT (1) = WHAT (1) - 10000.D+00 * JLVHLP | |
872 | END IF | |
873 | IF ( NINT (WHAT (1)) .GE. 100 ) THEN | |
874 | JLVMOD = NINT (WHAT (1)) / 100 | |
875 | WHAT (1) = WHAT (1) - 100.D+00 * JLVMOD | |
876 | END IF | |
877 | IF ( NINT (WHAT (1)) .GE. 10 ) THEN | |
878 | ||
879 | IEVFSS = 1 | |
880 | ||
881 | JLVHLP = NINT (WHAT (1)) / 10 | |
882 | WHAT (1) = WHAT (1) - 10.D+00 * JLVHLP | |
883 | ELSE IF ( NINT (WHTSAV) .NE. 0 ) THEN | |
884 | ||
885 | IEVFSS = 0 | |
886 | ||
887 | END IF | |
888 | IF ( NINT (WHAT (1)) .GE. 0 ) THEN | |
889 | LEVPRT = .TRUE. | |
890 | ILVMOD = NINT (WHAT(1)) | |
891 | IF ( ABS (NINT (WHAT (2))) .GE. 10 ) THEN | |
892 | LFRMBK = .TRUE. | |
893 | JLVHLP = NINT (WHAT (2)) / 10 | |
894 | WHAT (2) = WHAT (2) - 10.D+00 * JLVHLP | |
895 | ELSE IF ( NINT (WHAT (2)) .NE. 0 ) THEN | |
896 | LFRMBK = .FALSE. | |
897 | END IF | |
898 | IF ( NINT (WHAT (2)) .GE. 0 ) THEN | |
899 | LDEEXG = .TRUE. | |
900 | ELSE | |
901 | LDEEXG = .FALSE. | |
902 | END IF | |
903 | **sr heavies are always put to /FKFHVY/ | |
904 | C IF ( NINT (WHAT(3)) .GE. 1 ) THEN | |
905 | C LHEAVY = .TRUE. | |
906 | C ELSE | |
907 | C LHEAVY = .FALSE. | |
908 | C END IF | |
909 | LHEAVY = .TRUE. | |
910 | ELSE | |
911 | LEVPRT = .FALSE. | |
912 | LDEEXG = .FALSE. | |
913 | LHEAVY = .FALSE. | |
914 | END IF | |
915 | ||
916 | LOLDEV = .FALSE. | |
917 | ||
918 | GOTO 10 | |
919 | ||
920 | ********************************************************************* | |
921 | * * | |
922 | * control card: codewd = EMCCHECK * | |
923 | * * | |
924 | * extended energy-momentum / quantum-number conservation check * | |
925 | * * | |
926 | * what (1) = -1 extended check not performed * | |
927 | * default: 1. * | |
928 | * what (2..6), sdum no meaning * | |
929 | * * | |
930 | ********************************************************************* | |
931 | ||
932 | 230 CONTINUE | |
933 | IF (WHAT(1).EQ.-1) THEN | |
934 | LEMCCK = .FALSE. | |
935 | ELSE | |
936 | LEMCCK = .TRUE. | |
937 | ENDIF | |
938 | GOTO 10 | |
939 | ||
940 | ********************************************************************* | |
941 | * * | |
942 | * control card: codewd = MODEL * | |
943 | * * | |
944 | * Model to be used to treat nucleon-nucleon interactions * | |
945 | * * | |
946 | * sdum = DTUNUC two-chain model * | |
947 | * = PHOJET multiple chains including minijets * | |
948 | * = LEPTO DIS * | |
949 | * = QNEUTRIN quasi-elastic neutrino scattering * | |
950 | * default: PHOJET * | |
951 | * * | |
952 | * if sdum = LEPTO: * | |
953 | * what (1) (variable INTER) * | |
954 | * = 1 gamma exchange * | |
955 | * = 2 W+- exchange * | |
956 | * = 3 Z0 exchange * | |
957 | * = 4 gamma/Z0 exchange * | |
958 | * * | |
959 | * if sdum = QNEUTRIN: * | |
960 | * what (1) = 0 elastic scattering on nucleon and * | |
961 | * tau does not decay (default) * | |
962 | * = 1 decay of tau into mu.. * | |
963 | * = 2 decay of tau into e.. * | |
964 | * = 10 CC events on p and n * | |
965 | * = 11 NC events on p and n * | |
966 | * * | |
967 | * what (2..6) no meaning * | |
968 | * * | |
969 | ********************************************************************* | |
970 | ||
971 | 240 CONTINUE | |
972 | IF (SDUM.EQ.CMODEL(1)) THEN | |
973 | MCGENE = 1 | |
974 | ELSEIF (SDUM.EQ.CMODEL(2)) THEN | |
975 | MCGENE = 2 | |
976 | ELSEIF (SDUM.EQ.CMODEL(3)) THEN | |
977 | MCGENE = 3 | |
978 | IF ((WHAT(1).GE.1.0D0).AND.(WHAT(1).LE.4.0D0)) | |
979 | & INTER = INT(WHAT(1)) | |
980 | ELSEIF (SDUM.EQ.CMODEL(4)) THEN | |
981 | MCGENE = 4 | |
982 | IWHAT = INT(WHAT(1)) | |
983 | IF ((IWHAT.EQ.1 ).OR.(IWHAT.EQ.2 ).OR. | |
984 | & (IWHAT.EQ.10).OR.(IWHAT.EQ.11)) | |
985 | & NEUDEC = IWHAT | |
986 | ELSE | |
987 | STOP ' Unknown model !' | |
988 | ENDIF | |
989 | GOTO 10 | |
990 | ||
991 | ********************************************************************* | |
992 | * * | |
993 | * control card: codewd = PHOINPUT * | |
994 | * * | |
995 | * Start of input-section for PHOJET-specific input-cards * | |
996 | * Note: This section will not be finished before giving * | |
997 | * ENDINPUT-card * | |
998 | * what (1..6), sdum no meaning * | |
999 | * * | |
1000 | ********************************************************************* | |
1001 | ||
1002 | 250 CONTINUE | |
1003 | IF (LPHOIN) THEN | |
1004 | ||
1005 | CALL PHO_INIT(LINP,LOUT,IREJ1) | |
1006 | ||
1007 | IF (IREJ1.NE.0) THEN | |
1008 | WRITE(LOUT,'(1X,A)')'INIT: reading PHOJET-input failed' | |
1009 | STOP | |
1010 | ENDIF | |
1011 | LPHOIN = .FALSE. | |
1012 | ENDIF | |
1013 | GOTO 10 | |
1014 | ||
1015 | ********************************************************************* | |
1016 | * * | |
1017 | * control card: codewd = GLAUBERI * | |
1018 | * * | |
1019 | * Pre-initialization of impact parameter selection * | |
1020 | * * | |
1021 | * what (1..6), sdum no meaning * | |
1022 | * * | |
1023 | ********************************************************************* | |
1024 | ||
1025 | 260 CONTINUE | |
1026 | IF (IFIRST.NE.99) THEN | |
1027 | CALL DT_RNDMST(12,34,56,78) | |
1028 | CALL DT_RNDMTE(1) | |
1029 | OPEN(40,FILE='outdata0/shm.out',STATUS='UNKNOWN') | |
1030 | C OPEN(11,FILE='outdata0/shm.dbg',STATUS='UNKNOWN') | |
1031 | IFIRST = 99 | |
1032 | ENDIF | |
1033 | ||
1034 | IPPN = 8 | |
1035 | PLOW = 10.0D0 | |
1036 | C IPPN = 1 | |
1037 | C PLOW = 100.0D0 | |
1038 | PHI = 1.0D5 | |
1039 | APLOW = LOG10(PLOW) | |
1040 | APHI = LOG10(PHI) | |
1041 | ADP = (APHI-APLOW)/DBLE(IPPN) | |
1042 | ||
1043 | IPLOW = 1 | |
1044 | IDIP = 1 | |
1045 | IIP = 5 | |
1046 | C IPLOW = 1 | |
1047 | C IDIP = 1 | |
1048 | C IIP = 1 | |
1049 | IPRANG(1) = 1 | |
1050 | IPRANG(2) = 2 | |
1051 | IPRANG(3) = 5 | |
1052 | IPRANG(4) = 10 | |
1053 | IPRANG(5) = 20 | |
1054 | ||
1055 | ITLOW = 30 | |
1056 | IDIT = 3 | |
1057 | IIT = 60 | |
1058 | C IDIT = 10 | |
1059 | C IIT = 21 | |
1060 | ||
1061 | DO 473 NCIT=1,IIT | |
1062 | IT = ITLOW+(NCIT-1)*IDIT | |
1063 | C IPHI = IT | |
1064 | C IDIP = 10 | |
1065 | C IIP = (IPHI-IPLOW)/IDIP | |
1066 | C IF (IIP.EQ.0) IIP = 1 | |
1067 | C IF (IT.EQ.IPLOW) IIP = 0 | |
1068 | ||
1069 | DO 472 NCIP=1,IIP | |
1070 | IP = IPRANG(NCIP) | |
1071 | CC IF (NCIP.LE.IIP) THEN | |
1072 | C IP = IPLOW+(NCIP-1)*IDIP | |
1073 | CC ELSE | |
1074 | CC IP = IT | |
1075 | CC ENDIF | |
1076 | IF (IP.GT.IT) GOTO 472 | |
1077 | ||
1078 | DO 471 NCP=1,IPPN+1 | |
1079 | APPN = APLOW+DBLE(NCP-1)*ADP | |
1080 | PPN = 10**APPN | |
1081 | ||
1082 | OPEN(12,FILE='outdata0/shm.sta',STATUS='UNKNOWN') | |
1083 | WRITE(12,'(1X,2I5,E15.3)') IP,IT,PPN | |
1084 | CLOSE(12) | |
1085 | ||
1086 | XLIM1 = 0.0D0 | |
1087 | XLIM2 = 50.0D0 | |
1088 | XLIM3 = ZERO | |
1089 | IBIN = 50 | |
1090 | CALL DT_NEWHGR(XDUM,XDUM,XDUM,XDUMB,-1,IHDUM) | |
1091 | CALL DT_NEWHGR(XLIM1,XLIM2,XLIM3,XDUMB,IBIN,IHSHMA) | |
1092 | ||
1093 | NEVFIT = 5 | |
1094 | C IF ((IP.GT.10).OR.(IT.GT.10)) THEN | |
1095 | C NEVFIT = 5 | |
1096 | C ELSE | |
1097 | C NEVFIT = 10 | |
1098 | C ENDIF | |
1099 | SIGAV = 0.0D0 | |
1100 | ||
1101 | DO 478 I=1,NEVFIT | |
1102 | CALL DT_SHMAKI(IP,IDUM1,IT,IDUM1,IJPROJ,PPN,99) | |
1103 | SIGAV = SIGAV+XSPRO(1,1,1) | |
1104 | DO 479 J=1,50 | |
1105 | XC = DBLE(J) | |
1106 | CALL DT_FILHGR(XC,BSITE(1,1,1,J),IHSHMA,I) | |
1107 | 479 CONTINUE | |
1108 | 478 CONTINUE | |
1109 | ||
1110 | CALL DT_EVTHIS(IDUM) | |
1111 | HEADER = ' BSITE' | |
1112 | C CALL OUTGEN(IHSHMA,0,0,0,0,0,HEADER,0,NEVFIT,ONE,0,1,-1) | |
1113 | ||
1114 | C CALL GENFIT(XPARA) | |
1115 | C WRITE(40,'(2I4,E11.3,F6.0,5E11.3)') | |
1116 | C & IP,IT,PPN,SIGAV/DBLE(NEVFIT),XPARA | |
1117 | ||
1118 | 471 CONTINUE | |
1119 | ||
1120 | 472 CONTINUE | |
1121 | ||
1122 | 473 CONTINUE | |
1123 | ||
1124 | STOP | |
1125 | ||
1126 | ********************************************************************* | |
1127 | * * | |
1128 | * control card: codewd = FLUCTUAT * | |
1129 | * * | |
1130 | * Treatment of cross section fluctuations * | |
1131 | * * | |
1132 | * what (1) = 1 treat cross section fluctuations * | |
1133 | * default: 0. * | |
1134 | * what (1..6), sdum no meaning * | |
1135 | * * | |
1136 | ********************************************************************* | |
1137 | ||
1138 | 270 CONTINUE | |
1139 | IFLUCT = 0 | |
1140 | IF (WHAT(1).EQ.ONE) THEN | |
1141 | IFLUCT = 1 | |
1142 | CALL DT_FLUINI | |
1143 | ENDIF | |
1144 | GOTO 10 | |
1145 | ||
1146 | ********************************************************************* | |
1147 | * * | |
1148 | * control card: codewd = CENTRAL * | |
1149 | * * | |
1150 | * what (1) = 1. central production forced default: 0 * | |
1151 | * if what (1) < 0 and > -100 * | |
1152 | * what (2) = min. impact parameter default: 0 * | |
1153 | * what (3) = max. impact parameter default: b_max * | |
1154 | * if what (1) < -99 * | |
1155 | * what (2) = fraction of cross section default: 1 * | |
1156 | * if what (1) = -1 : evaporation/fzc suppressed * | |
1157 | * if what (1) < -1 : evaporation/fzc allowed * | |
1158 | * * | |
1159 | * what (4..6), sdum no meaning * | |
1160 | * * | |
1161 | ********************************************************************* | |
1162 | ||
1163 | 280 CONTINUE | |
1164 | ICENTR = INT(WHAT(1)) | |
1165 | IF (ICENTR.LT.0) THEN | |
1166 | IF (ICENTR.GT.-100) THEN | |
1167 | BIMIN = WHAT(2) | |
1168 | BIMAX = WHAT(3) | |
1169 | ELSE | |
1170 | XSFRAC = WHAT(2) | |
1171 | ENDIF | |
1172 | ENDIF | |
1173 | GOTO 10 | |
1174 | ||
1175 | ********************************************************************* | |
1176 | * * | |
1177 | * control card: codewd = RECOMBIN * | |
1178 | * * | |
1179 | * Chain recombination * | |
1180 | * (recombine S-S and V-V chains to V-S chains) * | |
1181 | * * | |
1182 | * what (1) = -1. recombination switched off default: 1 * | |
1183 | * what (2..6), sdum no meaning * | |
1184 | * * | |
1185 | ********************************************************************* | |
1186 | ||
1187 | 290 CONTINUE | |
1188 | IRECOM = 1 | |
1189 | IF (WHAT(1).EQ.-1.0D0) IRECOM = 0 | |
1190 | GOTO 10 | |
1191 | ||
1192 | ********************************************************************* | |
1193 | * * | |
1194 | * control card: codewd = COMBIJET * | |
1195 | * * | |
1196 | * chain fusion (2 q-aq --> qq-aqaq) * | |
1197 | * * | |
1198 | * what (1) = 1 fusion treated * | |
1199 | * default: 0. * | |
1200 | * what (2) minimum number of uncombined chains from * | |
1201 | * single projectile or target nucleons * | |
1202 | * default: 0. * | |
1203 | * what (3..6), sdum no meaning * | |
1204 | * * | |
1205 | ********************************************************************* | |
1206 | ||
1207 | 300 CONTINUE | |
1208 | LCO2CR = .FALSE. | |
1209 | IF (INT(WHAT(1)).EQ.1) LCO2CR = .TRUE. | |
1210 | IF (WHAT(2).GE.ZERO) CUTOF = WHAT(2) | |
1211 | GOTO 10 | |
1212 | ||
1213 | ********************************************************************* | |
1214 | * * | |
1215 | * control card: codewd = XCUTS * | |
1216 | * * | |
1217 | * thresholds for x-sampling * | |
1218 | * * | |
1219 | * what (1) defines lower threshold for val.-q x-value (CVQ) * | |
1220 | * default: 1. * | |
1221 | * what (2) defines lower threshold for val.-qq x-value (CDQ) * | |
1222 | * default: 2. * | |
1223 | * what (3) defines lower threshold for sea-q x-value (CSEA) * | |
1224 | * default: 0.2 * | |
1225 | * what (4) sea-q x-values in S-S chains (SSMIMA) * | |
1226 | * default: 0.14 * | |
1227 | * what (5) not used * | |
1228 | * default: 2. * | |
1229 | * what (6), sdum no meaning * | |
1230 | * * | |
1231 | * Note: Lower thresholds (what(1..3)) are def. as x_thr=CXXX/ECM * | |
1232 | * * | |
1233 | ********************************************************************* | |
1234 | ||
1235 | 310 CONTINUE | |
1236 | IF (WHAT(1).GE.0.5D0) CVQ = WHAT(1) | |
1237 | IF (WHAT(2).GE.ONE) CDQ = WHAT(2) | |
1238 | IF (WHAT(3).GE.0.1D0) CSEA = WHAT(3) | |
1239 | IF (WHAT(4).GE.ZERO) THEN | |
1240 | SSMIMA = WHAT(4) | |
1241 | SSMIMQ = SSMIMA**2 | |
1242 | ENDIF | |
1243 | IF (WHAT(5).GT.2.0D0) VVMTHR = WHAT(5) | |
1244 | GOTO 10 | |
1245 | ||
1246 | ********************************************************************* | |
1247 | * * | |
1248 | * control card: codewd = INTPT * | |
1249 | * * | |
1250 | * what (1) = -1 intrinsic transverse momenta of partons * | |
1251 | * not treated default: 1 * | |
1252 | * what (2..6), sdum no meaning * | |
1253 | * * | |
1254 | ********************************************************************* | |
1255 | ||
1256 | 320 CONTINUE | |
1257 | IF (WHAT(1).EQ.-1.0D0) THEN | |
1258 | LINTPT = .FALSE. | |
1259 | ELSE | |
1260 | LINTPT = .TRUE. | |
1261 | ENDIF | |
1262 | GOTO 10 | |
1263 | ||
1264 | ********************************************************************* | |
1265 | * * | |
1266 | * control card: codewd = CRONINPT * | |
1267 | * * | |
1268 | * Cronin effect (multiple scattering of partons at chain ends) * | |
1269 | * * | |
1270 | * what (1) = -1 Cronin effect not treated default: 1 * | |
1271 | * what (2) = 0 scattering parameter default: 0.64 * | |
1272 | * what (3..6), sdum no meaning * | |
1273 | * * | |
1274 | ********************************************************************* | |
1275 | ||
1276 | 330 CONTINUE | |
1277 | IF (WHAT(1).EQ.-1.0D0) THEN | |
1278 | MKCRON = 0 | |
1279 | ELSE | |
1280 | MKCRON = 1 | |
1281 | ENDIF | |
1282 | CRONCO = WHAT(2) | |
1283 | GOTO 10 | |
1284 | ||
1285 | ********************************************************************* | |
1286 | * * | |
1287 | * control card: codewd = SEADISTR * | |
1288 | * * | |
1289 | * what (1) (XSEACO) sea(x) prop. 1/x**what (1) default: 1. * | |
1290 | * what (2) (UNON) default: 2. * | |
1291 | * what (3) (UNOM) default: 1.5 * | |
1292 | * what (4) (UNOSEA) default: 5. * | |
1293 | * qdis(x) prop. (1-x)**what (1) etc. * | |
1294 | * what (5..6), sdum no meaning * | |
1295 | * * | |
1296 | ********************************************************************* | |
1297 | ||
1298 | 340 CONTINUE | |
1299 | XSEACO = WHAT(1) | |
1300 | XSEACU = 1.05D0-XSEACO | |
1301 | UNON = WHAT(2) | |
1302 | IF (UNON.LT.0.1D0) UNON = 2.0D0 | |
1303 | UNOM = WHAT(3) | |
1304 | IF (UNOM.LT.0.1D0) UNOM = 1.5D0 | |
1305 | UNOSEA = WHAT(4) | |
1306 | IF (UNOSEA.LT.0.1D0) UNOSEA = 5.0D0 | |
1307 | GOTO 10 | |
1308 | ||
1309 | ********************************************************************* | |
1310 | * * | |
1311 | * control card: codewd = SEASU3 * | |
1312 | * * | |
1313 | * Treatment of strange-quarks at chain ends * | |
1314 | * * | |
1315 | * what (1) (SEASQ) strange-quark supression factor * | |
1316 | * iflav = 1.+rndm*(2.+SEASQ) * | |
1317 | * default: 1. * | |
1318 | * what (2..6), sdum no meaning * | |
1319 | * * | |
1320 | ********************************************************************* | |
1321 | ||
1322 | 350 CONTINUE | |
1323 | SEASQ = WHAT(1) | |
1324 | GOTO 10 | |
1325 | ||
1326 | ********************************************************************* | |
1327 | * * | |
1328 | * control card: codewd = DIQUARKS * | |
1329 | * * | |
1330 | * what (1) = -1. sea-diquark/antidiquark-pairs not treated * | |
1331 | * default: 1. * | |
1332 | * what (2..6), sdum no meaning * | |
1333 | * * | |
1334 | ********************************************************************* | |
1335 | ||
1336 | 360 CONTINUE | |
1337 | IF (WHAT(1).EQ.-1.0D0) THEN | |
1338 | LSEADI = .FALSE. | |
1339 | ELSE | |
1340 | LSEADI = .TRUE. | |
1341 | ENDIF | |
1342 | GOTO 10 | |
1343 | ||
1344 | ********************************************************************* | |
1345 | * * | |
1346 | * control card: codewd = RESONANC * | |
1347 | * * | |
1348 | * treatment of low mass chains * | |
1349 | * * | |
1350 | * what (1) = -1 low chain masses are not corrected for resonance * | |
1351 | * masses (obsolete for BAMJET-fragmentation) * | |
1352 | * default: 1. * | |
1353 | * what (2) = -1 massless partons default: 1. (massive) * | |
1354 | * default: 1. (massive) * | |
1355 | * what (3) = -1 chain-system containing chain of too small * | |
1356 | * mass is rejected (note: this does not fully * | |
1357 | * apply to S-S chains) default: 0. * | |
1358 | * what (4..6), sdum no meaning * | |
1359 | * * | |
1360 | ********************************************************************* | |
1361 | ||
1362 | 370 CONTINUE | |
1363 | IRESCO = 1 | |
1364 | IMSHL = 1 | |
1365 | IRESRJ = 0 | |
1366 | IF (WHAT(1).EQ.-ONE) IRESCO = 0 | |
1367 | IF (WHAT(2).EQ.-ONE) IMSHL = 0 | |
1368 | IF (WHAT(3).EQ.-ONE) IRESRJ = 1 | |
1369 | GOTO 10 | |
1370 | ||
1371 | ********************************************************************* | |
1372 | * * | |
1373 | * control card: codewd = DIFFRACT * | |
1374 | * * | |
1375 | * Treatment of diffractive events * | |
1376 | * * | |
1377 | * what (1) = (ISINGD) 0 no single diffraction * | |
1378 | * 1 single diffraction included * | |
1379 | * +-2 single diffractive events only * | |
1380 | * +-3 projectile single diffraction only * | |
1381 | * +-4 target single diffraction only * | |
1382 | * -5 double pomeron exchange only * | |
1383 | * (neg. sign applies to PHOJET events) * | |
1384 | * default: 0. * | |
1385 | * * | |
1386 | * what (2) = (IDOUBD) 0 no double diffraction * | |
1387 | * 1 double diffraction included * | |
1388 | * 2 double diffractive events only * | |
1389 | * default: 0. * | |
1390 | * what (3) = 1 projectile diffraction treated (2-channel form.) * | |
1391 | * default: 0. * | |
1392 | * what (4) = alpha-parameter in projectile diffraction * | |
1393 | * default: 0. * | |
1394 | * what (5..6), sdum no meaning * | |
1395 | * * | |
1396 | ********************************************************************* | |
1397 | ||
1398 | 380 CONTINUE | |
1399 | IF (ABS(WHAT(1)).GT.ZERO) ISINGD = INT(WHAT(1)) | |
1400 | IF (ABS(WHAT(2)).GT.ZERO) IDOUBD = INT(WHAT(2)) | |
1401 | IF ((ISINGD.GT.1).AND.(IDOUBD.GT.1)) THEN | |
1402 | WRITE(LOUT,1380) | |
1403 | 1380 FORMAT(1X,'INIT: inconsistent DIFFRACT - input !',/, | |
1404 | & 11X,'IDOUBD is reset to zero') | |
1405 | IDOUBD = 0 | |
1406 | ENDIF | |
1407 | IF (WHAT(3).GT.ZERO) DIBETA = WHAT(3) | |
1408 | IF (WHAT(4).GT.ZERO) DIALPH = WHAT(4) | |
1409 | GOTO 10 | |
1410 | ||
1411 | ********************************************************************* | |
1412 | * * | |
1413 | * control card: codewd = SINGLECH * | |
1414 | * * | |
1415 | * what (1) = 1. Regge contribution (one chain) included * | |
1416 | * default: 0. * | |
1417 | * what (2..6), sdum no meaning * | |
1418 | * * | |
1419 | ********************************************************************* | |
1420 | ||
1421 | 390 CONTINUE | |
1422 | ISICHA = 0 | |
1423 | IF (WHAT(1).EQ.ONE) ISICHA = 1 | |
1424 | GOTO 10 | |
1425 | ||
1426 | ********************************************************************* | |
1427 | * * | |
1428 | * control card: codewd = NOFRAGME * | |
1429 | * * | |
1430 | * biased chain hadronization * | |
1431 | * * | |
1432 | * what (1..6) = -1 no of hadronizsation of S-S chains * | |
1433 | * = -2 no of hadronizsation of D-S chains * | |
1434 | * = -3 no of hadronizsation of S-D chains * | |
1435 | * = -4 no of hadronizsation of S-V chains * | |
1436 | * = -5 no of hadronizsation of D-V chains * | |
1437 | * = -6 no of hadronizsation of V-S chains * | |
1438 | * = -7 no of hadronizsation of V-D chains * | |
1439 | * = -8 no of hadronizsation of V-V chains * | |
1440 | * = -9 no of hadronizsation of comb. chains * | |
1441 | * default: complete hadronization * | |
1442 | * sdum no meaning * | |
1443 | * * | |
1444 | ********************************************************************* | |
1445 | ||
1446 | 400 CONTINUE | |
1447 | DO 401 I=1,6 | |
1448 | ICHAIN = INT(WHAT(I)) | |
1449 | IF ((ICHAIN.LE.-1).AND.(ICHAIN.GE.-9)) | |
1450 | & LHADRO(ABS(ICHAIN)) = .FALSE. | |
1451 | 401 CONTINUE | |
1452 | GOTO 10 | |
1453 | ||
1454 | ********************************************************************* | |
1455 | * * | |
1456 | * control card: codewd = HADRONIZE * | |
1457 | * * | |
1458 | * hadronization model and parameter switch * | |
1459 | * * | |
1460 | * what (1) = 1 hadronization via BAMJET * | |
1461 | * = 2 hadronization via JETSET * | |
1462 | * default: 2 * | |
1463 | * what (2) = 1..3 parameter set to be used * | |
1464 | * JETSET: 3 sets available * | |
1465 | * ( = 3 default JETSET-parameters) * | |
1466 | * BAMJET: 1 set available * | |
1467 | * default: 1 * | |
1468 | * what (3..6), sdum no meaning * | |
1469 | * * | |
1470 | ********************************************************************* | |
1471 | ||
1472 | 410 CONTINUE | |
1473 | IWHAT1 = INT(WHAT(1)) | |
1474 | IWHAT2 = INT(WHAT(2)) | |
1475 | IF ((IWHAT1.EQ.1).OR.(IWHAT1.EQ.2)) IFRAG(1) = IWHAT1 | |
1476 | IF ((IWHAT1.EQ.2).AND.(IWHAT2.GE.1).AND.(IWHAT2.LE.3)) | |
1477 | & IFRAG(2) = IWHAT2 | |
1478 | GOTO 10 | |
1479 | ||
1480 | ********************************************************************* | |
1481 | * * | |
1482 | * control card: codewd = POPCORN * | |
1483 | * * | |
1484 | * "Popcorn-effect" in fragmentation and diquark breaking diagrams * | |
1485 | * * | |
1486 | * what (1) = (PDB) frac. of diquark fragmenting directly into * | |
1487 | * baryons (PYTHIA/JETSET fragmentation) * | |
1488 | * (JETSET: = 0. Popcorn mechanism switched off) * | |
1489 | * default: 0.5 * | |
1490 | * what (2) = probability for accepting a diquark breaking * | |
1491 | * diagram involving the generation of a u/d quark- * | |
1492 | * antiquark pair default: 0.0 * | |
1493 | * what (3) = same a what (2), here for s quark-antiquark pair * | |
1494 | * default: 0.0 * | |
1495 | * what (4..6), sdum no meaning * | |
1496 | * * | |
1497 | ********************************************************************* | |
1498 | ||
1499 | 420 CONTINUE | |
1500 | IF (WHAT(1).GE.0.0D0) PDB = WHAT(1) | |
1501 | IF (WHAT(2).GE.0.0D0) THEN | |
1502 | PDBSEA(1) = WHAT(2) | |
1503 | PDBSEA(2) = WHAT(2) | |
1504 | ENDIF | |
1505 | IF (WHAT(3).GE.0.0D0) PDBSEA(3) = WHAT(3) | |
1506 | DO 421 I=1,8 | |
1507 | DBRKA(1,I) = DBRKR(1,I)*PDBSEA(1)/(1.D0-PDBSEA(1)) | |
1508 | DBRKA(2,I) = DBRKR(2,I)*PDBSEA(2)/(1.D0-PDBSEA(2)) | |
1509 | DBRKA(3,I) = DBRKR(3,I)*PDBSEA(3)/(1.D0-PDBSEA(3)) | |
1510 | 421 CONTINUE | |
1511 | GOTO 10 | |
1512 | ||
1513 | ********************************************************************* | |
1514 | * * | |
1515 | * control card: codewd = PARDECAY * | |
1516 | * * | |
1517 | * what (1) = 1. Sigma0/Asigma0 are decaying within JETSET * | |
1518 | * = 2. pion^0 decay after intranucl. cascade * | |
1519 | * default: no decay * | |
1520 | * what (2..6), sdum no meaning * | |
1521 | * * | |
1522 | ********************************************************************* | |
1523 | ||
1524 | 430 CONTINUE | |
1525 | IF (WHAT(1).EQ.ONE) ISIG0 = 1 | |
1526 | IF (WHAT(1).EQ.2.0D0) IPI0 = 1 | |
1527 | GOTO 10 | |
1528 | ||
1529 | ********************************************************************* | |
1530 | * * | |
1531 | * control card: codewd = BEAM * | |
1532 | * * | |
1533 | * definition of beam parameters * | |
1534 | * * | |
1535 | * what (1/2) > 0 : energy of beam 1/2 (GeV) * | |
1536 | * < 0 : abs(what(1/2)) energy per charge of * | |
1537 | * beam 1/2 (GeV) * | |
1538 | * (beam 1 is directed into positive z-direction) * | |
1539 | * what (3) beam crossing angle, defined as 2x angle between * | |
1540 | * one beam and the z-axis (micro rad) * | |
1541 | * what (4) angle with x-axis defining the collision plane * | |
1542 | * what (5..6), sdum no meaning * | |
1543 | * * | |
1544 | * Note: this card requires previously defined projectile and * | |
1545 | * target identities (PROJPAR, TARPAR) * | |
1546 | * * | |
1547 | ********************************************************************* | |
1548 | ||
1549 | 440 CONTINUE | |
1550 | CALL DT_BEAMPR(WHAT,PPN,1) | |
1551 | EPN = ZERO | |
1552 | CMENER = ZERO | |
1553 | LEINP = .TRUE. | |
1554 | GOTO 10 | |
1555 | ||
1556 | ********************************************************************* | |
1557 | * * | |
1558 | * control card: codewd = LUND-MSTU * | |
1559 | * * | |
1560 | * set parameter MSTU in JETSET-common /LUDAT1/ * | |
1561 | * * | |
1562 | * what (1) = index according to LUND-common block * | |
1563 | * what (2) = new value of MSTU( int(what(1)) ) * | |
1564 | * what (3), what(4) and what (5), what(6) further * | |
1565 | * parameter in the same way as what (1) and * | |
1566 | * what (2) * | |
1567 | * default: default-Lund or corresponding to * | |
1568 | * the set given in HADRONIZE * | |
1569 | * * | |
1570 | ********************************************************************* | |
1571 | ||
1572 | 450 CONTINUE | |
1573 | IF (WHAT(1).GT.ZERO) THEN | |
1574 | NMSTU = NMSTU+1 | |
1575 | IMSTU(NMSTU) = INT(WHAT(1)) | |
1576 | MSTUX(NMSTU) = INT(WHAT(2)) | |
1577 | ENDIF | |
1578 | IF (WHAT(3).GT.ZERO) THEN | |
1579 | NMSTU = NMSTU+1 | |
1580 | IMSTU(NMSTU) = INT(WHAT(3)) | |
1581 | MSTUX(NMSTU) = INT(WHAT(4)) | |
1582 | ENDIF | |
1583 | IF (WHAT(5).GT.ZERO) THEN | |
1584 | NMSTU = NMSTU+1 | |
1585 | IMSTU(NMSTU) = INT(WHAT(5)) | |
1586 | MSTUX(NMSTU) = INT(WHAT(6)) | |
1587 | ENDIF | |
1588 | GOTO 10 | |
1589 | ||
1590 | ********************************************************************* | |
1591 | * * | |
1592 | * control card: codewd = LUND-MSTJ * | |
1593 | * * | |
1594 | * set parameter MSTJ in JETSET-common /LUDAT1/ * | |
1595 | * * | |
1596 | * what (1) = index according to LUND-common block * | |
1597 | * what (2) = new value of MSTJ( int(what(1)) ) * | |
1598 | * what (3), what(4) and what (5), what(6) further * | |
1599 | * parameter in the same way as what (1) and * | |
1600 | * what (2) * | |
1601 | * default: default-Lund or corresponding to * | |
1602 | * the set given in HADRONIZE * | |
1603 | * * | |
1604 | ********************************************************************* | |
1605 | ||
1606 | 451 CONTINUE | |
1607 | IF (WHAT(1).GT.ZERO) THEN | |
1608 | NMSTJ = NMSTJ+1 | |
1609 | IMSTJ(NMSTJ) = INT(WHAT(1)) | |
1610 | MSTJX(NMSTJ) = INT(WHAT(2)) | |
1611 | ENDIF | |
1612 | IF (WHAT(3).GT.ZERO) THEN | |
1613 | NMSTJ = NMSTJ+1 | |
1614 | IMSTJ(NMSTJ) = INT(WHAT(3)) | |
1615 | MSTJX(NMSTJ) = INT(WHAT(4)) | |
1616 | ENDIF | |
1617 | IF (WHAT(5).GT.ZERO) THEN | |
1618 | NMSTJ = NMSTJ+1 | |
1619 | IMSTJ(NMSTJ) = INT(WHAT(5)) | |
1620 | MSTJX(NMSTJ) = INT(WHAT(6)) | |
1621 | ENDIF | |
1622 | GOTO 10 | |
1623 | ||
1624 | ********************************************************************* | |
1625 | * * | |
1626 | * control card: codewd = LUND-MDCY * | |
1627 | * * | |
1628 | * set parameter MDCY(I,1) for particle decays in JETSET-common * | |
1629 | * /LUDAT3/ * | |
1630 | * * | |
1631 | * what (1-6) = PDG particle index of particle which should * | |
1632 | * not decay * | |
1633 | * default: default-Lund or forced in * | |
1634 | * DT_INITJS * | |
1635 | * * | |
1636 | ********************************************************************* | |
1637 | ||
1638 | 452 CONTINUE | |
1639 | DO 4521 I=1,6 | |
1640 | IF (WHAT(I).NE.ZERO) THEN | |
1641 | ||
1642 | KC = PYCOMP(INT(WHAT(I))) | |
1643 | ||
1644 | MDCY(KC,1) = 0 | |
1645 | ENDIF | |
1646 | 4521 CONTINUE | |
1647 | GOTO 10 | |
1648 | ||
1649 | ********************************************************************* | |
1650 | * * | |
1651 | * control card: codewd = LUND-PARJ * | |
1652 | * * | |
1653 | * set parameter PARJ in JETSET-common /LUDAT1/ * | |
1654 | * * | |
1655 | * what (1) = index according to LUND-common block * | |
1656 | * what (2) = new value of PARJ( int(what(1)) ) * | |
1657 | * what (3), what(4) and what (5), what(6) further * | |
1658 | * parameter in the same way as what (1) and * | |
1659 | * what (2) * | |
1660 | * default: default-Lund or corresponding to * | |
1661 | * the set given in HADRONIZE * | |
1662 | * * | |
1663 | ********************************************************************* | |
1664 | ||
1665 | 460 CONTINUE | |
1666 | IF (WHAT(1).NE.ZERO) THEN | |
1667 | NPARJ = NPARJ+1 | |
1668 | IPARJ(NPARJ) = INT(WHAT(1)) | |
1669 | PARJX(NPARJ) = WHAT(2) | |
1670 | ENDIF | |
1671 | IF (WHAT(3).NE.ZERO) THEN | |
1672 | NPARJ = NPARJ+1 | |
1673 | IPARJ(NPARJ) = INT(WHAT(3)) | |
1674 | PARJX(NPARJ) = WHAT(4) | |
1675 | ENDIF | |
1676 | IF (WHAT(5).NE.ZERO) THEN | |
1677 | NPARJ = NPARJ+1 | |
1678 | IPARJ(NPARJ) = INT(WHAT(5)) | |
1679 | PARJX(NPARJ) = WHAT(6) | |
1680 | ENDIF | |
1681 | GOTO 10 | |
1682 | ||
1683 | ********************************************************************* | |
1684 | * * | |
1685 | * control card: codewd = LUND-PARU * | |
1686 | * * | |
1687 | * set parameter PARJ in JETSET-common /LUDAT1/ * | |
1688 | * * | |
1689 | * what (1) = index according to LUND-common block * | |
1690 | * what (2) = new value of PARU( int(what(1)) ) * | |
1691 | * what (3), what(4) and what (5), what(6) further * | |
1692 | * parameter in the same way as what (1) and * | |
1693 | * what (2) * | |
1694 | * default: default-Lund or corresponding to * | |
1695 | * the set given in HADRONIZE * | |
1696 | * * | |
1697 | ********************************************************************* | |
1698 | ||
1699 | 470 CONTINUE | |
1700 | IF (WHAT(1).GT.ZERO) THEN | |
1701 | NPARU = NPARU+1 | |
1702 | IPARU(NPARU) = INT(WHAT(1)) | |
1703 | PARUX(NPARU) = WHAT(2) | |
1704 | ENDIF | |
1705 | IF (WHAT(3).GT.ZERO) THEN | |
1706 | NPARU = NPARU+1 | |
1707 | IPARU(NPARU) = INT(WHAT(3)) | |
1708 | PARUX(NPARU) = WHAT(4) | |
1709 | ENDIF | |
1710 | IF (WHAT(5).GT.ZERO) THEN | |
1711 | NPARU = NPARU+1 | |
1712 | IPARU(NPARU) = INT(WHAT(5)) | |
1713 | PARUX(NPARU) = WHAT(6) | |
1714 | ENDIF | |
1715 | GOTO 10 | |
1716 | ||
1717 | ********************************************************************* | |
1718 | * * | |
1719 | * control card: codewd = OUTLEVEL * | |
1720 | * * | |
1721 | * output control switches * | |
1722 | * * | |
1723 | * what (1) = internal rejection informations default: 0 * | |
1724 | * what (2) = energy-momentum conservation check output * | |
1725 | * default: 0 * | |
1726 | * what (3) = internal warning messages default: 0 * | |
1727 | * what (4..6), sdum not yet used * | |
1728 | * * | |
1729 | ********************************************************************* | |
1730 | ||
1731 | 480 CONTINUE | |
1732 | DO 481 K=1,6 | |
1733 | IOULEV(K) = INT(WHAT(K)) | |
1734 | 481 CONTINUE | |
1735 | GOTO 10 | |
1736 | ||
1737 | ********************************************************************* | |
1738 | * * | |
1739 | * control card: codewd = FRAME * | |
1740 | * * | |
1741 | * frame in which final state is given in DTEVT1 * | |
1742 | * * | |
1743 | * what (1) = 1 target rest frame (laboratory) * | |
1744 | * = 2 nucleon-nucleon cms * | |
1745 | * default: 1 * | |
1746 | * * | |
1747 | ********************************************************************* | |
1748 | ||
1749 | 490 CONTINUE | |
1750 | KFRAME = INT(WHAT(1)) | |
1751 | IF ((KFRAME.GE.1).AND.(KFRAME.LE.2)) IFRAME = KFRAME | |
1752 | GOTO 10 | |
1753 | ||
1754 | ********************************************************************* | |
1755 | * * | |
1756 | * control card: codewd = L-TAG * | |
1757 | * * | |
1758 | * lepton tagger: * | |
1759 | * definition of kinematical cuts for radiated photon and * | |
1760 | * outgoing lepton detection in lepton-nucleus interactions * | |
1761 | * * | |
1762 | * what (1) = y_min * | |
1763 | * what (2) = y_max * | |
1764 | * what (3) = Q^2_min * | |
1765 | * what (4) = Q^2_max * | |
1766 | * what (5) = theta_min (Lab) * | |
1767 | * what (6) = theta_max (Lab) * | |
1768 | * default: no cuts * | |
1769 | * sdum no meaning * | |
1770 | * * | |
1771 | ********************************************************************* | |
1772 | ||
1773 | 500 CONTINUE | |
1774 | YMIN = WHAT(1) | |
1775 | YMAX = WHAT(2) | |
1776 | Q2MIN = WHAT(3) | |
1777 | Q2MAX = WHAT(4) | |
1778 | THMIN = WHAT(5) | |
1779 | THMAX = WHAT(6) | |
1780 | GOTO 10 | |
1781 | ||
1782 | ********************************************************************* | |
1783 | * * | |
1784 | * control card: codewd = L-ETAG * | |
1785 | * * | |
1786 | * lepton tagger: * | |
1787 | * what (1) = min. outgoing lepton energy (in Lab) * | |
1788 | * what (2) = min. photon energy (in Lab) * | |
1789 | * what (3) = max. photon energy (in Lab) * | |
1790 | * default: no cuts * | |
1791 | * what (2..6), sdum no meaning * | |
1792 | * * | |
1793 | ********************************************************************* | |
1794 | ||
1795 | 510 CONTINUE | |
1796 | ELMIN = MAX(WHAT(1),ZERO) | |
1797 | EGMIN = MAX(WHAT(2),ZERO) | |
1798 | EGMAX = MAX(WHAT(3),ZERO) | |
1799 | GOTO 10 | |
1800 | ||
1801 | ********************************************************************* | |
1802 | * * | |
1803 | * control card: codewd = ECMS-CUT * | |
1804 | * * | |
1805 | * what (1) = min. c.m. energy to be sampled * | |
1806 | * what (2) = max. c.m. energy to be sampled * | |
1807 | * what (3) = min x_Bj to be sampled * | |
1808 | * default: no cuts * | |
1809 | * what (3..6), sdum no meaning * | |
1810 | * * | |
1811 | ********************************************************************* | |
1812 | ||
1813 | 520 CONTINUE | |
1814 | ECMIN = WHAT(1) | |
1815 | ECMAX = WHAT(2) | |
1816 | IF (ECMIN.GT.ECMAX) ECMIN = ECMAX | |
1817 | XBJMIN = MAX(WHAT(3),ZERO) | |
1818 | GOTO 10 | |
1819 | ||
1820 | ********************************************************************* | |
1821 | * * | |
1822 | * control card: codewd = VDM-PAR1 * | |
1823 | * * | |
1824 | * parameters in gamma-nucleus cross section calculation * | |
1825 | * * | |
1826 | * what (1) = Lambda^2 default: 2. * | |
1827 | * what (2) lower limit in M^2 integration * | |
1828 | * = 1 (3m_pi)^2 * | |
1829 | * = 2 (m_rho0)^2 * | |
1830 | * = 3 (m_phi)^2 default: 1 * | |
1831 | * what (3) upper limit in M^2 integration * | |
1832 | * = 1 s/2 * | |
1833 | * = 2 s/4 * | |
1834 | * = 3 s default: 3 * | |
1835 | * what (4) CKMT F_2 structure function * | |
1836 | * = 2212 proton * | |
1837 | * = 100 deuteron default: 2212 * | |
1838 | * what (5) calculation of gamma-nucleon xsections * | |
1839 | * = 1 according to CKMT-parametrization of F_2 * | |
1840 | * = 2 integrating SIGVP over M^2 * | |
1841 | * = 3 using SIGGA * | |
1842 | * = 4 PHOJET cross sections default: 4 * | |
1843 | * * | |
1844 | * what (6), sdum no meaning * | |
1845 | * * | |
1846 | ********************************************************************* | |
1847 | ||
1848 | 530 CONTINUE | |
1849 | IF (WHAT(1).GE.ZERO) RL2 = WHAT(1) | |
1850 | IF ((WHAT(2).GE.1).AND.(WHAT(2).LE.3)) INTRGE(1) = INT(WHAT(2)) | |
1851 | IF ((WHAT(3).GE.1).AND.(WHAT(3).LE.3)) INTRGE(2) = INT(WHAT(3)) | |
1852 | IF ((WHAT(4).EQ.2212).OR.(WHAT(4).EQ.100)) IDPDF = INT(WHAT(4)) | |
1853 | IF ((WHAT(5).GE.1).AND.(WHAT(5).LE.4)) MODEGA = INT(WHAT(5)) | |
1854 | GOTO 10 | |
1855 | ||
1856 | ********************************************************************* | |
1857 | * * | |
1858 | * control card: codewd = HISTOGRAM * | |
1859 | * * | |
1860 | * activate different classes of histograms * | |
1861 | * * | |
1862 | * default: no histograms * | |
1863 | * * | |
1864 | ********************************************************************* | |
1865 | ||
1866 | 540 CONTINUE | |
1867 | DO 541 J=1,6 | |
1868 | IF ((WHAT(J).GE.100).AND.(WHAT(J).LE.150)) THEN | |
1869 | IHISPP(INT(WHAT(J))-100) = 1 | |
1870 | ELSEIF ((ABS(WHAT(J)).GE.200).AND.(ABS(WHAT(J)).LE.250)) THEN | |
1871 | IHISXS(INT(ABS(WHAT(J)))-200) = 1 | |
1872 | IF (WHAT(J).LT.ZERO) IXSTBL = 1 | |
1873 | ENDIF | |
1874 | 541 CONTINUE | |
1875 | GOTO 10 | |
1876 | ||
1877 | ********************************************************************* | |
1878 | * * | |
1879 | * control card: codewd = XS-TABLE * | |
1880 | * * | |
1881 | * output of cross section table for requested interaction * | |
1882 | * - particle production deactivated ! - * | |
1883 | * * | |
1884 | * what (1) lower energy limit for tabulation * | |
1885 | * > 0 Lab. frame * | |
1886 | * < 0 nucleon-nucleon cms * | |
1887 | * what (2) upper energy limit for tabulation * | |
1888 | * > 0 Lab. frame * | |
1889 | * < 0 nucleon-nucleon cms * | |
1890 | * what (3) > 0 # of equidistant lin. bins in E * | |
1891 | * < 0 # of equidistant log. bins in E * | |
1892 | * what (4) lower limit of particle virtuality (photons) * | |
1893 | * what (5) upper limit of particle virtuality (photons) * | |
1894 | * what (6) > 0 # of equidistant lin. bins in Q^2 * | |
1895 | * < 0 # of equidistant log. bins in Q^2 * | |
1896 | * * | |
1897 | ********************************************************************* | |
1898 | ||
1899 | 550 CONTINUE | |
1900 | IF (WHAT(1).EQ.99999.0D0) THEN | |
1901 | IRATIO = INT(WHAT(2)) | |
1902 | GOTO 10 | |
1903 | ENDIF | |
1904 | CMENER = ABS(WHAT(2)) | |
1905 | IF (.NOT.LXSTAB) THEN | |
1906 | ||
1907 | CALL NCDTRD | |
1908 | CALL INCINI | |
1909 | ||
1910 | ENDIF | |
1911 | IF ((.NOT.LXSTAB).OR.(CMENER.NE.CMEOLD)) THEN | |
1912 | CMEOLD = CMENER | |
1913 | IF (WHAT(2).GT.ZERO) | |
1914 | & CMENER = SQRT(2.0D0*AAM(1)**2+2.0D0*WHAT(2)*AAM(1)) | |
1915 | EPN = ZERO | |
1916 | PPN = ZERO | |
1917 | C WRITE(LOUT,*) 'CMENER = ',CMENER | |
1918 | CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,CMENER,1) | |
1919 | CALL DT_PHOINI | |
1920 | ENDIF | |
1921 | CALL DT_XSTABL(WHAT,IXSQEL,IRATIO) | |
1922 | IXSQEL = 0 | |
1923 | LXSTAB = .TRUE. | |
1924 | GOTO 10 | |
1925 | ||
1926 | ********************************************************************* | |
1927 | * * | |
1928 | * control card: codewd = GLAUB-PAR * | |
1929 | * * | |
1930 | * parameters in Glauber-formalism * | |
1931 | * * | |
1932 | * what (1) # of nucleon configurations sampled in integration * | |
1933 | * over nuclear desity default: 1000 * | |
1934 | * what (2) # of bins for integration over impact-parameter and * | |
1935 | * for profile-function calculation default: 49 * | |
1936 | * what (3) = 1 calculation of tot., el. and qel. cross sections * | |
1937 | * default: 0 * | |
1938 | * what (4) = 1 read pre-calculated impact-parameter distrib. * | |
1939 | * from "sdum".glb * | |
1940 | * =-1 dump pre-calculated impact-parameter distrib. * | |
1941 | * into "sdum".glb * | |
1942 | * = 100 read pre-calculated impact-parameter distrib. * | |
1943 | * for variable projectile/target/energy runs * | |
1944 | * from "sdum".glb * | |
1945 | * default: 0 * | |
1946 | * what (5..6) no meaning * | |
1947 | * sdum if |what (4)| = 1 name of in/output-file (sdum.glb) * | |
1948 | * * | |
1949 | ********************************************************************* | |
1950 | ||
1951 | 560 CONTINUE | |
1952 | IF (WHAT(1).GT.ZERO) JSTATB = INT(WHAT(1)) | |
1953 | IF (WHAT(2).GT.ZERO) JBINSB = INT(WHAT(2)) | |
1954 | IF (WHAT(3).EQ.ONE) LPROD = .FALSE. | |
1955 | IF ((ABS(WHAT(4)).EQ.ONE).OR.(WHAT(4).EQ.100)) THEN | |
1956 | IOGLB = INT(WHAT(4)) | |
1957 | CGLB = SDUM | |
1958 | ENDIF | |
1959 | GOTO 10 | |
1960 | ||
1961 | ********************************************************************* | |
1962 | * * | |
1963 | * control card: codewd = GLAUB-INI * | |
1964 | * * | |
1965 | * pre-initialization of profile function * | |
1966 | * * | |
1967 | * what (1) lower energy limit for initialization * | |
1968 | * > 0 Lab. frame * | |
1969 | * < 0 nucleon-nucleon cms * | |
1970 | * what (2) upper energy limit for initialization * | |
1971 | * > 0 Lab. frame * | |
1972 | * < 0 nucleon-nucleon cms * | |
1973 | * what (3) > 0 # of equidistant lin. bins in E * | |
1974 | * < 0 # of equidistant log. bins in E * | |
1975 | * what (4) maximum projectile mass number for which the * | |
1976 | * Glauber data are initialized for each * | |
1977 | * projectile mass number * | |
1978 | * (if <= mass given with the PROJPAR-card) * | |
1979 | * default: 18 * | |
1980 | * what (5) steps in mass number starting from what (4) * | |
1981 | * up to mass number defined with PROJPAR-card * | |
1982 | * for which Glauber data are initialized * | |
1983 | * default: 5 * | |
1984 | * what (6) no meaning * | |
1985 | * sdum no meaning * | |
1986 | * * | |
1987 | ********************************************************************* | |
1988 | ||
1989 | 565 CONTINUE | |
1990 | IOGLB = -100 | |
1991 | CALL DT_GLBINI(WHAT) | |
1992 | GOTO 10 | |
1993 | ||
1994 | ********************************************************************* | |
1995 | * * | |
1996 | * control card: codewd = VDM-PAR2 * | |
1997 | * * | |
1998 | * parameters in gamma-nucleus cross section calculation * | |
1999 | * * | |
2000 | * what (1) = 0 no suppression of shadowing by direct photon * | |
2001 | * processes * | |
2002 | * = 1 suppression .. default: 1 * | |
2003 | * what (2) = 0 no suppression of shadowing by anomalous * | |
2004 | * component if photon-F_2 * | |
2005 | * = 1 suppression .. default: 1 * | |
2006 | * what (3) = 0 no suppression of shadowing by coherence * | |
2007 | * length of the photon * | |
2008 | * = 1 suppression .. default: 1 * | |
2009 | * what (4) = 1 longitudinal polarized photons are taken into * | |
2010 | * account * | |
2011 | * eps*R*Q^2/M^2 = what(4)*Q^2/M^2 default: 0 * | |
2012 | * what (5..6), sdum no meaning * | |
2013 | * * | |
2014 | ********************************************************************* | |
2015 | ||
2016 | 570 CONTINUE | |
2017 | IF ((WHAT(1).EQ.ZERO).OR.(WHAT(1).EQ.ONE)) ISHAD(1) = INT(WHAT(1)) | |
2018 | IF ((WHAT(2).EQ.ZERO).OR.(WHAT(2).EQ.ONE)) ISHAD(2) = INT(WHAT(2)) | |
2019 | IF ((WHAT(3).EQ.ZERO).OR.(WHAT(3).EQ.ONE)) ISHAD(3) = INT(WHAT(3)) | |
2020 | EPSPOL = WHAT(4) | |
2021 | GOTO 10 | |
2022 | ||
2023 | ********************************************************************* | |
2024 | * * | |
2025 | * control card: XS-QELPRO * | |
2026 | * * | |
2027 | * what (1..6), sdum no meaning * | |
2028 | * * | |
2029 | ********************************************************************* | |
2030 | ||
2031 | 580 CONTINUE | |
2032 | IXSQEL = ABS(WHAT(1)) | |
2033 | GOTO 10 | |
2034 | ||
2035 | ********************************************************************* | |
2036 | * * | |
2037 | * control card: RNDMINIT * | |
2038 | * * | |
2039 | * initialization of random number generator * | |
2040 | * * | |
2041 | * what (1..4) values for initialization (= 1..168) * | |
2042 | * what (5..6), sdum no meaning * | |
2043 | * * | |
2044 | ********************************************************************* | |
2045 | ||
2046 | 590 CONTINUE | |
2047 | IF ((WHAT(1).LT.1.0D0).OR.(WHAT(1).GT.168.0D0)) THEN | |
2048 | NA1 = 22 | |
2049 | ELSE | |
2050 | NA1 = WHAT(1) | |
2051 | ENDIF | |
2052 | IF ((WHAT(2).LT.1.0D0).OR.(WHAT(2).GT.168.0D0)) THEN | |
2053 | NA2 = 54 | |
2054 | ELSE | |
2055 | NA2 = WHAT(2) | |
2056 | ENDIF | |
2057 | IF ((WHAT(3).LT.1.0D0).OR.(WHAT(3).GT.168.0D0)) THEN | |
2058 | NA3 = 76 | |
2059 | ELSE | |
2060 | NA3 = WHAT(3) | |
2061 | ENDIF | |
2062 | IF ((WHAT(4).LT.1.0D0).OR.(WHAT(4).GT.168.0D0)) THEN | |
2063 | NA4 = 92 | |
2064 | ELSE | |
2065 | NA4 = WHAT(4) | |
2066 | ENDIF | |
2067 | CALL DT_RNDMST(NA1,NA2,NA3,NA4) | |
2068 | GOTO 10 | |
2069 | ||
2070 | ********************************************************************* | |
2071 | * * | |
2072 | * control card: codewd = LEPTO-CUT * | |
2073 | * * | |
2074 | * set parameter CUT in LEPTO-common /LEPTOU/ * | |
2075 | * * | |
2076 | * what (1) = index in CUT-array * | |
2077 | * what (2) = new value of CUT( int(what(1)) ) * | |
2078 | * what (3), what(4) and what (5), what(6) further * | |
2079 | * parameter in the same way as what (1) and * | |
2080 | * what (2) * | |
2081 | * default: default-LEPTO parameters * | |
2082 | * * | |
2083 | ********************************************************************* | |
2084 | ||
2085 | 600 CONTINUE | |
2086 | IF (WHAT(1).GT.ZERO) CUT(INT(WHAT(1))) = WHAT(2) | |
2087 | IF (WHAT(3).GT.ZERO) CUT(INT(WHAT(3))) = WHAT(4) | |
2088 | IF (WHAT(5).GT.ZERO) CUT(INT(WHAT(5))) = WHAT(6) | |
2089 | GOTO 10 | |
2090 | ||
2091 | ********************************************************************* | |
2092 | * * | |
2093 | * control card: codewd = LEPTO-LST * | |
2094 | * * | |
2095 | * set parameter LST in LEPTO-common /LEPTOU/ * | |
2096 | * * | |
2097 | * what (1) = index in LST-array * | |
2098 | * what (2) = new value of LST( int(what(1)) ) * | |
2099 | * what (3), what(4) and what (5), what(6) further * | |
2100 | * parameter in the same way as what (1) and * | |
2101 | * what (2) * | |
2102 | * default: default-LEPTO parameters * | |
2103 | * * | |
2104 | ********************************************************************* | |
2105 | ||
2106 | 610 CONTINUE | |
2107 | IF (WHAT(1).GT.ZERO) LST(INT(WHAT(1))) = INT(WHAT(2)) | |
2108 | IF (WHAT(3).GT.ZERO) LST(INT(WHAT(3))) = INT(WHAT(4)) | |
2109 | IF (WHAT(5).GT.ZERO) LST(INT(WHAT(5))) = INT(WHAT(6)) | |
2110 | GOTO 10 | |
2111 | ||
2112 | ********************************************************************* | |
2113 | * * | |
2114 | * control card: codewd = LEPTO-PARL * | |
2115 | * * | |
2116 | * set parameter PARL in LEPTO-common /LEPTOU/ * | |
2117 | * * | |
2118 | * what (1) = index in PARL-array * | |
2119 | * what (2) = new value of PARL( int(what(1)) ) * | |
2120 | * what (3), what(4) and what (5), what(6) further * | |
2121 | * parameter in the same way as what (1) and * | |
2122 | * what (2) * | |
2123 | * default: default-LEPTO parameters * | |
2124 | * * | |
2125 | ********************************************************************* | |
2126 | ||
2127 | 620 CONTINUE | |
2128 | IF (WHAT(1).GT.ZERO) PARL(INT(WHAT(1))) = WHAT(2) | |
2129 | IF (WHAT(3).GT.ZERO) PARL(INT(WHAT(3))) = WHAT(4) | |
2130 | IF (WHAT(5).GT.ZERO) PARL(INT(WHAT(5))) = WHAT(6) | |
2131 | GOTO 10 | |
2132 | ||
2133 | ********************************************************************* | |
2134 | * * | |
2135 | * control card: codewd = START * | |
2136 | * * | |
2137 | * what (1) = number of events default: 100. * | |
2138 | * what (2) = 0 Glauber initialization follows * | |
2139 | * = 1 Glauber initialization supressed, fitted * | |
2140 | * results are used instead * | |
2141 | * (this does not apply if emulsion-treatment * | |
2142 | * is requested) * | |
2143 | * = 2 Glauber initialization is written to * | |
2144 | * output-file shmakov.out * | |
2145 | * = 3 Glauber initialization is read from input-file * | |
2146 | * shmakov.out default: 0 * | |
2147 | * what (3..6) no meaning * | |
2148 | * what (3..6) no meaning * | |
2149 | * * | |
2150 | ********************************************************************* | |
2151 | ||
2152 | 630 CONTINUE | |
2153 | ||
2154 | * check for cross-section table output only | |
2155 | IF (LXSTAB) STOP | |
2156 | ||
2157 | NCASES = INT(WHAT(1)) | |
2158 | IF (NCASES.LE.0) NCASES = 100 | |
2159 | IGLAU = INT(WHAT(2)) | |
2160 | IF ((IGLAU.NE.1).AND.(IGLAU.NE.2).AND.(IGLAU.NE.3)) | |
2161 | & IGLAU = 0 | |
2162 | ||
2163 | NPMASS = IP | |
2164 | NPCHAR = IPZ | |
2165 | NTMASS = IT | |
2166 | NTCHAR = ITZ | |
2167 | IDP = IJPROJ | |
2168 | IDT = IJTARG | |
2169 | IF (IDP.LE.0) IDP = 1 | |
2170 | * muon neutrinos: temporary (missing index) | |
2171 | * (new patch in projpar: therefore the following this is probably not | |
2172 | * necessary anymore..) | |
2173 | C IF (IDP.EQ.26) IDP = 5 | |
2174 | C IF (IDP.EQ.27) IDP = 6 | |
2175 | ||
2176 | * redefine collision energy | |
2177 | IF (LEINP) THEN | |
2178 | IF (ABS(VAREHI).GT.ZERO) THEN | |
2179 | PDUM = ZERO | |
2180 | IF (VARELO.LT.EHADLO) VARELO = EHADLO | |
2181 | CALL DT_LTINI(IDP,IDT,VARELO,PDUM,VARCLO,1) | |
2182 | PDUM = ZERO | |
2183 | CALL DT_LTINI(IDP,IDT,VAREHI,PDUM,VARCHI,1) | |
2184 | ENDIF | |
2185 | CALL DT_LTINI(IDP,IDT,EPN,PPN,CMENER,1) | |
2186 | ELSE | |
2187 | WRITE(LOUT,1003) | |
2188 | 1003 FORMAT(1X,'INIT: collision energy not defined!',/, | |
2189 | & 1X,' -program stopped- ') | |
2190 | STOP | |
2191 | ENDIF | |
2192 | ||
2193 | * switch off evaporation (even if requested) if central coll. requ. | |
2194 | IF ((ICENTR.EQ.-1).OR.(ICENTR.GT.0).OR.(XSFRAC.LT.0.5D0)) THEN | |
2195 | IF (LEVPRT) THEN | |
2196 | WRITE(LOUT,1004) | |
2197 | 1004 FORMAT(1X,/,'Warning! Evaporation request rejected since', | |
2198 | & ' central collisions forced.') | |
2199 | LEVPRT = .FALSE. | |
2200 | LDEEXG = .FALSE. | |
2201 | LHEAVY = .FALSE. | |
2202 | ENDIF | |
2203 | ENDIF | |
2204 | ||
2205 | * initialization of evaporation-module | |
2206 | ||
2207 | * initialize evaporation if the code is not used as Fluka event generator | |
2208 | WRITE(LOUT,*) ' ITRSPT = ', ITRSPT | |
2209 | IF (ITRSPT.NE.1) THEN | |
2210 | CALL NCDTRD | |
2211 | CALL INCINI | |
2212 | ENDIF | |
2213 | WRITE(LOUT,*) ' LEVPRT = ',LEVPRT | |
2214 | IF (LEVPRT) LHEAVY = .TRUE. | |
2215 | * save the default JETSET-parameter | |
2216 | CALL DT_JSPARA(0) | |
2217 | ||
2218 | WRITE(LOUT,*) ' IDP = ',IDP,' MCGENE = ',MCGENE | |
2219 | * force use of phojet for g-A | |
2220 | IF ((IDP.EQ.7).AND.(MCGENE.NE.3)) MCGENE = 2 | |
2221 | * initialization of nucleon-nucleon event generator | |
2222 | IF (MCGENE.EQ.2) CALL DT_PHOINI | |
2223 | * initialization of LEPTO event generator | |
2224 | IF (MCGENE.EQ.3) THEN | |
2225 | ||
2226 | STOP ' This version does not contain LEPTO !' | |
2227 | ||
2228 | ENDIF | |
2229 | ||
2230 | * initialization of quasi-elastic neutrino scattering | |
2231 | IF (MCGENE.EQ.4) THEN | |
2232 | IF (IJPROJ.EQ.5) THEN | |
2233 | NEUTYP = 1 | |
2234 | ELSEIF (IJPROJ.EQ.6) THEN | |
2235 | NEUTYP = 2 | |
2236 | ELSEIF (IJPROJ.EQ.135) THEN | |
2237 | NEUTYP = 3 | |
2238 | ELSEIF (IJPROJ.EQ.136) THEN | |
2239 | NEUTYP = 4 | |
2240 | ELSEIF (IJPROJ.EQ.133) THEN | |
2241 | NEUTYP = 5 | |
2242 | ELSEIF (IJPROJ.EQ.134) THEN | |
2243 | NEUTYP = 6 | |
2244 | ENDIF | |
2245 | ENDIF | |
2246 | ||
2247 | * normalize fractions of emulsion components | |
2248 | IF (NCOMPO.GT.0) THEN | |
2249 | SUMFRA = ZERO | |
2250 | DO 491 I=1,NCOMPO | |
2251 | SUMFRA = SUMFRA+EMUFRA(I) | |
2252 | 491 CONTINUE | |
2253 | IF (SUMFRA.GT.ZERO) THEN | |
2254 | DO 492 I=1,NCOMPO | |
2255 | EMUFRA(I) = EMUFRA(I)/SUMFRA | |
2256 | 492 CONTINUE | |
2257 | ENDIF | |
2258 | ENDIF | |
2259 | ||
2260 | * disallow Cronin's multiple scattering for nucleus-nucleus interactions | |
2261 | IF ((IP.GT.1).AND.(MKCRON.GT.0)) THEN | |
2262 | WRITE(LOUT,1005) | |
2263 | 1005 FORMAT(/,1X,'INIT: multiple scattering disallowed',/) | |
2264 | MKCRON = 0 | |
2265 | ENDIF | |
2266 | ||
2267 | * initialization of Glauber-formalism (moved to xAEVT, sr 26.3.96) | |
2268 | C IF (NCOMPO.LE.0) THEN | |
2269 | C CALL DT_SHMAKI(IP,IPZ,IT,ITZ,IDP,PPN,IGLAU) | |
2270 | C ELSE | |
2271 | C DO 493 I=1,NCOMPO | |
2272 | C CALL DT_SHMAKI(IP,IPZ,IEMUMA(I),IEMUCH(I),IDP,PPN,0) | |
2273 | C 493 CONTINUE | |
2274 | C ENDIF | |
2275 | ||
2276 | * pre-tabulation of elastic cross-sections | |
2277 | CALL DT_SIGTBL(JDUM,JDUM,DUM,DUM,-1) | |
2278 | ||
2279 | CALL DT_XTIME | |
2280 | ||
2281 | RETURN | |
2282 | ||
2283 | ********************************************************************* | |
2284 | * * | |
2285 | * control card: codewd = STOP * | |
2286 | * * | |
2287 | * stop of the event generation * | |
2288 | * * | |
2289 | * what (1..6) no meaning * | |
2290 | * * | |
2291 | ********************************************************************* | |
2292 | ||
2293 | 9999 CONTINUE | |
2294 | WRITE(LOUT,9000) | |
2295 | 9000 FORMAT(1X,'---> unexpected end of input !') | |
2296 | ||
2297 | 640 CONTINUE | |
2298 | STOP | |
2299 | ||
2300 | END | |
2301 | ||
2302 | *$ CREATE DT_KKINC.FOR | |
2303 | *COPY DT_KKINC | |
2304 | * | |
2305 | *===kkinc==============================================================* | |
2306 | * | |
2307 | SUBROUTINE DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT, | |
2308 | & IREJ) | |
2309 | ||
2310 | ************************************************************************ | |
2311 | * Treatment of complete nucleus-nucleus or hadron-nucleus scattering * | |
2312 | * This subroutine is an update of the previous version written * | |
2313 | * by J. Ranft/ H.-J. Moehring. * | |
2314 | * This version dated 19.11.95 is written by S. Roesler * | |
2315 | ************************************************************************ | |
2316 | ||
2317 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
2318 | SAVE | |
2319 | ||
2320 | PARAMETER ( LINP = 10 , | |
2321 | & LOUT = 6 , | |
2322 | & LDAT = 9 ) | |
2323 | ||
2324 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY5=1.0D-5, | |
2325 | & TINY2=1.0D-2,TINY3=1.0D-3) | |
2326 | ||
2327 | LOGICAL LFZC | |
2328 | ||
2329 | * event history | |
2330 | ||
2331 | PARAMETER (NMXHKK=200000) | |
2332 | ||
2333 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
2334 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
2335 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
2336 | ||
2337 | * extended event history | |
2338 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
2339 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
2340 | & IHIST(2,NMXHKK) | |
2341 | ||
2342 | * particle properties (BAMJET index convention) | |
2343 | CHARACTER*8 ANAME | |
2344 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
2345 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
2346 | ||
2347 | * properties of interacting particles | |
2348 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
2349 | ||
2350 | * Lorentz-parameters of the current interaction | |
2351 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
2352 | & UMO,PPCM,EPROJ,PPROJ | |
2353 | ||
2354 | * flags for input different options | |
2355 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
2356 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
2357 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
2358 | ||
2359 | * flags for particle decays | |
2360 | COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20), | |
2361 | & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20), | |
2362 | & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0 | |
2363 | ||
2364 | * cuts for variable energy runs | |
2365 | COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI | |
2366 | ||
2367 | * Glauber formalism: flags and parameters for statistics | |
2368 | LOGICAL LPROD | |
2369 | CHARACTER*8 CGLB | |
2370 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD | |
2371 | ||
2372 | DIMENSION WHAT(6) | |
2373 | ||
2374 | IREJ = 0 | |
2375 | ILOOP = 0 | |
2376 | 100 CONTINUE | |
2377 | IF (ILOOP.EQ.4) THEN | |
2378 | WRITE(LOUT,1000) NEVHKK | |
2379 | 1000 FORMAT(1X,'KKINC: event ',I8,' rejected!') | |
2380 | GOTO 9999 | |
2381 | ENDIF | |
2382 | ILOOP = ILOOP+1 | |
2383 | ||
2384 | * variable energy-runs, recalculate parameters for LT's | |
2385 | IF ((ABS(VAREHI).GT.ZERO).OR.(IOGLB.EQ.100)) THEN | |
2386 | PDUM = ZERO | |
2387 | CDUM = ZERO | |
2388 | CALL DT_LTINI(IDP,1,EPN,PDUM,CDUM,1) | |
2389 | ENDIF | |
2390 | IF (EPN.GT.EPROJ) THEN | |
2391 | WRITE(LOUT,'(A,E9.3,2A,E9.3,A)') | |
2392 | & ' Requested energy (',EPN,'GeV) exceeds', | |
2393 | & ' initialization energy (',EPROJ,'GeV) !' | |
2394 | STOP | |
2395 | ENDIF | |
2396 | ||
2397 | * re-initialize /DTPRTA/ | |
2398 | IP = NPMASS | |
2399 | IPZ = NPCHAR | |
2400 | IT = NTMASS | |
2401 | ITZ = NTCHAR | |
2402 | IJPROJ = IDP | |
2403 | IBPROJ = IIBAR(IJPROJ) | |
2404 | ||
2405 | * calculate nuclear potentials (common /DTNPOT/) | |
2406 | CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0) | |
2407 | ||
2408 | * initialize treatment for residual nuclei | |
2409 | CALL DT_RESNCL(EPN,NLOOP,1) | |
2410 | ||
2411 | * sample hadron/nucleus-nucleus interaction | |
2412 | CALL DT_KKEVNT(KKMAT,IREJ1) | |
2413 | IF (IREJ1.GT.0) THEN | |
2414 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKINC' | |
2415 | GOTO 9999 | |
2416 | ENDIF | |
2417 | ||
2418 | IF ((NPMASS.GT.1).OR.(NTMASS.GT.1)) THEN | |
2419 | ||
2420 | * intranuclear cascade of final state particles for KTAUGE generations | |
2421 | * of secondaries | |
2422 | CALL DT_FOZOCA(LFZC,IREJ1) | |
2423 | IF (IREJ1.GT.0) THEN | |
2424 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKINC' | |
2425 | GOTO 9999 | |
2426 | ENDIF | |
2427 | ||
2428 | * baryons unable to escape the nuclear potential are treated as | |
2429 | * excited nucleons (ISTHKK=15,16) | |
2430 | CALL DT_SCN4BA | |
2431 | ||
2432 | * decay of resonances produced in intranuclear cascade processes | |
2433 | **sr 15-11-95 should be obsolete | |
2434 | C IF (LFZC) CALL DT_DECAY1 | |
2435 | ||
2436 | 101 CONTINUE | |
2437 | * treatment of residual nuclei | |
2438 | CALL DT_RESNCL(EPN,NLOOP,2) | |
2439 | ||
2440 | * evaporation / fission / fragmentation | |
2441 | * (if intranuclear cascade was sampled only) | |
2442 | IF (LFZC) THEN | |
2443 | CALL DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ1) | |
2444 | IF (IREJ1.GT.1) GOTO 101 | |
2445 | IF (IREJ1.EQ.1) GOTO 100 | |
2446 | ENDIF | |
2447 | ||
2448 | ENDIF | |
2449 | ||
2450 | * rejection of unphysical configurations | |
2451 | C CALL DT_REJUCO(1,IREJ1) | |
2452 | C IF (IREJ1.GT.0) THEN | |
2453 | C IF (IOULEV(1).GT.0) | |
2454 | C & WRITE(LOUT,*) 'rejected 3 in KKINC: too large x' | |
2455 | C GOTO 100 | |
2456 | C ENDIF | |
2457 | ||
2458 | * transform finale state into Lab. | |
2459 | IFLAG = 2 | |
2460 | CALL DT_BEAMPR(WHAT,DUM,IFLAG) | |
2461 | IF ((IFRAME.EQ.1).AND.(IFLAG.EQ.-1)) CALL DT_LT2LAB | |
2462 | ||
2463 | IF (IPI0.EQ.1) CALL DT_DECPI0 | |
2464 | ||
2465 | C IF (NEVHKK.EQ.5) CALL DT_EVTOUT(4) | |
2466 | ||
2467 | RETURN | |
2468 | 9999 CONTINUE | |
2469 | IREJ = 1 | |
2470 | RETURN | |
2471 | END | |
2472 | ||
2473 | *$ CREATE DT_DEFAUL.FOR | |
2474 | *COPY DT_DEFAUL | |
2475 | * | |
2476 | *===defaul=============================================================* | |
2477 | * | |
2478 | SUBROUTINE DT_DEFAUL(EPN,PPN) | |
2479 | ||
2480 | ************************************************************************ | |
2481 | * Variables are set to default values. * | |
2482 | * This version dated 8.5.95 is written by S. Roesler. * | |
2483 | ************************************************************************ | |
2484 | ||
2485 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
2486 | SAVE | |
2487 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10) | |
2488 | PARAMETER (TWOPI = 6.283185307179586454D+00) | |
2489 | ||
2490 | * particle properties (BAMJET index convention) | |
2491 | CHARACTER*8 ANAME | |
2492 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
2493 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
2494 | ||
2495 | * nuclear potential | |
2496 | LOGICAL LFERMI | |
2497 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, | |
2498 | & EBINDP(2),EBINDN(2),EPOT(2,210), | |
2499 | & ETACOU(2),ICOUL,LFERMI | |
2500 | ||
2501 | * interface HADRIN-DPM | |
2502 | COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA | |
2503 | ||
2504 | * central particle production, impact parameter biasing | |
2505 | COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR | |
2506 | ||
2507 | * properties of interacting particles | |
2508 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
2509 | ||
2510 | * properties of photon/lepton projectiles | |
2511 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC | |
2512 | ||
2513 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
2514 | ||
2515 | * emulsion treatment | |
2516 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
2517 | & NCOMPO,IEMUL | |
2518 | ||
2519 | * parameter for intranuclear cascade | |
2520 | LOGICAL LPAULI | |
2521 | COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI | |
2522 | ||
2523 | * various options for treatment of partons (DTUNUC 1.x) | |
2524 | * (chain recombination, Cronin,..) | |
2525 | LOGICAL LCO2CR,LINTPT | |
2526 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, | |
2527 | & LCO2CR,LINTPT | |
2528 | ||
2529 | * threshold values for x-sampling (DTUNUC 1.x) | |
2530 | COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA, | |
2531 | & SSMIMQ,VVMTHR | |
2532 | ||
2533 | * flags for input different options | |
2534 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
2535 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
2536 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
2537 | ||
2538 | * n-n cross section fluctuations | |
2539 | PARAMETER (NBINS = 1000) | |
2540 | COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT | |
2541 | ||
2542 | * flags for particle decays | |
2543 | COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20), | |
2544 | & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20), | |
2545 | & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0 | |
2546 | ||
2547 | * diquark-breaking mechanism | |
2548 | COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3 | |
2549 | ||
2550 | * nucleon-nucleon event-generator | |
2551 | CHARACTER*8 CMODEL | |
2552 | LOGICAL LPHOIN | |
2553 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
2554 | ||
2555 | * flags for diffractive interactions (DTUNUC 1.x) | |
2556 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF | |
2557 | ||
2558 | * VDM parameter for photon-nucleus interactions | |
2559 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
2560 | ||
2561 | * Glauber formalism: flags and parameters for statistics | |
2562 | LOGICAL LPROD | |
2563 | CHARACTER*8 CGLB | |
2564 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD | |
2565 | ||
2566 | * kinematical cuts for lepton-nucleus interactions | |
2567 | COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX, | |
2568 | & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI | |
2569 | ||
2570 | * flags for activated histograms | |
2571 | COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL | |
2572 | ||
2573 | * cuts for variable energy runs | |
2574 | COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI | |
2575 | ||
2576 | * parameters for hA-diffraction | |
2577 | COMMON /DTDIHA/ DIBETA,DIALPH | |
2578 | ||
2579 | * LEPTO | |
2580 | REAL RPPN | |
2581 | COMMON /LEPTOI/ RPPN,LEPIN,INTER | |
2582 | ||
2583 | * steering flags for qel neutrino scattering modules | |
2584 | COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC | |
2585 | ||
2586 | * event flag | |
2587 | COMMON /DTEVNO/ NEVENT,ICASCA | |
2588 | ||
2589 | DATA POTMES /0.002D0/ | |
2590 | ||
2591 | * common /DTNPOT/ | |
2592 | DO 10 I=1,2 | |
2593 | PFERMP(I) = ZERO | |
2594 | PFERMN(I) = ZERO | |
2595 | EBINDP(I) = ZERO | |
2596 | EBINDN(I) = ZERO | |
2597 | DO 11 J=1,210 | |
2598 | EPOT(I,J) = ZERO | |
2599 | 11 CONTINUE | |
2600 | * nucleus independent meson potential | |
2601 | EPOT(I,13) = POTMES | |
2602 | EPOT(I,14) = POTMES | |
2603 | EPOT(I,15) = POTMES | |
2604 | EPOT(I,16) = POTMES | |
2605 | EPOT(I,23) = POTMES | |
2606 | EPOT(I,24) = POTMES | |
2607 | EPOT(I,25) = POTMES | |
2608 | 10 CONTINUE | |
2609 | FERMOD = 0.55D0 | |
2610 | ETACOU(1) = ZERO | |
2611 | ETACOU(2) = ZERO | |
2612 | ICOUL = 1 | |
2613 | LFERMI = .TRUE. | |
2614 | ||
2615 | * common /HNTHRE/ | |
2616 | EHADTH = -99.0D0 | |
2617 | EHADLO = 4.06D0 | |
2618 | EHADHI = 6.0D0 | |
2619 | INTHAD = 1 | |
2620 | IDXTA = 2 | |
2621 | ||
2622 | * common /DTIMPA/ | |
2623 | ICENTR = 0 | |
2624 | BIMIN = ZERO | |
2625 | BIMAX = 1.0D10 | |
2626 | XSFRAC = 1.0D0 | |
2627 | ||
2628 | * common /DTPRTA/ | |
2629 | IP = 1 | |
2630 | IPZ = 1 | |
2631 | IT = 1 | |
2632 | ITZ = 1 | |
2633 | IJPROJ = 1 | |
2634 | IBPROJ = 1 | |
2635 | IJTARG = 1 | |
2636 | IBTARG = 1 | |
2637 | * common /DTGPRO/ | |
2638 | VIRT = ZERO | |
2639 | DO 14 I=1,4 | |
2640 | PGAMM(I) = ZERO | |
2641 | PLEPT0(I) = ZERO | |
2642 | PLEPT1(I) = ZERO | |
2643 | PNUCL(I) = ZERO | |
2644 | 14 CONTINUE | |
2645 | IDIREC = 0 | |
2646 | ||
2647 | * common /DTFOTI/ | |
2648 | **sr 7.4.98: changed after corrected B-sampling | |
2649 | C TAUFOR = 4.4D0 | |
2650 | TAUFOR = 3.5D0 | |
2651 | KTAUGE = 25 | |
2652 | ITAUVE = 1 | |
2653 | INCMOD = 1 | |
2654 | LPAULI = .TRUE. | |
2655 | ||
2656 | * common /DTCHAI/ | |
2657 | SEASQ = ONE | |
2658 | MKCRON = 1 | |
2659 | CRONCO = 0.64D0 | |
2660 | ISICHA = 0 | |
2661 | CUTOF = 100.0D0 | |
2662 | LCO2CR = .FALSE. | |
2663 | IRECOM = 1 | |
2664 | LINTPT = .TRUE. | |
2665 | ||
2666 | * common /DTXCUT/ | |
2667 | * definition of soft quark distributions | |
2668 | XSEACU = 0.05D0 | |
2669 | UNON = 2.0D0 | |
2670 | UNOM = 1.5D0 | |
2671 | UNOSEA = 5.0D0 | |
2672 | * cutoff parameters for x-sampling | |
2673 | CVQ = 1.0D0 | |
2674 | CDQ = 2.0D0 | |
2675 | C CSEA = 0.3D0 | |
2676 | CSEA = 0.1D0 | |
2677 | SSMIMA = 1.2D0 | |
2678 | SSMIMQ = SSMIMA**2 | |
2679 | VVMTHR = 2.0D0 | |
2680 | ||
2681 | * common /DTXSFL/ | |
2682 | IFLUCT = 0 | |
2683 | ||
2684 | * common /DTFRPA/ | |
2685 | PDB = 0.15D0 | |
2686 | PDBSEA(1) = 0.0D0 | |
2687 | PDBSEA(2) = 0.0D0 | |
2688 | PDBSEA(3) = 0.0D0 | |
2689 | ISIG0 = 0 | |
2690 | IPI0 = 0 | |
2691 | NMSTU = 0 | |
2692 | NPARU = 0 | |
2693 | NMSTJ = 0 | |
2694 | NPARJ = 0 | |
2695 | ||
2696 | * common /DTDIQB/ | |
2697 | DO 15 I=1,8 | |
2698 | DBRKR(1,I) = 5.0D0 | |
2699 | DBRKR(2,I) = 5.0D0 | |
2700 | DBRKR(3,I) = 10.0D0 | |
2701 | DBRKA(1,I) = ZERO | |
2702 | DBRKA(2,I) = ZERO | |
2703 | DBRKA(3,I) = ZERO | |
2704 | 15 CONTINUE | |
2705 | CHAM1 = 0.2D0 | |
2706 | CHAM3 = 0.5D0 | |
2707 | CHAB1 = 0.7D0 | |
2708 | CHAB3 = 1.0D0 | |
2709 | ||
2710 | * common /DTFLG3/ | |
2711 | ISINGD = 0 | |
2712 | IDOUBD = 0 | |
2713 | IFLAGD = 0 | |
2714 | IDIFF = 0 | |
2715 | ||
2716 | * common /DTMODL/ | |
2717 | MCGENE = 2 | |
2718 | CMODEL(1) = 'DTUNUC ' | |
2719 | CMODEL(2) = 'PHOJET ' | |
2720 | CMODEL(3) = 'LEPTO ' | |
2721 | CMODEL(4) = 'QNEUTRIN' | |
2722 | LPHOIN = .TRUE. | |
2723 | ELOJET = 5.0D0 | |
2724 | ||
2725 | * common /DTLCUT/ | |
2726 | ECMIN = 3.5D0 | |
2727 | ECMAX = 1.0D10 | |
2728 | XBJMIN = ZERO | |
2729 | ELMIN = ZERO | |
2730 | EGMIN = ZERO | |
2731 | EGMAX = 1.0D10 | |
2732 | YMIN = TINY10 | |
2733 | YMAX = 0.999D0 | |
2734 | Q2MIN = TINY10 | |
2735 | Q2MAX = 10.0D0 | |
2736 | THMIN = ZERO | |
2737 | THMAX = TWOPI | |
2738 | Q2LI = ZERO | |
2739 | Q2HI = 1.0D10 | |
2740 | ECMLI = ZERO | |
2741 | ECMHI = 1.0D10 | |
2742 | ||
2743 | * common /DTVDMP/ | |
2744 | RL2 = 2.0D0 | |
2745 | INTRGE(1) = 1 | |
2746 | INTRGE(2) = 3 | |
2747 | IDPDF = 2212 | |
2748 | MODEGA = 4 | |
2749 | ISHAD(1) = 1 | |
2750 | ISHAD(2) = 1 | |
2751 | ISHAD(3) = 1 | |
2752 | EPSPOL = ZERO | |
2753 | ||
2754 | * common /DTGLGP/ | |
2755 | JSTATB = 1000 | |
2756 | JBINSB = 49 | |
2757 | CGLB = ' ' | |
2758 | IF (ITRSPT.EQ.1) THEN | |
2759 | IOGLB = 100 | |
2760 | ELSE | |
2761 | IOGLB = 0 | |
2762 | ENDIF | |
2763 | LPROD = .TRUE. | |
2764 | ||
2765 | * common /DTHIS3/ | |
2766 | DO 16 I=1,50 | |
2767 | IHISPP(I) = 0 | |
2768 | IHISXS(I) = 0 | |
2769 | 16 CONTINUE | |
2770 | IXSTBL = 0 | |
2771 | ||
2772 | * common /DTVARE/ | |
2773 | VARELO = ZERO | |
2774 | VAREHI = ZERO | |
2775 | VARCLO = ZERO | |
2776 | VARCHI = ZERO | |
2777 | ||
2778 | * common /DTDIHA/ | |
2779 | DIBETA = -1.0D0 | |
2780 | DIALPH = ZERO | |
2781 | ||
2782 | * common /LEPTOI/ | |
2783 | RPPN = 0.0 | |
2784 | LEPIN = 0 | |
2785 | INTER = 0 | |
2786 | ||
2787 | * common /QNEUTO/ | |
2788 | NEUTYP = 1 | |
2789 | NEUDEC = 0 | |
2790 | ||
2791 | * common /DTEVNO/ | |
2792 | NEVENT = 1 | |
2793 | IF (ITRSPT.EQ.1) THEN | |
2794 | ICASCA = 1 | |
2795 | ELSE | |
2796 | ICASCA = 0 | |
2797 | ENDIF | |
2798 | ||
2799 | * default Lab.-energy | |
2800 | EPN = 200.0D0 | |
2801 | PPN = SQRT((EPN-AAM(IJPROJ))*(EPN+AAM(IJPROJ))) | |
2802 | ||
2803 | RETURN | |
2804 | END | |
2805 | ||
2806 | *$ CREATE DT_AAEVT.FOR | |
2807 | *COPY DT_AAEVT | |
2808 | * | |
2809 | *===aaevt==============================================================* | |
2810 | * | |
2811 | SUBROUTINE DT_AAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR, | |
2812 | & IDP,IGLAU) | |
2813 | ||
2814 | ************************************************************************ | |
2815 | * This version dated 22.03.96 is written by S. Roesler. * | |
2816 | ************************************************************************ | |
2817 | ||
2818 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
2819 | SAVE | |
2820 | ||
2821 | PARAMETER ( LINP = 10 , | |
2822 | & LOUT = 6 , | |
2823 | & LDAT = 9 ) | |
2824 | ||
2825 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
2826 | ||
2827 | * emulsion treatment | |
2828 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
2829 | & NCOMPO,IEMUL | |
2830 | ||
2831 | * event flag | |
2832 | COMMON /DTEVNO/ NEVENT,ICASCA | |
2833 | ||
2834 | CHARACTER*8 DATE,HHMMSS | |
2835 | CHARACTER*9 CHDATE,CHTIME,CHZONE | |
2836 | DIMENSION JDMNYR(8),IDMNYR(3) | |
2837 | ||
2838 | KKMAT = 1 | |
2839 | NMSG = MAX(NEVTS/100,1) | |
2840 | ||
2841 | * initialization of run-statistics and histograms | |
2842 | CALL DT_STATIS(1) | |
2843 | ||
2844 | CALL PHO_PHIST(1000,DUM) | |
2845 | ||
2846 | * initialization of Glauber-formalism | |
2847 | IF (NCOMPO.LE.0) THEN | |
2848 | CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU) | |
2849 | ELSE | |
2850 | DO 1 I=1,NCOMPO | |
2851 | CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0) | |
2852 | 1 CONTINUE | |
2853 | ENDIF | |
2854 | CALL DT_SIGEMU | |
2855 | ||
2856 | C CALL IDATE(IDMNYR) | |
2857 | C WRITE(DATE,'(I2,''/'',I2,''/'',I2)') | |
2858 | C & IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100) | |
2859 | CALL DATE_AND_TIME ( CHDATE, CHTIME, CHZONE, JDMNYR ) | |
2860 | WRITE(DATE,'(I2,''/'',I2,''/'',I2)') | |
2861 | & JDMNYR(3),JDMNYR(2),MOD(JDMNYR(1),100) | |
2862 | CALL ITIME(IDMNYR) | |
2863 | WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)') | |
2864 | & IDMNYR(1),IDMNYR(2),IDMNYR(3) | |
2865 | WRITE(LOUT,1001) DATE,HHMMSS | |
2866 | 1001 FORMAT(/,' DT_AAEVT: Initialisation finished. ( Date: ',A8, | |
2867 | & ' Time: ',A8,' )') | |
2868 | ||
2869 | * generate NEVTS events | |
2870 | DO 2 IEVT=1,NEVTS | |
2871 | ||
2872 | * print run-status message | |
2873 | IF (MOD(IEVT,NMSG).EQ.0) THEN | |
2874 | C CALL IDATE(IDMNYR) | |
2875 | C WRITE(DATE,'(I2,''/'',I2,''/'',I2)') | |
2876 | C & IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100) | |
2877 | CALL DATE_AND_TIME ( CHDATE, CHTIME, CHZONE, JDMNYR ) | |
2878 | WRITE(DATE,'(I2,''/'',I2,''/'',I2)') | |
2879 | & JDMNYR(3),JDMNYR(2),MOD(JDMNYR(1),100) | |
2880 | CALL ITIME(IDMNYR) | |
2881 | WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)') | |
2882 | & IDMNYR(1),IDMNYR(2),IDMNYR(3) | |
2883 | WRITE(LOUT,1000) IEVT-1,NEVTS,DATE,HHMMSS | |
2884 | 1000 FORMAT(/,1X,I8,' out of ',I8,' events sampled ( Date: ',A, | |
2885 | & ' Time: ',A,' )',/) | |
2886 | C WRITE(LOUT,1000) IEVT-1 | |
2887 | C1000 FORMAT(1X,I8,' events sampled') | |
2888 | ENDIF | |
2889 | NEVENT = IEVT | |
2890 | * treat nuclear emulsions | |
2891 | IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0) | |
2892 | * composite targets only | |
2893 | KKMAT = -KKMAT | |
2894 | * sample this event | |
2895 | CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,IREJ) | |
2896 | ||
2897 | CALL PHO_PHIST(2000,DUM) | |
2898 | ||
2899 | 2 CONTINUE | |
2900 | ||
2901 | * print run-statistics and histograms to output-unit 6 | |
2902 | ||
2903 | CALL PHO_PHIST(3000,DUM) | |
2904 | ||
2905 | CALL DT_STATIS(2) | |
2906 | ||
2907 | RETURN | |
2908 | END | |
2909 | ||
2910 | *$ CREATE DT_LAEVT.FOR | |
2911 | *COPY DT_LAEVT | |
2912 | * | |
2913 | *===laevt==============================================================* | |
2914 | * | |
2915 | SUBROUTINE DT_LAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR, | |
2916 | & IDP,IGLAU) | |
2917 | ||
2918 | ************************************************************************ | |
2919 | * Interface to run DPMJET for lepton-nucleus interactions. * | |
2920 | * Kinematics is sampled using the equivalent photon approximation * | |
2921 | * Based on GPHERA-routine by R. Engel. * | |
2922 | * This version dated 23.03.96 is written by S. Roesler. * | |
2923 | ************************************************************************ | |
2924 | ||
2925 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
2926 | SAVE | |
2927 | ||
2928 | PARAMETER ( LINP = 10 , | |
2929 | & LOUT = 6 , | |
2930 | & LDAT = 9 ) | |
2931 | ||
2932 | PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4, | |
2933 | & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0) | |
2934 | PARAMETER (TWOPI = 6.283185307179586454D+00, | |
2935 | & PI = TWOPI/TWO, | |
2936 | & ALPHEM = ONE/137.0D0) | |
2937 | ||
2938 | C CHARACTER*72 HEADER | |
2939 | ||
2940 | * particle properties (BAMJET index convention) | |
2941 | CHARACTER*8 ANAME | |
2942 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
2943 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
2944 | ||
2945 | * event history | |
2946 | ||
2947 | PARAMETER (NMXHKK=200000) | |
2948 | ||
2949 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
2950 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
2951 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
2952 | ||
2953 | * extended event history | |
2954 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
2955 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
2956 | & IHIST(2,NMXHKK) | |
2957 | ||
2958 | * kinematical cuts for lepton-nucleus interactions | |
2959 | COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX, | |
2960 | & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI | |
2961 | ||
2962 | * properties of interacting particles | |
2963 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
2964 | ||
2965 | * properties of photon/lepton projectiles | |
2966 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC | |
2967 | ||
2968 | * kinematics at lepton-gamma vertex | |
2969 | COMMON /DTLGVX/ PPL0(4),PPL1(4),PPG(4),PPA(4) | |
2970 | ||
2971 | * flags for activated histograms | |
2972 | COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL | |
2973 | ||
2974 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
2975 | ||
2976 | * emulsion treatment | |
2977 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
2978 | & NCOMPO,IEMUL | |
2979 | ||
2980 | * Glauber formalism: cross sections | |
2981 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
2982 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
2983 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
2984 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
2985 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
2986 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
2987 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
2988 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
2989 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
2990 | & BSLOPE,NEBINI,NQBINI | |
2991 | ||
2992 | * nucleon-nucleon event-generator | |
2993 | CHARACTER*8 CMODEL | |
2994 | LOGICAL LPHOIN | |
2995 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
2996 | ||
2997 | * flags for input different options | |
2998 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
2999 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
3000 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
3001 | ||
3002 | * event flag | |
3003 | COMMON /DTEVNO/ NEVENT,ICASCA | |
3004 | ||
3005 | DIMENSION XDUMB(40),BGTA(4) | |
3006 | ||
3007 | * LEPTO | |
3008 | IF (MCGENE.EQ.3) THEN | |
3009 | ||
3010 | STOP ' This version does not contain LEPTO !' | |
3011 | ||
3012 | ENDIF | |
3013 | ||
3014 | KKMAT = 1 | |
3015 | NMSG = MAX(NEVTS/10,1) | |
3016 | ||
3017 | * mass of incident lepton | |
3018 | AMLPT = AAM(IDP) | |
3019 | AMLPT2 = AMLPT**2 | |
3020 | IDPPDG = IDT_IPDGHA(IDP) | |
3021 | ||
3022 | * consistency of kinematical limits | |
3023 | Q2MIN = MAX(Q2MIN,TINY10) | |
3024 | Q2MAX = MAX(Q2MAX,TINY10) | |
3025 | YMIN = MIN(MAX(YMIN,TINY10),0.999D0) | |
3026 | YMAX = MIN(MAX(YMAX,TINY10),0.999D0) | |
3027 | ||
3028 | * total energy of the lepton-nucleon system | |
3029 | PTOTLN = SQRT( (PLEPT0(1)+PNUCL(1))**2+(PLEPT0(2)+PNUCL(2))**2 | |
3030 | & +(PLEPT0(3)+PNUCL(3))**2 ) | |
3031 | ETOTLN = PLEPT0(4)+PNUCL(4) | |
3032 | ECMLN = SQRT((ETOTLN-PTOTLN)*(ETOTLN+PTOTLN)) | |
3033 | ECMAX = MIN(ECMAX,ECMLN) | |
3034 | WRITE(LOUT,1003) ECMIN,ECMAX,YMIN,YMAX,Q2MIN,Q2MAX,EGMIN, | |
3035 | & THMIN,THMAX,ELMIN | |
3036 | 1003 FORMAT(1X,'LAEVT:',16X,'kinematical cuts',/,22X, | |
3037 | & '------------------',/,9X,'W (min) =', | |
3038 | & F7.1,' GeV (max) =',F7.1,' GeV',/,9X,'y (min) =', | |
3039 | & F7.3,8X,'(max) =',F7.3,/,9X,'Q^2 (min) =',F7.1, | |
3040 | & ' GeV^2 (max) =',F7.1,' GeV^2',/,' (Lab) E_g (min) =' | |
3041 | & ,F7.1,' GeV',/,' (Lab) theta (min) =',F7.4,8X,'(max) =', | |
3042 | & F7.4,' for E_lpt >',F7.1,' GeV',/) | |
3043 | ||
3044 | * Lorentz-parameter for transf. into Lab | |
3045 | BGTA(1) = PNUCL(1)/AAM(1) | |
3046 | BGTA(2) = PNUCL(2)/AAM(1) | |
3047 | BGTA(3) = PNUCL(3)/AAM(1) | |
3048 | BGTA(4) = PNUCL(4)/AAM(1) | |
3049 | * LT of incident lepton into Lab and dump it in DTEVT1 | |
3050 | CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3), | |
3051 | & PLEPT0(1),PLEPT0(2),PLEPT0(3),PLEPT0(4), | |
3052 | & PLTOT,PPL0(1),PPL0(2),PPL0(3),PPL0(4)) | |
3053 | CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3), | |
3054 | & PNUCL(1),PNUCL(2),PNUCL(3),PNUCL(4), | |
3055 | & PLTOT,PPA(1),PPA(2),PPA(3),PPA(4)) | |
3056 | * maximum energy of photon nucleon system | |
3057 | PTOTGN = SQRT((YMAX*PPL0(1)+PPA(1))**2+(YMAX*PPL0(2)+PPA(2))**2 | |
3058 | & +(YMAX*PPL0(3)+PPA(3))**2) | |
3059 | ETOTGN = YMAX*PPL0(4)+PPA(4) | |
3060 | EGNMAX = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN)) | |
3061 | EGNMAX = MIN(EGNMAX,ECMAX) | |
3062 | * minimum energy of photon nucleon system | |
3063 | PTOTGN = SQRT((YMIN*PPL0(1)+PPA(1))**2+(YMIN*PPL0(2)+PPA(2))**2 | |
3064 | & +(YMIN*PPL0(3)+PPA(3))**2) | |
3065 | ETOTGN = YMIN*PPL0(4)+PPA(4) | |
3066 | EGNMIN = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN)) | |
3067 | EGNMIN = MAX(EGNMIN,ECMIN) | |
3068 | ||
3069 | * limits for Glauber-initialization | |
3070 | Q2LI = Q2MIN | |
3071 | Q2HI = MAX(Q2LI,MIN(Q2HI,Q2MAX)) | |
3072 | ECMLI = MAX(EGNMIN,THREE) | |
3073 | ECMHI = EGNMAX | |
3074 | WRITE(LOUT,1004) EGNMIN,EGNMAX,ECMLI,ECMHI,Q2LI,Q2HI | |
3075 | 1004 FORMAT(1X,'resulting limits:',/,9X,'W (min) =',F7.1, | |
3076 | & ' GeV (max) =',F7.1,' GeV',/,/,' limits for ', | |
3077 | & 'Glauber-initialization:',/,9X,'W (min) =',F7.1, | |
3078 | & ' GeV (max) =',F7.1,' GeV',/,9X,'Q^2 (min) =',F7.1, | |
3079 | & ' GeV^2 (max) =',F7.1,' GeV^2',/) | |
3080 | * initialization of Glauber-formalism | |
3081 | IF (NCOMPO.LE.0) THEN | |
3082 | CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU) | |
3083 | ELSE | |
3084 | DO 9 I=1,NCOMPO | |
3085 | CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0) | |
3086 | 9 CONTINUE | |
3087 | ENDIF | |
3088 | CALL DT_SIGEMU | |
3089 | ||
3090 | * initialization of run-statistics and histograms | |
3091 | CALL DT_STATIS(1) | |
3092 | ||
3093 | CALL PHO_PHIST(1000,DUM) | |
3094 | ||
3095 | * maximum photon-nucleus cross section | |
3096 | I1 = 1 | |
3097 | I2 = 1 | |
3098 | RAT = ONE | |
3099 | IF (EGNMAX.GE.ECMNN(NEBINI)) THEN | |
3100 | I1 = NEBINI | |
3101 | I2 = NEBINI | |
3102 | RAT = ONE | |
3103 | ELSEIF (EGNMAX.GT.ECMNN(1)) THEN | |
3104 | DO 5 I=2,NEBINI | |
3105 | IF (EGNMAX.LT.ECMNN(I)) THEN | |
3106 | I1 = I-1 | |
3107 | I2 = I | |
3108 | RAT = (EGNMAX-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1)) | |
3109 | GOTO 6 | |
3110 | ENDIF | |
3111 | 5 CONTINUE | |
3112 | 6 CONTINUE | |
3113 | ENDIF | |
3114 | SIGMAX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1)) | |
3115 | EGNXX = EGNMAX | |
3116 | I1 = 1 | |
3117 | I2 = 1 | |
3118 | RAT = ONE | |
3119 | IF (EGNMIN.GE.ECMNN(NEBINI)) THEN | |
3120 | I1 = NEBINI | |
3121 | I2 = NEBINI | |
3122 | RAT = ONE | |
3123 | ELSEIF (EGNMIN.GT.ECMNN(1)) THEN | |
3124 | DO 7 I=2,NEBINI | |
3125 | IF (EGNMIN.LT.ECMNN(I)) THEN | |
3126 | I1 = I-1 | |
3127 | I2 = I | |
3128 | RAT = (EGNMIN-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1)) | |
3129 | GOTO 8 | |
3130 | ENDIF | |
3131 | 7 CONTINUE | |
3132 | 8 CONTINUE | |
3133 | ENDIF | |
3134 | SIGXX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1)) | |
3135 | IF (SIGXX.GT.SIGMAX) EGNXX = EGNMIN | |
3136 | SIGMAX = MAX(SIGMAX,SIGXX) | |
3137 | WRITE(LOUT,'(9X,A,F8.3,A)') 'Sigma_tot (max) =',SIGMAX,' mb' | |
3138 | ||
3139 | * plot photon flux table | |
3140 | AYMIN = LOG(YMIN) | |
3141 | AYMAX = LOG(YMAX) | |
3142 | AYRGE = AYMAX-AYMIN | |
3143 | MAXTAB = 50 | |
3144 | ADY = LOG(YMAX/YMIN)/DBLE(MAXTAB-1) | |
3145 | C WRITE(LOUT,'(/,1X,A)') 'LAEVT: photon flux ' | |
3146 | DO 1 I=1,MAXTAB | |
3147 | Y = EXP(AYMIN+ADY*DBLE(I-1)) | |
3148 | Q2LOW = MAX(Q2MIN,AMLPT2*Y**2/(ONE-Y)) | |
3149 | FF1 = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW) | |
3150 | & -TWO*AMLPT2*Y*(ONE/Q2LOW-ONE/Q2MAX)) | |
3151 | FF2 = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW) | |
3152 | & -TWO*(ONE-Y)/Y*(ONE-Q2LOW/Q2MAX)) | |
3153 | C WRITE(LOUT,'(5X,3E15.4)') Y,FF1,FF2 | |
3154 | 1 CONTINUE | |
3155 | ||
3156 | * maximum residual weight for flux sampling (dy/y) | |
3157 | YY = YMIN | |
3158 | Q2LOW = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY)) | |
3159 | WGHMAX = (ONE+(ONE-YY)**2)*LOG(Q2MAX/Q2LOW) | |
3160 | & -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY | |
3161 | ||
3162 | CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY0) | |
3163 | CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY1) | |
3164 | CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY2) | |
3165 | CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ0) | |
3166 | CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ1) | |
3167 | CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ2) | |
3168 | CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE0) | |
3169 | CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE1) | |
3170 | CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE2) | |
3171 | CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU0) | |
3172 | CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU1) | |
3173 | CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU2) | |
3174 | XBLOW = 0.001D0 | |
3175 | CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX0) | |
3176 | CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX1) | |
3177 | CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX2) | |
3178 | ||
3179 | ITRY = 0 | |
3180 | ITRW = 0 | |
3181 | NC0 = 0 | |
3182 | NC1 = 0 | |
3183 | ||
3184 | * generate events | |
3185 | DO 2 IEVT=1,NEVTS | |
3186 | IF (MOD(IEVT,NMSG).EQ.0) THEN | |
3187 | C OPEN(LDAT,FILE='/scrtch3/hr/sroesler/statusd5.out', | |
3188 | C & STATUS='UNKNOWN') | |
3189 | WRITE(LOUT,'(1X,I8,A)') IEVT-1,' events sampled' | |
3190 | C CLOSE(LDAT) | |
3191 | ENDIF | |
3192 | NEVENT = IEVT | |
3193 | ||
3194 | 100 CONTINUE | |
3195 | ITRY = ITRY+1 | |
3196 | ||
3197 | * sample y | |
3198 | 101 CONTINUE | |
3199 | ITRW = ITRW+1 | |
3200 | YY = EXP(AYRGE*DT_RNDM(RAT)+AYMIN) | |
3201 | Q2LOW = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY)) | |
3202 | Q2LOG = LOG(Q2MAX/Q2LOW) | |
3203 | WGH = (ONE+(ONE-YY)**2)*Q2LOG | |
3204 | & -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY | |
3205 | IF (WGHMAX.LT.WGH) WRITE(LOUT,1000) YY,WGHMAX,WGH | |
3206 | 1000 FORMAT(1X,'LAEVT: weight error!',3E12.5) | |
3207 | IF (DT_RNDM(YY)*WGHMAX.GT.WGH) GOTO 101 | |
3208 | ||
3209 | * sample Q2 | |
3210 | YEFF = ONE+(ONE-YY)**2 | |
3211 | 102 CONTINUE | |
3212 | Q2 = Q2LOW*EXP(Q2LOG*DT_RNDM(YY)) | |
3213 | WGH = (YEFF-TWO*(ONE-YY)*Q2LOW/Q2)/YEFF | |
3214 | IF (WGH.LT.DT_RNDM(Q2)) GOTO 102 | |
3215 | ||
3216 | c NC0 = NC0+1 | |
3217 | c CALL DT_FILHGR(YY,ONE,IHFLY0,NC0) | |
3218 | c CALL DT_FILHGR(Q2,ONE,IHFLQ0,NC0) | |
3219 | ||
3220 | * kinematics at lepton-photon vertex | |
3221 | * scattered electron | |
3222 | YQ2 = SQRT((ONE-YY)*Q2) | |
3223 | Q2E = Q2/(4.0D0*PLEPT0(4)) | |
3224 | E1Y = (ONE-YY)*PLEPT0(4) | |
3225 | CALL DT_DSFECF(SIF,COF) | |
3226 | PLEPT1(1) = YQ2*COF | |
3227 | PLEPT1(2) = YQ2*SIF | |
3228 | PLEPT1(3) = E1Y-Q2E | |
3229 | PLEPT1(4) = E1Y+Q2E | |
3230 | C THETA = ACOS( (E1Y-Q2E)/(E1Y+Q2E) ) | |
3231 | * radiated photon | |
3232 | PGAMM(1) = -PLEPT1(1) | |
3233 | PGAMM(2) = -PLEPT1(2) | |
3234 | PGAMM(3) = PLEPT0(3)-PLEPT1(3) | |
3235 | PGAMM(4) = PLEPT0(4)-PLEPT1(4) | |
3236 | * E_cm cut | |
3237 | PTOTGN = SQRT( (PGAMM(1)+PNUCL(1))**2+(PGAMM(2)+PNUCL(2))**2 | |
3238 | & +(PGAMM(3)+PNUCL(3))**2 ) | |
3239 | ETOTGN = PGAMM(4)+PNUCL(4) | |
3240 | ECMGN = (ETOTGN-PTOTGN)*(ETOTGN+PTOTGN) | |
3241 | IF (ECMGN.LT.0.1D0) GOTO 101 | |
3242 | ECMGN = SQRT(ECMGN) | |
3243 | IF ((ECMGN.LT.ECMIN).OR.(ECMGN.GT.ECMAX)) GOTO 101 | |
3244 | ||
3245 | * Lorentz-transformation into nucleon-rest system | |
3246 | CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3), | |
3247 | & PGAMM(1),PGAMM(2),PGAMM(3),PGAMM(4), | |
3248 | & PGTOT,PPG(1),PPG(2),PPG(3),PPG(4)) | |
3249 | CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3), | |
3250 | & PLEPT1(1),PLEPT1(2),PLEPT1(3),PLEPT1(4), | |
3251 | & PLTOT,PPL1(1),PPL1(2),PPL1(3),PPL1(4)) | |
3252 | * temporary checks.. | |
3253 | Q2TMP = ABS(PPG(4)**2-PGTOT**2) | |
3254 | IF (ABS(Q2-Q2TMP).GT.0.01D0) WRITE(LOUT,1001) Q2,Q2TMP | |
3255 | 1001 FORMAT(1X,'LAEVT: inconsistent kinematics (Q2,Q2TMP) ', | |
3256 | & 2F10.4) | |
3257 | ECMTMP = SQRT((PPG(4)+AAM(1)-PGTOT)*(PPG(4)+AAM(1)+PGTOT)) | |
3258 | IF (ABS(ECMGN-ECMTMP).GT.TINY10) WRITE(LOUT,1002) ECMGN,ECMTMP | |
3259 | 1002 FORMAT(1X,'LAEVT: inconsistent kinematics (ECMGN,ECMTMP) ', | |
3260 | & 2F10.2) | |
3261 | YYTMP = PPG(4)/PPL0(4) | |
3262 | IF (ABS(YY-YYTMP).GT.0.01D0) WRITE(LOUT,1005) YY,YYTMP | |
3263 | 1005 FORMAT(1X,'LAEVT: inconsistent kinematics (YY,YYTMP) ', | |
3264 | & 2F10.4) | |
3265 | ||
3266 | * lepton tagger (Lab) | |
3267 | THETA = ACOS( PPL1(3)/PLTOT ) | |
3268 | IF (PPL1(4).GT.ELMIN) THEN | |
3269 | IF ((THETA.LT.THMIN).OR.(THETA.GT.THMAX)) GOTO 101 | |
3270 | ENDIF | |
3271 | * photon energy-cut (Lab) | |
3272 | IF (PPG(4).LT.EGMIN) GOTO 101 | |
3273 | IF (PPG(4).GT.EGMAX) GOTO 101 | |
3274 | * x_Bj cut | |
3275 | XBJ = ABS(Q2/(1.876D0*PPG(4))) | |
3276 | IF (XBJ.LT.XBJMIN) GOTO 101 | |
3277 | ||
3278 | NC0 = NC0+1 | |
3279 | CALL DT_FILHGR( Q2,ONE,IHFLQ0,NC0) | |
3280 | CALL DT_FILHGR( YY,ONE,IHFLY0,NC0) | |
3281 | CALL DT_FILHGR( XBJ,ONE,IHFLX0,NC0) | |
3282 | CALL DT_FILHGR(PPG(4),ONE,IHFLU0,NC0) | |
3283 | CALL DT_FILHGR( ECMGN,ONE,IHFLE0,NC0) | |
3284 | ||
3285 | * rotation angles against z-axis | |
3286 | COD = PPG(3)/PGTOT | |
3287 | C SID = SQRT((ONE-COD)*(ONE+COD)) | |
3288 | PPT = SQRT(PPG(1)**2+PPG(2)**2) | |
3289 | SID = PPT/PGTOT | |
3290 | COF = ONE | |
3291 | SIF = ZERO | |
3292 | IF (PGTOT*SID.GT.TINY10) THEN | |
3293 | COF = PPG(1)/(SID*PGTOT) | |
3294 | SIF = PPG(2)/(SID*PGTOT) | |
3295 | ANORF = SQRT(COF*COF+SIF*SIF) | |
3296 | COF = COF/ANORF | |
3297 | SIF = SIF/ANORF | |
3298 | ENDIF | |
3299 | ||
3300 | IF (IXSTBL.EQ.0) THEN | |
3301 | * change to photon projectile | |
3302 | IJPROJ = 7 | |
3303 | * set virtuality | |
3304 | VIRT = Q2 | |
3305 | * re-initialize LTs with new kinematics | |
3306 | * !!PGAMM ist set in cms (ECMGN) along z | |
3307 | EPN = ZERO | |
3308 | PPN = ZERO | |
3309 | CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,ECMGN,0) | |
3310 | * force Lab-system | |
3311 | IFRAME = 1 | |
3312 | * get emulsion component if requested | |
3313 | IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0) | |
3314 | * convolute with cross section | |
3315 | CALL DT_SIGGAT(Q2LOW,EGNXX,STOTX,KKMAT) | |
3316 | CALL DT_SIGGAT(Q2,ECMGN,STOT,KKMAT) | |
3317 | IF (STOTX.LT.STOT) WRITE(LOUT,'(1X,A,/,6E12.3)') | |
3318 | & 'LAEVT: warning STOTX<STOT ! ',Q2LOW,EGNMAX,STOTX, | |
3319 | & Q2,ECMGN,STOT | |
3320 | IF (DT_RNDM(Q2)*STOTX.GT.STOT) GOTO 100 | |
3321 | NC1 = NC1+1 | |
3322 | CALL DT_FILHGR( Q2,ONE,IHFLQ1,NC1) | |
3323 | CALL DT_FILHGR( YY,ONE,IHFLY1,NC1) | |
3324 | CALL DT_FILHGR( XBJ,ONE,IHFLX1,NC1) | |
3325 | CALL DT_FILHGR(PPG(4),ONE,IHFLU1,NC1) | |
3326 | CALL DT_FILHGR( ECMGN,ONE,IHFLE1,NC1) | |
3327 | * composite targets only | |
3328 | KKMAT = -KKMAT | |
3329 | * sample this event | |
3330 | CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IJPROJ,EPN,KKMAT, | |
3331 | & IREJ) | |
3332 | * rotate momenta of final state particles back in photon-nucleon syst. | |
3333 | DO 4 I=NPOINT(4),NHKK | |
3334 | IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR. | |
3335 | & (ISTHKK(I).EQ.1001)) THEN | |
3336 | PX = PHKK(1,I) | |
3337 | PY = PHKK(2,I) | |
3338 | PZ = PHKK(3,I) | |
3339 | CALL DT_MYTRAN(1,PX,PY,PZ,COD,SID,COF,SIF, | |
3340 | & PHKK(1,I),PHKK(2,I),PHKK(3,I)) | |
3341 | ENDIF | |
3342 | 4 CONTINUE | |
3343 | ENDIF | |
3344 | ||
3345 | CALL DT_FILHGR( Q2,ONE,IHFLQ2,NC1) | |
3346 | CALL DT_FILHGR( YY,ONE,IHFLY2,NC1) | |
3347 | CALL DT_FILHGR( XBJ,ONE,IHFLX2,NC1) | |
3348 | CALL DT_FILHGR(PPG(4),ONE,IHFLU2,NC1) | |
3349 | CALL DT_FILHGR( ECMGN,ONE,IHFLE2,NC1) | |
3350 | ||
3351 | * dump this event to histograms | |
3352 | ||
3353 | CALL PHO_PHIST(2000,DUM) | |
3354 | ||
3355 | 2 CONTINUE | |
3356 | ||
3357 | WGY = ALPHEM/TWOPI*WGHMAX*DBLE(ITRY)/DBLE(ITRW) | |
3358 | WGY = WGY*LOG(YMAX/YMIN) | |
3359 | WEIGHT = WGY*SIGMAX*DBLE(NEVTS)/DBLE(ITRY) | |
3360 | ||
3361 | C HEADER = ' LAEVT: Q^2 distribution 0' | |
3362 | C CALL DT_OUTHGR(IHFLQ0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3363 | C HEADER = ' LAEVT: Q^2 distribution 1' | |
3364 | C CALL DT_OUTHGR(IHFLQ1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3365 | C HEADER = ' LAEVT: Q^2 distribution 2' | |
3366 | C CALL DT_OUTHGR(IHFLQ2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3367 | C HEADER = ' LAEVT: y distribution 0' | |
3368 | C CALL DT_OUTHGR(IHFLY0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3369 | C HEADER = ' LAEVT: y distribution 1' | |
3370 | C CALL DT_OUTHGR(IHFLY1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3371 | C HEADER = ' LAEVT: y distribution 2' | |
3372 | C CALL DT_OUTHGR(IHFLY2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3373 | C HEADER = ' LAEVT: x distribution 0' | |
3374 | C CALL DT_OUTHGR(IHFLX0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3375 | C HEADER = ' LAEVT: x distribution 1' | |
3376 | C CALL DT_OUTHGR(IHFLX1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3377 | C HEADER = ' LAEVT: x distribution 2' | |
3378 | C CALL DT_OUTHGR(IHFLX2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3379 | C HEADER = ' LAEVT: E_g distribution 0' | |
3380 | C CALL DT_OUTHGR(IHFLU0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3381 | C HEADER = ' LAEVT: E_g distribution 1' | |
3382 | C CALL DT_OUTHGR(IHFLU1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3383 | C HEADER = ' LAEVT: E_g distribution 2' | |
3384 | C CALL DT_OUTHGR(IHFLU2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3385 | C HEADER = ' LAEVT: E_c distribution 0' | |
3386 | C CALL DT_OUTHGR(IHFLE0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3387 | C HEADER = ' LAEVT: E_c distribution 1' | |
3388 | C CALL DT_OUTHGR(IHFLE1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3389 | C HEADER = ' LAEVT: E_c distribution 2' | |
3390 | C CALL DT_OUTHGR(IHFLE2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3391 | ||
3392 | * print run-statistics and histograms to output-unit 6 | |
3393 | ||
3394 | CALL PHO_PHIST(3000,DUM) | |
3395 | ||
3396 | IF (IXSTBL.EQ.0) CALL DT_STATIS(2) | |
3397 | ||
3398 | RETURN | |
3399 | END | |
3400 | ||
3401 | *$ CREATE DT_DTUINI.FOR | |
3402 | *COPY DT_DTUINI | |
3403 | * | |
3404 | *===dtuini=============================================================* | |
3405 | * | |
3406 | SUBROUTINE DT_DTUINI(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR, | |
3407 | & IDP,IEMU) | |
3408 | ||
3409 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
3410 | SAVE | |
3411 | ||
3412 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
3413 | ||
3414 | * emulsion treatment | |
3415 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
3416 | & NCOMPO,IEMUL | |
3417 | ||
3418 | * Glauber formalism: flags and parameters for statistics | |
3419 | LOGICAL LPROD | |
3420 | CHARACTER*8 CGLB | |
3421 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD | |
3422 | ||
3423 | CALL DT_INIT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,IGLAU) | |
3424 | CALL DT_STATIS(1) | |
3425 | ||
3426 | CALL PHO_PHIST(1000,DUM) | |
3427 | ||
3428 | IF (NCOMPO.LE.0) THEN | |
3429 | CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU) | |
3430 | ELSE | |
3431 | DO 1 I=1,NCOMPO | |
3432 | CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0) | |
3433 | 1 CONTINUE | |
3434 | ENDIF | |
3435 | IF (IOGLB.NE.100) CALL DT_SIGEMU | |
3436 | IEMU = IEMUL | |
3437 | ||
3438 | RETURN | |
3439 | END | |
3440 | ||
3441 | *$ CREATE DT_DTUOUT.FOR | |
3442 | *COPY DT_DTUOUT | |
3443 | * | |
3444 | *===dtuout=============================================================* | |
3445 | * | |
3446 | SUBROUTINE DT_DTUOUT | |
3447 | ||
3448 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
3449 | SAVE | |
3450 | ||
3451 | CALL PHO_PHIST(3000,DUM) | |
3452 | ||
3453 | CALL DT_STATIS(2) | |
3454 | ||
3455 | RETURN | |
3456 | END | |
3457 | ||
3458 | *$ CREATE DT_BEAMPR.FOR | |
3459 | *COPY DT_BEAMPR | |
3460 | * | |
3461 | *===beampr=============================================================* | |
3462 | * | |
3463 | SUBROUTINE DT_BEAMPR(WHAT,PLAB,MODE) | |
3464 | ||
3465 | ************************************************************************ | |
3466 | * Initialization of event generation * | |
3467 | * This version dated 7.4.98 is written by S. Roesler. * | |
3468 | ************************************************************************ | |
3469 | ||
3470 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
3471 | SAVE | |
3472 | ||
3473 | PARAMETER ( LINP = 10 , | |
3474 | & LOUT = 6 , | |
3475 | & LDAT = 9 ) | |
3476 | ||
3477 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10) | |
3478 | PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0) | |
3479 | ||
3480 | LOGICAL LBEAM | |
3481 | ||
3482 | * event history | |
3483 | ||
3484 | PARAMETER (NMXHKK=200000) | |
3485 | ||
3486 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
3487 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
3488 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
3489 | ||
3490 | * extended event history | |
3491 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
3492 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
3493 | & IHIST(2,NMXHKK) | |
3494 | ||
3495 | * properties of interacting particles | |
3496 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
3497 | ||
3498 | * particle properties (BAMJET index convention) | |
3499 | CHARACTER*8 ANAME | |
3500 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
3501 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
3502 | ||
3503 | * beam momenta | |
3504 | COMMON /DTBEAM/ P1(4),P2(4) | |
3505 | ||
3506 | C DIMENSION WHAT(6),P1(4),P2(4),P1CMS(4),P2CMS(4) | |
3507 | DIMENSION WHAT(6),P1CMS(4),P2CMS(4) | |
3508 | ||
3509 | DATA LBEAM /.FALSE./ | |
3510 | ||
3511 | GOTO (1,2) MODE | |
3512 | ||
3513 | 1 CONTINUE | |
3514 | ||
3515 | E1 = WHAT(1) | |
3516 | IF (E1.LT.ZERO) E1 = DBLE(IPZ)/DBLE(IP)*ABS(WHAT(1)) | |
3517 | E2 = WHAT(2) | |
3518 | IF (E2.LT.ZERO) E2 = DBLE(ITZ)/DBLE(IT)*ABS(WHAT(2)) | |
3519 | PP1 = SQRT( (E1+AAM(IJPROJ))*(E1-AAM(IJPROJ)) ) | |
3520 | PP2 = SQRT( (E2+AAM(IJTARG))*(E2-AAM(IJTARG)) ) | |
3521 | TH = 1.D-6*WHAT(3)/2.D0 | |
3522 | PH = WHAT(4)*BOG | |
3523 | P1(1) = PP1*SIN(TH)*COS(PH) | |
3524 | P1(2) = PP1*SIN(TH)*SIN(PH) | |
3525 | P1(3) = PP1*COS(TH) | |
3526 | P1(4) = E1 | |
3527 | P2(1) = PP2*SIN(TH)*COS(PH) | |
3528 | P2(2) = PP2*SIN(TH)*SIN(PH) | |
3529 | P2(3) = -PP2*COS(TH) | |
3530 | P2(4) = E2 | |
3531 | ECM = SQRT( (P1(4)+P2(4))**2-(P1(1)+P2(1))**2-(P1(2)+P2(2))**2 | |
3532 | & -(P1(3)+P2(3))**2 ) | |
3533 | ELAB = (ECM**2-AAM(IJPROJ)**2-AAM(IJTARG)**2)/(2.0D0*AAM(IJTARG)) | |
3534 | PLAB = SQRT( (ELAB+AAM(IJPROJ))*(ELAB-AAM(IJPROJ)) ) | |
3535 | BGX = (P1(1)+P2(1))/ECM | |
3536 | BGY = (P1(2)+P2(2))/ECM | |
3537 | BGZ = (P1(3)+P2(3))/ECM | |
3538 | BGE = (P1(4)+P2(4))/ECM | |
3539 | CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P1(1),P1(2),P1(3),P1(4), | |
3540 | & P1TOT,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4)) | |
3541 | CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P2(1),P2(2),P2(3),P2(4), | |
3542 | & P2TOT,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4)) | |
3543 | COD = P1CMS(3)/P1TOT | |
3544 | C SID = SQRT((ONE-COD)*(ONE+COD)) | |
3545 | PPT = SQRT(P1CMS(1)**2+P1CMS(2)**2) | |
3546 | SID = PPT/P1TOT | |
3547 | COF = ONE | |
3548 | SIF = ZERO | |
3549 | IF (P1TOT*SID.GT.TINY10) THEN | |
3550 | COF = P1CMS(1)/(SID*P1TOT) | |
3551 | SIF = P1CMS(2)/(SID*P1TOT) | |
3552 | ANORF = SQRT(COF*COF+SIF*SIF) | |
3553 | COF = COF/ANORF | |
3554 | SIF = SIF/ANORF | |
3555 | ENDIF | |
3556 | **check | |
3557 | C WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4) | |
3558 | C WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4) | |
3559 | C WRITE(LOUT,'(5E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),P1TOT | |
3560 | C WRITE(LOUT,'(5E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),P2TOT | |
3561 | C PAX = ZERO | |
3562 | C PAY = ZERO | |
3563 | C PAZ = P1TOT | |
3564 | C PAE = SQRT(AAM(IJPROJ)**2+PAZ**2) | |
3565 | C PBX = ZERO | |
3566 | C PBY = ZERO | |
3567 | C PBZ = -P2TOT | |
3568 | C PBE = SQRT(AAM(IJTARG)**2+PBZ**2) | |
3569 | C WRITE(LOUT,'(4E15.4)') PAX,PAY,PAZ,PAE | |
3570 | C WRITE(LOUT,'(4E15.4)') PBX,PBY,PBZ,PBE | |
3571 | C CALL DT_MYTRAN(1,PAX,PAY,PAZ,COD,SID,COF,SIF, | |
3572 | C & P1CMS(1),P1CMS(2),P1CMS(3)) | |
3573 | C CALL DT_MYTRAN(1,PBX,PBY,PBZ,COD,SID,COF,SIF, | |
3574 | C & P2CMS(1),P2CMS(2),P2CMS(3)) | |
3575 | C WRITE(LOUT,'(4E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4) | |
3576 | C WRITE(LOUT,'(4E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4) | |
3577 | C CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4), | |
3578 | C & P1TOT,P1(1),P1(2),P1(3),P1(4)) | |
3579 | C CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4), | |
3580 | C & P2TOT,P2(1),P2(2),P2(3),P2(4)) | |
3581 | C WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4) | |
3582 | C WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4) | |
3583 | C STOP | |
3584 | ** | |
3585 | ||
3586 | LBEAM = .TRUE. | |
3587 | ||
3588 | RETURN | |
3589 | ||
3590 | 2 CONTINUE | |
3591 | ||
3592 | IF (LBEAM) THEN | |
3593 | IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN | |
3594 | DO 20 I=NPOINT(4),NHKK | |
3595 | IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR. | |
3596 | & (ISTHKK(I).EQ.1001)) THEN | |
3597 | CALL DT_MYTRAN(1,PHKK(1,I),PHKK(2,I),PHKK(3,I), | |
3598 | & COD,SID,COF,SIF,PXCMS,PYCMS,PZCMS) | |
3599 | PECMS = PHKK(4,I) | |
3600 | CALL DT_DALTRA(BGE,BGX,BGY,BGZ,PXCMS,PYCMS,PZCMS,PECMS, | |
3601 | & PTOT,PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I)) | |
3602 | ENDIF | |
3603 | 20 CONTINUE | |
3604 | ELSE | |
3605 | MODE = -1 | |
3606 | ENDIF | |
3607 | ||
3608 | RETURN | |
3609 | END | |
3610 | ||
3611 | *$ CREATE DT_REJUCO.FOR | |
3612 | *COPY DT_REJUCO | |
3613 | * | |
3614 | *===rejuco=============================================================* | |
3615 | * | |
3616 | SUBROUTINE DT_REJUCO(MODE,IREJ) | |
3617 | ||
3618 | ************************************************************************ | |
3619 | * REJection of Unphysical COnfigurations * | |
3620 | * MODE = 1 rejection of particles with unphysically large energy * | |
3621 | * * | |
3622 | * This version dated 27.12.2006 is written by S. Roesler. * | |
3623 | ************************************************************************ | |
3624 | ||
3625 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
3626 | SAVE | |
3627 | ||
3628 | PARAMETER ( LINP = 10 , | |
3629 | & LOUT = 6 , | |
3630 | & LDAT = 9 ) | |
3631 | ||
3632 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10) | |
3633 | PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0) | |
3634 | ||
3635 | * maximum x_cms of final state particle | |
3636 | PARAMETER (XCMSMX = 1.4D0) | |
3637 | ||
3638 | * event history | |
3639 | ||
3640 | PARAMETER (NMXHKK=200000) | |
3641 | ||
3642 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
3643 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
3644 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
3645 | ||
3646 | * extended event history | |
3647 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
3648 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
3649 | & IHIST(2,NMXHKK) | |
3650 | ||
3651 | * Lorentz-parameters of the current interaction | |
3652 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
3653 | & UMO,PPCM,EPROJ,PPROJ | |
3654 | ||
3655 | IREJ = 0 | |
3656 | ||
3657 | IF (MODE.EQ.1) THEN | |
3658 | IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN | |
3659 | ECMHLF = UMO/2.0D0 | |
3660 | DO 10 I=NPOINT(4),NHKK | |
3661 | IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDHKK(I).NE.80000)) THEN | |
3662 | XCMS = ABS(PHKK(4,I))/ECMHLF | |
3663 | IF (XCMS.GT.XCMSMX) GOTO 9999 | |
3664 | ENDIF | |
3665 | 10 CONTINUE | |
3666 | ENDIF | |
3667 | ||
3668 | RETURN | |
3669 | 9999 CONTINUE | |
3670 | IREJ = 1 | |
3671 | RETURN | |
3672 | END | |
3673 | *$ CREATE DT_EVENTB.FOR | |
3674 | *COPY DT_EVENTB | |
3675 | * | |
3676 | *===eventb=============================================================* | |
3677 | * | |
3678 | SUBROUTINE DT_EVENTB(NCSY,IREJ) | |
3679 | ||
3680 | ************************************************************************ | |
3681 | * Treatment of nucleon-nucleon interactions with full two-component * | |
3682 | * Dual Parton Model. * | |
3683 | * NCSY number of nucleon-nucleon interactions * | |
3684 | * IREJ rejection flag * | |
3685 | * This version dated 14.01.2000 is written by S. Roesler * | |
3686 | ************************************************************************ | |
3687 | ||
3688 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
3689 | SAVE | |
3690 | ||
3691 | PARAMETER ( LINP = 10 , | |
3692 | & LOUT = 6 , | |
3693 | & LDAT = 9 ) | |
3694 | ||
3695 | PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0) | |
3696 | ||
3697 | * event history | |
3698 | ||
3699 | PARAMETER (NMXHKK=200000) | |
3700 | ||
3701 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
3702 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
3703 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
3704 | ||
3705 | * extended event history | |
3706 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
3707 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
3708 | & IHIST(2,NMXHKK) | |
3709 | *! uncomment this line for internal phojet-fragmentation | |
3710 | C #include "dtu_dtevtp.inc" | |
3711 | ||
3712 | * particle properties (BAMJET index convention) | |
3713 | CHARACTER*8 ANAME | |
3714 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
3715 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
3716 | ||
3717 | * flags for input different options | |
3718 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
3719 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
3720 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
3721 | ||
3722 | * rejection counter | |
3723 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
3724 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
3725 | & IREXCI(3),IRDIFF(2),IRINC | |
3726 | ||
3727 | * properties of interacting particles | |
3728 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
3729 | ||
3730 | * properties of photon/lepton projectiles | |
3731 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC | |
3732 | ||
3733 | * various options for treatment of partons (DTUNUC 1.x) | |
3734 | * (chain recombination, Cronin,..) | |
3735 | LOGICAL LCO2CR,LINTPT | |
3736 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, | |
3737 | & LCO2CR,LINTPT | |
3738 | ||
3739 | * statistics | |
3740 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
3741 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
3742 | & ICEVTG(8,0:30) | |
3743 | ||
3744 | * DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem | |
3745 | COMMON /DTLTSU/ BGX,BGY,BGZ,GAM | |
3746 | ||
3747 | * Glauber formalism: collision properties | |
3748 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, | |
3749 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC | |
3750 | ||
3751 | * flags for diffractive interactions (DTUNUC 1.x) | |
3752 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF | |
3753 | ||
3754 | * statistics: double-Pomeron exchange | |
3755 | COMMON /DTFLG2/ INTFLG,IPOPO | |
3756 | ||
3757 | * flags for particle decays | |
3758 | COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20), | |
3759 | & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20), | |
3760 | & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0 | |
3761 | ||
3762 | * nucleon-nucleon event-generator | |
3763 | CHARACTER*8 CMODEL | |
3764 | LOGICAL LPHOIN | |
3765 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
3766 | ||
3767 | C nucleon-nucleus / nucleus-nucleus interface to DPMJET | |
3768 | INTEGER IDEQP,IDEQB,IHFLD,IHFLS | |
3769 | DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB | |
3770 | COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB, | |
3771 | & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2) | |
3772 | ||
3773 | C model switches and parameters | |
3774 | CHARACTER*8 MDLNA | |
3775 | INTEGER ISWMDL,IPAMDL | |
3776 | DOUBLE PRECISION PARMDL | |
3777 | COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400) | |
3778 | ||
3779 | C initial state parton radiation (internal part) | |
3780 | INTEGER MXISR3,MXISR4 | |
3781 | PARAMETER ( MXISR3 = 50, MXISR4 = 100 ) | |
3782 | INTEGER IFL1,IFL2,IBRA,IFANO,ISH,NACC | |
3783 | DOUBLE PRECISION Q2SH,PT2SH,XPSH,ZPSH,THSH,SHAT | |
3784 | COMMON /POINT6/ Q2SH(2,MXISR3),PT2SH(2,MXISR3),XPSH(2,MXISR3), | |
3785 | & ZPSH(2,MXISR3),THSH(2,MXISR3),SHAT(MXISR3), | |
3786 | & IFL1(2,MXISR3),IFL2(2,MXISR3), | |
3787 | & IBRA(2,MXISR4),IFANO(2),ISH(2),NACC | |
3788 | ||
3789 | C event debugging information | |
3790 | INTEGER NMAXD | |
3791 | PARAMETER (NMAXD=100) | |
3792 | INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO, | |
3793 | & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD | |
3794 | COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG, | |
3795 | & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD | |
3796 | ||
3797 | C general process information | |
3798 | INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON | |
3799 | COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4) | |
3800 | ||
3801 | DIMENSION PP(4),PT(4),PTOT(4),PP1(4),PP2(4),PT1(4),PT2(4), | |
3802 | & PPNN(4),PTNN(4),PTOTNN(4),PPSUB(4),PTSUB(4), | |
3803 | & PPTCMS(4),PTTCMS(4),PPTMP(4),PTTMP(4), | |
3804 | & KPRON(15),ISINGL(2000) | |
3805 | ||
3806 | * initial values for max. number of phojet scatterings and dtunuc chains | |
3807 | * to be fragmented with one pyexec call | |
3808 | DATA MXPHFR,MXDTFR /10,100/ | |
3809 | ||
3810 | IREJ = 0 | |
3811 | * pointer to first parton of the first chain in dtevt common | |
3812 | NPOINT(3) = NHKK+1 | |
3813 | * special flag for double-Pomeron statistics | |
3814 | IPOPO = 1 | |
3815 | * counter for low-mass (DTUNUC) interactions | |
3816 | NDTUSC = 0 | |
3817 | * counter for interactions treated by PHOJET | |
3818 | NPHOSC = 0 | |
3819 | ||
3820 | * scan interactions for single nucleon-nucleon interactions | |
3821 | * (this has to be checked here because Cronin modifies parton momenta) | |
3822 | NC = NPOINT(2) | |
3823 | IF (NCSY.GT.2000) STOP ' DT_EVENTB: NCSY > 2000 ! ' | |
3824 | DO 8 I=1,NCSY | |
3825 | ISINGL(I) = 0 | |
3826 | MOP = JMOHKK(1,NC) | |
3827 | MOT = JMOHKK(1,NC+1) | |
3828 | DIFF1 = ABS(PHKK(4,MOP)-PHKK(4, NC)-PHKK(4,NC+2)) | |
3829 | DIFF2 = ABS(PHKK(4,MOT)-PHKK(4,NC+1)-PHKK(4,NC+3)) | |
3830 | IF ((DIFF1.LT.TINY10).AND.(DIFF2.LT.TINY10)) ISINGL(I) = 1 | |
3831 | NC = NC+4 | |
3832 | 8 CONTINUE | |
3833 | ||
3834 | * multiple scattering of chain ends | |
3835 | IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1) | |
3836 | IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2) | |
3837 | ||
3838 | * switch to PHOJET-settings for JETSET parameter | |
3839 | CALL DT_INITJS(1) | |
3840 | ||
3841 | * loop over nucleon-nucleon interaction | |
3842 | NC = NPOINT(2) | |
3843 | DO 2 I=1,NCSY | |
3844 | * | |
3845 | * pick up one nucleon-nucleon interaction from DTEVT1 | |
3846 | * ppnn / ptnn - momenta of the interacting nucleons (cms) | |
3847 | * ptotnn - total momentum of the interacting nucleons (cms) | |
3848 | * pp1,2 / pt1,2 - momenta of the four partons | |
3849 | * pp / pt - total momenta of the proj / targ partons | |
3850 | * ptot - total momentum of the four partons | |
3851 | MOP = JMOHKK(1,NC) | |
3852 | MOT = JMOHKK(1,NC+1) | |
3853 | DO 3 K=1,4 | |
3854 | PPNN(K) = PHKK(K,MOP) | |
3855 | PTNN(K) = PHKK(K,MOT) | |
3856 | PTOTNN(K) = PPNN(K)+PTNN(K) | |
3857 | PP1(K) = PHKK(K,NC) | |
3858 | PT1(K) = PHKK(K,NC+1) | |
3859 | PP2(K) = PHKK(K,NC+2) | |
3860 | PT2(K) = PHKK(K,NC+3) | |
3861 | PP(K) = PP1(K)+PP2(K) | |
3862 | PT(K) = PT1(K)+PT2(K) | |
3863 | PTOT(K) = PP(K)+PT(K) | |
3864 | 3 CONTINUE | |
3865 | * | |
3866 | *----------------------------------------------------------------------- | |
3867 | * this is a complete nucleon-nucleon interaction | |
3868 | * | |
3869 | IF (ISINGL(I).EQ.1) THEN | |
3870 | * | |
3871 | * initialize PHOJET-variables for remnant/valence-partons | |
3872 | IHFLD(1,1) = 0 | |
3873 | IHFLD(1,2) = 0 | |
3874 | IHFLD(2,1) = 0 | |
3875 | IHFLD(2,2) = 0 | |
3876 | IHFLS(1) = 1 | |
3877 | IHFLS(2) = 1 | |
3878 | * save current settings of PHOJET process and min. bias flags | |
3879 | DO 9 K=1,11 | |
3880 | KPRON(K) = IPRON(K,1) | |
3881 | 9 CONTINUE | |
3882 | ISWSAV = ISWMDL(2) | |
3883 | * | |
3884 | * check if forced sampling of diffractive interaction requested | |
3885 | IF (ISINGD.LT.-1) THEN | |
3886 | DO 90 K=1,11 | |
3887 | IPRON(K,1) = 0 | |
3888 | 90 CONTINUE | |
3889 | IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-3)) IPRON(5,1) = 1 | |
3890 | IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-4)) IPRON(6,1) = 1 | |
3891 | IF (ISINGD.EQ.-5) IPRON(4,1) = 1 | |
3892 | ENDIF | |
3893 | * | |
3894 | * for photons: a direct/anomalous interaction is not sampled | |
3895 | * in PHOJET but already in Glauber-formalism. Here we check if such | |
3896 | * an interaction is requested | |
3897 | IF (IJPROJ.EQ.7) THEN | |
3898 | * first switch off direct interactions | |
3899 | IPRON(8,1) = 0 | |
3900 | * this is a direct interactions | |
3901 | IF (IDIREC.EQ.1) THEN | |
3902 | DO 12 K=1,11 | |
3903 | IPRON(K,1) = 0 | |
3904 | 12 CONTINUE | |
3905 | IPRON(8,1) = 1 | |
3906 | * this is an anomalous interactions | |
3907 | * (iswmdl(2) = 0 only hard int. generated ( = 1 min. bias) ) | |
3908 | ELSEIF (IDIREC.EQ.2) THEN | |
3909 | ISWMDL(2) = 0 | |
3910 | ENDIF | |
3911 | ELSE | |
3912 | IF (IDIREC.NE.0) STOP ' DT_EVENTB: IDIREC > 0 ! ' | |
3913 | ENDIF | |
3914 | * | |
3915 | * make sure that total momenta of partons, pp and pt, are on mass | |
3916 | * shell (Cronin may have srewed this up..) | |
3917 | CALL DT_MASHEL(PP,PT,PHKK(5,MOP),PHKK(5,MOT),PPNN,PTNN,IR1) | |
3918 | IF (IR1.NE.0) THEN | |
3919 | IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A)') | |
3920 | & 'EVENTB: mass shell correction rejected' | |
3921 | GOTO 9999 | |
3922 | ENDIF | |
3923 | * | |
3924 | * initialize the incoming particles in PHOJET | |
3925 | IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN | |
3926 | ||
3927 | CALL PHO_SETPAR(1,22,0,VIRT) | |
3928 | ||
3929 | ELSE | |
3930 | ||
3931 | CALL PHO_SETPAR(1,IDHKK(MOP),0,ZERO) | |
3932 | ||
3933 | ENDIF | |
3934 | ||
3935 | CALL PHO_SETPAR(2,IDHKK(MOT),0,ZERO) | |
3936 | ||
3937 | * | |
3938 | * initialize rejection loop counter for anomalous processes | |
3939 | IRJANO = 0 | |
3940 | 800 CONTINUE | |
3941 | IRJANO = IRJANO+1 | |
3942 | * | |
3943 | * temporary fix for ifano problem | |
3944 | IFANO(1) = 0 | |
3945 | IFANO(2) = 0 | |
3946 | * | |
3947 | * generate complete hadron/nucleon/photon-nucleon event with PHOJET | |
3948 | ||
3949 | CALL PHO_EVENT(2,PPNN,PTNN,DUM,IREJ1) | |
3950 | ||
3951 | * | |
3952 | * for photons: special consistency check for anomalous interactions | |
3953 | IF (IJPROJ.EQ.7) THEN | |
3954 | IF (IRJANO.LT.30) THEN | |
3955 | IF (IFANO(1).NE.0) THEN | |
3956 | * here, an anomalous interaction was generated. Check if it | |
3957 | * was also requested. Otherwise reject this event. | |
3958 | IF (IDIREC.EQ.0) GOTO 800 | |
3959 | ELSE | |
3960 | * here, an anomalous interaction was not generated. Check if it | |
3961 | * was requested in which case we need to reject this event. | |
3962 | IF (IDIREC.EQ.2) GOTO 800 | |
3963 | ENDIF | |
3964 | ELSE | |
3965 | WRITE(LOUT,*) ' DT_EVENTB: Warning! IRJANO > 30 ', | |
3966 | & IRJANO,IDIREC,NEVHKK | |
3967 | ENDIF | |
3968 | ENDIF | |
3969 | * | |
3970 | * copy back original settings of PHOJET process and min. bias flags | |
3971 | DO 10 K=1,11 | |
3972 | IPRON(K,1) = KPRON(K) | |
3973 | 10 CONTINUE | |
3974 | ISWMDL(2) = ISWSAV | |
3975 | * | |
3976 | * check if PHOJET has rejected this event | |
3977 | IF (IREJ1.NE.0) THEN | |
3978 | C IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)') | |
3979 | WRITE(LOUT,'(1X,A,I4)') | |
3980 | & 'EVENTB: chain system rejected',IDIREC | |
3981 | ||
3982 | CALL PHO_PREVNT(0) | |
3983 | ||
3984 | GOTO 9999 | |
3985 | ENDIF | |
3986 | * | |
3987 | * copy partons and strings from PHOJET common back into DTEVT for | |
3988 | * external fragmentation | |
3989 | MO1 = NC | |
3990 | MO2 = NC+3 | |
3991 | *! uncomment this line for internal phojet-fragmentation | |
3992 | C CALL DT_GETFSP(MO1,MO2,PPNN,PTNN,-1) | |
3993 | NPHOSC = NPHOSC+1 | |
3994 | CALL DT_GETPJE(MO1,MO2,PPNN,PTNN,-1,NPHOSC,IREJ1) | |
3995 | IF (IREJ1.NE.0) THEN | |
3996 | IF (IOULEV(1).GT.0) | |
3997 | & WRITE(LOUT,'(1X,A,I4)') 'EVENTB: chain system rejected 1' | |
3998 | GOTO 9999 | |
3999 | ENDIF | |
4000 | * | |
4001 | * update statistics counter | |
4002 | ICEVTG(IDCH(NC),29) = ICEVTG(IDCH(NC),29)+1 | |
4003 | * | |
4004 | *----------------------------------------------------------------------- | |
4005 | * this interaction involves "remnants" | |
4006 | * | |
4007 | ELSE | |
4008 | * | |
4009 | * total mass of this system | |
4010 | PPTOT = SQRT(PTOT(1)**2+PTOT(2)**2+PTOT(3)**2) | |
4011 | AMTOT2 = (PTOT(4)-PPTOT)*(PTOT(4)+PPTOT) | |
4012 | IF (AMTOT2.LT.ZERO) THEN | |
4013 | AMTOT = ZERO | |
4014 | ELSE | |
4015 | AMTOT = SQRT(AMTOT2) | |
4016 | ENDIF | |
4017 | * | |
4018 | * systems with masses larger than elojet are treated with PHOJET | |
4019 | IF (AMTOT.GT.ELOJET) THEN | |
4020 | * | |
4021 | * initialize PHOJET-variables for remnant/valence-partons | |
4022 | * projectile parton flavors and valence flag | |
4023 | IHFLD(1,1) = IDHKK(NC) | |
4024 | IHFLD(1,2) = IDHKK(NC+2) | |
4025 | IHFLS(1) = 0 | |
4026 | IF ((IDCH(NC).EQ.6).OR.(IDCH(NC).EQ.7) | |
4027 | & .OR.(IDCH(NC).EQ.8)) IHFLS(1) = 1 | |
4028 | * target parton flavors and valence flag | |
4029 | IHFLD(2,1) = IDHKK(NC+1) | |
4030 | IHFLD(2,2) = IDHKK(NC+3) | |
4031 | IHFLS(2) = 0 | |
4032 | IF ((IDCH(NC).EQ.4).OR.(IDCH(NC).EQ.5) | |
4033 | & .OR.(IDCH(NC).EQ.8)) IHFLS(2) = 1 | |
4034 | * flag signalizing PHOJET how to treat the remnant: | |
4035 | * iremn = -1 sea-quark remnant: PHOJET takes flavors from ihfld | |
4036 | * iremn > -1 valence remnant: PHOJET assumes flavors according | |
4037 | * to mother particle | |
4038 | IREMN1 = IHFLS(1)-1 | |
4039 | IREMN2 = IHFLS(2)-1 | |
4040 | * | |
4041 | * initialize the incoming particles in PHOJET | |
4042 | IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN | |
4043 | ||
4044 | CALL PHO_SETPAR(1,22,IREMN1,VIRT) | |
4045 | ||
4046 | ELSE | |
4047 | ||
4048 | CALL PHO_SETPAR(1,IDHKK(MOP),IREMN1,ZERO) | |
4049 | ||
4050 | ENDIF | |
4051 | ||
4052 | CALL PHO_SETPAR(2,IDHKK(MOT),IREMN2,ZERO) | |
4053 | ||
4054 | * | |
4055 | * calculate Lorentz parameter of the nucleon-nucleon cm-system | |
4056 | PPTOTN = SQRT(PTOTNN(1)**2+PTOTNN(2)**2+PTOTNN(3)**2) | |
4057 | AMNN = SQRT( (PTOTNN(4)-PPTOTN)*(PTOTNN(4)+PPTOTN) ) | |
4058 | BGX = PTOTNN(1)/AMNN | |
4059 | BGY = PTOTNN(2)/AMNN | |
4060 | BGZ = PTOTNN(3)/AMNN | |
4061 | GAM = PTOTNN(4)/AMNN | |
4062 | * transform interacting nucleons into nucleon-nucleon cm-system | |
4063 | CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ, | |
4064 | & PPNN(1),PPNN(2),PPNN(3),PPNN(4),PPCMS, | |
4065 | & PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4)) | |
4066 | CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ, | |
4067 | & PTNN(1),PTNN(2),PTNN(3),PTNN(4),PTCMS, | |
4068 | & PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4)) | |
4069 | * transform (total) momenta of the proj and targ partons into | |
4070 | * nucleon-nucleon cm-system | |
4071 | CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ, | |
4072 | & PP(1),PP(2),PP(3),PP(4), | |
4073 | & PPTSUB,PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4)) | |
4074 | CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ, | |
4075 | & PT(1),PT(2),PT(3),PT(4), | |
4076 | & PTTSUB,PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4)) | |
4077 | * energy fractions of the proj and targ partons | |
4078 | XPSUB = MIN(PPSUB(4)/PPTCMS(4),ONE) | |
4079 | XTSUB = MIN(PTSUB(4)/PTTCMS(4),ONE) | |
4080 | *** | |
4081 | * testprint | |
4082 | c PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 + | |
4083 | c & (PPTCMS(2)+PTTCMS(2))**2 + | |
4084 | c & (PPTCMS(3)+PTTCMS(3))**2 ) | |
4085 | c EOLDCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) * | |
4086 | c & (PPTCMS(4)+PTTCMS(4)+PTOTCM) ) | |
4087 | c PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 + | |
4088 | c & (PPSUB(2)+PTSUB(2))**2 + | |
4089 | c & (PPSUB(3)+PTSUB(3))**2 ) | |
4090 | c EOLDSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) * | |
4091 | c & (PPSUB(4)+PTSUB(4)+PTOTSU) ) | |
4092 | *** | |
4093 | * | |
4094 | * save current settings of PHOJET process and min. bias flags | |
4095 | DO 7 K=1,11 | |
4096 | KPRON(K) = IPRON(K,1) | |
4097 | 7 CONTINUE | |
4098 | * disallow direct photon int. (does not make sense here anyway) | |
4099 | IPRON(8,1) = 0 | |
4100 | * disallow double pomeron processes (due to technical problems | |
4101 | * in PHOJET, needs to be solved sometime) | |
4102 | IPRON(4,1) = 0 | |
4103 | * disallow diffraction for sea-diquarks | |
4104 | IF ((IABS(IHFLD(1,1)).GT.1100).AND. | |
4105 | & (IABS(IHFLD(1,2)).GT.1100)) THEN | |
4106 | IPRON(3,1) = 0 | |
4107 | IPRON(6,1) = 0 | |
4108 | ENDIF | |
4109 | IF ((IABS(IHFLD(2,1)).GT.1100).AND. | |
4110 | & (IABS(IHFLD(2,2)).GT.1100)) THEN | |
4111 | IPRON(3,1) = 0 | |
4112 | IPRON(5,1) = 0 | |
4113 | ENDIF | |
4114 | * | |
4115 | * we need massless partons: transform them on mass shell | |
4116 | XMP = ZERO | |
4117 | XMT = ZERO | |
4118 | DO 6 K=1,4 | |
4119 | PPTMP(K) = PPSUB(K) | |
4120 | PTTMP(K) = PTSUB(K) | |
4121 | 6 CONTINUE | |
4122 | CALL DT_MASHEL(PPTMP,PTTMP,XMP,XMT,PPSUB,PTSUB,IREJ1) | |
4123 | PPSUTO = SQRT(PPSUB(1)**2+PPSUB(2)**2+PPSUB(3)**2) | |
4124 | PTSUTO = SQRT(PTSUB(1)**2+PTSUB(2)**2+PTSUB(3)**2) | |
4125 | PSUTOT = SQRT((PPSUB(1)+PTSUB(1))**2+ | |
4126 | & (PPSUB(2)+PTSUB(2))**2+(PPSUB(3)+PTSUB(3))**2) | |
4127 | * total energy of the subsysten after mass transformation | |
4128 | * (should be the same as before..) | |
4129 | SECM = SQRT( (PPSUB(4)+PTSUB(4)-PSUTOT)* | |
4130 | & (PPSUB(4)+PTSUB(4)+PSUTOT) ) | |
4131 | * | |
4132 | * after mass shell transformation the x_sub - relation has to be | |
4133 | * corrected. We therefore create "pseudo-momenta" of mother-nucleons. | |
4134 | * | |
4135 | * The old version was to scale based on the original x_sub and the | |
4136 | * 4-momenta of the subsystem. At very high energy this could lead to | |
4137 | * "pseudo-cm energies" of the parent system considerably exceeding | |
4138 | * the true cm energy. Now we keep the true cm energy and calculate | |
4139 | * new x_sub instead. | |
4140 | C old version PPTCMS(4) = PPSUB(4)/XPSUB | |
4141 | PPTCMS(4) = MAX(PPTCMS(4),PPSUB(4)) | |
4142 | XPSUB = PPSUB(4)/PPTCMS(4) | |
4143 | IF (IJPROJ.EQ.7) THEN | |
4144 | AMP2 = PHKK(5,MOT)**2 | |
4145 | PTOT1 = SQRT(PPTCMS(4)**2-AMP2) | |
4146 | ELSE | |
4147 | *??????? | |
4148 | PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOP)) | |
4149 | & *(PPTCMS(4)+PHKK(5,MOP))) | |
4150 | C PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOT)) | |
4151 | C & *(PPTCMS(4)+PHKK(5,MOT))) | |
4152 | ENDIF | |
4153 | C old version PTTCMS(4) = PTSUB(4)/XTSUB | |
4154 | PTTCMS(4) = MAX(PTTCMS(4),PTSUB(4)) | |
4155 | XTSUB = PTSUB(4)/PTTCMS(4) | |
4156 | PTOT2 = SQRT((PTTCMS(4)-PHKK(5,MOT)) | |
4157 | & *(PTTCMS(4)+PHKK(5,MOT))) | |
4158 | DO 4 K=1,3 | |
4159 | PPTCMS(K) = PTOT1*PPSUB(K)/PPSUTO | |
4160 | PTTCMS(K) = PTOT2*PTSUB(K)/PTSUTO | |
4161 | 4 CONTINUE | |
4162 | *** | |
4163 | * testprint | |
4164 | * | |
4165 | * ppnn / ptnn - momenta of the int. nucleons (cms, negl. Fermi) | |
4166 | * ptotnn - total momentum of the int. nucleons (cms, negl. Fermi) | |
4167 | * pptcms/ pttcms - momenta of the interacting nucleons (cms) | |
4168 | * pp1,2 / pt1,2 - momenta of the four partons | |
4169 | * | |
4170 | * pp / pt - total momenta of the pr/ta partons (cms, negl. Fermi) | |
4171 | * ptot - total momentum of the four partons (cms, negl. Fermi) | |
4172 | * ppsub / ptsub - total momenta of the proj / targ partons (cms) | |
4173 | * | |
4174 | c PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 + | |
4175 | c & (PPTCMS(2)+PTTCMS(2))**2 + | |
4176 | c & (PPTCMS(3)+PTTCMS(3))**2 ) | |
4177 | c ENEWCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) * | |
4178 | c & (PPTCMS(4)+PTTCMS(4)+PTOTCM) ) | |
4179 | c PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 + | |
4180 | c & (PPSUB(2)+PTSUB(2))**2 + | |
4181 | c & (PPSUB(3)+PTSUB(3))**2 ) | |
4182 | c ENEWSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) * | |
4183 | c & (PPSUB(4)+PTSUB(4)+PTOTSU) ) | |
4184 | c IF (ENEWCM/EOLDCM.GT.1.1D0) THEN | |
4185 | c WRITE(*,*) ' EOLDCM, ENEWCM : ',EOLDCM,ENEWCM | |
4186 | c WRITE(*,*) ' EOLDSU, ENEWSU : ',EOLDSU,ENEWSU | |
4187 | c WRITE(*,*) ' XPSUB, XTSUB : ',XPSUB,XTSUB | |
4188 | c ENDIF | |
4189 | c BBGX = (PPTCMS(1)+PTTCMS(1))/ENEWCM | |
4190 | c BBGY = (PPTCMS(2)+PTTCMS(2))/ENEWCM | |
4191 | c BBGZ = (PPTCMS(3)+PTTCMS(3))/ENEWCM | |
4192 | c BGAM = (PPTCMS(4)+PTTCMS(4))/ENEWCM | |
4193 | * transform interacting nucleons into nucleon-nucleon cm-system | |
4194 | c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ, | |
4195 | c & PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4),PPTOT, | |
4196 | c & PPNEW1,PPNEW2,PPNEW3,PPNEW4) | |
4197 | c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ, | |
4198 | c & PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4),PTTOT, | |
4199 | c & PTNEW1,PTNEW2,PTNEW3,PTNEW4) | |
4200 | c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ, | |
4201 | c & PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4),PPTOT, | |
4202 | c & PPSUB1,PPSUB2,PPSUB3,PPSUB4) | |
4203 | c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ, | |
4204 | c & PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4),PTTOT, | |
4205 | c & PTSUB1,PTSUB2,PTSUB3,PTSUB4) | |
4206 | c PTSTCM = SQRT( (PPNEW1+PTNEW1)**2 + | |
4207 | c & (PPNEW2+PTNEW2)**2 + | |
4208 | c & (PPNEW3+PTNEW3)**2 ) | |
4209 | c ETSTCM = SQRT( (PPNEW4+PTNEW4-PTSTCM) * | |
4210 | c & (PPNEW4+PTNEW4+PTSTCM) ) | |
4211 | c PTSTSU = SQRT( (PPSUB1+PTSUB1)**2 + | |
4212 | c & (PPSUB2+PTSUB2)**2 + | |
4213 | c & (PPSUB3+PTSUB3)**2 ) | |
4214 | c ETSTSU = SQRT( (PPSUB4+PTSUB4-PTSTSU) * | |
4215 | c & (PPSUB4+PTSUB4+PTSTSU) ) | |
4216 | C WRITE(*,*) ' mother cmE :' | |
4217 | C WRITE(*,*) ETSTCM,ENEWCM | |
4218 | C WRITE(*,*) ' subsystem cmE :' | |
4219 | C WRITE(*,*) ETSTSU,ENEWSU | |
4220 | C WRITE(*,*) ' projectile mother :' | |
4221 | C WRITE(*,*) PPNEW1,PPNEW2,PPNEW3,PPNEW4 | |
4222 | C WRITE(*,*) ' target mother :' | |
4223 | C WRITE(*,*) PTNEW1,PTNEW2,PTNEW3,PTNEW4 | |
4224 | C WRITE(*,*) ' projectile subsystem:' | |
4225 | C WRITE(*,*) PPSUB1,PPSUB2,PPSUB3,PPSUB4 | |
4226 | C WRITE(*,*) ' target subsystem:' | |
4227 | C WRITE(*,*) PTSUB1,PTSUB2,PTSUB3,PTSUB4 | |
4228 | C WRITE(*,*) ' projectile subsystem should be:' | |
4229 | C WRITE(*,*) ZERO,ZERO,XPSUB*ETSTCM/2.0D0, | |
4230 | C & XPSUB*ETSTCM/2.0D0 | |
4231 | C WRITE(*,*) ' target subsystem should be:' | |
4232 | C WRITE(*,*) ZERO,ZERO,-XTSUB*ETSTCM/2.0D0, | |
4233 | C & XTSUB*ETSTCM/2.0D0 | |
4234 | C WRITE(*,*) ' subsystem cmE should be: ' | |
4235 | C WRITE(*,*) SQRT(XPSUB*XTSUB)*ETSTCM,XPSUB,XTSUB | |
4236 | *** | |
4237 | * | |
4238 | * generate complete remnant - nucleon/remnant event with PHOJET | |
4239 | ||
4240 | CALL PHO_EVENT(3,PPTCMS,PTTCMS,DUM,IREJ1) | |
4241 | ||
4242 | * | |
4243 | * copy back original settings of PHOJET process flags | |
4244 | DO 11 K=1,11 | |
4245 | IPRON(K,1) = KPRON(K) | |
4246 | 11 CONTINUE | |
4247 | * | |
4248 | * check if PHOJET has rejected this event | |
4249 | IF (IREJ1.NE.0) THEN | |
4250 | IF (IOULEV(1).GT.0) | |
4251 | & WRITE(LOUT,'(1X,A)') 'EVENTB: chain system rejected' | |
4252 | WRITE(LOUT,*) | |
4253 | & 'XPSUB,XTSUB,SECM ',XPSUB,XTSUB,SECM,AMTOT | |
4254 | ||
4255 | CALL PHO_PREVNT(0) | |
4256 | ||
4257 | GOTO 9999 | |
4258 | ENDIF | |
4259 | * | |
4260 | * copy partons and strings from PHOJET common back into DTEVT for | |
4261 | * external fragmentation | |
4262 | MO1 = NC | |
4263 | MO2 = NC+3 | |
4264 | *! uncomment this line for internal phojet-fragmentation | |
4265 | C CALL DT_GETFSP(MO1,MO2,PP,PT,1) | |
4266 | NPHOSC = NPHOSC+1 | |
4267 | CALL DT_GETPJE(MO1,MO2,PP,PT,1,NPHOSC,IREJ1) | |
4268 | IF (IREJ1.NE.0) THEN | |
4269 | IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)') | |
4270 | & 'EVENTB: chain system rejected 2' | |
4271 | GOTO 9999 | |
4272 | ENDIF | |
4273 | * | |
4274 | * update statistics counter | |
4275 | ICEVTG(IDCH(NC),2) = ICEVTG(IDCH(NC),2)+1 | |
4276 | * | |
4277 | *----------------------------------------------------------------------- | |
4278 | * two-chain approx. for smaller systems | |
4279 | * | |
4280 | ELSE | |
4281 | * | |
4282 | NDTUSC = NDTUSC+1 | |
4283 | * special flag for double-Pomeron statistics | |
4284 | IPOPO = 0 | |
4285 | * | |
4286 | * pick up flavors at the ends of the two chains | |
4287 | IFP1 = IDHKK(NC) | |
4288 | IFT1 = IDHKK(NC+1) | |
4289 | IFP2 = IDHKK(NC+2) | |
4290 | IFT2 = IDHKK(NC+3) | |
4291 | * ..and the indices of the mothers | |
4292 | MOP1 = NC | |
4293 | MOT1 = NC+1 | |
4294 | MOP2 = NC+2 | |
4295 | MOT2 = NC+3 | |
4296 | CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2, | |
4297 | & IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1) | |
4298 | * | |
4299 | * check if this chain system was rejected | |
4300 | IF (IREJ1.GT.0) THEN | |
4301 | IF (IOULEV(1).GT.0) THEN | |
4302 | WRITE(LOUT,*) 'rejected 1 in EVENTB' | |
4303 | WRITE(LOUT,'(1X,4(I6,4E12.3,/),E12.3)') | |
4304 | & IFP1,PP1,IFT1,PT1,IFP2,PP2,IFT2,PT2,AMTOT | |
4305 | ENDIF | |
4306 | IRHHA = IRHHA+1 | |
4307 | GOTO 9999 | |
4308 | ENDIF | |
4309 | * the following lines are for sea-sea chains rejected in GETCSY | |
4310 | IF (IREJ1.EQ.-1) NDTUSC = NDTUSC-1 | |
4311 | ICEVTG(IDCH(NC),1) = ICEVTG(IDCH(NC),1)+1 | |
4312 | ENDIF | |
4313 | * | |
4314 | ENDIF | |
4315 | * | |
4316 | * update statistics counter | |
4317 | ICEVTG(IDCH(NC),0) = ICEVTG(IDCH(NC),0)+1 | |
4318 | * | |
4319 | NC = NC+4 | |
4320 | * | |
4321 | 2 CONTINUE | |
4322 | * | |
4323 | *----------------------------------------------------------------------- | |
4324 | * treatment of low-mass chains (if there are any) | |
4325 | * | |
4326 | IF (NDTUSC.GT.0) THEN | |
4327 | * | |
4328 | * correct chains of very low masses for possible resonances | |
4329 | IF (IRESCO.EQ.1) THEN | |
4330 | CALL DT_EVTRES(IREJ1) | |
4331 | IF (IREJ1.GT.0) THEN | |
4332 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2a in EVENTB' | |
4333 | IRRES(1) = IRRES(1)+1 | |
4334 | GOTO 9999 | |
4335 | ENDIF | |
4336 | ENDIF | |
4337 | * fragmentation of low-mass chains | |
4338 | *! uncomment this line for internal phojet-fragmentation | |
4339 | * (of course it will still be fragmented by DPMJET-routines but it | |
4340 | * has to be done here instead of further below) | |
4341 | C CALL DT_EVTFRA(IREJ1) | |
4342 | C IF (IREJ1.GT.0) THEN | |
4343 | C IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2b in EVENTB' | |
4344 | C IRFRAG = IRFRAG+1 | |
4345 | C GOTO 9999 | |
4346 | C ENDIF | |
4347 | ELSE | |
4348 | *! uncomment this line for internal phojet-fragmentation | |
4349 | C NPOINT(4) = NHKK+1 | |
4350 | IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1 | |
4351 | ENDIF | |
4352 | * | |
4353 | *----------------------------------------------------------------------- | |
4354 | * new di-quark breaking mechanisms | |
4355 | * | |
4356 | MXLEFT = 2 | |
4357 | CALL DT_CHASTA(0) | |
4358 | IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0) | |
4359 | & .OR.(PDBSEA(3).GT.0.0D0)) THEN | |
4360 | CALL DT_DIQBRK | |
4361 | MXLEFT = 4 | |
4362 | ENDIF | |
4363 | * | |
4364 | *----------------------------------------------------------------------- | |
4365 | * hadronize this event | |
4366 | * | |
4367 | * hadronize PHOJET chain systems | |
4368 | NPYMAX = 0 | |
4369 | NPJE = NPHOSC/MXPHFR | |
4370 | IF (MXPHFR.LT.MXLEFT) MXLEFT = 2 | |
4371 | IF (NPJE.GT.1) THEN | |
4372 | NLEFT = NPHOSC-NPJE*MXPHFR | |
4373 | DO 20 JFRG=1,NPJE | |
4374 | NFRG = JFRG*MXPHFR | |
4375 | IF ((JFRG.EQ.NPJE).AND.(NLEFT.LE.MXLEFT)) THEN | |
4376 | CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1) | |
4377 | IF (IREJ1.GT.0) GOTO 22 | |
4378 | NLEFT = 0 | |
4379 | ELSE | |
4380 | CALL DT_EVTFRG(1,NFRG,NPYMEM,IREJ1) | |
4381 | IF (IREJ1.GT.0) GOTO 22 | |
4382 | ENDIF | |
4383 | IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM | |
4384 | 20 CONTINUE | |
4385 | IF (NLEFT.GT.0) THEN | |
4386 | CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1) | |
4387 | IF (IREJ1.GT.0) GOTO 22 | |
4388 | IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM | |
4389 | ENDIF | |
4390 | ELSE | |
4391 | CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1) | |
4392 | IF (IREJ1.GT.0) GOTO 22 | |
4393 | IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM | |
4394 | ENDIF | |
4395 | * | |
4396 | * check max. filling level of jetset common and | |
4397 | * reduce mxphfr if necessary | |
4398 | IF (NPYMAX.GT.3000) THEN | |
4399 | IF (NPYMAX.GT.3500) THEN | |
4400 | MXPHFR = MAX(1,MXPHFR-2) | |
4401 | ELSE | |
4402 | MXPHFR = MAX(1,MXPHFR-1) | |
4403 | ENDIF | |
4404 | C WRITE(LOUT,*) ' EVENTB: Mxphfr reduced to ',MXPHFR | |
4405 | ENDIF | |
4406 | * | |
4407 | * hadronize DTUNUC chain systems | |
4408 | 23 CONTINUE | |
4409 | IBACK = MXDTFR | |
4410 | CALL DT_EVTFRG(2,IBACK,NPYMEM,IREJ2) | |
4411 | IF (IREJ2.GT.0) GOTO 22 | |
4412 | * | |
4413 | * check max. filling level of jetset common and | |
4414 | * reduce mxdtfr if necessary | |
4415 | IF (NPYMEM.GT.3000) THEN | |
4416 | IF (NPYMEM.GT.3500) THEN | |
4417 | MXDTFR = MAX(1,MXDTFR-20) | |
4418 | ELSE | |
4419 | MXDTFR = MAX(1,MXDTFR-10) | |
4420 | ENDIF | |
4421 | C WRITE(LOUT,*) ' EVENTB: Mxdtfr reduced to ',MXDTFR | |
4422 | ENDIF | |
4423 | * | |
4424 | IF (IBACK.EQ.-1) GOTO 23 | |
4425 | * | |
4426 | 22 CONTINUE | |
4427 | C CALL DT_EVTFRG(1,IREJ1) | |
4428 | C CALL DT_EVTFRG(2,IREJ2) | |
4429 | IF ((IREJ1.GT.0).OR.(IREJ2.GT.0)) THEN | |
4430 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTB' | |
4431 | IRFRAG = IRFRAG+1 | |
4432 | GOTO 9999 | |
4433 | ENDIF | |
4434 | * | |
4435 | * get final state particles from /DTEVTP/ | |
4436 | *! uncomment this line for internal phojet-fragmentation | |
4437 | C CALL DT_GETFSP(IDUM,IDUM,PP,PT,2) | |
4438 | ||
4439 | IF (IJPROJ.NE.7) | |
4440 | & CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,88,IREJ3) | |
4441 | C IF (IREJ3.NE.0) GOTO 9999 | |
4442 | ||
4443 | RETURN | |
4444 | ||
4445 | 9999 CONTINUE | |
4446 | IREVT = IREVT+1 | |
4447 | IREJ = 1 | |
4448 | RETURN | |
4449 | END | |
4450 | ||
4451 | *$ CREATE DT_GETPJE.FOR | |
4452 | *COPY DT_GETPJE | |
4453 | * | |
4454 | *===getpje=============================================================* | |
4455 | * | |
4456 | SUBROUTINE DT_GETPJE(MO1,MO2,PP,PT,MODE,IPJE,IREJ) | |
4457 | ||
4458 | ************************************************************************ | |
4459 | * This subroutine copies PHOJET partons and strings from POEVT1 into * | |
4460 | * DTEVT1. * | |
4461 | * MO1,MO2 indices of first and last mother-parton in DTEVT1 * | |
4462 | * PP,PT 4-momenta of projectile/target being handled by * | |
4463 | * PHOJET * | |
4464 | * This version dated 11.12.99 is written by S. Roesler * | |
4465 | ************************************************************************ | |
4466 | ||
4467 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
4468 | SAVE | |
4469 | ||
4470 | PARAMETER ( LINP = 10 , | |
4471 | & LOUT = 6 , | |
4472 | & LDAT = 9 ) | |
4473 | ||
4474 | PARAMETER (TINY10=1.0D-10,TINY1=1.0D-1, | |
4475 | & ZERO=0.0D0,ONE=1.0D0,OHALF=0.5D0) | |
4476 | ||
4477 | LOGICAL LFLIP | |
4478 | ||
4479 | * event history | |
4480 | ||
4481 | PARAMETER (NMXHKK=200000) | |
4482 | ||
4483 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
4484 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
4485 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
4486 | ||
4487 | * extended event history | |
4488 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
4489 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
4490 | & IHIST(2,NMXHKK) | |
4491 | ||
4492 | * Lorentz-parameters of the current interaction | |
4493 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
4494 | & UMO,PPCM,EPROJ,PPROJ | |
4495 | ||
4496 | * DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem | |
4497 | COMMON /DTLTSU/ BGX,BGY,BGZ,GAM | |
4498 | ||
4499 | * flags for input different options | |
4500 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
4501 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
4502 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
4503 | ||
4504 | * statistics: double-Pomeron exchange | |
4505 | COMMON /DTFLG2/ INTFLG,IPOPO | |
4506 | ||
4507 | * statistics | |
4508 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
4509 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
4510 | & ICEVTG(8,0:30) | |
4511 | ||
4512 | * rejection counter | |
4513 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
4514 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
4515 | & IREXCI(3),IRDIFF(2),IRINC | |
4516 | C standard particle data interface | |
4517 | INTEGER NMXHEP | |
4518 | ||
4519 | PARAMETER (NMXHEP=4000) | |
4520 | ||
4521 | INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP | |
4522 | DOUBLE PRECISION PHEP,VHEP | |
4523 | COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP), | |
4524 | & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP), | |
4525 | & VHEP(4,NMXHEP) | |
4526 | C extension to standard particle data interface (PHOJET specific) | |
4527 | INTEGER IMPART,IPHIST,ICOLOR | |
4528 | COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP) | |
4529 | ||
4530 | C color string configurations including collapsed strings and hadrons | |
4531 | INTEGER MSTR | |
4532 | PARAMETER (MSTR=500) | |
4533 | INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD | |
4534 | COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR), | |
4535 | & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR), | |
4536 | & NNCH(MSTR),IBHAD(MSTR),ISTR | |
4537 | ||
4538 | C general process information | |
4539 | INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON | |
4540 | COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4) | |
4541 | ||
4542 | C model switches and parameters | |
4543 | CHARACTER*8 MDLNA | |
4544 | INTEGER ISWMDL,IPAMDL | |
4545 | DOUBLE PRECISION PARMDL | |
4546 | COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400) | |
4547 | ||
4548 | C event debugging information | |
4549 | INTEGER NMAXD | |
4550 | PARAMETER (NMAXD=100) | |
4551 | INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO, | |
4552 | & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD | |
4553 | COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG, | |
4554 | & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD | |
4555 | ||
4556 | DIMENSION PP(4),PT(4) | |
4557 | DATA MAXLOP /10000/ | |
4558 | ||
4559 | INHKK = NHKK | |
4560 | LFLIP = .TRUE. | |
4561 | 1 CONTINUE | |
4562 | NPVAL = 0 | |
4563 | NTVAL = 0 | |
4564 | IREJ = 0 | |
4565 | ||
4566 | * store initial momenta for energy-momentum conservation check | |
4567 | IF (LEMCCK) THEN | |
4568 | CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM1,IDUM2) | |
4569 | CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM1,IDUM2) | |
4570 | ENDIF | |
4571 | * copy partons and strings from POEVT1 into DTEVT1 | |
4572 | DO 11 I=1,ISTR | |
4573 | C IF ((NCODE(I).EQ.-99).AND.(IPAMDL(17).EQ.0)) THEN | |
4574 | IF (NCODE(I).EQ.-99) THEN | |
4575 | IDXSTG = NPOS(1,I) | |
4576 | IDSTG = IDHEP(IDXSTG) | |
4577 | PX = PHEP(1,IDXSTG) | |
4578 | PY = PHEP(2,IDXSTG) | |
4579 | PZ = PHEP(3,IDXSTG) | |
4580 | PE = PHEP(4,IDXSTG) | |
4581 | IF (MODE.LT.0) THEN | |
4582 | ISTAT = 70000+IPJE | |
4583 | CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PX,PY,PZ,PE, | |
4584 | & 11,IDSTG,0) | |
4585 | IF (LEMCCK) THEN | |
4586 | PX = -PX | |
4587 | PY = -PY | |
4588 | PZ = -PZ | |
4589 | PE = -PE | |
4590 | CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2) | |
4591 | ENDIF | |
4592 | ELSE | |
4593 | CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP, | |
4594 | & PPX,PPY,PPZ,PPE) | |
4595 | ISTAT = 70000+IPJE | |
4596 | CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PPX,PPY,PPZ,PPE, | |
4597 | & 11,IDSTG,0) | |
4598 | IF (LEMCCK) THEN | |
4599 | PX = -PPX | |
4600 | PY = -PPY | |
4601 | PZ = -PPZ | |
4602 | PE = -PPE | |
4603 | CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2) | |
4604 | ENDIF | |
4605 | ENDIF | |
4606 | NOBAM(NHKK) = 0 | |
4607 | IHIST(1,NHKK) = IPHIST(1,IDXSTG) | |
4608 | IHIST(2,NHKK) = 0 | |
4609 | ELSEIF (NCODE(I).GE.0) THEN | |
4610 | * indices of partons and string in POEVT1 | |
4611 | IDX1 = ABS(JMOHEP(1,NPOS(1,I))) | |
4612 | IDX2 = ABS(JMOHEP(2,NPOS(1,I))) | |
4613 | IF ((IDX1.GT.IDX2).OR.(JMOHEP(2,NPOS(1,I)).GT.0)) THEN | |
4614 | WRITE(LOUT,*) ' GETPJE: IDX1.GT.IDX2 ',IDX1,IDX2, | |
4615 | & ' or JMOHEP(2,NPOS(1,I)).GT.0 ',JMOHEP(2,NPOS(1,I)),' ! ' | |
4616 | STOP ' GETPJE 1' | |
4617 | ENDIF | |
4618 | IDXSTG = NPOS(1,I) | |
4619 | * find "mother" string of the string | |
4620 | IDXMS1 = ABS(JMOHEP(1,IDX1)) | |
4621 | IDXMS2 = ABS(JMOHEP(1,IDX2)) | |
4622 | IF (IDXMS1.NE.IDXMS2) THEN | |
4623 | IDXMS1 = IDXSTG | |
4624 | IDXMS2 = IDXSTG | |
4625 | C STOP ' GETPJE: IDXMS1.NE.IDXMS2 !' | |
4626 | ENDIF | |
4627 | * search POEVT1 for the original hadron of the parton | |
4628 | ILOOP = 0 | |
4629 | IPOM1 = 0 | |
4630 | 14 CONTINUE | |
4631 | ILOOP = ILOOP+1 | |
4632 | ||
4633 | IF (IDHEP(IDXMS1).EQ.990) IPOM1 = 1 | |
4634 | ||
4635 | IDXMS1 = ABS(JMOHEP(1,IDXMS1)) | |
4636 | IF ((IDXMS1.NE.1).AND.(IDXMS1.NE.2).AND. | |
4637 | & (ILOOP.LT.MAXLOP)) GOTO 14 | |
4638 | IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 1 ! ' | |
4639 | IPOM2 = 0 | |
4640 | ILOOP = 0 | |
4641 | 15 CONTINUE | |
4642 | ILOOP = ILOOP+1 | |
4643 | ||
4644 | IF (IDHEP(IDXMS2).EQ.990) IPOM2 = 1 | |
4645 | ||
4646 | IF ((ILOOP.EQ.1).OR.(IDHEP(IDXMS2).GE.7777)) THEN | |
4647 | IDXMS2 = ABS(JMOHEP(2,IDXMS2)) | |
4648 | ELSE | |
4649 | IDXMS2 = ABS(JMOHEP(1,IDXMS2)) | |
4650 | ENDIF | |
4651 | IF ((IDXMS2.NE.1).AND.(IDXMS2.NE.2).AND. | |
4652 | & (ILOOP.LT.MAXLOP)) GOTO 15 | |
4653 | IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 5 ! ' | |
4654 | * parton 1 | |
4655 | IF (IDXMS1.EQ.1) THEN | |
4656 | ISPTN1 = ISTHKK(MO1) | |
4657 | M1PTN1 = MO1 | |
4658 | M2PTN1 = MO1+2 | |
4659 | ELSE | |
4660 | ISPTN1 = ISTHKK(MO2) | |
4661 | M1PTN1 = MO2-2 | |
4662 | M2PTN1 = MO2 | |
4663 | ENDIF | |
4664 | * parton 2 | |
4665 | IF (IDXMS2.EQ.1) THEN | |
4666 | ISPTN2 = ISTHKK(MO1) | |
4667 | M1PTN2 = MO1 | |
4668 | M2PTN2 = MO1+2 | |
4669 | ELSE | |
4670 | ISPTN2 = ISTHKK(MO2) | |
4671 | M1PTN2 = MO2-2 | |
4672 | M2PTN2 = MO2 | |
4673 | ENDIF | |
4674 | * check for mis-identified mothers and switch mother indices if necessary | |
4675 | IF ((IDXMS1.EQ.IDXMS2).AND.(IPROCE.NE.5).AND.(IPROCE.NE.6) | |
4676 | & .AND.((IDHEP(IDX1).NE.21).OR.(IDHEP(IDX2).NE.21)).AND. | |
4677 | & (LFLIP)) THEN | |
4678 | IF (PHEP(3,IDX1).GT.PHEP(3,IDX2)) THEN | |
4679 | ISPTN1 = ISTHKK(MO1) | |
4680 | M1PTN1 = MO1 | |
4681 | M2PTN1 = MO1+2 | |
4682 | ISPTN2 = ISTHKK(MO2) | |
4683 | M1PTN2 = MO2-2 | |
4684 | M2PTN2 = MO2 | |
4685 | ELSE | |
4686 | ISPTN1 = ISTHKK(MO2) | |
4687 | M1PTN1 = MO2-2 | |
4688 | M2PTN1 = MO2 | |
4689 | ISPTN2 = ISTHKK(MO1) | |
4690 | M1PTN2 = MO1 | |
4691 | M2PTN2 = MO1+2 | |
4692 | ENDIF | |
4693 | ENDIF | |
4694 | * register partons in temporary common | |
4695 | * parton at chain end | |
4696 | PX = PHEP(1,IDX1) | |
4697 | PY = PHEP(2,IDX1) | |
4698 | PZ = PHEP(3,IDX1) | |
4699 | PE = PHEP(4,IDX1) | |
4700 | * flag only partons coming from Pomeron with 41/42 | |
4701 | C IF ((IPOM1.NE.0).OR.(NPOS(4,I).GE.4)) THEN | |
4702 | IF (IPOM1.NE.0) THEN | |
4703 | ISTX = ABS(ISPTN1)/10 | |
4704 | IMO = ABS(ISPTN1)-10*ISTX | |
4705 | ISPTN1 = -(40+IMO) | |
4706 | ELSE | |
4707 | IF ((ICOLOR(2,IDX1).EQ.0).OR.(IDHEP(IDX1).EQ.21)) THEN | |
4708 | ISTX = ABS(ISPTN1)/10 | |
4709 | IMO = ABS(ISPTN1)-10*ISTX | |
4710 | IF ((IDHEP(IDX1).EQ.21).OR. | |
4711 | & (ABS(IPHIST(1,IDX1)).GE.100)) THEN | |
4712 | ISPTN1 = -(60+IMO) | |
4713 | ELSE | |
4714 | ISPTN1 = -(50+IMO) | |
4715 | ENDIF | |
4716 | ENDIF | |
4717 | ENDIF | |
4718 | IF (ISPTN1.EQ.-21) NPVAL = NPVAL+1 | |
4719 | IF (ISPTN1.EQ.-22) NTVAL = NTVAL+1 | |
4720 | IF (MODE.LT.0) THEN | |
4721 | CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PX,PY, | |
4722 | & PZ,PE,0,0,0) | |
4723 | ELSE | |
4724 | CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP, | |
4725 | & PPX,PPY,PPZ,PPE) | |
4726 | CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PPX,PPY, | |
4727 | & PPZ,PPE,0,0,0) | |
4728 | ENDIF | |
4729 | IHIST(1,NHKK) = IPHIST(1,IDX1) | |
4730 | IHIST(2,NHKK) = 0 | |
4731 | DO 19 KK=1,4 | |
4732 | VHKK(KK,NHKK) = VHKK(KK,M2PTN1) | |
4733 | WHKK(KK,NHKK) = WHKK(KK,M1PTN1) | |
4734 | 19 CONTINUE | |
4735 | VHKK(4,NHKK) = VHKK(3,M2PTN1)/BLAB-VHKK(3,M1PTN1)/BGLAB | |
4736 | WHKK(4,NHKK) = -WHKK(3,M1PTN1)/BLAB+WHKK(3,M2PTN1)/BGLAB | |
4737 | M1STRG = NHKK | |
4738 | * gluon kinks | |
4739 | NGLUON = IDX2-IDX1-1 | |
4740 | IF (NGLUON.GT.0) THEN | |
4741 | DO 17 IGLUON=1,NGLUON | |
4742 | IDX = IDX1+IGLUON | |
4743 | IDXMS = ABS(JMOHEP(1,IDX)) | |
4744 | IF ((IDXMS.NE.1).AND.(IDXMS.NE.2)) THEN | |
4745 | ILOOP = 0 | |
4746 | 16 CONTINUE | |
4747 | ILOOP = ILOOP+1 | |
4748 | IDXMS = ABS(JMOHEP(1,IDXMS)) | |
4749 | IF ((IDXMS.NE.1).AND.(IDXMS.NE.2).AND. | |
4750 | & (ILOOP.LT.MAXLOP)) GOTO 16 | |
4751 | IF (ILOOP.EQ.MAXLOP) | |
4752 | & WRITE(LOUT,*) ' GETPJE: MAXLOP in 3 ! ' | |
4753 | ENDIF | |
4754 | IF (IDXMS.EQ.1) THEN | |
4755 | ISPTN = ISTHKK(MO1) | |
4756 | M1PTN = MO1 | |
4757 | M2PTN = MO1+2 | |
4758 | ELSE | |
4759 | ISPTN = ISTHKK(MO2) | |
4760 | M1PTN = MO2-2 | |
4761 | M2PTN = MO2 | |
4762 | ENDIF | |
4763 | PX = PHEP(1,IDX) | |
4764 | PY = PHEP(2,IDX) | |
4765 | PZ = PHEP(3,IDX) | |
4766 | PE = PHEP(4,IDX) | |
4767 | IF ((ICOLOR(2,IDX).EQ.0).OR.(IDHEP(IDX).EQ.21)) THEN | |
4768 | ISTX = ABS(ISPTN)/10 | |
4769 | IMO = ABS(ISPTN)-10*ISTX | |
4770 | IF ((IDHEP(IDX).EQ.21).OR. | |
4771 | & (ABS(IPHIST(1,IDX)).GE.100)) THEN | |
4772 | ISPTN = -(60+IMO) | |
4773 | ELSE | |
4774 | ISPTN = -(50+IMO) | |
4775 | ENDIF | |
4776 | ENDIF | |
4777 | IF (ISPTN.EQ.-21) NPVAL = NPVAL+1 | |
4778 | IF (ISPTN.EQ.-22) NTVAL = NTVAL+1 | |
4779 | IF (MODE.LT.0) THEN | |
4780 | CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN, | |
4781 | & PX,PY,PZ,PE,0,0,0) | |
4782 | ELSE | |
4783 | CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP, | |
4784 | & PPX,PPY,PPZ,PPE) | |
4785 | CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN, | |
4786 | & PPX,PPY,PPZ,PPE,0,0,0) | |
4787 | ENDIF | |
4788 | IHIST(1,NHKK) = IPHIST(1,IDX) | |
4789 | IHIST(2,NHKK) = 0 | |
4790 | DO 20 KK=1,4 | |
4791 | VHKK(KK,NHKK) = VHKK(KK,M2PTN) | |
4792 | WHKK(KK,NHKK) = WHKK(KK,M1PTN) | |
4793 | 20 CONTINUE | |
4794 | VHKK(4,NHKK)= VHKK(3,M2PTN)/BLAB-VHKK(3,M1PTN)/BGLAB | |
4795 | WHKK(4,NHKK)= -WHKK(3,M1PTN)/BLAB+WHKK(3,M2PTN)/BGLAB | |
4796 | 17 CONTINUE | |
4797 | ENDIF | |
4798 | * parton at chain end | |
4799 | PX = PHEP(1,IDX2) | |
4800 | PY = PHEP(2,IDX2) | |
4801 | PZ = PHEP(3,IDX2) | |
4802 | PE = PHEP(4,IDX2) | |
4803 | * flag only partons coming from Pomeron with 41/42 | |
4804 | C IF ((IPOM2.NE.0).OR.(NPOS(4,I).GE.4)) THEN | |
4805 | IF (IPOM2.NE.0) THEN | |
4806 | ISTX = ABS(ISPTN2)/10 | |
4807 | IMO = ABS(ISPTN2)-10*ISTX | |
4808 | ISPTN2 = -(40+IMO) | |
4809 | ELSE | |
4810 | IF ((ICOLOR(2,IDX2).EQ.0).OR.(IDHEP(IDX2).EQ.21)) THEN | |
4811 | ISTX = ABS(ISPTN2)/10 | |
4812 | IMO = ABS(ISPTN2)-10*ISTX | |
4813 | IF ((IDHEP(IDX2).EQ.21).OR. | |
4814 | & (ABS(IPHIST(1,IDX2)).GE.100)) THEN | |
4815 | ISPTN2 = -(60+IMO) | |
4816 | ELSE | |
4817 | ISPTN2 = -(50+IMO) | |
4818 | ENDIF | |
4819 | ENDIF | |
4820 | ENDIF | |
4821 | IF (ISPTN2.EQ.-21) NPVAL = NPVAL+1 | |
4822 | IF (ISPTN2.EQ.-22) NTVAL = NTVAL+1 | |
4823 | IF (MODE.LT.0) THEN | |
4824 | CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2, | |
4825 | & PX,PY,PZ,PE,0,0,0) | |
4826 | ELSE | |
4827 | CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP, | |
4828 | & PPX,PPY,PPZ,PPE) | |
4829 | CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2, | |
4830 | & PPX,PPY,PPZ,PPE,0,0,0) | |
4831 | ENDIF | |
4832 | IHIST(1,NHKK) = IPHIST(1,IDX2) | |
4833 | IHIST(2,NHKK) = 0 | |
4834 | DO 21 KK=1,4 | |
4835 | VHKK(KK,NHKK) = VHKK(KK,M2PTN2) | |
4836 | WHKK(KK,NHKK) = WHKK(KK,M1PTN2) | |
4837 | 21 CONTINUE | |
4838 | VHKK(4,NHKK) = VHKK(3,M2PTN2)/BLAB-VHKK(3,M1PTN2)/BGLAB | |
4839 | WHKK(4,NHKK) = -WHKK(3,M1PTN2)/BLAB+WHKK(3,M2PTN2)/BGLAB | |
4840 | M2STRG = NHKK | |
4841 | * register string | |
4842 | JSTRG = 100*IPROCE+NCODE(I) | |
4843 | PX = PHEP(1,IDXSTG) | |
4844 | PY = PHEP(2,IDXSTG) | |
4845 | PZ = PHEP(3,IDXSTG) | |
4846 | PE = PHEP(4,IDXSTG) | |
4847 | IF (MODE.LT.0) THEN | |
4848 | ISTAT = 70000+IPJE | |
4849 | CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG, | |
4850 | & PX,PY,PZ,PE,0,0,0) | |
4851 | IF (LEMCCK) THEN | |
4852 | PX = -PX | |
4853 | PY = -PY | |
4854 | PZ = -PZ | |
4855 | PE = -PE | |
4856 | CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2) | |
4857 | ENDIF | |
4858 | ELSE | |
4859 | CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP, | |
4860 | & PPX,PPY,PPZ,PPE) | |
4861 | ISTAT = 70000+IPJE | |
4862 | CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG, | |
4863 | & PPX,PPY,PPZ,PPE,0,0,0) | |
4864 | IF (LEMCCK) THEN | |
4865 | PX = -PPX | |
4866 | PY = -PPY | |
4867 | PZ = -PPZ | |
4868 | PE = -PPE | |
4869 | CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2) | |
4870 | ENDIF | |
4871 | ENDIF | |
4872 | NOBAM(NHKK) = 0 | |
4873 | IHIST(1,NHKK) = 0 | |
4874 | IHIST(2,NHKK) = 0 | |
4875 | DO 18 KK=1,4 | |
4876 | VHKK(KK,NHKK) = VHKK(KK,MO2) | |
4877 | WHKK(KK,NHKK) = WHKK(KK,MO1) | |
4878 | 18 CONTINUE | |
4879 | VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB | |
4880 | WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB | |
4881 | ENDIF | |
4882 | 11 CONTINUE | |
4883 | ||
4884 | IF ( ((NPVAL.GT.2).OR.(NTVAL.GT.2)).AND.(LFLIP) ) THEN | |
4885 | NHKK = INHKK | |
4886 | LFLIP = .FALSE. | |
4887 | GOTO 1 | |
4888 | ENDIF | |
4889 | ||
4890 | IF (LEMCCK) THEN | |
4891 | IF (UMO.GT.1.0D5) THEN | |
4892 | CHKLEV = 1.0D0 | |
4893 | ELSE | |
4894 | CHKLEV = TINY1 | |
4895 | ENDIF | |
4896 | CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,1000,IREJ2) | |
4897 | ||
4898 | IF (IREJ2.GT.ZERO) CALL PHO_PREVNT(0) | |
4899 | ||
4900 | ENDIF | |
4901 | ||
4902 | * internal statistics | |
4903 | * dble-Po statistics. | |
4904 | IF (IPROCE.NE.4) IPOPO = 0 | |
4905 | ||
4906 | INTFLG = IPROCE | |
4907 | IDCHSY = IDCH(MO1) | |
4908 | IF ((IPROCE.GE.1).AND.(IPROCE.LE.8)) THEN | |
4909 | ICEVTG(IDCHSY,IPROCE+2) = ICEVTG(IDCHSY,IPROCE+2)+1 | |
4910 | ELSE | |
4911 | WRITE(LOUT,1000) IPROCE,NEVHKK,MO1 | |
4912 | 1000 FORMAT(1X,'GETFSP: warning! incons. process id. (',I2, | |
4913 | & ') at evt(chain) ',I6,'(',I2,')') | |
4914 | ENDIF | |
4915 | IF (IPROCE.EQ.5) THEN | |
4916 | IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3)) THEN | |
4917 | ICEVTG(IDCHSY,18+IDIFR1) = ICEVTG(IDCHSY,18+IDIFR1)+1 | |
4918 | ELSE | |
4919 | C WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2 | |
4920 | 1001 FORMAT(1X,'GETFSP: warning! incons. diffrac. id. ', | |
4921 | & '(IPROCE,IDIFR1,IDIFR2=',3I3,')') | |
4922 | ENDIF | |
4923 | ELSEIF (IPROCE.EQ.6) THEN | |
4924 | IF ((IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN | |
4925 | ICEVTG(IDCHSY,21+IDIFR2) = ICEVTG(IDCHSY,21+IDIFR2)+1 | |
4926 | ELSE | |
4927 | C WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2 | |
4928 | ENDIF | |
4929 | ELSEIF (IPROCE.EQ.7) THEN | |
4930 | IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3).AND. | |
4931 | & (IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN | |
4932 | IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.1)) | |
4933 | & ICEVTG(IDCHSY,25) = ICEVTG(IDCHSY,25)+1 | |
4934 | IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.2)) | |
4935 | & ICEVTG(IDCHSY,26) = ICEVTG(IDCHSY,26)+1 | |
4936 | IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.2)) | |
4937 | & ICEVTG(IDCHSY,27) = ICEVTG(IDCHSY,27)+1 | |
4938 | IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.1)) | |
4939 | & ICEVTG(IDCHSY,28) = ICEVTG(IDCHSY,28)+1 | |
4940 | ELSE | |
4941 | WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2 | |
4942 | ENDIF | |
4943 | ENDIF | |
4944 | IF ((IDIFR1+IDIFR2.EQ.0).AND.(KHDIR.GE.1).AND.(KHDIR.LE.3)) | |
4945 | & THEN | |
4946 | ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1 | |
4947 | ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1 | |
4948 | ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1 | |
4949 | ENDIF | |
4950 | ICEVTG(IDCHSY,14) = ICEVTG(IDCHSY,14)+KSPOM | |
4951 | ICEVTG(IDCHSY,15) = ICEVTG(IDCHSY,15)+KHPOM | |
4952 | ICEVTG(IDCHSY,16) = ICEVTG(IDCHSY,16)+KSREG | |
4953 | ICEVTG(IDCHSY,17) = ICEVTG(IDCHSY,17)+(KSTRG+KHTRG) | |
4954 | ICEVTG(IDCHSY,18) = ICEVTG(IDCHSY,18)+(KSLOO+KHLOO) | |
4955 | ||
4956 | RETURN | |
4957 | ||
4958 | 9999 CONTINUE | |
4959 | IREJ = 1 | |
4960 | RETURN | |
4961 | END | |
4962 | ||
4963 | *$ CREATE DT_PHOINI.FOR | |
4964 | *COPY DT_PHOINI | |
4965 | * | |
4966 | *===phoini=============================================================* | |
4967 | * | |
4968 | SUBROUTINE DT_PHOINI | |
4969 | ||
4970 | ************************************************************************ | |
4971 | * Initialization PHOJET-event generator for nucleon-nucleon interact. * | |
4972 | * This version dated 16.11.95 is written by S. Roesler * | |
4973 | * * | |
4974 | * Last change 27.12.2006 by S. Roesler. * | |
4975 | ************************************************************************ | |
4976 | ||
4977 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
4978 | SAVE | |
4979 | ||
4980 | PARAMETER ( LINP = 10 , | |
4981 | & LOUT = 6 , | |
4982 | & LDAT = 9 ) | |
4983 | ||
4984 | PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0) | |
4985 | ||
4986 | * nucleon-nucleon event-generator | |
4987 | CHARACTER*8 CMODEL | |
4988 | LOGICAL LPHOIN | |
4989 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
4990 | ||
4991 | * particle properties (BAMJET index convention) | |
4992 | CHARACTER*8 ANAME | |
4993 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
4994 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
4995 | ||
4996 | * Lorentz-parameters of the current interaction | |
4997 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
4998 | & UMO,PPCM,EPROJ,PPROJ | |
4999 | ||
5000 | * properties of interacting particles | |
5001 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
5002 | ||
5003 | * properties of photon/lepton projectiles | |
5004 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC | |
5005 | ||
5006 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
5007 | ||
5008 | * emulsion treatment | |
5009 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
5010 | & NCOMPO,IEMUL | |
5011 | ||
5012 | * VDM parameter for photon-nucleus interactions | |
5013 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
5014 | ||
5015 | * nuclear potential | |
5016 | LOGICAL LFERMI | |
5017 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, | |
5018 | & EBINDP(2),EBINDN(2),EPOT(2,210), | |
5019 | & ETACOU(2),ICOUL,LFERMI | |
5020 | ||
5021 | * Glauber formalism: flags and parameters for statistics | |
5022 | LOGICAL LPROD | |
5023 | CHARACTER*8 CGLB | |
5024 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD | |
5025 | * | |
5026 | * parameters for cascade calculations: | |
5027 | * maximum mumber of PDF's which can be defined in phojet (limited | |
5028 | * by the dimension of ipdfs in pho_setpdf) | |
5029 | PARAMETER (MAXPDF = 20) | |
5030 | * PDF parametrization and number of set for the first 30 hadrons in | |
5031 | * the bamjet-code list | |
5032 | * negative numbers mean that the PDF is set in phojet, | |
5033 | * zero stands for "not a hadron" | |
5034 | DIMENSION IPARPD(30),ISETPD(30) | |
5035 | * PDF parametrization | |
5036 | DATA IPARPD / | |
5037 | & -5,-5, 0, 0, 0, 0,-5,-5,-5, 0, 0, 5,-5,-5, 5, 5, 5, 5, 5, 5, | |
5038 | & 5, 5,-5, 5, 5, 0, 0, 0, 0, 0/ | |
5039 | * number of set | |
5040 | DATA ISETPD / | |
5041 | & -6,-6, 0, 0, 0, 0,-3,-6,-6, 0, 0, 2,-2,-2, 2, 2, 6, 6, 2, 6, | |
5042 | & 6, 6,-2, 2, 2, 0, 0, 0, 0, 0/ | |
5043 | ||
5044 | **PHOJET105a | |
5045 | C COMMON /GLOCMS/ XECM,XPCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2) | |
5046 | C PARAMETER ( MAXPRO = 16 ) | |
5047 | C PARAMETER ( MAXTAB = 20 ) | |
5048 | C COMMON /HAXSEC/ XSECTA(4,-1:MAXPRO,4,MAXTAB),XSECT(6,-1:MAXPRO), | |
5049 | C & MXSECT(0:4,-1:MAXPRO,4),ECMSH(4,MAXTAB),ISTTAB | |
5050 | C CHARACTER*8 MDLNA | |
5051 | C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100) | |
5052 | C COMMON /PROCES/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15) | |
5053 | **PHOJET110 | |
5054 | ||
5055 | C global event kinematics and particle IDs | |
5056 | INTEGER IFPAP,IFPAB | |
5057 | DOUBLE PRECISION ECM,PCM,PMASS,PVIRT | |
5058 | COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2) | |
5059 | ||
5060 | C hard cross sections and MC selection weights | |
5061 | INTEGER Max_pro_2 | |
5062 | PARAMETER ( Max_pro_2 = 16 ) | |
5063 | INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried, | |
5064 | & MH_acc_1,MH_acc_2 | |
5065 | DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last | |
5066 | COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2), | |
5067 | & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2), | |
5068 | & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last, | |
5069 | & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4), | |
5070 | & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4) | |
5071 | ||
5072 | C model switches and parameters | |
5073 | CHARACTER*8 MDLNA | |
5074 | INTEGER ISWMDL,IPAMDL | |
5075 | DOUBLE PRECISION PARMDL | |
5076 | COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400) | |
5077 | ||
5078 | C general process information | |
5079 | INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON | |
5080 | COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4) | |
5081 | ** | |
5082 | DIMENSION PP(4),PT(4) | |
5083 | ||
5084 | LOGICAL LSTART | |
5085 | DATA LSTART /.TRUE./ | |
5086 | ||
5087 | IJP = IJPROJ | |
5088 | IJT = IJTARG | |
5089 | Q2 = VIRT | |
5090 | * lepton-projectiles: initialize real photon instead | |
5091 | IF ((IJP.EQ.3).OR.(IJP.EQ.4).OR.(IJP.EQ.10).OR.(IJP.EQ.11)) THEN | |
5092 | IJP = 7 | |
5093 | Q2 = ZERO | |
5094 | ENDIF | |
5095 | ||
5096 | IF (LPHOIN) CALL PHO_INIT(-1,LOUT,IDUM) | |
5097 | ||
5098 | * switch Reggeon off | |
5099 | C IPAMDL(3)= 0 | |
5100 | IF (IP.EQ.1) THEN | |
5101 | IFPAP(1) = IDT_IPDGHA(IJP) | |
5102 | IFPAB(1) = IJP | |
5103 | ELSE | |
5104 | IFPAP(1) = 2212 | |
5105 | IFPAB(1) = IDT_ICIHAD(IFPAP(1)) | |
5106 | ENDIF | |
5107 | PMASS(1) = AAM(IFPAB(1))-SQRT(Q2) | |
5108 | PVIRT(1) = PMASS(1)**2 | |
5109 | IF (IT.EQ.1) THEN | |
5110 | IFPAP(2) = IDT_IPDGHA(IJT) | |
5111 | IFPAB(2) = IJT | |
5112 | ELSE | |
5113 | IFPAP(2) = 2212 | |
5114 | IFPAB(2) = IDT_ICIHAD(IFPAP(2)) | |
5115 | ENDIF | |
5116 | PMASS(2) = AAM(IFPAB(2)) | |
5117 | PVIRT(2) = ZERO | |
5118 | DO 1 K=1,4 | |
5119 | PP(K) = ZERO | |
5120 | PT(K) = ZERO | |
5121 | 1 CONTINUE | |
5122 | * get max. possible momenta of incoming particles to be used for PHOJET ini. | |
5123 | PPF = ZERO | |
5124 | PTF = ZERO | |
5125 | SCPF= 1.5D0 | |
5126 | IF (UMO.GE.1.E5) THEN | |
5127 | SCPF= 5.0D0 | |
5128 | ENDIF | |
5129 | IF (NCOMPO.GT.0) THEN | |
5130 | DO 2 I=1,NCOMPO | |
5131 | IF (IT.GT.1) THEN | |
5132 | CALL DT_NCLPOT(IEMUCH(I),IEMUMA(I),ITZ,IT,ZERO,ZERO,0) | |
5133 | ELSE | |
5134 | CALL DT_NCLPOT(IPZ,IP,IEMUCH(I),IEMUMA(I),ZERO,ZERO,0) | |
5135 | ENDIF | |
5136 | PPFTMP = MAX(PFERMP(1),PFERMN(1)) | |
5137 | PTFTMP = MAX(PFERMP(2),PFERMN(2)) | |
5138 | IF (PPFTMP.GT.PPF) PPF = PPFTMP | |
5139 | IF (PTFTMP.GT.PTF) PTF = PTFTMP | |
5140 | 2 CONTINUE | |
5141 | ELSE | |
5142 | CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0) | |
5143 | PPF = MAX(PFERMP(1),PFERMN(1)) | |
5144 | PTF = MAX(PFERMP(2),PFERMN(2)) | |
5145 | ENDIF | |
5146 | PTF = -PTF | |
5147 | PPF = SCPF*PPF | |
5148 | PTF = SCPF*PTF | |
5149 | IF (IJP.EQ.7) THEN | |
5150 | AMP2 = SIGN(PMASS(1)**2,PMASS(1)) | |
5151 | PP(3) = PPCM | |
5152 | PP(4) = SQRT(AMP2+PP(3)**2) | |
5153 | ELSE | |
5154 | EPF = SQRT(PPF**2+PMASS(1)**2) | |
5155 | CALL DT_LTNUC(PPF,EPF,PP(3),PP(4),2) | |
5156 | ENDIF | |
5157 | ETF = SQRT(PTF**2+PMASS(2)**2) | |
5158 | CALL DT_LTNUC(PTF,ETF,PT(3),PT(4),3) | |
5159 | ECMINI = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2- | |
5160 | & (PP(2)+PT(2))**2-(PP(3)+PT(3))**2) | |
5161 | IF (LSTART) THEN | |
5162 | WRITE(LOUT,1001) IP,IPZ,SCPF,PPF,PP | |
5163 | 1001 FORMAT( | |
5164 | & ' DT_PHOINI: PHOJET initialized for projectile A,Z = ', | |
5165 | & I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3) | |
5166 | IF (NCOMPO.GT.0) THEN | |
5167 | WRITE(LOUT,1002) SCPF,PTF,PT | |
5168 | ELSE | |
5169 | WRITE(LOUT,1003) IT,ITZ,SCPF,PTF,PT | |
5170 | ENDIF | |
5171 | 1002 FORMAT( | |
5172 | & ' DT_PHOINI: PHOJET initialized for target emulsion ', | |
5173 | & /,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3) | |
5174 | 1003 FORMAT( | |
5175 | & ' DT_PHOINI: PHOJET initialized for target A,Z = ', | |
5176 | & I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3) | |
5177 | WRITE(LOUT,1004) ECMINI | |
5178 | 1004 FORMAT(' E_cm = ',E10.3) | |
5179 | IF (IJP.EQ.8) WRITE(LOUT,1005) | |
5180 | 1005 FORMAT( | |
5181 | & ' DT_PHOINI: warning! proton parameters used for neutron', | |
5182 | & ' projectile') | |
5183 | LSTART = .FALSE. | |
5184 | ENDIF | |
5185 | * switch off new diffractive cross sections at low energies for nuclei | |
5186 | * (temporary solution) | |
5187 | IF ((ISWMDL(30).NE.0).AND.((IP.GT.1).OR.(IT.GT.1))) THEN | |
5188 | WRITE(LOUT,'(1X,A)') | |
5189 | & ' DT_PHOINI: model-switch 30 for nuclei re-set !' | |
5190 | CALL PHO_SETMDL(30,0,1) | |
5191 | ENDIF | |
5192 | * | |
5193 | C IF (IJP.EQ.7) THEN | |
5194 | C AMP2 = SIGN(PMASS(1)**2,PMASS(1)) | |
5195 | C PP(3) = PPCM | |
5196 | C PP(4) = SQRT(AMP2+PP(3)**2) | |
5197 | C ELSE | |
5198 | C PFERMX = ZERO | |
5199 | C IF (IP.GT.1) PFERMX = 0.5D0 | |
5200 | C EFERMX = SQRT(PFERMX**2+PMASS(1)**2) | |
5201 | C CALL DT_LTNUC(PFERMX,EFERMX,PP(3),PP(4),2) | |
5202 | C ENDIF | |
5203 | C PFERMX = ZERO | |
5204 | C IF ((IT.GT.1).OR.(NCOMPO.GT.0)) PFERMX = -0.5D0 | |
5205 | C EFERMX = SQRT(PFERMX**2+PMASS(2)**2) | |
5206 | C CALL DT_LTNUC(PFERMX,EFERMX,PT(3),PT(4),3) | |
5207 | **sr 26.10.96 | |
5208 | ISAV = IPAMDL(13) | |
5209 | IF ((ISHAD(2).EQ.1).AND. | |
5210 | & ((IJPROJ.EQ. 7).OR.(IJPROJ.EQ.3).OR.(IJPROJ.EQ.4).OR. | |
5211 | & (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11))) IPAMDL(13) = 1 | |
5212 | ** | |
5213 | ||
5214 | CALL PHO_EVENT(-1,PP,PT,SIGMAX,IREJ1) | |
5215 | ||
5216 | **sr 26.10.96 | |
5217 | IPAMDL(13) = ISAV | |
5218 | ** | |
5219 | * | |
5220 | * patch for cascade calculations: | |
5221 | * define parton distribution functions for other hadrons, i.e. other | |
5222 | * then defined already in phojet | |
5223 | IF (IOGLB.EQ.100) THEN | |
5224 | WRITE(LOUT,1006) | |
5225 | 1006 FORMAT(/,1X,'PHOINI: additional parton distribution functions', | |
5226 | & ' assiged (ID,IPAR,ISET)',/) | |
5227 | NPDF = 0 | |
5228 | DO 3 I=1,30 | |
5229 | IF (IPARPD(I).NE.0) THEN | |
5230 | NPDF = NPDF+1 | |
5231 | IF (NPDF.GT.MAXPDF) STOP ' PHOINI: npdf > maxpdf !' | |
5232 | IF ((IPARPD(I).GT.0).AND.(ISETPD(I).GT.0)) THEN | |
5233 | IDPDG = IDT_IPDGHA(I) | |
5234 | IPAR = IPARPD(I) | |
5235 | ISET = ISETPD(I) | |
5236 | WRITE(LOUT,'(13X,A8,3I6)') ANAME(I),IDPDG,IPAR,ISET | |
5237 | CALL PHO_SETPDF(IDPDG,IDUM,IPAR,ISET,0,0,-1) | |
5238 | ENDIF | |
5239 | ENDIF | |
5240 | 3 CONTINUE | |
5241 | ENDIF | |
5242 | ||
5243 | C CALL PHO_PHIST(-1,SIGMAX) | |
5244 | ||
5245 | IF (IREJ1.NE.0) THEN | |
5246 | WRITE(LOUT,1000) | |
5247 | 1000 FORMAT(1X,'PHOINI: PHOJET event-initialization failed!') | |
5248 | STOP | |
5249 | ENDIF | |
5250 | ||
5251 | RETURN | |
5252 | END | |
5253 | ||
5254 | *$ CREATE DT_EVENTD.FOR | |
5255 | *COPY DT_EVENTD | |
5256 | * | |
5257 | *===eventd=============================================================* | |
5258 | * | |
5259 | SUBROUTINE DT_EVENTD(IREJ) | |
5260 | ||
5261 | ************************************************************************ | |
5262 | * Quasi-elastic neutrino nucleus scattering. * | |
5263 | * This version dated 29.04.00 is written by S. Roesler. * | |
5264 | ************************************************************************ | |
5265 | ||
5266 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
5267 | SAVE | |
5268 | ||
5269 | PARAMETER ( LINP = 10 , | |
5270 | & LOUT = 6 , | |
5271 | & LDAT = 9 ) | |
5272 | ||
5273 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY5=1.0D-5) | |
5274 | PARAMETER (SQTINF=1.0D+15) | |
5275 | ||
5276 | LOGICAL LFIRST | |
5277 | ||
5278 | * event history | |
5279 | ||
5280 | PARAMETER (NMXHKK=200000) | |
5281 | ||
5282 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
5283 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
5284 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
5285 | ||
5286 | * extended event history | |
5287 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
5288 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
5289 | & IHIST(2,NMXHKK) | |
5290 | ||
5291 | * flags for input different options | |
5292 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
5293 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
5294 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
5295 | PARAMETER (MAXLND=4000) | |
5296 | COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5) | |
5297 | ||
5298 | * properties of interacting particles | |
5299 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
5300 | ||
5301 | * Lorentz-parameters of the current interaction | |
5302 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
5303 | & UMO,PPCM,EPROJ,PPROJ | |
5304 | ||
5305 | * nuclear potential | |
5306 | LOGICAL LFERMI | |
5307 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, | |
5308 | & EBINDP(2),EBINDN(2),EPOT(2,210), | |
5309 | & ETACOU(2),ICOUL,LFERMI | |
5310 | ||
5311 | * steering flags for qel neutrino scattering modules | |
5312 | COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC | |
5313 | ||
5314 | COMMON /QNPOL/ POLARX(4),PMODUL | |
5315 | ||
5316 | INTEGER PYK | |
5317 | ||
5318 | DATA LFIRST /.TRUE./ | |
5319 | ||
5320 | IREJ = 0 | |
5321 | ||
5322 | IF (LFIRST) THEN | |
5323 | LFIRST = .FALSE. | |
5324 | CALL DT_MASS_INI | |
5325 | ENDIF | |
5326 | ||
5327 | * JETSET parameter | |
5328 | CALL DT_INITJS(0) | |
5329 | ||
5330 | * interacting target nucleon | |
5331 | LTYP = NEUTYP | |
5332 | IF (NEUDEC.LE.9) THEN | |
5333 | IF ((LTYP.EQ.1).OR.(LTYP.EQ.3).OR.(LTYP.EQ.5)) THEN | |
5334 | NUCTYP = 2112 | |
5335 | NUCTOP = 2 | |
5336 | ELSE | |
5337 | NUCTYP = 2212 | |
5338 | NUCTOP = 1 | |
5339 | ENDIF | |
5340 | ELSE | |
5341 | RTYP = DT_RNDM(RTYP) | |
5342 | ZFRAC = DBLE(ITZ)/DBLE(IT) | |
5343 | IF (RTYP.LE.ZFRAC) THEN | |
5344 | NUCTYP = 2212 | |
5345 | NUCTOP = 1 | |
5346 | ELSE | |
5347 | NUCTYP = 2112 | |
5348 | NUCTOP = 2 | |
5349 | ENDIF | |
5350 | ENDIF | |
5351 | ||
5352 | * select first nucleon in list with matching id and reset all other | |
5353 | * nucleons which have been marked as "wounded" by ININUC | |
5354 | IFOUND = 0 | |
5355 | DO 1 I=1,NHKK | |
5356 | IF ((IDHKK(I).EQ.NUCTYP).AND.(IFOUND.EQ.0)) THEN | |
5357 | ISTHKK(I) = 12 | |
5358 | IFOUND = 1 | |
5359 | IDX = I | |
5360 | ELSE | |
5361 | IF (ISTHKK(I).EQ.12) ISTHKK(I) = 14 | |
5362 | ENDIF | |
5363 | 1 CONTINUE | |
5364 | IF (IFOUND.EQ.0) | |
5365 | & STOP ' EVENTD: interacting target nucleon not found! ' | |
5366 | ||
5367 | * correct position of proj. lepton: assume position of target nucleon | |
5368 | DO 3 I=1,4 | |
5369 | VHKK(I,1) = VHKK(I,IDX) | |
5370 | WHKK(I,1) = WHKK(I,IDX) | |
5371 | 3 CONTINUE | |
5372 | ||
5373 | * load initial momenta for conservation check | |
5374 | IF (LEMCCK) THEN | |
5375 | CALL DT_EVTEMC(ZERO,ZERO,PPROJ,EPROJ,1,IDUM,IDUM) | |
5376 | CALL DT_EVTEMC(PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),PHKK(4,IDX), | |
5377 | & 2,IDUM,IDUM) | |
5378 | ENDIF | |
5379 | ||
5380 | * quasi-elastic scattering | |
5381 | IF (NEUDEC.LT.9) THEN | |
5382 | CALL DT_QEL_POL(EPROJ,LTYP,PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX), | |
5383 | & PHKK(4,IDX),PHKK(5,IDX)) | |
5384 | * CC event on p or n | |
5385 | ELSEIF (NEUDEC.EQ.10) THEN | |
5386 | CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,1,PHKK(1,IDX),PHKK(2,IDX), | |
5387 | & PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX)) | |
5388 | * NC event on p or n | |
5389 | ELSEIF (NEUDEC.EQ.11) THEN | |
5390 | CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,2,PHKK(1,IDX),PHKK(2,IDX), | |
5391 | & PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX)) | |
5392 | ENDIF | |
5393 | ||
5394 | * get final state particles from Lund-common and write them into HKKEVT | |
5395 | NPOINT(1) = NHKK+1 | |
5396 | NPOINT(4) = NHKK+1 | |
5397 | ||
5398 | NLINES = PYK(0,1) | |
5399 | ||
5400 | NHKK0 = NHKK+1 | |
5401 | DO 4 I=4,NLINES | |
5402 | IF (K(I,1).EQ.1) THEN | |
5403 | ID = K(I,2) | |
5404 | PX = P(I,1) | |
5405 | PY = P(I,2) | |
5406 | PZ = P(I,3) | |
5407 | PE = P(I,4) | |
5408 | CALL DT_EVTPUT(1,ID,1,IDX,PX,PY,PZ,PE,0,0,0) | |
5409 | IDBJ = IDT_ICIHAD(ID) | |
5410 | EKIN = PHKK(4,NHKK)-PHKK(5,NHKK) | |
5411 | IF ((IDBJ.EQ.1).OR.(IDBJ.EQ.8)) THEN | |
5412 | IF (EKIN.LE.EPOT(2,IDBJ)) ISTHKK(NHKK) = 16 | |
5413 | ENDIF | |
5414 | VHKK(1,NHKK) = VHKK(1,IDX) | |
5415 | VHKK(2,NHKK) = VHKK(2,IDX) | |
5416 | VHKK(3,NHKK) = VHKK(3,IDX) | |
5417 | VHKK(4,NHKK) = VHKK(4,IDX) | |
5418 | C IF (I.EQ.4) THEN | |
5419 | C WHKK(1,NHKK) = POLARX(1) | |
5420 | C WHKK(2,NHKK) = POLARX(2) | |
5421 | C WHKK(3,NHKK) = POLARX(3) | |
5422 | C WHKK(4,NHKK) = POLARX(4) | |
5423 | C ELSE | |
5424 | WHKK(1,NHKK) = WHKK(1,IDX) | |
5425 | WHKK(2,NHKK) = WHKK(2,IDX) | |
5426 | WHKK(3,NHKK) = WHKK(3,IDX) | |
5427 | WHKK(4,NHKK) = WHKK(4,IDX) | |
5428 | C ENDIF | |
5429 | IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM) | |
5430 | ENDIF | |
5431 | 4 CONTINUE | |
5432 | ||
5433 | IF (LEMCCK) THEN | |
5434 | CHKLEV = TINY5 | |
5435 | CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,778,IREJ1) | |
5436 | IF (IREJ1.NE.0) CALL DT_EVTOUT(4) | |
5437 | ENDIF | |
5438 | ||
5439 | * transform momenta into cms (as required for inc etc.) | |
5440 | DO 5 I=NHKK0,NHKK | |
5441 | IF (ISTHKK(I).EQ.1) THEN | |
5442 | CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,3) | |
5443 | PHKK(3,I) = PZ | |
5444 | PHKK(4,I) = PE | |
5445 | ENDIF | |
5446 | 5 CONTINUE | |
5447 | ||
5448 | RETURN | |
5449 | END | |
5450 | *$ CREATE DT_KKEVNT.FOR | |
5451 | *COPY DT_KKEVNT | |
5452 | * | |
5453 | *===kkevnt=============================================================* | |
5454 | * | |
5455 | SUBROUTINE DT_KKEVNT(KKMAT,IREJ) | |
5456 | ||
5457 | ************************************************************************ | |
5458 | * Treatment of complete nucleus-nucleus or hadron-nucleus scattering * | |
5459 | * without nuclear effects (one event). * | |
5460 | * This subroutine is an update of the previous version (KKEVT) written * | |
5461 | * by J. Ranft/ H.-J. Moehring. * | |
5462 | * This version dated 20.04.95 is written by S. Roesler * | |
5463 | ************************************************************************ | |
5464 | ||
5465 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
5466 | SAVE | |
5467 | ||
5468 | PARAMETER ( LINP = 10 , | |
5469 | & LOUT = 6 , | |
5470 | & LDAT = 9 ) | |
5471 | ||
5472 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10) | |
5473 | ||
5474 | PARAMETER ( MAXNCL = 260, | |
5475 | ||
5476 | & MAXVQU = MAXNCL, | |
5477 | & MAXSQU = 20*MAXVQU, | |
5478 | & MAXINT = MAXVQU+MAXSQU) | |
5479 | ||
5480 | * event history | |
5481 | ||
5482 | PARAMETER (NMXHKK=200000) | |
5483 | ||
5484 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
5485 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
5486 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
5487 | ||
5488 | * extended event history | |
5489 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
5490 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
5491 | & IHIST(2,NMXHKK) | |
5492 | ||
5493 | * flags for input different options | |
5494 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
5495 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
5496 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
5497 | ||
5498 | * rejection counter | |
5499 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
5500 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
5501 | & IREXCI(3),IRDIFF(2),IRINC | |
5502 | ||
5503 | * statistics | |
5504 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
5505 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
5506 | & ICEVTG(8,0:30) | |
5507 | ||
5508 | * properties of interacting particles | |
5509 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
5510 | ||
5511 | * Lorentz-parameters of the current interaction | |
5512 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
5513 | & UMO,PPCM,EPROJ,PPROJ | |
5514 | ||
5515 | * flags for diffractive interactions (DTUNUC 1.x) | |
5516 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF | |
5517 | ||
5518 | * interface HADRIN-DPM | |
5519 | COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA | |
5520 | ||
5521 | * nucleon-nucleon event-generator | |
5522 | CHARACTER*8 CMODEL | |
5523 | LOGICAL LPHOIN | |
5524 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
5525 | ||
5526 | * coordinates of nucleons | |
5527 | COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL) | |
5528 | ||
5529 | * interface between Glauber formalism and DPM | |
5530 | COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL), | |
5531 | & INTER1(MAXINT),INTER2(MAXINT) | |
5532 | ||
5533 | * Glauber formalism: collision properties | |
5534 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, | |
5535 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC | |
5536 | ||
5537 | * central particle production, impact parameter biasing | |
5538 | COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR | |
5539 | **temporary | |
5540 | ||
5541 | * statistics: Glauber-formalism | |
5542 | COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB | |
5543 | ** | |
5544 | ||
5545 | DATA NEVOLD,IPOLD,ITOLD,JJPOLD,EPROLD /4*0,0.0D0/ | |
5546 | ||
5547 | IREJ = 0 | |
5548 | ICREQU = ICREQU+1 | |
5549 | NC = 0 | |
5550 | ||
5551 | 1 CONTINUE | |
5552 | ICSAMP = ICSAMP+1 | |
5553 | NC = NC+1 | |
5554 | IF (MOD(NC,10).EQ.0) THEN | |
5555 | WRITE(LOUT,1000) NEVHKK | |
5556 | 1000 FORMAT(1X,'KKEVNT: event ',I8,' rejected!') | |
5557 | GOTO 9999 | |
5558 | ENDIF | |
5559 | ||
5560 | * initialize DTEVT1/DTEVT2 | |
5561 | CALL DT_EVTINI | |
5562 | ||
5563 | * We need the following only in order to sample nucleon coordinates. | |
5564 | * However we don't have parameters (cross sections, slope etc.) | |
5565 | * for neutrinos available. Therefore switch projectile to proton | |
5566 | * in this case. | |
5567 | IF (MCGENE.EQ.4) THEN | |
5568 | JJPROJ = 1 | |
5569 | ELSE | |
5570 | JJPROJ = IJPROJ | |
5571 | ENDIF | |
5572 | ||
5573 | 10 CONTINUE | |
5574 | IF ( (NEVHKK.NE.NEVOLD).OR.(ICENTR.GT.0).OR. | |
5575 | * make sure that Glauber-formalism is called each time the interaction | |
5576 | * configuration changed | |
5577 | & (IP.NE.IPOLD).OR.(IT.NE.ITOLD).OR.(JJPROJ.NE.JJPOLD).OR. | |
5578 | & (ABS(EPROJ-EPROLD).GT.TINY10) ) THEN | |
5579 | * sample number of nucleon-nucleon coll. according to Glauber-form. | |
5580 | CALL DT_GLAUBE(IP,IT,JJPROJ,BIMPAC,NN,NP,NT,JSSH,JTSH,KKMAT) | |
5581 | NWTSAM = NN | |
5582 | NWASAM = NP | |
5583 | NWBSAM = NT | |
5584 | NEVOLD = NEVHKK | |
5585 | IPOLD = IP | |
5586 | ITOLD = IT | |
5587 | JJPOLD = JJPROJ | |
5588 | EPROLD = EPROJ | |
5589 | ENDIF | |
5590 | ||
5591 | * force diffractive particle production in h-K interactions | |
5592 | IF (((ABS(ISINGD).GT.1).OR.(ABS(IDOUBD).GT.1)).AND. | |
5593 | & (IP.EQ.1).AND.(NN.NE.1)) THEN | |
5594 | NEVOLD = 0 | |
5595 | GOTO 10 | |
5596 | ENDIF | |
5597 | ||
5598 | * check number of involved proj. nucl. (NP) if central prod.is requested | |
5599 | IF (ICENTR.GT.0) THEN | |
5600 | CALL DT_CHKCEN(IP,IT,NP,NT,IBACK) | |
5601 | IF (IBACK.GT.0) GOTO 10 | |
5602 | ENDIF | |
5603 | ||
5604 | * get initial nucleon-configuration in projectile and target | |
5605 | * rest-system (including Fermi-momenta if requested) | |
5606 | CALL DT_ININUC(IJPROJ,IP,IPZ,PKOO,JSSH,1) | |
5607 | MODE = 2 | |
5608 | IF (EPROJ.LE.EHADTH) MODE = 3 | |
5609 | CALL DT_ININUC(IJTARG,IT,ITZ,TKOO,JTSH,MODE) | |
5610 | ||
5611 | IF ((MCGENE.NE.3).AND.(MCGENE.NE.4)) THEN | |
5612 | ||
5613 | * activate HADRIN at low energies (implemented for h-N scattering only) | |
5614 | IF (EPROJ.LE.EHADHI) THEN | |
5615 | IF (EHADTH.LT.ZERO) THEN | |
5616 | * smooth transition btwn. DPM and HADRIN | |
5617 | FRAC = (EPROJ-EHADLO)/(EHADHI-EHADLO) | |
5618 | RR = DT_RNDM(FRAC) | |
5619 | IF (RR.GT.FRAC) THEN | |
5620 | IF (IP.EQ.1) THEN | |
5621 | CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1) | |
5622 | IF (IREJ1.GT.0) GOTO 1 | |
5623 | RETURN | |
5624 | ELSE | |
5625 | WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH | |
5626 | ENDIF | |
5627 | ENDIF | |
5628 | ELSE | |
5629 | * fixed threshold for onset of production via HADRIN | |
5630 | IF (EPROJ.LE.EHADTH) THEN | |
5631 | IF (IP.EQ.1) THEN | |
5632 | CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1) | |
5633 | IF (IREJ1.GT.0) GOTO 1 | |
5634 | RETURN | |
5635 | ELSE | |
5636 | WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH | |
5637 | ENDIF | |
5638 | ENDIF | |
5639 | ENDIF | |
5640 | ENDIF | |
5641 | 1001 FORMAT(1X,'KKEVNT: warning! interaction of proj. (m=', | |
5642 | & I3,') with target (m=',I3,')',/,11X, | |
5643 | & 'at E_lab=',F5.1,'GeV (threshold-energy: ',F3.1, | |
5644 | & 'GeV) cannot be handled') | |
5645 | ||
5646 | * sampling of momentum-x fractions & flavors of chain ends | |
5647 | CALL DT_SPLPTN(NN) | |
5648 | ||
5649 | * Lorentz-transformation of wounded nucleons into nucl.-nucl. cms | |
5650 | CALL DT_NUC2CM | |
5651 | ||
5652 | * collect momenta of chain ends and put them into DTEVT1 | |
5653 | CALL DT_GETPTN(IP,NN,NCSY,IREJ1) | |
5654 | IF (IREJ1.NE.0) GOTO 1 | |
5655 | ||
5656 | ENDIF | |
5657 | ||
5658 | * handle chains including fragmentation (two-chain approximation) | |
5659 | IF (MCGENE.EQ.1) THEN | |
5660 | * two-chain approximation | |
5661 | CALL DT_EVENTA(IJPROJ,IP,IT,NCSY,IREJ1) | |
5662 | IF (IREJ1.NE.0) THEN | |
5663 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKEVNT' | |
5664 | GOTO 1 | |
5665 | ENDIF | |
5666 | ELSEIF (MCGENE.EQ.2) THEN | |
5667 | * multiple-Po exchange including minijets | |
5668 | CALL DT_EVENTB(NCSY,IREJ1) | |
5669 | IF (IREJ1.NE.0) THEN | |
5670 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKEVNT' | |
5671 | GOTO 1 | |
5672 | ENDIF | |
5673 | ELSEIF (MCGENE.EQ.3) THEN | |
5674 | STOP ' This version does not contain LEPTO !' | |
5675 | ||
5676 | ELSEIF (MCGENE.EQ.4) THEN | |
5677 | * quasi-elastic neutrino scattering | |
5678 | CALL DT_EVENTD(IREJ1) | |
5679 | IF (IREJ1.NE.0) THEN | |
5680 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 4 in KKEVNT' | |
5681 | GOTO 1 | |
5682 | ENDIF | |
5683 | ELSE | |
5684 | WRITE(LOUT,1002) MCGENE | |
5685 | 1002 FORMAT(1X,'KKEVNT: warning! event-generator',I4, | |
5686 | & ' not available - program stopped') | |
5687 | STOP | |
5688 | ENDIF | |
5689 | ||
5690 | RETURN | |
5691 | ||
5692 | 9999 CONTINUE | |
5693 | IREJ = 1 | |
5694 | RETURN | |
5695 | END | |
5696 | ||
5697 | *$ CREATE DT_CHKCEN.FOR | |
5698 | *COPY DT_CHKCEN | |
5699 | * | |
5700 | *===chkcen=============================================================* | |
5701 | * | |
5702 | SUBROUTINE DT_CHKCEN(IP,IT,NP,NT,IBACK) | |
5703 | ||
5704 | ************************************************************************ | |
5705 | * Check of number of involved projectile nucleons if central production* | |
5706 | * is requested. * | |
5707 | * Adopted from a part of the old KKEVT routine which was written by * | |
5708 | * J. Ranft/H.-J.Moehring. * | |
5709 | * This version dated 13.01.95 is written by S. Roesler * | |
5710 | ************************************************************************ | |
5711 | ||
5712 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
5713 | SAVE | |
5714 | ||
5715 | PARAMETER ( LINP = 10 , | |
5716 | & LOUT = 6 , | |
5717 | & LDAT = 9 ) | |
5718 | ||
5719 | * statistics | |
5720 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
5721 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
5722 | & ICEVTG(8,0:30) | |
5723 | ||
5724 | * central particle production, impact parameter biasing | |
5725 | COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR | |
5726 | ||
5727 | IBACK = 0 | |
5728 | ||
5729 | * old version | |
5730 | IF (ICENTR.EQ.2) THEN | |
5731 | IF (IP.LT.IT) THEN | |
5732 | IF (IP.LE.8) THEN | |
5733 | IF (NP.LT.IP-1) IBACK = 1 | |
5734 | ELSEIF (IP.LE.16) THEN | |
5735 | IF (NP.LT.IP-2) IBACK = 1 | |
5736 | ELSEIF (IP.LE.32) THEN | |
5737 | IF (NP.LT.IP-3) IBACK = 1 | |
5738 | ELSEIF (IP.GE.33) THEN | |
5739 | IF (NP.LT.IP-5) IBACK = 1 | |
5740 | ENDIF | |
5741 | ELSEIF (IP.EQ.IT) THEN | |
5742 | IF (IP.EQ.32) THEN | |
5743 | IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1 | |
5744 | ELSE | |
5745 | IF (NP.LT.IP-IP/8) IBACK = 1 | |
5746 | ENDIF | |
5747 | ELSEIF (ABS(IP-IT).LT.3) THEN | |
5748 | IF (NP.LT.IP-IP/8) IBACK = 1 | |
5749 | ENDIF | |
5750 | ELSE | |
5751 | * new version (DPMJET, 5.6.99) | |
5752 | IF (IP.LT.IT) THEN | |
5753 | IF (IP.LE.8) THEN | |
5754 | IF (NP.LT.IP-1) IBACK = 1 | |
5755 | ELSEIF (IP.LE.16) THEN | |
5756 | IF (NP.LT.IP-2) IBACK = 1 | |
5757 | ELSEIF (IP.LT.32) THEN | |
5758 | IF (NP.LT.IP-3) IBACK = 1 | |
5759 | ELSEIF (IP.GE.32) THEN | |
5760 | IF (IT.LE.150) THEN | |
5761 | * Example: S-Ag | |
5762 | IF (NP.LT.IP-1) IBACK = 1 | |
5763 | ELSE | |
5764 | * Example: S-Au | |
5765 | IF (NP.LT.IP) IBACK = 1 | |
5766 | ENDIF | |
5767 | ENDIF | |
5768 | ELSEIF (IP.EQ.IT) THEN | |
5769 | * Example: S-S | |
5770 | IF (IP.EQ.32) THEN | |
5771 | IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1 | |
5772 | * Example: Pb-Pb | |
5773 | ELSE | |
5774 | IF (NP.LT.IP-IP/4) IBACK = 1 | |
5775 | ENDIF | |
5776 | ELSEIF (ABS(IP-IT).LT.3) THEN | |
5777 | IF (NP.LT.IP-IP/8) IBACK = 1 | |
5778 | ENDIF | |
5779 | ENDIF | |
5780 | ||
5781 | ICCPRO = ICCPRO+1 | |
5782 | ||
5783 | RETURN | |
5784 | END | |
5785 | ||
5786 | *$ CREATE DT_ININUC.FOR | |
5787 | *COPY DT_ININUC | |
5788 | * | |
5789 | *===ininuc=============================================================* | |
5790 | * | |
5791 | SUBROUTINE DT_ININUC(ID,NMASS,NCH,COORD,JS,IMODE) | |
5792 | ||
5793 | ************************************************************************ | |
5794 | * Samples initial configuration of nucleons in nucleus with mass NMASS * | |
5795 | * including Fermi-momenta (if reqested). * | |
5796 | * ID BAMJET-code for hadrons (instead of nuclei) * | |
5797 | * NMASS mass number of nucleus (number of nucleons) * | |
5798 | * NCH charge of nucleus * | |
5799 | * COORD(3,NMASS) coordinates of nucleons inside nucleus in fm * | |
5800 | * JS(NMASS) > 0 nucleon undergoes nucleon-nucleon interact. * | |
5801 | * IMODE = 1 projectile nucleus * | |
5802 | * = 2 target nucleus * | |
5803 | * = 3 target nucleus (E_lab<E_thr for HADRIN) * | |
5804 | * Adopted from a part of the old KKEVT routine which was written by * | |
5805 | * J. Ranft/H.-J.Moehring. * | |
5806 | * This version dated 13.01.95 is written by S. Roesler * | |
5807 | ************************************************************************ | |
5808 | ||
5809 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
5810 | SAVE | |
5811 | ||
5812 | PARAMETER ( LINP = 10 , | |
5813 | & LOUT = 6 , | |
5814 | & LDAT = 9 ) | |
5815 | ||
5816 | PARAMETER (FM2MM=1.0D-12) | |
5817 | ||
5818 | PARAMETER ( MAXNCL = 260, | |
5819 | ||
5820 | & MAXVQU = MAXNCL, | |
5821 | & MAXSQU = 20*MAXVQU, | |
5822 | & MAXINT = MAXVQU+MAXSQU) | |
5823 | ||
5824 | * event history | |
5825 | ||
5826 | PARAMETER (NMXHKK=200000) | |
5827 | ||
5828 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
5829 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
5830 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
5831 | ||
5832 | * extended event history | |
5833 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
5834 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
5835 | & IHIST(2,NMXHKK) | |
5836 | ||
5837 | * flags for input different options | |
5838 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
5839 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
5840 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
5841 | ||
5842 | * auxiliary common for chain system storage (DTUNUC 1.x) | |
5843 | COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL) | |
5844 | ||
5845 | * nuclear potential | |
5846 | LOGICAL LFERMI | |
5847 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, | |
5848 | & EBINDP(2),EBINDN(2),EPOT(2,210), | |
5849 | & ETACOU(2),ICOUL,LFERMI | |
5850 | ||
5851 | * properties of photon/lepton projectiles | |
5852 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC | |
5853 | ||
5854 | * particle properties (BAMJET index convention) | |
5855 | CHARACTER*8 ANAME | |
5856 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
5857 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
5858 | ||
5859 | * Glauber formalism: collision properties | |
5860 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, | |
5861 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC | |
5862 | ||
5863 | * flavors of partons (DTUNUC 1.x) | |
5864 | COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU), | |
5865 | & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU), | |
5866 | & IPSQ(MAXSQU),IPSQ2(MAXSQU), | |
5867 | & IPSAQ(MAXSQU),IPSAQ2(MAXSQU), | |
5868 | & ITSQ(MAXSQU),ITSQ2(MAXSQU), | |
5869 | & ITSAQ(MAXSQU),ITSAQ2(MAXSQU), | |
5870 | & KKPROJ(MAXVQU),KKTARG(MAXVQU) | |
5871 | ||
5872 | * interface HADRIN-DPM | |
5873 | COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA | |
5874 | ||
5875 | DIMENSION PF(4),PFTOT(4),COORD(3,MAXNCL),JS(MAXNCL) | |
5876 | ||
5877 | * number of neutrons | |
5878 | NNEU = NMASS-NCH | |
5879 | * initializations | |
5880 | NP = 0 | |
5881 | NN = 0 | |
5882 | DO 1 K=1,4 | |
5883 | PFTOT(K) = 0.0D0 | |
5884 | 1 CONTINUE | |
5885 | MODE = IMODE | |
5886 | IF (IMODE.GT.2) MODE = 2 | |
5887 | **sr 29.5. new NPOINT(1)-definition | |
5888 | C IF (IMODE.GE.2) NPOINT(1) = NHKK+1 | |
5889 | ** | |
5890 | NHADRI = 0 | |
5891 | NC = NHKK | |
5892 | ||
5893 | * get initial configuration | |
5894 | DO 2 I=1,NMASS | |
5895 | NHKK = NHKK+1 | |
5896 | IF (JS(I).GT.0) THEN | |
5897 | ISTHKK(NHKK) = 10+MODE | |
5898 | IF (IMODE.EQ.3) THEN | |
5899 | * additional treatment if HADRIN-generator is requested | |
5900 | NHADRI = NHADRI+1 | |
5901 | IF (NHADRI.EQ.1) IDXTA = NHKK | |
5902 | IF (NHADRI.GT.1) ISTHKK(NHKK) = 14 | |
5903 | ENDIF | |
5904 | ELSE | |
5905 | ISTHKK(NHKK) = 12+MODE | |
5906 | ENDIF | |
5907 | IF (NMASS.GE.2) THEN | |
5908 | * treatment for nuclei | |
5909 | FRAC = 1.0D0-DBLE(NCH)/DBLE(NMASS) | |
5910 | RR = DT_RNDM(FRAC) | |
5911 | IF ((RR.LT.FRAC).AND.(NN.LT.NNEU)) THEN | |
5912 | IDX = 8 | |
5913 | NN = NN+1 | |
5914 | ELSEIF ((RR.GE.FRAC).AND.(NP.LT.NCH)) THEN | |
5915 | IDX = 1 | |
5916 | NP = NP+1 | |
5917 | ELSEIF (NN.LT.NNEU) THEN | |
5918 | IDX = 8 | |
5919 | NN = NN+1 | |
5920 | ELSEIF (NP.LT.NCH) THEN | |
5921 | IDX = 1 | |
5922 | NP = NP+1 | |
5923 | ENDIF | |
5924 | IDHKK(NHKK) = IDT_IPDGHA(IDX) | |
5925 | IDBAM(NHKK) = IDX | |
5926 | IF (MODE.EQ.1) THEN | |
5927 | IPOSP(I) = NHKK | |
5928 | KKPROJ(I) = IDX | |
5929 | ELSE | |
5930 | IPOST(I) = NHKK | |
5931 | KKTARG(I) = IDX | |
5932 | ENDIF | |
5933 | IF (IDX.EQ.1) THEN | |
5934 | PFER = PFERMP(MODE) | |
5935 | PBIN = SQRT(2.0D0*EBINDP(MODE)*AAM(1)) | |
5936 | ELSE | |
5937 | PFER = PFERMN(MODE) | |
5938 | PBIN = SQRT(2.0D0*EBINDN(MODE)*AAM(8)) | |
5939 | ENDIF | |
5940 | CALL DT_FER4M(PFER,PBIN,PF(1),PF(2),PF(3),PF(4),IDX) | |
5941 | DO 3 K=1,4 | |
5942 | PFTOT(K) = PFTOT(K)+PF(K) | |
5943 | PHKK(K,NHKK) = PF(K) | |
5944 | 3 CONTINUE | |
5945 | PHKK(5,NHKK) = AAM(IDX) | |
5946 | ELSE | |
5947 | * treatment for hadrons | |
5948 | IDHKK(NHKK) = IDT_IPDGHA(ID) | |
5949 | IDBAM(NHKK) = ID | |
5950 | PHKK(4,NHKK) = AAM(ID) | |
5951 | PHKK(5,NHKK) = AAM(ID) | |
5952 | C* VDM assumption | |
5953 | C IF (IDHKK(NHKK).EQ.22) THEN | |
5954 | C PHKK(4,NHKK) = AAM(33) | |
5955 | C PHKK(5,NHKK) = AAM(33) | |
5956 | C ENDIF | |
5957 | IF (MODE.EQ.1) THEN | |
5958 | IPOSP(I) = NHKK | |
5959 | KKPROJ(I) = ID | |
5960 | PHKK(5,NHKK) = PHKK(5,NHKK)-SQRT(VIRT) | |
5961 | ELSE | |
5962 | IPOST(I) = NHKK | |
5963 | KKTARG(I) = ID | |
5964 | ENDIF | |
5965 | ENDIF | |
5966 | DO 4 K=1,3 | |
5967 | VHKK(K,NHKK) = COORD(K,I)*FM2MM | |
5968 | WHKK(K,NHKK) = COORD(K,I)*FM2MM | |
5969 | 4 CONTINUE | |
5970 | IF (MODE.EQ.2) VHKK(1,NHKK) = VHKK(1,NHKK)+BIMPAC*FM2MM | |
5971 | IF (MODE.EQ.2) WHKK(1,NHKK) = WHKK(1,NHKK)+BIMPAC*FM2MM | |
5972 | VHKK(4,NHKK) = 0.0D0 | |
5973 | WHKK(4,NHKK) = 0.0D0 | |
5974 | 2 CONTINUE | |
5975 | ||
5976 | * balance Fermi-momenta | |
5977 | IF (NMASS.GE.2) THEN | |
5978 | DO 5 I=1,NMASS | |
5979 | NC = NC+1 | |
5980 | DO 6 K=1,3 | |
5981 | PHKK(K,NC) = PHKK(K,NC)-PFTOT(K)/DBLE(NMASS) | |
5982 | 6 CONTINUE | |
5983 | PHKK(4,NC) = SQRT(PHKK(5,NC)**2+PHKK(1,NC)**2+ | |
5984 | & PHKK(2,NC)**2+PHKK(3,NC)**2) | |
5985 | 5 CONTINUE | |
5986 | ENDIF | |
5987 | ||
5988 | RETURN | |
5989 | END | |
5990 | ||
5991 | *$ CREATE DT_FER4M.FOR | |
5992 | *COPY DT_FER4M | |
5993 | * | |
5994 | *===fer4m==============================================================* | |
5995 | * | |
5996 | SUBROUTINE DT_FER4M(PFERM,PBIND,PXT,PYT,PZT,ET,KT) | |
5997 | ||
5998 | ************************************************************************ | |
5999 | * Sampling of nucleon Fermi-momenta from distributions at T=0. * | |
6000 | * processed by S. Roesler, 17.10.95 * | |
6001 | ************************************************************************ | |
6002 | ||
6003 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
6004 | SAVE | |
6005 | ||
6006 | PARAMETER ( LINP = 10 , | |
6007 | & LOUT = 6 , | |
6008 | & LDAT = 9 ) | |
6009 | ||
6010 | LOGICAL LSTART | |
6011 | ||
6012 | * particle properties (BAMJET index convention) | |
6013 | CHARACTER*8 ANAME | |
6014 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
6015 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
6016 | ||
6017 | * nuclear potential | |
6018 | LOGICAL LFERMI | |
6019 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, | |
6020 | & EBINDP(2),EBINDN(2),EPOT(2,210), | |
6021 | & ETACOU(2),ICOUL,LFERMI | |
6022 | ||
6023 | DATA LSTART /.TRUE./ | |
6024 | ||
6025 | ILOOP = 0 | |
6026 | IF (LFERMI) THEN | |
6027 | IF (LSTART) THEN | |
6028 | WRITE(LOUT,1000) | |
6029 | 1000 FORMAT(/,1X,'FER4M: sampling of Fermi-momenta activated') | |
6030 | LSTART = .FALSE. | |
6031 | ENDIF | |
6032 | 1 CONTINUE | |
6033 | CALL DT_DFERMI(PABS) | |
6034 | PABS = PFERM*PABS | |
6035 | C IF (PABS.GE.PBIND) THEN | |
6036 | C ILOOP = ILOOP+1 | |
6037 | C IF (MOD(ILOOP,500).EQ.0) THEN | |
6038 | C WRITE(LOUT,1001) PABS,PBIND,ILOOP | |
6039 | C1001 FORMAT(1X,'FER4M: Fermi-mom. corr. for binding', | |
6040 | C & ' energy ',2E12.3,I6) | |
6041 | C ENDIF | |
6042 | C GOTO 1 | |
6043 | C ENDIF | |
6044 | CALL DT_DPOLI(POLC,POLS) | |
6045 | CALL DT_DSFECF(SFE,CFE) | |
6046 | CXTA = POLS*CFE | |
6047 | CYTA = POLS*SFE | |
6048 | CZTA = POLC | |
6049 | ET = SQRT(PABS*PABS+AAM(KT)**2) | |
6050 | PXT = CXTA*PABS | |
6051 | PYT = CYTA*PABS | |
6052 | PZT = CZTA*PABS | |
6053 | ELSE | |
6054 | ET = AAM(KT) | |
6055 | PXT = 0.0D0 | |
6056 | PYT = 0.0D0 | |
6057 | PZT = 0.0D0 | |
6058 | ENDIF | |
6059 | ||
6060 | RETURN | |
6061 | END | |
6062 | ||
6063 | *$ CREATE DT_NUC2CM.FOR | |
6064 | *COPY DT_NUC2CM | |
6065 | * | |
6066 | *===nuc2cm=============================================================* | |
6067 | * | |
6068 | SUBROUTINE DT_NUC2CM | |
6069 | ||
6070 | ************************************************************************ | |
6071 | * Lorentz-transformation of all wounded nucleons from Lab. to nucl.- * | |
6072 | * nucl. cms. (This subroutine replaces NUCMOM.) * | |
6073 | * This version dated 15.01.95 is written by S. Roesler * | |
6074 | ************************************************************************ | |
6075 | ||
6076 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
6077 | SAVE | |
6078 | ||
6079 | PARAMETER ( LINP = 10 , | |
6080 | & LOUT = 6 , | |
6081 | & LDAT = 9 ) | |
6082 | ||
6083 | PARAMETER (ZERO=0.0D0,TINY3=1.0D-3) | |
6084 | ||
6085 | * event history | |
6086 | ||
6087 | PARAMETER (NMXHKK=200000) | |
6088 | ||
6089 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
6090 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
6091 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
6092 | ||
6093 | * extended event history | |
6094 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
6095 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
6096 | & IHIST(2,NMXHKK) | |
6097 | ||
6098 | * statistics | |
6099 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
6100 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
6101 | & ICEVTG(8,0:30) | |
6102 | ||
6103 | * properties of photon/lepton projectiles | |
6104 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC | |
6105 | ||
6106 | * particle properties (BAMJET index convention) | |
6107 | CHARACTER*8 ANAME | |
6108 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
6109 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
6110 | ||
6111 | * Glauber formalism: collision properties | |
6112 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, | |
6113 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC | |
6114 | **temporary | |
6115 | ||
6116 | * statistics: Glauber-formalism | |
6117 | COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB | |
6118 | ** | |
6119 | ||
6120 | ICWP = 0 | |
6121 | ICWT = 0 | |
6122 | NWTACC = 0 | |
6123 | NWAACC = 0 | |
6124 | NWBACC = 0 | |
6125 | ||
6126 | NPOINT(1) = NHKK+1 | |
6127 | NEND = NHKK | |
6128 | DO 1 I=1,NEND | |
6129 | IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.12)) THEN | |
6130 | IF (ISTHKK(I).EQ.11) NWAACC = NWAACC+1 | |
6131 | IF (ISTHKK(I).EQ.12) NWBACC = NWBACC+1 | |
6132 | MODE = ISTHKK(I)-9 | |
6133 | C IF (IDHKK(I).EQ.22) THEN | |
6134 | C* VDM assumption | |
6135 | C PEIN = AAM(33) | |
6136 | C IDB = 33 | |
6137 | C ELSE | |
6138 | C PEIN = PHKK(4,I) | |
6139 | C IDB = IDBAM(I) | |
6140 | C ENDIF | |
6141 | C CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PEIN, | |
6142 | C & PX,PY,PZ,PE,IDB,MODE) | |
6143 | IF (PHKK(5,I).GT.ZERO) THEN | |
6144 | CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I), | |
6145 | & PX,PY,PZ,PE,IDBAM(I),MODE) | |
6146 | ELSE | |
6147 | PX = PGAMM(1) | |
6148 | PY = PGAMM(2) | |
6149 | PZ = PGAMM(3) | |
6150 | PE = PGAMM(4) | |
6151 | ENDIF | |
6152 | IST = ISTHKK(I)-2 | |
6153 | ID = IDHKK(I) | |
6154 | C* VDM assumption | |
6155 | C IF (ID.EQ.22) ID = 113 | |
6156 | CALL DT_EVTPUT(IST,ID,I,0,PX,PY,PZ,PE,0,0,0) | |
6157 | IF (ISTHKK(I).EQ.11) ICWP = ICWP+1 | |
6158 | IF (ISTHKK(I).EQ.12) ICWT = ICWT+1 | |
6159 | ENDIF | |
6160 | 1 CONTINUE | |
6161 | ||
6162 | NWTACC = MAX(NWAACC,NWBACC) | |
6163 | ICDPR = ICDPR+ICWP | |
6164 | ICDTA = ICDTA+ICWT | |
6165 | **temporary | |
6166 | IF ((ICWP.EQ.0).OR.(ICWT.EQ.0)) THEN | |
6167 | CALL DT_EVTOUT(4) | |
6168 | STOP | |
6169 | ENDIF | |
6170 | ||
6171 | RETURN | |
6172 | END | |
6173 | ||
6174 | *$ CREATE DT_SPLPTN.FOR | |
6175 | *COPY DT_SPLPTN | |
6176 | * | |
6177 | *===splptn=============================================================* | |
6178 | * | |
6179 | SUBROUTINE DT_SPLPTN(NN) | |
6180 | ||
6181 | ************************************************************************ | |
6182 | * SamPLing of ParToN momenta and flavors. * | |
6183 | * This version dated 15.01.95 is written by S. Roesler * | |
6184 | ************************************************************************ | |
6185 | ||
6186 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
6187 | SAVE | |
6188 | ||
6189 | PARAMETER ( LINP = 10 , | |
6190 | & LOUT = 6 , | |
6191 | & LDAT = 9 ) | |
6192 | ||
6193 | * Lorentz-parameters of the current interaction | |
6194 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
6195 | & UMO,PPCM,EPROJ,PPROJ | |
6196 | ||
6197 | * sample flavors of sea-quarks | |
6198 | CALL DT_SPLFLA(NN,1) | |
6199 | ||
6200 | * sample x-values of partons at chain ends | |
6201 | ECM = UMO | |
6202 | CALL DT_XKSAMP(NN,ECM) | |
6203 | ||
6204 | * samle flavors | |
6205 | CALL DT_SPLFLA(NN,2) | |
6206 | ||
6207 | RETURN | |
6208 | END | |
6209 | ||
6210 | *$ CREATE DT_SPLFLA.FOR | |
6211 | *COPY DT_SPLFLA | |
6212 | * | |
6213 | *===splfla=============================================================* | |
6214 | * | |
6215 | SUBROUTINE DT_SPLFLA(NN,MODE) | |
6216 | ||
6217 | ************************************************************************ | |
6218 | * SamPLing of FLAvors of partons at chain ends. * | |
6219 | * This subroutine replaces FLKSAA/FLKSAM. * | |
6220 | * NN number of nucleon-nucleon interactions * | |
6221 | * MODE = 1 sea-flavors * | |
6222 | * = 2 valence-flavors * | |
6223 | * Based on the original version written by J. Ranft/H.-J. Moehring. * | |
6224 | * This version dated 16.01.95 is written by S. Roesler * | |
6225 | ************************************************************************ | |
6226 | ||
6227 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
6228 | SAVE | |
6229 | ||
6230 | PARAMETER ( LINP = 10 , | |
6231 | & LOUT = 6 , | |
6232 | & LDAT = 9 ) | |
6233 | ||
6234 | PARAMETER ( MAXNCL = 260, | |
6235 | ||
6236 | & MAXVQU = MAXNCL, | |
6237 | & MAXSQU = 20*MAXVQU, | |
6238 | & MAXINT = MAXVQU+MAXSQU) | |
6239 | ||
6240 | * flavors of partons (DTUNUC 1.x) | |
6241 | COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU), | |
6242 | & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU), | |
6243 | & IPSQ(MAXSQU),IPSQ2(MAXSQU), | |
6244 | & IPSAQ(MAXSQU),IPSAQ2(MAXSQU), | |
6245 | & ITSQ(MAXSQU),ITSQ2(MAXSQU), | |
6246 | & ITSAQ(MAXSQU),ITSAQ2(MAXSQU), | |
6247 | & KKPROJ(MAXVQU),KKTARG(MAXVQU) | |
6248 | ||
6249 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) | |
6250 | COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD, | |
6251 | & IXPV,IXPS,IXTV,IXTS, | |
6252 | & INTVV1(MAXVQU),INTVV2(MAXVQU), | |
6253 | & INTSV1(MAXVQU),INTSV2(MAXVQU), | |
6254 | & INTVS1(MAXVQU),INTVS2(MAXVQU), | |
6255 | & INTSS1(MAXSQU),INTSS2(MAXSQU), | |
6256 | & INTDV1(MAXVQU),INTDV2(MAXVQU), | |
6257 | & INTVD1(MAXVQU),INTVD2(MAXVQU), | |
6258 | & INTDS1(MAXSQU),INTDS2(MAXSQU), | |
6259 | & INTSD1(MAXSQU),INTSD2(MAXSQU) | |
6260 | ||
6261 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) | |
6262 | COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU), | |
6263 | & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU) | |
6264 | ||
6265 | * particle properties (BAMJET index convention) | |
6266 | CHARACTER*8 ANAME | |
6267 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
6268 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
6269 | ||
6270 | * various options for treatment of partons (DTUNUC 1.x) | |
6271 | * (chain recombination, Cronin,..) | |
6272 | LOGICAL LCO2CR,LINTPT | |
6273 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, | |
6274 | & LCO2CR,LINTPT | |
6275 | ||
6276 | IF (MODE.EQ.1) THEN | |
6277 | * sea-flavors | |
6278 | DO 1 I=1,NN | |
6279 | IPSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ)) | |
6280 | IPSAQ(I) = -IPSQ(I) | |
6281 | 1 CONTINUE | |
6282 | DO 2 I=1,NN | |
6283 | ITSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ)) | |
6284 | ITSAQ(I)= -ITSQ(I) | |
6285 | 2 CONTINUE | |
6286 | ELSEIF (MODE.EQ.2) THEN | |
6287 | * valence flavors | |
6288 | DO 3 I=1,IXPV | |
6289 | CALL DT_FLAHAD(KKPROJ(IFROVP(I)),IPVQ(I),IPPV1(I),IPPV2(I)) | |
6290 | 3 CONTINUE | |
6291 | DO 4 I=1,IXTV | |
6292 | CALL DT_FLAHAD(KKTARG(IFROVT(I)),ITVQ(I),ITTV1(I),ITTV2(I)) | |
6293 | 4 CONTINUE | |
6294 | ENDIF | |
6295 | ||
6296 | RETURN | |
6297 | END | |
6298 | ||
6299 | *$ CREATE DT_GETPTN.FOR | |
6300 | *COPY DT_GETPTN | |
6301 | * | |
6302 | *===getptn=============================================================* | |
6303 | * | |
6304 | SUBROUTINE DT_GETPTN(IP,NN,NCSY,IREJ) | |
6305 | ||
6306 | ************************************************************************ | |
6307 | * This subroutine collects partons at chain ends from temporary * | |
6308 | * commons and puts them into DTEVT1. * | |
6309 | * This version dated 15.01.95 is written by S. Roesler * | |
6310 | ************************************************************************ | |
6311 | ||
6312 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
6313 | SAVE | |
6314 | ||
6315 | PARAMETER ( LINP = 10 , | |
6316 | & LOUT = 6 , | |
6317 | & LDAT = 9 ) | |
6318 | ||
6319 | PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0) | |
6320 | ||
6321 | LOGICAL LCHK | |
6322 | ||
6323 | PARAMETER ( MAXNCL = 260, | |
6324 | ||
6325 | & MAXVQU = MAXNCL, | |
6326 | & MAXSQU = 20*MAXVQU, | |
6327 | & MAXINT = MAXVQU+MAXSQU) | |
6328 | ||
6329 | * event history | |
6330 | ||
6331 | PARAMETER (NMXHKK=200000) | |
6332 | ||
6333 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
6334 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
6335 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
6336 | ||
6337 | * extended event history | |
6338 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
6339 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
6340 | & IHIST(2,NMXHKK) | |
6341 | ||
6342 | * flags for input different options | |
6343 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
6344 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
6345 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
6346 | ||
6347 | * auxiliary common for chain system storage (DTUNUC 1.x) | |
6348 | COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL) | |
6349 | ||
6350 | * statistics | |
6351 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
6352 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
6353 | & ICEVTG(8,0:30) | |
6354 | ||
6355 | * flags for diffractive interactions (DTUNUC 1.x) | |
6356 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF | |
6357 | ||
6358 | * x-values of partons (DTUNUC 1.x) | |
6359 | COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU), | |
6360 | & XTVQ(MAXVQU),XTVD(MAXVQU), | |
6361 | & XPSQ(MAXSQU),XPSAQ(MAXSQU), | |
6362 | & XTSQ(MAXSQU),XTSAQ(MAXSQU) | |
6363 | ||
6364 | * flavors of partons (DTUNUC 1.x) | |
6365 | COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU), | |
6366 | & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU), | |
6367 | & IPSQ(MAXSQU),IPSQ2(MAXSQU), | |
6368 | & IPSAQ(MAXSQU),IPSAQ2(MAXSQU), | |
6369 | & ITSQ(MAXSQU),ITSQ2(MAXSQU), | |
6370 | & ITSAQ(MAXSQU),ITSAQ2(MAXSQU), | |
6371 | & KKPROJ(MAXVQU),KKTARG(MAXVQU) | |
6372 | ||
6373 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) | |
6374 | COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD, | |
6375 | & IXPV,IXPS,IXTV,IXTS, | |
6376 | & INTVV1(MAXVQU),INTVV2(MAXVQU), | |
6377 | & INTSV1(MAXVQU),INTSV2(MAXVQU), | |
6378 | & INTVS1(MAXVQU),INTVS2(MAXVQU), | |
6379 | & INTSS1(MAXSQU),INTSS2(MAXSQU), | |
6380 | & INTDV1(MAXVQU),INTDV2(MAXVQU), | |
6381 | & INTVD1(MAXVQU),INTVD2(MAXVQU), | |
6382 | & INTDS1(MAXSQU),INTDS2(MAXSQU), | |
6383 | & INTSD1(MAXSQU),INTSD2(MAXSQU) | |
6384 | ||
6385 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) | |
6386 | COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU), | |
6387 | & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU) | |
6388 | ||
6389 | DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PP(4),PT(4) | |
6390 | ||
6391 | DATA AMSS,AMVS,AMDS,AMVD,AMVV/0.4D0,2.0D0,2.0D0,2.5D0,2.0D0/ | |
6392 | ||
6393 | IREJ = 0 | |
6394 | NCSY = 0 | |
6395 | NPOINT(2) = NHKK+1 | |
6396 | ||
6397 | * sea-sea chains | |
6398 | DO 10 I=1,NSS | |
6399 | IF (ISKPCH(1,I).EQ.99) GOTO 10 | |
6400 | ICCHAI(1,1) = ICCHAI(1,1)+2 | |
6401 | IDXP = INTSS1(I) | |
6402 | IDXT = INTSS2(I) | |
6403 | MOP = JDAHKK(1,IPOSP(IFROSP(IDXP))) | |
6404 | MOT = JDAHKK(1,IPOST(IFROST(IDXT))) | |
6405 | DO 11 K=1,4 | |
6406 | PP1(K) = XPSQ(IDXP) *PHKK(K,MOP) | |
6407 | PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP) | |
6408 | PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT) | |
6409 | PT2(K) = XTSQ(IDXT) *PHKK(K,MOT) | |
6410 | 11 CONTINUE | |
6411 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 | |
6412 | & +(PP1(3)+PT1(3))**2) | |
6413 | ECH = PP1(4)+PT1(4) | |
6414 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
6415 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 | |
6416 | & +(PP2(3)+PT2(3))**2) | |
6417 | ECH = PP2(4)+PT2(4) | |
6418 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
6419 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN | |
6420 | AM1 = SQRT(AM1) | |
6421 | AM2 = SQRT(AM2) | |
6422 | IF ((AM1.LT.AMSS).OR.(AM2.LT.AMSS)) THEN | |
6423 | C WRITE(LOUT,5000) NEVHKK,I,AM1,AM2 | |
6424 | 5000 FORMAT(1X,'incon. chain mass SS: ',2I5,2E10.3) | |
6425 | ENDIF | |
6426 | ELSE | |
6427 | WRITE(LOUT,5000) NEVHKK,I,AM1,AM2 | |
6428 | ENDIF | |
6429 | IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2) | |
6430 | IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2) | |
6431 | IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2) | |
6432 | IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2) | |
6433 | CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), | |
6434 | & 0,0,1) | |
6435 | CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), | |
6436 | & 0,0,1) | |
6437 | CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), | |
6438 | & 0,0,1) | |
6439 | CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), | |
6440 | & 0,0,1) | |
6441 | NCSY = NCSY+1 | |
6442 | 10 CONTINUE | |
6443 | ||
6444 | * disea-sea chains | |
6445 | DO 20 I=1,NDS | |
6446 | IF (ISKPCH(2,I).EQ.99) GOTO 20 | |
6447 | ICCHAI(1,2) = ICCHAI(1,2)+2 | |
6448 | IDXP = INTDS1(I) | |
6449 | IDXT = INTDS2(I) | |
6450 | MOP = JDAHKK(1,IPOSP(IFROSP(IDXP))) | |
6451 | MOT = JDAHKK(1,IPOST(IFROST(IDXT))) | |
6452 | DO 21 K=1,4 | |
6453 | PP1(K) = XPSQ(IDXP) *PHKK(K,MOP) | |
6454 | PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP) | |
6455 | PT1(K) = XTSQ(IDXT) *PHKK(K,MOT) | |
6456 | PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT) | |
6457 | 21 CONTINUE | |
6458 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 | |
6459 | & +(PP1(3)+PT1(3))**2) | |
6460 | ECH = PP1(4)+PT1(4) | |
6461 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
6462 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 | |
6463 | & +(PP2(3)+PT2(3))**2) | |
6464 | ECH = PP2(4)+PT2(4) | |
6465 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
6466 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN | |
6467 | AM1 = SQRT(AM1) | |
6468 | AM2 = SQRT(AM2) | |
6469 | IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN | |
6470 | C WRITE(LOUT,5001) NEVHKK,I,AM1,AM2 | |
6471 | 5001 FORMAT(1X,'incon. chain mass DS: ',2I5,2E10.3) | |
6472 | ENDIF | |
6473 | ELSE | |
6474 | WRITE(LOUT,5001) NEVHKK,I,AM1,AM2 | |
6475 | ENDIF | |
6476 | IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2) | |
6477 | IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2) | |
6478 | IFT1 = IDT_IB2PDG(ITSQ(IDXT),0,2) | |
6479 | IFT2 = IDT_IB2PDG(ITSAQ(IDXT),0,2) | |
6480 | CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), | |
6481 | & 0,0,2) | |
6482 | CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), | |
6483 | & 0,0,2) | |
6484 | CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), | |
6485 | & 0,0,2) | |
6486 | CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), | |
6487 | & 0,0,2) | |
6488 | NCSY = NCSY+1 | |
6489 | 20 CONTINUE | |
6490 | ||
6491 | * sea-disea chains | |
6492 | DO 30 I=1,NSD | |
6493 | IF (ISKPCH(3,I).EQ.99) GOTO 30 | |
6494 | ICCHAI(1,3) = ICCHAI(1,3)+2 | |
6495 | IDXP = INTSD1(I) | |
6496 | IDXT = INTSD2(I) | |
6497 | MOP = JDAHKK(1,IPOSP(IFROSP(IDXP))) | |
6498 | MOT = JDAHKK(1,IPOST(IFROST(IDXT))) | |
6499 | DO 31 K=1,4 | |
6500 | PP1(K) = XPSQ(IDXP) *PHKK(K,MOP) | |
6501 | PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP) | |
6502 | PT1(K) = XTSQ(IDXT) *PHKK(K,MOT) | |
6503 | PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT) | |
6504 | 31 CONTINUE | |
6505 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 | |
6506 | & +(PP1(3)+PT1(3))**2) | |
6507 | ECH = PP1(4)+PT1(4) | |
6508 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
6509 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 | |
6510 | & +(PP2(3)+PT2(3))**2) | |
6511 | ECH = PP2(4)+PT2(4) | |
6512 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
6513 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN | |
6514 | AM1 = SQRT(AM1) | |
6515 | AM2 = SQRT(AM2) | |
6516 | IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN | |
6517 | C WRITE(LOUT,5002) NEVHKK,I,AM1,AM2 | |
6518 | 5002 FORMAT(1X,'incon. chain mass SD: ',2I5,2E10.3) | |
6519 | ENDIF | |
6520 | ELSE | |
6521 | WRITE(LOUT,5002) NEVHKK,I,AM1,AM2 | |
6522 | ENDIF | |
6523 | IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2) | |
6524 | IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2) | |
6525 | IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2) | |
6526 | IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2) | |
6527 | CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), | |
6528 | & 0,0,3) | |
6529 | CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), | |
6530 | & 0,0,3) | |
6531 | CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), | |
6532 | & 0,0,3) | |
6533 | CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), | |
6534 | & 0,0,3) | |
6535 | NCSY = NCSY+1 | |
6536 | 30 CONTINUE | |
6537 | ||
6538 | * disea-valence chains | |
6539 | DO 50 I=1,NDV | |
6540 | IF (ISKPCH(5,I).EQ.99) GOTO 50 | |
6541 | ICCHAI(1,5) = ICCHAI(1,5)+2 | |
6542 | IDXP = INTDV1(I) | |
6543 | IDXT = INTDV2(I) | |
6544 | MOP = JDAHKK(1,IPOSP(IFROSP(IDXP))) | |
6545 | MOT = JDAHKK(1,IPOST(IFROVT(IDXT))) | |
6546 | DO 51 K=1,4 | |
6547 | PP1(K) = XPSQ(IDXP) *PHKK(K,MOP) | |
6548 | PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP) | |
6549 | PT1(K) = XTVQ(IDXT) *PHKK(K,MOT) | |
6550 | PT2(K) = XTVD(IDXT) *PHKK(K,MOT) | |
6551 | 51 CONTINUE | |
6552 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 | |
6553 | & +(PP1(3)+PT1(3))**2) | |
6554 | ECH = PP1(4)+PT1(4) | |
6555 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
6556 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 | |
6557 | & +(PP2(3)+PT2(3))**2) | |
6558 | ECH = PP2(4)+PT2(4) | |
6559 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
6560 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN | |
6561 | AM1 = SQRT(AM1) | |
6562 | AM2 = SQRT(AM2) | |
6563 | IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN | |
6564 | C WRITE(LOUT,5003) NEVHKK,I,AM1,AM2 | |
6565 | 5003 FORMAT(1X,'incon. chain mass DV: ',2I5,2E10.3) | |
6566 | ENDIF | |
6567 | ELSE | |
6568 | WRITE(LOUT,5003) NEVHKK,I,AM1,AM2 | |
6569 | ENDIF | |
6570 | IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2) | |
6571 | IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2) | |
6572 | IFT1 = IDT_IB2PDG(ITVQ(IDXT),0,2) | |
6573 | IFT2 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2) | |
6574 | CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), | |
6575 | & 0,0,5) | |
6576 | CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), | |
6577 | & 0,0,5) | |
6578 | CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), | |
6579 | & 0,0,5) | |
6580 | CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), | |
6581 | & 0,0,5) | |
6582 | NCSY = NCSY+1 | |
6583 | 50 CONTINUE | |
6584 | ||
6585 | * valence-sea chains | |
6586 | DO 60 I=1,NVS | |
6587 | IF (ISKPCH(6,I).EQ.99) GOTO 60 | |
6588 | ICCHAI(1,6) = ICCHAI(1,6)+2 | |
6589 | IDXP = INTVS1(I) | |
6590 | IDXT = INTVS2(I) | |
6591 | MOP = JDAHKK(1,IPOSP(IFROVP(IDXP))) | |
6592 | MOT = JDAHKK(1,IPOST(IFROST(IDXT))) | |
6593 | DO 61 K=1,4 | |
6594 | PP1(K) = XPVQ(IDXP) *PHKK(K,MOP) | |
6595 | PP2(K) = XPVD(IDXP) *PHKK(K,MOP) | |
6596 | PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT) | |
6597 | PT2(K) = XTSQ(IDXT) *PHKK(K,MOT) | |
6598 | 61 CONTINUE | |
6599 | IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2) | |
6600 | IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2) | |
6601 | IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2) | |
6602 | IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2) | |
6603 | CALL DT_CHKCSY(IFP1,IFT1,LCHK) | |
6604 | IF (LCHK) THEN | |
6605 | CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), | |
6606 | & 0,0,6) | |
6607 | CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), | |
6608 | & 0,0,6) | |
6609 | CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), | |
6610 | & 0,0,6) | |
6611 | CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), | |
6612 | & 0,0,6) | |
6613 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 | |
6614 | & +(PP1(3)+PT1(3))**2) | |
6615 | ECH = PP1(4)+PT1(4) | |
6616 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
6617 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 | |
6618 | & +(PP2(3)+PT2(3))**2) | |
6619 | ECH = PP2(4)+PT2(4) | |
6620 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
6621 | ELSE | |
6622 | CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), | |
6623 | & 0,0,6) | |
6624 | CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), | |
6625 | & 0,0,6) | |
6626 | CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), | |
6627 | & 0,0,6) | |
6628 | CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), | |
6629 | & 0,0,6) | |
6630 | PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2 | |
6631 | & +(PP1(3)+PT2(3))**2) | |
6632 | ECH = PP1(4)+PT2(4) | |
6633 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
6634 | PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2 | |
6635 | & +(PP2(3)+PT1(3))**2) | |
6636 | ECH = PP2(4)+PT1(4) | |
6637 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
6638 | ENDIF | |
6639 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN | |
6640 | AM1 = SQRT(AM1) | |
6641 | AM2 = SQRT(AM2) | |
6642 | IF ((AM1.LT.AMSS).OR.(AM2.LT.AMVS)) THEN | |
6643 | C WRITE(LOUT,5004) NEVHKK,I,AM1,AM2 | |
6644 | 5004 FORMAT(1X,'incon. chain mass VS: ',2I5,2E10.3) | |
6645 | ENDIF | |
6646 | ELSE | |
6647 | WRITE(LOUT,5004) NEVHKK,I,AM1,AM2 | |
6648 | ENDIF | |
6649 | NCSY = NCSY+1 | |
6650 | 60 CONTINUE | |
6651 | ||
6652 | * sea-valence chains | |
6653 | DO 40 I=1,NSV | |
6654 | IF (ISKPCH(4,I).EQ.99) GOTO 40 | |
6655 | ICCHAI(1,4) = ICCHAI(1,4)+2 | |
6656 | IDXP = INTSV1(I) | |
6657 | IDXT = INTSV2(I) | |
6658 | MOP = JDAHKK(1,IPOSP(IFROSP(IDXP))) | |
6659 | MOT = JDAHKK(1,IPOST(IFROVT(IDXT))) | |
6660 | DO 41 K=1,4 | |
6661 | PP1(K) = XPSQ(IDXP) *PHKK(K,MOP) | |
6662 | PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP) | |
6663 | PT1(K) = XTVD(IDXT) *PHKK(K,MOT) | |
6664 | PT2(K) = XTVQ(IDXT) *PHKK(K,MOT) | |
6665 | 41 CONTINUE | |
6666 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 | |
6667 | & +(PP1(3)+PT1(3))**2) | |
6668 | ECH = PP1(4)+PT1(4) | |
6669 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
6670 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 | |
6671 | & +(PP2(3)+PT2(3))**2) | |
6672 | ECH = PP2(4)+PT2(4) | |
6673 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
6674 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN | |
6675 | AM1 = SQRT(AM1) | |
6676 | AM2 = SQRT(AM2) | |
6677 | IF ((AM1.LT.AMVS).OR.(AM2.LT.AMSS)) THEN | |
6678 | C WRITE(LOUT,5005) NEVHKK,I,AM1,AM2 | |
6679 | 5005 FORMAT(1X,'incon. chain mass SV: ',2I5,2E10.3) | |
6680 | ENDIF | |
6681 | ELSE | |
6682 | WRITE(LOUT,5005) NEVHKK,I,AM1,AM2 | |
6683 | ENDIF | |
6684 | IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2) | |
6685 | IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2) | |
6686 | IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2) | |
6687 | IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2) | |
6688 | CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), | |
6689 | & 0,0,4) | |
6690 | CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), | |
6691 | & 0,0,4) | |
6692 | CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), | |
6693 | & 0,0,4) | |
6694 | CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), | |
6695 | & 0,0,4) | |
6696 | NCSY = NCSY+1 | |
6697 | 40 CONTINUE | |
6698 | ||
6699 | * valence-disea chains | |
6700 | DO 70 I=1,NVD | |
6701 | IF (ISKPCH(7,I).EQ.99) GOTO 70 | |
6702 | ICCHAI(1,7) = ICCHAI(1,7)+2 | |
6703 | IDXP = INTVD1(I) | |
6704 | IDXT = INTVD2(I) | |
6705 | MOP = JDAHKK(1,IPOSP(IFROVP(IDXP))) | |
6706 | MOT = JDAHKK(1,IPOST(IFROST(IDXT))) | |
6707 | DO 71 K=1,4 | |
6708 | PP1(K) = XPVQ(IDXP) *PHKK(K,MOP) | |
6709 | PP2(K) = XPVD(IDXP) *PHKK(K,MOP) | |
6710 | PT1(K) = XTSQ(IDXT) *PHKK(K,MOT) | |
6711 | PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT) | |
6712 | 71 CONTINUE | |
6713 | IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2) | |
6714 | IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2) | |
6715 | IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2) | |
6716 | IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2) | |
6717 | CALL DT_CHKCSY(IFP1,IFT1,LCHK) | |
6718 | IF (LCHK) THEN | |
6719 | CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), | |
6720 | & 0,0,7) | |
6721 | CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), | |
6722 | & 0,0,7) | |
6723 | CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), | |
6724 | & 0,0,7) | |
6725 | CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), | |
6726 | & 0,0,7) | |
6727 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 | |
6728 | & +(PP1(3)+PT1(3))**2) | |
6729 | ECH = PP1(4)+PT1(4) | |
6730 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
6731 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 | |
6732 | & +(PP2(3)+PT2(3))**2) | |
6733 | ECH = PP2(4)+PT2(4) | |
6734 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
6735 | ELSE | |
6736 | CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), | |
6737 | & 0,0,7) | |
6738 | CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), | |
6739 | & 0,0,7) | |
6740 | CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), | |
6741 | & 0,0,7) | |
6742 | CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), | |
6743 | & 0,0,7) | |
6744 | PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2 | |
6745 | & +(PP1(3)+PT2(3))**2) | |
6746 | ECH = PP1(4)+PT2(4) | |
6747 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
6748 | PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2 | |
6749 | & +(PP2(3)+PT1(3))**2) | |
6750 | ECH = PP2(4)+PT1(4) | |
6751 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
6752 | ENDIF | |
6753 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN | |
6754 | AM1 = SQRT(AM1) | |
6755 | AM2 = SQRT(AM2) | |
6756 | IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN | |
6757 | C WRITE(LOUT,5006) NEVHKK,I,AM1,AM2 | |
6758 | 5006 FORMAT(1X,'incon. chain mass VD: ',2I5,2E10.3) | |
6759 | ENDIF | |
6760 | ELSE | |
6761 | WRITE(LOUT,5006) NEVHKK,I,AM1,AM2 | |
6762 | ENDIF | |
6763 | NCSY = NCSY+1 | |
6764 | 70 CONTINUE | |
6765 | ||
6766 | * valence-valence chains | |
6767 | DO 80 I=1,NVV | |
6768 | IF (ISKPCH(8,I).EQ.99) GOTO 80 | |
6769 | ICCHAI(1,8) = ICCHAI(1,8)+2 | |
6770 | IDXP = INTVV1(I) | |
6771 | IDXT = INTVV2(I) | |
6772 | MOP = JDAHKK(1,IPOSP(IFROVP(IDXP))) | |
6773 | MOT = JDAHKK(1,IPOST(IFROVT(IDXT))) | |
6774 | DO 81 K=1,4 | |
6775 | PP1(K) = XPVQ(IDXP)*PHKK(K,MOP) | |
6776 | PP2(K) = XPVD(IDXP)*PHKK(K,MOP) | |
6777 | PT1(K) = XTVD(IDXT)*PHKK(K,MOT) | |
6778 | PT2(K) = XTVQ(IDXT)*PHKK(K,MOT) | |
6779 | 81 CONTINUE | |
6780 | IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2) | |
6781 | IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2) | |
6782 | IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2) | |
6783 | IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2) | |
6784 | ||
6785 | * check for diffractive event | |
6786 | IDIFF = 0 | |
6787 | IF (((ISINGD.GT.0).OR.(IDOUBD.GT.0)).AND. | |
6788 | & (IP.EQ.1).AND.(NN.EQ.1)) THEN | |
6789 | DO 800 K=1,4 | |
6790 | PP(K) = PP1(K)+PP2(K) | |
6791 | PT(K) = PT1(K)+PT2(K) | |
6792 | 800 CONTINUE | |
6793 | ISTCK = NHKK | |
6794 | CALL DT_DIFEVT(IFP1,IFP2,PP,MOP, | |
6795 | & IFT1,IFT2,PT,MOT,IDIFF,NCSY,IREJ1) | |
6796 | C IF (IREJ1.NE.0) GOTO 9999 | |
6797 | IF (IREJ1.NE.0) THEN | |
6798 | IDIFF = 0 | |
6799 | NHKK = ISTCK | |
6800 | ENDIF | |
6801 | ELSE | |
6802 | IDIFF = 0 | |
6803 | ENDIF | |
6804 | ||
6805 | IF (IDIFF.EQ.0) THEN | |
6806 | * valence-valence chain system | |
6807 | CALL DT_CHKCSY(IFP1,IFT1,LCHK) | |
6808 | IF (LCHK) THEN | |
6809 | * baryon-baryon | |
6810 | CALL DT_EVTPUT(-21,IFP1,MOP,0, | |
6811 | & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8) | |
6812 | CALL DT_EVTPUT(-22,IFT1,MOT,0, | |
6813 | & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8) | |
6814 | CALL DT_EVTPUT(-21,IFP2,MOP,0, | |
6815 | & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8) | |
6816 | CALL DT_EVTPUT(-22,IFT2,MOT,0, | |
6817 | & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8) | |
6818 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 | |
6819 | & +(PP1(3)+PT1(3))**2) | |
6820 | ECH = PP1(4)+PT1(4) | |
6821 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
6822 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 | |
6823 | & +(PP2(3)+PT2(3))**2) | |
6824 | ECH = PP2(4)+PT2(4) | |
6825 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
6826 | ELSE | |
6827 | * antibaryon-baryon | |
6828 | CALL DT_EVTPUT(-21,IFP1,MOP,0, | |
6829 | & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8) | |
6830 | CALL DT_EVTPUT(-22,IFT2,MOT,0, | |
6831 | & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8) | |
6832 | CALL DT_EVTPUT(-21,IFP2,MOP,0, | |
6833 | & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8) | |
6834 | CALL DT_EVTPUT(-22,IFT1,MOT,0, | |
6835 | & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8) | |
6836 | PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2 | |
6837 | & +(PP1(3)+PT2(3))**2) | |
6838 | ECH = PP1(4)+PT2(4) | |
6839 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
6840 | PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2 | |
6841 | & +(PP2(3)+PT1(3))**2) | |
6842 | ECH = PP2(4)+PT1(4) | |
6843 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
6844 | ENDIF | |
6845 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN | |
6846 | AM1 = SQRT(AM1) | |
6847 | AM2 = SQRT(AM2) | |
6848 | IF ((AM1.LT.AMVV).OR.(AM2.LT.AMVV)) THEN | |
6849 | C WRITE(LOUT,5007) NEVHKK,I,AM1,AM2 | |
6850 | 5007 FORMAT(1X,'incon. chain mass VV: ',2I5,2E10.3) | |
6851 | ENDIF | |
6852 | ELSE | |
6853 | WRITE(LOUT,5007) NEVHKK,I,AM1,AM2 | |
6854 | ENDIF | |
6855 | NCSY = NCSY+1 | |
6856 | ENDIF | |
6857 | 80 CONTINUE | |
6858 | IF (ISTHKK(NPOINT(2)).EQ.1) NPOINT(2) = NPOINT(2)+1 | |
6859 | ||
6860 | * energy-momentum & flavor conservation check | |
6861 | IF (ABS(IDIFF).NE.1) THEN | |
6862 | IF (IDIFF.NE.0) THEN | |
6863 | IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-41,1,0, | |
6864 | & 1,3,10,IREJ) | |
6865 | ELSE | |
6866 | IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-31,-32,0, | |
6867 | & 1,3,10,IREJ) | |
6868 | ENDIF | |
6869 | IF (IREJ.NE.0) THEN | |
6870 | CALL DT_EVTOUT(4) | |
6871 | STOP | |
6872 | ENDIF | |
6873 | ENDIF | |
6874 | ||
6875 | RETURN | |
6876 | ||
6877 | 9999 CONTINUE | |
6878 | IREJ = 1 | |
6879 | RETURN | |
6880 | END | |
6881 | ||
6882 | *$ CREATE DT_CHKCSY.FOR | |
6883 | *COPY DT_CHKCSY | |
6884 | * | |
6885 | *===chkcsy=============================================================* | |
6886 | * | |
6887 | SUBROUTINE DT_CHKCSY(ID1,ID2,LCHK) | |
6888 | ||
6889 | ************************************************************************ | |
6890 | * CHeCk Chain SYstem for consistency of partons at chain ends. * | |
6891 | * ID1,ID2 PDG-numbers of partons at chain ends * | |
6892 | * LCHK = .true. consistent chain * | |
6893 | * = .false. inconsistent chain * | |
6894 | * This version dated 18.01.95 is written by S. Roesler * | |
6895 | ************************************************************************ | |
6896 | ||
6897 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
6898 | SAVE | |
6899 | ||
6900 | PARAMETER ( LINP = 10 , | |
6901 | & LOUT = 6 , | |
6902 | & LDAT = 9 ) | |
6903 | ||
6904 | LOGICAL LCHK | |
6905 | ||
6906 | LCHK = .TRUE. | |
6907 | ||
6908 | * q-aq chain | |
6909 | IF ((ABS(ID1).LE.6).AND.(ABS(ID2).LE.6)) THEN | |
6910 | IF (ID1*ID2.GT.0) LCHK = .FALSE. | |
6911 | * q-qq, aq-aqaq chain | |
6912 | ELSEIF (((ABS(ID1).LE.6).AND.(ABS(ID2).GT.6)).OR. | |
6913 | & ((ABS(ID1).GT.6).AND.(ABS(ID2).LE.6))) THEN | |
6914 | IF (ID1*ID2.LT.0) LCHK = .FALSE. | |
6915 | * qq-aqaq chain | |
6916 | ELSEIF ((ABS(ID1).GT.6).AND.(ABS(ID2).GT.6)) THEN | |
6917 | IF (ID1*ID2.GT.0) LCHK = .FALSE. | |
6918 | ENDIF | |
6919 | ||
6920 | RETURN | |
6921 | END | |
6922 | ||
6923 | *$ CREATE DT_EVENTA.FOR | |
6924 | *COPY DT_EVENTA | |
6925 | * | |
6926 | *===eventa=============================================================* | |
6927 | * | |
6928 | SUBROUTINE DT_EVENTA(ID,IP,IT,NCSY,IREJ) | |
6929 | ||
6930 | ************************************************************************ | |
6931 | * Treatment of nucleon-nucleon interactions in a two-chain * | |
6932 | * approximation. * | |
6933 | * (input) ID BAMJET-index of projectile hadron (in case of * | |
6934 | * h-K scattering) * | |
6935 | * IP/IT mass number of projectile/target nucleus * | |
6936 | * NCSY number of two chain systems * | |
6937 | * IREJ rejection flag * | |
6938 | * This version dated 15.01.95 is written by S. Roesler * | |
6939 | ************************************************************************ | |
6940 | ||
6941 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
6942 | SAVE | |
6943 | ||
6944 | PARAMETER ( LINP = 10 , | |
6945 | & LOUT = 6 , | |
6946 | & LDAT = 9 ) | |
6947 | ||
6948 | PARAMETER (TINY10=1.0D-10) | |
6949 | ||
6950 | * event history | |
6951 | ||
6952 | PARAMETER (NMXHKK=200000) | |
6953 | ||
6954 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
6955 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
6956 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
6957 | ||
6958 | * extended event history | |
6959 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
6960 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
6961 | & IHIST(2,NMXHKK) | |
6962 | ||
6963 | * rejection counter | |
6964 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
6965 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
6966 | & IREXCI(3),IRDIFF(2),IRINC | |
6967 | ||
6968 | * flags for diffractive interactions (DTUNUC 1.x) | |
6969 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF | |
6970 | ||
6971 | * particle properties (BAMJET index convention) | |
6972 | CHARACTER*8 ANAME | |
6973 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
6974 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
6975 | ||
6976 | * flags for input different options | |
6977 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
6978 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
6979 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
6980 | ||
6981 | * various options for treatment of partons (DTUNUC 1.x) | |
6982 | * (chain recombination, Cronin,..) | |
6983 | LOGICAL LCO2CR,LINTPT | |
6984 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, | |
6985 | & LCO2CR,LINTPT | |
6986 | ||
6987 | DIMENSION PP1(4),PP2(4),PT1(4),PT2(4) | |
6988 | ||
6989 | IREJ = 0 | |
6990 | NPOINT(3) = NHKK+1 | |
6991 | ||
6992 | * skip following treatment for low-mass diffraction | |
6993 | IF (ABS(IFLAGD).EQ.1) THEN | |
6994 | NPOINT(3) = NPOINT(2) | |
6995 | GOTO 5 | |
6996 | ENDIF | |
6997 | ||
6998 | * multiple scattering of chain ends | |
6999 | IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1) | |
7000 | IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2) | |
7001 | ||
7002 | NC = NPOINT(2) | |
7003 | * get a two-chain system from DTEVT1 | |
7004 | DO 3 I=1,NCSY | |
7005 | IFP1 = IDHKK(NC) | |
7006 | IFT1 = IDHKK(NC+1) | |
7007 | IFP2 = IDHKK(NC+2) | |
7008 | IFT2 = IDHKK(NC+3) | |
7009 | DO 4 K=1,4 | |
7010 | PP1(K) = PHKK(K,NC) | |
7011 | PT1(K) = PHKK(K,NC+1) | |
7012 | PP2(K) = PHKK(K,NC+2) | |
7013 | PT2(K) = PHKK(K,NC+3) | |
7014 | 4 CONTINUE | |
7015 | MOP1 = NC | |
7016 | MOT1 = NC+1 | |
7017 | MOP2 = NC+2 | |
7018 | MOT2 = NC+3 | |
7019 | CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2, | |
7020 | & IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1) | |
7021 | IF (IREJ1.GT.0) THEN | |
7022 | IRHHA = IRHHA+1 | |
7023 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTA' | |
7024 | GOTO 9999 | |
7025 | ENDIF | |
7026 | NC = NC+4 | |
7027 | 3 CONTINUE | |
7028 | ||
7029 | * meson/antibaryon projectile: | |
7030 | * sample single-chain valence-valence systems (Reggeon contrib.) | |
7031 | IF ((IP.EQ.1).AND.(ISICHA.EQ.1)) THEN | |
7032 | IF (IIBAR(ID).LE.0) CALL DT_VV2SCH | |
7033 | ENDIF | |
7034 | ||
7035 | IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN | |
7036 | * check DTEVT1 for remaining resonance mass corrections | |
7037 | CALL DT_EVTRES(IREJ1) | |
7038 | IF (IREJ1.GT.0) THEN | |
7039 | IRRES(1) = IRRES(1)+1 | |
7040 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in EVENTA' | |
7041 | GOTO 9999 | |
7042 | ENDIF | |
7043 | ENDIF | |
7044 | ||
7045 | * assign p_t to two-"chain" systems consisting of two resonances only | |
7046 | * since only entries for chains will be affected, this is obsolete | |
7047 | * in case of JETSET-fragmetation | |
7048 | CALL DT_RESPT | |
7049 | ||
7050 | * combine q-aq chains to color ropes (qq-aqaq) (chain fusion) | |
7051 | IF (LCO2CR) CALL DT_COM2CR | |
7052 | ||
7053 | 5 CONTINUE | |
7054 | ||
7055 | * fragmentation of the complete event | |
7056 | **uncomment for internal phojet-fragmentation | |
7057 | C CALL DT_EVTFRA(IREJ1) | |
7058 | CALL DT_EVTFRG(2,IDUM,NPYMEM,IREJ1) | |
7059 | IF (IREJ1.GT.0) THEN | |
7060 | IRFRAG = IRFRAG+1 | |
7061 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 3 in EVENTA' | |
7062 | GOTO 9999 | |
7063 | ENDIF | |
7064 | ||
7065 | * decay of possible resonances (should be obsolete) | |
7066 | CALL DT_DECAY1 | |
7067 | ||
7068 | RETURN | |
7069 | ||
7070 | 9999 CONTINUE | |
7071 | IREVT = IREVT+1 | |
7072 | IREJ = 1 | |
7073 | RETURN | |
7074 | END | |
7075 | ||
7076 | *$ CREATE DT_GETCSY.FOR | |
7077 | *COPY DT_GETCSY | |
7078 | * | |
7079 | *===getcsy=============================================================* | |
7080 | * | |
7081 | SUBROUTINE DT_GETCSY(IFPR1,PP1,MOP1,IFPR2,PP2,MOP2, | |
7082 | & IFTA1,PT1,MOT1,IFTA2,PT2,MOT2,IREJ) | |
7083 | ||
7084 | ************************************************************************ | |
7085 | * This version dated 15.01.95 is written by S. Roesler * | |
7086 | ************************************************************************ | |
7087 | ||
7088 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
7089 | SAVE | |
7090 | ||
7091 | PARAMETER ( LINP = 10 , | |
7092 | & LOUT = 6 , | |
7093 | & LDAT = 9 ) | |
7094 | ||
7095 | PARAMETER (TINY10=1.0D-10) | |
7096 | ||
7097 | * event history | |
7098 | ||
7099 | PARAMETER (NMXHKK=200000) | |
7100 | ||
7101 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
7102 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
7103 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
7104 | ||
7105 | * extended event history | |
7106 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
7107 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
7108 | & IHIST(2,NMXHKK) | |
7109 | ||
7110 | * rejection counter | |
7111 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
7112 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
7113 | & IREXCI(3),IRDIFF(2),IRINC | |
7114 | ||
7115 | * flags for input different options | |
7116 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
7117 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
7118 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
7119 | ||
7120 | * flags for diffractive interactions (DTUNUC 1.x) | |
7121 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF | |
7122 | ||
7123 | DIMENSION PP1(4),PP2(4),PT1(4),PT2(4), | |
7124 | & IFP1(2),IFP2(2),IFT1(2),IFT2(2),PCH1(4),PCH2(4) | |
7125 | ||
7126 | IREJ = 0 | |
7127 | ||
7128 | * get quark content of partons | |
7129 | DO 1 I=1,2 | |
7130 | IFP1(I) = 0 | |
7131 | IFP2(I) = 0 | |
7132 | IFT1(I) = 0 | |
7133 | IFT2(I) = 0 | |
7134 | 1 CONTINUE | |
7135 | IFP1(1) = IDT_IPDG2B(IFPR1,1,2) | |
7136 | IF (ABS(IFPR1).GE.1000) IFP1(2) = IDT_IPDG2B(IFPR1,2,2) | |
7137 | IFP2(1) = IDT_IPDG2B(IFPR2,1,2) | |
7138 | IF (ABS(IFPR2).GE.1000) IFP2(2) = IDT_IPDG2B(IFPR2,2,2) | |
7139 | IFT1(1) = IDT_IPDG2B(IFTA1,1,2) | |
7140 | IF (ABS(IFTA1).GE.1000) IFT1(2) = IDT_IPDG2B(IFTA1,2,2) | |
7141 | IFT2(1) = IDT_IPDG2B(IFTA2,1,2) | |
7142 | IF (ABS(IFTA2).GE.1000) IFT2(2) = IDT_IPDG2B(IFTA2,2,2) | |
7143 | ||
7144 | * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq, 3 - qq-aqaq) | |
7145 | IDCH1 = 2 | |
7146 | IF ((IFP1(2).EQ.0).AND.(IFT1(2).EQ.0)) IDCH1 = 1 | |
7147 | IF ((IFP1(2).NE.0).AND.(IFT1(2).NE.0)) IDCH1 = 3 | |
7148 | IDCH2 = 2 | |
7149 | IF ((IFP2(2).EQ.0).AND.(IFT2(2).EQ.0)) IDCH2 = 1 | |
7150 | IF ((IFP2(2).NE.0).AND.(IFT2(2).NE.0)) IDCH2 = 3 | |
7151 | ||
7152 | * store initial configuration for energy-momentum cons. check | |
7153 | IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IDUM) | |
7154 | ||
7155 | * sample intrinsic p_t at chain-ends | |
7156 | CALL DT_GETSPT(PP1,IFPR1,IFP1,PP2,IFPR2,IFP2, | |
7157 | & PT1,IFTA1,IFT1,PT2,IFTA2,IFT2, | |
7158 | & AMCH1,IDCH1,AMCH2,IDCH2,IDCH(MOP1),IREJ1) | |
7159 | IF (IREJ1.NE.0) THEN | |
7160 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in GETCSY' | |
7161 | IRPT = IRPT+1 | |
7162 | GOTO 9999 | |
7163 | ENDIF | |
7164 | ||
7165 | C IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN | |
7166 | C IF ((IDCH1.EQ.3).OR.((IDCH1.GT.1).AND.(IDCH2.EQ.1))) THEN | |
7167 | C* check second chain for resonance | |
7168 | C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2, | |
7169 | C & AMCH2,AMCH2N,IDCH2,IREJ1) | |
7170 | C IF (IREJ1.NE.0) GOTO 9999 | |
7171 | C IF (IDR2.NE.0) THEN | |
7172 | C CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1, | |
7173 | C & AMCH2,AMCH2N,AMCH1,IREJ1) | |
7174 | C IF (IREJ1.NE.0) GOTO 9999 | |
7175 | C ENDIF | |
7176 | C* check first chain for resonance | |
7177 | C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1, | |
7178 | C & AMCH1,AMCH1N,IDCH1,IREJ1) | |
7179 | C IF (IREJ1.NE.0) GOTO 9999 | |
7180 | C IF (IDR1.NE.0) IDR1 = 100*IDR1 | |
7181 | C ELSE | |
7182 | C* check first chain for resonance | |
7183 | C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1, | |
7184 | C & AMCH1,AMCH1N,IDCH1,IREJ1) | |
7185 | C IF (IREJ1.NE.0) GOTO 9999 | |
7186 | C IF (IDR1.NE.0) THEN | |
7187 | C CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2, | |
7188 | C & AMCH1,AMCH1N,AMCH2,IREJ1) | |
7189 | C IF (IREJ1.NE.0) GOTO 9999 | |
7190 | C ENDIF | |
7191 | C* check second chain for resonance | |
7192 | C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2, | |
7193 | C & AMCH2,AMCH2N,IDCH2,IREJ1) | |
7194 | C IF (IREJ1.NE.0) GOTO 9999 | |
7195 | C IF (IDR2.NE.0) IDR2 = 100*IDR2 | |
7196 | C ENDIF | |
7197 | C ENDIF | |
7198 | ||
7199 | IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN | |
7200 | * check chains for resonances | |
7201 | CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1, | |
7202 | & AMCH1,AMCH1N,IDCH1,IREJ1) | |
7203 | IF (IREJ1.NE.0) GOTO 9999 | |
7204 | CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2, | |
7205 | & AMCH2,AMCH2N,IDCH2,IREJ1) | |
7206 | IF (IREJ1.NE.0) GOTO 9999 | |
7207 | * change kinematics corresponding to resonance-masses | |
7208 | IF ( (IDR1.NE.0).AND.(IDR2.EQ.0) ) THEN | |
7209 | CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2, | |
7210 | & AMCH1,AMCH1N,AMCH2,IREJ1) | |
7211 | IF (IREJ1.GT.0) GOTO 9999 | |
7212 | IF (IREJ1.EQ.-1) IDR1 = 100*IDR1 | |
7213 | CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2, | |
7214 | & AMCH2,AMCH2N,IDCH2,IREJ1) | |
7215 | IF (IREJ1.NE.0) GOTO 9999 | |
7216 | IF (IDR2.NE.0) IDR2 = 100*IDR2 | |
7217 | ELSEIF ( (IDR1.EQ.0).AND.(IDR2.NE.0) ) THEN | |
7218 | CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1, | |
7219 | & AMCH2,AMCH2N,AMCH1,IREJ1) | |
7220 | IF (IREJ1.GT.0) GOTO 9999 | |
7221 | IF (IREJ1.EQ.-1) IDR2 = 100*IDR2 | |
7222 | CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1, | |
7223 | & AMCH1,AMCH1N,IDCH1,IREJ1) | |
7224 | IF (IREJ1.NE.0) GOTO 9999 | |
7225 | IF (IDR1.NE.0) IDR1 = 100*IDR1 | |
7226 | ELSEIF ( (IDR1.NE.0).AND.(IDR2.NE.0) ) THEN | |
7227 | AMDIF1 = ABS(AMCH1-AMCH1N) | |
7228 | AMDIF2 = ABS(AMCH2-AMCH2N) | |
7229 | IF (AMDIF2.LT.AMDIF1) THEN | |
7230 | CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1, | |
7231 | & AMCH2,AMCH2N,AMCH1,IREJ1) | |
7232 | IF (IREJ1.GT.0) GOTO 9999 | |
7233 | IF (IREJ1.EQ.-1) IDR2 = 100*IDR2 | |
7234 | CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2), | |
7235 | & IDR1,IDXR1,AMCH1,AMCH1N,IDCH1,IREJ1) | |
7236 | IF (IREJ1.NE.0) GOTO 9999 | |
7237 | IF (IDR1.NE.0) IDR1 = 100*IDR1 | |
7238 | ELSE | |
7239 | CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2, | |
7240 | & AMCH1,AMCH1N,AMCH2,IREJ1) | |
7241 | IF (IREJ1.GT.0) GOTO 9999 | |
7242 | IF (IREJ1.EQ.-1) IDR1 = 100*IDR1 | |
7243 | CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2), | |
7244 | & IDR2,IDXR2,AMCH2,AMCH2N,IDCH2,IREJ1) | |
7245 | IF (IREJ1.NE.0) GOTO 9999 | |
7246 | IF (IDR2.NE.0) IDR2 = 100*IDR2 | |
7247 | ENDIF | |
7248 | ENDIF | |
7249 | ENDIF | |
7250 | ||
7251 | * store final configuration for energy-momentum cons. check | |
7252 | IF (LEMCCK) THEN | |
7253 | CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IDUM) | |
7254 | CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1) | |
7255 | IF (IREJ1.NE.0) GOTO 9999 | |
7256 | ENDIF | |
7257 | ||
7258 | * put partons and chains into DTEVT1 | |
7259 | DO 10 I=1,4 | |
7260 | PCH1(I) = PP1(I)+PT1(I) | |
7261 | PCH2(I) = PP2(I)+PT2(I) | |
7262 | 10 CONTINUE | |
7263 | CALL DT_EVTPUT(-ISTHKK(MOP1),IFPR1,MOP1,0,PP1(1),PP1(2), | |
7264 | & PP1(3),PP1(4),0,0,0) | |
7265 | CALL DT_EVTPUT(-ISTHKK(MOT1),IFTA1,MOT1,0,PT1(1),PT1(2), | |
7266 | & PT1(3),PT1(4),0,0,0) | |
7267 | KCH = 100+IDCH(MOP1)*10+1 | |
7268 | CALL DT_EVTPUT(KCH,88888,-2,-1, | |
7269 | & PCH1(1),PCH1(2),PCH1(3),PCH1(4),IDR1,IDXR1,IDCH(MOP1)) | |
7270 | CALL DT_EVTPUT(-ISTHKK(MOP2),IFPR2,MOP2,0,PP2(1),PP2(2), | |
7271 | & PP2(3),PP2(4),0,0,0) | |
7272 | CALL DT_EVTPUT(-ISTHKK(MOT2),IFTA2,MOT2,0,PT2(1),PT2(2), | |
7273 | & PT2(3),PT2(4),0,0,0) | |
7274 | KCH = KCH+1 | |
7275 | CALL DT_EVTPUT(KCH,88888,-2,-1, | |
7276 | & PCH2(1),PCH2(2),PCH2(3),PCH2(4),IDR2,IDXR2,IDCH(MOP2)) | |
7277 | ||
7278 | RETURN | |
7279 | ||
7280 | 9999 CONTINUE | |
7281 | IF ((IDCH(MOP1).LE.3).AND.(IDCH(MOP2).LE.3)) THEN | |
7282 | * "cancel" sea-sea chains | |
7283 | CALL DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ1) | |
7284 | IF (IREJ1.NE.0) GOTO 9998 | |
7285 | **sr 16.5. flag for EVENTB | |
7286 | IREJ = -1 | |
7287 | RETURN | |
7288 | ENDIF | |
7289 | 9998 CONTINUE | |
7290 | IREJ = 1 | |
7291 | RETURN | |
7292 | END | |
7293 | ||
7294 | *$ CREATE DT_CHKINE.FOR | |
7295 | *COPY DT_CHKINE | |
7296 | * | |
7297 | *===chkine=============================================================* | |
7298 | * | |
7299 | SUBROUTINE DT_CHKINE(PP1I,IFP1,PP2I,IFP2,PT1I,IFT1,PT2I,IFT2, | |
7300 | & AMCH1,AMCH1N,AMCH2,IREJ) | |
7301 | ||
7302 | ************************************************************************ | |
7303 | * This subroutine replaces CORMOM. * | |
7304 | * This version dated 05.01.95 is written by S. Roesler * | |
7305 | ************************************************************************ | |
7306 | ||
7307 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
7308 | SAVE | |
7309 | ||
7310 | PARAMETER ( LINP = 10 , | |
7311 | & LOUT = 6 , | |
7312 | & LDAT = 9 ) | |
7313 | ||
7314 | PARAMETER (TINY10=1.0D-10) | |
7315 | ||
7316 | * flags for input different options | |
7317 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
7318 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
7319 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
7320 | ||
7321 | * rejection counter | |
7322 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
7323 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
7324 | & IREXCI(3),IRDIFF(2),IRINC | |
7325 | ||
7326 | DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),P1(4),P2(4), | |
7327 | & PP1I(4),PP2I(4),PT1I(4),PT2I(4) | |
7328 | ||
7329 | IREJ = 0 | |
7330 | JMSHL = IMSHL | |
7331 | ||
7332 | SCALE = AMCH1N/MAX(AMCH1,TINY10) | |
7333 | DO 10 I=1,4 | |
7334 | PP1(I) = PP1I(I) | |
7335 | PP2(I) = PP2I(I) | |
7336 | PT1(I) = PT1I(I) | |
7337 | PT2(I) = PT2I(I) | |
7338 | PP2(I) = PP2(I)+(1.0D0-SCALE)*PP1(I) | |
7339 | PT2(I) = PT2(I)+(1.0D0-SCALE)*PT1(I) | |
7340 | PP1(I) = SCALE*PP1(I) | |
7341 | PT1(I) = SCALE*PT1(I) | |
7342 | 10 CONTINUE | |
7343 | IF ((PP1(4).LT.0.0D0).OR.(PP2(4).LT.0.0D0).OR. | |
7344 | & (PT1(4).LT.0.0D0).OR.(PT2(4).LT.0.0D0)) GOTO 9997 | |
7345 | ||
7346 | ECH = PP2(4)+PT2(4) | |
7347 | PCH = SQRT( (PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2+ | |
7348 | & (PP2(3)+PT2(3))**2 ) | |
7349 | AMCH22 = (ECH-PCH)*(ECH+PCH) | |
7350 | IF (AMCH22.LT.0.0D0) THEN | |
7351 | IF (IOULEV(1).GT.0) | |
7352 | & WRITE(LOUT,'(1X,A)') 'CHKINE: inconsistent treatment!' | |
7353 | GOTO 9997 | |
7354 | ENDIF | |
7355 | ||
7356 | AMCH1 = AMCH1N | |
7357 | AMCH2 = SQRT(AMCH22) | |
7358 | ||
7359 | * put partons again on mass shell | |
7360 | 13 CONTINUE | |
7361 | XM1 = 0.0D0 | |
7362 | XM2 = 0.0D0 | |
7363 | IF (JMSHL.EQ.1) THEN | |
7364 | ||
7365 | XM1 = PYMASS(IFP1) | |
7366 | XM2 = PYMASS(IFT1) | |
7367 | ||
7368 | ENDIF | |
7369 | CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1) | |
7370 | IF (IREJ1.NE.0) THEN | |
7371 | IF (JMSHL.EQ.0) GOTO 9998 | |
7372 | JMSHL = 0 | |
7373 | GOTO 13 | |
7374 | ENDIF | |
7375 | JMSHL = IMSHL | |
7376 | DO 11 I=1,4 | |
7377 | PP1(I) = P1(I) | |
7378 | PT1(I) = P2(I) | |
7379 | 11 CONTINUE | |
7380 | 14 CONTINUE | |
7381 | XM1 = 0.0D0 | |
7382 | XM2 = 0.0D0 | |
7383 | IF (JMSHL.EQ.1) THEN | |
7384 | ||
7385 | XM1 = PYMASS(IFP2) | |
7386 | XM2 = PYMASS(IFT2) | |
7387 | ||
7388 | ENDIF | |
7389 | CALL DT_MASHEL(PP2,PT2,XM1,XM2,P1,P2,IREJ1) | |
7390 | IF (IREJ1.NE.0) THEN | |
7391 | IF (JMSHL.EQ.0) GOTO 9998 | |
7392 | JMSHL = 0 | |
7393 | GOTO 14 | |
7394 | ENDIF | |
7395 | DO 12 I=1,4 | |
7396 | PP2(I) = P1(I) | |
7397 | PT2(I) = P2(I) | |
7398 | 12 CONTINUE | |
7399 | DO 15 I=1,4 | |
7400 | PP1I(I) = PP1(I) | |
7401 | PP2I(I) = PP2(I) | |
7402 | PT1I(I) = PT1(I) | |
7403 | PT2I(I) = PT2(I) | |
7404 | 15 CONTINUE | |
7405 | RETURN | |
7406 | ||
7407 | 9997 IRCHKI(1) = IRCHKI(1)+1 | |
7408 | **sr | |
7409 | C GOTO 9999 | |
7410 | IREJ = -1 | |
7411 | RETURN | |
7412 | ** | |
7413 | 9998 IRCHKI(2) = IRCHKI(2)+1 | |
7414 | ||
7415 | 9999 CONTINUE | |
7416 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in CHKINE' | |
7417 | IREJ = 1 | |
7418 | RETURN | |
7419 | END | |
7420 | ||
7421 | *$ CREATE DT_CH2RES.FOR | |
7422 | *COPY DT_CH2RES | |
7423 | * | |
7424 | *===ch2res=============================================================* | |
7425 | * | |
7426 | SUBROUTINE DT_CH2RES(IF1,IF2,IF3,IF4,IDR,IDXR, | |
7427 | & AM,AMN,IMODE,IREJ) | |
7428 | ||
7429 | ************************************************************************ | |
7430 | * Check chains for resonance production. * | |
7431 | * This subroutine replaces COMCMA/COBCMA/COMCM2 * | |
7432 | * input: * | |
7433 | * IF1,2,3,4 input flavors (q,aq in any order) * | |
7434 | * AM chain mass * | |
7435 | * MODE = 1 check q-aq chain for meson-resonance * | |
7436 | * = 2 check q-qq, aq-aqaq chain for baryon-resonance * | |
7437 | * = 3 check qq-aqaq chain for lower mass cut * | |
7438 | * output: * | |
7439 | * IDR = 0 no resonances found * | |
7440 | * = -1 pseudoscalar meson/octet baryon * | |
7441 | * = 1 vector-meson/decuplet baryon * | |
7442 | * IDXR BAMJET-index of corresponding resonance * | |
7443 | * AMN mass of corresponding resonance * | |
7444 | * * | |
7445 | * IREJ rejection flag * | |
7446 | * This version dated 06.01.95 is written by S. Roesler * | |
7447 | ************************************************************************ | |
7448 | ||
7449 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
7450 | SAVE | |
7451 | ||
7452 | PARAMETER ( LINP = 10 , | |
7453 | & LOUT = 6 , | |
7454 | & LDAT = 9 ) | |
7455 | ||
7456 | * particle properties (BAMJET index convention) | |
7457 | CHARACTER*8 ANAME | |
7458 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
7459 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
7460 | ||
7461 | * quark-content to particle index conversion (DTUNUC 1.x) | |
7462 | COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21), | |
7463 | & IA08(6,21),IA10(6,21) | |
7464 | ||
7465 | * rejection counter | |
7466 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
7467 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
7468 | & IREXCI(3),IRDIFF(2),IRINC | |
7469 | ||
7470 | * flags for input different options | |
7471 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
7472 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
7473 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
7474 | ||
7475 | DIMENSION IF(4),JF(4) | |
7476 | ||
7477 | **sr 4.7. test | |
7478 | C DATA AMLOM,AMLOB /0.08D0,0.2D0/ | |
7479 | DATA AMLOM,AMLOB /0.1D0,0.7D0/ | |
7480 | ** | |
7481 | C DATA AMLOM,AMLOB /0.001D0,0.001D0/ | |
7482 | ||
7483 | MODE = ABS(IMODE) | |
7484 | ||
7485 | IF ((MODE.LT.1).OR.(MODE.GT.3)) THEN | |
7486 | WRITE(LOUT,1000) MODE | |
7487 | 1000 FORMAT(1X,'CH2RES: MODE ',I4,' not supported!',/, | |
7488 | & 1X,' program stopped') | |
7489 | STOP | |
7490 | ENDIF | |
7491 | ||
7492 | AMX = AM | |
7493 | IREJ = 0 | |
7494 | IDR = 0 | |
7495 | IDXR = 0 | |
7496 | AMN = AMX | |
7497 | IF ((AM.LE.0.0D0).AND.(MODE.EQ.1)) AMX = AMLOM | |
7498 | IF ((AM.LE.0.0D0).AND.(MODE.EQ.2)) AMX = AMLOB | |
7499 | ||
7500 | IF(1) = IF1 | |
7501 | IF(2) = IF2 | |
7502 | IF(3) = IF3 | |
7503 | IF(4) = IF4 | |
7504 | NF = 0 | |
7505 | DO 100 I=1,4 | |
7506 | IF (IF(I).NE.0) THEN | |
7507 | NF = NF+1 | |
7508 | JF(NF) = IF(I) | |
7509 | ENDIF | |
7510 | 100 CONTINUE | |
7511 | IF (NF.LE.MODE) THEN | |
7512 | WRITE(LOUT,1001) MODE,IF | |
7513 | 1001 FORMAT(1X,'CH2RES: inconsistent input flavors in MODE ', | |
7514 | & I4,' IF1 = ',I4,' IF2 = ',I4,' IF3 = ',I4,' IF4 = ',I4) | |
7515 | GOTO 9999 | |
7516 | ENDIF | |
7517 | ||
7518 | GOTO (1,2,3) MODE | |
7519 | ||
7520 | * check for meson resonance | |
7521 | 1 CONTINUE | |
7522 | IFQ = JF(1) | |
7523 | IFAQ = ABS(JF(2)) | |
7524 | IF (JF(2).GT.0) THEN | |
7525 | IFQ = JF(2) | |
7526 | IFAQ = ABS(JF(1)) | |
7527 | ENDIF | |
7528 | IFPS = IMPS(IFAQ,IFQ) | |
7529 | IFV = IMVE(IFAQ,IFQ) | |
7530 | AMPS = AAM(IFPS) | |
7531 | AMV = AAM(IFV) | |
7532 | AMHI = AMV+0.3D0 | |
7533 | IF (AMX.LT.AMV) THEN | |
7534 | IF (AMX.LT.AMPS) THEN | |
7535 | IF (IMODE.GT.0) THEN | |
7536 | IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOM)) GOTO 9999 | |
7537 | ELSE | |
7538 | IF (AMX.LT.0.8D0*AMPS) GOTO 9999 | |
7539 | ENDIF | |
7540 | LOMRES = LOMRES+1 | |
7541 | ENDIF | |
7542 | * replace chain by pseudoscalar meson | |
7543 | IDR = -1 | |
7544 | IDXR = IFPS | |
7545 | AMN = AMPS | |
7546 | ELSEIF (AMX.LT.AMHI) THEN | |
7547 | * replace chain by vector-meson | |
7548 | IDR = 1 | |
7549 | IDXR = IFV | |
7550 | AMN = AMV | |
7551 | ENDIF | |
7552 | RETURN | |
7553 | ||
7554 | * check for baryon resonance | |
7555 | 2 CONTINUE | |
7556 | CALL DT_DBKLAS(JF(1),JF(2),JF(3),JB8,JB10) | |
7557 | AM8 = AAM(JB8) | |
7558 | AM10 = AAM(JB10) | |
7559 | AMHI = AM10+0.3D0 | |
7560 | IF (AMX.LT.AM10) THEN | |
7561 | IF (AMX.LT.AM8) THEN | |
7562 | IF (IMODE.GT.0) THEN | |
7563 | IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOB)) GOTO 9999 | |
7564 | ELSE | |
7565 | IF (AMX.LT.0.8D0*AM8) GOTO 9999 | |
7566 | ENDIF | |
7567 | LOBRES = LOBRES+1 | |
7568 | ENDIF | |
7569 | * replace chain by oktet baryon | |
7570 | IDR = -1 | |
7571 | IDXR = JB8 | |
7572 | AMN = AM8 | |
7573 | ELSEIF (AMX.LT.AMHI) THEN | |
7574 | IDR = 1 | |
7575 | IDXR = JB10 | |
7576 | AMN = AM10 | |
7577 | ENDIF | |
7578 | RETURN | |
7579 | ||
7580 | * check qq-aqaq for lower mass cut | |
7581 | 3 CONTINUE | |
7582 | * empirical definition of AMHI to allow for (b-antib)-pair prod. | |
7583 | AMHI = 2.5D0 | |
7584 | IF (AMX.LT.AMHI) GOTO 9999 | |
7585 | RETURN | |
7586 | ||
7587 | 9999 CONTINUE | |
7588 | IF ((IOULEV(1).GT.0).AND.(IMODE.GT.0)) | |
7589 | & WRITE(LOUT,*) 'rejected 1 in CH2RES',IMODE | |
7590 | IREJ = 1 | |
7591 | IRRES(2) = IRRES(2)+1 | |
7592 | RETURN | |
7593 | END | |
7594 | ||
7595 | *$ CREATE DT_RJSEAC.FOR | |
7596 | *COPY DT_RJSEAC | |
7597 | * | |
7598 | *===rjseac=============================================================* | |
7599 | * | |
7600 | SUBROUTINE DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ) | |
7601 | ||
7602 | ************************************************************************ | |
7603 | * ReJection of SEA-sea Chains. * | |
7604 | * MOP1/2 entries of projectile sea-partons in DTEVT1 * | |
7605 | * MOT1/2 entries of projectile sea-partons in DTEVT1 * | |
7606 | * This version dated 16.01.95 is written by S. Roesler * | |
7607 | ************************************************************************ | |
7608 | ||
7609 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
7610 | SAVE | |
7611 | ||
7612 | PARAMETER ( LINP = 10 , | |
7613 | & LOUT = 6 , | |
7614 | & LDAT = 9 ) | |
7615 | ||
7616 | PARAMETER (TINY10=1.0D-10,ZERO=0.0D0) | |
7617 | ||
7618 | * event history | |
7619 | ||
7620 | PARAMETER (NMXHKK=200000) | |
7621 | ||
7622 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
7623 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
7624 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
7625 | ||
7626 | * extended event history | |
7627 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
7628 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
7629 | & IHIST(2,NMXHKK) | |
7630 | ||
7631 | * statistics | |
7632 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
7633 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
7634 | & ICEVTG(8,0:30) | |
7635 | ||
7636 | DIMENSION IDXSEA(2,2),IDXNUC(2),ISTVAL(2) | |
7637 | ||
7638 | IREJ = 0 | |
7639 | ||
7640 | * projectile sea q-aq-pair | |
7641 | * indices of sea-pair | |
7642 | IDXSEA(1,1) = MOP1 | |
7643 | IDXSEA(1,2) = MOP2 | |
7644 | * index of mother-nucleon | |
7645 | IDXNUC(1) = JMOHKK(1,MOP1) | |
7646 | * status of valence quarks to be corrected | |
7647 | ISTVAL(1) = -21 | |
7648 | ||
7649 | * target sea q-aq-pair | |
7650 | * indices of sea-pair | |
7651 | IDXSEA(2,1) = MOT1 | |
7652 | IDXSEA(2,2) = MOT2 | |
7653 | * index of mother-nucleon | |
7654 | IDXNUC(2) = JMOHKK(1,MOT1) | |
7655 | * status of valence quarks to be corrected | |
7656 | ISTVAL(2) = -22 | |
7657 | ||
7658 | DO 1 N=1,2 | |
7659 | IDONE = 0 | |
7660 | DO 2 I=NPOINT(2),NHKK | |
7661 | IF ((ISTHKK(I).EQ.ISTVAL(N)).AND. | |
7662 | & (JMOHKK(1,I).EQ.IDXNUC(N))) THEN | |
7663 | * valence parton found | |
7664 | * inrease 4-momentum by sea 4-momentum | |
7665 | DO 3 K=1,4 | |
7666 | PHKK(K,I) = PHKK(K,I)+PHKK(K,IDXSEA(N,1))+ | |
7667 | & PHKK(K,IDXSEA(N,2)) | |
7668 | 3 CONTINUE | |
7669 | PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2- | |
7670 | & PHKK(2,I)**2-PHKK(3,I)**2)) | |
7671 | * "cancel" sea-pair | |
7672 | DO 4 J=1,2 | |
7673 | ISTHKK(IDXSEA(N,J)) = 100 | |
7674 | IDHKK(IDXSEA(N,J)) = 0 | |
7675 | JMOHKK(1,IDXSEA(N,J)) = 0 | |
7676 | JMOHKK(2,IDXSEA(N,J)) = 0 | |
7677 | JDAHKK(1,IDXSEA(N,J)) = 0 | |
7678 | JDAHKK(2,IDXSEA(N,J)) = 0 | |
7679 | DO 5 K=1,4 | |
7680 | PHKK(K,IDXSEA(N,J)) = ZERO | |
7681 | VHKK(K,IDXSEA(N,J)) = ZERO | |
7682 | WHKK(K,IDXSEA(N,J)) = ZERO | |
7683 | 5 CONTINUE | |
7684 | PHKK(5,IDXSEA(N,J)) = ZERO | |
7685 | 4 CONTINUE | |
7686 | IDONE = 1 | |
7687 | ENDIF | |
7688 | 2 CONTINUE | |
7689 | IF (IDONE.NE.1) THEN | |
7690 | WRITE(LOUT,1000) NEVHKK,MOP1,MOP2,MOT1,MOT2 | |
7691 | 1000 FORMAT(1X,'RJSEAC: event ',I8,': inconsistent event', | |
7692 | & '-record!',/,1X,' sea-quark pairs ', | |
7693 | & 2I5,4X,2I5,' could not be canceled!') | |
7694 | GOTO 9999 | |
7695 | ENDIF | |
7696 | 1 CONTINUE | |
7697 | ICRJSS = ICRJSS+1 | |
7698 | RETURN | |
7699 | ||
7700 | 9999 CONTINUE | |
7701 | IREJ = 1 | |
7702 | RETURN | |
7703 | END | |
7704 | ||
7705 | *$ CREATE DT_VV2SCH.FOR | |
7706 | *COPY DT_VV2SCH | |
7707 | * | |
7708 | *===vv2sch=============================================================* | |
7709 | * | |
7710 | SUBROUTINE DT_VV2SCH | |
7711 | ||
7712 | ************************************************************************ | |
7713 | * Change Valence-Valence chain systems to Single CHain systems for * | |
7714 | * hadron-nucleus collisions with meson or antibaryon projectile. * | |
7715 | * (Reggeon contribution) * | |
7716 | * The single chain system is approximately treated as one chain and a * | |
7717 | * meson at rest. * | |
7718 | * This version dated 18.01.95 is written by S. Roesler * | |
7719 | ************************************************************************ | |
7720 | ||
7721 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
7722 | SAVE | |
7723 | ||
7724 | PARAMETER ( LINP = 10 , | |
7725 | & LOUT = 6 , | |
7726 | & LDAT = 9 ) | |
7727 | ||
7728 | PARAMETER (ZERO=0.0D0,TINY7=1.0D-7,TINY3=1.0D-3) | |
7729 | ||
7730 | LOGICAL LSTART | |
7731 | ||
7732 | * event history | |
7733 | ||
7734 | PARAMETER (NMXHKK=200000) | |
7735 | ||
7736 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
7737 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
7738 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
7739 | ||
7740 | * extended event history | |
7741 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
7742 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
7743 | & IHIST(2,NMXHKK) | |
7744 | ||
7745 | * flags for input different options | |
7746 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
7747 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
7748 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
7749 | ||
7750 | * statistics | |
7751 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
7752 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
7753 | & ICEVTG(8,0:30) | |
7754 | ||
7755 | DIMENSION IF(4,2),MO(4),PP1(4),PP2(4),PT1(4),PT2(4),PCH1(4), | |
7756 | & PCH2(4) | |
7757 | ||
7758 | DATA LSTART /.TRUE./ | |
7759 | ||
7760 | IFSC = 0 | |
7761 | IF (LSTART) THEN | |
7762 | WRITE(LOUT,1000) | |
7763 | 1000 FORMAT(/,1X,'VV2SCH: Reggeon contribution to valance-', | |
7764 | & 'valence chains treated') | |
7765 | LSTART = .FALSE. | |
7766 | ENDIF | |
7767 | ||
7768 | NSTOP = NHKK | |
7769 | ||
7770 | * get index of first chain | |
7771 | DO 1 I=NPOINT(3),NHKK | |
7772 | IF (IDHKK(I).EQ.88888) THEN | |
7773 | NC = I | |
7774 | GOTO 2 | |
7775 | ENDIF | |
7776 | 1 CONTINUE | |
7777 | ||
7778 | 2 CONTINUE | |
7779 | IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888) | |
7780 | & .AND.(NC.LT.NSTOP)) THEN | |
7781 | * get valence-valence chains | |
7782 | IF ((IDCH(NC).EQ.8).AND.(IDCH(NC+3).EQ.8)) THEN | |
7783 | * get "mother"-hadron indices | |
7784 | MO1 = JMOHKK(1,JMOHKK(1,JMOHKK(1,NC))) | |
7785 | MO2 = JMOHKK(1,JMOHKK(1,JMOHKK(2,NC))) | |
7786 | KPROJ = IDT_ICIHAD(IDHKK(MO1)) | |
7787 | KTARG = IDT_ICIHAD(IDHKK(MO2)) | |
7788 | * Lab momentum of projectile hadron | |
7789 | CALL DT_LTNUC(PHKK(3,MO1),PHKK(4,MO1),PPZ,PPE,-3) | |
7790 | PTOT = SQRT(PHKK(1,MO1)**2+PHKK(2,MO1)**2+ | |
7791 | & PHKK(3,MO1)**2) | |
7792 | ||
7793 | SICHAP = DT_PHNSCH(KPROJ,KTARG,PTOT) | |
7794 | IF (DT_RNDM(PTOT).LE.SICHAP) THEN | |
7795 | ICVV2S = ICVV2S+1 | |
7796 | * single chain requested | |
7797 | * get flavors of chain-end partons | |
7798 | MO(1) = JMOHKK(1,NC) | |
7799 | MO(2) = JMOHKK(2,NC) | |
7800 | MO(3) = JMOHKK(1,NC+3) | |
7801 | MO(4) = JMOHKK(2,NC+3) | |
7802 | DO 3 I=1,4 | |
7803 | IF(I,1) = IDT_IPDG2B(IDHKK(MO(I)),1,2) | |
7804 | IF(I,2) = 0 | |
7805 | IF (ABS(IDHKK(MO(I))).GE.1000) | |
7806 | & IF(I,2) = IDT_IPDG2B(IDHKK(MO(I)),2,2) | |
7807 | 3 CONTINUE | |
7808 | * which one is the q-aq chain? | |
7809 | * N1,N1+1 - DTEVT1-entries for q-aq system | |
7810 | * N2,N2+1 - DTEVT1-entries for the other chain | |
7811 | IF ((IF(1,2).EQ.0).AND.(IF(2,2).EQ.0)) THEN | |
7812 | K1 = 1 | |
7813 | K2 = 3 | |
7814 | N1 = NC-2 | |
7815 | N2 = NC+1 | |
7816 | ELSEIF ((IF(3,2).EQ.0).AND.(IF(4,2).EQ.0)) THEN | |
7817 | K1 = 3 | |
7818 | K2 = 1 | |
7819 | N1 = NC+1 | |
7820 | N2 = NC-2 | |
7821 | ELSE | |
7822 | GOTO 10 | |
7823 | ENDIF | |
7824 | DO 4 K=1,4 | |
7825 | PP1(K) = PHKK(K,N1) | |
7826 | PT1(K) = PHKK(K,N1+1) | |
7827 | PP2(K) = PHKK(K,N2) | |
7828 | PT2(K) = PHKK(K,N2+1) | |
7829 | 4 CONTINUE | |
7830 | AMCH1 = PHKK(5,N1+2) | |
7831 | AMCH2 = PHKK(5,N2+2) | |
7832 | * get meson-identity corresponding to flavors of q-aq chain | |
7833 | ITMP = IRESRJ | |
7834 | IRESRJ = 0 | |
7835 | CALL DT_CH2RES(IF(K1,1),IF(K1+1,1),0,0,IDR1,IDXR1, | |
7836 | & ZERO,AMCH1N,1,IDUM) | |
7837 | IRESRJ = ITMP | |
7838 | * change kinematics of chains | |
7839 | CALL DT_CHKINE(PP1,IDHKK(N1), PP2,IDHKK(N2), | |
7840 | & PT1,IDHKK(N1+1),PT2,IDHKK(N2+1), | |
7841 | & AMCH1,AMCH1N,AMCH2,IREJ1) | |
7842 | IF (IREJ1.NE.0) GOTO 10 | |
7843 | * check second chain for resonance | |
7844 | IDCHAI = 2 | |
7845 | IF ((IF(K2,2).NE.0).AND.(IF(K2+1,2).NE.0)) IDCHAI = 3 | |
7846 | CALL DT_CH2RES(IF(K2,1),IF(K2,2),IF(K2+1,1),IF(K2+1,2), | |
7847 | & IDR2,IDXR2,AMCH2,AMCH2N,IDCHAI,IREJ1) | |
7848 | IF (IREJ1.NE.0) GOTO 10 | |
7849 | IF (IDR2.NE.0) IDR2 = 100*IDR2 | |
7850 | * add partons and chains to DTEVT1 | |
7851 | DO 5 K=1,4 | |
7852 | PCH1(K) = PP1(K)+PT1(K) | |
7853 | PCH2(K) = PP2(K)+PT2(K) | |
7854 | 5 CONTINUE | |
7855 | CALL DT_EVTPUT(ISTHKK(N1),IDHKK(N1),N1,0,PP1(1),PP1(2), | |
7856 | & PP1(3),PP1(4),0,0,0) | |
7857 | CALL DT_EVTPUT(ISTHKK(N1+1),IDHKK(N1+1),N1+1,0,PT1(1), | |
7858 | & PT1(2),PT1(3),PT1(4),0,0,0) | |
7859 | KCH = ISTHKK(N1+2)+100 | |
7860 | CALL DT_EVTPUT(KCH,88888,-2,-1,PCH1(1),PCH1(2),PCH1(3), | |
7861 | & PCH1(4),IDR1,IDXR1,IDCH(N1+2)) | |
7862 | IDHKK(N1+2) = 22222 | |
7863 | CALL DT_EVTPUT(ISTHKK(N2),IDHKK(N2),N2,0,PP2(1),PP2(2), | |
7864 | & PP2(3),PP2(4),0,0,0) | |
7865 | CALL DT_EVTPUT(ISTHKK(N2+1),IDHKK(N2+1),N2+1,0,PT2(1), | |
7866 | & PT2(2),PT2(3),PT2(4),0,0,0) | |
7867 | KCH = ISTHKK(N2+2)+100 | |
7868 | CALL DT_EVTPUT(KCH,88888,-2,-1,PCH2(1),PCH2(2),PCH2(3), | |
7869 | & PCH2(4),IDR2,IDXR2,IDCH(N2+2)) | |
7870 | IDHKK(N2+2) = 22222 | |
7871 | ENDIF | |
7872 | ENDIF | |
7873 | ELSE | |
7874 | GOTO 11 | |
7875 | ENDIF | |
7876 | 10 CONTINUE | |
7877 | NC = NC+6 | |
7878 | GOTO 2 | |
7879 | ||
7880 | 11 CONTINUE | |
7881 | ||
7882 | RETURN | |
7883 | END | |
7884 | ||
7885 | *$ CREATE DT_PHNSCH.FOR | |
7886 | *COPY DT_PHNSCH | |
7887 | * | |
7888 | *=== phnsch ===========================================================* | |
7889 | * | |
7890 | DOUBLE PRECISION FUNCTION DT_PHNSCH( KP, KTARG, PLAB ) | |
7891 | ||
7892 | *----------------------------------------------------------------------* | |
7893 | * * | |
7894 | * Probability for Hadron Nucleon Single CHain interactions: * | |
7895 | * * | |
7896 | * Created on 30 december 1993 by Alfredo Ferrari & Paola Sala * | |
7897 | * Infn - Milan * | |
7898 | * * | |
7899 | * Last change on 04-jan-94 by Alfredo Ferrari * | |
7900 | * * | |
7901 | * modified by J.R.for use in DTUNUC 6.1.94 * | |
7902 | * * | |
7903 | * Input variables: * | |
7904 | * Kp = hadron projectile index (Part numbering * | |
7905 | * scheme) * | |
7906 | * Ktarg = target nucleon index (1=proton, 8=neutron) * | |
7907 | * Plab = projectile laboratory momentum (GeV/c) * | |
7908 | * Output variable: * | |
7909 | * Phnsch = probability per single chain (particle * | |
7910 | * exchange) interactions * | |
7911 | * * | |
7912 | *----------------------------------------------------------------------* | |
7913 | ||
7914 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
7915 | SAVE | |
7916 | ||
7917 | PARAMETER ( LUNOUT = 6 ) | |
7918 | PARAMETER ( LUNERR = 6 ) | |
7919 | PARAMETER ( ONEPLS = 1.000000000000001 D+00 ) | |
7920 | PARAMETER ( ZERZER = 0.D+00 ) | |
7921 | PARAMETER ( ONEONE = 1.D+00 ) | |
7922 | PARAMETER ( TWOTWO = 2.D+00 ) | |
7923 | PARAMETER ( FIVFIV = 5.D+00 ) | |
7924 | PARAMETER ( HLFHLF = 0.5D+00 ) | |
7925 | ||
7926 | PARAMETER ( NALLWP = 39 ) | |
7927 | PARAMETER ( IDMAXP = 210 ) | |
7928 | ||
7929 | DIMENSION ICHRGE(39),AM(39) | |
7930 | ||
7931 | * particle properties (BAMJET index convention) | |
7932 | CHARACTER*8 ANAME | |
7933 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
7934 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
7935 | ||
7936 | DIMENSION KPTOIP(210) | |
7937 | ||
7938 | * auxiliary common for reggeon exchange (DTUNUC 1.x) | |
7939 | COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6), | |
7940 | & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6), | |
7941 | & IQTCHR(-6:6),MQUARK(3,39) | |
7942 | ||
7943 | DIMENSION SGTCOE (5,33), IHLP (NALLWP) | |
7944 | DIMENSION SGTCO1(5,10),SGTCO2(5,8),SGTCO3(5,15) | |
7945 | EQUIVALENCE (SGTCO1(1,1),SGTCOE(1,1)) | |
7946 | EQUIVALENCE (SGTCO2(1,1),SGTCOE(1,11)) | |
7947 | EQUIVALENCE (SGTCO3(1,1),SGTCOE(1,19)) | |
7948 | ||
7949 | * Conversion from part to paprop numbering | |
7950 | DATA KPTOIP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, | |
7951 | & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 66*0, | |
7952 | & 34, 36, 31, 32, 33, 35, 37, 5*0, 38, 5*0, 39, 19*0, 27, 28, 74*0/ | |
7953 | ||
7954 | * 1=baryon, 2=pion, 3=kaon, 4=antibaryon: | |
7955 | DATA IHLP/1,4,5*0,1,4,2*0,3,2*2,2*3,1,4,3,3*1,2, | |
7956 | & 2*3, 2, 4*0, 3*4, 1, 4, 1, 4, 1, 4 / | |
7957 | C DATA ( ( SGTCOE (J,I), J=1,5 ), I=1,10 ) / | |
7958 | DATA SGTCO1 / | |
7959 | * 1st reaction: gamma p total | |
7960 | &0.147 D+00, ZERZER , ZERZER , 0.0022D+00, -0.0170D+00, | |
7961 | * 2nd reaction: gamma d total | |
7962 | &0.300 D+00, ZERZER , ZERZER , 0.0095D+00, -0.057 D+00, | |
7963 | * 3rd reaction: pi+ p total | |
7964 | &16.4 D+00, 19.3D+00, -0.42D+00, 0.19 D+00, ZERZER , | |
7965 | * 4th reaction: pi- p total | |
7966 | &33.0 D+00, 14.0D+00, -1.36D+00, 0.456 D+00, -4.03 D+00, | |
7967 | * 5th reaction: pi+/- d total | |
7968 | &56.8 D+00, 42.2D+00, -1.45D+00, 0.65 D+00, -5.39 D+00, | |
7969 | * 6th reaction: K+ p total | |
7970 | &18.1 D+00, ZERZER , ZERZER , 0.26 D+00, -1.0 D+00, | |
7971 | * 7th reaction: K+ n total | |
7972 | &18.7 D+00, ZERZER , ZERZER , 0.21 D+00, -0.89 D+00, | |
7973 | * 8th reaction: K+ d total | |
7974 | &34.2 D+00, 7.9 D+00, -2.1 D+00, 0.346 D+00, -0.99 D+00, | |
7975 | * 9th reaction: K- p total | |
7976 | &32.1 D+00, ZERZER , ZERZER , 0.66 D+00, -5.6 D+00, | |
7977 | * 10th reaction: K- n total | |
7978 | &25.2 D+00, ZERZER , ZERZER , 0.38 D+00, -2.9 D+00/ | |
7979 | C DATA ( ( SGTCOE (J,I), J=1,5 ), I=11,18 ) / | |
7980 | DATA SGTCO2 / | |
7981 | * 11th reaction: K- d total | |
7982 | &57.6 D+00, ZERZER , ZERZER , 1.17 D+00, -9.5 D+00, | |
7983 | * 12th reaction: p p total | |
7984 | &48.0 D+00, ZERZER , ZERZER , 0.522 D+00, -4.51 D+00, | |
7985 | * 13th reaction: p n total | |
7986 | &47.30 D+00, ZERZER , ZERZER , 0.513 D+00, -4.27 D+00, | |
7987 | * 14th reaction: p d total | |
7988 | &91.3 D+00, ZERZER , ZERZER , 1.05 D+00, -8.8 D+00, | |
7989 | * 15th reaction: pbar p total | |
7990 | &38.4 D+00, 77.6D+00, -0.64D+00, 0.26 D+00, -1.2 D+00, | |
7991 | * 16th reaction: pbar n total | |
7992 | &ZERZER ,133.6D+00, -0.70D+00, -1.22 D+00, 13.7 D+00, | |
7993 | * 17th reaction: pbar d total | |
7994 | &112. D+00, 125.D+00, -1.08D+00, 1.14 D+00, -12.4 D+00, | |
7995 | * 18th reaction: Lamda p total | |
7996 | &30.4 D+00, ZERZER , ZERZER , ZERZER , 1.6 D+00/ | |
7997 | C DATA ( ( SGTCOE (J,I), J=1,5 ), I=19,33 ) / | |
7998 | DATA SGTCO3 / | |
7999 | * 19th reaction: pi+ p elastic | |
8000 | &ZERZER , 11.4D+00, -0.4 D+00, 0.079 D+00, ZERZER , | |
8001 | * 20th reaction: pi- p elastic | |
8002 | &1.76 D+00, 11.2D+00, -0.64D+00, 0.043 D+00, ZERZER , | |
8003 | * 21st reaction: K+ p elastic | |
8004 | &5.0 D+00, 8.1 D+00, -1.8 D+00, 0.16 D+00, -1.3 D+00, | |
8005 | * 22nd reaction: K- p elastic | |
8006 | &7.3 D+00, ZERZER , ZERZER , 0.29 D+00, -2.40 D+00, | |
8007 | * 23rd reaction: p p elastic | |
8008 | &11.9 D+00, 26.9D+00, -1.21D+00, 0.169 D+00, -1.85 D+00, | |
8009 | * 24th reaction: p d elastic | |
8010 | &16.1 D+00, ZERZER , ZERZER , 0.32 D+00, -3.4 D+00, | |
8011 | * 25th reaction: pbar p elastic | |
8012 | &10.2 D+00, 52.7D+00, -1.16D+00, 0.125 D+00, -1.28 D+00, | |
8013 | * 26th reaction: pbar p elastic bis | |
8014 | &10.6 D+00, 53.1D+00, -1.19D+00, 0.136 D+00, -1.41 D+00, | |
8015 | * 27th reaction: pbar n elastic | |
8016 | &36.5 D+00, ZERZER , ZERZER , ZERZER , -11.9 D+00, | |
8017 | * 28th reaction: Lamda p elastic | |
8018 | &12.3 D+00, ZERZER , ZERZER , ZERZER , -2.4 D+00, | |
8019 | * 29th reaction: K- p ela bis | |
8020 | &7.24 D+00, 46.0D+00, -4.71D+00, 0.279 D+00, -2.35 D+00, | |
8021 | * 30th reaction: pi- p cx | |
8022 | &ZERZER ,0.912D+00, -1.22D+00, ZERZER , ZERZER , | |
8023 | * 31st reaction: K- p cx | |
8024 | &ZERZER , 3.39D+00, -1.75D+00, ZERZER , ZERZER , | |
8025 | * 32nd reaction: K+ n cx | |
8026 | &ZERZER , 7.18D+00, -2.01D+00, ZERZER , ZERZER , | |
8027 | * 33rd reaction: pbar p cx | |
8028 | &ZERZER , 18.8D+00, -2.01D+00, ZERZER , ZERZER / | |
8029 | * | |
8030 | * +-------------------------------------------------------------------* | |
8031 | ICHRGE(KTARG)=IICH(KTARG) | |
8032 | AM (KTARG)=AAM (KTARG) | |
8033 | * | Check for pi0 (d-dbar) | |
8034 | IF ( KP .NE. 26 ) THEN | |
8035 | IP = KPTOIP (KP) | |
8036 | IF(IP.EQ.0)IP=1 | |
8037 | ICHRGE(IP)=IICH(KP) | |
8038 | AM (IP)=AAM (KP) | |
8039 | * | | |
8040 | * +-------------------------------------------------------------------* | |
8041 | * | | |
8042 | ELSE | |
8043 | IP = 23 | |
8044 | ICHRGE(IP)=0 | |
8045 | END IF | |
8046 | * | | |
8047 | * +-------------------------------------------------------------------* | |
8048 | * +-------------------------------------------------------------------* | |
8049 | * | No such interactions for baryon-baryon | |
8050 | IF ( IIBAR (KP) .GT. 0 ) THEN | |
8051 | DT_PHNSCH = ZERZER | |
8052 | RETURN | |
8053 | * | | |
8054 | * +-------------------------------------------------------------------* | |
8055 | * | No "annihilation" diagram possible for K+ p/n | |
8056 | ELSE IF ( IP .EQ. 15 ) THEN | |
8057 | DT_PHNSCH = ZERZER | |
8058 | RETURN | |
8059 | * | | |
8060 | * +-------------------------------------------------------------------* | |
8061 | * | No "annihilation" diagram possible for K0 p/n | |
8062 | ELSE IF ( IP .EQ. 24 ) THEN | |
8063 | DT_PHNSCH = ZERZER | |
8064 | RETURN | |
8065 | * | | |
8066 | * +-------------------------------------------------------------------* | |
8067 | * | No "annihilation" diagram possible for Omebar p/n | |
8068 | ELSE IF ( IP .GE. 38 ) THEN | |
8069 | DT_PHNSCH = ZERZER | |
8070 | RETURN | |
8071 | END IF | |
8072 | * | | |
8073 | * +-------------------------------------------------------------------* | |
8074 | * +-------------------------------------------------------------------* | |
8075 | * | If the momentum is larger than 50 GeV/c, compute the single | |
8076 | * | chain probability at 50 GeV/c and extrapolate to the present | |
8077 | * | momentum according to 1/sqrt(s) | |
8078 | * | sigma = sigma_sch (50) * sqrt (s(50)/s) + sigma_dch | |
8079 | * | P_sch (50) = sigma_sch (50) / ( sigma_dch + sigma_sch (50) ) | |
8080 | * | sigma_dch / sigma_sch (50) = 1 / P_sch (50) - 1 | |
8081 | * | sigma_dch / sigma_sch = 1 / P_sch - 1 = ( 1 / P_sch (50) - 1 ) | |
8082 | * | x sqrt(s/s(50)) | |
8083 | * | P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ] | |
8084 | IF ( PLAB .GT. 50.D+00 ) THEN | |
8085 | PLA = 50.D+00 | |
8086 | AMPSQ = AM (IP)**2 | |
8087 | AMTSQ = AM (KTARG)**2 | |
8088 | EPROJ = SQRT ( PLAB**2 + AMPSQ ) | |
8089 | UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ | |
8090 | EPROJ = SQRT ( PLA**2 + AMPSQ ) | |
8091 | UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ | |
8092 | UMORAT = SQRT ( UMOSQ / UMO50 ) | |
8093 | * | | |
8094 | * +-------------------------------------------------------------------* | |
8095 | * | P < 3 GeV/c | |
8096 | ELSE IF ( PLAB .LT. 3.D+00 ) THEN | |
8097 | PLA = 3.D+00 | |
8098 | AMPSQ = AM (IP)**2 | |
8099 | AMTSQ = AM (KTARG)**2 | |
8100 | EPROJ = SQRT ( PLAB**2 + AMPSQ ) | |
8101 | UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ | |
8102 | EPROJ = SQRT ( PLA**2 + AMPSQ ) | |
8103 | UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ | |
8104 | UMORAT = SQRT ( UMOSQ / UMO50 ) | |
8105 | * | | |
8106 | * +-------------------------------------------------------------------* | |
8107 | * | P < 50 GeV/c | |
8108 | ELSE | |
8109 | PLA = PLAB | |
8110 | UMORAT = ONEONE | |
8111 | END IF | |
8112 | * | | |
8113 | * +-------------------------------------------------------------------* | |
8114 | ALGPLA = LOG (PLA) | |
8115 | * +-------------------------------------------------------------------* | |
8116 | * | Pions: | |
8117 | IF ( IHLP (IP) .EQ. 2 ) THEN | |
8118 | ACOF = SGTCOE (1,3) | |
8119 | BCOF = SGTCOE (2,3) | |
8120 | ENNE = SGTCOE (3,3) | |
8121 | CCOF = SGTCOE (4,3) | |
8122 | DCOF = SGTCOE (5,3) | |
8123 | * | Compute the pi+ p total cross section: | |
8124 | SPPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
8125 | & + DCOF * ALGPLA | |
8126 | ACOF = SGTCOE (1,19) | |
8127 | BCOF = SGTCOE (2,19) | |
8128 | ENNE = SGTCOE (3,19) | |
8129 | CCOF = SGTCOE (4,19) | |
8130 | DCOF = SGTCOE (5,19) | |
8131 | * | Compute the pi+ p elastic cross section: | |
8132 | SPPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
8133 | & + DCOF * ALGPLA | |
8134 | * | Compute the pi+ p inelastic cross section: | |
8135 | SPPPIN = SPPPTT - SPPPEL | |
8136 | ACOF = SGTCOE (1,4) | |
8137 | BCOF = SGTCOE (2,4) | |
8138 | ENNE = SGTCOE (3,4) | |
8139 | CCOF = SGTCOE (4,4) | |
8140 | DCOF = SGTCOE (5,4) | |
8141 | * | Compute the pi- p total cross section: | |
8142 | SPMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
8143 | & + DCOF * ALGPLA | |
8144 | ACOF = SGTCOE (1,20) | |
8145 | BCOF = SGTCOE (2,20) | |
8146 | ENNE = SGTCOE (3,20) | |
8147 | CCOF = SGTCOE (4,20) | |
8148 | DCOF = SGTCOE (5,20) | |
8149 | * | Compute the pi- p elastic cross section: | |
8150 | SPMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
8151 | & + DCOF * ALGPLA | |
8152 | * | Compute the pi- p inelastic cross section: | |
8153 | SPMPIN = SPMPTT - SPMPEL | |
8154 | SIGDIA = SPMPIN - SPPPIN | |
8155 | * | +----------------------------------------------------------------* | |
8156 | * | | Charged pions: besides isospin consideration it is supposed | |
8157 | * | | that (pi+ n)el is almost equal to (pi- p)el | |
8158 | * | | and (pi+ p)el " " " " (pi- n)el | |
8159 | * | | and all are almost equal among each others | |
8160 | * | | (reasonable above 5 GeV/c) | |
8161 | IF ( ICHRGE (IP) .NE. 0 ) THEN | |
8162 | KHELP = KTARG / 8 | |
8163 | JREAC = 3 + IP - 13 + ICHRGE (IP) * KHELP | |
8164 | ACOF = SGTCOE (1,JREAC) | |
8165 | BCOF = SGTCOE (2,JREAC) | |
8166 | ENNE = SGTCOE (3,JREAC) | |
8167 | CCOF = SGTCOE (4,JREAC) | |
8168 | DCOF = SGTCOE (5,JREAC) | |
8169 | * | | Compute the total cross section: | |
8170 | SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
8171 | & + DCOF * ALGPLA | |
8172 | JREAC = 19 + IP - 13 + ICHRGE (IP) * KHELP | |
8173 | ACOF = SGTCOE (1,JREAC) | |
8174 | BCOF = SGTCOE (2,JREAC) | |
8175 | ENNE = SGTCOE (3,JREAC) | |
8176 | CCOF = SGTCOE (4,JREAC) | |
8177 | DCOF = SGTCOE (5,JREAC) | |
8178 | * | | Compute the elastic cross section: | |
8179 | SHNCEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
8180 | & + DCOF * ALGPLA | |
8181 | * | | Compute the inelastic cross section: | |
8182 | SHNCIN = SHNCTT - SHNCEL | |
8183 | * | | Number of diagrams: | |
8184 | NDIAGR = 1 + IP - 13 + ICHRGE (IP) * KHELP | |
8185 | * | | Now compute the chain end (anti)quark-(anti)diquark | |
8186 | IQFSC1 = 1 + IP - 13 | |
8187 | IQFSC2 = 0 | |
8188 | IQBSC1 = 1 + KHELP | |
8189 | IQBSC2 = 1 + IP - 13 | |
8190 | * | | | |
8191 | * | +----------------------------------------------------------------* | |
8192 | * | | pi0: besides isospin consideration it is supposed that the | |
8193 | * | | elastic cross section is not very different from | |
8194 | * | | pi+ p and/or pi- p (reasonable above 5 GeV/c) | |
8195 | ELSE | |
8196 | KHELP = KTARG / 8 | |
8197 | K2HLP = ( KP - 23 ) / 3 | |
8198 | * | | Number of diagrams: | |
8199 | * | | For u ubar (k2hlp=0): | |
8200 | * NDIAGR = 2 - KHELP | |
8201 | * | | For d dbar (k2hlp=1): | |
8202 | * NDIAGR = 2 + KHELP - K2HLP | |
8203 | NDIAGR = 2 + KHELP * ( 2 * K2HLP - 1 ) - K2HLP | |
8204 | SHNCIN = HLFHLF * ( SPPPIN + SPMPIN ) | |
8205 | * | | Now compute the chain end (anti)quark-(anti)diquark | |
8206 | IQFSC1 = 1 + K2HLP | |
8207 | IQFSC2 = 0 | |
8208 | IQBSC1 = 1 + KHELP | |
8209 | IQBSC2 = 2 - K2HLP | |
8210 | END IF | |
8211 | * | | | |
8212 | * | +----------------------------------------------------------------* | |
8213 | * | end pi's | |
8214 | * +-------------------------------------------------------------------* | |
8215 | * | Kaons: | |
8216 | ELSE IF ( IHLP (IP) .EQ. 3 ) THEN | |
8217 | ACOF = SGTCOE (1,6) | |
8218 | BCOF = SGTCOE (2,6) | |
8219 | ENNE = SGTCOE (3,6) | |
8220 | CCOF = SGTCOE (4,6) | |
8221 | DCOF = SGTCOE (5,6) | |
8222 | * | Compute the K+ p total cross section: | |
8223 | SKPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
8224 | & + DCOF * ALGPLA | |
8225 | ACOF = SGTCOE (1,21) | |
8226 | BCOF = SGTCOE (2,21) | |
8227 | ENNE = SGTCOE (3,21) | |
8228 | CCOF = SGTCOE (4,21) | |
8229 | DCOF = SGTCOE (5,21) | |
8230 | * | Compute the K+ p elastic cross section: | |
8231 | SKPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
8232 | & + DCOF * ALGPLA | |
8233 | * | Compute the K+ p inelastic cross section: | |
8234 | SKPPIN = SKPPTT - SKPPEL | |
8235 | ACOF = SGTCOE (1,9) | |
8236 | BCOF = SGTCOE (2,9) | |
8237 | ENNE = SGTCOE (3,9) | |
8238 | CCOF = SGTCOE (4,9) | |
8239 | DCOF = SGTCOE (5,9) | |
8240 | * | Compute the K- p total cross section: | |
8241 | SKMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
8242 | & + DCOF * ALGPLA | |
8243 | ACOF = SGTCOE (1,22) | |
8244 | BCOF = SGTCOE (2,22) | |
8245 | ENNE = SGTCOE (3,22) | |
8246 | CCOF = SGTCOE (4,22) | |
8247 | DCOF = SGTCOE (5,22) | |
8248 | * | Compute the K- p elastic cross section: | |
8249 | SKMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
8250 | & + DCOF * ALGPLA | |
8251 | * | Compute the K- p inelastic cross section: | |
8252 | SKMPIN = SKMPTT - SKMPEL | |
8253 | SIGDIA = HLFHLF * ( SKMPIN - SKPPIN ) | |
8254 | * | +----------------------------------------------------------------* | |
8255 | * | | Charged Kaons: actually only K- | |
8256 | IF ( ICHRGE (IP) .NE. 0 ) THEN | |
8257 | KHELP = KTARG / 8 | |
8258 | * | | +-------------------------------------------------------------* | |
8259 | * | | | Proton target: | |
8260 | IF ( KHELP .EQ. 0 ) THEN | |
8261 | SHNCIN = SKMPIN | |
8262 | * | | | Number of diagrams: | |
8263 | NDIAGR = 2 | |
8264 | * | | | | |
8265 | * | | +-------------------------------------------------------------* | |
8266 | * | | | Neutron target: besides isospin consideration it is supposed | |
8267 | * | | | that (K- n)el is almost equal to (K- p)el | |
8268 | * | | | (reasonable above 5 GeV/c) | |
8269 | ELSE | |
8270 | ACOF = SGTCOE (1,10) | |
8271 | BCOF = SGTCOE (2,10) | |
8272 | ENNE = SGTCOE (3,10) | |
8273 | CCOF = SGTCOE (4,10) | |
8274 | DCOF = SGTCOE (5,10) | |
8275 | * | | | Compute the total cross section: | |
8276 | SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
8277 | & + DCOF * ALGPLA | |
8278 | * | | | Compute the elastic cross section: | |
8279 | SHNCEL = SKMPEL | |
8280 | * | | | Compute the inelastic cross section: | |
8281 | SHNCIN = SHNCTT - SHNCEL | |
8282 | * | | | Number of diagrams: | |
8283 | NDIAGR = 1 | |
8284 | END IF | |
8285 | * | | | | |
8286 | * | | +-------------------------------------------------------------* | |
8287 | * | | Now compute the chain end (anti)quark-(anti)diquark | |
8288 | IQFSC1 = 3 | |
8289 | IQFSC2 = 0 | |
8290 | IQBSC1 = 1 + KHELP | |
8291 | IQBSC2 = 2 | |
8292 | * | | | |
8293 | * | +----------------------------------------------------------------* | |
8294 | * | | K0's: (actually only K0bar) | |
8295 | ELSE | |
8296 | KHELP = KTARG / 8 | |
8297 | * | | +-------------------------------------------------------------* | |
8298 | * | | | Proton target: (K0bar p)in supposed to be given by | |
8299 | * | | | (K- p)in - Sig_diagr | |
8300 | IF ( KHELP .EQ. 0 ) THEN | |
8301 | SHNCIN = SKMPIN - SIGDIA | |
8302 | * | | | Number of diagrams: | |
8303 | NDIAGR = 1 | |
8304 | * | | | | |
8305 | * | | +-------------------------------------------------------------* | |
8306 | * | | | Neutron target: (K0bar n)in supposed to be given by | |
8307 | * | | | (K- n)in + Sig_diagr | |
8308 | * | | | besides isospin consideration it is supposed | |
8309 | * | | | that (K- n)el is almost equal to (K- p)el | |
8310 | * | | | (reasonable above 5 GeV/c) | |
8311 | ELSE | |
8312 | ACOF = SGTCOE (1,10) | |
8313 | BCOF = SGTCOE (2,10) | |
8314 | ENNE = SGTCOE (3,10) | |
8315 | CCOF = SGTCOE (4,10) | |
8316 | DCOF = SGTCOE (5,10) | |
8317 | * | | | Compute the total cross section: | |
8318 | SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
8319 | & + DCOF * ALGPLA | |
8320 | * | | | Compute the elastic cross section: | |
8321 | SHNCEL = SKMPEL | |
8322 | * | | | Compute the inelastic cross section: | |
8323 | SHNCIN = SHNCTT - SHNCEL + SIGDIA | |
8324 | * | | | Number of diagrams: | |
8325 | NDIAGR = 2 | |
8326 | END IF | |
8327 | * | | | | |
8328 | * | | +-------------------------------------------------------------* | |
8329 | * | | Now compute the chain end (anti)quark-(anti)diquark | |
8330 | IQFSC1 = 3 | |
8331 | IQFSC2 = 0 | |
8332 | IQBSC1 = 1 | |
8333 | IQBSC2 = 1 + KHELP | |
8334 | END IF | |
8335 | * | | | |
8336 | * | +----------------------------------------------------------------* | |
8337 | * | end Kaon's | |
8338 | * +-------------------------------------------------------------------* | |
8339 | * | Antinucleons: | |
8340 | ELSE IF ( IHLP (IP) .EQ. 4 .AND. IP .LE. 9 ) THEN | |
8341 | * | For momenta between 3 and 5 GeV/c the use of tabulated data | |
8342 | * | should be implemented! | |
8343 | ACOF = SGTCOE (1,15) | |
8344 | BCOF = SGTCOE (2,15) | |
8345 | ENNE = SGTCOE (3,15) | |
8346 | CCOF = SGTCOE (4,15) | |
8347 | DCOF = SGTCOE (5,15) | |
8348 | * | Compute the pbar p total cross section: | |
8349 | SAPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
8350 | & + DCOF * ALGPLA | |
8351 | IF ( PLA .LT. FIVFIV ) THEN | |
8352 | JREAC = 26 | |
8353 | ELSE | |
8354 | JREAC = 25 | |
8355 | END IF | |
8356 | ACOF = SGTCOE (1,JREAC) | |
8357 | BCOF = SGTCOE (2,JREAC) | |
8358 | ENNE = SGTCOE (3,JREAC) | |
8359 | CCOF = SGTCOE (4,JREAC) | |
8360 | DCOF = SGTCOE (5,JREAC) | |
8361 | * | Compute the pbar p elastic cross section: | |
8362 | SAPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
8363 | & + DCOF * ALGPLA | |
8364 | * | Compute the pbar p inelastic cross section: | |
8365 | SAPPIN = SAPPTT - SAPPEL | |
8366 | ACOF = SGTCOE (1,12) | |
8367 | BCOF = SGTCOE (2,12) | |
8368 | ENNE = SGTCOE (3,12) | |
8369 | CCOF = SGTCOE (4,12) | |
8370 | DCOF = SGTCOE (5,12) | |
8371 | * | Compute the p p total cross section: | |
8372 | SPPTOT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
8373 | & + DCOF * ALGPLA | |
8374 | ACOF = SGTCOE (1,23) | |
8375 | BCOF = SGTCOE (2,23) | |
8376 | ENNE = SGTCOE (3,23) | |
8377 | CCOF = SGTCOE (4,23) | |
8378 | DCOF = SGTCOE (5,23) | |
8379 | * | Compute the p p elastic cross section: | |
8380 | SPPELA = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
8381 | & + DCOF * ALGPLA | |
8382 | * | Compute the K- p inelastic cross section: | |
8383 | SPPINE = SPPTOT - SPPELA | |
8384 | SIGDIA = ( SAPPIN - SPPINE ) / FIVFIV | |
8385 | KHELP = KTARG / 8 | |
8386 | * | +----------------------------------------------------------------* | |
8387 | * | | Pbar: | |
8388 | IF ( ICHRGE (IP) .NE. 0 ) THEN | |
8389 | NDIAGR = 5 - KHELP | |
8390 | * | | +-------------------------------------------------------------* | |
8391 | * | | | Proton target: | |
8392 | IF ( KHELP .EQ. 0 ) THEN | |
8393 | * | | | Number of diagrams: | |
8394 | SHNCIN = SAPPIN | |
8395 | PUUBAR = 0.8D+00 | |
8396 | * | | | | |
8397 | * | | +-------------------------------------------------------------* | |
8398 | * | | | Neutron target: it is supposed that (ap n)el is almost equal | |
8399 | * | | | to (ap p)el (reasonable above 5 GeV/c) | |
8400 | ELSE | |
8401 | ACOF = SGTCOE (1,16) | |
8402 | BCOF = SGTCOE (2,16) | |
8403 | ENNE = SGTCOE (3,16) | |
8404 | CCOF = SGTCOE (4,16) | |
8405 | DCOF = SGTCOE (5,16) | |
8406 | * | | | Compute the total cross section: | |
8407 | SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
8408 | & + DCOF * ALGPLA | |
8409 | * | | | Compute the elastic cross section: | |
8410 | SHNCEL = SAPPEL | |
8411 | * | | | Compute the inelastic cross section: | |
8412 | SHNCIN = SHNCTT - SHNCEL | |
8413 | PUUBAR = HLFHLF | |
8414 | END IF | |
8415 | * | | | | |
8416 | * | | +-------------------------------------------------------------* | |
8417 | * | | Now compute the chain end (anti)quark-(anti)diquark | |
8418 | * | | there are different possibilities, make a random choiche: | |
8419 | IQFSC1 = -1 | |
8420 | RNCHEN = DT_RNDM(PUUBAR) | |
8421 | IF ( RNCHEN .LT. PUUBAR ) THEN | |
8422 | IQFSC2 = -2 | |
8423 | ELSE | |
8424 | IQFSC2 = -1 | |
8425 | END IF | |
8426 | IQBSC1 = -IQFSC1 + KHELP | |
8427 | IQBSC2 = -IQFSC2 | |
8428 | * | | | |
8429 | * | +----------------------------------------------------------------* | |
8430 | * | | nbar: | |
8431 | ELSE | |
8432 | NDIAGR = 4 + KHELP | |
8433 | * | | +-------------------------------------------------------------* | |
8434 | * | | | Proton target: (nbar p)in supposed to be given by | |
8435 | * | | | (pbar p)in - Sig_diagr | |
8436 | IF ( KHELP .EQ. 0 ) THEN | |
8437 | SHNCIN = SAPPIN - SIGDIA | |
8438 | PDDBAR = HLFHLF | |
8439 | * | | | | |
8440 | * | | +-------------------------------------------------------------* | |
8441 | * | | | Neutron target: (nbar n)el is supposed to be equal to | |
8442 | * | | | (pbar p)el (reasonable above 5 GeV/c) | |
8443 | ELSE | |
8444 | * | | | Compute the total cross section: | |
8445 | SHNCTT = SAPPTT | |
8446 | * | | | Compute the elastic cross section: | |
8447 | SHNCEL = SAPPEL | |
8448 | * | | | Compute the inelastic cross section: | |
8449 | SHNCIN = SHNCTT - SHNCEL | |
8450 | PDDBAR = 0.8D+00 | |
8451 | END IF | |
8452 | * | | | | |
8453 | * | | +-------------------------------------------------------------* | |
8454 | * | | Now compute the chain end (anti)quark-(anti)diquark | |
8455 | * | | there are different possibilities, make a random choiche: | |
8456 | IQFSC1 = -2 | |
8457 | RNCHEN = DT_RNDM(RNCHEN) | |
8458 | IF ( RNCHEN .LT. PDDBAR ) THEN | |
8459 | IQFSC2 = -1 | |
8460 | ELSE | |
8461 | IQFSC2 = -2 | |
8462 | END IF | |
8463 | IQBSC1 = -IQFSC1 + KHELP - 1 | |
8464 | IQBSC2 = -IQFSC2 | |
8465 | END IF | |
8466 | * | | | |
8467 | * | +----------------------------------------------------------------* | |
8468 | * | | |
8469 | * +-------------------------------------------------------------------* | |
8470 | * | Others: not yet implemented | |
8471 | ELSE | |
8472 | SIGDIA = ZERZER | |
8473 | SHNCIN = ONEONE | |
8474 | NDIAGR = 0 | |
8475 | DT_PHNSCH = ZERZER | |
8476 | RETURN | |
8477 | END IF | |
8478 | * | end others | |
8479 | * +-------------------------------------------------------------------* | |
8480 | DT_PHNSCH = NDIAGR * SIGDIA / SHNCIN | |
8481 | IQECHC = IQECHR (IQFSC1) + IQECHR (IQFSC2) + IQECHR (IQBSC1) | |
8482 | & + IQECHR (IQBSC2) | |
8483 | IQBCHC = IQBCHR (IQFSC1) + IQBCHR (IQFSC2) + IQBCHR (IQBSC1) | |
8484 | & + IQBCHR (IQBSC2) | |
8485 | IQECHC = IQECHC / 3 | |
8486 | IQBCHC = IQBCHC / 3 | |
8487 | IQSCHC = IQSCHR (IQFSC1) + IQSCHR (IQFSC2) + IQSCHR (IQBSC1) | |
8488 | & + IQSCHR (IQBSC2) | |
8489 | IQSPRO = IQSCHR (MQUARK(1,IP)) + IQSCHR (MQUARK(2,IP)) | |
8490 | & + IQSCHR (MQUARK(3,IP)) | |
8491 | * +-------------------------------------------------------------------* | |
8492 | * | Consistency check: | |
8493 | IF ( DT_PHNSCH .LE. ZERZER .OR. DT_PHNSCH .GT. ONEONE ) THEN | |
8494 | WRITE (LUNOUT,*)' *** Phnsch,kp,ktarg,pla', | |
8495 | & DT_PHNSCH,KP,KTARG,PLA,' ****' | |
8496 | WRITE (LUNERR,*)' *** Phnsch,kp,ktarg,pla', | |
8497 | & DT_PHNSCH,KP,KTARG,PLA,' ****' | |
8498 | DT_PHNSCH = MAX ( DT_PHNSCH, ZERZER ) | |
8499 | DT_PHNSCH = MIN ( DT_PHNSCH, ONEONE ) | |
8500 | END IF | |
8501 | * | | |
8502 | * +-------------------------------------------------------------------* | |
8503 | * +-------------------------------------------------------------------* | |
8504 | * | Consistency check: | |
8505 | IF ( IQSPRO .NE. IQSCHC .OR. ICHRGE (IP) + ICHRGE (KTARG) | |
8506 | & .NE. IQECHC .OR. IIBAR (KP) + IIBAR (KTARG) .NE. IQBCHC) THEN | |
8507 | WRITE (LUNOUT,*) | |
8508 | &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg', | |
8509 | & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG | |
8510 | WRITE (LUNERR,*) | |
8511 | &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg', | |
8512 | & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG | |
8513 | END IF | |
8514 | * | | |
8515 | * +-------------------------------------------------------------------* | |
8516 | * P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ] | |
8517 | IF ( UMORAT .GT. ONEPLS ) | |
8518 | & DT_PHNSCH = ONEONE / ( ( ONEONE / DT_PHNSCH | |
8519 | & - ONEONE ) * UMORAT + ONEONE ) | |
8520 | RETURN | |
8521 | * | |
8522 | ENTRY DT_SCHQUA ( JQFSC1, JQFSC2, JQBSC1, JQBSC2 ) | |
8523 | DT_SCHQUA = ONEONE | |
8524 | JQFSC1 = IQFSC1 | |
8525 | JQFSC2 = IQFSC2 | |
8526 | JQBSC1 = IQBSC1 | |
8527 | JQBSC2 = IQBSC2 | |
8528 | *=== End of function Phnsch ===========================================* | |
8529 | RETURN | |
8530 | END | |
8531 | ||
8532 | *$ CREATE DT_RESPT.FOR | |
8533 | *COPY DT_RESPT | |
8534 | * | |
8535 | *===respt==============================================================* | |
8536 | * | |
8537 | SUBROUTINE DT_RESPT | |
8538 | ||
8539 | ************************************************************************ | |
8540 | * Check DTEVT1 for two-resonance systems and sample intrinsic p_t. * | |
8541 | * This version dated 18.01.95 is written by S. Roesler * | |
8542 | ************************************************************************ | |
8543 | ||
8544 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
8545 | SAVE | |
8546 | ||
8547 | PARAMETER ( LINP = 10 , | |
8548 | & LOUT = 6 , | |
8549 | & LDAT = 9 ) | |
8550 | ||
8551 | PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3) | |
8552 | ||
8553 | * event history | |
8554 | ||
8555 | PARAMETER (NMXHKK=200000) | |
8556 | ||
8557 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
8558 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
8559 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
8560 | ||
8561 | * extended event history | |
8562 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
8563 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
8564 | & IHIST(2,NMXHKK) | |
8565 | ||
8566 | * get index of first chain | |
8567 | DO 1 I=NPOINT(3),NHKK | |
8568 | IF (IDHKK(I).EQ.88888) THEN | |
8569 | NC = I | |
8570 | GOTO 2 | |
8571 | ENDIF | |
8572 | 1 CONTINUE | |
8573 | ||
8574 | 2 CONTINUE | |
8575 | IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)) THEN | |
8576 | C WRITE(LOUT,*)NC,NC+3,IDRES(NC),IDRES(NC+3) | |
8577 | * skip VV-,SS- systems | |
8578 | IF ((IDCH(NC ).NE.1).AND.(IDCH(NC ).NE.8).AND. | |
8579 | & (IDCH(NC+3).NE.1).AND.(IDCH(NC+3).NE.8)) THEN | |
8580 | * check if both "chains" are resonances | |
8581 | IF ((IDRES(NC).NE.0).AND.(IDRES(NC+3).NE.0)) THEN | |
8582 | CALL DT_SAPTRE(NC,NC+3) | |
8583 | ENDIF | |
8584 | ENDIF | |
8585 | ELSE | |
8586 | GOTO 3 | |
8587 | ENDIF | |
8588 | NC = NC+6 | |
8589 | GOTO 2 | |
8590 | ||
8591 | 3 CONTINUE | |
8592 | ||
8593 | RETURN | |
8594 | END | |
8595 | ||
8596 | *$ CREATE DT_EVTRES.FOR | |
8597 | *COPY DT_EVTRES | |
8598 | * | |
8599 | *===evtres=============================================================* | |
8600 | * | |
8601 | SUBROUTINE DT_EVTRES(IREJ) | |
8602 | ||
8603 | ************************************************************************ | |
8604 | * This version dated 14.12.94 is written by S. Roesler * | |
8605 | ************************************************************************ | |
8606 | ||
8607 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
8608 | SAVE | |
8609 | ||
8610 | PARAMETER ( LINP = 10 , | |
8611 | & LOUT = 6 , | |
8612 | & LDAT = 9 ) | |
8613 | ||
8614 | PARAMETER (TINY5=1.0D-5,TINY10=1.0D-10) | |
8615 | ||
8616 | * event history | |
8617 | ||
8618 | PARAMETER (NMXHKK=200000) | |
8619 | ||
8620 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
8621 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
8622 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
8623 | ||
8624 | * extended event history | |
8625 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
8626 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
8627 | & IHIST(2,NMXHKK) | |
8628 | ||
8629 | * flags for input different options | |
8630 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
8631 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
8632 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
8633 | ||
8634 | * particle properties (BAMJET index convention) | |
8635 | CHARACTER*8 ANAME | |
8636 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
8637 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
8638 | ||
8639 | DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),IFP(2),IFT(2) | |
8640 | ||
8641 | IREJ = 0 | |
8642 | ||
8643 | DO 1 I=NPOINT(3),NHKK | |
8644 | IF (ABS(IDRES(I)).GE.100) THEN | |
8645 | AMMX = 0.0D0 | |
8646 | DO 2 J=NPOINT(3),NHKK | |
8647 | IF (IDHKK(J).EQ.88888) THEN | |
8648 | IF (PHKK(5,J).GT.AMMX) THEN | |
8649 | AMMX = PHKK(5,J) | |
8650 | IMMX = J | |
8651 | ENDIF | |
8652 | ENDIF | |
8653 | 2 CONTINUE | |
8654 | IF (IDRES(IMMX).NE.0) THEN | |
8655 | IF (IOULEV(3).GT.0) THEN | |
8656 | WRITE(LOUT,'(1X,A)') | |
8657 | & 'EVTRES: no chain for correc. found' | |
8658 | C GOTO 6 | |
8659 | GOTO 9999 | |
8660 | ELSE | |
8661 | GOTO 9999 | |
8662 | ENDIF | |
8663 | ENDIF | |
8664 | IMO11 = JMOHKK(1,I) | |
8665 | IMO12 = JMOHKK(2,I) | |
8666 | IF (PHKK(3,IMO11).LT.0.0D0) THEN | |
8667 | IMO11 = JMOHKK(2,I) | |
8668 | IMO12 = JMOHKK(1,I) | |
8669 | ENDIF | |
8670 | IMO21 = JMOHKK(1,IMMX) | |
8671 | IMO22 = JMOHKK(2,IMMX) | |
8672 | IF (PHKK(3,IMO21).LT.0.0D0) THEN | |
8673 | IMO21 = JMOHKK(2,IMMX) | |
8674 | IMO22 = JMOHKK(1,IMMX) | |
8675 | ENDIF | |
8676 | AMCH1 = PHKK(5,I) | |
8677 | AMCH1N = AAM(IDXRES(I)) | |
8678 | ||
8679 | IFPR1 = IDHKK(IMO11) | |
8680 | IFPR2 = IDHKK(IMO21) | |
8681 | IFTA1 = IDHKK(IMO12) | |
8682 | IFTA2 = IDHKK(IMO22) | |
8683 | DO 4 J=1,4 | |
8684 | PP1(J) = PHKK(J,IMO11) | |
8685 | PP2(J) = PHKK(J,IMO21) | |
8686 | PT1(J) = PHKK(J,IMO12) | |
8687 | PT2(J) = PHKK(J,IMO22) | |
8688 | 4 CONTINUE | |
8689 | * store initial configuration for energy-momentum cons. check | |
8690 | IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IREJ1) | |
8691 | * correct kinematics of second chain | |
8692 | CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2, | |
8693 | & AMCH1,AMCH1N,AMCH2,IREJ1) | |
8694 | IF (IREJ1.NE.0) GOTO 9999 | |
8695 | * check now this chain for resonance mass | |
8696 | IFP(1) = IDT_IPDG2B(IFPR2,1,2) | |
8697 | IFP(2) = 0 | |
8698 | IF (ABS(IFPR2).GE.1000) IFP(2) = IDT_IPDG2B(IFPR2,2,2) | |
8699 | IFT(1) = IDT_IPDG2B(IFTA2,1,2) | |
8700 | IFT(2) = 0 | |
8701 | IF (ABS(IFTA2).GE.1000) IFT(2) = IDT_IPDG2B(IFTA2,2,2) | |
8702 | IDCH2 = 2 | |
8703 | IF ((IFP(2).EQ.0).AND.(IFT(2).EQ.0)) IDCH2 = 1 | |
8704 | IF ((IFP(2).NE.0).AND.(IFT(2).NE.0)) IDCH2 = 3 | |
8705 | CALL DT_CH2RES(IFP(1),IFP(2),IFT(1),IFT(2),IDR2,IDXR2, | |
8706 | & AMCH2,AMCH2N,IDCH2,IREJ1) | |
8707 | IF ((IREJ1.NE.0).OR.(IDR2.NE.0)) THEN | |
8708 | IF (IOULEV(1).GT.0) | |
8709 | & WRITE(LOUT,*) ' correction for resonance not poss.' | |
8710 | **sr test | |
8711 | C GOTO 1 | |
8712 | C GOTO 9999 | |
8713 | ** | |
8714 | ENDIF | |
8715 | * store final configuration for energy-momentum cons. check | |
8716 | IF (LEMCCK) THEN | |
8717 | CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IREJ1) | |
8718 | CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1) | |
8719 | IF (IREJ1.NE.0) GOTO 9999 | |
8720 | ENDIF | |
8721 | DO 5 J=1,4 | |
8722 | PHKK(J,IMO11) = PP1(J) | |
8723 | PHKK(J,IMO21) = PP2(J) | |
8724 | PHKK(J,IMO12) = PT1(J) | |
8725 | PHKK(J,IMO22) = PT2(J) | |
8726 | 5 CONTINUE | |
8727 | * correct entries of chains | |
8728 | DO 3 K=1,4 | |
8729 | PHKK(K,I) = PHKK(K,IMO11)+PHKK(K,IMO12) | |
8730 | PHKK(K,IMMX) = PHKK(K,IMO21)+PHKK(K,IMO22) | |
8731 | 3 CONTINUE | |
8732 | AM1 = PHKK(4,I)**2-PHKK(1,I)**2-PHKK(2,I)**2-PHKK(3,I)**2 | |
8733 | AM2 = PHKK(4,IMMX)**2-PHKK(1,IMMX)**2-PHKK(2,IMMX)**2- | |
8734 | & PHKK(3,IMMX)**2 | |
8735 | * ?? the following should now be obsolete | |
8736 | **sr test | |
8737 | C IF ((AM1.LT.0.0D0).OR.(AM2.LT.1.0D0)) THEN | |
8738 | IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN | |
8739 | ** | |
8740 | WRITE(LOUT,'(1X,A,4G10.3)') | |
8741 | & 'EVTRES: inonsistent mass-corr.',AM1,AM2 | |
8742 | C GOTO 9999 | |
8743 | GOTO 1 | |
8744 | ENDIF | |
8745 | PHKK(5,I) = SQRT(AM1) | |
8746 | PHKK(5,IMMX) = SQRT(AM2) | |
8747 | IDRES(I) = IDRES(I)/100 | |
8748 | IF ((ABS(PHKK(5,I)-AMCH1N).GT.TINY5).OR. | |
8749 | & (ABS(PHKK(5,IMMX)-AMCH2).GT.TINY5)) THEN | |
8750 | WRITE(LOUT,'(1X,A,4G10.3)') | |
8751 | & 'EVTRES: inconsistent chain-masses', | |
8752 | & PHKK(5,I),AMCH1N,PHKK(5,IMMX),AMCH2 | |
8753 | GOTO 9999 | |
8754 | ENDIF | |
8755 | ENDIF | |
8756 | 1 CONTINUE | |
8757 | 6 CONTINUE | |
8758 | RETURN | |
8759 | ||
8760 | 9999 CONTINUE | |
8761 | IREJ = 1 | |
8762 | RETURN | |
8763 | END | |
8764 | ||
8765 | *$ CREATE DT_GETSPT.FOR | |
8766 | *COPY DT_GETSPT | |
8767 | * | |
8768 | *===getspt=============================================================* | |
8769 | * | |
8770 | SUBROUTINE DT_GETSPT(PP1I,IFPR1,IFP1,PP2I,IFPR2,IFP2, | |
8771 | & PT1I,IFTA1,IFT1,PT2I,IFTA2,IFT2, | |
8772 | & AM1,IDCH1,AM2,IDCH2,IDCHAI,IREJ) | |
8773 | ||
8774 | ************************************************************************ | |
8775 | * This version dated 12.12.94 is written by S. Roesler * | |
8776 | ************************************************************************ | |
8777 | ||
8778 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
8779 | SAVE | |
8780 | ||
8781 | PARAMETER ( LINP = 10 , | |
8782 | & LOUT = 6 , | |
8783 | & LDAT = 9 ) | |
8784 | ||
8785 | PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,ZERO=0.0D0) | |
8786 | ||
8787 | * various options for treatment of partons (DTUNUC 1.x) | |
8788 | * (chain recombination, Cronin,..) | |
8789 | LOGICAL LCO2CR,LINTPT | |
8790 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, | |
8791 | & LCO2CR,LINTPT | |
8792 | ||
8793 | * flags for input different options | |
8794 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
8795 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
8796 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
8797 | ||
8798 | * flags for diffractive interactions (DTUNUC 1.x) | |
8799 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF | |
8800 | ||
8801 | DIMENSION PP1(4),PP1I(4),PP2(4),PP2I(4),PT1(4),PT1I(4), | |
8802 | & PT2(4),PT2I(4),P1(4),P2(4), | |
8803 | & IFP1(2),IFP2(2),IFT1(2),IFT2(2), | |
8804 | & PTOTI(4),PTOTF(4),DIFF(4) | |
8805 | ||
8806 | IC = 0 | |
8807 | IREJ = 0 | |
8808 | C B33P = 4.0D0 | |
8809 | C B33T = 4.0D0 | |
8810 | C IF ((IDCHAI.EQ.6).OR.(IDCHAI.EQ.7).OR.(IDCHAI.EQ.8)) B33P = 2.0D0 | |
8811 | C IF ((IDCHAI.EQ.4).OR.(IDCHAI.EQ.5).OR.(IDCHAI.EQ.8)) B33T = 2.0D0 | |
8812 | REDU = 1.0D0 | |
8813 | C B33P = 3.5D0 | |
8814 | C B33T = 3.5D0 | |
8815 | B33P = 4.0D0 | |
8816 | B33T = 4.0D0 | |
8817 | IF (IDIFF.NE.0) THEN | |
8818 | B33P = 16.0D0 | |
8819 | B33T = 16.0D0 | |
8820 | ENDIF | |
8821 | ||
8822 | DO 1 I=1,4 | |
8823 | PTOTI(I) = PP1I(I)+PP2I(I)+PT1I(I)+PT2I(I) | |
8824 | PP1(I) = PP1I(I) | |
8825 | PP2(I) = PP2I(I) | |
8826 | PT1(I) = PT1I(I) | |
8827 | PT2(I) = PT2I(I) | |
8828 | 1 CONTINUE | |
8829 | * get initial chain masses | |
8830 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 | |
8831 | & +(PP1(3)+PT1(3))**2) | |
8832 | ECH = PP1(4)+PT1(4) | |
8833 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
8834 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 | |
8835 | & +(PP2(3)+PT2(3))**2) | |
8836 | ECH = PP2(4)+PT2(4) | |
8837 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
8838 | IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN | |
8839 | IF (IOULEV(1).GT.0) | |
8840 | & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 1', | |
8841 | & AM1,AM2 | |
8842 | GOTO 9999 | |
8843 | ENDIF | |
8844 | AM1 = SQRT(AM1) | |
8845 | AM2 = SQRT(AM2) | |
8846 | AM1N = ZERO | |
8847 | AM2N = ZERO | |
8848 | ||
8849 | MODE = 0 | |
8850 | C IF ((AM1.GE.3.0D0).AND.(AM2.GE.3.0D0)) THEN | |
8851 | C MODE = 0 | |
8852 | C ELSE | |
8853 | C MODE = 1 | |
8854 | C IF (AM1.LT.0.6) THEN | |
8855 | C B33P = 10.0D0 | |
8856 | C ELSEIF ((AM1.GE.1.2).AND.(AM1.LT.3.0D0)) THEN | |
8857 | CC B33P = 4.0D0 | |
8858 | C ENDIF | |
8859 | C IF (AM2.LT.0.6) THEN | |
8860 | C B33T = 10.0D0 | |
8861 | C ELSEIF ((AM2.GE.1.2).AND.(AM2.LT.3.0D0)) THEN | |
8862 | CC B33T = 4.0D0 | |
8863 | C ENDIF | |
8864 | C ENDIF | |
8865 | ||
8866 | * check chain masses for very low mass chains | |
8867 | C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM, | |
8868 | C & AM1,DUM,-IDCH1,IREJ1) | |
8869 | C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM, | |
8870 | C & AM2,DUM,-IDCH2,IREJ2) | |
8871 | C IF ((IREJ1.NE.0).OR.(IREJ2.NE.0)) THEN | |
8872 | C B33P = 20.0D0 | |
8873 | C B33T = 20.0D0 | |
8874 | C ENDIF | |
8875 | ||
8876 | JMSHL = IMSHL | |
8877 | ||
8878 | 2 CONTINUE | |
8879 | IC = IC+1 | |
8880 | IF (MOD(IC,15).EQ.0) B33P = 2.0D0*B33P | |
8881 | IF (MOD(IC,15).EQ.0) B33T = 2.0D0*B33T | |
8882 | IF (MOD(IC,18).EQ.0) REDU = 0.0D0 | |
8883 | C IF (MOD(IC,19).EQ.0) JMSHL = 0 | |
8884 | IF (MOD(IC,20).EQ.0) GOTO 7 | |
8885 | C WRITE(LOUT,'(1X,A)') 'GETSPT: rejection ' | |
8886 | C RETURN | |
8887 | C GOTO 9999 | |
8888 | C ENDIF | |
8889 | ||
8890 | * get transverse momentum | |
8891 | IF (LINTPT) THEN | |
8892 | ES = -2.0D0/(B33P**2) | |
8893 | & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10) | |
8894 | HPSP = SQRT(ES*ES+2.0D0*ES*0.94D0) | |
8895 | HPSP = HPSP*REDU | |
8896 | ES = -2.0D0/(B33T**2) | |
8897 | & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10) | |
8898 | HPST = SQRT(ES*ES+2.0D0*ES*0.94D0) | |
8899 | HPST = HPST*REDU | |
8900 | ELSE | |
8901 | HPSP = ZERO | |
8902 | HPST = ZERO | |
8903 | ENDIF | |
8904 | CALL DT_DSFECF(SFE1,CFE1) | |
8905 | CALL DT_DSFECF(SFE2,CFE2) | |
8906 | IF (MODE.EQ.0) THEN | |
8907 | PP1(1) = PP1I(1)+HPSP*CFE1 | |
8908 | PP1(2) = PP1I(2)+HPSP*SFE1 | |
8909 | PP2(1) = PP2I(1)-HPSP*CFE1 | |
8910 | PP2(2) = PP2I(2)-HPSP*SFE1 | |
8911 | PT1(1) = PT1I(1)+HPST*CFE2 | |
8912 | PT1(2) = PT1I(2)+HPST*SFE2 | |
8913 | PT2(1) = PT2I(1)-HPST*CFE2 | |
8914 | PT2(2) = PT2I(2)-HPST*SFE2 | |
8915 | ELSE | |
8916 | PP1(1) = PP1I(1)+HPSP*CFE1 | |
8917 | PP1(2) = PP1I(2)+HPSP*SFE1 | |
8918 | PT1(1) = PT1I(1)-HPSP*CFE1 | |
8919 | PT1(2) = PT1I(2)-HPSP*SFE1 | |
8920 | PP2(1) = PP2I(1)+HPST*CFE2 | |
8921 | PP2(2) = PP2I(2)+HPST*SFE2 | |
8922 | PT2(1) = PT2I(1)-HPST*CFE2 | |
8923 | PT2(2) = PT2I(2)-HPST*SFE2 | |
8924 | ENDIF | |
8925 | ||
8926 | * put partons on mass shell | |
8927 | XMP1 = 0.0D0 | |
8928 | XMT1 = 0.0D0 | |
8929 | IF (JMSHL.EQ.1) THEN | |
8930 | ||
8931 | XMP1 = PYMASS(IFPR1) | |
8932 | XMT1 = PYMASS(IFTA1) | |
8933 | ||
8934 | ENDIF | |
8935 | CALL DT_MASHEL(PP1,PT1,XMP1,XMT1,P1,P2,IREJ1) | |
8936 | IF (IREJ1.NE.0) GOTO 2 | |
8937 | DO 3 I=1,4 | |
8938 | PTOTF(I) = P1(I)+P2(I) | |
8939 | PP1(I) = P1(I) | |
8940 | PT1(I) = P2(I) | |
8941 | 3 CONTINUE | |
8942 | XMP2 = 0.0D0 | |
8943 | XMT2 = 0.0D0 | |
8944 | IF (JMSHL.EQ.1) THEN | |
8945 | ||
8946 | XMP2 = PYMASS(IFPR2) | |
8947 | XMT2 = PYMASS(IFTA2) | |
8948 | ||
8949 | ENDIF | |
8950 | CALL DT_MASHEL(PP2,PT2,XMP2,XMT2,P1,P2,IREJ1) | |
8951 | IF (IREJ1.NE.0) GOTO 2 | |
8952 | DO 4 I=1,4 | |
8953 | PTOTF(I) = PTOTF(I)+P1(I)+P2(I) | |
8954 | PP2(I) = P1(I) | |
8955 | PT2(I) = P2(I) | |
8956 | 4 CONTINUE | |
8957 | ||
8958 | * check consistency | |
8959 | DO 5 I=1,4 | |
8960 | DIFF(I) = PTOTI(I)-PTOTF(I) | |
8961 | 5 CONTINUE | |
8962 | IF ((ABS(DIFF(1)).GT.TINY5).OR.(ABS(DIFF(2)).GT.TINY5).OR. | |
8963 | & (ABS(DIFF(3)).GT.TINY5).OR.(ABS(DIFF(4)).GT.TINY5)) THEN | |
8964 | WRITE(LOUT,'(1X,A,4G10.3)') 'GETSPT: inconsistencies ',DIFF | |
8965 | GOTO 9999 | |
8966 | ENDIF | |
8967 | PTOTP1 = SQRT(PP1(1)**2+PP1(2)**2+PP1(3)**2) | |
8968 | AMP1 = SQRT(ABS( (PP1(4)-PTOTP1)*(PP1(4)+PTOTP1) )) | |
8969 | PTOTP2 = SQRT(PP2(1)**2+PP2(2)**2+PP2(3)**2) | |
8970 | AMP2 = SQRT(ABS( (PP2(4)-PTOTP2)*(PP2(4)+PTOTP2) )) | |
8971 | PTOTT1 = SQRT(PT1(1)**2+PT1(2)**2+PT1(3)**2) | |
8972 | AMT1 = SQRT(ABS( (PT1(4)-PTOTT1)*(PT1(4)+PTOTT1) )) | |
8973 | PTOTT2 = SQRT(PT2(1)**2+PT2(2)**2+PT2(3)**2) | |
8974 | AMT2 = SQRT(ABS( (PT2(4)-PTOTT2)*(PT2(4)+PTOTT2) )) | |
8975 | IF ((ABS(AMP1-XMP1).GT.TINY3).OR.(ABS(AMP2-XMP2).GT.TINY3).OR. | |
8976 | & (ABS(AMT1-XMT1).GT.TINY3).OR.(ABS(AMT2-XMT2).GT.TINY3)) | |
8977 | & THEN | |
8978 | WRITE(LOUT,'(1X,A,2(4G10.3,/))') | |
8979 | & 'GETSPT: inconsistent masses', | |
8980 | & AMP1,XMP1,AMP2,XMP2,AMT1,XMT1,AMT2,XMT2 | |
8981 | * sr 22.11.00: commented. It should only have inconsistent masses for | |
8982 | * ultrahigh energies due to rounding problems | |
8983 | C GOTO 9999 | |
8984 | ENDIF | |
8985 | ||
8986 | * get chain masses | |
8987 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 | |
8988 | & +(PP1(3)+PT1(3))**2) | |
8989 | ECH = PP1(4)+PT1(4) | |
8990 | AM1N = (ECH+PTOCH)*(ECH-PTOCH) | |
8991 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 | |
8992 | & +(PP2(3)+PT2(3))**2) | |
8993 | ECH = PP2(4)+PT2(4) | |
8994 | AM2N = (ECH+PTOCH)*(ECH-PTOCH) | |
8995 | IF ((AM1N.LT.0.0D0).OR.(AM2N.LT.0.0D0)) THEN | |
8996 | IF (IOULEV(1).GT.0) | |
8997 | & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 2', | |
8998 | & AM1N,AM2N | |
8999 | GOTO 2 | |
9000 | ENDIF | |
9001 | AM1N = SQRT(AM1N) | |
9002 | AM2N = SQRT(AM2N) | |
9003 | ||
9004 | * check chain masses for very low mass chains | |
9005 | CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM, | |
9006 | & AM1N,DUM,-IDCH1,IREJ1) | |
9007 | IF (IREJ1.NE.0) GOTO 2 | |
9008 | CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM, | |
9009 | & AM2N,DUM,-IDCH2,IREJ2) | |
9010 | IF (IREJ2.NE.0) GOTO 2 | |
9011 | ||
9012 | 7 CONTINUE | |
9013 | IF (AM1N.GT.ZERO) THEN | |
9014 | AM1 = AM1N | |
9015 | AM2 = AM2N | |
9016 | ENDIF | |
9017 | DO 6 I=1,4 | |
9018 | PP1I(I) = PP1(I) | |
9019 | PP2I(I) = PP2(I) | |
9020 | PT1I(I) = PT1(I) | |
9021 | PT2I(I) = PT2(I) | |
9022 | 6 CONTINUE | |
9023 | ||
9024 | RETURN | |
9025 | ||
9026 | 9999 CONTINUE | |
9027 | IREJ = 1 | |
9028 | RETURN | |
9029 | END | |
9030 | ||
9031 | *$ CREATE DT_SAPTRE.FOR | |
9032 | *COPY DT_SAPTRE | |
9033 | * | |
9034 | *===saptre=============================================================* | |
9035 | * | |
9036 | SUBROUTINE DT_SAPTRE(IDX1,IDX2) | |
9037 | ||
9038 | ************************************************************************ | |
9039 | * p-t sampling for two-resonance systems. ("BAMJET-like" method) * | |
9040 | * IDX1,IDX2 indices of resonances ("chains") in DTEVT1 * | |
9041 | * Adopted from the original SAPTRE written by J. Ranft. * | |
9042 | * This version dated 18.01.95 is written by S. Roesler * | |
9043 | ************************************************************************ | |
9044 | ||
9045 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
9046 | SAVE | |
9047 | ||
9048 | PARAMETER ( LINP = 10 , | |
9049 | & LOUT = 6 , | |
9050 | & LDAT = 9 ) | |
9051 | ||
9052 | PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3) | |
9053 | ||
9054 | * event history | |
9055 | ||
9056 | PARAMETER (NMXHKK=200000) | |
9057 | ||
9058 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
9059 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
9060 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
9061 | ||
9062 | * extended event history | |
9063 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
9064 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
9065 | & IHIST(2,NMXHKK) | |
9066 | ||
9067 | * flags for input different options | |
9068 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
9069 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
9070 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
9071 | ||
9072 | DIMENSION PA1(4),PA2(4),P1(4),P2(4) | |
9073 | ||
9074 | DATA B3 /4.0D0/ | |
9075 | ||
9076 | ESMAX1 = PHKK(4,IDX1)-PHKK(5,IDX1) | |
9077 | ESMAX2 = PHKK(4,IDX2)-PHKK(5,IDX2) | |
9078 | ESMAX = MIN(ESMAX1,ESMAX2) | |
9079 | IF (ESMAX.LE.0.05D0) RETURN | |
9080 | ||
9081 | HMA = PHKK(5,IDX1) | |
9082 | DO 1 K=1,4 | |
9083 | PA1(K) = PHKK(K,IDX1) | |
9084 | PA2(K) = PHKK(K,IDX2) | |
9085 | 1 CONTINUE | |
9086 | ||
9087 | IF (LEMCCK) THEN | |
9088 | CALL DT_EVTEMC(PA1(1),PA1(2),PA1(3),PA1(4),1,IDUM,IDUM) | |
9089 | CALL DT_EVTEMC(PA2(1),PA2(2),PA2(3),PA2(4),2,IDUM,IDUM) | |
9090 | ENDIF | |
9091 | ||
9092 | EXEB = 0.0D0 | |
9093 | IF (B3*ESMAX.LE.60.0D0) EXEB = EXP(-B3*ESMAX) | |
9094 | BEXP = HMA*(1.0D0-EXEB)/B3 | |
9095 | AXEXP = (1.0D0-(B3*ESMAX-1.0D0)*EXEB)/B3**2 | |
9096 | WA = AXEXP/(BEXP+AXEXP) | |
9097 | XAB = DT_RNDM(WA) | |
9098 | 10 CONTINUE | |
9099 | * ES is the transverse kinetic energy | |
9100 | IF (XAB.LT.WA)THEN | |
9101 | X = DT_RNDM(WA) | |
9102 | Y = DT_RNDM(WA) | |
9103 | ES = -2.0D0/(B3**2)*LOG(X*Y+TINY7) | |
9104 | ELSE | |
9105 | X = DT_RNDM(Y) | |
9106 | ES = ABS(-LOG(X+TINY7)/B3) | |
9107 | ENDIF | |
9108 | IF (ES.GT.ESMAX) GOTO 10 | |
9109 | ES = ES+HMA | |
9110 | * transverse momentum | |
9111 | HPS = SQRT((ES-HMA)*(ES+HMA)) | |
9112 | ||
9113 | CALL DT_DSFECF(SFE,CFE) | |
9114 | HPX = HPS*CFE | |
9115 | HPY = HPS*SFE | |
9116 | PZ1NSQ = PA1(3)**2-HPS**2-2.0D0*PA1(1)*HPX-2.0D0*PA1(2)*HPY | |
9117 | PZ2NSQ = PA2(3)**2-HPS**2+2.0D0*PA2(1)*HPX+2.0D0*PA2(2)*HPY | |
9118 | IF ((PZ1NSQ.LT.TINY3).OR.(PZ2NSQ.LT.TINY3)) RETURN | |
9119 | ||
9120 | C PA1(3) = SIGN(SQRT(PZ1NSQ),PA1(3)) | |
9121 | C PA2(3) = SIGN(SQRT(PZ2NSQ),PA2(3)) | |
9122 | PA1(1) = PA1(1)+HPX | |
9123 | PA1(2) = PA1(2)+HPY | |
9124 | PA2(1) = PA2(1)-HPX | |
9125 | PA2(2) = PA2(2)-HPY | |
9126 | ||
9127 | * put resonances on mass-shell again | |
9128 | XM1 = PHKK(5,IDX1) | |
9129 | XM2 = PHKK(5,IDX2) | |
9130 | CALL DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ1) | |
9131 | IF (IREJ1.NE.0) RETURN | |
9132 | ||
9133 | IF (LEMCCK) THEN | |
9134 | CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,IDUM,IDUM) | |
9135 | CALL DT_EVTEMC(-P2(1),-P2(2),-P2(3),-P2(4),2,IDUM,IDUM) | |
9136 | CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,12,IREJ1) | |
9137 | IF (IREJ1.NE.0) RETURN | |
9138 | ENDIF | |
9139 | ||
9140 | DO 2 K=1,4 | |
9141 | PHKK(K,IDX1) = P1(K) | |
9142 | PHKK(K,IDX2) = P2(K) | |
9143 | 2 CONTINUE | |
9144 | ||
9145 | RETURN | |
9146 | END | |
9147 | ||
9148 | *$ CREATE DT_CRONIN.FOR | |
9149 | *COPY DT_CRONIN | |
9150 | * | |
9151 | *===cronin=============================================================* | |
9152 | * | |
9153 | SUBROUTINE DT_CRONIN(INCL) | |
9154 | ||
9155 | ************************************************************************ | |
9156 | * Cronin-Effect. Multiple scattering of partons at chain ends. * | |
9157 | * INCL = 1 multiple sc. in projectile * | |
9158 | * = 2 multiple sc. in target * | |
9159 | * This version dated 05.01.96 is written by S. Roesler. * | |
9160 | ************************************************************************ | |
9161 | ||
9162 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
9163 | SAVE | |
9164 | ||
9165 | PARAMETER ( LINP = 10 , | |
9166 | & LOUT = 6 , | |
9167 | & LDAT = 9 ) | |
9168 | ||
9169 | PARAMETER (ZERO=0.0D0,TINY3=1.0D-3) | |
9170 | ||
9171 | * event history | |
9172 | ||
9173 | PARAMETER (NMXHKK=200000) | |
9174 | ||
9175 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
9176 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
9177 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
9178 | ||
9179 | * extended event history | |
9180 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
9181 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
9182 | & IHIST(2,NMXHKK) | |
9183 | ||
9184 | * rejection counter | |
9185 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
9186 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
9187 | & IREXCI(3),IRDIFF(2),IRINC | |
9188 | ||
9189 | * Glauber formalism: collision properties | |
9190 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, | |
9191 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC | |
9192 | ||
9193 | DIMENSION R(3),PIN(4),POUT(4),DEV(4) | |
9194 | ||
9195 | DO 1 K=1,4 | |
9196 | DEV(K) = ZERO | |
9197 | 1 CONTINUE | |
9198 | ||
9199 | DO 2 I=NPOINT(2),NHKK | |
9200 | IF (ISTHKK(I).LT.0) THEN | |
9201 | * get z-position of the chain | |
9202 | R(1) = VHKK(1,I)*1.0D12 | |
9203 | IF (INCL.EQ.2) R(1) = VHKK(1,I)*1.0D12-BIMPAC | |
9204 | R(2) = VHKK(2,I)*1.0D12 | |
9205 | IDXNU = JMOHKK(1,I) | |
9206 | IF ( (INCL.EQ.1).AND.(ISTHKK(IDXNU).EQ.10) ) | |
9207 | & IDXNU = JMOHKK(1,I-1) | |
9208 | IF ( (INCL.EQ.2).AND.(ISTHKK(IDXNU).EQ. 9) ) | |
9209 | & IDXNU = JMOHKK(1,I+1) | |
9210 | R(3) = VHKK(3,IDXNU)*1.0D12 | |
9211 | * position of target parton the chain is connected to | |
9212 | DO 3 K=1,4 | |
9213 | PIN(K) = PHKK(K,I) | |
9214 | 3 CONTINUE | |
9215 | * multiple scattering of parton with DTEVT1-index I | |
9216 | CALL DT_CROMSC(PIN,R,POUT,INCL) | |
9217 | **testprint | |
9218 | C IF (NEVHKK.EQ.5) THEN | |
9219 | C AMIN = PIN(4)**2-PIN(1)**2-PIN(2)**2-PIN(3)**2 | |
9220 | C AMOU = POUT(4)**2-POUT(1)**2-POUT(2)**2-POUT(3)**2 | |
9221 | C AMIN = SIGN(SQRT(ABS(AMIN)),AMIN) | |
9222 | C AMOU = SIGN(SQRT(ABS(AMOU)),AMOU) | |
9223 | C WRITE(6,'(A,I4,2E15.5)')'I,AMIN,AMOU: ',I,AMIN,AMOU | |
9224 | C WRITE(6,'(A,4E15.5)')'PIN: ',PIN | |
9225 | C WRITE(6,'(A,4E15.5)')'POUT: ',POUT | |
9226 | C ENDIF | |
9227 | ** | |
9228 | * increase accumulator by energy-momentum difference | |
9229 | DO 4 K=1,4 | |
9230 | DEV(K) = DEV(K)+POUT(K)-PIN(K) | |
9231 | PHKK(K,I) = POUT(K) | |
9232 | 4 CONTINUE | |
9233 | PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2- | |
9234 | & PHKK(2,I)**2-PHKK(3,I)**2)) | |
9235 | ENDIF | |
9236 | 2 CONTINUE | |
9237 | ||
9238 | * dump accumulator to momenta of valence partons | |
9239 | NVAL = 0 | |
9240 | ETOT = 0.0D0 | |
9241 | DO 5 I=NPOINT(2),NHKK | |
9242 | IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN | |
9243 | NVAL = NVAL+1 | |
9244 | ETOT = ETOT+PHKK(4,I) | |
9245 | ENDIF | |
9246 | 5 CONTINUE | |
9247 | C WRITE(LOUT,1000) NVAL,(DEV(K)/DBLE(NVAL),K=1,4) | |
9248 | 1000 FORMAT(1X,'CRONIN : number of val. partons ',I4,/, | |
9249 | & 9X,4E12.4) | |
9250 | DO 6 I=NPOINT(2),NHKK | |
9251 | IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN | |
9252 | E = PHKK(4,I) | |
9253 | DO 7 K=1,4 | |
9254 | C PHKK(K,I) = PHKK(K,I)-DEV(K)/DBLE(NVAL) | |
9255 | PHKK(K,I) = PHKK(K,I)-DEV(K)*E/ETOT | |
9256 | 7 CONTINUE | |
9257 | PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2- | |
9258 | & PHKK(2,I)**2-PHKK(3,I)**2)) | |
9259 | ENDIF | |
9260 | 6 CONTINUE | |
9261 | ||
9262 | RETURN | |
9263 | END | |
9264 | ||
9265 | *$ CREATE DT_CROMSC.FOR | |
9266 | *COPY DT_CROMSC | |
9267 | * | |
9268 | *===cromsc=============================================================* | |
9269 | * | |
9270 | SUBROUTINE DT_CROMSC(PIN,R,POUT,INCL) | |
9271 | ||
9272 | ************************************************************************ | |
9273 | * Cronin-Effect. Multiple scattering of one parton passing through * | |
9274 | * nuclear matter. * | |
9275 | * PIN(4) input 4-momentum of parton * | |
9276 | * POUT(4) 4-momentum of parton after mult. scatt. * | |
9277 | * R(3) spatial position of parton in target nucleus * | |
9278 | * INCL = 1 multiple sc. in projectile * | |
9279 | * = 2 multiple sc. in target * | |
9280 | * This is a revised version of the original version written by J. Ranft* | |
9281 | * This version dated 17.01.95 is written by S. Roesler. * | |
9282 | ************************************************************************ | |
9283 | ||
9284 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
9285 | SAVE | |
9286 | ||
9287 | PARAMETER ( LINP = 10 , | |
9288 | & LOUT = 6 , | |
9289 | & LDAT = 9 ) | |
9290 | ||
9291 | PARAMETER (ZERO=0.0D0,TINY3=1.0D-3) | |
9292 | ||
9293 | LOGICAL LSTART | |
9294 | ||
9295 | * rejection counter | |
9296 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
9297 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
9298 | & IREXCI(3),IRDIFF(2),IRINC | |
9299 | ||
9300 | * Glauber formalism: collision properties | |
9301 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, | |
9302 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC | |
9303 | ||
9304 | * various options for treatment of partons (DTUNUC 1.x) | |
9305 | * (chain recombination, Cronin,..) | |
9306 | LOGICAL LCO2CR,LINTPT | |
9307 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, | |
9308 | & LCO2CR,LINTPT | |
9309 | ||
9310 | DIMENSION PIN(4),POUT(4),R(3) | |
9311 | ||
9312 | DATA LSTART /.TRUE./ | |
9313 | ||
9314 | IRCRON(1) = IRCRON(1)+1 | |
9315 | ||
9316 | IF (LSTART) THEN | |
9317 | WRITE(LOUT,1000) CRONCO | |
9318 | 1000 FORMAT(/,1X,'CROMSC: multiple scattering of chain ends', | |
9319 | & ' treated',/,10X,'with parameter CRONCO = ',F5.2) | |
9320 | LSTART = .FALSE. | |
9321 | ENDIF | |
9322 | ||
9323 | NCBACK = 0 | |
9324 | RNCL = RPROJ | |
9325 | IF (INCL.EQ.2) RNCL = RTARG | |
9326 | ||
9327 | * Lorentz-transformation into Lab. | |
9328 | MODE = -(INCL+1) | |
9329 | CALL DT_LTNUC(PIN(3),PIN(4),PZ,PE,MODE) | |
9330 | ||
9331 | PTOT = SQRT(PIN(1)**2+PIN(2)**2+PZ**2) | |
9332 | IF (PTOT.LE.8.0D0) GOTO 9997 | |
9333 | ||
9334 | * direction cosines of parton before mult. scattering | |
9335 | COSX = PIN(1)/PTOT | |
9336 | COSY = PIN(2)/PTOT | |
9337 | COSZ = PZ/PTOT | |
9338 | ||
9339 | RTESQ = R(1)**2+R(2)**2+R(3)**2-RNCL**2 | |
9340 | IF (RTESQ.GE.-TINY3) GOTO 9999 | |
9341 | ||
9342 | * calculate distance (DIST) from R to surface of nucleus (radius RNCL) | |
9343 | * in the direction of particle motion | |
9344 | ||
9345 | A = COSX*R(1)+COSY*R(2)+COSZ*R(3) | |
9346 | TMP = A**2-RTESQ | |
9347 | IF (TMP.LT.ZERO) GOTO 9998 | |
9348 | DIST = -A+SQRT(TMP) | |
9349 | ||
9350 | * multiple scattering angle | |
9351 | THETO = CRONCO*SQRT(DIST)/PTOT | |
9352 | IF (THETO.GT.0.1D0) THETO=0.1D0 | |
9353 | ||
9354 | 1 CONTINUE | |
9355 | * Gaussian sampling of spatial angle | |
9356 | CALL DT_RANNOR(R1,R2) | |
9357 | THETA = ABS(R1*THETO) | |
9358 | IF (THETA.GT.0.3D0) GOTO 9997 | |
9359 | CALL DT_DSFECF(SFE,CFE) | |
9360 | COSTH = COS(THETA) | |
9361 | SINTH = SIN(THETA) | |
9362 | ||
9363 | * new direction cosines | |
9364 | CALL DT_MYTRAN(1,COSX,COSY,COSZ,COSTH,SINTH,SFE,CFE, | |
9365 | & COSXN,COSYN,COSZN) | |
9366 | ||
9367 | POUT(1) = COSXN*PTOT | |
9368 | POUT(2) = COSYN*PTOT | |
9369 | PZ = COSZN*PTOT | |
9370 | * Lorentz-transformation into nucl.-nucl. cms | |
9371 | MODE = INCL+1 | |
9372 | CALL DT_LTNUC(PZ,PE,POUT(3),POUT(4),MODE) | |
9373 | ||
9374 | C IF (ABS(PIN(4)-POUT(4)).GT.0.2D0) THEN | |
9375 | C IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.1D0 ) THEN | |
9376 | IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.05D0 ) THEN | |
9377 | THETO = THETO/2.0D0 | |
9378 | NCBACK = NCBACK+1 | |
9379 | IF (MOD(NCBACK,200).EQ.0) THEN | |
9380 | WRITE(LOUT,1001) THETO,PIN,POUT | |
9381 | 1001 FORMAT(1X,'CROMSC: inconsistent scattering angle ', | |
9382 | & E12.4,/,1X,' PIN :',4E12.4,/, | |
9383 | & 1X,' POUT:',4E12.4) | |
9384 | GOTO 9997 | |
9385 | ENDIF | |
9386 | GOTO 1 | |
9387 | ENDIF | |
9388 | ||
9389 | RETURN | |
9390 | ||
9391 | 9997 IRCRON(2) = IRCRON(2)+1 | |
9392 | GOTO 9999 | |
9393 | 9998 IRCRON(3) = IRCRON(3)+1 | |
9394 | ||
9395 | 9999 CONTINUE | |
9396 | DO 100 K=1,4 | |
9397 | POUT(K) = PIN(K) | |
9398 | 100 CONTINUE | |
9399 | RETURN | |
9400 | END | |
9401 | ||
9402 | *$ CREATE DT_COM2CR.FOR | |
9403 | *COPY DT_COM2CR | |
9404 | * | |
9405 | *===com2sr=============================================================* | |
9406 | * | |
9407 | SUBROUTINE DT_COM2CR | |
9408 | ||
9409 | ************************************************************************ | |
9410 | * COMbine q-aq chains to Color Ropes (qq-aqaq). * | |
9411 | * CUTOF parameter determining minimum number of not * | |
9412 | * combined q-aq chains * | |
9413 | * This subroutine replaces KKEVCC etc. * | |
9414 | * This version dated 11.01.95 is written by S. Roesler. * | |
9415 | ************************************************************************ | |
9416 | ||
9417 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
9418 | SAVE | |
9419 | ||
9420 | PARAMETER ( LINP = 10 , | |
9421 | & LOUT = 6 , | |
9422 | & LDAT = 9 ) | |
9423 | ||
9424 | * event history | |
9425 | ||
9426 | PARAMETER (NMXHKK=200000) | |
9427 | ||
9428 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
9429 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
9430 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
9431 | ||
9432 | * extended event history | |
9433 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
9434 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
9435 | & IHIST(2,NMXHKK) | |
9436 | ||
9437 | * statistics | |
9438 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
9439 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
9440 | & ICEVTG(8,0:30) | |
9441 | ||
9442 | * various options for treatment of partons (DTUNUC 1.x) | |
9443 | * (chain recombination, Cronin,..) | |
9444 | LOGICAL LCO2CR,LINTPT | |
9445 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, | |
9446 | & LCO2CR,LINTPT | |
9447 | ||
9448 | DIMENSION IDXQA(248),IDXAQ(248) | |
9449 | ||
9450 | ICCHAI(1,9) = ICCHAI(1,9)+1 | |
9451 | NQA = 0 | |
9452 | NAQ = 0 | |
9453 | * scan DTEVT1 for q-aq, aq-q chains | |
9454 | DO 10 I=NPOINT(3),NHKK | |
9455 | * skip "chains" which are resonances | |
9456 | IF ((IDHKK(I).EQ.88888).AND.(IDRES(I).EQ.0)) THEN | |
9457 | MO1 = JMOHKK(1,I) | |
9458 | MO2 = JMOHKK(2,I) | |
9459 | IF ((ABS(IDHKK(MO1)).LE.6).AND.(ABS(IDHKK(MO2)).LE.6)) THEN | |
9460 | * q-aq, aq-q chain found, keep index | |
9461 | IF (IDHKK(MO1).GT.0) THEN | |
9462 | NQA = NQA+1 | |
9463 | IDXQA(NQA) = I | |
9464 | ELSE | |
9465 | NAQ = NAQ+1 | |
9466 | IDXAQ(NAQ) = I | |
9467 | ENDIF | |
9468 | ENDIF | |
9469 | ENDIF | |
9470 | 10 CONTINUE | |
9471 | ||
9472 | * minimum number of q-aq chains requested for the same projectile/ | |
9473 | * target | |
9474 | NCHMIN = IDT_NPOISS(CUTOF) | |
9475 | ||
9476 | * combine q-aq chains of the same projectile | |
9477 | CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,1) | |
9478 | * combine q-aq chains of the same target | |
9479 | CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,2) | |
9480 | * combine aq-q chains of the same projectile | |
9481 | CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,1) | |
9482 | * combine aq-q chains of the same target | |
9483 | CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,2) | |
9484 | ||
9485 | RETURN | |
9486 | END | |
9487 | ||
9488 | *$ CREATE DT_SCN4CR.FOR | |
9489 | *COPY DT_SCN4CR | |
9490 | * | |
9491 | *===scn4cr=============================================================* | |
9492 | * | |
9493 | SUBROUTINE DT_SCN4CR(NCH,IDXCH,NCHMIN,MODE) | |
9494 | ||
9495 | ************************************************************************ | |
9496 | * SCan q-aq chains for Color Ropes. * | |
9497 | * This version dated 11.01.95 is written by S. Roesler. * | |
9498 | ************************************************************************ | |
9499 | ||
9500 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
9501 | SAVE | |
9502 | ||
9503 | PARAMETER ( LINP = 10 , | |
9504 | & LOUT = 6 , | |
9505 | & LDAT = 9 ) | |
9506 | ||
9507 | * event history | |
9508 | ||
9509 | PARAMETER (NMXHKK=200000) | |
9510 | ||
9511 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
9512 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
9513 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
9514 | ||
9515 | * extended event history | |
9516 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
9517 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
9518 | & IHIST(2,NMXHKK) | |
9519 | ||
9520 | DIMENSION IDXCH(248),IDXJN(248) | |
9521 | ||
9522 | DO 1 I=1,NCH | |
9523 | IF (IDXCH(I).GT.0) THEN | |
9524 | NJOIN = 1 | |
9525 | IDXMO = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(I)))) | |
9526 | IDXJN(NJOIN) = I | |
9527 | IF (I.LT.NCH) THEN | |
9528 | DO 2 J=I+1,NCH | |
9529 | IF (IDXCH(J).GT.0) THEN | |
9530 | IDXMO1 = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(J)))) | |
9531 | IF (IDXMO.EQ.IDXMO1) THEN | |
9532 | NJOIN = NJOIN+1 | |
9533 | IDXJN(NJOIN) = J | |
9534 | ENDIF | |
9535 | ENDIF | |
9536 | 2 CONTINUE | |
9537 | ENDIF | |
9538 | IF (NJOIN.GE.NCHMIN+2) THEN | |
9539 | NJ = INT(DBLE(NJOIN-NCHMIN)/2.0D0) | |
9540 | DO 3 J=1,2*NJ,2 | |
9541 | CALL DT_JOIN(IDXCH(IDXJN(J)),IDXCH(IDXJN(J+1)),IREJ1) | |
9542 | IF (IREJ1.NE.0) GOTO 3 | |
9543 | IDXCH(IDXJN(J)) = 0 | |
9544 | IDXCH(IDXJN(J+1)) = 0 | |
9545 | 3 CONTINUE | |
9546 | ENDIF | |
9547 | ENDIF | |
9548 | 1 CONTINUE | |
9549 | ||
9550 | RETURN | |
9551 | END | |
9552 | ||
9553 | *$ CREATE DT_JOIN.FOR | |
9554 | *COPY DT_JOIN | |
9555 | * | |
9556 | *===join===============================================================* | |
9557 | * | |
9558 | SUBROUTINE DT_JOIN(IDX1,IDX2,IREJ) | |
9559 | ||
9560 | ************************************************************************ | |
9561 | * This subroutine joins two q-aq chains to one qq-aqaq chain. * | |
9562 | * IDX1, IDX2 DTEVT1 indices of chains to be joined * | |
9563 | * This version dated 11.01.95 is written by S. Roesler. * | |
9564 | ************************************************************************ | |
9565 | ||
9566 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
9567 | SAVE | |
9568 | ||
9569 | PARAMETER ( LINP = 10 , | |
9570 | & LOUT = 6 , | |
9571 | & LDAT = 9 ) | |
9572 | ||
9573 | * event history | |
9574 | ||
9575 | PARAMETER (NMXHKK=200000) | |
9576 | ||
9577 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
9578 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
9579 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
9580 | ||
9581 | * extended event history | |
9582 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
9583 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
9584 | & IHIST(2,NMXHKK) | |
9585 | ||
9586 | * flags for input different options | |
9587 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
9588 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
9589 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
9590 | ||
9591 | * statistics | |
9592 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
9593 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
9594 | & ICEVTG(8,0:30) | |
9595 | ||
9596 | DIMENSION MO(2,2),ID(2,2),IDX(2),PCH(4),PP(4),PT(4),P1(4),P2(4) | |
9597 | ||
9598 | IREJ = 0 | |
9599 | ||
9600 | IDX(1) = IDX1 | |
9601 | IDX(2) = IDX2 | |
9602 | DO 1 I=1,2 | |
9603 | DO 2 J=1,2 | |
9604 | MO(I,J) = JMOHKK(J,IDX(I)) | |
9605 | ID(I,J) = IDT_IPDG2B(IDHKK(MO(I,J)),1,2) | |
9606 | 2 CONTINUE | |
9607 | 1 CONTINUE | |
9608 | ||
9609 | * check consistency | |
9610 | IF ((ABS(ID(1,1)).GT.6).OR.(ABS(ID(1,2)).GT.6).OR. | |
9611 | & (ABS(ID(2,1)).GT.6).OR.(ABS(ID(2,2)).GT.6).OR. | |
9612 | & ((ID(1,1)*ID(2,1)).LT.0).OR. | |
9613 | & ((ID(1,2)*ID(2,2)).LT.0)) THEN | |
9614 | WRITE(LOUT,1000) IDX(1),MO(1,1),MO(1,2),IDX(2),MO(2,1), | |
9615 | & MO(2,2) | |
9616 | 1000 FORMAT(1X,'JOIN: incons. chain system! chain ',I4,':', | |
9617 | & 2I5,' chain ',I4,':',2I5) | |
9618 | ENDIF | |
9619 | ||
9620 | * join chains | |
9621 | DO 3 K=1,4 | |
9622 | PP(K) = PHKK(K,MO(1,1))+PHKK(K,MO(2,1)) | |
9623 | PT(K) = PHKK(K,MO(1,2))+PHKK(K,MO(2,2)) | |
9624 | 3 CONTINUE | |
9625 | IF1 = IDT_IB2PDG(ID(1,1),ID(2,1),2) | |
9626 | IF2 = IDT_IB2PDG(ID(1,2),ID(2,2),2) | |
9627 | IST1 = ISTHKK(MO(1,1)) | |
9628 | IST2 = ISTHKK(MO(1,2)) | |
9629 | ||
9630 | * put partons again on mass shell | |
9631 | XM1 = 0.0D0 | |
9632 | XM2 = 0.0D0 | |
9633 | IF (IMSHL.EQ.1) THEN | |
9634 | ||
9635 | XM1 = PYMASS(IF1) | |
9636 | XM2 = PYMASS(IF2) | |
9637 | ||
9638 | ENDIF | |
9639 | CALL DT_MASHEL(PP,PT,XM1,XM2,P1,P2,IREJ1) | |
9640 | IF (IREJ1.NE.0) GOTO 9999 | |
9641 | DO 4 I=1,4 | |
9642 | PP(I) = P1(I) | |
9643 | PT(I) = P2(I) | |
9644 | 4 CONTINUE | |
9645 | ||
9646 | * store new partons in DTEVT1 | |
9647 | CALL DT_EVTPUT(IST1,IF1,MO(1,1),MO(2,1),PP(1),PP(2),PP(3),PP(4), | |
9648 | & 0,0,0) | |
9649 | CALL DT_EVTPUT(IST2,IF2,MO(1,2),MO(2,2),PT(1),PT(2),PT(3),PT(4), | |
9650 | & 0,0,0) | |
9651 | DO 5 K=1,4 | |
9652 | PCH(K) = PP(K)+PT(K) | |
9653 | 5 CONTINUE | |
9654 | ||
9655 | * check new chain for lower mass limit | |
9656 | IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN | |
9657 | AMCH = SQRT(ABS(PCH(4)**2-PCH(1)**2-PCH(2)**2-PCH(3)**2)) | |
9658 | CALL DT_CH2RES(ID(1,1),ID(2,1),ID(1,2),ID(2,2),IDUM,IDUM, | |
9659 | & AMCH,AMCHN,3,IREJ1) | |
9660 | IF (IREJ1.NE.0) THEN | |
9661 | NHKK = NHKK-2 | |
9662 | GOTO 9999 | |
9663 | ENDIF | |
9664 | ENDIF | |
9665 | ||
9666 | ICCHAI(2,9) = ICCHAI(2,9)+1 | |
9667 | * store new chain in DTEVT1 | |
9668 | KCH = 191 | |
9669 | CALL DT_EVTPUT(KCH,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),0,0,9) | |
9670 | IDHKK(IDX(1)) = 22222 | |
9671 | IDHKK(IDX(2)) = 22222 | |
9672 | * special treatment for space-time coordinates | |
9673 | DO 6 K=1,4 | |
9674 | VHKK(K,NHKK) = (VHKK(K,IDX(1))+VHKK(K,IDX(2)))/2.0D0 | |
9675 | WHKK(K,NHKK) = (WHKK(K,IDX(1))+WHKK(K,IDX(2)))/2.0D0 | |
9676 | 6 CONTINUE | |
9677 | RETURN | |
9678 | ||
9679 | 9999 CONTINUE | |
9680 | IREJ = 1 | |
9681 | RETURN | |
9682 | END | |
9683 | *$ CREATE DT_XSGLAU.FOR | |
9684 | *COPY DT_XSGLAU | |
9685 | * | |
9686 | *===xsglau=============================================================* | |
9687 | * | |
9688 | SUBROUTINE DT_XSGLAU(NA,NB,JJPROJ,XI,Q2I,ECMI,IE,IQ,NIDX) | |
9689 | ||
9690 | ************************************************************************ | |
9691 | * Total, elastic, quasi-elastic, inelastic cross sections according to * | |
9692 | * Glauber's approach. * | |
9693 | * NA / NB mass numbers of proj./target nuclei * | |
9694 | * JJPROJ bamjet-index of projectile (=1 in case of proj.nucleus) * | |
9695 | * XI,Q2I,ECMI kinematical variables x, Q^2, E_cm * | |
9696 | * IE,IQ indices of energy and virtuality (the latter for gamma * | |
9697 | * projectiles only) * | |
9698 | * NIDX index of projectile/target nucleus * | |
9699 | * This version dated 17.3.98 is written by S. Roesler * | |
9700 | ************************************************************************ | |
9701 | ||
9702 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
9703 | SAVE | |
9704 | ||
9705 | PARAMETER ( LINP = 10 , | |
9706 | & LOUT = 6 , | |
9707 | & LDAT = 9 ) | |
9708 | ||
9709 | COMPLEX*16 CZERO,CONE,CTWO | |
9710 | CHARACTER*12 CFILE | |
9711 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0, | |
9712 | & ONETHI=ONE/THREE,TINY25=1.0D-25) | |
9713 | PARAMETER (TWOPI = 6.283185307179586454D+00, | |
9714 | & PI = TWOPI/TWO, | |
9715 | & GEV2MB = 0.38938D0, | |
9716 | & GEV2FM = 0.1972D0, | |
9717 | & ALPHEM = ONE/137.0D0, | |
9718 | * proton mass | |
9719 | & AMP = 0.938D0, | |
9720 | & AMP2 = AMP**2, | |
9721 | * approx. nucleon radius | |
9722 | & RNUCLE = 1.12D0) | |
9723 | ||
9724 | * particle properties (BAMJET index convention) | |
9725 | CHARACTER*8 ANAME | |
9726 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
9727 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
9728 | ||
9729 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
9730 | ||
9731 | PARAMETER ( MAXNCL = 260, | |
9732 | ||
9733 | & MAXVQU = MAXNCL, | |
9734 | & MAXSQU = 20*MAXVQU, | |
9735 | & MAXINT = MAXVQU+MAXSQU) | |
9736 | ||
9737 | * Glauber formalism: parameters | |
9738 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), | |
9739 | & BMAX(NCOMPX),BSTEP(NCOMPX), | |
9740 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), | |
9741 | & NSITEB,NSTATB | |
9742 | ||
9743 | * Glauber formalism: cross sections | |
9744 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
9745 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
9746 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
9747 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
9748 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
9749 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
9750 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
9751 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
9752 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
9753 | & BSLOPE,NEBINI,NQBINI | |
9754 | ||
9755 | * Glauber formalism: flags and parameters for statistics | |
9756 | LOGICAL LPROD | |
9757 | CHARACTER*8 CGLB | |
9758 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD | |
9759 | ||
9760 | * nucleon-nucleon event-generator | |
9761 | CHARACTER*8 CMODEL | |
9762 | LOGICAL LPHOIN | |
9763 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
9764 | ||
9765 | * VDM parameter for photon-nucleus interactions | |
9766 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
9767 | ||
9768 | * parameters for hA-diffraction | |
9769 | COMMON /DTDIHA/ DIBETA,DIALPH | |
9770 | ||
9771 | COMPLEX*16 PP11(MAXNCL),PP12(MAXNCL),PP21(MAXNCL),PP22(MAXNCL), | |
9772 | & OMPP11,OMPP12,OMPP21,OMPP22, | |
9773 | & DIPP11,DIPP12,DIPP21,DIPP22,AVDIPP, | |
9774 | & PPTMP1,PPTMP2 | |
9775 | COMPLEX*16 C,CA,CI | |
9776 | DIMENSION COOP1(3,MAXNCL),COOT1(3,MAXNCL), | |
9777 | & COOP2(3,MAXNCL),COOT2(3,MAXNCL), | |
9778 | & BPROD(KSITEB) | |
9779 | ||
9780 | PARAMETER (NPOINT=16) | |
9781 | DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT) | |
9782 | ||
9783 | LOGICAL LFIRST,LOPEN | |
9784 | DATA LFIRST,LOPEN /.TRUE.,.FALSE./ | |
9785 | ||
9786 | NTARG = ABS(NIDX) | |
9787 | * for quasi-elastic neutrino scattering set projectile to proton | |
9788 | * it should not have an effect since the whole Glauber-formalism is | |
9789 | * not needed for these interactions.. | |
9790 | IF (MCGENE.EQ.4) THEN | |
9791 | IJPROJ = 1 | |
9792 | ELSE | |
9793 | IJPROJ = JJPROJ | |
9794 | ENDIF | |
9795 | ||
9796 | IF ((ABS(IOGLB).EQ.1).AND.(.NOT.LOPEN)) THEN | |
9797 | I = INDEX(CGLB,' ') | |
9798 | IF (I.EQ.0) THEN | |
9799 | CFILE = CGLB//'.glb' | |
9800 | OPEN(LDAT,FILE=CGLB//'.glb',STATUS='UNKNOWN') | |
9801 | ELSEIF (I.GT.1) THEN | |
9802 | CFILE = CGLB(1:I-1)//'.glb' | |
9803 | OPEN(LDAT,FILE=CGLB(1:I-1)//'.glb',STATUS='UNKNOWN') | |
9804 | ELSE | |
9805 | STOP 'XSGLAU 1' | |
9806 | ENDIF | |
9807 | LOPEN = .TRUE. | |
9808 | ENDIF | |
9809 | ||
9810 | CZERO = DCMPLX(ZERO,ZERO) | |
9811 | CONE = DCMPLX(ONE,ZERO) | |
9812 | CTWO = DCMPLX(TWO,ZERO) | |
9813 | NEBINI = IE | |
9814 | NQBINI = IQ | |
9815 | ||
9816 | * re-define kinematics | |
9817 | S = ECMI**2 | |
9818 | Q2 = Q2I | |
9819 | X = XI | |
9820 | * g(Q2=0)-A, h-A, A-A scattering | |
9821 | IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN | |
9822 | Q2 = 0.0001D0 | |
9823 | X = Q2/(S+Q2-AMP2) | |
9824 | * g(Q2>0)-A scattering | |
9825 | ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(S.GT.ZERO)) THEN | |
9826 | X = Q2/(S+Q2-AMP2) | |
9827 | ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN | |
9828 | Q2 = (S-AMP2)*X/(ONE-X) | |
9829 | ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN | |
9830 | S = Q2*(ONE-X)/X+AMP2 | |
9831 | ELSE | |
9832 | WRITE(LOUT,*) 'XSGLAU: inconsistent input ',S,Q2,X | |
9833 | STOP | |
9834 | ENDIF | |
9835 | ECMNN(IE) = SQRT(S) | |
9836 | Q2G(IQ) = Q2 | |
9837 | XNU = (S+Q2-AMP2)/(TWO*AMP) | |
9838 | ||
9839 | * parameters determining statistics in evaluating Glauber-xsection | |
9840 | NSTATB = JSTATB | |
9841 | NSITEB = JBINSB | |
9842 | IF (NSITEB.GT.KSITEB) NSITEB = KSITEB | |
9843 | ||
9844 | * set up interaction geometry (common /DTGLAM/) | |
9845 | * projectile/target radii | |
9846 | RPRNCL = DT_RNCLUS(NA) | |
9847 | RTANCL = DT_RNCLUS(NB) | |
9848 | IF (IJPROJ.EQ.7) THEN | |
9849 | RASH(1) = ZERO | |
9850 | RBSH(NTARG) = RTANCL | |
9851 | BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG)) | |
9852 | ELSE | |
9853 | IF (NIDX.LE.-1) THEN | |
9854 | RASH(1) = RPRNCL | |
9855 | RBSH(NTARG) = RTANCL | |
9856 | BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG)) | |
9857 | ELSE | |
9858 | RASH(NTARG) = RPRNCL | |
9859 | RBSH(1) = RTANCL | |
9860 | BMAX(NTARG) = 2.0D0*(RASH(NTARG)+RBSH(1)) | |
9861 | ENDIF | |
9862 | ENDIF | |
9863 | * maximum impact-parameter | |
9864 | BSTEP(NTARG)= BMAX(NTARG)/DBLE(NSITEB-1) | |
9865 | ||
9866 | * slope, rho ( Re(f(0))/Im(f(0)) ) | |
9867 | IF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN | |
9868 | IF (MCGENE.EQ.2) THEN | |
9869 | ZERO1 = ZERO | |
9870 | CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,SDUM1,SDUM2,SDUM3, | |
9871 | & BSLOPE,0) | |
9872 | ELSE | |
9873 | BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S)) | |
9874 | ENDIF | |
9875 | IF (ECMNN(IE).LE.3.0D0) THEN | |
9876 | ROSH = -0.43D0 | |
9877 | ELSEIF ((ECMNN(IE).GT.3.0D0).AND.(ECMNN(IE).LE.50.D0)) THEN | |
9878 | ROSH = -0.63D0+0.175D0*LOG(ECMNN(IE)) | |
9879 | ELSEIF (ECMNN(IE).GT.50.0D0) THEN | |
9880 | ROSH = 0.1D0 | |
9881 | ENDIF | |
9882 | ELSEIF (IJPROJ.EQ.7) THEN | |
9883 | ROSH = 0.1D0 | |
9884 | ELSE | |
9885 | BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S)) | |
9886 | ROSH = 0.01D0 | |
9887 | ENDIF | |
9888 | ||
9889 | * projectile-nucleon xsection (in fm) | |
9890 | IF (IJPROJ.EQ.7) THEN | |
9891 | SIGSH = DT_SIGVP(X,Q2)/10.0D0 | |
9892 | ELSE | |
9893 | ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP) | |
9894 | PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) ) | |
9895 | C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0 | |
9896 | DUMZER = ZERO | |
9897 | CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL) | |
9898 | SIGSH = SIGSH/10.0D0 | |
9899 | ENDIF | |
9900 | ||
9901 | * parameters for projectile diffraction (hA scattering only) | |
9902 | IF ((MCGENE.EQ.2).AND.(NA.EQ.1).AND.(NB.GT.1).AND.(IJPROJ.NE.7) | |
9903 | & .AND.(DIBETA.GE.ZERO)) THEN | |
9904 | ZERO1 = ZERO | |
9905 | CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,STOT,SDUM2,SDIF1,BDUM,0) | |
9906 | C DIBETA = SDIF1/STOT | |
9907 | DIBETA = 0.2D0 | |
9908 | DIGAMM = SQRT(DIALPH**2+DIBETA**2) | |
9909 | IF (DIBETA.LE.ZERO) THEN | |
9910 | ALPGAM = ONE | |
9911 | ELSE | |
9912 | ALPGAM = DIALPH/DIGAMM | |
9913 | ENDIF | |
9914 | FACDI1 = ONE-ALPGAM | |
9915 | FACDI2 = ONE+ALPGAM | |
9916 | FACDI = SQRT(FACDI1*FACDI2) | |
9917 | WRITE(LOUT,*)'DIBETA,DIALPH,DIGAMM: ',DIBETA,DIALPH,DIGAMM | |
9918 | ELSE | |
9919 | DIBETA = -1.0D0 | |
9920 | DIALPH = ZERO | |
9921 | DIGAMM = ZERO | |
9922 | FACDI1 = ZERO | |
9923 | FACDI2 = 2.0D0 | |
9924 | FACDI = ZERO | |
9925 | ENDIF | |
9926 | ||
9927 | * initializations | |
9928 | DO 10 I=1,NSITEB | |
9929 | BSITE( 0,IQ,NTARG,I) = ZERO | |
9930 | BSITE(IE,IQ,NTARG,I) = ZERO | |
9931 | BPROD(I) = ZERO | |
9932 | 10 CONTINUE | |
9933 | STOT = ZERO | |
9934 | STOT2 = ZERO | |
9935 | SELA = ZERO | |
9936 | SELA2 = ZERO | |
9937 | SQEP = ZERO | |
9938 | SQEP2 = ZERO | |
9939 | SQET = ZERO | |
9940 | SQET2 = ZERO | |
9941 | SQE2 = ZERO | |
9942 | SQE22 = ZERO | |
9943 | SPRO = ZERO | |
9944 | SPRO2 = ZERO | |
9945 | SDEL = ZERO | |
9946 | SDEL2 = ZERO | |
9947 | SDQE = ZERO | |
9948 | SDQE2 = ZERO | |
9949 | FACN = ONE/DBLE(NSTATB) | |
9950 | ||
9951 | IPNT = 0 | |
9952 | RPNT = ZERO | |
9953 | ||
9954 | * initialize Gauss-integration for photon-proj. | |
9955 | JPOINT = 1 | |
9956 | IF (IJPROJ.EQ.7) THEN | |
9957 | IF (INTRGE(1).EQ.1) THEN | |
9958 | AMLO2 = (3.0D0*AAM(13))**2 | |
9959 | ELSEIF (INTRGE(1).EQ.2) THEN | |
9960 | AMLO2 = AAM(33)**2 | |
9961 | ELSE | |
9962 | AMLO2 = AAM(96)**2 | |
9963 | ENDIF | |
9964 | IF (INTRGE(2).EQ.1) THEN | |
9965 | AMHI2 = S/TWO | |
9966 | ELSEIF (INTRGE(2).EQ.2) THEN | |
9967 | AMHI2 = S/4.0D0 | |
9968 | ELSE | |
9969 | AMHI2 = S | |
9970 | ENDIF | |
9971 | AMHI20 = (ECMNN(IE)-AMP)**2 | |
9972 | IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20 | |
9973 | XAMLO = LOG( AMLO2+Q2 ) | |
9974 | XAMHI = LOG( AMHI2+Q2 ) | |
9975 | **PHOJET105a | |
9976 | C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT) | |
9977 | **PHOJET112 | |
9978 | ||
9979 | CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT) | |
9980 | ||
9981 | ** | |
9982 | JPOINT = NPOINT | |
9983 | * ratio direct/total photon-nucleon xsection | |
9984 | CALL DT_POILIK(NB,NTARG,ECMNN(IE),Q2,IPNT,RPNT,1) | |
9985 | ENDIF | |
9986 | ||
9987 | * read pre-initialized profile-function from file | |
9988 | IF (IOGLB.EQ.1) THEN | |
9989 | READ(LDAT,'(5I10,E15.5)') KJPROJ,IA,IB,ISTATB,ISITEB,DUM | |
9990 | IF ((IA.NE.NA).OR.(IB.NE.NB)) THEN | |
9991 | WRITE(LOUT,1000) CFILE,IA,IB,ISTATB,ISITEB, | |
9992 | & NA,NB,NSTATB,NSITEB | |
9993 | 1000 FORMAT(' XSGLAU: inconsistent input data in file ',A12,/, | |
9994 | & ' (IA,IB,ISTATB,ISITEB) ',4I10,/, | |
9995 | & ' (NA,NB,NSTATB,NSITEB) ',4I10) | |
9996 | STOP | |
9997 | ENDIF | |
9998 | IF (LFIRST) WRITE(LOUT,1001) CFILE | |
9999 | 1001 FORMAT(/,' XSGLAU: impact parameter distribution read from ', | |
10000 | & 'file ',A12,/) | |
10001 | READ(LDAT,'(6E12.5)') XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG), | |
10002 | & XSQEP(IE,IQ,NTARG),XSQET(IE,IQ,NTARG), | |
10003 | & XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG) | |
10004 | READ(LDAT,'(6E12.5)') XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG), | |
10005 | & XEQEP(IE,IQ,NTARG),XEQET(IE,IQ,NTARG), | |
10006 | & XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG) | |
10007 | NLINES = INT(DBLE(NSITEB)/7.0D0) | |
10008 | IF (NLINES.GT.0) THEN | |
10009 | DO 21 I=1,NLINES | |
10010 | ISTART = 7*I-6 | |
10011 | READ(LDAT,'(7E11.4)') | |
10012 | & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6) | |
10013 | 21 CONTINUE | |
10014 | ENDIF | |
10015 | ISTART = 7*NLINES+1 | |
10016 | IF (ISTART.LE.NSITEB) THEN | |
10017 | READ(LDAT,'(7E11.4)') | |
10018 | & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB) | |
10019 | ENDIF | |
10020 | LFIRST = .FALSE. | |
10021 | GOTO 100 | |
10022 | * variable projectile/target/energy runs: | |
10023 | * read pre-initialized profile-functions from file | |
10024 | ELSEIF (IOGLB.EQ.100) THEN | |
10025 | CALL DT_GLBSET(IJPROJ,IINA,IINB,RRELAB,0) | |
10026 | GOTO 100 | |
10027 | ENDIF | |
10028 | ||
10029 | * cross sections averaged over NSTATB nucleon configurations | |
10030 | DO 11 IS=1,NSTATB | |
10031 | C IF ((NA.EQ.207).AND.(NB.EQ.207)) WRITE(LOUT,*) 'conf. ',IS | |
10032 | STOTN = ZERO | |
10033 | SELAN = ZERO | |
10034 | SQEPN = ZERO | |
10035 | SQETN = ZERO | |
10036 | SQE2N = ZERO | |
10037 | SPRON = ZERO | |
10038 | SDELN = ZERO | |
10039 | SDQEN = ZERO | |
10040 | ||
10041 | IF (NIDX.LE.-1) THEN | |
10042 | CALL DT_CONUCL(COOP1,NA,RASH(1),0) | |
10043 | CALL DT_CONUCL(COOT1,NB,RBSH(NTARG),1) | |
10044 | IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN | |
10045 | CALL DT_CONUCL(COOP2,NA,RASH(1),0) | |
10046 | CALL DT_CONUCL(COOT2,NB,RBSH(NTARG),1) | |
10047 | ENDIF | |
10048 | ELSE | |
10049 | CALL DT_CONUCL(COOP1,NA,RASH(NTARG),0) | |
10050 | CALL DT_CONUCL(COOT1,NB,RBSH(1),1) | |
10051 | IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN | |
10052 | CALL DT_CONUCL(COOP2,NA,RASH(NTARG),0) | |
10053 | CALL DT_CONUCL(COOT2,NB,RBSH(1),1) | |
10054 | ENDIF | |
10055 | ENDIF | |
10056 | ||
10057 | * integration over impact parameter B | |
10058 | DO 12 IB=1,NSITEB-1 | |
10059 | STOTB = ZERO | |
10060 | SELAB = ZERO | |
10061 | SQEPB = ZERO | |
10062 | SQETB = ZERO | |
10063 | SQE2B = ZERO | |
10064 | SPROB = ZERO | |
10065 | SDIR = ZERO | |
10066 | SDELB = ZERO | |
10067 | SDQEB = ZERO | |
10068 | B = DBLE(IB)*BSTEP(NTARG) | |
10069 | FACB = 10.0D0*TWOPI*B*BSTEP(NTARG) | |
10070 | ||
10071 | * integration over M_V^2 for photon-proj. | |
10072 | DO 14 IM=1,JPOINT | |
10073 | PP11(1) = CONE | |
10074 | PP12(1) = CONE | |
10075 | PP21(1) = CONE | |
10076 | PP22(1) = CONE | |
10077 | IF (IJPROJ.EQ.7) THEN | |
10078 | DO 13 K=2,NB | |
10079 | PP11(K) = CONE | |
10080 | PP12(K) = CONE | |
10081 | PP21(K) = CONE | |
10082 | PP22(K) = CONE | |
10083 | 13 CONTINUE | |
10084 | ENDIF | |
10085 | SHI = ZERO | |
10086 | FACM = ONE | |
10087 | DCOH = 1.0D10 | |
10088 | ||
10089 | IF (IJPROJ.EQ.7) THEN | |
10090 | AMV2 = EXP(ABSZX(IM))-Q2 | |
10091 | AMV = SQRT(AMV2) | |
10092 | IF (AMV2.LT.16.0D0) THEN | |
10093 | R = TWO | |
10094 | ELSEIF ((AMV2.GE.16.0D0).AND.(AMV2.LT.121.0D0)) THEN | |
10095 | R = 10.0D0/3.0D0 | |
10096 | ELSE | |
10097 | R = 11.0D0/3.0D0 | |
10098 | ENDIF | |
10099 | * define M_V dependent properties of nucleon scattering amplitude | |
10100 | * V_M-nucleon xsection | |
10101 | SIGMVD = RPNT*SIGSH/(AMV2+Q2+RL2)*10.0D0 | |
10102 | SIGMV = (ONE-RPNT)*SIGSH/(AMV2+Q2+RL2) | |
10103 | * slope-parametrisation a la Kaidalov | |
10104 | BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2) | |
10105 | & +0.25D0*LOG(S/(AMV2+Q2))) | |
10106 | * coherence length | |
10107 | IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+Q2)*GEV2FM | |
10108 | * integration weight factor | |
10109 | FACM = ALPHEM/(3.0D0*PI*(ONE-X))* | |
10110 | & R*AMV2/(AMV2+Q2)*(ONE+EPSPOL*Q2/AMV2)*WEIGHT(IM) | |
10111 | ENDIF | |
10112 | GSH = 10.0D0/(TWO*BSLOPE*GEV2MB) | |
10113 | GAM = GSH | |
10114 | IF (IJPROJ.EQ.7) THEN | |
10115 | RCA = GAM*SIGMV/TWOPI | |
10116 | ELSE | |
10117 | RCA = GAM*SIGSH/TWOPI | |
10118 | ENDIF | |
10119 | FCA = -ROSH*RCA | |
10120 | CA = DCMPLX(RCA,FCA) | |
10121 | CI = CONE | |
10122 | ||
10123 | DO 15 INA=1,NA | |
10124 | KK1 = 1 | |
10125 | INT1 = 1 | |
10126 | KK2 = 1 | |
10127 | INT2 = 1 | |
10128 | DO 16 INB=1,NB | |
10129 | * photon-projectile: check for supression by coherence length | |
10130 | IF (IJPROJ.EQ.7) THEN | |
10131 | IF (ABS(COOT1(3,INB)-COOT1(3,KK1)).GT.DCOH)THEN | |
10132 | KK1 = INB | |
10133 | INT1 = INT1+1 | |
10134 | ENDIF | |
10135 | IF (ABS(COOT2(3,INB)-COOT2(3,KK2)).GT.DCOH)THEN | |
10136 | KK2 = INB | |
10137 | INT2 = INT2+1 | |
10138 | ENDIF | |
10139 | ENDIF | |
10140 | ||
10141 | X11 = B+COOT1(1,INB)-COOP1(1,INA) | |
10142 | Y11 = COOT1(2,INB)-COOP1(2,INA) | |
10143 | XY11 = GAM*(X11*X11+Y11*Y11) | |
10144 | IF (XY11.LE.15.0D0) THEN | |
10145 | C = CONE-CA*EXP(-XY11) | |
10146 | AR = DBLE(PP11(INT1)) | |
10147 | AI = DIMAG(PP11(INT1)) | |
10148 | IF (ABS(AR).LT.TINY25) AR = ZERO | |
10149 | IF (ABS(AI).LT.TINY25) AI = ZERO | |
10150 | PP11(INT1) = DCMPLX(AR,AI) | |
10151 | PP11(INT1) = PP11(INT1)*C | |
10152 | AR = DBLE(C) | |
10153 | AI = DIMAG(C) | |
10154 | SHI = SHI+LOG(AR*AR+AI*AI) | |
10155 | ENDIF | |
10156 | IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN | |
10157 | X12 = B+COOT2(1,INB)-COOP1(1,INA) | |
10158 | Y12 = COOT2(2,INB)-COOP1(2,INA) | |
10159 | XY12 = GAM*(X12*X12+Y12*Y12) | |
10160 | IF (XY12.LE.15.0D0) THEN | |
10161 | C = CONE-CA*EXP(-XY12) | |
10162 | AR = DBLE(PP12(INT2)) | |
10163 | AI = DIMAG(PP12(INT2)) | |
10164 | IF (ABS(AR).LT.TINY25) AR = ZERO | |
10165 | IF (ABS(AI).LT.TINY25) AI = ZERO | |
10166 | PP12(INT2) = DCMPLX(AR,AI) | |
10167 | PP12(INT2) = PP12(INT2)*C | |
10168 | ENDIF | |
10169 | X21 = B+COOT1(1,INB)-COOP2(1,INA) | |
10170 | Y21 = COOT1(2,INB)-COOP2(2,INA) | |
10171 | XY21 = GAM*(X21*X21+Y21*Y21) | |
10172 | IF (XY21.LE.15.0D0) THEN | |
10173 | C = CONE-CA*EXP(-XY21) | |
10174 | AR = DBLE(PP21(INT1)) | |
10175 | AI = DIMAG(PP21(INT1)) | |
10176 | IF (ABS(AR).LT.TINY25) AR = ZERO | |
10177 | IF (ABS(AI).LT.TINY25) AI = ZERO | |
10178 | PP21(INT1) = DCMPLX(AR,AI) | |
10179 | PP21(INT1) = PP21(INT1)*C | |
10180 | ENDIF | |
10181 | X22 = B+COOT2(1,INB)-COOP2(1,INA) | |
10182 | Y22 = COOT2(2,INB)-COOP2(2,INA) | |
10183 | XY22 = GAM*(X22*X22+Y22*Y22) | |
10184 | IF (XY22.LE.15.0D0) THEN | |
10185 | C = CONE-CA*EXP(-XY22) | |
10186 | AR = DBLE(PP22(INT2)) | |
10187 | AI = DIMAG(PP22(INT2)) | |
10188 | IF (ABS(AR).LT.TINY25) AR = ZERO | |
10189 | IF (ABS(AI).LT.TINY25) AI = ZERO | |
10190 | PP22(INT2) = DCMPLX(AR,AI) | |
10191 | PP22(INT2) = PP22(INT2)*C | |
10192 | ENDIF | |
10193 | ENDIF | |
10194 | 16 CONTINUE | |
10195 | 15 CONTINUE | |
10196 | ||
10197 | OMPP11 = CZERO | |
10198 | OMPP21 = CZERO | |
10199 | DIPP11 = CZERO | |
10200 | DIPP21 = CZERO | |
10201 | DO 17 K=1,INT1 | |
10202 | IF (PP11(K).EQ.CZERO) THEN | |
10203 | PPTMP1 = CZERO | |
10204 | PPTMP2 = CZERO | |
10205 | ELSE | |
10206 | PPTMP1 = PP11(K)**(ONE-DIALPH-DIGAMM) | |
10207 | PPTMP2 = PP11(K)**(ONE-DIALPH+DIGAMM) | |
10208 | ENDIF | |
10209 | AVDIPP = 0.5D0* | |
10210 | & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) ) | |
10211 | OMPP11 = OMPP11+AVDIPP | |
10212 | C OMPP11 = OMPP11+(CONE-PP11(K)) | |
10213 | AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 ) | |
10214 | DIPP11 = DIPP11+AVDIPP | |
10215 | IF (PP21(K).EQ.CZERO) THEN | |
10216 | PPTMP1 = CZERO | |
10217 | PPTMP2 = CZERO | |
10218 | ELSE | |
10219 | PPTMP1 = PP21(K)**(ONE-DIALPH-DIGAMM) | |
10220 | PPTMP2 = PP21(K)**(ONE-DIALPH+DIGAMM) | |
10221 | ENDIF | |
10222 | AVDIPP = 0.5D0* | |
10223 | & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) ) | |
10224 | OMPP21 = OMPP21+AVDIPP | |
10225 | C OMPP21 = OMPP21+(CONE-PP21(K)) | |
10226 | AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 ) | |
10227 | DIPP21 = DIPP21+AVDIPP | |
10228 | 17 CONTINUE | |
10229 | OMPP12 = CZERO | |
10230 | OMPP22 = CZERO | |
10231 | DIPP12 = CZERO | |
10232 | DIPP22 = CZERO | |
10233 | DO 18 K=1,INT2 | |
10234 | IF (PP12(K).EQ.CZERO) THEN | |
10235 | PPTMP1 = CZERO | |
10236 | PPTMP2 = CZERO | |
10237 | ELSE | |
10238 | PPTMP1 = PP12(K)**(ONE-DIALPH-DIGAMM) | |
10239 | PPTMP2 = PP12(K)**(ONE-DIALPH+DIGAMM) | |
10240 | ENDIF | |
10241 | AVDIPP = 0.5D0* | |
10242 | & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) ) | |
10243 | OMPP12 = OMPP12+AVDIPP | |
10244 | C OMPP12 = OMPP12+(CONE-PP12(K)) | |
10245 | AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 ) | |
10246 | DIPP12 = DIPP12+AVDIPP | |
10247 | IF (PP22(K).EQ.CZERO) THEN | |
10248 | PPTMP1 = CZERO | |
10249 | PPTMP2 = CZERO | |
10250 | ELSE | |
10251 | PPTMP1 = PP22(K)**(ONE-DIALPH-DIGAMM) | |
10252 | PPTMP2 = PP22(K)**(ONE-DIALPH+DIGAMM) | |
10253 | ENDIF | |
10254 | AVDIPP = 0.5D0* | |
10255 | & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) ) | |
10256 | OMPP22 = OMPP22+AVDIPP | |
10257 | C OMPP22 = OMPP22+(CONE-PP22(K)) | |
10258 | AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 ) | |
10259 | DIPP22 = DIPP22+AVDIPP | |
10260 | 18 CONTINUE | |
10261 | ||
10262 | SPROM = ONE-EXP(SHI) | |
10263 | SPROB = SPROB+FACM*SPROM | |
10264 | IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN | |
10265 | STOTM = DBLE(OMPP11+OMPP22) | |
10266 | SELAM = DBLE(OMPP11*DCONJG(OMPP22)) | |
10267 | SQEPM = DBLE(OMPP11*DCONJG(OMPP21))-SELAM | |
10268 | SQETM = DBLE(OMPP11*DCONJG(OMPP12))-SELAM | |
10269 | SQE2M = DBLE(OMPP11*DCONJG(OMPP11))-SELAM-SQEPM-SQETM | |
10270 | SDELM = DBLE(DIPP11*DCONJG(DIPP22)) | |
10271 | SDQEM = DBLE(DIPP11*DCONJG(DIPP21))-SDELM | |
10272 | STOTB = STOTB+FACM*STOTM | |
10273 | SELAB = SELAB+FACM*SELAM | |
10274 | SDELB = SDELB+FACM*SDELM | |
10275 | IF (NB.GT.1) THEN | |
10276 | SQEPB = SQEPB+FACM*SQEPM | |
10277 | SDQEB = SDQEB+FACM*SDQEM | |
10278 | ENDIF | |
10279 | IF (NA.GT.1) SQETB = SQETB+FACM*SQETM | |
10280 | IF ((NA.GT.1).AND.(NB.GT.1)) SQE2B = SQE2B+FACM*SQE2M | |
10281 | IF (IJPROJ.EQ.7) SDIR = SDIR+FACM*SIGMVD | |
10282 | ENDIF | |
10283 | ||
10284 | 14 CONTINUE | |
10285 | ||
10286 | STOTN = STOTN+FACB*STOTB | |
10287 | SELAN = SELAN+FACB*SELAB | |
10288 | SQEPN = SQEPN+FACB*SQEPB | |
10289 | SQETN = SQETN+FACB*SQETB | |
10290 | SQE2N = SQE2N+FACB*SQE2B | |
10291 | SPRON = SPRON+FACB*SPROB | |
10292 | SDELN = SDELN+FACB*SDELB | |
10293 | SDQEN = SDQEN+FACB*SDQEB | |
10294 | ||
10295 | IF (IJPROJ.EQ.7) THEN | |
10296 | BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*(STOTB-SELAB-SQEPB) | |
10297 | ELSE | |
10298 | IF (DIBETA.GT.ZERO) THEN | |
10299 | BPROD(IB+1)= BPROD(IB+1) | |
10300 | & +FACN*FACB*(STOTB-SELAB-SQEPB-SQETB-SQE2B) | |
10301 | ELSE | |
10302 | BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*SPROB | |
10303 | ENDIF | |
10304 | ENDIF | |
10305 | ||
10306 | 12 CONTINUE | |
10307 | ||
10308 | STOT = STOT +FACN*STOTN | |
10309 | STOT2 = STOT2+FACN*STOTN**2 | |
10310 | SELA = SELA +FACN*SELAN | |
10311 | SELA2 = SELA2+FACN*SELAN**2 | |
10312 | SQEP = SQEP +FACN*SQEPN | |
10313 | SQEP2 = SQEP2+FACN*SQEPN**2 | |
10314 | SQET = SQET +FACN*SQETN | |
10315 | SQET2 = SQET2+FACN*SQETN**2 | |
10316 | SQE2 = SQE2 +FACN*SQE2N | |
10317 | SQE22 = SQE22+FACN*SQE2N**2 | |
10318 | SPRO = SPRO +FACN*SPRON | |
10319 | SPRO2 = SPRO2+FACN*SPRON**2 | |
10320 | SDEL = SDEL +FACN*SDELN | |
10321 | SDEL2 = SDEL2+FACN*SDELN**2 | |
10322 | SDQE = SDQE +FACN*SDQEN | |
10323 | SDQE2 = SDQE2+FACN*SDQEN**2 | |
10324 | ||
10325 | 11 CONTINUE | |
10326 | ||
10327 | * final cross sections | |
10328 | * 1) total | |
10329 | XSTOT(IE,IQ,NTARG) = STOT | |
10330 | IF (IJPROJ.EQ.7) | |
10331 | & XSTOT(IE,IQ,NTARG) = XSTOT(IE,IQ,NTARG)+DBLE(NB)*SDIR | |
10332 | * 2) elastic | |
10333 | XSELA(IE,IQ,NTARG) = SELA | |
10334 | * 3) quasi-el.: A+B-->A+X (excluding 2) | |
10335 | XSQEP(IE,IQ,NTARG) = SQEP | |
10336 | * 4) quasi-el.: A+B-->X+B (excluding 2) | |
10337 | XSQET(IE,IQ,NTARG) = SQET | |
10338 | * 5) quasi-el.: A+B-->X (excluding 2-4) | |
10339 | XSQE2(IE,IQ,NTARG) = SQE2 | |
10340 | * 6) production (= STOT-SELA-SQEP-SQET-SQE2!) | |
10341 | IF (SDEL.GT.ZERO) THEN | |
10342 | XSPRO(IE,IQ,NTARG) = STOT-SELA-SQEP-SQET-SQE2 | |
10343 | ELSE | |
10344 | XSPRO(IE,IQ,NTARG) = SPRO | |
10345 | ENDIF | |
10346 | * 7) projectile diffraction (el. scatt. off target) | |
10347 | XSDEL(IE,IQ,NTARG) = SDEL | |
10348 | * 8) projectile diffraction (quasi-el. scatt. off target) | |
10349 | XSDQE(IE,IQ,NTARG) = SDQE | |
10350 | * stat. errors | |
10351 | XETOT(IE,IQ,NTARG) = SQRT(ABS(STOT2-STOT**2)/DBLE(NSTATB-1)) | |
10352 | XEELA(IE,IQ,NTARG) = SQRT(ABS(SELA2-SELA**2)/DBLE(NSTATB-1)) | |
10353 | XEQEP(IE,IQ,NTARG) = SQRT(ABS(SQEP2-SQEP**2)/DBLE(NSTATB-1)) | |
10354 | XEQET(IE,IQ,NTARG) = SQRT(ABS(SQET2-SQET**2)/DBLE(NSTATB-1)) | |
10355 | XEQE2(IE,IQ,NTARG) = SQRT(ABS(SQE22-SQE2**2)/DBLE(NSTATB-1)) | |
10356 | XEPRO(IE,IQ,NTARG) = SQRT(ABS(SPRO2-SPRO**2)/DBLE(NSTATB-1)) | |
10357 | XEDEL(IE,IQ,NTARG) = SQRT(ABS(SDEL2-SDEL**2)/DBLE(NSTATB-1)) | |
10358 | XEDQE(IE,IQ,NTARG) = SQRT(ABS(SDQE2-SDQE**2)/DBLE(NSTATB-1)) | |
10359 | ||
10360 | IF (IJPROJ.EQ.7) THEN | |
10361 | BNORM = XSTOT(IE,IQ,NTARG)-XSELA(IE,IQ,NTARG) | |
10362 | & -XSQEP(IE,IQ,NTARG) | |
10363 | ELSE | |
10364 | BNORM = XSPRO(IE,IQ,NTARG) | |
10365 | ENDIF | |
10366 | DO 19 I=2,NSITEB | |
10367 | BSITE(IE,IQ,NTARG,I) = BPROD(I)/BNORM+BSITE(IE,IQ,NTARG,I-1) | |
10368 | IF ((IE.EQ.1).AND.(IQ.EQ.1)) | |
10369 | & BSITE(0,1,NTARG,I) = BPROD(I)/BNORM+BSITE(0,1,NTARG,I-1) | |
10370 | 19 CONTINUE | |
10371 | ||
10372 | * write profile function data into file | |
10373 | IF ((IOGLB.EQ.-1).OR.(IOGLB.EQ.-100)) THEN | |
10374 | WRITE(LDAT,'(5I10,1P,E15.5)') | |
10375 | & IJPROJ,NA,NB,NSTATB,NSITEB,ECMNN(IE) | |
10376 | WRITE(LDAT,'(1P,6E12.5)') | |
10377 | & XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),XSQEP(IE,IQ,NTARG), | |
10378 | & XSQET(IE,IQ,NTARG),XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG) | |
10379 | WRITE(LDAT,'(1P,6E12.5)') | |
10380 | & XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),XEQEP(IE,IQ,NTARG), | |
10381 | & XEQET(IE,IQ,NTARG),XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG) | |
10382 | NLINES = INT(DBLE(NSITEB)/7.0D0) | |
10383 | IF (NLINES.GT.0) THEN | |
10384 | DO 20 I=1,NLINES | |
10385 | ISTART = 7*I-6 | |
10386 | WRITE(LDAT,'(1P,7E11.4)') | |
10387 | & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6) | |
10388 | 20 CONTINUE | |
10389 | ENDIF | |
10390 | ISTART = 7*NLINES+1 | |
10391 | IF (ISTART.LE.NSITEB) THEN | |
10392 | WRITE(LDAT,'(1P,7E11.4)') | |
10393 | & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB) | |
10394 | ENDIF | |
10395 | ENDIF | |
10396 | ||
10397 | 100 CONTINUE | |
10398 | ||
10399 | C IF (ABS(IOGLB).EQ.1) CLOSE(LDAT) | |
10400 | ||
10401 | RETURN | |
10402 | END | |
10403 | ||
10404 | *$ CREATE DT_GETBXS.FOR | |
10405 | *COPY DT_GETBXS | |
10406 | * | |
10407 | *===getbxs=============================================================* | |
10408 | * | |
10409 | SUBROUTINE DT_GETBXS(XSFRAC,BLO,BHI,NIDX) | |
10410 | ||
10411 | ************************************************************************ | |
10412 | * Biasing in impact parameter space. * | |
10413 | * XSFRAC = 0 : BLO - minimum impact parameter (input) * | |
10414 | * BHI - maximum impact parameter (input) * | |
10415 | * XSFRAC - fraction of cross section corresponding * | |
10416 | * to impact parameter range (BLO,BHI) * | |
10417 | * (output) * | |
10418 | * XSFRAC > 0 : XSFRAC - fraction of cross section (input) * | |
10419 | * BHI - maximum impact parameter giving requested * | |
10420 | * fraction of cross section in impact * | |
10421 | * parameter range (0,BMAX) (output) * | |
10422 | * This version dated 17.03.00 is written by S. Roesler * | |
10423 | ************************************************************************ | |
10424 | ||
10425 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
10426 | SAVE | |
10427 | ||
10428 | PARAMETER ( LINP = 10 , | |
10429 | & LOUT = 6 , | |
10430 | & LDAT = 9 ) | |
10431 | ||
10432 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
10433 | ||
10434 | * Glauber formalism: parameters | |
10435 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), | |
10436 | & BMAX(NCOMPX),BSTEP(NCOMPX), | |
10437 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), | |
10438 | & NSITEB,NSTATB | |
10439 | ||
10440 | NTARG = ABS(NIDX) | |
10441 | IF (XSFRAC.LE.0.0D0) THEN | |
10442 | ILO = MIN(NSITEB-1,INT(BLO/BSTEP(NTARG))) | |
10443 | IHI = MIN(NSITEB-1,INT(BHI/BSTEP(NTARG))) | |
10444 | IF (ILO.GE.IHI) THEN | |
10445 | XSFRAC = 0.0D0 | |
10446 | RETURN | |
10447 | ENDIF | |
10448 | IF (ILO.EQ.NSITEB-1) THEN | |
10449 | FRCLO = BSITE(0,1,NTARG,NSITEB) | |
10450 | ELSE | |
10451 | FRCLO = BSITE(0,1,NTARG,ILO+1) | |
10452 | & +(BLO-ILO*BSTEP(NTARG))/BSTEP(NTARG) | |
10453 | & *(BSITE(0,1,NTARG,ILO+2)-BSITE(0,1,NTARG,ILO+1)) | |
10454 | ENDIF | |
10455 | IF (IHI.EQ.NSITEB-1) THEN | |
10456 | FRCHI = BSITE(0,1,NTARG,NSITEB) | |
10457 | ELSE | |
10458 | FRCHI = BSITE(0,1,NTARG,IHI+1) | |
10459 | & +(BHI-IHI*BSTEP(NTARG))/BSTEP(NTARG) | |
10460 | & *(BSITE(0,1,NTARG,IHI+2)-BSITE(0,1,NTARG,IHI+1)) | |
10461 | ENDIF | |
10462 | XSFRAC = FRCHI-FRCLO | |
10463 | ELSE | |
10464 | BLO = 0.0D0 | |
10465 | BHI = BMAX(NTARG) | |
10466 | DO 1 I=1,NSITEB-1 | |
10467 | IF (XSFRAC.LT.BSITE(0,1,NTARG,I+1)) THEN | |
10468 | FAC = (XSFRAC -BSITE(0,1,NTARG,I))/ | |
10469 | & (BSITE(0,1,NTARG,I+1)-BSITE(0,1,NTARG,I)) | |
10470 | BHI = DBLE(I-1)*BSTEP(NTARG)+BSTEP(NTARG)*FAC | |
10471 | GOTO 2 | |
10472 | ENDIF | |
10473 | 1 CONTINUE | |
10474 | 2 CONTINUE | |
10475 | ENDIF | |
10476 | ||
10477 | RETURN | |
10478 | END | |
10479 | ||
10480 | *$ CREATE DT_CONUCL.FOR | |
10481 | *COPY DT_CONUCL | |
10482 | * | |
10483 | *===conucl=============================================================* | |
10484 | * | |
10485 | SUBROUTINE DT_CONUCL(X,N,R,MODE) | |
10486 | ||
10487 | ************************************************************************ | |
10488 | * Calculation of coordinates of nucleons within nuclei. * | |
10489 | * X(3,N) spatial coordinates of nucleons (in fm) (output) * | |
10490 | * N / R number of nucleons / radius of nucleus (input) * | |
10491 | * MODE = 0 coordinates not sorted * | |
10492 | * = 1 coordinates sorted with increasing X(3,i) * | |
10493 | * = 2 coordinates sorted with decreasing X(3,i) * | |
10494 | * This version dated 26.10.95 is revised by S. Roesler * | |
10495 | ************************************************************************ | |
10496 | ||
10497 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
10498 | SAVE | |
10499 | ||
10500 | PARAMETER ( LINP = 10 , | |
10501 | & LOUT = 6 , | |
10502 | & LDAT = 9 ) | |
10503 | ||
10504 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0, | |
10505 | & ONETHI=ONE/THREE,SQRTWO=1.414213562D0) | |
10506 | ||
10507 | PARAMETER (TWOPI = 6.283185307179586454D+00 ) | |
10508 | ||
10509 | PARAMETER (NSRT=10) | |
10510 | DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT) | |
10511 | DIMENSION X(3,N),XTMP(3,260) | |
10512 | ||
10513 | CALL DT_COORDI(XTMP,IDXSRT,ICSRT,N,R) | |
10514 | ||
10515 | IF ((MODE.NE.0).AND.(N.GT.4)) THEN | |
10516 | K = 0 | |
10517 | DO 1 I=1,NSRT | |
10518 | IF (MODE.EQ.2) THEN | |
10519 | ISRT = NSRT+1-I | |
10520 | ELSE | |
10521 | ISRT = I | |
10522 | ENDIF | |
10523 | K1 = K | |
10524 | DO 2 J=1,ICSRT(ISRT) | |
10525 | K = K+1 | |
10526 | X(1,K) = XTMP(1,IDXSRT(ISRT,J)) | |
10527 | X(2,K) = XTMP(2,IDXSRT(ISRT,J)) | |
10528 | X(3,K) = XTMP(3,IDXSRT(ISRT,J)) | |
10529 | 2 CONTINUE | |
10530 | IF (ICSRT(ISRT).GT.1) THEN | |
10531 | I0 = K1+1 | |
10532 | I1 = K | |
10533 | CALL DT_SORT(X,N,I0,I1,MODE) | |
10534 | ENDIF | |
10535 | 1 CONTINUE | |
10536 | ELSEIF ((MODE.NE.0).AND.(N.GE.2).AND.(N.LE.4)) THEN | |
10537 | DO 3 I=1,N | |
10538 | X(1,I) = XTMP(1,I) | |
10539 | X(2,I) = XTMP(2,I) | |
10540 | X(3,I) = XTMP(3,I) | |
10541 | 3 CONTINUE | |
10542 | CALL DT_SORT(X,N,1,N,MODE) | |
10543 | ELSE | |
10544 | DO 4 I=1,N | |
10545 | X(1,I) = XTMP(1,I) | |
10546 | X(2,I) = XTMP(2,I) | |
10547 | X(3,I) = XTMP(3,I) | |
10548 | 4 CONTINUE | |
10549 | ENDIF | |
10550 | ||
10551 | RETURN | |
10552 | END | |
10553 | ||
10554 | *$ CREATE DT_COORDI.FOR | |
10555 | *COPY DT_COORDI | |
10556 | * | |
10557 | *===coordi=============================================================* | |
10558 | * | |
10559 | SUBROUTINE DT_COORDI(X,IDXSRT,ICSRT,N,R) | |
10560 | ||
10561 | ************************************************************************ | |
10562 | * Calculation of coordinates of nucleons within nuclei. * | |
10563 | * X(3,N) spatial coordinates of nucleons (in fm) (output) * | |
10564 | * N / R number of nucleons / radius of nucleus (input) * | |
10565 | * Based on the original version by Shmakov et al. * | |
10566 | * This version dated 26.10.95 is revised by S. Roesler * | |
10567 | ************************************************************************ | |
10568 | ||
10569 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
10570 | SAVE | |
10571 | ||
10572 | PARAMETER ( LINP = 10 , | |
10573 | & LOUT = 6 , | |
10574 | & LDAT = 9 ) | |
10575 | ||
10576 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0, | |
10577 | & ONETHI=ONE/THREE,SQRTWO=1.414213562D0) | |
10578 | ||
10579 | PARAMETER (TWOPI = 6.283185307179586454D+00 ) | |
10580 | ||
10581 | LOGICAL LSTART | |
10582 | ||
10583 | PARAMETER (NSRT=10) | |
10584 | DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT) | |
10585 | DIMENSION X(3,260),WD(4),RD(3) | |
10586 | ||
10587 | DATA PDIF/0.545D0/,R2MIN/0.16D0/ | |
10588 | DATA WD / 0.0D0, 0.178D0, 0.465D0, 1.0D0/ | |
10589 | DATA RD /2.09D0, 0.935D0, 0.697D0/ | |
10590 | ||
10591 | X1SUM = ZERO | |
10592 | X2SUM = ZERO | |
10593 | X3SUM = ZERO | |
10594 | ||
10595 | IF (N.EQ.1) THEN | |
10596 | X(1,1) = ZERO | |
10597 | X(2,1) = ZERO | |
10598 | X(3,1) = ZERO | |
10599 | ELSEIF (N.EQ.2) THEN | |
10600 | EPS = DT_RNDM(RD(1)) | |
10601 | DO 30 I=1,3 | |
10602 | IF ((EPS.GE.WD(I)).AND.(EPS.LE.WD(I+1))) GOTO 40 | |
10603 | 30 CONTINUE | |
10604 | 40 CONTINUE | |
10605 | DO 50 J=1,3 | |
10606 | CALL DT_RANNOR(X1,X2) | |
10607 | X(J,1) = RD(I)*X1 | |
10608 | X(J,2) = -X(J,1) | |
10609 | 50 CONTINUE | |
10610 | ELSEIF ((N.EQ.3).OR.(N.EQ.4)) THEN | |
10611 | SIGMA = R/SQRTWO | |
10612 | LSTART = .TRUE. | |
10613 | CALL DT_RANNOR(X3,X4) | |
10614 | DO 100 I=1,N | |
10615 | CALL DT_RANNOR(X1,X2) | |
10616 | X(1,I) = SIGMA*X1 | |
10617 | X(2,I) = SIGMA*X2 | |
10618 | IF (LSTART) GOTO 80 | |
10619 | X(3,I) = SIGMA*X4 | |
10620 | CALL DT_RANNOR(X3,X4) | |
10621 | GOTO 90 | |
10622 | 80 CONTINUE | |
10623 | X(3,I) = SIGMA*X3 | |
10624 | 90 CONTINUE | |
10625 | LSTART = .NOT.LSTART | |
10626 | X1SUM = X1SUM+X(1,I) | |
10627 | X2SUM = X2SUM+X(2,I) | |
10628 | X3SUM = X3SUM+X(3,I) | |
10629 | 100 CONTINUE | |
10630 | X1SUM = X1SUM/DBLE(N) | |
10631 | X2SUM = X2SUM/DBLE(N) | |
10632 | X3SUM = X3SUM/DBLE(N) | |
10633 | DO 101 I=1,N | |
10634 | X(1,I) = X(1,I)-X1SUM | |
10635 | X(2,I) = X(2,I)-X2SUM | |
10636 | X(3,I) = X(3,I)-X3SUM | |
10637 | 101 CONTINUE | |
10638 | ELSE | |
10639 | ||
10640 | * maximum nuclear radius for coordinate sampling | |
10641 | RMAX = R+4.605D0*PDIF | |
10642 | ||
10643 | * initialize pre-sorting | |
10644 | DO 121 I=1,NSRT | |
10645 | ICSRT(I) = 0 | |
10646 | 121 CONTINUE | |
10647 | DR = TWO*RMAX/DBLE(NSRT) | |
10648 | ||
10649 | * sample coordinates for N nucleons | |
10650 | DO 140 I=1,N | |
10651 | 120 CONTINUE | |
10652 | RAD = RMAX*(DT_RNDM(DR))**ONETHI | |
10653 | F = DT_DENSIT(N,RAD,R) | |
10654 | IF (DT_RNDM(RAD).GT.F) GOTO 120 | |
10655 | * theta, phi uniformly distributed | |
10656 | CT = ONE-TWO*DT_RNDM(F) | |
10657 | ST = SQRT((ONE-CT)*(ONE+CT)) | |
10658 | CALL DT_DSFECF(SFE,CFE) | |
10659 | X(1,I) = RAD*ST*CFE | |
10660 | X(2,I) = RAD*ST*SFE | |
10661 | X(3,I) = RAD*CT | |
10662 | * ensure that distance between two nucleons is greater than R2MIN | |
10663 | IF (I.LT.2) GOTO 122 | |
10664 | I1 = I-1 | |
10665 | DO 130 I2=1,I1 | |
10666 | DIST2 = (X(1,I)-X(1,I2))**2+(X(2,I)-X(2,I2))**2+ | |
10667 | & (X(3,I)-X(3,I2))**2 | |
10668 | IF (DIST2.LE.R2MIN) GOTO 120 | |
10669 | 130 CONTINUE | |
10670 | 122 CONTINUE | |
10671 | * save index according to z-bin | |
10672 | IDXZ = INT( (X(3,I)+RMAX)/DR )+1 | |
10673 | ICSRT(IDXZ) = ICSRT(IDXZ)+1 | |
10674 | IDXSRT(IDXZ,ICSRT(IDXZ)) = I | |
10675 | X1SUM = X1SUM+X(1,I) | |
10676 | X2SUM = X2SUM+X(2,I) | |
10677 | X3SUM = X3SUM+X(3,I) | |
10678 | 140 CONTINUE | |
10679 | X1SUM = X1SUM/DBLE(N) | |
10680 | X2SUM = X2SUM/DBLE(N) | |
10681 | X3SUM = X3SUM/DBLE(N) | |
10682 | DO 141 I=1,N | |
10683 | X(1,I) = X(1,I)-X1SUM | |
10684 | X(2,I) = X(2,I)-X2SUM | |
10685 | X(3,I) = X(3,I)-X3SUM | |
10686 | 141 CONTINUE | |
10687 | ||
10688 | ENDIF | |
10689 | ||
10690 | RETURN | |
10691 | END | |
10692 | ||
10693 | *$ CREATE DT_DENSIT.FOR | |
10694 | *COPY DT_DENSIT | |
10695 | * | |
10696 | *===densit=============================================================* | |
10697 | * | |
10698 | DOUBLE PRECISION FUNCTION DT_DENSIT(NA,R,RA) | |
10699 | ||
10700 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
10701 | SAVE | |
10702 | ||
10703 | PARAMETER ( LINP = 10 , | |
10704 | & LOUT = 6 , | |
10705 | & LDAT = 9 ) | |
10706 | ||
10707 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) | |
10708 | PARAMETER (TWOPI = 6.283185307179586476925286766559D+00, | |
10709 | & PI = TWOPI/TWO) | |
10710 | ||
10711 | DIMENSION R0(18),FNORM(18) | |
10712 | DATA R0 / ZERO, ZERO, ZERO, ZERO, 2.12D0, | |
10713 | & 2.56D0, 2.41D0, 2.46D0, 2.52D0, 2.45D0, | |
10714 | & 2.37D0, 2.46D0, 2.44D0, 2.54D0, 2.58D0, | |
10715 | & 2.72D0, 2.66D0, 2.79D0/ | |
10716 | DATA FNORM /.1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01, | |
10717 | & .1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01, | |
10718 | & .1012D+01,.1039D+01,.1075D+01,.1118D+01,.1164D+01, | |
10719 | & .1214D+01,.1265D+01,.1318D+01/ | |
10720 | DATA PDIF /0.545D0/ | |
10721 | ||
10722 | DT_DENSIT = ZERO | |
10723 | * shell model | |
10724 | IF (NA.LE.4) THEN | |
10725 | STOP 'DT_DENSIT-0' | |
10726 | ELSEIF ((NA.GT.4).AND.(NA.LE.18)) THEN | |
10727 | R1 = R0(NA)/SQRT(2.5D0-4.0D0/DBLE(NA)) | |
10728 | DT_DENSIT = (ONE+(DBLE(NA)-4.0D0)/6.0D0*(R/R1)**2) | |
10729 | & *EXP(-(R/R1)**2)/FNORM(NA) | |
10730 | * Woods-Saxon | |
10731 | ELSEIF (NA.GT.18) THEN | |
10732 | DT_DENSIT = ONE/(ONE+EXP((R-RA)/PDIF)) | |
10733 | ENDIF | |
10734 | ||
10735 | RETURN | |
10736 | END | |
10737 | ||
10738 | *$ CREATE DT_RNCLUS.FOR | |
10739 | *COPY DT_RNCLUS | |
10740 | * | |
10741 | *===rnclus=============================================================* | |
10742 | * | |
10743 | DOUBLE PRECISION FUNCTION DT_RNCLUS(N) | |
10744 | ||
10745 | ************************************************************************ | |
10746 | * Nuclear radius for nucleus with mass number N. * | |
10747 | * This version dated 26.9.00 is written by S. Roesler * | |
10748 | ************************************************************************ | |
10749 | ||
10750 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
10751 | SAVE | |
10752 | ||
10753 | PARAMETER (ONE=1.0D0,THREE=3.0D0,ONETHI=ONE/THREE) | |
10754 | ||
10755 | * nucleon radius | |
10756 | PARAMETER (RNUCLE = 1.12D0) | |
10757 | ||
10758 | * nuclear radii for selected nuclei | |
10759 | DIMENSION RADNUC(18) | |
10760 | DATA RADNUC / 8*0.0D0,2.52D0,2.45D0,2.37D0,2.45D0,2.44D0,2.55D0, | |
10761 | & 2.58D0,2.71D0,2.66D0,2.71D0/ | |
10762 | ||
10763 | IF (N.LE.18) THEN | |
10764 | IF (RADNUC(N).GT.0.0D0) THEN | |
10765 | DT_RNCLUS = RADNUC(N) | |
10766 | ELSE | |
10767 | DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI | |
10768 | ENDIF | |
10769 | ELSE | |
10770 | DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI | |
10771 | ENDIF | |
10772 | ||
10773 | RETURN | |
10774 | END | |
10775 | ||
10776 | *$ CREATE DT_DENTST.FOR | |
10777 | *COPY DT_DENTST | |
10778 | * | |
10779 | *===dentst=============================================================* | |
10780 | * | |
10781 | C PROGRAM DT_DENTST | |
10782 | SUBROUTINE DT_DENTST | |
10783 | ||
10784 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
10785 | SAVE | |
10786 | ||
10787 | OPEN(40,FILE='dentst.out',STATUS='UNKNOWN') | |
10788 | OPEN(41,FILE='denmax.out',STATUS='UNKNOWN') | |
10789 | ||
10790 | RMIN = 0.0D0 | |
10791 | RMAX = 8.0D0 | |
10792 | NBINS = 500.0D0 | |
10793 | DR = (RMAX-RMIN)/DBLE(NBINS) | |
10794 | DO 1 IA=5,18 | |
10795 | FMAX = 0.0D0 | |
10796 | DO 2 IR=1,NBINS+1 | |
10797 | R = RMIN+DBLE(IR-1)*DR | |
10798 | F = DT_DENSIT(IA,R,R) | |
10799 | IF (F.GT.FMAX) FMAX = F | |
10800 | WRITE(40,'(1X,I3,2E15.5)') IA,R,F | |
10801 | 2 CONTINUE | |
10802 | WRITE(41,'(1X,I3,E15.5)') IA,FMAX | |
10803 | 1 CONTINUE | |
10804 | ||
10805 | CLOSE(40) | |
10806 | CLOSE(41) | |
10807 | ||
10808 | END | |
10809 | ||
10810 | *$ CREATE DT_SHMAKI.FOR | |
10811 | *COPY DT_SHMAKI | |
10812 | * | |
10813 | *===shmaki=============================================================* | |
10814 | * | |
10815 | SUBROUTINE DT_SHMAKI(NA,NCA,NB,NCB,IJP,PPN,MODE) | |
10816 | ||
10817 | ************************************************************************ | |
10818 | * Initialisation of Glauber formalism. This subroutine has to be * | |
10819 | * called once (in case of target emulsions as often as many different * | |
10820 | * target nuclei are considered) before events are sampled. * | |
10821 | * NA / NCA mass number/charge of projectile nucleus * | |
10822 | * NB / NCB mass number/charge of target nucleus * | |
10823 | * IJP identity of projectile (hadrons/leptons/photons) * | |
10824 | * PPN projectile momentum (for projectile nuclei: * | |
10825 | * momentum per nucleon) in target rest system * | |
10826 | * MODE = 0 Glauber formalism invoked * | |
10827 | * = 1 fitted results are loaded from data-file * | |
10828 | * = 99 NTARG is forced to be 1 * | |
10829 | * (used in connection with GLAUBERI-card only) * | |
10830 | * This version dated 22.03.96 is based on the original SHMAKI-routine * | |
10831 | * and revised by S. Roesler. * | |
10832 | ************************************************************************ | |
10833 | ||
10834 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
10835 | SAVE | |
10836 | ||
10837 | PARAMETER ( LINP = 10 , | |
10838 | & LOUT = 6 , | |
10839 | & LDAT = 9 ) | |
10840 | ||
10841 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0, | |
10842 | & THREE=3.0D0) | |
10843 | ||
10844 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
10845 | ||
10846 | * Glauber formalism: parameters | |
10847 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), | |
10848 | & BMAX(NCOMPX),BSTEP(NCOMPX), | |
10849 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), | |
10850 | & NSITEB,NSTATB | |
10851 | ||
10852 | * Lorentz-parameters of the current interaction | |
10853 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
10854 | & UMO,PPCM,EPROJ,PPROJ | |
10855 | ||
10856 | * properties of photon/lepton projectiles | |
10857 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC | |
10858 | ||
10859 | * kinematical cuts for lepton-nucleus interactions | |
10860 | COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX, | |
10861 | & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI | |
10862 | ||
10863 | * Glauber formalism: cross sections | |
10864 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
10865 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
10866 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
10867 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
10868 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
10869 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
10870 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
10871 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
10872 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
10873 | & BSLOPE,NEBINI,NQBINI | |
10874 | ||
10875 | * cuts for variable energy runs | |
10876 | COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI | |
10877 | ||
10878 | * nucleon-nucleon event-generator | |
10879 | CHARACTER*8 CMODEL | |
10880 | LOGICAL LPHOIN | |
10881 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
10882 | ||
10883 | * Glauber formalism: flags and parameters for statistics | |
10884 | LOGICAL LPROD | |
10885 | CHARACTER*8 CGLB | |
10886 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD | |
10887 | ||
10888 | DATA NTARG,ICOUT,IVEOUT /0,0,0/ | |
10889 | ||
10890 | C CALL DT_HISHAD | |
10891 | C STOP | |
10892 | ||
10893 | NTARG = NTARG+1 | |
10894 | IF (MODE.EQ.99) NTARG = 1 | |
10895 | NIDX = -NTARG | |
10896 | IF (MODE.EQ.-1) NIDX = NTARG | |
10897 | ||
10898 | IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) ICOUT = ICOUT+1 | |
10899 | IF (ICOUT.EQ.1) WRITE(LOUT,1000) | |
10900 | 1000 FORMAT(//,1X,'SHMAKI: Glauber formalism (Shmakov et. al) -', | |
10901 | & ' initialization',/,12X,'--------------------------', | |
10902 | & '-------------------------',/) | |
10903 | ||
10904 | IF (MODE.EQ.2) THEN | |
10905 | CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX) | |
10906 | CALL DT_SHFAST(MODE,PPN,IBACK) | |
10907 | STOP ' Glauber pre-initialization done' | |
10908 | ENDIF | |
10909 | IF (MODE.EQ.1) THEN | |
10910 | CALL DT_PROFBI(NA,NB,PPN,NTARG) | |
10911 | ELSE | |
10912 | IBACK = 1 | |
10913 | IF (MODE.EQ.3) CALL DT_SHFAST(MODE,PPN,IBACK) | |
10914 | IF (IBACK.EQ.1) THEN | |
10915 | * lepton-nucleus (variable energy runs) | |
10916 | IF ((IJP.EQ. 3).OR.(IJP.EQ. 4).OR. | |
10917 | & (IJP.EQ.10).OR.(IJP.EQ.11)) THEN | |
10918 | IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) | |
10919 | & WRITE(LOUT,1002) NB,NCB | |
10920 | 1002 FORMAT(1X,'variable energy run: projectile-id: 7', | |
10921 | & ' target A/Z: ',I3,' /',I3,/,/,8X, | |
10922 | & 'E_cm (GeV) Q^2 (GeV^2)', | |
10923 | & ' Sigma_tot (mb) Sigma_in (mb)',/,7X, | |
10924 | & '--------------------------------', | |
10925 | & '------------------------------') | |
10926 | AECMLO = LOG10(MIN(UMO,ECMLI)) | |
10927 | AECMHI = LOG10(MIN(UMO,ECMHI)) | |
10928 | IESTEP = NEB-1 | |
10929 | DAECM = (AECMHI-AECMLO)/DBLE(IESTEP) | |
10930 | IF (AECMLO.EQ.AECMHI) IESTEP = 0 | |
10931 | DO 1 I=1,IESTEP+1 | |
10932 | ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM) | |
10933 | IF (Q2HI.GT.0.1D0) THEN | |
10934 | IF (Q2LI.LT.0.01D0) THEN | |
10935 | CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX) | |
10936 | IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) | |
10937 | & WRITE(LOUT,1003) | |
10938 | & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG) | |
10939 | Q2LI = 0.01D0 | |
10940 | IBIN = 2 | |
10941 | ELSE | |
10942 | IBIN = 1 | |
10943 | ENDIF | |
10944 | IQSTEP = NQB-IBIN | |
10945 | AQ2LO = LOG10(Q2LI) | |
10946 | AQ2HI = LOG10(Q2HI) | |
10947 | DAQ2 = (AQ2HI-AQ2LO)/MAX(DBLE(IQSTEP),ONE) | |
10948 | DO 2 J=IBIN,IQSTEP+IBIN | |
10949 | Q2 = 10.0D0**(AQ2LO+DBLE(J-IBIN)*DAQ2) | |
10950 | CALL DT_XSGLAU(NA,NB,7,ZERO,Q2,ECM,I,J,NIDX) | |
10951 | IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) | |
10952 | & WRITE(LOUT,1003) ECMNN(I), | |
10953 | & Q2G(J),XSTOT(I,J,NTARG),XSPRO(I,J,NTARG) | |
10954 | 2 CONTINUE | |
10955 | ELSE | |
10956 | CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX) | |
10957 | IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) | |
10958 | & WRITE(LOUT,1003) | |
10959 | & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG) | |
10960 | ENDIF | |
10961 | 1003 FORMAT(9X,F6.1,9X,F6.2,8X,F8.3,11X,F8.3) | |
10962 | 1 CONTINUE | |
10963 | IVEOUT = 1 | |
10964 | ELSE | |
10965 | * hadron/photon/nucleus-nucleus | |
10966 | IF ((ABS(VAREHI).GT.ZERO).AND. | |
10967 | & (ABS(VAREHI).GT.ABS(VARELO))) THEN | |
10968 | IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) THEN | |
10969 | WRITE(LOUT,1004) NA,NB,NCB | |
10970 | 1004 FORMAT(1X,'variable energy run: projectile-id:', | |
10971 | & I3,' target A/Z: ',I3,' /',I3,/) | |
10972 | WRITE(LOUT,1005) | |
10973 | 1005 FORMAT(' E_cm (GeV) E_Lab (GeV) sig_tot^pp (mb)' | |
10974 | & ,' Sigma_tot (mb) Sigma_prod (mb)',/, | |
10975 | & ' -------------------------------------', | |
10976 | & '--------------------------------------') | |
10977 | ENDIF | |
10978 | AECMLO = LOG10(VARCLO) | |
10979 | AECMHI = LOG10(VARCHI) | |
10980 | IESTEP = NEB-1 | |
10981 | DAECM = (AECMHI-AECMLO)/DBLE(IESTEP) | |
10982 | IF (AECMLO.EQ.AECMHI) IESTEP = 0 | |
10983 | DO 3 I=1,IESTEP+1 | |
10984 | ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM) | |
10985 | AMP = 0.938D0 | |
10986 | AMT = 0.938D0 | |
10987 | AMP2 = AMP**2 | |
10988 | AMT2 = AMT**2 | |
10989 | ELAB = (ECM**2-AMP2-AMT2)/(TWO*AMT) | |
10990 | PLAB = SQRT((ELAB+AMP)*(ELAB-AMP)) | |
10991 | CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,ECM,I,1,NIDX) | |
10992 | IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) | |
10993 | & WRITE(LOUT,1006) | |
10994 | & ECM,PLAB,SIGSH,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG) | |
10995 | 1006 FORMAT(1X,F9.1,1X,E11.3,1X,F12.2,8X,F10.3,8X,F8.3) | |
10996 | 3 CONTINUE | |
10997 | IVEOUT = 1 | |
10998 | ELSE | |
10999 | CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX) | |
11000 | ENDIF | |
11001 | ENDIF | |
11002 | ENDIF | |
11003 | ENDIF | |
11004 | ||
11005 | IF ((ICOUT.LT.15).AND.(IVEOUT.EQ.0).AND.(MCGENE.NE.4).AND. | |
11006 | & (IOGLB.NE.100)) THEN | |
11007 | WRITE(LOUT,1001) NA,NCA,NB,NCB,ECMNN(1),SIGSH*10.0D0,ROSH, | |
11008 | & BSLOPE,NSITEB,NSTATB,XSPRO(1,1,NTARG) | |
11009 | 1001 FORMAT(38X,'projectile', | |
11010 | & ' target',/,1X,'Mass number / charge', | |
11011 | & 17X,I3,' /',I3,6X,I3,' /',I3,/,/,1X, | |
11012 | & 'Nucleon-nucleon c.m. energy',9X,F10.2,' GeV',/,/,1X, | |
11013 | & 'Parameters of elastic scattering amplitude:',/,5X, | |
11014 | & 'sigma =',F7.2,' mb',6X,'rho = ',F9.4,6X,'slope = ', | |
11015 | & F4.1,' GeV^-2',/,/,1X,'Number of b-steps',4X,I3,8X, | |
11016 | & 'statistics at each b-step',4X,I5,/,/,1X, | |
11017 | & 'Prod. cross section ',5X,F10.4,' mb',/) | |
11018 | ENDIF | |
11019 | ||
11020 | RETURN | |
11021 | END | |
11022 | ||
11023 | *$ CREATE DT_PROFBI.FOR | |
11024 | *COPY DT_PROFBI | |
11025 | * | |
11026 | *===profbi=============================================================* | |
11027 | * | |
11028 | SUBROUTINE DT_PROFBI(NA,NB,PPN,NTARG) | |
11029 | ||
11030 | ************************************************************************ | |
11031 | * Integral over profile function (to be used for impact-parameter * | |
11032 | * sampling during event generation). * | |
11033 | * Fitted results are used. * | |
11034 | * NA / NB mass numbers of proj./target nuclei * | |
11035 | * PPN projectile momentum (for projectile nuclei: * | |
11036 | * momentum per nucleon) in target rest system * | |
11037 | * NTARG index of target material (i.e. kind of nucleus) * | |
11038 | * This version dated 31.05.95 is revised by S. Roesler * | |
11039 | ************************************************************************ | |
11040 | ||
11041 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
11042 | SAVE | |
11043 | ||
11044 | PARAMETER ( LINP = 10 , | |
11045 | & LOUT = 6 , | |
11046 | & LDAT = 9 ) | |
11047 | ||
11048 | SAVE | |
11049 | ||
11050 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0) | |
11051 | ||
11052 | LOGICAL LSTART | |
11053 | CHARACTER CNAME*80 | |
11054 | ||
11055 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
11056 | ||
11057 | * Glauber formalism: parameters | |
11058 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), | |
11059 | & BMAX(NCOMPX),BSTEP(NCOMPX), | |
11060 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), | |
11061 | & NSITEB,NSTATB | |
11062 | ||
11063 | * Glauber formalism: cross sections | |
11064 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
11065 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
11066 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
11067 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
11068 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
11069 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
11070 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
11071 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
11072 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
11073 | & BSLOPE,NEBINI,NQBINI | |
11074 | ||
11075 | PARAMETER (NGLMAX=8000) | |
11076 | DIMENSION NGLIT(NGLMAX),NGLIP(NGLMAX),GLAPPN(NGLMAX), | |
11077 | & GLASIG(NGLMAX),GLAFIT(5,NGLMAX) | |
11078 | ||
11079 | DATA LSTART /.TRUE./ | |
11080 | ||
11081 | IF (LSTART) THEN | |
11082 | * read fit-parameters from file | |
11083 | OPEN(47,FILE='inpdata/glpara.dat',STATUS='UNKNOWN') | |
11084 | I = 0 | |
11085 | 1 CONTINUE | |
11086 | READ(47,'(A80)') CNAME | |
11087 | IF (CNAME.EQ.'STOP') GOTO 2 | |
11088 | I = I+1 | |
11089 | READ(CNAME,*) NGLIP(I),NGLIT(I),GLAPPN(I),GLASIG(I), | |
11090 | & GLAFIT(1,I),GLAFIT(2,I),GLAFIT(3,I), | |
11091 | & GLAFIT(4,I),GLAFIT(5,I) | |
11092 | IF (I+1.GT.NGLMAX) THEN | |
11093 | WRITE(LOUT,1000) | |
11094 | 1000 FORMAT(1X,'PROFBI: warning! array size exceeded - ', | |
11095 | & 'program stopped') | |
11096 | STOP | |
11097 | ENDIF | |
11098 | GOTO 1 | |
11099 | 2 CONTINUE | |
11100 | NGLPAR = I | |
11101 | LSTART = .FALSE. | |
11102 | ENDIF | |
11103 | ||
11104 | NNA = NA | |
11105 | NNB = NB | |
11106 | IF (NA.GT.NB) THEN | |
11107 | NNA = NB | |
11108 | NNB = NA | |
11109 | ENDIF | |
11110 | IDXGLA = 0 | |
11111 | DO 3 J=1,NGLPAR | |
11112 | IF ((NNB.LT.NGLIT(J)).OR.(J.EQ.NGLPAR)) THEN | |
11113 | IF (NNB.NE.NGLIT(J-1)) NNB = NGLIT(J-1) | |
11114 | DO 4 K=1,J-1 | |
11115 | IPOINT = J-K | |
11116 | IF (J.EQ.NGLPAR) IPOINT = J+1-K | |
11117 | IF ((NNA.GT.NGLIP(IPOINT)).OR. | |
11118 | & (NNB.NE.NGLIT(IPOINT)).OR.(IPOINT.EQ.1)) THEN | |
11119 | IF (IPOINT.EQ.1) IPOINT = 0 | |
11120 | NATMP = NGLIP(IPOINT+1) | |
11121 | IF (PPN.LT.GLAPPN(IPOINT+1)) THEN | |
11122 | IDXGLA = IPOINT+1 | |
11123 | GOTO 6 | |
11124 | ELSE | |
11125 | J1BEG = IPOINT+1 | |
11126 | J1END = J | |
11127 | C IF (J.EQ.NGLPAR) THEN | |
11128 | C J1BEG = IPOINT | |
11129 | C J1END = J | |
11130 | C ENDIF | |
11131 | DO 5 J1=J1BEG,J1END | |
11132 | IF (NGLIP(J1).EQ.NATMP) THEN | |
11133 | IF (PPN.LT.GLAPPN(J1)) THEN | |
11134 | IDXGLA = J1 | |
11135 | GOTO 6 | |
11136 | ENDIF | |
11137 | ELSE | |
11138 | IDXGLA = J1-1 | |
11139 | GOTO 6 | |
11140 | ENDIF | |
11141 | 5 CONTINUE | |
11142 | IF ((J.EQ.NGLPAR).AND.(PPN.GT.GLAPPN(NGLPAR))) | |
11143 | & IDXGLA = NGLPAR | |
11144 | ENDIF | |
11145 | ENDIF | |
11146 | 4 CONTINUE | |
11147 | ENDIF | |
11148 | 3 CONTINUE | |
11149 | ||
11150 | 6 CONTINUE | |
11151 | IF (IDXGLA.EQ.0) THEN | |
11152 | WRITE(LOUT,1001) NNA,NNB,PPN | |
11153 | 1001 FORMAT(1X,'PROFBI: configuration (NA,NB,PPN = ', | |
11154 | & 2I4,F6.0,') not found ') | |
11155 | STOP | |
11156 | ENDIF | |
11157 | ||
11158 | * no interpolation yet available | |
11159 | XSPRO(1,1,NTARG) = GLASIG(IDXGLA) | |
11160 | ||
11161 | BSITE(1,1,NTARG,1) = ZERO | |
11162 | DO 10 I=2,NSITEB | |
11163 | XX = DBLE(I) | |
11164 | POLY = GLAFIT(1,IDXGLA)+GLAFIT(2,IDXGLA)*XX+ | |
11165 | & GLAFIT(3,IDXGLA)*XX**2+GLAFIT(4,IDXGLA)*XX**3+ | |
11166 | & GLAFIT(5,IDXGLA)*XX**4 | |
11167 | IF (ABS(POLY).GT.35.0D0) POLY = SIGN(35.0D0,POLY) | |
11168 | BSITE(1,1,NTARG,I) = (1.0D0-EXP(-POLY)) | |
11169 | IF (BSITE(1,1,NTARG,I).LT.ZERO) BSITE(1,1,NTARG,I) = ZERO | |
11170 | 10 CONTINUE | |
11171 | ||
11172 | RETURN | |
11173 | END | |
11174 | ||
11175 | *$ CREATE DT_GLAUBE.FOR | |
11176 | *COPY DT_GLAUBE | |
11177 | * | |
11178 | *===glaube=============================================================* | |
11179 | * | |
11180 | SUBROUTINE DT_GLAUBE(NA,NB,IJPROJ,B,INTT,INTA,INTB,JS,JT,NIDX) | |
11181 | ||
11182 | ************************************************************************ | |
11183 | * Calculation of configuartion of interacting nucleons for one event. * | |
11184 | * NB / NB mass numbers of proj./target nuclei (input) * | |
11185 | * B impact parameter (output) * | |
11186 | * INTT total number of wounded nucleons " * | |
11187 | * INTA / INTB number of wounded nucleons in proj. / target " * | |
11188 | * JS / JT(i) number of collisions proj. / target nucleon i is * | |
11189 | * involved (output) * | |
11190 | * NIDX index of projectile/target material (input) * | |
11191 | * = -2 call within FLUKA transport calculation * | |
11192 | * This is an update of the original routine SHMAKO by J.Ranft/HJM * | |
11193 | * This version dated 22.03.96 is revised by S. Roesler * | |
11194 | * * | |
11195 | * Last change 27.12.2006 by S. Roesler. * | |
11196 | ************************************************************************ | |
11197 | ||
11198 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
11199 | SAVE | |
11200 | ||
11201 | PARAMETER ( LINP = 10 , | |
11202 | & LOUT = 6 , | |
11203 | & LDAT = 9 ) | |
11204 | ||
11205 | PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14, | |
11206 | & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0) | |
11207 | ||
11208 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
11209 | ||
11210 | PARAMETER ( MAXNCL = 260, | |
11211 | ||
11212 | & MAXVQU = MAXNCL, | |
11213 | & MAXSQU = 20*MAXVQU, | |
11214 | & MAXINT = MAXVQU+MAXSQU) | |
11215 | ||
11216 | * Glauber formalism: parameters | |
11217 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), | |
11218 | & BMAX(NCOMPX),BSTEP(NCOMPX), | |
11219 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), | |
11220 | & NSITEB,NSTATB | |
11221 | ||
11222 | * Glauber formalism: cross sections | |
11223 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
11224 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
11225 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
11226 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
11227 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
11228 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
11229 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
11230 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
11231 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
11232 | & BSLOPE,NEBINI,NQBINI | |
11233 | ||
11234 | * Lorentz-parameters of the current interaction | |
11235 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
11236 | & UMO,PPCM,EPROJ,PPROJ | |
11237 | ||
11238 | * properties of photon/lepton projectiles | |
11239 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC | |
11240 | ||
11241 | * Glauber formalism: collision properties | |
11242 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, | |
11243 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC | |
11244 | ||
11245 | * Glauber formalism: flags and parameters for statistics | |
11246 | LOGICAL LPROD | |
11247 | CHARACTER*8 CGLB | |
11248 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD | |
11249 | ||
11250 | DIMENSION JS(MAXNCL),JT(MAXNCL) | |
11251 | ||
11252 | NTARG = ABS(NIDX) | |
11253 | ||
11254 | * get actual energy from /DTLTRA/ | |
11255 | ECMNOW = UMO | |
11256 | Q2 = VIRT | |
11257 | * | |
11258 | * new patch for pre-initialized variable projectile/target/energy runs, | |
11259 | * bypassed for use within FLUKA (Nidx=-2) | |
11260 | IF (IOGLB.EQ.100) THEN | |
11261 | IF (NIDX.NE.-2) CALL DT_GLBSET(IJPROJ,NA,NB,EPROJ,1) | |
11262 | * | |
11263 | * variable energy run, interpolate profile function | |
11264 | ELSE | |
11265 | I1 = 1 | |
11266 | I2 = 1 | |
11267 | RATE = ONE | |
11268 | IF (NEBINI.GT.1) THEN | |
11269 | IF (ECMNOW.GE.ECMNN(NEBINI)) THEN | |
11270 | I1 = NEBINI | |
11271 | I2 = NEBINI | |
11272 | RATE = ONE | |
11273 | ELSEIF (ECMNOW.GT.ECMNN(1)) THEN | |
11274 | DO 1 I=2,NEBINI | |
11275 | IF (ECMNOW.LT.ECMNN(I)) THEN | |
11276 | I1 = I-1 | |
11277 | I2 = I | |
11278 | RATE = (ECMNOW-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1)) | |
11279 | GOTO 2 | |
11280 | ENDIF | |
11281 | 1 CONTINUE | |
11282 | 2 CONTINUE | |
11283 | ENDIF | |
11284 | ENDIF | |
11285 | J1 = 1 | |
11286 | J2 = 1 | |
11287 | RATQ = ONE | |
11288 | IF (NQBINI.GT.1) THEN | |
11289 | IF (Q2.GE.Q2G(NQBINI)) THEN | |
11290 | J1 = NQBINI | |
11291 | J2 = NQBINI | |
11292 | RATQ = ONE | |
11293 | ELSEIF (Q2.GT.Q2G(1)) THEN | |
11294 | DO 3 I=2,NQBINI | |
11295 | IF (Q2.LT.Q2G(I)) THEN | |
11296 | J1 = I-1 | |
11297 | J2 = I | |
11298 | RATQ = LOG10( Q2/MAX(Q2G(J1),TINY14))/ | |
11299 | & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14)) | |
11300 | C RATQ = (Q2-Q2G(J1))/(Q2G(J2)-Q2G(J1)) | |
11301 | GOTO 4 | |
11302 | ENDIF | |
11303 | 3 CONTINUE | |
11304 | 4 CONTINUE | |
11305 | ENDIF | |
11306 | ENDIF | |
11307 | ||
11308 | DO 5 I=1,KSITEB | |
11309 | BSITE(0,1,NTARG,I) = BSITE(I1,J1,NTARG,I)+ | |
11310 | & RATE*(BSITE(I2,J1,NTARG,I)-BSITE(I1,J1,NTARG,I))+ | |
11311 | & RATQ*(BSITE(I1,J2,NTARG,I)-BSITE(I1,J1,NTARG,I))+ | |
11312 | & RATE*RATQ*(BSITE(I2,J2,NTARG,I)-BSITE(I1,J2,NTARG,I)+ | |
11313 | & BSITE(I1,J1,NTARG,I)-BSITE(I2,J1,NTARG,I)) | |
11314 | 5 CONTINUE | |
11315 | ENDIF | |
11316 | ||
11317 | CALL DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,INTT,INTA,INTB,IDIREC,NIDX) | |
11318 | IF (NIDX.LE.-1) THEN | |
11319 | RPROJ = RASH(1) | |
11320 | RTARG = RBSH(NTARG) | |
11321 | ELSE | |
11322 | RPROJ = RASH(NTARG) | |
11323 | RTARG = RBSH(1) | |
11324 | ENDIF | |
11325 | ||
11326 | RETURN | |
11327 | END | |
11328 | ||
11329 | *$ CREATE DT_DIAGR.FOR | |
11330 | *COPY DT_DIAGR | |
11331 | * | |
11332 | *===diagr==============================================================* | |
11333 | * | |
11334 | SUBROUTINE DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,JNT,INTA,INTB,IDIREC, | |
11335 | & NIDX) | |
11336 | ||
11337 | ************************************************************************ | |
11338 | * Based on the original version by Shmakov et al. * | |
11339 | * This version dated 21.04.95 is revised by S. Roesler * | |
11340 | ************************************************************************ | |
11341 | ||
11342 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
11343 | SAVE | |
11344 | ||
11345 | PARAMETER ( LINP = 10 , | |
11346 | & LOUT = 6 , | |
11347 | & LDAT = 9 ) | |
11348 | ||
11349 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) | |
11350 | PARAMETER (TWOPI = 6.283185307179586454D+00, | |
11351 | & PI = TWOPI/TWO, | |
11352 | & GEV2MB = 0.38938D0, | |
11353 | & GEV2FM = 0.1972D0, | |
11354 | & ALPHEM = ONE/137.0D0, | |
11355 | * proton mass | |
11356 | & AMP = 0.938D0, | |
11357 | & AMP2 = AMP**2, | |
11358 | * rho0 mass | |
11359 | & AMRHO0 = 0.77D0) | |
11360 | ||
11361 | COMPLEX*16 C,CA,CI | |
11362 | ||
11363 | PARAMETER ( MAXNCL = 260, | |
11364 | ||
11365 | & MAXVQU = MAXNCL, | |
11366 | & MAXSQU = 20*MAXVQU, | |
11367 | & MAXINT = MAXVQU+MAXSQU) | |
11368 | ||
11369 | * particle properties (BAMJET index convention) | |
11370 | CHARACTER*8 ANAME | |
11371 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
11372 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
11373 | ||
11374 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
11375 | ||
11376 | * emulsion treatment | |
11377 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
11378 | & NCOMPO,IEMUL | |
11379 | ||
11380 | * Glauber formalism: parameters | |
11381 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), | |
11382 | & BMAX(NCOMPX),BSTEP(NCOMPX), | |
11383 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), | |
11384 | & NSITEB,NSTATB | |
11385 | ||
11386 | * Glauber formalism: cross sections | |
11387 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
11388 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
11389 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
11390 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
11391 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
11392 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
11393 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
11394 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
11395 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
11396 | & BSLOPE,NEBINI,NQBINI | |
11397 | ||
11398 | * VDM parameter for photon-nucleus interactions | |
11399 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
11400 | ||
11401 | * nucleon-nucleon event-generator | |
11402 | CHARACTER*8 CMODEL | |
11403 | LOGICAL LPHOIN | |
11404 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
11405 | **PHOJET105a | |
11406 | C COMMON /CUTOFF/ PTCUT(4),CUTMU(4),FPS(4),FPH(4),PSOMIN,XSOMIN | |
11407 | **PHOJET112 | |
11408 | ||
11409 | C obsolete cut-off information | |
11410 | DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN | |
11411 | COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN | |
11412 | ** | |
11413 | ||
11414 | * coordinates of nucleons | |
11415 | COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL) | |
11416 | ||
11417 | * interface between Glauber formalism and DPM | |
11418 | COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL), | |
11419 | & INTER1(MAXINT),INTER2(MAXINT) | |
11420 | ||
11421 | * statistics: Glauber-formalism | |
11422 | COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB | |
11423 | ||
11424 | * n-n cross section fluctuations | |
11425 | PARAMETER (NBINS = 1000) | |
11426 | COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT | |
11427 | ||
11428 | DIMENSION JS(MAXNCL),JT(MAXNCL), | |
11429 | & JS0(MAXNCL),JT0(MAXNCL,MAXNCL), | |
11430 | & JI1(MAXNCL,MAXNCL),JI2(MAXNCL,MAXNCL),JNT0(MAXNCL) | |
11431 | DIMENSION NWA(0:210),NWB(0:210) | |
11432 | ||
11433 | LOGICAL LFIRST | |
11434 | DATA LFIRST /.TRUE./ | |
11435 | ||
11436 | DATA NTARGO,ICNT /0,0/ | |
11437 | ||
11438 | NTARG = ABS(NIDX) | |
11439 | ||
11440 | IF (LFIRST) THEN | |
11441 | LFIRST = .FALSE. | |
11442 | IF (NCOMPO.EQ.0) THEN | |
11443 | NCALL = 0 | |
11444 | NWAMAX = NA | |
11445 | NWBMAX = NB | |
11446 | DO 17 I=0,210 | |
11447 | NWA(I) = 0 | |
11448 | NWB(I) = 0 | |
11449 | 17 CONTINUE | |
11450 | ENDIF | |
11451 | ENDIF | |
11452 | IF (NTARG.EQ.-1) THEN | |
11453 | IF (NCOMPO.EQ.0) THEN | |
11454 | WRITE(LOUT,*) ' DIAGR: distribution of wounded nucleons' | |
11455 | WRITE(LOUT,'(8X,A,3I7)') 'NCALL,NWAMAX,NWBMAX = ', | |
11456 | & NCALL,NWAMAX,NWBMAX | |
11457 | DO 18 I=1,MAX(NWAMAX,NWBMAX) | |
11458 | WRITE(LOUT,'(8X,2I7,E12.4,I7,E12.4)') | |
11459 | & I,NWA(I),DBLE(NWA(I))/DBLE(NCALL), | |
11460 | & NWB(I),DBLE(NWB(I))/DBLE(NCALL) | |
11461 | 18 CONTINUE | |
11462 | ENDIF | |
11463 | RETURN | |
11464 | ENDIF | |
11465 | ||
11466 | DCOH = 1.0D10 | |
11467 | IPNT = 0 | |
11468 | ||
11469 | SQ2 = Q2 | |
11470 | IF (SQ2.LE.ZERO) SQ2 = 0.0001D0 | |
11471 | S = ECMNOW**2 | |
11472 | X = SQ2/(S+SQ2-AMP2) | |
11473 | XNU = (S+SQ2-AMP2)/(TWO*AMP) | |
11474 | * photon projectiles: recalculate photon-nucleon amplitude | |
11475 | IF (IJPROJ.EQ.7) THEN | |
11476 | 15 CONTINUE | |
11477 | * VDM assumption: mass of V-meson | |
11478 | AMV2 = DT_SAM2(SQ2,ECMNOW) | |
11479 | AMV = SQRT(AMV2) | |
11480 | IF (AMV.GT.2.0D0*PTCUT(1)) GOTO 15 | |
11481 | * check for pointlike interaction | |
11482 | CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,1) | |
11483 | **sr 27.10. | |
11484 | C SIGSH = DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0 | |
11485 | SIGSH = (ONE-RPNT)*DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0 | |
11486 | ** | |
11487 | ROSH = 0.1D0 | |
11488 | BSLOPE = 2.0D0*(2.0D0+AMRHO0**2/(AMV2+SQ2) | |
11489 | & +0.25D0*LOG(S/(AMV2+SQ2))) | |
11490 | * coherence length | |
11491 | IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+SQ2)*GEV2FM | |
11492 | ELSEIF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN | |
11493 | IF (MCGENE.EQ.2) THEN | |
11494 | ZERO1 = ZERO | |
11495 | CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SDUM1,SDUM2,SDUM3, | |
11496 | & BSLOPE,0) | |
11497 | ELSE | |
11498 | BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S)) | |
11499 | ENDIF | |
11500 | IF (ECMNOW.LE.3.0D0) THEN | |
11501 | ROSH = -0.43D0 | |
11502 | ELSEIF ((ECMNOW.GT.3.0D0).AND.(ECMNOW.LE.50.D0)) THEN | |
11503 | ROSH = -0.63D0+0.175D0*LOG(ECMNOW) | |
11504 | ELSEIF (ECMNOW.GT.50.0D0) THEN | |
11505 | ROSH = 0.1D0 | |
11506 | ENDIF | |
11507 | ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP) | |
11508 | PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) ) | |
11509 | IF (MCGENE.EQ.2) THEN | |
11510 | ZERO1 = ZERO | |
11511 | CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SIGSH,SDUM2,SDUM3, | |
11512 | & BDUM,0) | |
11513 | SIGSH = SIGSH/10.0D0 | |
11514 | ELSE | |
11515 | C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0 | |
11516 | DUMZER = ZERO | |
11517 | CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL) | |
11518 | SIGSH = SIGSH/10.0D0 | |
11519 | ENDIF | |
11520 | ELSE | |
11521 | BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S)) | |
11522 | ROSH = 0.01D0 | |
11523 | ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP) | |
11524 | PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) ) | |
11525 | C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0 | |
11526 | DUMZER = ZERO | |
11527 | CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL) | |
11528 | SIGSH = SIGSH/10.0D0 | |
11529 | ENDIF | |
11530 | GSH = 10.0D0/(TWO*BSLOPE*GEV2MB) | |
11531 | GAM = GSH | |
11532 | RCA = GAM*SIGSH/TWOPI | |
11533 | FCA = -ROSH*RCA | |
11534 | CA = DCMPLX(RCA,FCA) | |
11535 | CI = DCMPLX(ONE,ZERO) | |
11536 | ||
11537 | 16 CONTINUE | |
11538 | * impact parameter | |
11539 | IF (MCGENE.NE.3) CALL DT_MODB(B,NIDX) | |
11540 | ||
11541 | NTRY = 0 | |
11542 | 3 CONTINUE | |
11543 | NTRY = NTRY+1 | |
11544 | * initializations | |
11545 | JNT = 0 | |
11546 | DO 1 I=1,NA | |
11547 | JS(I) = 0 | |
11548 | 1 CONTINUE | |
11549 | DO 2 I=1,NB | |
11550 | JT(I) = 0 | |
11551 | 2 CONTINUE | |
11552 | IF (IJPROJ.EQ.7) THEN | |
11553 | DO 8 I=1,MAXNCL | |
11554 | JS0(I) = 0 | |
11555 | JNT0(I)= 0 | |
11556 | DO 9 J=1,NB | |
11557 | JT0(I,J) = 0 | |
11558 | 9 CONTINUE | |
11559 | 8 CONTINUE | |
11560 | ENDIF | |
11561 | ||
11562 | * nucleon configuration | |
11563 | C IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,5).EQ.0)) THEN | |
11564 | IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,1).EQ.0)) THEN | |
11565 | C CALL DT_CONUCL(PKOO,NA,RASH,2) | |
11566 | C CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),1) | |
11567 | IF (NIDX.LE.-1) THEN | |
11568 | CALL DT_CONUCL(PKOO,NA,RASH(1),0) | |
11569 | CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),0) | |
11570 | ELSE | |
11571 | CALL DT_CONUCL(PKOO,NA,RASH(NTARG),0) | |
11572 | CALL DT_CONUCL(TKOO,NB,RBSH(1),0) | |
11573 | ENDIF | |
11574 | NTARGO = NTARG | |
11575 | ENDIF | |
11576 | ICNT = ICNT+1 | |
11577 | ||
11578 | * LEPTO: pick out one struck nucleon | |
11579 | IF (MCGENE.EQ.3) THEN | |
11580 | JNT = 1 | |
11581 | JS(1) = 1 | |
11582 | IDX = INT(DT_RNDM(X)*NB)+1 | |
11583 | JT(IDX) = 1 | |
11584 | B = ZERO | |
11585 | GOTO 19 | |
11586 | ENDIF | |
11587 | ||
11588 | DO 4 INA=1,NA | |
11589 | * cross section fluctuations | |
11590 | AFLUC = ONE | |
11591 | IF (IFLUCT.EQ.1) THEN | |
11592 | IFLUK = INT((DT_RNDM(X)+0.001D0)*1000.0D0) | |
11593 | AFLUC = FLUIXX(IFLUK) | |
11594 | ENDIF | |
11595 | KK1 = 1 | |
11596 | KINT = 1 | |
11597 | DO 5 INB=1,NB | |
11598 | * photon-projectile: check for supression by coherence length | |
11599 | IF (IJPROJ.EQ.7) THEN | |
11600 | IF (ABS(TKOO(3,INB)-TKOO(3,KK1)).GT.DCOH) THEN | |
11601 | KK1 = INB | |
11602 | KINT = KINT+1 | |
11603 | ENDIF | |
11604 | ENDIF | |
11605 | QQ1 = B+TKOO(1,INB)-PKOO(1,INA) | |
11606 | QQ2 = TKOO(2,INB)-PKOO(2,INA) | |
11607 | XY = GAM*(QQ1*QQ1+QQ2*QQ2) | |
11608 | IF (XY.LE.15.0D0) THEN | |
11609 | C = CI-CA*AFLUC*EXP(-XY) | |
11610 | AR = DBLE(C) | |
11611 | AI = DIMAG(C) | |
11612 | P = AR*AR+AI*AI | |
11613 | IF (DT_RNDM(XY).GE.P) THEN | |
11614 | JNT = JNT+1 | |
11615 | IF (IJPROJ.EQ.7) THEN | |
11616 | JNT0(KINT) = JNT0(KINT)+1 | |
11617 | IF (JNT0(KINT).GT.MAXNCL) THEN | |
11618 | WRITE(LOUT,1001) MAXNCL | |
11619 | 1001 FORMAT(1X, | |
11620 | & 'DIAGR: no. of requested interactions', | |
11621 | & ' exceeds array dimensions ',I4) | |
11622 | STOP | |
11623 | ENDIF | |
11624 | JS0(KINT) = JS0(KINT)+1 | |
11625 | JT0(KINT,INB) = JT0(KINT,INB)+1 | |
11626 | JI1(KINT,JNT0(KINT)) = INA | |
11627 | JI2(KINT,JNT0(KINT)) = INB | |
11628 | ELSE | |
11629 | IF (JNT.GT.MAXINT) THEN | |
11630 | WRITE(LOUT,1000) JNT, MAXINT | |
11631 | 1000 FORMAT(1X, | |
11632 | & 'DIAGR: no. of requested interactions (' | |
11633 | & ,I4,') exceeds array dimensions (',I4,')') | |
11634 | STOP | |
11635 | ENDIF | |
11636 | JS(INA) = JS(INA)+1 | |
11637 | JT(INB) = JT(INB)+1 | |
11638 | INTER1(JNT) = INA | |
11639 | INTER2(JNT) = INB | |
11640 | ENDIF | |
11641 | ENDIF | |
11642 | ENDIF | |
11643 | 5 CONTINUE | |
11644 | 4 CONTINUE | |
11645 | ||
11646 | IF (JNT.EQ.0) THEN | |
11647 | IF (NTRY.LT.500) THEN | |
11648 | GOTO 3 | |
11649 | ELSE | |
11650 | C WRITE(6,*) ' new impact parameter required (old= ',B,')' | |
11651 | GOTO 16 | |
11652 | ENDIF | |
11653 | ENDIF | |
11654 | ||
11655 | IDIREC = 0 | |
11656 | IF (IJPROJ.EQ.7) THEN | |
11657 | K = INT(ONE+DT_RNDM(X)*DBLE(KINT)) | |
11658 | 10 CONTINUE | |
11659 | IF (JNT0(K).EQ.0) THEN | |
11660 | K = K+1 | |
11661 | IF (K.GT.KINT) K = 1 | |
11662 | GOTO 10 | |
11663 | ENDIF | |
11664 | * supress Glauber-cascade by direct photon processes | |
11665 | CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,2) | |
11666 | IF (IPNT.GT.0) THEN | |
11667 | JNT = 1 | |
11668 | JS(1) = 1 | |
11669 | DO 11 INB=1,NB | |
11670 | JT(INB) = JT0(K,INB) | |
11671 | IF (JT(INB).GT.0) GOTO 12 | |
11672 | 11 CONTINUE | |
11673 | 12 CONTINUE | |
11674 | INTER1(1) = 1 | |
11675 | INTER2(1) = INB | |
11676 | IDIREC = IPNT | |
11677 | ELSE | |
11678 | JNT = JNT0(K) | |
11679 | JS(1) = JS0(K) | |
11680 | DO 13 INB=1,NB | |
11681 | JT(INB) = JT0(K,INB) | |
11682 | 13 CONTINUE | |
11683 | DO 14 I=1,JNT | |
11684 | INTER1(I) = JI1(K,I) | |
11685 | INTER2(I) = JI2(K,I) | |
11686 | 14 CONTINUE | |
11687 | ENDIF | |
11688 | ENDIF | |
11689 | ||
11690 | 19 CONTINUE | |
11691 | INTA = 0 | |
11692 | INTB = 0 | |
11693 | DO 6 I=1,NA | |
11694 | IF (JS(I).NE.0) INTA=INTA+1 | |
11695 | 6 CONTINUE | |
11696 | DO 7 I=1,NB | |
11697 | IF (JT(I).NE.0) INTB=INTB+1 | |
11698 | 7 CONTINUE | |
11699 | ICWPG = INTA | |
11700 | ICWTG = INTB | |
11701 | ICIG = JNT | |
11702 | IPGLB = IPGLB+INTA | |
11703 | ITGLB = ITGLB+INTB | |
11704 | NGLB = NGLB+1 | |
11705 | ||
11706 | IF (NCOMPO.EQ.0) THEN | |
11707 | NCALL = NCALL+1 | |
11708 | NWA(INTA) = NWA(INTA)+1 | |
11709 | NWB(INTB) = NWB(INTB)+1 | |
11710 | ENDIF | |
11711 | ||
11712 | RETURN | |
11713 | END | |
11714 | ||
11715 | *$ CREATE DT_MODB.FOR | |
11716 | *COPY DT_MODB | |
11717 | * | |
11718 | *===modb===============================================================* | |
11719 | * | |
11720 | SUBROUTINE DT_MODB(B,NIDX) | |
11721 | ||
11722 | ************************************************************************ | |
11723 | * Sampling of impact parameter of collision. * | |
11724 | * B impact parameter (output) * | |
11725 | * NIDX index of projectile/target material (input)* | |
11726 | * Based on the original version by Shmakov et al. * | |
11727 | * This version dated 21.04.95 is revised by S. Roesler * | |
11728 | * * | |
11729 | * Last change 27.12.2006 by S. Roesler. * | |
11730 | ************************************************************************ | |
11731 | ||
11732 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
11733 | SAVE | |
11734 | ||
11735 | PARAMETER ( LINP = 10 , | |
11736 | & LOUT = 6 , | |
11737 | & LDAT = 9 ) | |
11738 | ||
11739 | PARAMETER (ZERO=0.0D0,TINY15=1.0D-15,ONE=1.0D0,TWO=2.0D0) | |
11740 | ||
11741 | LOGICAL LEFT,LFIRST | |
11742 | ||
11743 | * central particle production, impact parameter biasing | |
11744 | COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR | |
11745 | ||
11746 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
11747 | ||
11748 | * Glauber formalism: parameters | |
11749 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), | |
11750 | & BMAX(NCOMPX),BSTEP(NCOMPX), | |
11751 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), | |
11752 | & NSITEB,NSTATB | |
11753 | ||
11754 | * Glauber formalism: cross sections | |
11755 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
11756 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
11757 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
11758 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
11759 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
11760 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
11761 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
11762 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
11763 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
11764 | & BSLOPE,NEBINI,NQBINI | |
11765 | ||
11766 | DATA LFIRST /.TRUE./ | |
11767 | ||
11768 | NTARG = ABS(NIDX) | |
11769 | IF (NIDX.LE.-1) THEN | |
11770 | RA = RASH(1) | |
11771 | RB = RBSH(NTARG) | |
11772 | ELSE | |
11773 | RA = RASH(NTARG) | |
11774 | RB = RBSH(1) | |
11775 | ENDIF | |
11776 | ||
11777 | IF (ICENTR.EQ.2) THEN | |
11778 | IF (RA.EQ.RB) THEN | |
11779 | BB = DT_RNDM(B)*(0.3D0*RA)**2 | |
11780 | B = SQRT(BB) | |
11781 | ELSEIF(RA.LT.RB)THEN | |
11782 | BB = DT_RNDM(B)*1.4D0*(RB-RA)**2 | |
11783 | B = SQRT(BB) | |
11784 | ELSEIF(RA.GT.RB)THEN | |
11785 | BB = DT_RNDM(B)*1.4D0*(RA-RB)**2 | |
11786 | B = SQRT(BB) | |
11787 | ENDIF | |
11788 | ELSE | |
11789 | 9 CONTINUE | |
11790 | Y = DT_RNDM(BB) | |
11791 | I0 = 1 | |
11792 | I2 = NSITEB | |
11793 | 10 CONTINUE | |
11794 | I1 = (I0+I2)/2 | |
11795 | LEFT = ((BSITE(0,1,NTARG,I0)-Y) | |
11796 | & *(BSITE(0,1,NTARG,I1)-Y)).LT.ZERO | |
11797 | IF (LEFT) GOTO 20 | |
11798 | I0 = I1 | |
11799 | GOTO 30 | |
11800 | 20 CONTINUE | |
11801 | I2 = I1 | |
11802 | 30 CONTINUE | |
11803 | IF (I2-I0-2) 40,50,60 | |
11804 | 40 CONTINUE | |
11805 | I1 = I2+1 | |
11806 | IF (I1.GT.NSITEB) I1 = I0-1 | |
11807 | GOTO 70 | |
11808 | 50 CONTINUE | |
11809 | I1 = I0+1 | |
11810 | GOTO 70 | |
11811 | 60 CONTINUE | |
11812 | GOTO 10 | |
11813 | 70 CONTINUE | |
11814 | X0 = DBLE(I0-1)*BSTEP(NTARG) | |
11815 | X1 = DBLE(I1-1)*BSTEP(NTARG) | |
11816 | X2 = DBLE(I2-1)*BSTEP(NTARG) | |
11817 | Y0 = BSITE(0,1,NTARG,I0) | |
11818 | Y1 = BSITE(0,1,NTARG,I1) | |
11819 | Y2 = BSITE(0,1,NTARG,I2) | |
11820 | 80 CONTINUE | |
11821 | B = X0*(Y-Y1)*(Y-Y2)/((Y0-Y1)*(Y0-Y2)+TINY15)+ | |
11822 | & X1*(Y-Y0)*(Y-Y2)/((Y1-Y0)*(Y1-Y2)+TINY15)+ | |
11823 | & X2*(Y-Y0)*(Y-Y1)/((Y2-Y0)*(Y2-Y1)+TINY15) | |
11824 | **sr 5.4.98: shift B by half the bin width to be in agreement with BPROD | |
11825 | B = B+0.5D0*BSTEP(NTARG) | |
11826 | IF (B.LT.ZERO) B = X1 | |
11827 | IF (B.GT.BMAX(NTARG)) B = BMAX(NTARG) | |
11828 | IF (ICENTR.LT.0) THEN | |
11829 | IF (LFIRST) THEN | |
11830 | LFIRST = .FALSE. | |
11831 | IF (ICENTR.LE.-100) THEN | |
11832 | BIMIN = 0.0D0 | |
11833 | ELSE | |
11834 | XSFRAC = 0.0D0 | |
11835 | ENDIF | |
11836 | CALL DT_GETBXS(XSFRAC,BIMIN,BIMAX,NTARG) | |
11837 | WRITE(LOUT,1000) RASH(1),RBSH(NTARG),BMAX(NTARG), | |
11838 | & BIMIN,BIMAX,XSFRAC*100.0D0, | |
11839 | & XSFRAC*XSPRO(1,1,NTARG) | |
11840 | 10000 FORMAT(/,1X,'DT_MODB: Biasing in impact parameter', | |
11841 | & /,15X,'---------------------------'/,/,4X, | |
11842 | & 'average radii of proj / targ :',F10.3,' fm /', | |
11843 | & F7.3,' fm',/,4X,'corresp. b_max (4*(r_p+r_t)) :', | |
11844 | & F10.3,' fm',/,/,21X,'b_lo / b_hi :', | |
11845 | & F10.3,' fm /',F7.3,' fm',/,5X,'percentage of', | |
11846 | & ' cross section :',F10.3,' %',/,5X, | |
11847 | & 'corresponding cross section :',F10.3,' mb',/) | |
11848 | ENDIF | |
11849 | IF (ABS(BIMAX-BIMIN).LT.1.0D-3) THEN | |
11850 | B = BIMIN | |
11851 | ELSE | |
11852 | IF ((B.LT.BIMIN).OR.(B.GT.BIMAX)) GOTO 9 | |
11853 | ENDIF | |
11854 | ENDIF | |
11855 | ENDIF | |
11856 | ||
11857 | RETURN | |
11858 | END | |
11859 | ||
11860 | *$ CREATE DT_SHFAST.FOR | |
11861 | *COPY DT_SHFAST | |
11862 | * | |
11863 | *===shfast=============================================================* | |
11864 | * | |
11865 | SUBROUTINE DT_SHFAST(MODE,PPN,IBACK) | |
11866 | ||
11867 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
11868 | SAVE | |
11869 | ||
11870 | PARAMETER ( LINP = 10 , | |
11871 | & LOUT = 6 , | |
11872 | & LDAT = 9 ) | |
11873 | ||
11874 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY1=1.0D-1, | |
11875 | & ONE=1.0D0,TWO=2.0D0) | |
11876 | ||
11877 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
11878 | ||
11879 | * Glauber formalism: parameters | |
11880 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), | |
11881 | & BMAX(NCOMPX),BSTEP(NCOMPX), | |
11882 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), | |
11883 | & NSITEB,NSTATB | |
11884 | ||
11885 | * properties of interacting particles | |
11886 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
11887 | ||
11888 | * Glauber formalism: cross sections | |
11889 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
11890 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
11891 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
11892 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
11893 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
11894 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
11895 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
11896 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
11897 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
11898 | & BSLOPE,NEBINI,NQBINI | |
11899 | ||
11900 | IBACK = 0 | |
11901 | ||
11902 | IF (MODE.EQ.2) THEN | |
11903 | OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN') | |
11904 | WRITE(47,1000) IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG,PPN | |
11905 | 1000 FORMAT(1X,8I5,E15.5) | |
11906 | WRITE(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1) | |
11907 | 1001 FORMAT(1X,4E15.5) | |
11908 | WRITE(47,1002) SIGSH,ROSH,GSH | |
11909 | 1002 FORMAT(1X,3E15.5) | |
11910 | DO 10 I=1,100 | |
11911 | WRITE(47,'(1X,E15.5)') BSITE(1,1,1,I) | |
11912 | 10 CONTINUE | |
11913 | WRITE(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE | |
11914 | 1003 FORMAT(1X,2I10,3E15.5) | |
11915 | CLOSE(47) | |
11916 | ELSE | |
11917 | OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN') | |
11918 | READ(47,1000) JT,JTZ,JP,JPZ,JJPROJ,JBPROJ,JJTARG,JBTARG,PP | |
11919 | IF ((JT.EQ.IT).AND.(JTZ.EQ.ITZ).AND.(JP.EQ.IP).AND. | |
11920 | & (JPZ.EQ.IPZ).AND.(JJPROJ.EQ.IJPROJ).AND.(JBPROJ.EQ.IBPROJ) | |
11921 | & .AND.(JJTARG.EQ.IJTARG).AND.(JBTARG.EQ.IBTARG).AND. | |
11922 | & (ABS(PP-PPN).LT.(PPN*0.01D0))) THEN | |
11923 | READ(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1) | |
11924 | READ(47,1002) SIGSH,ROSH,GSH | |
11925 | DO 11 I=1,100 | |
11926 | READ(47,'(1X,E15.5)') BSITE(1,1,1,I) | |
11927 | 11 CONTINUE | |
11928 | READ(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE | |
11929 | ELSE | |
11930 | IBACK = 1 | |
11931 | ENDIF | |
11932 | CLOSE(47) | |
11933 | ENDIF | |
11934 | ||
11935 | RETURN | |
11936 | END | |
11937 | ||
11938 | *$ CREATE DT_POILIK.FOR | |
11939 | *COPY DT_POILIK | |
11940 | * | |
11941 | *===poilik=============================================================* | |
11942 | * | |
11943 | SUBROUTINE DT_POILIK(NB,NTARG,ECM,VIRT,IPNT,RPNT,MODE) | |
11944 | ||
11945 | IMPLICIT DOUBLE PRECISION(A-H,O-Z) | |
11946 | SAVE | |
11947 | ||
11948 | PARAMETER ( LINP = 10 , | |
11949 | & LOUT = 6 , | |
11950 | & LDAT = 9 ) | |
11951 | ||
11952 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.0D0) | |
11953 | PARAMETER (NE = 8) | |
11954 | ||
11955 | **PHOJET105a | |
11956 | C CHARACTER*8 MDLNA | |
11957 | C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100) | |
11958 | C PARAMETER (IEETAB=10) | |
11959 | C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX | |
11960 | **PHOJET110 | |
11961 | ||
11962 | C model switches and parameters | |
11963 | CHARACTER*8 MDLNA | |
11964 | INTEGER ISWMDL,IPAMDL | |
11965 | DOUBLE PRECISION PARMDL | |
11966 | COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400) | |
11967 | ||
11968 | C energy-interpolation table | |
11969 | INTEGER IEETA2 | |
11970 | PARAMETER ( IEETA2 = 20 ) | |
11971 | INTEGER ISIMAX | |
11972 | DOUBLE PRECISION SIGTAB,SIGECM | |
11973 | COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX | |
11974 | ** | |
11975 | ||
11976 | * VDM parameter for photon-nucleus interactions | |
11977 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
11978 | **sr 22.7.97 | |
11979 | ||
11980 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
11981 | ||
11982 | * Glauber formalism: cross sections | |
11983 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
11984 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
11985 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
11986 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
11987 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
11988 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
11989 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
11990 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
11991 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
11992 | & BSLOPE,NEBINI,NQBINI | |
11993 | ** | |
11994 | ||
11995 | DATA ECMOLD,Q2OLD /-1.0D0,-1.0D0/ | |
11996 | ||
11997 | IF ((ECM.EQ.ECMOLD).AND.(VIRT.EQ.Q2OLD)) GOTO 3 | |
11998 | ||
11999 | * load cross sections from interpolation table | |
12000 | IP = 1 | |
12001 | IF(ECM.LE.SIGECM(IP,1)) THEN | |
12002 | I1 = 1 | |
12003 | I2 = 1 | |
12004 | ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN | |
12005 | DO 50 I=2,ISIMAX | |
12006 | IF(ECM.LE.SIGECM(IP,I)) GOTO 200 | |
12007 | 50 CONTINUE | |
12008 | 200 CONTINUE | |
12009 | I1 = I-1 | |
12010 | I2 = I | |
12011 | ELSE | |
12012 | WRITE(LOUT,'(/1X,A,2E12.3)') | |
12013 | & 'POILIK:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX) | |
12014 | I1 = ISIMAX | |
12015 | I2 = ISIMAX | |
12016 | ENDIF | |
12017 | FAC2 = ZERO | |
12018 | IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1)) | |
12019 | & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1)) | |
12020 | FAC1 = ONE-FAC2 | |
12021 | ||
12022 | SIGANO = DT_SANO(ECM) | |
12023 | ||
12024 | * cross section dependence on photon virtuality | |
12025 | FSUP1 = ZERO | |
12026 | DO 150 I=1,3 | |
12027 | FSUP1 = FSUP1+PARMDL(26+I)*(ONE+VIRT/(4.D0*PARMDL(30+I))) | |
12028 | & /(ONE+VIRT/PARMDL(30+I))**2 | |
12029 | 150 CONTINUE | |
12030 | FSUP1 = FSUP1+PARMDL(30)/(ONE+VIRT/PARMDL(34)) | |
12031 | FAC1 = FAC1*FSUP1 | |
12032 | FAC2 = FAC2*FSUP1 | |
12033 | FSUP2 = ONE | |
12034 | ||
12035 | ECMOLD = ECM | |
12036 | Q2OLD = VIRT | |
12037 | ||
12038 | 3 CONTINUE | |
12039 | ||
12040 | C SIGTOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1) | |
12041 | CALL DT_SIGGP(ZERO,VIRT,ECM,ZERO,SIGTOT,DUM1,DUM2) | |
12042 | IF (ISHAD(1).EQ.1) THEN | |
12043 | SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1) | |
12044 | ELSE | |
12045 | SIGDIR = ZERO | |
12046 | ENDIF | |
12047 | SIGANO = FSUP1*FSUP2*SIGANO | |
12048 | SIGTOT = SIGTOT-SIGDIR-SIGANO | |
12049 | SIGDIR = SIGDIR/(FSUP1*FSUP2) | |
12050 | SIGANO = SIGANO/(FSUP1*FSUP2) | |
12051 | SIGTOT = SIGTOT+SIGDIR+SIGANO | |
12052 | ||
12053 | RR = DT_RNDM(SIGTOT) | |
12054 | IF (RR.LT.SIGDIR/SIGTOT) THEN | |
12055 | IPNT = 1 | |
12056 | ELSEIF ((RR.GE.SIGDIR/SIGTOT).AND. | |
12057 | & (RR.LT.(SIGDIR+SIGANO)/SIGTOT)) THEN | |
12058 | IPNT = 2 | |
12059 | ELSE | |
12060 | IPNT = 0 | |
12061 | ENDIF | |
12062 | RPNT = (SIGDIR+SIGANO)/SIGTOT | |
12063 | C WRITE(LOUT,'(I3,2F15.5)') ISHAD(1),FAC1,FAC2 | |
12064 | C WRITE(LOUT,'(I3,2F15.5)') MODE,SIGDIR,SIGANO | |
12065 | C WRITE(LOUT,'(I3,4F15.5)') MODE,SIGDIR+SIGANO,SIGTOT,RPNT,ECM | |
12066 | C WRITE(LOUT,'(1X,6E12.4)') ECM,VIRT,SIGTOT,SIGDIR,SIGANO,RPNT | |
12067 | IF (MODE.EQ.1) RETURN | |
12068 | ||
12069 | **sr 22.7.97 | |
12070 | K1 = 1 | |
12071 | K2 = 1 | |
12072 | RATE = ZERO | |
12073 | IF (ECM.GE.ECMNN(NEBINI)) THEN | |
12074 | K1 = NEBINI | |
12075 | K2 = NEBINI | |
12076 | RATE = ONE | |
12077 | ELSEIF (ECM.GT.ECMNN(1)) THEN | |
12078 | DO 10 I=2,NEBINI | |
12079 | IF (ECM.LT.ECMNN(I)) THEN | |
12080 | K1 = I-1 | |
12081 | K2 = I | |
12082 | RATE = (ECM-ECMNN(K1))/(ECMNN(K2)-ECMNN(K1)) | |
12083 | GOTO 11 | |
12084 | ENDIF | |
12085 | 10 CONTINUE | |
12086 | 11 CONTINUE | |
12087 | ENDIF | |
12088 | J1 = 1 | |
12089 | J2 = 1 | |
12090 | RATQ = ZERO | |
12091 | IF (NQBINI.GT.1) THEN | |
12092 | IF (VIRT.GE.Q2G(NQBINI)) THEN | |
12093 | J1 = NQBINI | |
12094 | J2 = NQBINI | |
12095 | RATQ = ONE | |
12096 | ELSEIF (VIRT.GT.Q2G(1)) THEN | |
12097 | DO 12 I=2,NQBINI | |
12098 | IF (VIRT.LT.Q2G(I)) THEN | |
12099 | J1 = I-1 | |
12100 | J2 = I | |
12101 | RATQ = LOG10( VIRT/MAX(Q2G(J1),TINY14))/ | |
12102 | & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14)) | |
12103 | GOTO 13 | |
12104 | ENDIF | |
12105 | 12 CONTINUE | |
12106 | 13 CONTINUE | |
12107 | ENDIF | |
12108 | ENDIF | |
12109 | SGA = XSPRO(K1,J1,NTARG)+ | |
12110 | & RATE*(XSPRO(K2,J1,NTARG)-XSPRO(K1,J1,NTARG))+ | |
12111 | & RATQ*(XSPRO(K1,J2,NTARG)-XSPRO(K1,J1,NTARG))+ | |
12112 | & RATE*RATQ*(XSPRO(K2,J2,NTARG)-XSPRO(K1,J2,NTARG)+ | |
12113 | & XSPRO(K1,J1,NTARG)-XSPRO(K2,J1,NTARG)) | |
12114 | SDI = DBLE(NB)*SIGDIR | |
12115 | SAN = DBLE(NB)*SIGANO | |
12116 | SPL = SDI+SAN | |
12117 | RR = DT_RNDM(SPL) | |
12118 | IF (RR.LT.SDI/SGA) THEN | |
12119 | IPNT = 1 | |
12120 | ELSEIF ((RR.GE.SDI/SGA).AND. | |
12121 | & (RR.LT.SPL/SGA)) THEN | |
12122 | IPNT = 2 | |
12123 | ELSE | |
12124 | IPNT = 0 | |
12125 | ENDIF | |
12126 | RPNT = SPL/SGA | |
12127 | C WRITE(LOUT,'(I3,4F15.5)') MODE,SPL,SGA,RPNT,ECM | |
12128 | ** | |
12129 | ||
12130 | RETURN | |
12131 | END | |
12132 | ||
12133 | *$ CREATE DT_GLBINI.FOR | |
12134 | *COPY DT_GLBINI | |
12135 | * | |
12136 | *===glbini=============================================================* | |
12137 | * | |
12138 | SUBROUTINE DT_GLBINI(WHAT) | |
12139 | ||
12140 | ************************************************************************ | |
12141 | * Pre-initialization of profile function * | |
12142 | * This version dated 28.11.00 is written by S. Roesler. * | |
12143 | * * | |
12144 | * Last change 27.12.2006 by S. Roesler. * | |
12145 | ************************************************************************ | |
12146 | ||
12147 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
12148 | SAVE | |
12149 | ||
12150 | PARAMETER ( LINP = 10 , | |
12151 | & LOUT = 6 , | |
12152 | & LDAT = 9 ) | |
12153 | ||
12154 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.D-14) | |
12155 | ||
12156 | LOGICAL LCMS | |
12157 | ||
12158 | * particle properties (BAMJET index convention) | |
12159 | CHARACTER*8 ANAME | |
12160 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
12161 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
12162 | ||
12163 | * properties of interacting particles | |
12164 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
12165 | ||
12166 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
12167 | ||
12168 | * emulsion treatment | |
12169 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
12170 | & NCOMPO,IEMUL | |
12171 | ||
12172 | * Glauber formalism: flags and parameters for statistics | |
12173 | LOGICAL LPROD | |
12174 | CHARACTER*8 CGLB | |
12175 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD | |
12176 | ||
12177 | * number of data sets other than protons and nuclei | |
12178 | * at the moment = 2 (pions and kaons) | |
12179 | PARAMETER (MAXOFF=2) | |
12180 | DIMENSION IJPINI(5),IOFFST(25) | |
12181 | DATA IJPINI / 13, 15, 0, 0, 0/ | |
12182 | * Glauber data-set to be used for hadron projectiles | |
12183 | * (0=proton, 1=pion, 2=kaon) | |
12184 | DATA (IOFFST(K),K=1,25) / | |
12185 | & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0, | |
12186 | & 0, 0, 1, 2, 2/ | |
12187 | * Acceptance interval for target nucleus mass | |
12188 | PARAMETER (KBACC = 6) | |
12189 | ||
12190 | * flags for input different options | |
12191 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
12192 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
12193 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
12194 | ||
12195 | PARAMETER (MAXMSS = 100) | |
12196 | DIMENSION IASAV(MAXMSS),IBSAV(MAXMSS) | |
12197 | DIMENSION WHAT(6) | |
12198 | ||
12199 | DATA JPEACH,JPSTEP / 18, 5 / | |
12200 | ||
12201 | * temporary patch until fix has been implemented in phojet: | |
12202 | * maximum energy for pion projectile | |
12203 | DATA ECMXPI / 100000.0D0 / | |
12204 | * | |
12205 | *-------------------------------------------------------------------------- | |
12206 | * general initializations | |
12207 | * | |
12208 | * steps in projectile mass number for initialization | |
12209 | IF (WHAT(4).GT.ZERO) JPEACH = INT(WHAT(4)) | |
12210 | IF (WHAT(5).GT.ZERO) JPSTEP = INT(WHAT(5)) | |
12211 | * | |
12212 | * energy range and binning | |
12213 | ELO = ABS(WHAT(1)) | |
12214 | EHI = ABS(WHAT(2)) | |
12215 | IF (ELO.GT.EHI) ELO = EHI | |
12216 | NEBIN = MAX(INT(WHAT(3)),1) | |
12217 | IF (ELO.EQ.EHI) NEBIN = 0 | |
12218 | LCMS = (WHAT(1).LT.ZERO).OR.(WHAT(2).LT.ZERO) | |
12219 | IF (LCMS) THEN | |
12220 | ECMINI = EHI | |
12221 | ELSE | |
12222 | ECMINI = SQRT(AAM(IJPROJ)**2+AAM(IJTARG)**2 | |
12223 | & +2.0D0*AAM(IJTARG)*EHI) | |
12224 | ENDIF | |
12225 | * | |
12226 | * default arguments for Glauber-routine | |
12227 | XI = ZERO | |
12228 | Q2I = ZERO | |
12229 | * | |
12230 | * initialize nuclear parameters, etc. | |
12231 | ||
12232 | * initialize evaporation if the code is not used as Fluka event generator | |
12233 | IF (ITRSPT.NE.1) THEN | |
12234 | CALL NCDTRD | |
12235 | CALL INCINI | |
12236 | ENDIF | |
12237 | ||
12238 | * | |
12239 | * open Glauber-data output file | |
12240 | IDX = INDEX(CGLB,' ') | |
12241 | K = 12 | |
12242 | IF (IDX.GT.1) K = IDX-1 | |
12243 | OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN') | |
12244 | * | |
12245 | *-------------------------------------------------------------------------- | |
12246 | * Glauber-initialization for proton and nuclei projectiles | |
12247 | * | |
12248 | * initialize phojet for proton-proton interactions | |
12249 | ELAB = ZERO | |
12250 | PLAB = ZERO | |
12251 | CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1) | |
12252 | CALL DT_PHOINI | |
12253 | * | |
12254 | * record projectile masses | |
12255 | NASAV = 0 | |
12256 | NPROJ = MIN(IP,JPEACH) | |
12257 | DO 10 KPROJ=1,NPROJ | |
12258 | NASAV = NASAV+1 | |
12259 | IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! ' | |
12260 | IASAV(NASAV) = KPROJ | |
12261 | 10 CONTINUE | |
12262 | IF (IP.GT.JPEACH) THEN | |
12263 | NPROJ = DBLE(IP-JPEACH)/DBLE(JPSTEP) | |
12264 | IF (NPROJ.EQ.0) THEN | |
12265 | NASAV = NASAV+1 | |
12266 | IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! ' | |
12267 | IASAV(NASAV) = IP | |
12268 | ELSE | |
12269 | DO 11 IPROJ=1,NPROJ | |
12270 | KPROJ = JPEACH+IPROJ*JPSTEP | |
12271 | NASAV = NASAV+1 | |
12272 | IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! ' | |
12273 | IASAV(NASAV) = KPROJ | |
12274 | 11 CONTINUE | |
12275 | IF (KPROJ.LT.IP) THEN | |
12276 | NASAV = NASAV+1 | |
12277 | IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! ' | |
12278 | IASAV(NASAV) = IP | |
12279 | ENDIF | |
12280 | ENDIF | |
12281 | ENDIF | |
12282 | * | |
12283 | * record target masses | |
12284 | NBSAV = 0 | |
12285 | NTARG = 1 | |
12286 | IF (NCOMPO.GT.0) NTARG = NCOMPO | |
12287 | DO 12 ITARG=1,NTARG | |
12288 | NBSAV = NBSAV+1 | |
12289 | IF (NBSAV.GT.MAXMSS) STOP ' GLBINI: NBSAV > MAXMSS ! ' | |
12290 | IF (NCOMPO.GT.0) THEN | |
12291 | IBSAV(NBSAV) = IEMUMA(ITARG) | |
12292 | ELSE | |
12293 | IBSAV(NBSAV) = IT | |
12294 | ENDIF | |
12295 | 12 CONTINUE | |
12296 | * | |
12297 | * print masses | |
12298 | WRITE(LDAT,1000) NEBIN,': ',SIGN(ELO,WHAT(1)),SIGN(EHI,WHAT(2)) | |
12299 | 1000 FORMAT(I4,A,1P,2E13.5) | |
12300 | NLINES = DBLE(NASAV)/18.0D0 | |
12301 | IF (NLINES.GT.0) THEN | |
12302 | DO 13 I=1,NLINES | |
12303 | IF (I.EQ.1) THEN | |
12304 | WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=1,18) | |
12305 | ELSE | |
12306 | WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=18*I-17,18*I) | |
12307 | ENDIF | |
12308 | 13 CONTINUE | |
12309 | ENDIF | |
12310 | I0 = 18*NLINES+1 | |
12311 | IF (I0.LE.NASAV) THEN | |
12312 | IF (I0.EQ.1) THEN | |
12313 | WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=I0,NASAV) | |
12314 | ELSE | |
12315 | WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=I0,NASAV) | |
12316 | ENDIF | |
12317 | ENDIF | |
12318 | NLINES = DBLE(NBSAV)/18.0D0 | |
12319 | IF (NLINES.GT.0) THEN | |
12320 | DO 14 I=1,NLINES | |
12321 | IF (I.EQ.1) THEN | |
12322 | WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=1,18) | |
12323 | ELSE | |
12324 | WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=18*I-17,18*I) | |
12325 | ENDIF | |
12326 | 14 CONTINUE | |
12327 | ENDIF | |
12328 | I0 = 18*NLINES+1 | |
12329 | IF (I0.LE.NBSAV) THEN | |
12330 | IF (I0.EQ.1) THEN | |
12331 | WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=I0,NBSAV) | |
12332 | ELSE | |
12333 | WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=I0,NBSAV) | |
12334 | ENDIF | |
12335 | ENDIF | |
12336 | * | |
12337 | * calculate Glauber-data for each energy and mass combination | |
12338 | * | |
12339 | * loop over energy bins | |
12340 | ELO = LOG10(ELO) | |
12341 | EHI = LOG10(EHI) | |
12342 | DEBIN = (EHI-ELO)/MAX(DBLE(NEBIN),ONE) | |
12343 | DO 1 IE=1,NEBIN+1 | |
12344 | E = ELO+DBLE(IE-1)*DEBIN | |
12345 | E = 10**E | |
12346 | IF (LCMS) THEN | |
12347 | E = MAX(2.0D0*AAM(IJPROJ)+0.1D0,E) | |
12348 | ECM = E | |
12349 | ELSE | |
12350 | PLAB = ZERO | |
12351 | ECM = ZERO | |
12352 | E = MAX(AAM(IJPROJ)+0.1D0,E) | |
12353 | CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0) | |
12354 | ENDIF | |
12355 | * | |
12356 | * loop over projectile and target masses | |
12357 | DO 2 ITARG=1,NBSAV | |
12358 | DO 3 IPROJ=1,NASAV | |
12359 | CALL DT_XSGLAU(IASAV(IPROJ),IBSAV(ITARG),IJPROJ, | |
12360 | & XI,Q2I,ECM,1,1,-1) | |
12361 | 3 CONTINUE | |
12362 | 2 CONTINUE | |
12363 | * | |
12364 | 1 CONTINUE | |
12365 | * | |
12366 | *-------------------------------------------------------------------------- | |
12367 | * Glauber-initialization for pion, kaon, ... projectiles | |
12368 | * | |
12369 | DO 6 IJ=1,MAXOFF | |
12370 | * | |
12371 | * initialize phojet for this interaction | |
12372 | ELAB = ZERO | |
12373 | PLAB = ZERO | |
12374 | IJPROJ = IJPINI(IJ) | |
12375 | IP = 1 | |
12376 | IPZ = 1 | |
12377 | * | |
12378 | * temporary patch until fix has been implemented in phojet: | |
12379 | IF (ECMINI.GT.ECMXPI) THEN | |
12380 | CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMXPI,1) | |
12381 | ELSE | |
12382 | CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1) | |
12383 | ENDIF | |
12384 | CALL DT_PHOINI | |
12385 | * | |
12386 | * calculate Glauber-data for each energy and mass combination | |
12387 | * | |
12388 | * loop over energy bins | |
12389 | DO 4 IE=1,NEBIN+1 | |
12390 | E = ELO+DBLE(IE-1)*DEBIN | |
12391 | E = 10**E | |
12392 | IF (LCMS) THEN | |
12393 | E = MAX(2.0D0*AAM(IJPROJ)+TINY14,E) | |
12394 | ECM = E | |
12395 | ELSE | |
12396 | PLAB = ZERO | |
12397 | ECM = ZERO | |
12398 | E = MAX(AAM(IJPROJ)+TINY14,E) | |
12399 | CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0) | |
12400 | ENDIF | |
12401 | * | |
12402 | * loop over projectile and target masses | |
12403 | DO 5 ITARG=1,NBSAV | |
12404 | CALL DT_XSGLAU(1,IBSAV(ITARG),IJPROJ,XI,Q2I,ECM,1,1,-1) | |
12405 | 5 CONTINUE | |
12406 | * | |
12407 | 4 CONTINUE | |
12408 | * | |
12409 | 6 CONTINUE | |
12410 | ||
12411 | *-------------------------------------------------------------------------- | |
12412 | * close output unit(s), etc. | |
12413 | * | |
12414 | CLOSE(LDAT) | |
12415 | ||
12416 | RETURN | |
12417 | END | |
12418 | ||
12419 | *$ CREATE DT_GLBSET.FOR | |
12420 | *COPY DT_GLBSET | |
12421 | * | |
12422 | *===glbset=============================================================* | |
12423 | * | |
12424 | SUBROUTINE DT_GLBSET(IDPROJ,NA,NB,ELAB,MODE) | |
12425 | ************************************************************************ | |
12426 | * Interpolation of pre-initialized profile functions * | |
12427 | * This version dated 28.11.00 is written by S. Roesler. * | |
12428 | ************************************************************************ | |
12429 | ||
12430 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
12431 | SAVE | |
12432 | ||
12433 | PARAMETER ( LINP = 10 , | |
12434 | & LOUT = 6 , | |
12435 | & LDAT = 9 ) | |
12436 | ||
12437 | PARAMETER (ZERO=0.0D0,ONE=1.0D0) | |
12438 | ||
12439 | LOGICAL LCMS,LREAD,LFRST1,LFRST2 | |
12440 | ||
12441 | * particle properties (BAMJET index convention) | |
12442 | CHARACTER*8 ANAME | |
12443 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
12444 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
12445 | ||
12446 | * Glauber formalism: flags and parameters for statistics | |
12447 | LOGICAL LPROD | |
12448 | CHARACTER*8 CGLB | |
12449 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD | |
12450 | ||
12451 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
12452 | ||
12453 | * Glauber formalism: parameters | |
12454 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), | |
12455 | & BMAX(NCOMPX),BSTEP(NCOMPX), | |
12456 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), | |
12457 | & NSITEB,NSTATB | |
12458 | ||
12459 | * Glauber formalism: cross sections | |
12460 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
12461 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
12462 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
12463 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
12464 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
12465 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
12466 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
12467 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
12468 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
12469 | & BSLOPE,NEBINI,NQBINI | |
12470 | ||
12471 | * number of data sets other than protons and nuclei | |
12472 | * at the moment = 2 (pions and kaons) | |
12473 | PARAMETER (MAXOFF=2) | |
12474 | DIMENSION IJPINI(5),IOFFST(25) | |
12475 | DATA IJPINI / 13, 15, 0, 0, 0/ | |
12476 | * Glauber data-set to be used for hadron projectiles | |
12477 | * (0=proton, 1=pion, 2=kaon) | |
12478 | DATA (IOFFST(K),K=1,25) / | |
12479 | & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0, | |
12480 | & 0, 0, 1, 2, 2/ | |
12481 | * Acceptance interval for target nucleus mass | |
12482 | PARAMETER (KBACC = 6) | |
12483 | ||
12484 | * emulsion treatment | |
12485 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
12486 | & NCOMPO,IEMUL | |
12487 | ||
12488 | PARAMETER (MAXSET=5000, | |
12489 | & MAXBIN=100) | |
12490 | DIMENSION XSIG(MAXSET,6),XERR(MAXSET,6),BPROFL(MAXSET,KSITEB) | |
12491 | DIMENSION IABIN(MAXBIN),IBBIN(MAXBIN),XS(6),XE(6), | |
12492 | & BPRO0(KSITEB),BPRO1(KSITEB),BPRO(KSITEB), | |
12493 | & IAIDX(10) | |
12494 | ||
12495 | DATA LREAD,LFRST1,LFRST2 /.FALSE.,.TRUE.,.TRUE./ | |
12496 | * | |
12497 | * read data from file | |
12498 | * | |
12499 | IF (MODE.EQ.0) THEN | |
12500 | ||
12501 | IF (LREAD) RETURN | |
12502 | ||
12503 | DO 1 I=1,MAXSET | |
12504 | DO 2 J=1,6 | |
12505 | XSIG(I,J) = ZERO | |
12506 | XERR(I,J) = ZERO | |
12507 | 2 CONTINUE | |
12508 | DO 3 J=1,KSITEB | |
12509 | BPROFL(I,J) = ZERO | |
12510 | 3 CONTINUE | |
12511 | 1 CONTINUE | |
12512 | DO 4 I=1,MAXBIN | |
12513 | IABIN(I) = 0 | |
12514 | IBBIN(I) = 0 | |
12515 | 4 CONTINUE | |
12516 | DO 5 I=1,KSITEB | |
12517 | BPRO0(I) = ZERO | |
12518 | BPRO1(I) = ZERO | |
12519 | BPRO(I) = ZERO | |
12520 | 5 CONTINUE | |
12521 | ||
12522 | IDX = INDEX(CGLB,' ') | |
12523 | K = 12 | |
12524 | IF (IDX.GT.1) K = IDX-1 | |
12525 | OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN') | |
12526 | WRITE(LOUT,1000) CGLB(1:K)//'.glb' | |
12527 | 1000 FORMAT(/,' GLBSET: impact parameter distributions read from ', | |
12528 | & 'file ',A12,/) | |
12529 | * | |
12530 | * read binning information | |
12531 | READ(LDAT,'(I4,2X,2E13.5)') NEBIN,ELO,EHI | |
12532 | * return lower energy threshold to Fluka-interface | |
12533 | ELAB = ELO | |
12534 | LCMS = ELO.LT.ZERO | |
12535 | WRITE(LOUT,'(1X,A)') ' equidistant logarithmic energy binning:' | |
12536 | IF (LCMS) THEN | |
12537 | WRITE(LOUT,1001) '(cms)',ABS(ELO),ABS(EHI),NEBIN | |
12538 | ELSE | |
12539 | WRITE(LOUT,1001) '(lab)',ABS(ELO),ABS(EHI),NEBIN | |
12540 | ENDIF | |
12541 | 1001 FORMAT(2X,A5,' E_lo = ',1P,E9.3,' E_hi = ',1P,E9.3,4X, | |
12542 | & 'No. of bins:',I5,/) | |
12543 | ELO = LOG10(ABS(ELO)) | |
12544 | EHI = LOG10(ABS(EHI)) | |
12545 | DEBIN = (EHI-ELO)/ABS(DBLE(NEBIN)) | |
12546 | WRITE(LOUT,'(/,1X,A)') ' projectiles: (mass number)' | |
12547 | READ(LDAT,'(I4,2X,18I4)') NABIN,(IABIN(J),J=1,18) | |
12548 | IF (NABIN.LT.18) THEN | |
12549 | WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,NABIN) | |
12550 | ELSE | |
12551 | WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,18) | |
12552 | ENDIF | |
12553 | IF (NABIN.GT.MAXBIN) STOP ' GLBSET: NABIN > MAXBIN !' | |
12554 | IF (NABIN.GT.18) THEN | |
12555 | NLINES = DBLE(NABIN-18)/18.0D0 | |
12556 | IF (NLINES.GT.0) THEN | |
12557 | DO 7 I=1,NLINES | |
12558 | I0 = 18*(I+1)-17 | |
12559 | READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,I0+17) | |
12560 | WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,I0+17) | |
12561 | 7 CONTINUE | |
12562 | ENDIF | |
12563 | I0 = 18*(NLINES+1)+1 | |
12564 | IF (I0.LE.NABIN) THEN | |
12565 | READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,NABIN) | |
12566 | WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,NABIN) | |
12567 | ENDIF | |
12568 | ENDIF | |
12569 | WRITE(LOUT,'(/,1X,A)') ' targets: (mass number)' | |
12570 | READ(LDAT,'(I4,2X,18I4)') NBBIN,(IBBIN(J),J=1,18) | |
12571 | IF (NBBIN.LT.18) THEN | |
12572 | WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,NBBIN) | |
12573 | ELSE | |
12574 | WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,18) | |
12575 | ENDIF | |
12576 | IF (NBBIN.GT.MAXBIN) STOP ' GLBSET: NBBIN > MAXBIN !' | |
12577 | IF (NBBIN.GT.18) THEN | |
12578 | NLINES = DBLE(NBBIN-18)/18.0D0 | |
12579 | IF (NLINES.GT.0) THEN | |
12580 | DO 8 I=1,NLINES | |
12581 | I0 = 18*(I+1)-17 | |
12582 | READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17) | |
12583 | WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17) | |
12584 | 8 CONTINUE | |
12585 | ENDIF | |
12586 | I0 = 18*(NLINES+1)+1 | |
12587 | IF (I0.LE.NBBIN) THEN | |
12588 | READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN) | |
12589 | WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN) | |
12590 | ENDIF | |
12591 | ENDIF | |
12592 | * number of data sets to follow in the Glauber data file | |
12593 | * this variable is used for checks of consistency of projectile | |
12594 | * and target mass configurations given in header of Glauber data | |
12595 | * file and the data-sets which follow in this file | |
12596 | NSET0 = (NEBIN+1)*(NABIN+MAXOFF)*NBBIN | |
12597 | * | |
12598 | * read profile function data | |
12599 | NSET = 0 | |
12600 | NAIDX = 0 | |
12601 | IPOLD = 0 | |
12602 | 10 CONTINUE | |
12603 | NSET = NSET+1 | |
12604 | IF (NSET.GT.MAXSET) STOP ' GLBSET: NSET > MAXSET ! ' | |
12605 | READ(LDAT,1002,END=100) IP,IA,IB,ISTATB,ISITEB,ECM | |
12606 | 1002 FORMAT(5I10,E15.5) | |
12607 | IF ((IP.NE.1).AND.(IP.NE.IPOLD)) THEN | |
12608 | NAIDX = NAIDX+1 | |
12609 | IF (NAIDX.GT.10) STOP ' GLBSET: NAIDX > 10 !' | |
12610 | IAIDX(NAIDX) = IP | |
12611 | IPOLD = IP | |
12612 | ENDIF | |
12613 | READ(LDAT,'(6E12.5)') (XSIG(NSET,I),I=1,6) | |
12614 | READ(LDAT,'(6E12.5)') (XERR(NSET,I),I=1,6) | |
12615 | NLINES = INT(DBLE(ISITEB)/7.0D0) | |
12616 | IF (NLINES.GT.0) THEN | |
12617 | DO 11 I=1,NLINES | |
12618 | READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=7*I-6,7*I) | |
12619 | 11 CONTINUE | |
12620 | ENDIF | |
12621 | I0 = 7*NLINES+1 | |
12622 | IF (I0.LE.ISITEB) | |
12623 | & READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=I0,ISITEB) | |
12624 | GOTO 10 | |
12625 | 100 CONTINUE | |
12626 | NSET = NSET-1 | |
12627 | IF (NSET.NE.NSET0) STOP ' GLBSET: NSET.NE.NSET0 !' | |
12628 | WRITE(LOUT,'(/,1X,A)') | |
12629 | & ' projectiles other than protons and nuclei: (particle index)' | |
12630 | IF (NAIDX.GT.0) THEN | |
12631 | WRITE(LOUT,'(6X,18I4)') (IAIDX(J),J=1,NAIDX) | |
12632 | ELSE | |
12633 | WRITE(LOUT,'(6X,A)') 'none' | |
12634 | ENDIF | |
12635 | * | |
12636 | CLOSE(LDAT) | |
12637 | WRITE(LOUT,*) | |
12638 | LREAD = .TRUE. | |
12639 | ||
12640 | IF (NCOMPO.EQ.0) THEN | |
12641 | DO 12 J=1,NBBIN | |
12642 | NCOMPO = NCOMPO+1 | |
12643 | IEMUMA(NCOMPO) = IBBIN(J) | |
12644 | IEMUCH(NCOMPO) = IEMUMA(NCOMPO)/2 | |
12645 | EMUFRA(NCOMPO) = 1.0D0 | |
12646 | 12 CONTINUE | |
12647 | IEMUL = 1 | |
12648 | ENDIF | |
12649 | * | |
12650 | * calculate profile function for certain set of parameters | |
12651 | * | |
12652 | ELSE | |
12653 | ||
12654 | c write(*,*) 'glbset called for ',IDPROJ,NA,NB,ELAB,MODE | |
12655 | * | |
12656 | * check for type of projectile and set index-offset to entry in | |
12657 | * Glauber data array correspondingly | |
12658 | IF (IDPROJ.GT.25) STOP ' GLBSET: IDPROJ > 25 !' | |
12659 | IF (IOFFST(IDPROJ).EQ.-1) THEN | |
12660 | STOP ' GLBSET: no data for this projectile !' | |
12661 | ELSEIF (IOFFST(IDPROJ).GT.0) THEN | |
12662 | IDXOFF = (NEBIN+1)*(NABIN+IOFFST(IDPROJ)-1)*NBBIN | |
12663 | ELSE | |
12664 | IDXOFF = 0 | |
12665 | ENDIF | |
12666 | * | |
12667 | * get energy bin and interpolation factor | |
12668 | IF (LCMS) THEN | |
12669 | E = SQRT(AAM(IDPROJ)**2+AAM(1)**2+2.0D0*AAM(1)*ELAB) | |
12670 | ELSE | |
12671 | E = ELAB | |
12672 | ENDIF | |
12673 | E = LOG10(E) | |
12674 | IF (E.LT.ELO) THEN | |
12675 | IF (LFRST1) THEN | |
12676 | WRITE(LOUT,*) ' GLBSET: Too low energy! (E_lo,E) ',ELO,E | |
12677 | LFRST1 = .FALSE. | |
12678 | ENDIF | |
12679 | E = ELO | |
12680 | ENDIF | |
12681 | IF (E.GT.EHI) THEN | |
12682 | IF (LFRST2) THEN | |
12683 | WRITE(LOUT,*) ' GLBSET: Too high energy! (E_hi,E) ',EHI,E | |
12684 | LFRST2 = .FALSE. | |
12685 | ENDIF | |
12686 | E = EHI | |
12687 | ENDIF | |
12688 | IE0 = (E-ELO)/DEBIN+1 | |
12689 | IE1 = IE0+1 | |
12690 | FACE = (E-(ELO+DBLE(IE0-1)*DEBIN))/DEBIN | |
12691 | * | |
12692 | * get target nucleus index | |
12693 | KB = 0 | |
12694 | NBACC = KBACC | |
12695 | DO 20 I=1,NBBIN | |
12696 | NBDIFF = ABS(NB-IBBIN(I)) | |
12697 | IF (NB.EQ.IBBIN(I)) THEN | |
12698 | KB = I | |
12699 | GOTO 21 | |
12700 | ELSEIF (NBDIFF.LE.NBACC) THEN | |
12701 | KB = I | |
12702 | NBACC = NBDIFF | |
12703 | ENDIF | |
12704 | 20 CONTINUE | |
12705 | IF (KB.NE.0) GOTO 21 | |
12706 | WRITE(LOUT,*) ' GLBSET: data not found for target ',NB | |
12707 | STOP | |
12708 | 21 CONTINUE | |
12709 | * | |
12710 | * get projectile nucleus bin and interpolation factor | |
12711 | KA0 = 0 | |
12712 | KA1 = 0 | |
12713 | FACNA = 0 | |
12714 | IF (IDXOFF.GT.0) THEN | |
12715 | KA0 = 1 | |
12716 | KA1 = 1 | |
12717 | KABIN = 1 | |
12718 | ELSE | |
12719 | IF (NA.GT.IABIN(NABIN)) STOP ' GLBSET: NA > IABIN(NABIN) !' | |
12720 | DO 22 I=1,NABIN | |
12721 | IF (NA.EQ.IABIN(I)) THEN | |
12722 | KA0 = I | |
12723 | KA1 = I | |
12724 | GOTO 23 | |
12725 | ELSEIF (NA.LT.IABIN(I)) THEN | |
12726 | KA0 = I-1 | |
12727 | KA1 = I | |
12728 | GOTO 23 | |
12729 | ENDIF | |
12730 | 22 CONTINUE | |
12731 | WRITE(LOUT,*) ' GLBSET: data not found for projectile ',NA | |
12732 | STOP | |
12733 | 23 CONTINUE | |
12734 | IF (KA0.NE.KA1) | |
12735 | & FACNA = DBLE(NA-IABIN(KA0))/DBLE(IABIN(KA1)-IABIN(KA0)) | |
12736 | KABIN = NABIN | |
12737 | ENDIF | |
12738 | * | |
12739 | * interpolate profile functions for interactions ka0-kb and ka1-kb | |
12740 | * for energy E separately | |
12741 | IDX0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1) | |
12742 | IDX1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1) | |
12743 | IDY0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1) | |
12744 | IDY1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1) | |
12745 | DO 30 I=1,ISITEB | |
12746 | BPRO0(I) = BPROFL(IDX0,I) | |
12747 | & +FACE*(BPROFL(IDX1,I)-BPROFL(IDX0,I)) | |
12748 | BPRO1(I) = BPROFL(IDY0,I) | |
12749 | & +FACE*(BPROFL(IDY1,I)-BPROFL(IDY0,I)) | |
12750 | 30 CONTINUE | |
12751 | RADB = DT_RNCLUS(NB) | |
12752 | BSTP0 = 2.0D0*(DT_RNCLUS(IABIN(KA0))+RADB)/DBLE(ISITEB-1) | |
12753 | BSTP1 = 2.0D0*(DT_RNCLUS(IABIN(KA1))+RADB)/DBLE(ISITEB-1) | |
12754 | * | |
12755 | * interpolate cross sections for energy E and projectile mass | |
12756 | DO 31 I=1,6 | |
12757 | XS0 = XSIG(IDX0,I)+FACE*(XSIG(IDX1,I)-XSIG(IDX0,I)) | |
12758 | XS1 = XSIG(IDY0,I)+FACE*(XSIG(IDY1,I)-XSIG(IDY0,I)) | |
12759 | XS(I) = XS0+FACNA*(XS1-XS0) | |
12760 | XE0 = XERR(IDX0,I)+FACE*(XERR(IDX1,I)-XERR(IDX0,I)) | |
12761 | XE1 = XERR(IDY0,I)+FACE*(XERR(IDY1,I)-XERR(IDY0,I)) | |
12762 | XE(I) = XE0+FACNA*(XE1-XE0) | |
12763 | 31 CONTINUE | |
12764 | * | |
12765 | * interpolate between ka0 and ka1 | |
12766 | RADA = DT_RNCLUS(NA) | |
12767 | BMX = 2.0D0*(RADA+RADB) | |
12768 | BSTP = BMX/DBLE(ISITEB-1) | |
12769 | BPRO(1) = ZERO | |
12770 | DO 32 I=1,ISITEB-1 | |
12771 | B = DBLE(I)*BSTP | |
12772 | * | |
12773 | * calculate values of profile functions at B | |
12774 | IDX0 = B/BSTP0+1 | |
12775 | IF (IDX0.GT.ISITEB) IDX0 = ISITEB | |
12776 | IDX1 = MIN(IDX0+1,ISITEB) | |
12777 | FACB = (B-DBLE(IDX0-1)*BSTP0)/BSTP0 | |
12778 | BPR0 = BPRO0(IDX0)+FACB*(BPRO0(IDX1)-BPRO0(IDX0)) | |
12779 | IDX0 = B/BSTP1+1 | |
12780 | IF (IDX0.GT.ISITEB) IDX0 = ISITEB | |
12781 | IDX1 = MIN(IDX0+1,ISITEB) | |
12782 | FACB = (B-DBLE(IDX0-1)*BSTP1)/BSTP1 | |
12783 | BPR1 = BPRO1(IDX0)+FACB*(BPRO1(IDX1)-BPRO1(IDX0)) | |
12784 | * | |
12785 | BPRO(I+1) = BPR0+FACNA*(BPR1-BPR0) | |
12786 | 32 CONTINUE | |
12787 | * | |
12788 | * fill common dtglam | |
12789 | NSITEB = ISITEB | |
12790 | RASH(1) = RADA | |
12791 | RBSH(1) = RADB | |
12792 | BMAX(1) = BMX | |
12793 | BSTEP(1) = BSTP | |
12794 | DO 33 I=1,KSITEB | |
12795 | BSITE(0,1,1,I) = BPRO(I) | |
12796 | 33 CONTINUE | |
12797 | * | |
12798 | * fill common dtglxs | |
12799 | XSTOT(1,1,1) = XS(1) | |
12800 | XSELA(1,1,1) = XS(2) | |
12801 | XSQEP(1,1,1) = XS(3) | |
12802 | XSQET(1,1,1) = XS(4) | |
12803 | XSQE2(1,1,1) = XS(5) | |
12804 | XSPRO(1,1,1) = XS(6) | |
12805 | XETOT(1,1,1) = XE(1) | |
12806 | XEELA(1,1,1) = XE(2) | |
12807 | XEQEP(1,1,1) = XE(3) | |
12808 | XEQET(1,1,1) = XE(4) | |
12809 | XEQE2(1,1,1) = XE(5) | |
12810 | XEPRO(1,1,1) = XE(6) | |
12811 | ||
12812 | ENDIF | |
12813 | ||
12814 | RETURN | |
12815 | END | |
12816 | *$ CREATE DT_XKSAMP.FOR | |
12817 | *COPY DT_XKSAMP | |
12818 | * | |
12819 | *===xksamp=============================================================* | |
12820 | * | |
12821 | SUBROUTINE DT_XKSAMP(NN,ECM) | |
12822 | ||
12823 | ************************************************************************ | |
12824 | * Sampling of parton x-values and chain system for one interaction. * | |
12825 | * processed by S. Roesler, 9.8.95 * | |
12826 | ************************************************************************ | |
12827 | ||
12828 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
12829 | SAVE | |
12830 | ||
12831 | PARAMETER ( LINP = 10 , | |
12832 | & LOUT = 6 , | |
12833 | & LDAT = 9 ) | |
12834 | ||
12835 | PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0) | |
12836 | SAVE | |
12837 | ||
12838 | PARAMETER ( | |
12839 | * lower cuts for (valence-sea/sea-valence) chain masses | |
12840 | * antiquark-quark (u/d-sea quark) (s-sea quark) | |
12841 | & AMIU = 0.5D0, AMIS = 0.8D0, | |
12842 | * quark-diquark (u/d-sea quark) (s-sea quark) | |
12843 | & AMAU = 2.6D0, AMAS = 2.6D0, | |
12844 | * maximum lower valence-x threshold | |
12845 | & XVMAX = 0.98D0, | |
12846 | * fraction of sea-diquarks sampled out of sea-partons | |
12847 | **test | |
12848 | C & FRCDIQ = 0.9D0, | |
12849 | ** | |
12850 | * | |
12851 | & SQMA = 0.7D0, | |
12852 | * | |
12853 | * maximum number of trials to generate x's for the required number | |
12854 | * of sea quark pairs for a given hadron | |
12855 | & NSEATY = 12 | |
12856 | C & NSEATY = 3 | |
12857 | & ) | |
12858 | ||
12859 | LOGICAL ZUOVP,ZUOSP,ZUOVT,ZUOST,INTLO | |
12860 | ||
12861 | PARAMETER ( MAXNCL = 260, | |
12862 | ||
12863 | & MAXVQU = MAXNCL, | |
12864 | & MAXSQU = 20*MAXVQU, | |
12865 | & MAXINT = MAXVQU+MAXSQU) | |
12866 | ||
12867 | * event history | |
12868 | ||
12869 | PARAMETER (NMXHKK=200000) | |
12870 | ||
12871 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
12872 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
12873 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
12874 | ||
12875 | * particle properties (BAMJET index convention) | |
12876 | CHARACTER*8 ANAME | |
12877 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
12878 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
12879 | ||
12880 | * interface between Glauber formalism and DPM | |
12881 | COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL), | |
12882 | & INTER1(MAXINT),INTER2(MAXINT) | |
12883 | ||
12884 | * properties of interacting particles | |
12885 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
12886 | ||
12887 | * threshold values for x-sampling (DTUNUC 1.x) | |
12888 | COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA, | |
12889 | & SSMIMQ,VVMTHR | |
12890 | ||
12891 | * x-values of partons (DTUNUC 1.x) | |
12892 | COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU), | |
12893 | & XTVQ(MAXVQU),XTVD(MAXVQU), | |
12894 | & XPSQ(MAXSQU),XPSAQ(MAXSQU), | |
12895 | & XTSQ(MAXSQU),XTSAQ(MAXSQU) | |
12896 | ||
12897 | * flavors of partons (DTUNUC 1.x) | |
12898 | COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU), | |
12899 | & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU), | |
12900 | & IPSQ(MAXSQU),IPSQ2(MAXSQU), | |
12901 | & IPSAQ(MAXSQU),IPSAQ2(MAXSQU), | |
12902 | & ITSQ(MAXSQU),ITSQ2(MAXSQU), | |
12903 | & ITSAQ(MAXSQU),ITSAQ2(MAXSQU), | |
12904 | & KKPROJ(MAXVQU),KKTARG(MAXVQU) | |
12905 | ||
12906 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) | |
12907 | COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD, | |
12908 | & IXPV,IXPS,IXTV,IXTS, | |
12909 | & INTVV1(MAXVQU),INTVV2(MAXVQU), | |
12910 | & INTSV1(MAXVQU),INTSV2(MAXVQU), | |
12911 | & INTVS1(MAXVQU),INTVS2(MAXVQU), | |
12912 | & INTSS1(MAXSQU),INTSS2(MAXSQU), | |
12913 | & INTDV1(MAXVQU),INTDV2(MAXVQU), | |
12914 | & INTVD1(MAXVQU),INTVD2(MAXVQU), | |
12915 | & INTDS1(MAXSQU),INTDS2(MAXSQU), | |
12916 | & INTSD1(MAXSQU),INTSD2(MAXSQU) | |
12917 | ||
12918 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) | |
12919 | COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU), | |
12920 | & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU) | |
12921 | ||
12922 | * auxiliary common for chain system storage (DTUNUC 1.x) | |
12923 | COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL) | |
12924 | ||
12925 | * flags for input different options | |
12926 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
12927 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
12928 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
12929 | ||
12930 | * various options for treatment of partons (DTUNUC 1.x) | |
12931 | * (chain recombination, Cronin,..) | |
12932 | LOGICAL LCO2CR,LINTPT | |
12933 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, | |
12934 | & LCO2CR,LINTPT | |
12935 | ||
12936 | DIMENSION ZUOVP(MAXVQU),ZUOSP(MAXSQU),ZUOVT(MAXVQU),ZUOST(MAXSQU), | |
12937 | & INTLO(MAXINT) | |
12938 | ||
12939 | * (1) initializations | |
12940 | *----------------------------------------------------------------------- | |
12941 | ||
12942 | **test | |
12943 | IF (ECM.LT.4.5D0) THEN | |
12944 | C FRCDIQ = 0.6D0 | |
12945 | FRCDIQ = 0.4D0 | |
12946 | ELSEIF ((ECM.GE.4.5D0).AND.(ECM.LT.7.5)) THEN | |
12947 | C FRCDIQ = 0.6D0+(ECM-4.5D0)/3.0D0*0.3D0 | |
12948 | FRCDIQ = 0.4D0+(ECM-4.5D0)/3.0D0*0.3D0 | |
12949 | ELSE | |
12950 | C FRCDIQ = 0.9D0 | |
12951 | FRCDIQ = 0.7D0 | |
12952 | ENDIF | |
12953 | ** | |
12954 | DO 30 I=1,MAXSQU | |
12955 | ZUOSP(I) = .FALSE. | |
12956 | ZUOST(I) = .FALSE. | |
12957 | IF (I.LE.MAXVQU) THEN | |
12958 | ZUOVP(I) = .FALSE. | |
12959 | ZUOVT(I) = .FALSE. | |
12960 | ENDIF | |
12961 | 30 CONTINUE | |
12962 | ||
12963 | * lower thresholds for x-selection | |
12964 | * sea-quarks (default: CSEA=0.2) | |
12965 | IF (ECM.LT.10.0D0) THEN | |
12966 | **!!test | |
12967 | XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM | |
12968 | C XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM**2.0D0 | |
12969 | NSEA = NSEATY | |
12970 | C XSTHR = ONE/ECM**2 | |
12971 | ELSE | |
12972 | **sr 30.3.98 | |
12973 | C XSTHR = CSEA/ECM | |
12974 | XSTHR = CSEA/ECM**2 | |
12975 | C XSTHR = ONE/ECM**2 | |
12976 | ** | |
12977 | IF ((IP.GE.150).AND.(IT.GE.150)) | |
12978 | & XSTHR = 2.5D0/(ECM*SQRT(ECM)) | |
12979 | NSEA = NSEATY | |
12980 | ENDIF | |
12981 | * (default: SSMIMA=0.14) used for sea-diquarks (?) | |
12982 | XSSTHR = SSMIMA/ECM | |
12983 | BSQMA = SQMA/ECM | |
12984 | * valence-quarks (default: CVQ=1.0) | |
12985 | XVTHR = CVQ/ECM | |
12986 | * valence-diquarks (default: CDQ=2.0) | |
12987 | XDTHR = CDQ/ECM | |
12988 | ||
12989 | * maximum-x for sea-quarks | |
12990 | XVCUT = XVTHR+XDTHR | |
12991 | IF (XVCUT.GT.XVMAX) THEN | |
12992 | XVCUT = XVMAX | |
12993 | XVTHR = XVCUT/3.0D0 | |
12994 | XDTHR = XVCUT-XVTHR | |
12995 | ENDIF | |
12996 | XXSEAM = ONE-XVCUT | |
12997 | **sr 18.4. test: DPMJET | |
12998 | C XXSEAM=1.0 - XVTHR*(1.D0+0.3D0*DT_RNDM(V1)) | |
12999 | C & - XDTHR*(1.D0+0.3D0*DT_RNDM(V2)) | |
13000 | C & -0.01*(1.D0+1.5D0*DT_RNDM(V3)) | |
13001 | ** | |
13002 | * maximum number of sea-pairs allowed kinematically | |
13003 | C NSMAX = INT(OHALF*XXSEAM/XSTHR) | |
13004 | RNSMAX = OHALF*XXSEAM/XSTHR | |
13005 | IF (RNSMAX.GT.10000.0D0) THEN | |
13006 | NSMAX = 10000 | |
13007 | ELSE | |
13008 | NSMAX = INT(OHALF*XXSEAM/XSTHR) | |
13009 | ENDIF | |
13010 | * check kinematical limit for valence-x thresholds | |
13011 | * (should be obsolete now) | |
13012 | IF (XVCUT.GT.XVMAX) THEN | |
13013 | WRITE(LOUT,1000) XVCUT,ECM | |
13014 | 1000 FORMAT(' XKSAMP: kin. limit for valence-x', | |
13015 | & ' thresholds not allowed (',2E9.3,')') | |
13016 | C XVTHR = XVMAX-XDTHR | |
13017 | C IF (XVTHR.LT.ZERO) STOP | |
13018 | STOP | |
13019 | ENDIF | |
13020 | ||
13021 | * set eta for valence-x sampling (BETREJ) | |
13022 | * (UNON per default, UNOM used for projectile mesons only) | |
13023 | IF ((IJPROJ.NE.0).AND.(IBPROJ.EQ.0)) THEN | |
13024 | UNOPRV = UNOM | |
13025 | ELSE | |
13026 | UNOPRV = UNON | |
13027 | ENDIF | |
13028 | ||
13029 | * (2) select parton x-values of interacting projectile nucleons | |
13030 | *----------------------------------------------------------------------- | |
13031 | ||
13032 | IXPV = 0 | |
13033 | IXPS = 0 | |
13034 | ||
13035 | DO 100 IPP=1,IP | |
13036 | * get interacting projectile nucleon as sampled by Glauber | |
13037 | IF (JSSH(IPP).NE.0) THEN | |
13038 | IXSTMP = IXPS | |
13039 | IXVTMP = IXPV | |
13040 | 99 CONTINUE | |
13041 | IXPS = IXSTMP | |
13042 | IXPV = IXVTMP | |
13043 | * JIPP is the actual number of sea-pairs sampled for this nucleon | |
13044 | JIPP = MIN(JSSH(IPP)-1,NSMAX) | |
13045 | 41 CONTINUE | |
13046 | XXSEA = ZERO | |
13047 | IF (JIPP.GT.0) THEN | |
13048 | XSMAX = XXSEAM-2.0D0*DBLE(JIPP)*XSTHR | |
13049 | *??? | |
13050 | IF (XSTHR.GE.XSMAX) THEN | |
13051 | JIPP = JIPP-1 | |
13052 | GOTO 41 | |
13053 | ENDIF | |
13054 | ||
13055 | *>>>get x-values of sea-quark pairs | |
13056 | NSCOUN = 0 | |
13057 | PLW = 0.5D0 | |
13058 | 40 CONTINUE | |
13059 | * accumulator for sea x-values | |
13060 | XXSEA = ZERO | |
13061 | NSCOUN = NSCOUN+1 | |
13062 | IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0 | |
13063 | IF (NSCOUN.GT.NSEA) THEN | |
13064 | * decrease the number of interactions after NSEA trials | |
13065 | JIPP = JIPP-1 | |
13066 | NSCOUN = 0 | |
13067 | ENDIF | |
13068 | DO 70 ISQ=1,JIPP | |
13069 | * sea-quarks | |
13070 | IF (IPSQ(IXPS+1).LE.2) THEN | |
13071 | **sr 8.4.98 (1/sqrt(x)) | |
13072 | C XPSQI = DT_SAMPEX(XSTHR,XSMAX) | |
13073 | C XPSQI = DT_SAMSQX(XSTHR,XSMAX) | |
13074 | XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW) | |
13075 | ** | |
13076 | ELSE | |
13077 | IF (XSMAX.GT.XSTHR+BSQMA) THEN | |
13078 | XPSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA) | |
13079 | ELSE | |
13080 | **sr 8.4.98 (1/sqrt(x)) | |
13081 | C XPSQI = DT_SAMPEX(XSTHR,XSMAX) | |
13082 | C XPSQI = DT_SAMSQX(XSTHR,XSMAX) | |
13083 | XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW) | |
13084 | ** | |
13085 | ENDIF | |
13086 | ENDIF | |
13087 | * sea-antiquarks | |
13088 | IF (IPSAQ(IXPS+1).GE.-2) THEN | |
13089 | **sr 8.4.98 (1/sqrt(x)) | |
13090 | C XPSAQI = DT_SAMPEX(XSTHR,XSMAX) | |
13091 | C XPSAQI = DT_SAMSQX(XSTHR,XSMAX) | |
13092 | XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW) | |
13093 | ** | |
13094 | ELSE | |
13095 | IF (XSMAX.GT.XSTHR+BSQMA) THEN | |
13096 | XPSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA) | |
13097 | ELSE | |
13098 | **sr 8.4.98 (1/sqrt(x)) | |
13099 | C XPSAQI = DT_SAMPEX(XSTHR,XSMAX) | |
13100 | C XPSAQI = DT_SAMSQX(XSTHR,XSMAX) | |
13101 | XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW) | |
13102 | ** | |
13103 | ENDIF | |
13104 | ENDIF | |
13105 | XXSEA = XXSEA+XPSQI+XPSAQI | |
13106 | * check for maximum allowed sea x-value | |
13107 | IF (XXSEA.GE.XXSEAM) THEN | |
13108 | IXPS = IXPS-ISQ+1 | |
13109 | GOTO 40 | |
13110 | ENDIF | |
13111 | * accept this sea-quark pair | |
13112 | IXPS = IXPS+1 | |
13113 | XPSQ(IXPS) = XPSQI | |
13114 | XPSAQ(IXPS) = XPSAQI | |
13115 | IFROSP(IXPS) = IPP | |
13116 | ZUOSP(IXPS) = .TRUE. | |
13117 | 70 CONTINUE | |
13118 | ENDIF | |
13119 | ||
13120 | *>>>get x-values of valence partons | |
13121 | * valence quark | |
13122 | IF (XVTHR.GT.0.05D0) THEN | |
13123 | XVHI = ONE-XXSEA-XDTHR | |
13124 | XPVQI = DT_BETREJ(OHALF,UNOPRV,XVTHR,XVHI) | |
13125 | ELSE | |
13126 | 90 CONTINUE | |
13127 | XPVQI = DT_DBETAR(OHALF,UNOPRV) | |
13128 | IF ((XPVQI.LT.XVTHR).OR.(ONE-XPVQI-XXSEA.LT.XDTHR)) | |
13129 | & GOTO 90 | |
13130 | ENDIF | |
13131 | * valence diquark | |
13132 | XPVDI = ONE-XPVQI-XXSEA | |
13133 | * reject according to x**1.5 | |
13134 | XDTMP = XPVDI**1.5D0 | |
13135 | IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 99 | |
13136 | * accept these valence partons | |
13137 | IXPV = IXPV+1 | |
13138 | XPVQ(IXPV) = XPVQI | |
13139 | XPVD(IXPV) = XPVDI | |
13140 | IFROVP(IXPV) = IPP | |
13141 | ITOVP(IPP) = IXPV | |
13142 | ZUOVP(IXPV) = .TRUE. | |
13143 | ||
13144 | ENDIF | |
13145 | 100 CONTINUE | |
13146 | ||
13147 | * (3) select parton x-values of interacting target nucleons | |
13148 | *----------------------------------------------------------------------- | |
13149 | ||
13150 | IXTV = 0 | |
13151 | IXTS = 0 | |
13152 | ||
13153 | DO 170 ITT=1,IT | |
13154 | * get interacting target nucleon as sampled by Glauber | |
13155 | IF (JTSH(ITT).NE.0) THEN | |
13156 | IXSTMP = IXTS | |
13157 | IXVTMP = IXTV | |
13158 | 169 CONTINUE | |
13159 | IXTS = IXSTMP | |
13160 | IXTV = IXVTMP | |
13161 | * JITT is the actual number of sea-pairs sampled for this nucleon | |
13162 | JITT = MIN(JTSH(ITT)-1,NSMAX) | |
13163 | 111 CONTINUE | |
13164 | XXSEA = ZERO | |
13165 | IF (JITT.GT.0) THEN | |
13166 | XSMAX = XXSEAM-2.0D0*DBLE(JITT)*XSTHR | |
13167 | *??? | |
13168 | IF (XSTHR.GE.XSMAX) THEN | |
13169 | JITT = JITT-1 | |
13170 | GOTO 111 | |
13171 | ENDIF | |
13172 | ||
13173 | *>>>get x-values of sea-quark pairs | |
13174 | NSCOUN = 0 | |
13175 | PLW = 0.5D0 | |
13176 | 110 CONTINUE | |
13177 | * accumulator for sea x-values | |
13178 | XXSEA = ZERO | |
13179 | NSCOUN = NSCOUN+1 | |
13180 | IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0 | |
13181 | IF (NSCOUN.GT.NSEA)THEN | |
13182 | * decrease the number of interactions after NSEA trials | |
13183 | JITT = JITT-1 | |
13184 | NSCOUN = 0 | |
13185 | ENDIF | |
13186 | DO 140 ISQ=1,JITT | |
13187 | * sea-quarks | |
13188 | IF (ITSQ(IXTS+1).LE.2) THEN | |
13189 | **sr 8.4.98 (1/sqrt(x)) | |
13190 | C XTSQI = DT_SAMPEX(XSTHR,XSMAX) | |
13191 | C XTSQI = DT_SAMSQX(XSTHR,XSMAX) | |
13192 | XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW) | |
13193 | ** | |
13194 | ELSE | |
13195 | IF (XSMAX.GT.XSTHR+BSQMA) THEN | |
13196 | XTSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA) | |
13197 | ELSE | |
13198 | **sr 8.4.98 (1/sqrt(x)) | |
13199 | C XTSQI = DT_SAMPEX(XSTHR,XSMAX) | |
13200 | C XTSQI = DT_SAMSQX(XSTHR,XSMAX) | |
13201 | XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW) | |
13202 | ** | |
13203 | ENDIF | |
13204 | ENDIF | |
13205 | * sea-antiquarks | |
13206 | IF (ITSAQ(IXTS+1).GE.-2) THEN | |
13207 | **sr 8.4.98 (1/sqrt(x)) | |
13208 | C XTSAQI = DT_SAMPEX(XSTHR,XSMAX) | |
13209 | C XTSAQI = DT_SAMSQX(XSTHR,XSMAX) | |
13210 | XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW) | |
13211 | ** | |
13212 | ELSE | |
13213 | IF (XSMAX.GT.XSTHR+BSQMA) THEN | |
13214 | XTSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA) | |
13215 | ELSE | |
13216 | **sr 8.4.98 (1/sqrt(x)) | |
13217 | C XTSAQI = DT_SAMPEX(XSTHR,XSMAX) | |
13218 | C XTSAQI = DT_SAMSQX(XSTHR,XSMAX) | |
13219 | XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW) | |
13220 | ** | |
13221 | ENDIF | |
13222 | ENDIF | |
13223 | XXSEA = XXSEA+XTSQI+XTSAQI | |
13224 | * check for maximum allowed sea x-value | |
13225 | IF (XXSEA.GE.XXSEAM) THEN | |
13226 | IXTS = IXTS-ISQ+1 | |
13227 | GOTO 110 | |
13228 | ENDIF | |
13229 | * accept this sea-quark pair | |
13230 | IXTS = IXTS+1 | |
13231 | XTSQ(IXTS) = XTSQI | |
13232 | XTSAQ(IXTS) = XTSAQI | |
13233 | IFROST(IXTS) = ITT | |
13234 | ZUOST(IXTS) = .TRUE. | |
13235 | 140 CONTINUE | |
13236 | ENDIF | |
13237 | ||
13238 | *>>>get x-values of valence partons | |
13239 | * valence quark | |
13240 | IF (XVTHR.GT.0.05D0) THEN | |
13241 | XVHI = ONE-XXSEA-XDTHR | |
13242 | XTVQI = DT_BETREJ(OHALF,UNON,XVTHR,XVHI) | |
13243 | ELSE | |
13244 | 160 CONTINUE | |
13245 | XTVQI = DT_DBETAR(OHALF,UNON) | |
13246 | IF ((XTVQI.LT.XVTHR).OR.(ONE-XTVQI-XXSEA.LT.XDTHR)) | |
13247 | & GOTO 160 | |
13248 | ENDIF | |
13249 | * valence diquark | |
13250 | XTVDI = ONE-XTVQI-XXSEA | |
13251 | * reject according to x**1.5 | |
13252 | XDTMP = XTVDI**1.5D0 | |
13253 | IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 169 | |
13254 | * accept these valence partons | |
13255 | IXTV = IXTV+1 | |
13256 | XTVQ(IXTV) = XTVQI | |
13257 | XTVD(IXTV) = XTVDI | |
13258 | IFROVT(IXTV) = ITT | |
13259 | ITOVT(ITT) = IXTV | |
13260 | ZUOVT(IXTV) = .TRUE. | |
13261 | ||
13262 | ENDIF | |
13263 | 170 CONTINUE | |
13264 | ||
13265 | * (4) get valence-valence chains | |
13266 | *----------------------------------------------------------------------- | |
13267 | ||
13268 | NVV = 0 | |
13269 | DO 240 I=1,NN | |
13270 | INTLO(I) = .TRUE. | |
13271 | IPVAL = ITOVP(INTER1(I)) | |
13272 | ITVAL = ITOVT(INTER2(I)) | |
13273 | IF (ZUOVP(IPVAL).AND.ZUOVT(ITVAL)) THEN | |
13274 | INTLO(I) = .FALSE. | |
13275 | ZUOVP(IPVAL) = .FALSE. | |
13276 | ZUOVT(ITVAL) = .FALSE. | |
13277 | NVV = NVV+1 | |
13278 | ISKPCH(8,NVV) = 0 | |
13279 | INTVV1(NVV) = IPVAL | |
13280 | INTVV2(NVV) = ITVAL | |
13281 | ENDIF | |
13282 | 240 CONTINUE | |
13283 | ||
13284 | * (5) get sea-valence chains | |
13285 | *----------------------------------------------------------------------- | |
13286 | ||
13287 | NSV = 0 | |
13288 | NDV = 0 | |
13289 | PLW = 0.5D0 | |
13290 | DO 270 I=1,NN | |
13291 | IF (INTLO(I)) THEN | |
13292 | IPVAL = ITOVP(INTER1(I)) | |
13293 | ITVAL = ITOVT(INTER2(I)) | |
13294 | DO 250 J=1,IXPS | |
13295 | IF (ZUOSP(J).AND.(IFROSP(J).EQ.INTER1(I)).AND. | |
13296 | & ZUOVT(ITVAL)) THEN | |
13297 | ZUOSP(J) = .FALSE. | |
13298 | ZUOVT(ITVAL) = .FALSE. | |
13299 | INTLO(I) = .FALSE. | |
13300 | IF (LSEADI.AND.(DT_RNDM(PLW).GT.FRCDIQ)) THEN | |
13301 | * sample sea-diquark pair | |
13302 | CALL DT_SAMSDQ(ECM,ITVAL,J,2,IREJ1) | |
13303 | IF (IREJ1.EQ.0) GOTO 260 | |
13304 | ENDIF | |
13305 | NSV = NSV+1 | |
13306 | ISKPCH(4,NSV) = 0 | |
13307 | INTSV1(NSV) = J | |
13308 | INTSV2(NSV) = ITVAL | |
13309 | ||
13310 | *>>>correct chain kinematics according to minimum chain masses | |
13311 | * the actual chain masses | |
13312 | AMSVQ1 = XPSQ(J) *XTVD(ITVAL)*ECM**2 | |
13313 | AMSVQ2 = XPSAQ(J)*XTVQ(ITVAL)*ECM**2 | |
13314 | * get lower mass cuts | |
13315 | IF (IPSQ(J).EQ.3) THEN | |
13316 | * q being s-quark | |
13317 | AMCHK1 = AMAS | |
13318 | AMCHK2 = AMIS | |
13319 | ELSE | |
13320 | * q being u/d-quark | |
13321 | AMCHK1 = AMAU | |
13322 | AMCHK2 = AMIU | |
13323 | ENDIF | |
13324 | * q-qq chain | |
13325 | * chain mass above minimum - resampling of sea-q x-value | |
13326 | IF (AMSVQ1.GT.AMCHK1) THEN | |
13327 | XPSQTH = AMCHK1/(XTVD(ITVAL)*ECM**2) | |
13328 | **sr 8.4.98 (1/sqrt(x)) | |
13329 | C XPSQXX = DT_SAMPEX(XPSQTH,XPSQ(J)) | |
13330 | C XPSQXX = DT_SAMSQX(XPSQTH,XPSQ(J)) | |
13331 | XPSQXX = DT_SAMPLW(XPSQTH,XPSQ(J),PLW) | |
13332 | ** | |
13333 | XPVD(IPVAL) = XPVD(IPVAL)+XPSQ(J)-XPSQXX | |
13334 | XPSQ(J) = XPSQXX | |
13335 | * chain mass below minimum - reset sea-q x-value and correct | |
13336 | * diquark-x of the same nucleon | |
13337 | ELSEIF (AMSVQ1.LT.AMCHK1) THEN | |
13338 | XPSQW = AMCHK1/(XTVD(ITVAL)*ECM**2) | |
13339 | DXPSQ = XPSQW-XPSQ(J) | |
13340 | IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN | |
13341 | XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ | |
13342 | XPSQ(J) = XPSQW | |
13343 | ENDIF | |
13344 | ENDIF | |
13345 | * aq-q chain | |
13346 | * chain mass below minimum - reset sea-aq x-value and correct | |
13347 | * diquark-x of the same nucleon | |
13348 | IF (AMSVQ2.LT.AMCHK2) THEN | |
13349 | XPSQW = AMCHK2/(XTVQ(ITVAL)*ECM**2) | |
13350 | DXPSQ = XPSQW-XPSAQ(J) | |
13351 | IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN | |
13352 | XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ | |
13353 | XPSAQ(J) = XPSQW | |
13354 | ENDIF | |
13355 | ENDIF | |
13356 | *>>>end of chain mass correction | |
13357 | ||
13358 | GOTO 260 | |
13359 | ENDIF | |
13360 | 250 CONTINUE | |
13361 | ENDIF | |
13362 | 260 CONTINUE | |
13363 | 270 CONTINUE | |
13364 | ||
13365 | * (6) get valence-sea chains | |
13366 | *----------------------------------------------------------------------- | |
13367 | ||
13368 | NVS = 0 | |
13369 | NVD = 0 | |
13370 | DO 300 I=1,NN | |
13371 | IF (INTLO(I)) THEN | |
13372 | IPVAL = ITOVP(INTER1(I)) | |
13373 | ITVAL = ITOVT(INTER2(I)) | |
13374 | DO 280 J=1,IXTS | |
13375 | IF (ZUOVP(IPVAL).AND.ZUOST(J).AND. | |
13376 | & (IFROST(J).EQ.INTER2(I))) THEN | |
13377 | ZUOST(J) = .FALSE. | |
13378 | ZUOVP(IPVAL) = .FALSE. | |
13379 | INTLO(I) = .FALSE. | |
13380 | IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN | |
13381 | * sample sea-diquark pair | |
13382 | CALL DT_SAMSDQ(ECM,IPVAL,J,1,IREJ1) | |
13383 | IF (IREJ1.EQ.0) GOTO 290 | |
13384 | ENDIF | |
13385 | NVS = NVS + 1 | |
13386 | ISKPCH(6,NVS) = 0 | |
13387 | INTVS1(NVS) = IPVAL | |
13388 | INTVS2(NVS) = J | |
13389 | ||
13390 | *>>>correct chain kinematics according to minimum chain masses | |
13391 | * the actual chain masses | |
13392 | AMVSQ1 = XPVQ(IPVAL)*XTSAQ(J)*ECM**2 | |
13393 | AMVSQ2 = XPVD(IPVAL)*XTSQ(J) *ECM**2 | |
13394 | * get lower mass cuts | |
13395 | IF (ITSQ(J).EQ.3) THEN | |
13396 | * q being s-quark | |
13397 | AMCHK1 = AMIS | |
13398 | AMCHK2 = AMAS | |
13399 | ELSE | |
13400 | * q being u/d-quark | |
13401 | AMCHK1 = AMIU | |
13402 | AMCHK2 = AMAU | |
13403 | ENDIF | |
13404 | * q-aq chain | |
13405 | * chain mass below minimum - reset sea-aq x-value and correct | |
13406 | * diquark-x of the same nucleon | |
13407 | IF (AMVSQ1.LT.AMCHK1) THEN | |
13408 | XTSQW = AMCHK1/(XPVQ(IPVAL)*ECM**2) | |
13409 | DXTSQ = XTSQW-XTSAQ(J) | |
13410 | IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN | |
13411 | XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ | |
13412 | XTSAQ(J) = XTSQW | |
13413 | ENDIF | |
13414 | ENDIF | |
13415 | * qq-q chain | |
13416 | * chain mass above minimum - resampling of sea-q x-value | |
13417 | IF (AMVSQ2.GT.AMCHK2) THEN | |
13418 | XTSQTH = AMCHK2/(XPVD(IPVAL)*ECM**2) | |
13419 | **sr 8.4.98 (1/sqrt(x)) | |
13420 | C XTSQXX = DT_SAMPEX(XTSQTH,XTSQ(J)) | |
13421 | C XTSQXX = DT_SAMSQX(XTSQTH,XTSQ(J)) | |
13422 | XTSQXX = DT_SAMPLW(XTSQTH,XTSQ(J),PLW) | |
13423 | ** | |
13424 | XTVD(ITVAL) = XTVD(ITVAL)+XTSQ(J)-XTSQXX | |
13425 | XTSQ(J) = XTSQXX | |
13426 | * chain mass below minimum - reset sea-q x-value and correct | |
13427 | * diquark-x of the same nucleon | |
13428 | ELSEIF (AMVSQ2.LT.AMCHK2) THEN | |
13429 | XTSQW = AMCHK2/(XPVD(IPVAL)*ECM**2) | |
13430 | DXTSQ = XTSQW-XTSQ(J) | |
13431 | IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN | |
13432 | XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ | |
13433 | XTSQ(J) = XTSQW | |
13434 | ENDIF | |
13435 | ENDIF | |
13436 | *>>>end of chain mass correction | |
13437 | ||
13438 | GOTO 290 | |
13439 | ENDIF | |
13440 | 280 CONTINUE | |
13441 | ENDIF | |
13442 | 290 CONTINUE | |
13443 | 300 CONTINUE | |
13444 | ||
13445 | * (7) get sea-sea chains | |
13446 | *----------------------------------------------------------------------- | |
13447 | ||
13448 | NSS = 0 | |
13449 | NDS = 0 | |
13450 | NSD = 0 | |
13451 | DO 420 I=1,NN | |
13452 | IF (INTLO(I)) THEN | |
13453 | IPVAL = ITOVP(INTER1(I)) | |
13454 | ITVAL = ITOVT(INTER2(I)) | |
13455 | * loop over target partons not yet matched | |
13456 | DO 400 J=1,IXTS | |
13457 | IF (ZUOST(J).AND.(IFROST(J).EQ.INTER2(I))) THEN | |
13458 | * loop over projectile partons not yet matched | |
13459 | DO 390 JJ=1,IXPS | |
13460 | IF (ZUOSP(JJ).AND.(IFROSP(JJ).EQ.INTER1(I))) THEN | |
13461 | ZUOSP(JJ) = .FALSE. | |
13462 | ZUOST(J) = .FALSE. | |
13463 | INTLO(I) = .FALSE. | |
13464 | NSS = NSS+1 | |
13465 | ISKPCH(1,NSS) = 0 | |
13466 | INTSS1(NSS) = JJ | |
13467 | INTSS2(NSS) = J | |
13468 | ||
13469 | *---->chain recombination option | |
13470 | VALFRA = DBLE(NVV/(NVV+IXPS+IXTS)) | |
13471 | IF (IRECOM.EQ.1.AND.(DT_RNDM(BSQMA).GT.VALFRA)) | |
13472 | & THEN | |
13473 | * sea-sea chains may recombine with valence-valence chains | |
13474 | * only if they have the same projectile or target nucleon | |
13475 | DO 4201 IVV=1,NVV | |
13476 | IF (ISKPCH(8,IVV).NE.99) THEN | |
13477 | IXVPR = INTVV1(IVV) | |
13478 | IXVTA = INTVV2(IVV) | |
13479 | IF ((INTER1(I).EQ.IFROVP(IXVPR)).OR. | |
13480 | & (INTER2(I).EQ.IFROVT(IXVTA))) THEN | |
13481 | * recombination possible, drop old v-v and s-s chains | |
13482 | ISKPCH(1,NSS) = 99 | |
13483 | ISKPCH(8,IVV) = 99 | |
13484 | ||
13485 | * (a) assign new s-v chains | |
13486 | * ~~~~~~~~~~~~~~~~~~~~~~~~~ | |
13487 | IF (LSEADI.AND. | |
13488 | & (DT_RNDM(VALFRA).GT.FRCDIQ)) | |
13489 | & THEN | |
13490 | * sample sea-diquark pair | |
13491 | CALL DT_SAMSDQ(ECM,IXVTA,JJ,2, | |
13492 | & IREJ1) | |
13493 | IF (IREJ1.EQ.0) GOTO 4202 | |
13494 | ENDIF | |
13495 | NSV = NSV+1 | |
13496 | ISKPCH(4,NSV) = 0 | |
13497 | INTSV1(NSV) = JJ | |
13498 | INTSV2(NSV) = IXVTA | |
13499 | *>>>>>>>>>>>correct chain kinematics according to minimum chain masses | |
13500 | * the actual chain masses | |
13501 | AMSVQ1 = XPSQ(JJ) *XTVD(IXVTA) | |
13502 | & *ECM**2 | |
13503 | AMSVQ2 = XPSAQ(JJ)*XTVQ(IXVTA) | |
13504 | & *ECM**2 | |
13505 | * get lower mass cuts | |
13506 | IF (IPSQ(JJ).EQ.3) THEN | |
13507 | * q being s-quark | |
13508 | AMCHK1 = AMAS | |
13509 | AMCHK2 = AMIS | |
13510 | ELSE | |
13511 | * q being u/d-quark | |
13512 | AMCHK1 = AMAU | |
13513 | AMCHK2 = AMIU | |
13514 | ENDIF | |
13515 | * q-qq chain | |
13516 | * chain mass above minimum - resampling of sea-q x-value | |
13517 | IF (AMSVQ1.GT.AMCHK1) THEN | |
13518 | XPSQTH = | |
13519 | & AMCHK1/(XTVD(IXVTA)*ECM**2) | |
13520 | **sr 8.4.98 (1/sqrt(x)) | |
13521 | XPSQXX = | |
13522 | & DT_SAMPLW(XPSQTH,XPSQ(JJ),PLW) | |
13523 | C & DT_SAMSQX(XPSQTH,XPSQ(JJ)) | |
13524 | C & DT_SAMPEX(XPSQTH,XPSQ(JJ)) | |
13525 | ** | |
13526 | XPVD(IPVAL) = | |
13527 | & XPVD(IPVAL)+XPSQ(JJ)-XPSQXX | |
13528 | XPSQ(JJ) = XPSQXX | |
13529 | * chain mass below minimum - reset sea-q x-value and correct | |
13530 | * diquark-x of the same nucleon | |
13531 | ELSEIF (AMSVQ1.LT.AMCHK1) THEN | |
13532 | XPSQW = | |
13533 | & AMCHK1/(XTVD(IXVTA)*ECM**2) | |
13534 | DXPSQ = XPSQW-XPSQ(JJ) | |
13535 | IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) | |
13536 | & THEN | |
13537 | XPVD(IPVAL) = | |
13538 | & XPVD(IPVAL)-DXPSQ | |
13539 | XPSQ(JJ) = XPSQW | |
13540 | ENDIF | |
13541 | ENDIF | |
13542 | * aq-q chain | |
13543 | * chain mass below minimum - reset sea-aq x-value and correct | |
13544 | * diquark-x of the same nucleon | |
13545 | IF (AMSVQ2.LT.AMCHK2) THEN | |
13546 | XPSQW = | |
13547 | & AMCHK2/(XTVQ(IXVTA)*ECM**2) | |
13548 | DXPSQ = XPSQW-XPSAQ(JJ) | |
13549 | IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) | |
13550 | & THEN | |
13551 | XPVD(IPVAL) = | |
13552 | & XPVD(IPVAL)-DXPSQ | |
13553 | XPSAQ(JJ) = XPSQW | |
13554 | ENDIF | |
13555 | ENDIF | |
13556 | *>>>>>>>>>>>end of chain mass correction | |
13557 | 4202 CONTINUE | |
13558 | ||
13559 | * (b) assign new v-s chains | |
13560 | * ~~~~~~~~~~~~~~~~~~~~~~~~~ | |
13561 | IF (LSEADI.AND.( | |
13562 | & DT_RNDM(AMSVQ2).GT.FRCDIQ)) | |
13563 | & THEN | |
13564 | * sample sea-diquark pair | |
13565 | CALL DT_SAMSDQ(ECM,IXVPR,J,1, | |
13566 | & IREJ1) | |
13567 | IF (IREJ1.EQ.0) GOTO 4203 | |
13568 | ENDIF | |
13569 | NVS = NVS+1 | |
13570 | ISKPCH(6,NVS) = 0 | |
13571 | INTVS1(NVS) = IXVPR | |
13572 | INTVS2(NVS) = J | |
13573 | *>>>>>>>>>>>correct chain kinematics according to minimum chain masses | |
13574 | * the actual chain masses | |
13575 | AMVSQ1 = XPVQ(IXVPR)*XTSAQ(J)*ECM**2 | |
13576 | AMVSQ2 = XPVD(IXVPR)*XTSQ(J) *ECM**2 | |
13577 | * get lower mass cuts | |
13578 | IF (ITSQ(J).EQ.3) THEN | |
13579 | * q being s-quark | |
13580 | AMCHK1 = AMIS | |
13581 | AMCHK2 = AMAS | |
13582 | ELSE | |
13583 | * q being u/d-quark | |
13584 | AMCHK1 = AMIU | |
13585 | AMCHK2 = AMAU | |
13586 | ENDIF | |
13587 | * q-aq chain | |
13588 | * chain mass below minimum - reset sea-aq x-value and correct | |
13589 | * diquark-x of the same nucleon | |
13590 | IF (AMVSQ1.LT.AMCHK1) THEN | |
13591 | XTSQW = | |
13592 | & AMCHK1/(XPVQ(IXVPR)*ECM**2) | |
13593 | DXTSQ = XTSQW-XTSAQ(J) | |
13594 | IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) | |
13595 | & THEN | |
13596 | XTVD(ITVAL) = | |
13597 | & XTVD(ITVAL)-DXTSQ | |
13598 | XTSAQ(J) = XTSQW | |
13599 | ENDIF | |
13600 | ENDIF | |
13601 | IF (AMVSQ2.GT.AMCHK2) THEN | |
13602 | XTSQTH = | |
13603 | & AMCHK2/(XPVD(IXVPR)*ECM**2) | |
13604 | **sr 8.4.98 (1/sqrt(x)) | |
13605 | XTSQXX = | |
13606 | & DT_SAMPLW(XTSQTH,XTSQ(J),PLW) | |
13607 | C & DT_SAMSQX(XTSQTH,XTSQ(J)) | |
13608 | C & DT_SAMPEX(XTSQTH,XTSQ(J)) | |
13609 | ** | |
13610 | XTVD(ITVAL) = | |
13611 | & XTVD(ITVAL)+XTSQ(J)-XTSQXX | |
13612 | XTSQ(J) = XTSQXX | |
13613 | ELSEIF (AMVSQ2.LT.AMCHK2) THEN | |
13614 | XTSQW = | |
13615 | & AMCHK2/(XPVD(IXVPR)*ECM**2) | |
13616 | DXTSQ = XTSQW-XTSQ(J) | |
13617 | IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) | |
13618 | & THEN | |
13619 | XTVD(ITVAL) = | |
13620 | & XTVD(ITVAL)-DXTSQ | |
13621 | XTSQ(J) = XTSQW | |
13622 | ENDIF | |
13623 | ENDIF | |
13624 | *>>>>>>>>>end of chain mass correction | |
13625 | 4203 CONTINUE | |
13626 | * jump out of s-s chain loop | |
13627 | GOTO 420 | |
13628 | ENDIF | |
13629 | ENDIF | |
13630 | 4201 CONTINUE | |
13631 | ENDIF | |
13632 | *---->end of chain recombination option | |
13633 | ||
13634 | * sample sea-diquark pair (projectile) | |
13635 | IF (LSEADI.AND.(DT_RNDM(BSQMA).GT.FRCDIQ)) THEN | |
13636 | CALL DT_SAMSDQ(ECM,J,JJ,4,IREJ1) | |
13637 | IF (IREJ1.EQ.0) THEN | |
13638 | ISKPCH(1,NSS) = 99 | |
13639 | GOTO 410 | |
13640 | ENDIF | |
13641 | ENDIF | |
13642 | * sample sea-diquark pair (target) | |
13643 | IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN | |
13644 | CALL DT_SAMSDQ(ECM,JJ,J,3,IREJ1) | |
13645 | IF (IREJ1.EQ.0) THEN | |
13646 | ISKPCH(1,NSS) = 99 | |
13647 | GOTO 410 | |
13648 | ENDIF | |
13649 | ENDIF | |
13650 | *>>>>>correct chain kinematics according to minimum chain masses | |
13651 | * the actual chain masses | |
13652 | SSMA1Q = XPSQ(JJ) *XTSAQ(J)*ECM**2 | |
13653 | SSMA2Q = XPSAQ(JJ)*XTSQ(J) *ECM**2 | |
13654 | * check for lower mass cuts | |
13655 | IF ((SSMA1Q.LT.SSMIMQ).OR. | |
13656 | & (SSMA2Q.LT.SSMIMQ)) THEN | |
13657 | IPVAL = ITOVP(INTER1(I)) | |
13658 | ITVAL = ITOVT(INTER2(I)) | |
13659 | IF ((XPVD(IPVAL).GT.XDTHR+3.5D0*XSSTHR).AND. | |
13660 | & (XTVD(ITVAL).GT.XDTHR+3.5D0*XSSTHR))THEN | |
13661 | * maximum allowed x values for sea quarks | |
13662 | XSPMAX = ONE-XPVQ(IPVAL)-XDTHR- | |
13663 | & 1.2D0*XSSTHR | |
13664 | XSTMAX = ONE-XTVQ(ITVAL)-XDTHR- | |
13665 | & 1.2D0*XSSTHR | |
13666 | * resampling of x values not possible - skip sea-sea chains | |
13667 | IF ((XSPMAX.LE.XSSTHR+0.05D0).OR. | |
13668 | & (XSTMAX.LE.XSSTHR+0.05D0)) GOTO 380 | |
13669 | * resampling of x for projectile sea quark pair | |
13670 | ICOUS = 0 | |
13671 | 310 CONTINUE | |
13672 | ICOUS = ICOUS+1 | |
13673 | IF (XSSTHR.GT.0.05D0) THEN | |
13674 | XPSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR, | |
13675 | & XSPMAX) | |
13676 | XPSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR, | |
13677 | & XSPMAX) | |
13678 | ELSE | |
13679 | 320 CONTINUE | |
13680 | XPSQI = DT_DBETAR(XSEACU,UNOSEA) | |
13681 | IF ((XPSQI.LT.XSSTHR).OR. | |
13682 | & (XPSQI.GT.XSPMAX)) GOTO 320 | |
13683 | 330 CONTINUE | |
13684 | XPSAQI = DT_DBETAR(XSEACU,UNOSEA) | |
13685 | IF ((XPSAQI.LT.XSSTHR).OR. | |
13686 | & (XPSAQI.GT.XSPMAX)) GOTO 330 | |
13687 | ENDIF | |
13688 | * final test of remaining x for projectile diquark | |
13689 | XPVDCO = XPVD(IPVAL)-XPSQI-XPSAQI | |
13690 | & +XPSQ(JJ)+XPSAQ(JJ) | |
13691 | IF (XPVDCO.LE.XDTHR) THEN | |
13692 | *!!! | |
13693 | C IF (ICOUS.LT.5) GOTO 310 | |
13694 | IF (ICOUS.LT.0.5D0) GOTO 310 | |
13695 | GOTO 380 | |
13696 | ENDIF | |
13697 | * resampling of x for target sea quark pair | |
13698 | ICOUS = 0 | |
13699 | 350 CONTINUE | |
13700 | ICOUS = ICOUS+1 | |
13701 | IF (XSSTHR.GT.0.05D0) THEN | |
13702 | XTSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR, | |
13703 | & XSTMAX) | |
13704 | XTSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR, | |
13705 | & XSTMAX) | |
13706 | ELSE | |
13707 | 360 CONTINUE | |
13708 | XTSQI = DT_DBETAR(XSEACU,UNOSEA) | |
13709 | IF ((XTSQI.LT.XSSTHR).OR. | |
13710 | & (XTSQI.GT.XSTMAX)) GOTO 360 | |
13711 | 370 CONTINUE | |
13712 | XTSAQI = DT_DBETAR(XSEACU,UNOSEA) | |
13713 | IF ((XTSAQI.LT.XSSTHR).OR. | |
13714 | & (XTSAQI.GT.XSTMAX)) GOTO 370 | |
13715 | ENDIF | |
13716 | * final test of remaining x for target diquark | |
13717 | XTVDCO = XTVD(ITVAL)-XTSQI-XTSAQI | |
13718 | & +XTSQ(J)+XTSAQ(J) | |
13719 | IF (XTVDCO.LT.XDTHR) THEN | |
13720 | IF (ICOUS.LT.5) GOTO 350 | |
13721 | GOTO 380 | |
13722 | ENDIF | |
13723 | XPVD(IPVAL) = XPVDCO | |
13724 | XTVD(ITVAL) = XTVDCO | |
13725 | XPSQ(JJ) = XPSQI | |
13726 | XPSAQ(JJ) = XPSAQI | |
13727 | XTSQ(J) = XTSQI | |
13728 | XTSAQ(J) = XTSAQI | |
13729 | *>>>>>end of chain mass correction | |
13730 | GOTO 410 | |
13731 | ENDIF | |
13732 | * come here to discard s-s interaction | |
13733 | * resampling of x values not allowed or unsuccessful | |
13734 | 380 CONTINUE | |
13735 | INTLO(I) = .FALSE. | |
13736 | ZUOST(J) = .TRUE. | |
13737 | ZUOSP(JJ) = .TRUE. | |
13738 | NSS = NSS-1 | |
13739 | ENDIF | |
13740 | * consider next s-s interaction | |
13741 | GOTO 410 | |
13742 | ENDIF | |
13743 | 390 CONTINUE | |
13744 | ENDIF | |
13745 | 400 CONTINUE | |
13746 | ENDIF | |
13747 | 410 CONTINUE | |
13748 | 420 CONTINUE | |
13749 | ||
13750 | * correct x-values of valence quarks for non-matching sea quarks | |
13751 | DO 430 I=1,IXPS | |
13752 | IF (ZUOSP(I)) THEN | |
13753 | IPVAL = ITOVP(IFROSP(I)) | |
13754 | XPVQ(IPVAL) = XPVQ(IPVAL)+XPSQ(I)+XPSAQ(I) | |
13755 | XPSQ(I) = ZERO | |
13756 | XPSAQ(I) = ZERO | |
13757 | ZUOSP(I) = .FALSE. | |
13758 | ENDIF | |
13759 | 430 CONTINUE | |
13760 | DO 440 I=1,IXTS | |
13761 | IF (ZUOST(I)) THEN | |
13762 | ITVAL = ITOVT(IFROST(I)) | |
13763 | XTVQ(ITVAL) = XTVQ(ITVAL)+XTSQ(I)+XTSAQ(I) | |
13764 | XTSQ(I) = ZERO | |
13765 | XTSAQ(I) = ZERO | |
13766 | ZUOST(I) = .FALSE. | |
13767 | ENDIF | |
13768 | 440 CONTINUE | |
13769 | DO 450 I=1,IXPV | |
13770 | IF (ZUOVP(I)) ISTHKK(IFROVP(I)) = 13 | |
13771 | 450 CONTINUE | |
13772 | DO 460 I=1,IXTV | |
13773 | IF (ZUOVT(I)) ISTHKK(IFROVT(I)+IP) = 14 | |
13774 | 460 CONTINUE | |
13775 | ||
13776 | RETURN | |
13777 | END | |
13778 | ||
13779 | *$ CREATE DT_SAMSDQ.FOR | |
13780 | *COPY DT_SAMSDQ | |
13781 | * | |
13782 | *===samsdq=============================================================* | |
13783 | * | |
13784 | SUBROUTINE DT_SAMSDQ(ECM,IDX1,IDX2,MODE,IREJ) | |
13785 | ||
13786 | ************************************************************************ | |
13787 | * SAMpling of Sea-DiQuarks * | |
13788 | * ECM cm-energy of the nucleon-nucleon system * | |
13789 | * IDX1,2 indices of x-values of the participating * | |
13790 | * partons (IDX2 is always the sea-q-pair to be * | |
13791 | * changed to sea-qq-pair) * | |
13792 | * MODE = 1 valence-q - sea-diq * | |
13793 | * = 2 sea-diq - valence-q * | |
13794 | * = 3 sea-q - sea-diq * | |
13795 | * = 4 sea-diq - sea-q * | |
13796 | * Based on DIQVS, DIQSV, DIQSSD, DIQDSS. * | |
13797 | * This version dated 17.10.95 is written by S. Roesler * | |
13798 | ************************************************************************ | |
13799 | ||
13800 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
13801 | SAVE | |
13802 | ||
13803 | PARAMETER (ZERO=0.0D0) | |
13804 | ||
13805 | * threshold values for x-sampling (DTUNUC 1.x) | |
13806 | COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA, | |
13807 | & SSMIMQ,VVMTHR | |
13808 | ||
13809 | * various options for treatment of partons (DTUNUC 1.x) | |
13810 | * (chain recombination, Cronin,..) | |
13811 | LOGICAL LCO2CR,LINTPT | |
13812 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, | |
13813 | & LCO2CR,LINTPT | |
13814 | ||
13815 | PARAMETER ( MAXNCL = 260, | |
13816 | ||
13817 | & MAXVQU = MAXNCL, | |
13818 | & MAXSQU = 20*MAXVQU, | |
13819 | & MAXINT = MAXVQU+MAXSQU) | |
13820 | ||
13821 | * x-values of partons (DTUNUC 1.x) | |
13822 | COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU), | |
13823 | & XTVQ(MAXVQU),XTVD(MAXVQU), | |
13824 | & XPSQ(MAXSQU),XPSAQ(MAXSQU), | |
13825 | & XTSQ(MAXSQU),XTSAQ(MAXSQU) | |
13826 | ||
13827 | * flavors of partons (DTUNUC 1.x) | |
13828 | COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU), | |
13829 | & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU), | |
13830 | & IPSQ(MAXSQU),IPSQ2(MAXSQU), | |
13831 | & IPSAQ(MAXSQU),IPSAQ2(MAXSQU), | |
13832 | & ITSQ(MAXSQU),ITSQ2(MAXSQU), | |
13833 | & ITSAQ(MAXSQU),ITSAQ2(MAXSQU), | |
13834 | & KKPROJ(MAXVQU),KKTARG(MAXVQU) | |
13835 | ||
13836 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) | |
13837 | COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD, | |
13838 | & IXPV,IXPS,IXTV,IXTS, | |
13839 | & INTVV1(MAXVQU),INTVV2(MAXVQU), | |
13840 | & INTSV1(MAXVQU),INTSV2(MAXVQU), | |
13841 | & INTVS1(MAXVQU),INTVS2(MAXVQU), | |
13842 | & INTSS1(MAXSQU),INTSS2(MAXSQU), | |
13843 | & INTDV1(MAXVQU),INTDV2(MAXVQU), | |
13844 | & INTVD1(MAXVQU),INTVD2(MAXVQU), | |
13845 | & INTDS1(MAXSQU),INTDS2(MAXSQU), | |
13846 | & INTSD1(MAXSQU),INTSD2(MAXSQU) | |
13847 | ||
13848 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) | |
13849 | COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU), | |
13850 | & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU) | |
13851 | ||
13852 | * auxiliary common for chain system storage (DTUNUC 1.x) | |
13853 | COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL) | |
13854 | ||
13855 | IREJ = 0 | |
13856 | * threshold-x for valence diquarks | |
13857 | XDTHR = CDQ/ECM | |
13858 | ||
13859 | GOTO (1,2,3,4) MODE | |
13860 | ||
13861 | *--------------------------------------------------------------------- | |
13862 | * proj. valence partons - targ. sea partons | |
13863 | * get x-values and flavors for target sea-diquark pair | |
13864 | ||
13865 | 1 CONTINUE | |
13866 | IDXVP = IDX1 | |
13867 | IDXST = IDX2 | |
13868 | ||
13869 | * index of corr. val-diquark-x in target nucleon | |
13870 | IDXVT = ITOVT(IFROST(IDXST)) | |
13871 | * available x above diquark thresholds for valence- and sea-diquarks | |
13872 | XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR | |
13873 | ||
13874 | IF (XXD.GE.ZERO) THEN | |
13875 | * x-values for the three diquarks of the target nucleon | |
13876 | RR1 = DT_RNDM(XXD) | |
13877 | RR2 = DT_RNDM(RR1) | |
13878 | RR3 = DT_RNDM(RR2) | |
13879 | SR123 = RR1+RR2+RR3 | |
13880 | XXTV = XDTHR+RR1*XXD/SR123 | |
13881 | XXTSQ = XDTHR+RR2*XXD/SR123 | |
13882 | XXTSAQ = XDTHR+RR3*XXD/SR123 | |
13883 | ELSE | |
13884 | XXTV = XTVD(IDXVT) | |
13885 | XXTSQ = XTSQ(IDXST) | |
13886 | XXTSAQ = XTSAQ(IDXST) | |
13887 | ENDIF | |
13888 | * flavor of the second quarks in the sea-diquark pair | |
13889 | ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ)) | |
13890 | ITSAQ2(IDXST) = -ITSQ2(IDXST) | |
13891 | * check masses of the new val-q - sea-qq, val-qq - sea-aqaq chains | |
13892 | AM1 = XXTSQ *XPVQ(IDXVP)*ECM**2 | |
13893 | AM2 = XXTSAQ*XPVD(IDXVP)*ECM**2 | |
13894 | IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND. | |
13895 | * ss-asas pair | |
13896 | & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN | |
13897 | IREJ = 1 | |
13898 | RETURN | |
13899 | ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND. | |
13900 | * at least one strange quark | |
13901 | & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN | |
13902 | IREJ = 1 | |
13903 | RETURN | |
13904 | ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN | |
13905 | IREJ = 1 | |
13906 | RETURN | |
13907 | ENDIF | |
13908 | * accept the new sea-diquark | |
13909 | XTVD(IDXVT) = XXTV | |
13910 | XTSQ(IDXST) = XXTSQ | |
13911 | XTSAQ(IDXST) = XXTSAQ | |
13912 | NVD = NVD+1 | |
13913 | INTVD1(NVD) = IDXVP | |
13914 | INTVD2(NVD) = IDXST | |
13915 | ISKPCH(7,NVD) = 0 | |
13916 | RETURN | |
13917 | ||
13918 | *--------------------------------------------------------------------- | |
13919 | * proj. sea partons - targ. valence partons | |
13920 | * get x-values and flavors for projectile sea-diquark pair | |
13921 | ||
13922 | 2 CONTINUE | |
13923 | IDXSP = IDX2 | |
13924 | IDXVT = IDX1 | |
13925 | ||
13926 | * index of corr. val-diquark-x in projectile nucleon | |
13927 | IDXVP = ITOVP(IFROSP(IDXSP)) | |
13928 | * available x above diquark thresholds for valence- and sea-diquarks | |
13929 | XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR | |
13930 | ||
13931 | IF (XXD.GE.ZERO) THEN | |
13932 | * x-values for the three diquarks of the projectile nucleon | |
13933 | RR1 = DT_RNDM(XXD) | |
13934 | RR2 = DT_RNDM(RR1) | |
13935 | RR3 = DT_RNDM(RR2) | |
13936 | SR123 = RR1+RR2+RR3 | |
13937 | XXPV = XDTHR+RR1*XXD/SR123 | |
13938 | XXPSQ = XDTHR+RR2*XXD/SR123 | |
13939 | XXPSAQ = XDTHR+RR3*XXD/SR123 | |
13940 | ELSE | |
13941 | XXPV = XPVD(IDXVP) | |
13942 | XXPSQ = XPSQ(IDXSP) | |
13943 | XXPSAQ = XPSAQ(IDXSP) | |
13944 | ENDIF | |
13945 | * flavor of the second quarks in the sea-diquark pair | |
13946 | IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ)) | |
13947 | IPSAQ2(IDXSP) = -IPSQ2(IDXSP) | |
13948 | * check masses of the new sea-qq - val-q, sea-aqaq - val-qq chains | |
13949 | AM1 = XXPSQ *XTVQ(IDXVT)*ECM**2 | |
13950 | AM2 = XXPSAQ*XTVD(IDXVT)*ECM**2 | |
13951 | IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND. | |
13952 | * ss-asas pair | |
13953 | & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN | |
13954 | IREJ = 1 | |
13955 | RETURN | |
13956 | ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND. | |
13957 | * at least one strange quark | |
13958 | & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN | |
13959 | IREJ = 1 | |
13960 | RETURN | |
13961 | ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN | |
13962 | IREJ = 1 | |
13963 | RETURN | |
13964 | ENDIF | |
13965 | * accept the new sea-diquark | |
13966 | XPVD(IDXVP) = XXPV | |
13967 | XPSQ(IDXSP) = XXPSQ | |
13968 | XPSAQ(IDXSP) = XXPSAQ | |
13969 | NDV = NDV+1 | |
13970 | INTDV1(NDV) = IDXSP | |
13971 | INTDV2(NDV) = IDXVT | |
13972 | ISKPCH(5,NDV) = 0 | |
13973 | RETURN | |
13974 | ||
13975 | *--------------------------------------------------------------------- | |
13976 | * proj. sea partons - targ. sea partons | |
13977 | * get x-values and flavors for target sea-diquark pair | |
13978 | ||
13979 | 3 CONTINUE | |
13980 | IDXSP = IDX1 | |
13981 | IDXST = IDX2 | |
13982 | ||
13983 | * index of corr. val-diquark-x in target nucleon | |
13984 | IDXVT = ITOVT(IFROST(IDXST)) | |
13985 | * available x above diquark thresholds for valence- and sea-diquarks | |
13986 | XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR | |
13987 | ||
13988 | IF (XXD.GE.ZERO) THEN | |
13989 | * x-values for the three diquarks of the target nucleon | |
13990 | RR1 = DT_RNDM(XXD) | |
13991 | RR2 = DT_RNDM(RR1) | |
13992 | RR3 = DT_RNDM(RR2) | |
13993 | SR123 = RR1+RR2+RR3 | |
13994 | XXTV = XDTHR+RR1*XXD/SR123 | |
13995 | XXTSQ = XDTHR+RR2*XXD/SR123 | |
13996 | XXTSAQ = XDTHR+RR3*XXD/SR123 | |
13997 | ELSE | |
13998 | XXTV = XTVD(IDXVT) | |
13999 | XXTSQ = XTSQ(IDXST) | |
14000 | XXTSAQ = XTSAQ(IDXST) | |
14001 | ENDIF | |
14002 | * flavor of the second quarks in the sea-diquark pair | |
14003 | ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ)) | |
14004 | ITSAQ2(IDXST) = -ITSQ2(IDXST) | |
14005 | * check masses of the new sea-q - sea-qq, sea-aq - sea-aqaq chains | |
14006 | AM1 = XXTSQ *XPSQ(IDXSP)*ECM**2 | |
14007 | AM2 = XXTSAQ*XPSAQ(IDXSP)*ECM**2 | |
14008 | IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND. | |
14009 | * ss-asas pair | |
14010 | & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN | |
14011 | IREJ = 1 | |
14012 | RETURN | |
14013 | ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND. | |
14014 | * at least one strange quark | |
14015 | & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN | |
14016 | IREJ = 1 | |
14017 | RETURN | |
14018 | ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN | |
14019 | IREJ = 1 | |
14020 | RETURN | |
14021 | ENDIF | |
14022 | * accept the new sea-diquark | |
14023 | XTVD(IDXVT) = XXTV | |
14024 | XTSQ(IDXST) = XXTSQ | |
14025 | XTSAQ(IDXST) = XXTSAQ | |
14026 | NSD = NSD+1 | |
14027 | INTSD1(NSD) = IDXSP | |
14028 | INTSD2(NSD) = IDXST | |
14029 | ISKPCH(3,NSD) = 0 | |
14030 | RETURN | |
14031 | ||
14032 | *--------------------------------------------------------------------- | |
14033 | * proj. sea partons - targ. sea partons | |
14034 | * get x-values and flavors for projectile sea-diquark pair | |
14035 | ||
14036 | 4 CONTINUE | |
14037 | IDXSP = IDX2 | |
14038 | IDXST = IDX1 | |
14039 | ||
14040 | * index of corr. val-diquark-x in projectile nucleon | |
14041 | IDXVP = ITOVP(IFROSP(IDXSP)) | |
14042 | * available x above diquark thresholds for valence- and sea-diquarks | |
14043 | XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR | |
14044 | ||
14045 | IF (XXD.GE.ZERO) THEN | |
14046 | * x-values for the three diquarks of the projectile nucleon | |
14047 | RR1 = DT_RNDM(XXD) | |
14048 | RR2 = DT_RNDM(RR1) | |
14049 | RR3 = DT_RNDM(RR2) | |
14050 | SR123 = RR1+RR2+RR3 | |
14051 | XXPV = XDTHR+RR1*XXD/SR123 | |
14052 | XXPSQ = XDTHR+RR2*XXD/SR123 | |
14053 | XXPSAQ = XDTHR+RR3*XXD/SR123 | |
14054 | ELSE | |
14055 | XXPV = XPVD(IDXVP) | |
14056 | XXPSQ = XPSQ(IDXSP) | |
14057 | XXPSAQ = XPSAQ(IDXSP) | |
14058 | ENDIF | |
14059 | * flavor of the second quarks in the sea-diquark pair | |
14060 | IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ)) | |
14061 | IPSAQ2(IDXSP) = -IPSQ2(IDXSP) | |
14062 | * check masses of the new sea-qq - sea-q, sea-aqaq - sea-qq chains | |
14063 | AM1 = XXPSQ *XTSQ(IDXST)*ECM**2 | |
14064 | AM2 = XXPSAQ*XTSAQ(IDXST)*ECM**2 | |
14065 | IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND. | |
14066 | * ss-asas pair | |
14067 | & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN | |
14068 | IREJ = 1 | |
14069 | RETURN | |
14070 | ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND. | |
14071 | * at least one strange quark | |
14072 | & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN | |
14073 | IREJ = 1 | |
14074 | RETURN | |
14075 | ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN | |
14076 | IREJ = 1 | |
14077 | RETURN | |
14078 | ENDIF | |
14079 | * accept the new sea-diquark | |
14080 | XPVD(IDXVP) = XXPV | |
14081 | XPSQ(IDXSP) = XXPSQ | |
14082 | XPSAQ(IDXSP) = XXPSAQ | |
14083 | NDS = NDS+1 | |
14084 | INTDS1(NDS) = IDXSP | |
14085 | INTDS2(NDS) = IDXST | |
14086 | ISKPCH(2,NDS) = 0 | |
14087 | RETURN | |
14088 | END | |
14089 | *$ CREATE DT_DIFEVT.FOR | |
14090 | *COPY DT_DIFEVT | |
14091 | * | |
14092 | *===difevt=============================================================* | |
14093 | * | |
14094 | SUBROUTINE DT_DIFEVT(IFP1,IFP2,PP,MOP, | |
14095 | & IFT1,IFT2,PT,MOT,JDIFF,NCSY,IREJ) | |
14096 | ||
14097 | ************************************************************************ | |
14098 | * Interface to treatment of diffractive interactions. * | |
14099 | * (input) IFP1/2 PDG-indizes of projectile partons * | |
14100 | * (baryon: IFP2 - adiquark) * | |
14101 | * PP(4) projectile 4-momentum * | |
14102 | * IFT1/2 PDG-indizes of target partons * | |
14103 | * (baryon: IFT1 - adiquark) * | |
14104 | * PT(4) target 4-momentum * | |
14105 | * (output) JDIFF = 0 no diffraction * | |
14106 | * = 1/-1 LMSD/LMDD * | |
14107 | * = 2/-2 HMSD/HMDD * | |
14108 | * NCSY counter for two-chain systems * | |
14109 | * dumped to DTEVT1 * | |
14110 | * This version dated 14.02.95 is written by S. Roesler * | |
14111 | ************************************************************************ | |
14112 | ||
14113 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
14114 | SAVE | |
14115 | ||
14116 | PARAMETER ( LINP = 10 , | |
14117 | & LOUT = 6 , | |
14118 | & LDAT = 9 ) | |
14119 | ||
14120 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5, | |
14121 | & OHALF=0.5D0) | |
14122 | ||
14123 | * event history | |
14124 | ||
14125 | PARAMETER (NMXHKK=200000) | |
14126 | ||
14127 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
14128 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
14129 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
14130 | ||
14131 | * extended event history | |
14132 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
14133 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
14134 | & IHIST(2,NMXHKK) | |
14135 | ||
14136 | * flags for diffractive interactions (DTUNUC 1.x) | |
14137 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF | |
14138 | ||
14139 | DIMENSION PP(4),PT(4) | |
14140 | ||
14141 | LOGICAL LFIRST | |
14142 | DATA LFIRST /.TRUE./ | |
14143 | ||
14144 | IREJ = 0 | |
14145 | JDIFF = 0 | |
14146 | IFLAGD = JDIFF | |
14147 | ||
14148 | * cm. energy | |
14149 | XM = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2- | |
14150 | & (PP(2)+PT(2))**2-(PP(3)+PT(3))**2) | |
14151 | * identities of projectile hadron / target nucleon | |
14152 | KPROJ = IDT_ICIHAD(IDHKK(MOP)) | |
14153 | KTARG = IDT_ICIHAD(IDHKK(MOT)) | |
14154 | ||
14155 | * single diffractive xsections | |
14156 | CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM) | |
14157 | * double diffractive xsections | |
14158 | **!! no double diff yet | |
14159 | C CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM,DDTOT,DDHM) | |
14160 | DDTOT = 0.0D0 | |
14161 | DDHM = 0.0D0 | |
14162 | **!! | |
14163 | * total inelastic xsection | |
14164 | C SIGIN = DT_SHNTOT(KPROJ,KTARG,XM,ZERO)-DT_SHNELA(KPROJ,KTARG,XM) | |
14165 | DUMZER = ZERO | |
14166 | CALL DT_XSHN(KPROJ,KTARG,DUMZER,XM,SIGTO,SIGEL) | |
14167 | SIGIN = MAX(SIGTO-SIGEL,ZERO) | |
14168 | ||
14169 | * fraction of diffractive processes | |
14170 | FRADIF = (SDTOT+DDTOT)/SIGIN | |
14171 | ||
14172 | IF (LFIRST) THEN | |
14173 | WRITE(LOUT,1000) XM,SDTOT,SIGIN | |
14174 | 1000 FORMAT(1X,'DIFEVT: single diffraction requested at E_cm = ', | |
14175 | & F5.1,' GeV',/,9X,'sigma_sd = ',F4.1,' mb, sigma_in = ', | |
14176 | & F5.1,' mb',/) | |
14177 | LFIRST = .FALSE. | |
14178 | ENDIF | |
14179 | ||
14180 | IF ((DT_RNDM(DDHM).LE.FRADIF).OR. | |
14181 | & (ISINGD.GT.1).OR.(IDOUBD.GT.1)) THEN | |
14182 | * diffractive interaction requested by x-section or by user | |
14183 | FRASD = SDTOT/(SDTOT+DDTOT) | |
14184 | FRASDH = SDHM/SDTOT | |
14185 | **sr needs to be specified!! | |
14186 | C FRADDH = DDHM/DDTOT | |
14187 | FRADDH = 1.0D0 | |
14188 | ** | |
14189 | IF ((DT_RNDM(FRASD).LE.FRASD).OR.(ISINGD.GT.1)) THEN | |
14190 | * single diffraction | |
14191 | KDIFF = 1 | |
14192 | IF (DT_RNDM(DDTOT).LE.FRASDH) THEN | |
14193 | KP = 2 | |
14194 | KT = 0 | |
14195 | IF (((ISINGD.EQ.4).OR.(DT_RNDM(DDTOT).GE.OHALF)).AND. | |
14196 | & ISINGD.NE.3) THEN | |
14197 | KP = 0 | |
14198 | KT = 2 | |
14199 | ENDIF | |
14200 | ELSE | |
14201 | KP = 1 | |
14202 | KT = 0 | |
14203 | IF (((ISINGD.EQ.4).OR.(DT_RNDM(FRADDH).GE.OHALF)).AND. | |
14204 | & ISINGD.NE.3) THEN | |
14205 | KP = 0 | |
14206 | KT = 1 | |
14207 | ENDIF | |
14208 | ENDIF | |
14209 | ELSE | |
14210 | * double diffraction | |
14211 | KDIFF = -1 | |
14212 | IF (DT_RNDM(FRADDH).LE.FRADDH) THEN | |
14213 | KP = 2 | |
14214 | KT = 2 | |
14215 | ELSE | |
14216 | KP = 1 | |
14217 | KT = 1 | |
14218 | ENDIF | |
14219 | ENDIF | |
14220 | CALL DT_DIFFKI(IFP1,IFP2,PP,MOP,KP, | |
14221 | & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1) | |
14222 | IF (IREJ1.EQ.0) THEN | |
14223 | IFLAGD = 2*KDIFF | |
14224 | IF ((KP.EQ.1).OR.(KT.EQ.1)) IFLAGD = KDIFF | |
14225 | ELSE | |
14226 | GOTO 9999 | |
14227 | ENDIF | |
14228 | ENDIF | |
14229 | JDIFF = IFLAGD | |
14230 | ||
14231 | RETURN | |
14232 | ||
14233 | 9999 CONTINUE | |
14234 | IREJ = 1 | |
14235 | RETURN | |
14236 | END | |
14237 | ||
14238 | *$ CREATE DT_DIFFKI.FOR | |
14239 | *COPY DT_DIFFKI | |
14240 | * | |
14241 | *===difkin=============================================================* | |
14242 | * | |
14243 | SUBROUTINE DT_DIFFKI(IFP1,IFP2,PP,MOP,KP, | |
14244 | & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ) | |
14245 | ||
14246 | ************************************************************************ | |
14247 | * Kinematics of diffractive nucleon-nucleon interaction. * | |
14248 | * IFP1/2 PDG-indizes of projectile partons * | |
14249 | * (baryon: IFP2 - adiquark) * | |
14250 | * PP(4) projectile 4-momentum * | |
14251 | * IFT1/2 PDG-indizes of target partons * | |
14252 | * (baryon: IFT1 - adiquark) * | |
14253 | * PT(4) target 4-momentum * | |
14254 | * KP = 0 projectile quasi-elastically scattered * | |
14255 | * = 1 excited to low-mass diff. state * | |
14256 | * = 2 excited to high-mass diff. state * | |
14257 | * KT = 0 target quasi-elastically scattered * | |
14258 | * = 1 excited to low-mass diff. state * | |
14259 | * = 2 excited to high-mass diff. state * | |
14260 | * This version dated 12.02.95 is written by S. Roesler * | |
14261 | ************************************************************************ | |
14262 | ||
14263 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
14264 | SAVE | |
14265 | ||
14266 | PARAMETER ( LINP = 10 , | |
14267 | & LOUT = 6 , | |
14268 | & LDAT = 9 ) | |
14269 | ||
14270 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5) | |
14271 | ||
14272 | LOGICAL LSTART | |
14273 | ||
14274 | * particle properties (BAMJET index convention) | |
14275 | CHARACTER*8 ANAME | |
14276 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
14277 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
14278 | ||
14279 | * flags for input different options | |
14280 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
14281 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
14282 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
14283 | ||
14284 | * rejection counter | |
14285 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
14286 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
14287 | & IREXCI(3),IRDIFF(2),IRINC | |
14288 | ||
14289 | * kinematics of diffractive interactions (DTUNUC 1.x) | |
14290 | COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4), | |
14291 | & PPF(4),PTF(4), | |
14292 | & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4), | |
14293 | & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2) | |
14294 | ||
14295 | DIMENSION PITOT(4),BGTOT(4),PP1(4),PT1(4),PPBLOB(4),PTBLOB(4), | |
14296 | & PP(4),PT(4),PPOM1(4),DEV1(4),DEV2(4) | |
14297 | ||
14298 | DATA LSTART /.TRUE./ | |
14299 | ||
14300 | IF (LSTART) THEN | |
14301 | WRITE(LOUT,2000) | |
14302 | 2000 FORMAT(/,1X,'DIFEVT: diffractive interactions treated ') | |
14303 | LSTART = .FALSE. | |
14304 | ENDIF | |
14305 | ||
14306 | IREJ = 0 | |
14307 | ||
14308 | * initialize common /DTDIKI/ | |
14309 | CALL DT_DIFINI | |
14310 | * store momenta of initial incoming particles for emc-check | |
14311 | IF (LEMCCK) THEN | |
14312 | CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM,IDUM) | |
14313 | CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM,IDUM) | |
14314 | ENDIF | |
14315 | ||
14316 | * masses of initial particles | |
14317 | XMP2 = PP(4)**2-PP(1)**2-PP(2)**2-PP(3)**2 | |
14318 | XMT2 = PT(4)**2-PT(1)**2-PT(2)**2-PT(3)**2 | |
14319 | IF ((XMP2.LT.ZERO).OR.(XMT2.LT.ZERO)) GOTO 9999 | |
14320 | XMP = SQRT(XMP2) | |
14321 | XMT = SQRT(XMT2) | |
14322 | * check quark-input (used to adjust coherence cond. for M-selection) | |
14323 | IBP = 0 | |
14324 | IF ((ABS(IFP1).GE.1000).OR.(ABS(IFP2).GE.1000)) IBP = 1 | |
14325 | IBT = 0 | |
14326 | IF ((ABS(IFT1).GE.1000).OR.(ABS(IFT2).GE.1000)) IBT = 1 | |
14327 | ||
14328 | * parameter for Lorentz-transformation into nucleon-nucleon cms | |
14329 | DO 3 K=1,4 | |
14330 | PITOT(K) = PP(K)+PT(K) | |
14331 | 3 CONTINUE | |
14332 | XMTOT2 = PITOT(4)**2-PITOT(1)**2-PITOT(2)**2-PITOT(3)**2 | |
14333 | IF (XMTOT2.LE.ZERO) THEN | |
14334 | WRITE(LOUT,1000) XMTOT2 | |
14335 | 1000 FORMAT(1X,'DIFEVT: negative cm. energy! ', | |
14336 | & 'XMTOT2 = ',E12.3) | |
14337 | GOTO 9999 | |
14338 | ENDIF | |
14339 | XMTOT = SQRT(XMTOT2) | |
14340 | DO 4 K=1,4 | |
14341 | BGTOT(K) = PITOT(K)/XMTOT | |
14342 | 4 CONTINUE | |
14343 | * transformation of nucleons into cms | |
14344 | CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PP(1),PP(2), | |
14345 | & PP(3),PP(4),PPTOT,PP1(1),PP1(2),PP1(3),PP1(4)) | |
14346 | CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PT(1),PT(2), | |
14347 | & PT(3),PT(4),PTTOT,PT1(1),PT1(2),PT1(3),PT1(4)) | |
14348 | * rotation angles | |
14349 | COD = PP1(3)/PPTOT | |
14350 | C SID = SQRT((ONE-COD)*(ONE+COD)) | |
14351 | PPT = SQRT(PP1(1)**2+PP1(2)**2) | |
14352 | SID = PPT/PPTOT | |
14353 | COF = ONE | |
14354 | SIF = ZERO | |
14355 | IF(PPTOT*SID.GT.TINY10) THEN | |
14356 | COF = PP1(1)/(SID*PPTOT) | |
14357 | SIF = PP1(2)/(SID*PPTOT) | |
14358 | ANORF = SQRT(COF*COF+SIF*SIF) | |
14359 | COF = COF/ANORF | |
14360 | SIF = SIF/ANORF | |
14361 | ENDIF | |
14362 | * check consistency | |
14363 | DO 5 K=1,4 | |
14364 | DEV1(K) = ABS(PP1(K)+PT1(K)) | |
14365 | 5 CONTINUE | |
14366 | DEV1(4) = ABS(DEV1(4)-XMTOT) | |
14367 | IF ((DEV1(1).GT.TINY10).OR.(DEV1(2).GT.TINY10).OR. | |
14368 | & (DEV1(3).GT.TINY10).OR.(DEV1(4).GT.TINY10)) THEN | |
14369 | WRITE(LOUT,1001) DEV1 | |
14370 | 1001 FORMAT(1X,'DIFEVT: inconsitent Lorentz-transformation! ', | |
14371 | & /,8X,4E12.3) | |
14372 | GOTO 9999 | |
14373 | ENDIF | |
14374 | ||
14375 | * select x-fractions in high-mass diff. interactions | |
14376 | IF ((KP.EQ.2).OR.(KT.EQ.2)) CALL DT_XVALHM(KP,KT) | |
14377 | ||
14378 | * select diffractive masses | |
14379 | * - projectile | |
14380 | IF (KP.EQ.1) THEN | |
14381 | XMPF = DT_XMLMD(XMTOT) | |
14382 | CALL DT_LM2RES(IFP1,IFP2,XMPF,IDPR,IDXPR,IREJ1) | |
14383 | IF (IREJ1.GT.0) GOTO 9999 | |
14384 | ELSEIF (KP.EQ.2) THEN | |
14385 | XMPF = DT_XMHMD(XMTOT,IBP,1) | |
14386 | ELSE | |
14387 | XMPF = XMP | |
14388 | ENDIF | |
14389 | * - target | |
14390 | IF (KT.EQ.1) THEN | |
14391 | XMTF = DT_XMLMD(XMTOT) | |
14392 | CALL DT_LM2RES(IFT1,IFT2,XMTF,IDTR,IDXTR,IREJ1) | |
14393 | IF (IREJ1.GT.0) GOTO 9999 | |
14394 | ELSEIF (KT.EQ.2) THEN | |
14395 | XMTF = DT_XMHMD(XMTOT,IBT,2) | |
14396 | ELSE | |
14397 | XMTF = XMT | |
14398 | ENDIF | |
14399 | ||
14400 | * kinematical treatment of "two-particle" system (masses - XMPF,XMTF) | |
14401 | XMPF2 = XMPF**2 | |
14402 | XMTF2 = XMTF**2 | |
14403 | PPBLOB(3) = DT_YLAMB(XMTOT2,XMPF2,XMTF2)/(2.D0*XMTOT) | |
14404 | PPBLOB(4) = SQRT(XMPF2+PPBLOB(3)**2) | |
14405 | ||
14406 | * select momentum transfer (all t-values used here are <0) | |
14407 | * minimum absolute value to produce diffractive masses | |
14408 | TMIN = XMP2+XMPF2-2.0D0*(PP1(4)*PPBLOB(4)-PPTOT*PPBLOB(3)) | |
14409 | TT = DT_TDIFF(XMTOT,TMIN,XMPF,KP,XMTF,KT,IREJ1) | |
14410 | IF (IREJ1.GT.0) GOTO 9999 | |
14411 | ||
14412 | * longitudinal momentum of excited/elastically scattered projectile | |
14413 | PPBLOB(3) = (TT-XMP2-XMPF2+2.0D0*PP1(4)*PPBLOB(4))/(2.0D0*PPTOT) | |
14414 | * total transverse momentum due to t-selection | |
14415 | PPBLT2 = PPBLOB(4)**2-PPBLOB(3)**2-XMPF2 | |
14416 | IF (PPBLT2.LT.ZERO) THEN | |
14417 | WRITE(LOUT,1002) PPBLT2,KP,PP1,XMPF,KT,PT1,XMTF,TT | |
14418 | 1002 FORMAT(1X,'DIFEVT: inconsistent transverse momentum! ', | |
14419 | & E12.3,2(/,1X,I2,5E12.3),/,1X,E12.3) | |
14420 | GOTO 9999 | |
14421 | ENDIF | |
14422 | CALL DT_DSFECF(SINPHI,COSPHI) | |
14423 | PPBLT = SQRT(PPBLT2) | |
14424 | PPBLOB(1) = COSPHI*PPBLT | |
14425 | PPBLOB(2) = SINPHI*PPBLT | |
14426 | ||
14427 | * rotate excited/elastically scattered projectile into n-n cms. | |
14428 | CALL DT_MYTRAN(1,PPBLOB(1),PPBLOB(2),PPBLOB(3),COD,SID,COF,SIF, | |
14429 | & XX,YY,ZZ) | |
14430 | PPBLOB(1) = XX | |
14431 | PPBLOB(2) = YY | |
14432 | PPBLOB(3) = ZZ | |
14433 | ||
14434 | * 4-momentum of excited/elastically scattered target and of exchanged | |
14435 | * Pomeron | |
14436 | DO 6 K=1,4 | |
14437 | IF (K.LT.4) PTBLOB(K) = -PPBLOB(K) | |
14438 | PPOM1(K) = PP1(K)-PPBLOB(K) | |
14439 | 6 CONTINUE | |
14440 | PTBLOB(4) = XMTOT-PPBLOB(4) | |
14441 | ||
14442 | * Lorentz-transformation back into system of initial diff. collision | |
14443 | CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3), | |
14444 | & PPBLOB(1),PPBLOB(2),PPBLOB(3),PPBLOB(4), | |
14445 | & PPTOTF,PPF(1),PPF(2),PPF(3),PPF(4)) | |
14446 | CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3), | |
14447 | & PTBLOB(1),PTBLOB(2),PTBLOB(3),PTBLOB(4), | |
14448 | & PTTOTF,PTF(1),PTF(2),PTF(3),PTF(4)) | |
14449 | CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3), | |
14450 | & PPOM1(1),PPOM1(2),PPOM1(3),PPOM1(4), | |
14451 | & PPOMTO,PPOM(1),PPOM(2),PPOM(3),PPOM(4)) | |
14452 | ||
14453 | * store 4-momentum of elastically scattered particle (in single diff. | |
14454 | * events) | |
14455 | IF (KP.EQ.0) THEN | |
14456 | DO 7 K=1,4 | |
14457 | PSC(K) = PPF(K) | |
14458 | 7 CONTINUE | |
14459 | ELSEIF (KT.EQ.0) THEN | |
14460 | DO 8 K=1,4 | |
14461 | PSC(K) = PTF(K) | |
14462 | 8 CONTINUE | |
14463 | ENDIF | |
14464 | ||
14465 | * check consistency of kinematical treatment so far | |
14466 | IF (LEMCCK) THEN | |
14467 | CALL DT_EVTEMC(-PPF(1),-PPF(2),-PPF(3),-PPF(4),2,IDUM,IDUM) | |
14468 | CALL DT_EVTEMC(-PTF(1),-PTF(2),-PTF(3),-PTF(4),2,IDUM,IDUM) | |
14469 | CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,60,IREJ1) | |
14470 | IF (IREJ1.NE.0) GOTO 9999 | |
14471 | ENDIF | |
14472 | DO 9 K=1,4 | |
14473 | DEV1(K) = ABS(PP(K)-PPF(K)-PPOM(K)) | |
14474 | DEV2(K) = ABS(PT(K)-PTF(K)+PPOM(K)) | |
14475 | 9 CONTINUE | |
14476 | IF ((DEV1(1).GT.TINY5).OR.(DEV1(2).GT.TINY5).OR. | |
14477 | & (DEV1(3).GT.TINY5).OR.(DEV1(4).GT.TINY5).OR. | |
14478 | & (DEV2(1).GT.TINY5).OR.(DEV2(2).GT.TINY5).OR. | |
14479 | & (DEV2(3).GT.TINY5).OR.(DEV2(4).GT.TINY5)) THEN | |
14480 | WRITE(LOUT,1003) DEV1,DEV2 | |
14481 | 1003 FORMAT(1X,'DIFEVT: inconsitent kinematical treatment! ', | |
14482 | & 2(/,8X,4E12.3)) | |
14483 | GOTO 9999 | |
14484 | ENDIF | |
14485 | ||
14486 | * kinematical treatment for low-mass diffraction | |
14487 | CALL DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ1) | |
14488 | IF (IREJ1.NE.0) GOTO 9999 | |
14489 | ||
14490 | * dump diffractive chains into DTEVT1 | |
14491 | CALL DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1) | |
14492 | IF (IREJ1.NE.0) GOTO 9999 | |
14493 | ||
14494 | RETURN | |
14495 | ||
14496 | 9999 CONTINUE | |
14497 | IRDIFF(1) = IRDIFF(1)+1 | |
14498 | IREJ = 1 | |
14499 | RETURN | |
14500 | END | |
14501 | ||
14502 | *$ CREATE DT_XMHMD.FOR | |
14503 | *COPY DT_XMHMD | |
14504 | * | |
14505 | *===xmhmd==============================================================* | |
14506 | * | |
14507 | DOUBLE PRECISION FUNCTION DT_XMHMD(ECM,IB,MODE) | |
14508 | ||
14509 | ************************************************************************ | |
14510 | * Diffractive mass in high mass single/double diffractive events. * | |
14511 | * This version dated 11.02.95 is written by S. Roesler * | |
14512 | ************************************************************************ | |
14513 | ||
14514 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
14515 | SAVE | |
14516 | ||
14517 | PARAMETER ( LINP = 10 , | |
14518 | & LOUT = 6 , | |
14519 | & LDAT = 9 ) | |
14520 | ||
14521 | PARAMETER (OHALF=0.5D0,ONE=1.0D0,ZERO=0.0D0) | |
14522 | ||
14523 | * kinematics of diffractive interactions (DTUNUC 1.x) | |
14524 | COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4), | |
14525 | & PPF(4),PTF(4), | |
14526 | & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4), | |
14527 | & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2) | |
14528 | ||
14529 | C DATA XCOLOW /0.05D0/ | |
14530 | DATA XCOLOW /0.15D0/ | |
14531 | ||
14532 | DT_XMHMD = ZERO | |
14533 | XH = XPH(2) | |
14534 | IF (MODE.EQ.2) XH = XTH(2) | |
14535 | ||
14536 | * minimum Pomeron-x for high-mass diffraction | |
14537 | * (adjusted to get a smooth transition between HM and LM component) | |
14538 | R = DT_RNDM(XH) | |
14539 | XDIMIN = (3.0D0+400.0D0*R**2)/(XH*ECM**2) | |
14540 | IF (ECM.LE.300.0D0) THEN | |
14541 | RR = (1.0D0-EXP(-((ECM/140.0D0)**4))) | |
14542 | XDIMIN = (3.0D0+400.0D0*(R**2)*RR)/(XH*ECM**2) | |
14543 | ENDIF | |
14544 | * maximum Pomeron-x for high-mass diffraction | |
14545 | * (coherence condition, adjusted to fit to experimental data) | |
14546 | IF (IB.NE.0) THEN | |
14547 | * baryon-diffraction | |
14548 | XDIMAX = XCOLOW*(1.0D0+EXP(-((ECM/420.0D0)**2))) | |
14549 | ELSE | |
14550 | * meson-diffraction | |
14551 | XDIMAX = XCOLOW*(1.0D0+4.0D0*EXP(-((ECM/420.0D0)**2))) | |
14552 | ENDIF | |
14553 | * check boundaries | |
14554 | IF (XDIMIN.GE.XDIMAX) THEN | |
14555 | XDIMIN = OHALF*XDIMAX | |
14556 | ENDIF | |
14557 | ||
14558 | KLOOP = 0 | |
14559 | 1 CONTINUE | |
14560 | KLOOP = KLOOP+1 | |
14561 | IF (KLOOP.GT.20) RETURN | |
14562 | * sample Pomeron-x from 1/x-distribution (critical Pomeron) | |
14563 | XDIFF = DT_SAMPEX(XDIMIN,XDIMAX) | |
14564 | * corr. diffr. mass | |
14565 | DT_XMHMD = ECM*SQRT(XDIFF) | |
14566 | IF (DT_XMHMD.LT.2.5D0) GOTO 1 | |
14567 | ||
14568 | RETURN | |
14569 | END | |
14570 | ||
14571 | *$ CREATE DT_XMLMD.FOR | |
14572 | *COPY DT_XMLMD | |
14573 | * | |
14574 | *===xmlmd==============================================================* | |
14575 | * | |
14576 | DOUBLE PRECISION FUNCTION DT_XMLMD(ECM) | |
14577 | ||
14578 | ************************************************************************ | |
14579 | * Diffractive mass in high mass single/double diffractive events. * | |
14580 | * This version dated 11.02.95 is written by S. Roesler * | |
14581 | ************************************************************************ | |
14582 | ||
14583 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
14584 | SAVE | |
14585 | ||
14586 | PARAMETER ( LINP = 10 , | |
14587 | & LOUT = 6 , | |
14588 | & LDAT = 9 ) | |
14589 | ||
14590 | * minimum Pomeron-x for low-mass diffraction | |
14591 | C AMO = 1.5D0 | |
14592 | AMO = 2.0D0 | |
14593 | * maximum Pomeron-x for low-mass diffraction | |
14594 | * (adjusted to get a smooth transition between HM and LM component) | |
14595 | R = DT_RNDM(AMO) | |
14596 | SAM = 1.0D0 | |
14597 | IF (ECM.LE.300.0D0) SAM = 1.0D0-EXP(-((ECM/200.0D0)**4)) | |
14598 | R = DT_RNDM(AMO)*SAM | |
14599 | AMAX= (1.0D0-SAM)*SQRT(0.1D0*ECM**2)+SAM*SQRT(400.0D0) | |
14600 | AMU = R*SQRT(100.0D0)+(1.0D0-R)*AMAX | |
14601 | ||
14602 | * selection of diffractive mass | |
14603 | * (adjusted to get a smooth transition between HM and LM component) | |
14604 | R = DT_RNDM(AMU) | |
14605 | IF (ECM.LE.50.0D0) THEN | |
14606 | DT_XMLMD = AMO*(AMU/AMO)**R | |
14607 | ELSE | |
14608 | A = 0.7D0 | |
14609 | IF (ECM.LE.300.0D0) A = 0.7D0*(1.0D0-EXP(-((ECM/100.0D0)**2))) | |
14610 | DT_XMLMD = 1.0D0/((R/(AMU**A)+(1.0D0-R)/(AMO**A))**(1.0D0/A)) | |
14611 | ENDIF | |
14612 | ||
14613 | RETURN | |
14614 | END | |
14615 | ||
14616 | *$ CREATE DT_TDIFF.FOR | |
14617 | *COPY DT_TDIFF | |
14618 | * | |
14619 | *===tdiff==============================================================* | |
14620 | * | |
14621 | DOUBLE PRECISION FUNCTION DT_TDIFF(ECM,TMIN,XM1I,K1,XM2I,K2,IREJ) | |
14622 | ||
14623 | ************************************************************************ | |
14624 | * t-selection for single/double diffractive interactions. * | |
14625 | * ECM cm. energy * | |
14626 | * TMIN minimum momentum transfer to produce diff. masses * | |
14627 | * XM1/XM2 diffractively produced masses * | |
14628 | * (for single diffraction XM2 is obsolete) * | |
14629 | * K1/K2= 0 not excited * | |
14630 | * = 1 low-mass excitation * | |
14631 | * = 2 high-mass excitation * | |
14632 | * This version dated 11.02.95 is written by S. Roesler * | |
14633 | ************************************************************************ | |
14634 | ||
14635 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
14636 | SAVE | |
14637 | ||
14638 | PARAMETER ( LINP = 10 , | |
14639 | & LOUT = 6 , | |
14640 | & LDAT = 9 ) | |
14641 | ||
14642 | PARAMETER (ZERO=0.0D0) | |
14643 | ||
14644 | PARAMETER ( BTP0 = 3.7D0, | |
14645 | & ALPHAP = 0.24D0 ) | |
14646 | ||
14647 | IREJ = 0 | |
14648 | NCLOOP = 0 | |
14649 | DT_TDIFF = ZERO | |
14650 | ||
14651 | IF (K1.GT.0) THEN | |
14652 | XM1 = XM1I | |
14653 | XM2 = XM2I | |
14654 | ELSE | |
14655 | XM1 = XM2I | |
14656 | ENDIF | |
14657 | XDI = (XM1/ECM)**2 | |
14658 | IF ((K1.EQ.0).OR.(K2.EQ.0)) THEN | |
14659 | * slope for single diffraction | |
14660 | SLOPE = BTP0-2.0D0*ALPHAP*LOG(XDI) | |
14661 | ELSE | |
14662 | * slope for double diffraction | |
14663 | SLOPE = -2.0D0*ALPHAP*LOG(XDI*XM2**2) | |
14664 | ENDIF | |
14665 | ||
14666 | 1 CONTINUE | |
14667 | NCLOOP = NCLOOP+1 | |
14668 | IF (MOD(NCLOOP,1000).EQ.0) GOTO 9999 | |
14669 | Y = DT_RNDM(XDI) | |
14670 | T = -LOG(1.0D0-Y)/SLOPE | |
14671 | IF (ABS(T).LE.ABS(TMIN)) GOTO 1 | |
14672 | DT_TDIFF = -ABS(T) | |
14673 | ||
14674 | RETURN | |
14675 | ||
14676 | 9999 CONTINUE | |
14677 | WRITE(LOUT,1000) ECM,TMIN,XM1I,XM2I,K1,K2 | |
14678 | 1000 FORMAT(1X,'DT_TDIFF: t-selection rejected!',/, | |
14679 | & 1X,'ECM = ',E12.3,' TMIN = ',E12.2,/,1X,'XM1I = ', | |
14680 | & E12.3,' XM2I = ',E12.3,' K1 = ',I2,' K2 = ',I2) | |
14681 | IREJ = 1 | |
14682 | RETURN | |
14683 | END | |
14684 | ||
14685 | *$ CREATE DT_XVALHM.FOR | |
14686 | *COPY DT_XVALHM | |
14687 | * | |
14688 | *===xvalhm=============================================================* | |
14689 | * | |
14690 | SUBROUTINE DT_XVALHM(KP,KT) | |
14691 | ||
14692 | ************************************************************************ | |
14693 | * Sampling of parton x-values in high-mass diffractive interactions. * | |
14694 | * This version dated 12.02.95 is written by S. Roesler * | |
14695 | ************************************************************************ | |
14696 | ||
14697 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
14698 | SAVE | |
14699 | ||
14700 | PARAMETER ( LINP = 10 , | |
14701 | & LOUT = 6 , | |
14702 | & LDAT = 9 ) | |
14703 | ||
14704 | PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0,TINY2=1.0D-2) | |
14705 | ||
14706 | * kinematics of diffractive interactions (DTUNUC 1.x) | |
14707 | COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4), | |
14708 | & PPF(4),PTF(4), | |
14709 | & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4), | |
14710 | & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2) | |
14711 | ||
14712 | * various options for treatment of partons (DTUNUC 1.x) | |
14713 | * (chain recombination, Cronin,..) | |
14714 | LOGICAL LCO2CR,LINTPT | |
14715 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, | |
14716 | & LCO2CR,LINTPT | |
14717 | ||
14718 | DATA UNON,XVQTHR /2.0D0,0.8D0/ | |
14719 | ||
14720 | IF (KP.EQ.2) THEN | |
14721 | * x-fractions of projectile valence partons | |
14722 | 1 CONTINUE | |
14723 | XPH(1) = DT_DBETAR(OHALF,UNON) | |
14724 | IF (XPH(1).GE.XVQTHR) GOTO 1 | |
14725 | XPH(2) = ONE-XPH(1) | |
14726 | * x-fractions of Pomeron q-aq-pair | |
14727 | XPOLO = TINY2 | |
14728 | XPOHI = ONE-TINY2 | |
14729 | XPPO(1) = DT_SAMPEX(XPOLO,XPOHI) | |
14730 | XPPO(2) = ONE-XPPO(1) | |
14731 | * flavors of Pomeron q-aq-pair | |
14732 | IFLAV = INT(ONE+DT_RNDM(UNON)*(2.0D0+SEASQ)) | |
14733 | IFPPO(1) = IFLAV | |
14734 | IFPPO(2) = -IFLAV | |
14735 | IF (DT_RNDM(UNON).GT.OHALF) THEN | |
14736 | IFPPO(1) = -IFLAV | |
14737 | IFPPO(2) = IFLAV | |
14738 | ENDIF | |
14739 | ENDIF | |
14740 | ||
14741 | IF (KT.EQ.2) THEN | |
14742 | * x-fractions of projectile target partons | |
14743 | 2 CONTINUE | |
14744 | XTH(1) = DT_DBETAR(OHALF,UNON) | |
14745 | IF (XTH(1).GE.XVQTHR) GOTO 2 | |
14746 | XTH(2) = ONE-XTH(1) | |
14747 | * x-fractions of Pomeron q-aq-pair | |
14748 | XPOLO = TINY2 | |
14749 | XPOHI = ONE-TINY2 | |
14750 | XTPO(1) = DT_SAMPEX(XPOLO,XPOHI) | |
14751 | XTPO(2) = ONE-XTPO(1) | |
14752 | * flavors of Pomeron q-aq-pair | |
14753 | IFLAV = INT(ONE+DT_RNDM(XPOLO)*(2.0D0+SEASQ)) | |
14754 | IFTPO(1) = IFLAV | |
14755 | IFTPO(2) = -IFLAV | |
14756 | IF (DT_RNDM(XPOLO).GT.OHALF) THEN | |
14757 | IFTPO(1) = -IFLAV | |
14758 | IFTPO(2) = IFLAV | |
14759 | ENDIF | |
14760 | ENDIF | |
14761 | ||
14762 | RETURN | |
14763 | END | |
14764 | ||
14765 | *$ CREATE DT_LM2RES.FOR | |
14766 | *COPY DT_LM2RES | |
14767 | * | |
14768 | *===lm2res=============================================================* | |
14769 | * | |
14770 | SUBROUTINE DT_LM2RES(IF1,IF2,XM,IDR,IDXR,IREJ) | |
14771 | ||
14772 | ************************************************************************ | |
14773 | * Check low-mass diffractive excitation for resonance mass. * | |
14774 | * (input) IF1/2 PDG-indizes of valence partons * | |
14775 | * (in/out) XM diffractive mass requested/corrected * | |
14776 | * (output) IDR/IDXR id./BAMJET-index of resonance * | |
14777 | * This version dated 12.02.95 is written by S. Roesler * | |
14778 | ************************************************************************ | |
14779 | ||
14780 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
14781 | SAVE | |
14782 | ||
14783 | PARAMETER ( LINP = 10 , | |
14784 | & LOUT = 6 , | |
14785 | & LDAT = 9 ) | |
14786 | ||
14787 | PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0) | |
14788 | ||
14789 | * kinematics of diffractive interactions (DTUNUC 1.x) | |
14790 | COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4), | |
14791 | & PPF(4),PTF(4), | |
14792 | & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4), | |
14793 | & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2) | |
14794 | ||
14795 | IREJ = 0 | |
14796 | IF1B = 0 | |
14797 | IF2B = 0 | |
14798 | XMI = XM | |
14799 | ||
14800 | * BAMJET indices of partons | |
14801 | IF1A = IDT_IPDG2B(IF1,1,2) | |
14802 | IF (ABS(IF1).GE.1000) IF1B = IDT_IPDG2B(IF1,2,2) | |
14803 | IF2A = IDT_IPDG2B(IF2,1,2) | |
14804 | IF (ABS(IF2).GE.1000) IF2B = IDT_IPDG2B(IF2,2,2) | |
14805 | ||
14806 | * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq) | |
14807 | IDCH = 2 | |
14808 | IF ((IF1B.EQ.0).AND.(IF2B.EQ.0)) IDCH = 1 | |
14809 | ||
14810 | * check for resonance mass | |
14811 | CALL DT_CH2RES(IF1A,IF1B,IF2A,IF2B,IDR,IDXR,XMI,XMN,IDCH,IREJ1) | |
14812 | IF (IREJ1.NE.0) GOTO 9999 | |
14813 | ||
14814 | XM = XMN | |
14815 | RETURN | |
14816 | ||
14817 | 9999 CONTINUE | |
14818 | IREJ = 1 | |
14819 | RETURN | |
14820 | END | |
14821 | ||
14822 | *$ CREATE DT_LMKINE.FOR | |
14823 | *COPY DT_LMKINE | |
14824 | * | |
14825 | *===lmkine=============================================================* | |
14826 | * | |
14827 | SUBROUTINE DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ) | |
14828 | ||
14829 | ************************************************************************ | |
14830 | * Kinematical treatment of low-mass excitations. * | |
14831 | * This version dated 12.02.95 is written by S. Roesler * | |
14832 | ************************************************************************ | |
14833 | ||
14834 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
14835 | SAVE | |
14836 | ||
14837 | PARAMETER ( LINP = 10 , | |
14838 | & LOUT = 6 , | |
14839 | & LDAT = 9 ) | |
14840 | ||
14841 | PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0) | |
14842 | ||
14843 | * flags for input different options | |
14844 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
14845 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
14846 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
14847 | ||
14848 | * kinematics of diffractive interactions (DTUNUC 1.x) | |
14849 | COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4), | |
14850 | & PPF(4),PTF(4), | |
14851 | & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4), | |
14852 | & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2) | |
14853 | ||
14854 | DIMENSION P1(4),P2(4) | |
14855 | ||
14856 | IREJ = 0 | |
14857 | ||
14858 | IF (KP.EQ.1) THEN | |
14859 | PABS = SQRT(PPF(1)**2+PPF(2)**2+PPF(3)**2) | |
14860 | POE = PPF(4)/PABS | |
14861 | FAC1 = OHALF*(POE+ONE) | |
14862 | FAC2 = -OHALF*(POE-ONE) | |
14863 | DO 1 K=1,3 | |
14864 | PPLM1(K) = FAC1*PPF(K) | |
14865 | PPLM2(K) = FAC2*PPF(K) | |
14866 | 1 CONTINUE | |
14867 | PPLM1(4) = FAC1*PABS | |
14868 | PPLM2(4) = -FAC2*PABS | |
14869 | IF (IMSHL.EQ.1) THEN | |
14870 | ||
14871 | XM1 = PYMASS(IFP1) | |
14872 | XM2 = PYMASS(IFP2) | |
14873 | ||
14874 | CALL DT_MASHEL(PPLM1,PPLM2,XM1,XM2,P1,P2,IREJ1) | |
14875 | IF (IREJ1.NE.0) GOTO 9999 | |
14876 | DO 2 K=1,4 | |
14877 | PPLM1(K) = P1(K) | |
14878 | PPLM2(K) = P2(K) | |
14879 | 2 CONTINUE | |
14880 | ENDIF | |
14881 | ENDIF | |
14882 | ||
14883 | IF (KT.EQ.1) THEN | |
14884 | PABS = SQRT(PTF(1)**2+PTF(2)**2+PTF(3)**2) | |
14885 | POE = PTF(4)/PABS | |
14886 | FAC1 = OHALF*(POE+ONE) | |
14887 | FAC2 = -OHALF*(POE-ONE) | |
14888 | DO 3 K=1,3 | |
14889 | PTLM2(K) = FAC1*PTF(K) | |
14890 | PTLM1(K) = FAC2*PTF(K) | |
14891 | 3 CONTINUE | |
14892 | PTLM2(4) = FAC1*PABS | |
14893 | PTLM1(4) = -FAC2*PABS | |
14894 | IF (IMSHL.EQ.1) THEN | |
14895 | ||
14896 | XM1 = PYMASS(IFT1) | |
14897 | XM2 = PYMASS(IFT2) | |
14898 | ||
14899 | CALL DT_MASHEL(PTLM1,PTLM2,XM1,XM2,P1,P2,IREJ1) | |
14900 | IF (IREJ1.NE.0) GOTO 9999 | |
14901 | DO 4 K=1,4 | |
14902 | PTLM1(K) = P1(K) | |
14903 | PTLM2(K) = P2(K) | |
14904 | 4 CONTINUE | |
14905 | ENDIF | |
14906 | ENDIF | |
14907 | ||
14908 | RETURN | |
14909 | ||
14910 | 9999 CONTINUE | |
14911 | WRITE(LOUT,'(A)') 'LMKINE: kinematical treatment rejected' | |
14912 | IREJ = 1 | |
14913 | RETURN | |
14914 | END | |
14915 | ||
14916 | *$ CREATE DT_DIFINI.FOR | |
14917 | *COPY DT_DIFINI | |
14918 | * | |
14919 | *===difini=============================================================* | |
14920 | * | |
14921 | SUBROUTINE DT_DIFINI | |
14922 | ||
14923 | ************************************************************************ | |
14924 | * Initialization of common /DTDIKI/ * | |
14925 | * This version dated 12.02.95 is written by S. Roesler * | |
14926 | ************************************************************************ | |
14927 | ||
14928 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
14929 | SAVE | |
14930 | ||
14931 | PARAMETER ( LINP = 10 , | |
14932 | & LOUT = 6 , | |
14933 | & LDAT = 9 ) | |
14934 | ||
14935 | PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0) | |
14936 | ||
14937 | * kinematics of diffractive interactions (DTUNUC 1.x) | |
14938 | COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4), | |
14939 | & PPF(4),PTF(4), | |
14940 | & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4), | |
14941 | & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2) | |
14942 | ||
14943 | DO 1 K=1,4 | |
14944 | PPOM(K) = ZERO | |
14945 | PSC(K) = ZERO | |
14946 | PPF(K) = ZERO | |
14947 | PTF(K) = ZERO | |
14948 | PPLM1(K) = ZERO | |
14949 | PPLM2(K) = ZERO | |
14950 | PTLM1(K) = ZERO | |
14951 | PTLM2(K) = ZERO | |
14952 | 1 CONTINUE | |
14953 | DO 2 K=1,2 | |
14954 | XPH(K) = ZERO | |
14955 | XPPO(K) = ZERO | |
14956 | XTH(K) = ZERO | |
14957 | XTPO(K) = ZERO | |
14958 | IFPPO(K) = 0 | |
14959 | IFTPO(K) = 0 | |
14960 | 2 CONTINUE | |
14961 | IDPR = 0 | |
14962 | IDXPR = 0 | |
14963 | IDTR = 0 | |
14964 | IDXTR = 0 | |
14965 | ||
14966 | RETURN | |
14967 | END | |
14968 | ||
14969 | *$ CREATE DT_DIFPUT.FOR | |
14970 | *COPY DT_DIFPUT | |
14971 | * | |
14972 | *===difput=============================================================* | |
14973 | * | |
14974 | SUBROUTINE DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY, | |
14975 | & IREJ) | |
14976 | ||
14977 | ************************************************************************ | |
14978 | * Dump diffractive chains into DTEVT1 * | |
14979 | * This version dated 12.02.95 is written by S. Roesler * | |
14980 | ************************************************************************ | |
14981 | ||
14982 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
14983 | SAVE | |
14984 | ||
14985 | PARAMETER ( LINP = 10 , | |
14986 | & LOUT = 6 , | |
14987 | & LDAT = 9 ) | |
14988 | ||
14989 | PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0) | |
14990 | ||
14991 | LOGICAL LCHK | |
14992 | ||
14993 | * kinematics of diffractive interactions (DTUNUC 1.x) | |
14994 | COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4), | |
14995 | & PPF(4),PTF(4), | |
14996 | & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4), | |
14997 | & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2) | |
14998 | ||
14999 | * event history | |
15000 | ||
15001 | PARAMETER (NMXHKK=200000) | |
15002 | ||
15003 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
15004 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
15005 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
15006 | ||
15007 | * extended event history | |
15008 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
15009 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
15010 | & IHIST(2,NMXHKK) | |
15011 | ||
15012 | * rejection counter | |
15013 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
15014 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
15015 | & IREXCI(3),IRDIFF(2),IRINC | |
15016 | ||
15017 | DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PCH(4),PP(4),PT(4), | |
15018 | & P1(4),P2(4),P3(4),P4(4) | |
15019 | ||
15020 | IREJ = 0 | |
15021 | ||
15022 | IF (KP.EQ.1) THEN | |
15023 | DO 1 K=1,4 | |
15024 | PCH(K) = PPLM1(K)+PPLM2(K) | |
15025 | 1 CONTINUE | |
15026 | ID1 = IFP1 | |
15027 | ID2 = IFP2 | |
15028 | IF (DT_RNDM(PT).GT.OHALF) THEN | |
15029 | ID1 = IFP2 | |
15030 | ID2 = IFP1 | |
15031 | ENDIF | |
15032 | CALL DT_EVTPUT(21,ID1,MOP,0,PPLM1(1),PPLM1(2),PPLM1(3), | |
15033 | & PPLM1(4),0,0,0) | |
15034 | CALL DT_EVTPUT(21,ID2,MOP,0,PPLM2(1),PPLM2(2),PPLM2(3), | |
15035 | & PPLM2(4),0,0,0) | |
15036 | CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4), | |
15037 | & IDPR,IDXPR,8) | |
15038 | ELSEIF (KP.EQ.2) THEN | |
15039 | DO 2 K=1,4 | |
15040 | PP1(K) = XPH(1)*PP(K) | |
15041 | PP2(K) = XPH(2)*PP(K) | |
15042 | PT1(K) = -XPPO(1)*PPOM(K) | |
15043 | PT2(K) = -XPPO(2)*PPOM(K) | |
15044 | 2 CONTINUE | |
15045 | CALL DT_CHKCSY(IFP1,IFPPO(1),LCHK) | |
15046 | XM1 = ZERO | |
15047 | XM2 = ZERO | |
15048 | IF (LCHK) THEN | |
15049 | CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1) | |
15050 | IF (IREJ1.NE.0) GOTO 9999 | |
15051 | CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1) | |
15052 | IF (IREJ1.NE.0) GOTO 9999 | |
15053 | DO 3 K=1,4 | |
15054 | PP1(K) = P1(K) | |
15055 | PT1(K) = P2(K) | |
15056 | PP2(K) = P3(K) | |
15057 | PT2(K) = P4(K) | |
15058 | 3 CONTINUE | |
15059 | CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), | |
15060 | & 0,0,8) | |
15061 | CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3), | |
15062 | & PT1(4),0,0,8) | |
15063 | CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), | |
15064 | & 0,0,8) | |
15065 | CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3), | |
15066 | & PT2(4),0,0,8) | |
15067 | ELSE | |
15068 | CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1) | |
15069 | IF (IREJ1.NE.0) GOTO 9999 | |
15070 | CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1) | |
15071 | IF (IREJ1.NE.0) GOTO 9999 | |
15072 | DO 4 K=1,4 | |
15073 | PP1(K) = P1(K) | |
15074 | PT2(K) = P2(K) | |
15075 | PP2(K) = P3(K) | |
15076 | PT1(K) = P4(K) | |
15077 | 4 CONTINUE | |
15078 | CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), | |
15079 | & 0,0,8) | |
15080 | CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3), | |
15081 | & PT2(4),0,0,8) | |
15082 | CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), | |
15083 | & 0,0,8) | |
15084 | CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3), | |
15085 | & PT1(4),0,0,8) | |
15086 | ENDIF | |
15087 | NCSY = NCSY+1 | |
15088 | ELSE | |
15089 | CALL DT_EVTPUT(1,IDHKK(MOP),MOP,0,PSC(1),PSC(2),PSC(3),PSC(4), | |
15090 | & 0,0,0) | |
15091 | ENDIF | |
15092 | ||
15093 | IF (KT.EQ.1) THEN | |
15094 | DO 5 K=1,4 | |
15095 | PCH(K) = PTLM1(K)+PTLM2(K) | |
15096 | 5 CONTINUE | |
15097 | ID1 = IFT1 | |
15098 | ID2 = IFT2 | |
15099 | IF (DT_RNDM(PT).GT.OHALF) THEN | |
15100 | ID1 = IFT2 | |
15101 | ID2 = IFT1 | |
15102 | ENDIF | |
15103 | CALL DT_EVTPUT(22,ID1,MOT,0,PTLM1(1),PTLM1(2),PTLM1(3), | |
15104 | & PTLM1(4),0,0,0) | |
15105 | CALL DT_EVTPUT(22,ID2,MOT,0,PTLM2(1),PTLM2(2),PTLM2(3), | |
15106 | & PTLM2(4),0,0,0) | |
15107 | CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4), | |
15108 | & IDTR,IDXTR,8) | |
15109 | ELSEIF (KT.EQ.2) THEN | |
15110 | DO 6 K=1,4 | |
15111 | PP1(K) = XTPO(1)*PPOM(K) | |
15112 | PP2(K) = XTPO(2)*PPOM(K) | |
15113 | PT1(K) = XTH(2)*PT(K) | |
15114 | PT2(K) = XTH(1)*PT(K) | |
15115 | 6 CONTINUE | |
15116 | CALL DT_CHKCSY(IFTPO(1),IFT1,LCHK) | |
15117 | XM1 = ZERO | |
15118 | XM2 = ZERO | |
15119 | IF (LCHK) THEN | |
15120 | CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1) | |
15121 | IF (IREJ1.NE.0) GOTO 9999 | |
15122 | CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1) | |
15123 | IF (IREJ1.NE.0) GOTO 9999 | |
15124 | DO 7 K=1,4 | |
15125 | PP1(K) = P1(K) | |
15126 | PT1(K) = P2(K) | |
15127 | PP2(K) = P3(K) | |
15128 | PT2(K) = P4(K) | |
15129 | 7 CONTINUE | |
15130 | CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3), | |
15131 | & PP1(4),0,0,8) | |
15132 | CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), | |
15133 | & 0,0,8) | |
15134 | CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3), | |
15135 | & PP2(4),0,0,8) | |
15136 | CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), | |
15137 | & 0,0,8) | |
15138 | ELSE | |
15139 | CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1) | |
15140 | IF (IREJ1.NE.0) GOTO 9999 | |
15141 | CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1) | |
15142 | IF (IREJ1.NE.0) GOTO 9999 | |
15143 | DO 8 K=1,4 | |
15144 | PP1(K) = P1(K) | |
15145 | PT2(K) = P2(K) | |
15146 | PP2(K) = P3(K) | |
15147 | PT1(K) = P4(K) | |
15148 | 8 CONTINUE | |
15149 | CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3), | |
15150 | & PP1(4),0,0,8) | |
15151 | CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), | |
15152 | & 0,0,8) | |
15153 | CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3), | |
15154 | & PP2(4),0,0,8) | |
15155 | CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), | |
15156 | & 0,0,8) | |
15157 | ENDIF | |
15158 | NCSY = NCSY+1 | |
15159 | ELSE | |
15160 | CALL DT_EVTPUT(1,IDHKK(MOT),MOT,0,PSC(1),PSC(2),PSC(3),PSC(4), | |
15161 | & 0,0,0) | |
15162 | ENDIF | |
15163 | ||
15164 | RETURN | |
15165 | ||
15166 | 9999 CONTINUE | |
15167 | IRDIFF(2) = IRDIFF(2)+1 | |
15168 | IREJ = 1 | |
15169 | RETURN | |
15170 | END | |
15171 | *$ CREATE DT_EVTFRG.FOR | |
15172 | *COPY DT_EVTFRG | |
15173 | * | |
15174 | *===evtfrg=============================================================* | |
15175 | * | |
15176 | SUBROUTINE DT_EVTFRG(KMODE,NFRG,NPYMEM,IREJ) | |
15177 | ||
15178 | ************************************************************************ | |
15179 | * Hadronization of chains in DTEVT1. * | |
15180 | * * | |
15181 | * Input: * | |
15182 | * KMODE = 1 hadronization of PHOJET-chains (id=77xxx) * | |
15183 | * = 2 hadronization of DTUNUC-chains (id=88xxx) * | |
15184 | * NFRG if KMODE = 1 : upper index of PHOJET-scatterings to be * | |
15185 | * hadronized with one PYEXEC call * | |
15186 | * if KMODE = 2 : max. number of DTUNUC-chains to be hadronized * | |
15187 | * with one PYEXEC call * | |
15188 | * Output: * | |
15189 | * NPYMEM number of entries in JETSET-common after hadronization * | |
15190 | * IREJ rejection flag * | |
15191 | * * | |
15192 | * This version dated 17.09.00 is written by S. Roesler * | |
15193 | ************************************************************************ | |
15194 | ||
15195 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
15196 | SAVE | |
15197 | ||
15198 | PARAMETER ( LINP = 10 , | |
15199 | & LOUT = 6 , | |
15200 | & LDAT = 9 ) | |
15201 | ||
15202 | PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1) | |
15203 | PARAMETER (ONE=1.0D0,ZERO=0.0D0) | |
15204 | ||
15205 | LOGICAL LACCEP | |
15206 | ||
15207 | PARAMETER (MXJOIN=200) | |
15208 | ||
15209 | * event history | |
15210 | ||
15211 | PARAMETER (NMXHKK=200000) | |
15212 | ||
15213 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
15214 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
15215 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
15216 | ||
15217 | * extended event history | |
15218 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
15219 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
15220 | & IHIST(2,NMXHKK) | |
15221 | ||
15222 | * flags for input different options | |
15223 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
15224 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
15225 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
15226 | ||
15227 | * statistics | |
15228 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
15229 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
15230 | & ICEVTG(8,0:30) | |
15231 | ||
15232 | * flags for diffractive interactions (DTUNUC 1.x) | |
15233 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF | |
15234 | ||
15235 | * nucleon-nucleon event-generator | |
15236 | CHARACTER*8 CMODEL | |
15237 | LOGICAL LPHOIN | |
15238 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
15239 | * phojet | |
15240 | ||
15241 | C model switches and parameters | |
15242 | CHARACTER*8 MDLNA | |
15243 | INTEGER ISWMDL,IPAMDL | |
15244 | DOUBLE PRECISION PARMDL | |
15245 | COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400) | |
15246 | * jetset | |
15247 | ||
15248 | COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) | |
15249 | PARAMETER (MAXLND=4000) | |
15250 | COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5) | |
15251 | ||
15252 | INTEGER PYK | |
15253 | ||
15254 | DIMENSION IJOIN(MXJOIN),ISJOIN(MXJOIN),IHISMO(8000),IFLG(4000) | |
15255 | ||
15256 | MODE = KMODE | |
15257 | ISTSTG = 7 | |
15258 | IF (MODE.NE.1) ISTSTG = 8 | |
15259 | IREJ = 0 | |
15260 | ||
15261 | IP = 0 | |
15262 | ISH = 0 | |
15263 | INIEMC = 1 | |
15264 | NEND = NHKK | |
15265 | NACCEP = 0 | |
15266 | IFRG = 0 | |
15267 | IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1 | |
15268 | DO 10 I=NPOINT(3),NEND | |
15269 | * sr 14.02.00: seems to be not necessary anymore, commented | |
15270 | C LACCEP = ((NOBAM(I).EQ.0).AND.(MODE.EQ.1)).OR. | |
15271 | C & ((NOBAM(I).NE.0).AND.(MODE.EQ.2)) | |
15272 | LACCEP = .TRUE. | |
15273 | * pick up chains from dtevt1 | |
15274 | IDCHK = IDHKK(I)/10000 | |
15275 | IF ((IDCHK.EQ.ISTSTG).AND.LACCEP) THEN | |
15276 | IF (IDCHK.EQ.7) THEN | |
15277 | IPJE = IDHKK(I)-IDCHK*10000 | |
15278 | IF (IPJE.NE.IFRG) THEN | |
15279 | IFRG = IPJE | |
15280 | IF (IFRG.GT.NFRG) GOTO 16 | |
15281 | ENDIF | |
15282 | ELSE | |
15283 | IPJE = 1 | |
15284 | IFRG = IFRG+1 | |
15285 | IF (IFRG.GT.NFRG) THEN | |
15286 | NFRG = -1 | |
15287 | GOTO 16 | |
15288 | ENDIF | |
15289 | ENDIF | |
15290 | * statistics counter | |
15291 | c IF (IDCH(I).LE.8) | |
15292 | c & ICCHAI(2,IDCH(I)) = ICCHAI(2,IDCH(I))+1 | |
15293 | c IF (IDRES(I).NE.0) ICRES(IDCH(I)) = ICRES(IDCH(I))+1 | |
15294 | * special treatment for small chains already corrected to hadrons | |
15295 | IF (IDRES(I).NE.0) THEN | |
15296 | IF (IDRES(I).EQ.11) THEN | |
15297 | ID = IDXRES(I) | |
15298 | ELSE | |
15299 | ID = IDT_IPDGHA(IDXRES(I)) | |
15300 | ENDIF | |
15301 | IF (LEMCCK) THEN | |
15302 | CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I), | |
15303 | & PHKK(4,I),INIEMC,IDUM,IDUM) | |
15304 | INIEMC = 2 | |
15305 | ENDIF | |
15306 | IP = IP+1 | |
15307 | IF (IP.GT.MSTU(4)) STOP ' NEWFRA 1: IP.GT.MSTU(4) !' | |
15308 | P(IP,1) = PHKK(1,I) | |
15309 | P(IP,2) = PHKK(2,I) | |
15310 | P(IP,3) = PHKK(3,I) | |
15311 | P(IP,4) = PHKK(4,I) | |
15312 | P(IP,5) = PHKK(5,I) | |
15313 | K(IP,1) = 1 | |
15314 | K(IP,2) = ID | |
15315 | K(IP,3) = 0 | |
15316 | K(IP,4) = 0 | |
15317 | K(IP,5) = 0 | |
15318 | IHIST(2,I) = 10000*IPJE+IP | |
15319 | IF (IHIST(1,I).LE.-100) THEN | |
15320 | ISH = ISH+1 | |
15321 | IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !' | |
15322 | ISJOIN(ISH) = I | |
15323 | ENDIF | |
15324 | N = IP | |
15325 | IHISMO(IP) = I | |
15326 | ELSE | |
15327 | IJ = 0 | |
15328 | DO 11 KK=JMOHKK(1,I),JMOHKK(2,I) | |
15329 | IF (LEMCCK) THEN | |
15330 | CALL DT_EVTEMC(PHKK(1,KK),PHKK(2,KK),PHKK(3,KK), | |
15331 | & PHKK(4,KK),INIEMC,IDUM,IDUM) | |
15332 | CALL DT_EVTFLC(IDHKK(KK),1,INIEMC,IDUM,IDUM) | |
15333 | INIEMC = 2 | |
15334 | ENDIF | |
15335 | ID = IDHKK(KK) | |
15336 | IF (ID.EQ.0) ID = 21 | |
15337 | c PTOT = SQRT(PHKK(1,KK)**2+PHKK(2,KK)**2+PHKK(3,KK)**2) | |
15338 | c AM0 = SQRT(ABS((PHKK(4,KK)-PTOT)*(PHKK(4,KK)+PTOT))) | |
15339 | ||
15340 | c AMRQ = PYMASS(ID) | |
15341 | ||
15342 | c AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ) | |
15343 | c IF ((ABS(AMDIF2).GT.TINY3).AND.(PTOT.GT.ZERO).AND. | |
15344 | c & (ABS(IDIFF).EQ.0)) THEN | |
15345 | cC WRITE(LOUT,*)'here: ',NEVHKK,AM0,AMRQ | |
15346 | c DELTA = -AMDIF2/(2.0D0*(PHKK(4,KK)+PTOT)) | |
15347 | c PHKK(4,KK) = PHKK(4,KK)+DELTA | |
15348 | c PTOT1 = PTOT-DELTA | |
15349 | c PHKK(1,KK) = PHKK(1,KK)*PTOT1/PTOT | |
15350 | c PHKK(2,KK) = PHKK(2,KK)*PTOT1/PTOT | |
15351 | c PHKK(3,KK) = PHKK(3,KK)*PTOT1/PTOT | |
15352 | c PHKK(5,KK) = AMRQ | |
15353 | c ENDIF | |
15354 | IP = IP+1 | |
15355 | IF (IP.GT.MSTU(4)) STOP ' NEWFRA 2: IP.GT.MSTU(4) !' | |
15356 | P(IP,1) = PHKK(1,KK) | |
15357 | P(IP,2) = PHKK(2,KK) | |
15358 | P(IP,3) = PHKK(3,KK) | |
15359 | P(IP,4) = PHKK(4,KK) | |
15360 | P(IP,5) = PHKK(5,KK) | |
15361 | K(IP,1) = 1 | |
15362 | K(IP,2) = ID | |
15363 | K(IP,3) = 0 | |
15364 | K(IP,4) = 0 | |
15365 | K(IP,5) = 0 | |
15366 | IHIST(2,KK) = 10000*IPJE+IP | |
15367 | IF (IHIST(1,KK).LE.-100) THEN | |
15368 | ISH = ISH+1 | |
15369 | IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !' | |
15370 | ISJOIN(ISH) = KK | |
15371 | ENDIF | |
15372 | IJ = IJ+1 | |
15373 | IF (IJ.GT.MXJOIN) STOP 'IJ > MXJOIN !' | |
15374 | IJOIN(IJ) = IP | |
15375 | IHISMO(IP) = I | |
15376 | 11 CONTINUE | |
15377 | N = IP | |
15378 | * join the two-parton system | |
15379 | ||
15380 | CALL PYJOIN(IJ,IJOIN) | |
15381 | ||
15382 | ENDIF | |
15383 | IDHKK(I) = 99999 | |
15384 | ENDIF | |
15385 | 10 CONTINUE | |
15386 | 16 CONTINUE | |
15387 | N = IP | |
15388 | ||
15389 | IF (IP.GT.0) THEN | |
15390 | ||
15391 | * final state parton shower | |
15392 | DO 136 NPJE=1,IPJE | |
15393 | IF ((MCGENE.EQ.2).AND.(ISH.GE.2)) THEN | |
15394 | IF ((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN | |
15395 | DO 130 K1=1,ISH | |
15396 | IF (ISJOIN(K1).EQ.0) GOTO 130 | |
15397 | I = ISJOIN(K1) | |
15398 | IF ((IPAMDL(102).EQ.1).AND.(IHIST(1,I).NE.-100)) | |
15399 | & GOTO 130 | |
15400 | IH1 = IHIST(2,I)/10000 | |
15401 | IF (IH1.NE.NPJE) GOTO 130 | |
15402 | IH1 = IHIST(2,I)-IH1*10000 | |
15403 | DO 135 K2=K1+1,ISH | |
15404 | IF (ISJOIN(K2).EQ.0) GOTO 135 | |
15405 | II = ISJOIN(K2) | |
15406 | IH2 = IHIST(2,II)/10000 | |
15407 | IF (IH2.NE.NPJE) GOTO 135 | |
15408 | IH2 = IHIST(2,II)-IH2*10000 | |
15409 | IF (IHIST(1,I).EQ.IHIST(1,II)) THEN | |
15410 | PT1 = SQRT(PHKK(1,II)**2+PHKK(2,II)**2) | |
15411 | PT2 = SQRT(PHKK(1, I)**2+PHKK(2, I)**2) | |
15412 | ||
15413 | RQLUN = MIN(PT1,PT2) | |
15414 | CALL PYSHOW(IH1,IH2,RQLUN) | |
15415 | ||
15416 | ISJOIN(K1) = 0 | |
15417 | ISJOIN(K2) = 0 | |
15418 | GOTO 130 | |
15419 | ENDIF | |
15420 | 135 CONTINUE | |
15421 | 130 CONTINUE | |
15422 | ENDIF | |
15423 | ENDIF | |
15424 | 136 CONTINUE | |
15425 | ||
15426 | CALL DT_INITJS(MODE) | |
15427 | * hadronization | |
15428 | ||
15429 | CALL PYEXEC | |
15430 | ||
15431 | IF (MSTU(24).NE.0) THEN | |
15432 | WRITE(LOUT,*) ' JETSET-reject at event', | |
15433 | & NEVHKK,MSTU(24),KMODE | |
15434 | C CALL DT_EVTOUT(4) | |
15435 | ||
15436 | C CALL PYLIST(2) | |
15437 | ||
15438 | GOTO 9999 | |
15439 | ENDIF | |
15440 | ||
15441 | * number of entries in LUJETS | |
15442 | ||
15443 | NLINES = PYK(0,1) | |
15444 | ||
15445 | NPYMEM = NLINES | |
15446 | ||
15447 | DO 12 I=1,NLINES | |
15448 | IFLG(I) = 0 | |
15449 | 12 CONTINUE | |
15450 | ||
15451 | DO 13 II=1,NLINES | |
15452 | ||
15453 | IF ((PYK(II,7).EQ.1).AND.(IFLG(II).NE.1)) THEN | |
15454 | ||
15455 | * pick up mother resonance if possible and put it together with | |
15456 | * their decay-products into the common | |
15457 | IDXMOR = K(II,3) | |
15458 | IF ((IDXMOR.GE.1).AND.(IDXMOR.LE.MAXLND)) THEN | |
15459 | KFMOR = K(IDXMOR,2) | |
15460 | ISMOR = K(IDXMOR,1) | |
15461 | ELSE | |
15462 | KFMOR = 91 | |
15463 | ISMOR = 1 | |
15464 | ENDIF | |
15465 | IF ((KFMOR.NE.91).AND.(KFMOR.NE.92).AND. | |
15466 | & (KFMOR.NE.94).AND.(ISMOR.EQ.11)) THEN | |
15467 | ID = K(IDXMOR,2) | |
15468 | MO = IHISMO(PYK(IDXMOR,15)) | |
15469 | PX = PYP(IDXMOR,1) | |
15470 | PY = PYP(IDXMOR,2) | |
15471 | PZ = PYP(IDXMOR,3) | |
15472 | PE = PYP(IDXMOR,4) | |
15473 | ||
15474 | CALL DT_EVTPUT(2,ID,MO,0,PX,PY,PZ,PE,0,0,0) | |
15475 | IFLG(IDXMOR) = 1 | |
15476 | MO = NHKK | |
15477 | DO 15 JDAUG=K(IDXMOR,4),K(IDXMOR,5) | |
15478 | IF (PYK(JDAUG,7).EQ.1) THEN | |
15479 | ID = PYK(JDAUG,8) | |
15480 | PX = PYP(JDAUG,1) | |
15481 | PY = PYP(JDAUG,2) | |
15482 | PZ = PYP(JDAUG,3) | |
15483 | PE = PYP(JDAUG,4) | |
15484 | ||
15485 | CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0) | |
15486 | IF (LEMCCK) THEN | |
15487 | PX = -PYP(JDAUG,1) | |
15488 | PY = -PYP(JDAUG,2) | |
15489 | PZ = -PYP(JDAUG,3) | |
15490 | PE = -PYP(JDAUG,4) | |
15491 | ||
15492 | CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM) | |
15493 | ENDIF | |
15494 | IFLG(JDAUG) = 1 | |
15495 | ENDIF | |
15496 | 15 CONTINUE | |
15497 | ELSE | |
15498 | * there was no mother resonance | |
15499 | MO = IHISMO(PYK(II,15)) | |
15500 | ID = PYK(II,8) | |
15501 | PX = PYP(II,1) | |
15502 | PY = PYP(II,2) | |
15503 | PZ = PYP(II,3) | |
15504 | PE = PYP(II,4) | |
15505 | ||
15506 | CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0) | |
15507 | IF (LEMCCK) THEN | |
15508 | PX = -PYP(II,1) | |
15509 | PY = -PYP(II,2) | |
15510 | PZ = -PYP(II,3) | |
15511 | PE = -PYP(II,4) | |
15512 | ||
15513 | CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM) | |
15514 | ENDIF | |
15515 | ENDIF | |
15516 | ENDIF | |
15517 | 13 CONTINUE | |
15518 | IF (LEMCCK) THEN | |
15519 | CHKLEV = TINY1 | |
15520 | CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,6,IREJ1) | |
15521 | C IF (IREJ1.NE.0) CALL DT_EVTOUT(4) | |
15522 | ENDIF | |
15523 | ||
15524 | * global energy-momentum & flavor conservation check | |
15525 | **sr 16.5. this check is skipped in case of phojet-treatment | |
15526 | IF (MCGENE.EQ.1) | |
15527 | & CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,12,IREJ3) | |
15528 | ||
15529 | * update statistics-counter for diffraction | |
15530 | c IF (IFLAGD.NE.0) THEN | |
15531 | c ICDIFF(1) = ICDIFF(1)+1 | |
15532 | c IF (IFLAGD.EQ. 1) ICDIFF(2) = ICDIFF(2)+1 | |
15533 | c IF (IFLAGD.EQ. 2) ICDIFF(3) = ICDIFF(3)+1 | |
15534 | c IF (IFLAGD.EQ.-1) ICDIFF(4) = ICDIFF(4)+1 | |
15535 | c IF (IFLAGD.EQ.-2) ICDIFF(5) = ICDIFF(5)+1 | |
15536 | c ENDIF | |
15537 | ||
15538 | ENDIF | |
15539 | ||
15540 | RETURN | |
15541 | ||
15542 | 9999 CONTINUE | |
15543 | IREJ = 1 | |
15544 | RETURN | |
15545 | END | |
15546 | ||
15547 | *$ CREATE DT_DECAYS.FOR | |
15548 | *COPY DT_DECAYS | |
15549 | * | |
15550 | *===decay==============================================================* | |
15551 | * | |
15552 | SUBROUTINE DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ) | |
15553 | ||
15554 | ************************************************************************ | |
15555 | * Resonance-decay. * | |
15556 | * This subroutine replaces DDECAY/DECHKK. * | |
15557 | * PIN(4) 4-momentum of resonance (input) * | |
15558 | * IDXIN BAMJET-index of resonance (input) * | |
15559 | * POUT(20,4) 4-momenta of decay-products (output) * | |
15560 | * IDXOUT(20) BAMJET-indices of decay-products (output) * | |
15561 | * NSEC number of secondaries (output) * | |
15562 | * Adopted from the original version DECHKK. * | |
15563 | * This version dated 09.01.95 is written by S. Roesler * | |
15564 | ************************************************************************ | |
15565 | ||
15566 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
15567 | SAVE | |
15568 | ||
15569 | PARAMETER ( LINP = 10 , | |
15570 | & LOUT = 6 , | |
15571 | & LDAT = 9 ) | |
15572 | ||
15573 | PARAMETER (TINY17=1.0D-17) | |
15574 | ||
15575 | * HADRIN: decay channel information | |
15576 | PARAMETER (IDMAX9=602) | |
15577 | CHARACTER*8 ZKNAME | |
15578 | COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3) | |
15579 | ||
15580 | * particle properties (BAMJET index convention) | |
15581 | CHARACTER*8 ANAME | |
15582 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
15583 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
15584 | ||
15585 | * flags for input different options | |
15586 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
15587 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
15588 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
15589 | ||
15590 | DIMENSION PIN(4),PI(20,4),POUT(20,4),IDXOUT(20), | |
15591 | & EF(3),PF(3),PFF(3),IDXSTK(20),IDX(3), | |
15592 | & CODF(3),COFF(3),SIFF(3),DCOS(3),DCOSF(3) | |
15593 | ||
15594 | * ISTAB = 1 strong and weak decays | |
15595 | * = 2 strong decays only | |
15596 | * = 3 strong decays, weak decays for charmed particles and tau | |
15597 | * leptons only | |
15598 | DATA ISTAB /2/ | |
15599 | ||
15600 | IREJ = 0 | |
15601 | NSEC = 0 | |
15602 | * put initial resonance to stack | |
15603 | NSTK = 1 | |
15604 | IDXSTK(NSTK) = IDXIN | |
15605 | DO 5 I=1,4 | |
15606 | PI(NSTK,I) = PIN(I) | |
15607 | 5 CONTINUE | |
15608 | ||
15609 | * store initial configuration for energy-momentum cons. check | |
15610 | IF (LEMCCK) CALL DT_EVTEMC(PI(NSTK,1),PI(NSTK,2),PI(NSTK,3), | |
15611 | & PI(NSTK,4),1,IDUM,IDUM) | |
15612 | ||
15613 | 100 CONTINUE | |
15614 | * get particle from stack | |
15615 | IDXI = IDXSTK(NSTK) | |
15616 | * skip stable particles | |
15617 | IF (ISTAB.EQ.1) THEN | |
15618 | IF ((IDXI.EQ.135).OR. (IDXI.EQ.136)) GOTO 10 | |
15619 | IF ((IDXI.GE. 1).AND.(IDXI.LE. 7)) GOTO 10 | |
15620 | ELSEIF (ISTAB.EQ.2) THEN | |
15621 | IF ((IDXI.GE. 1).AND.(IDXI.LE. 30)) GOTO 10 | |
15622 | IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10 | |
15623 | IF ((IDXI.GE.115).AND.(IDXI.LE.122)) GOTO 10 | |
15624 | IF ((IDXI.GE.131).AND.(IDXI.LE.136)) GOTO 10 | |
15625 | IF ( IDXI.EQ.109) GOTO 10 | |
15626 | IF ((IDXI.GE.137).AND.(IDXI.LE.160)) GOTO 10 | |
15627 | ELSEIF (ISTAB.EQ.3) THEN | |
15628 | IF ((IDXI.GE. 1).AND.(IDXI.LE. 23)) GOTO 10 | |
15629 | IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10 | |
15630 | IF ((IDXI.GE.109).AND.(IDXI.LE.115)) GOTO 10 | |
15631 | IF ((IDXI.GE.133).AND.(IDXI.LE.136)) GOTO 10 | |
15632 | ENDIF | |
15633 | ||
15634 | * calculate direction cosines and Lorentz-parameter of decaying part. | |
15635 | PTOT = SQRT(PI(NSTK,1)**2+PI(NSTK,2)**2+PI(NSTK,3)**2) | |
15636 | PTOT = MAX(PTOT,TINY17) | |
15637 | DO 1 I=1,3 | |
15638 | DCOS(I) = PI(NSTK,I)/PTOT | |
15639 | 1 CONTINUE | |
15640 | GAM = PI(NSTK,4)/AAM(IDXI) | |
15641 | BGAM = PTOT/AAM(IDXI) | |
15642 | ||
15643 | * get decay-channel | |
15644 | KCHAN = K1(IDXI)-1 | |
15645 | 2 CONTINUE | |
15646 | KCHAN = KCHAN+1 | |
15647 | IF ((DT_RNDM(GAM)-TINY17).GT.WT(KCHAN)) GOTO 2 | |
15648 | ||
15649 | * identities of secondaries | |
15650 | IDX(1) = NZK(KCHAN,1) | |
15651 | IDX(2) = NZK(KCHAN,2) | |
15652 | IF (IDX(2).LT.1) GOTO 9999 | |
15653 | IDX(3) = NZK(KCHAN,3) | |
15654 | ||
15655 | * handle decay in rest system of decaying particle | |
15656 | IF (IDX(3).EQ.0) THEN | |
15657 | * two-particle decay | |
15658 | NDEC = 2 | |
15659 | CALL DT_DTWOPD(AAM(IDXI),EF(1),EF(2),PF(1),PF(2), | |
15660 | & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2), | |
15661 | & AAM(IDX(1)),AAM(IDX(2))) | |
15662 | ELSE | |
15663 | * three-particle decay | |
15664 | NDEC = 3 | |
15665 | CALL DT_DTHREP(AAM(IDXI),EF(1),EF(2),EF(3),PF(1),PF(2),PF(3), | |
15666 | & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2), | |
15667 | & CODF(3),COFF(3),SIFF(3), | |
15668 | & AAM(IDX(1)),AAM(IDX(2)),AAM(IDX(3))) | |
15669 | ENDIF | |
15670 | NSTK = NSTK-1 | |
15671 | ||
15672 | * transform decay products back | |
15673 | DO 3 I=1,NDEC | |
15674 | NSTK = NSTK+1 | |
15675 | CALL DT_DTRAFO(GAM,BGAM,DCOS(1),DCOS(2),DCOS(3), | |
15676 | & CODF(I),COFF(I),SIFF(I),PF(I),EF(I), | |
15677 | & PFF(I),DCOSF(1),DCOSF(2),DCOSF(3),PI(NSTK,4)) | |
15678 | * add particle to stack | |
15679 | IDXSTK(NSTK) = IDX(I) | |
15680 | DO 4 J=1,3 | |
15681 | PI(NSTK,J) = DCOSF(J)*PFF(I) | |
15682 | 4 CONTINUE | |
15683 | 3 CONTINUE | |
15684 | GOTO 100 | |
15685 | ||
15686 | 10 CONTINUE | |
15687 | * stable particle, put to output-arrays | |
15688 | NSEC = NSEC+1 | |
15689 | DO 6 I=1,4 | |
15690 | POUT(NSEC,I) = PI(NSTK,I) | |
15691 | 6 CONTINUE | |
15692 | IDXOUT(NSEC) = IDXSTK(NSTK) | |
15693 | * store secondaries for energy-momentum conservation check | |
15694 | IF (LEMCCK) | |
15695 | &CALL DT_EVTEMC(-POUT(NSEC,1),-POUT(NSEC,2),-POUT(NSEC,3), | |
15696 | & -POUT(NSEC,4),2,IDUM,IDUM) | |
15697 | NSTK = NSTK-1 | |
15698 | IF (NSTK.GT.0) GOTO 100 | |
15699 | ||
15700 | * check energy-momentum conservation | |
15701 | IF (LEMCCK) THEN | |
15702 | CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,5,IREJ1) | |
15703 | IF (IREJ1.NE.0) GOTO 9999 | |
15704 | ENDIF | |
15705 | ||
15706 | RETURN | |
15707 | ||
15708 | 9999 CONTINUE | |
15709 | IREJ = 1 | |
15710 | RETURN | |
15711 | END | |
15712 | ||
15713 | *$ CREATE DT_DECAY1.FOR | |
15714 | *COPY DT_DECAY1 | |
15715 | * | |
15716 | *===decay1=============================================================* | |
15717 | * | |
15718 | SUBROUTINE DT_DECAY1 | |
15719 | ||
15720 | ************************************************************************ | |
15721 | * Decay of resonances stored in DTEVT1. * | |
15722 | * This version dated 20.01.95 is written by S. Roesler * | |
15723 | ************************************************************************ | |
15724 | ||
15725 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
15726 | SAVE | |
15727 | ||
15728 | PARAMETER ( LINP = 10 , | |
15729 | & LOUT = 6 , | |
15730 | & LDAT = 9 ) | |
15731 | ||
15732 | * event history | |
15733 | ||
15734 | PARAMETER (NMXHKK=200000) | |
15735 | ||
15736 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
15737 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
15738 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
15739 | ||
15740 | * extended event history | |
15741 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
15742 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
15743 | & IHIST(2,NMXHKK) | |
15744 | ||
15745 | DIMENSION PIN(4),POUT(20,4),IDXOUT(20) | |
15746 | ||
15747 | NEND = NHKK | |
15748 | C DO 1 I=NPOINT(5),NEND | |
15749 | DO 1 I=NPOINT(4),NEND | |
15750 | IF (ABS(ISTHKK(I)).EQ.1) THEN | |
15751 | DO 2 K=1,4 | |
15752 | PIN(K) = PHKK(K,I) | |
15753 | 2 CONTINUE | |
15754 | IDXIN = IDBAM(I) | |
15755 | CALL DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ) | |
15756 | IF (NSEC.GT.1) THEN | |
15757 | DO 3 N=1,NSEC | |
15758 | IDHAD = IDT_IPDGHA(IDXOUT(N)) | |
15759 | CALL DT_EVTPUT(1,IDHAD,I,0,POUT(N,1),POUT(N,2), | |
15760 | & POUT(N,3),POUT(N,4),0,0,0) | |
15761 | 3 CONTINUE | |
15762 | ENDIF | |
15763 | ENDIF | |
15764 | 1 CONTINUE | |
15765 | ||
15766 | RETURN | |
15767 | END | |
15768 | ||
15769 | *$ CREATE DT_DECPI0.FOR | |
15770 | *COPY DT_DECPI0 | |
15771 | * | |
15772 | *===decpi0=============================================================* | |
15773 | * | |
15774 | SUBROUTINE DT_DECPI0 | |
15775 | ||
15776 | ************************************************************************ | |
15777 | * Decay of pi0 handled with JETSET. * | |
15778 | * This version dated 18.02.96 is written by S. Roesler * | |
15779 | ************************************************************************ | |
15780 | ||
15781 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
15782 | SAVE | |
15783 | ||
15784 | PARAMETER ( LINP = 10 , | |
15785 | & LOUT = 6 , | |
15786 | & LDAT = 9 ) | |
15787 | ||
15788 | PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0,ZERO=0.0D0) | |
15789 | ||
15790 | * event history | |
15791 | ||
15792 | PARAMETER (NMXHKK=200000) | |
15793 | ||
15794 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
15795 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
15796 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
15797 | ||
15798 | * extended event history | |
15799 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
15800 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
15801 | & IHIST(2,NMXHKK) | |
15802 | ||
15803 | COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5) | |
15804 | COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) | |
15805 | PARAMETER (MAXLND=4000) | |
15806 | COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5) | |
15807 | ||
15808 | * flags for input different options | |
15809 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
15810 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
15811 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
15812 | ||
15813 | INTEGER PYCOMP,PYK | |
15814 | ||
15815 | DIMENSION IHISMO(NMXHKK),P1(4) | |
15816 | ||
15817 | TWOPI = 2.0D0*ATAN2(0.0D0,-1.0D0) | |
15818 | ||
15819 | CALL DT_INITJS(2) | |
15820 | * allow pi0 decay | |
15821 | ||
15822 | KC = PYCOMP(111) | |
15823 | ||
15824 | MDCY(KC,1) = 1 | |
15825 | ||
15826 | NN = 0 | |
15827 | INI = 0 | |
15828 | DO 1 I=1,NHKK | |
15829 | IF ((ISTHKK(I).EQ.1).AND.(IDHKK(I).EQ.111)) THEN | |
15830 | IF (INI.EQ.0) THEN | |
15831 | INI = 1 | |
15832 | ELSE | |
15833 | INI = 2 | |
15834 | ENDIF | |
15835 | IF (LEMCCK) CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I), | |
15836 | & PHKK(4,I),INI,IDUM,IDUM) | |
15837 | PT = SQRT(PHKK(1,I)**2+PHKK(2,I)**2) | |
15838 | PTOT = SQRT(PT**2+PHKK(3,I)**2) | |
15839 | COSTH = PHKK(3,I)/(PTOT+TINY10) | |
15840 | IF (COSTH.GT.ONE) THEN | |
15841 | THETA = ZERO | |
15842 | ELSEIF (COSTH.LT.-ONE) THEN | |
15843 | THETA = TWOPI/2.0D0 | |
15844 | ELSE | |
15845 | THETA = ACOS(COSTH) | |
15846 | ENDIF | |
15847 | PHI = ASIN(PHKK(2,I)/(PT +TINY10)) | |
15848 | IF (PHKK(1,I).LT.0.0D0) | |
15849 | ||
15850 | & PHI = SIGN(TWOPI/2.0D0-ABS(PHI),PHI) | |
15851 | ||
15852 | ENER = PHKK(4,I) | |
15853 | NN = NN+1 | |
15854 | KTEMP = MSTU(10) | |
15855 | MSTU(10)= 1 | |
15856 | P(NN,5) = PHKK(5,I) | |
15857 | ||
15858 | CALL PY1ENT(NN,111,ENER,THETA,PHI) | |
15859 | ||
15860 | MSTU(10) = KTEMP | |
15861 | IHISMO(NN)= I | |
15862 | ENDIF | |
15863 | 1 CONTINUE | |
15864 | IF (NN.GT.0) THEN | |
15865 | ||
15866 | CALL PYEXEC | |
15867 | ||
15868 | NLINES = PYK(0,1) | |
15869 | ||
15870 | DO 2 II=1,NLINES | |
15871 | ||
15872 | IF (PYK(II,7).EQ.1) THEN | |
15873 | ||
15874 | DO 3 KK=1,4 | |
15875 | ||
15876 | P1(KK) = PYP(II,KK) | |
15877 | ||
15878 | 3 CONTINUE | |
15879 | ||
15880 | ID = PYK(II,8) | |
15881 | MO = IHISMO(PYK(II,15)) | |
15882 | ||
15883 | CALL DT_EVTPUT(1,ID,MO,0,P1(1),P1(2),P1(3),P1(4),0,0,0) | |
15884 | IF (LEMCCK) | |
15885 | & CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2, | |
15886 | & IDUM,IDUM) | |
15887 | *sr: flag with neg. sign (for HELIOS p/A-W jobs) | |
15888 | ISTHKK(MO) = -2 | |
15889 | ENDIF | |
15890 | 2 CONTINUE | |
15891 | IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,7000,IREJ1) | |
15892 | ENDIF | |
15893 | MDCY(KC,1) = 0 | |
15894 | ||
15895 | RETURN | |
15896 | END | |
15897 | ||
15898 | *$ CREATE DT_DTWOPD.FOR | |
15899 | *COPY DT_DTWOPD | |
15900 | * | |
15901 | *===dtwopd=============================================================* | |
15902 | * | |
15903 | SUBROUTINE DT_DTWOPD(UMO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,COD2, | |
15904 | & COF2,SIF2,AM1,AM2) | |
15905 | ||
15906 | ************************************************************************ | |
15907 | * Two-particle decay. * | |
15908 | * UMO cm-energy of the decaying system (input) * | |
15909 | * AM1/AM2 masses of the decay products (input) * | |
15910 | * ECM1,ECM2/PCM1,PCM2 cm-energies/momenta of the decay prod. (output) * | |
15911 | * COD,COF,SIF direction cosines of the decay prod. (output) * | |
15912 | * Revised by S. Roesler, 20.11.95 * | |
15913 | ************************************************************************ | |
15914 | ||
15915 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
15916 | SAVE | |
15917 | ||
15918 | PARAMETER ( LINP = 10 , | |
15919 | & LOUT = 6 , | |
15920 | & LDAT = 9 ) | |
15921 | ||
15922 | PARAMETER (TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,ZERO=0.0D0) | |
15923 | ||
15924 | IF (UMO.LT.(AM1+AM2)) THEN | |
15925 | WRITE(LOUT,1000) UMO,AM1,AM2 | |
15926 | 1000 FORMAT(1X,'DTWOPD: inconsistent kinematics - UMO,AM1,AM2 ', | |
15927 | & 3E12.3) | |
15928 | STOP | |
15929 | ENDIF | |
15930 | ||
15931 | ECM1 = ((UMO-AM2)*(UMO+AM2)+AM1*AM1)/(TWO*UMO) | |
15932 | ECM2 = UMO-ECM1 | |
15933 | PCM1 = SQRT((ECM1-AM1)*(ECM1+AM1)) | |
15934 | PCM2 = PCM1 | |
15935 | CALL DT_DSFECF(SIF1,COF1) | |
15936 | COD1 = TWO*DT_RNDM(PCM2)-ONE | |
15937 | COD2 = -COD1 | |
15938 | COF2 = -COF1 | |
15939 | SIF2 = -SIF1 | |
15940 | ||
15941 | RETURN | |
15942 | END | |
15943 | ||
15944 | *$ CREATE DT_DTHREP.FOR | |
15945 | *COPY DT_DTHREP | |
15946 | * | |
15947 | *===dthrep=============================================================* | |
15948 | * | |
15949 | SUBROUTINE DT_DTHREP(UMO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1, | |
15950 | & SIF1,COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3) | |
15951 | ||
15952 | ************************************************************************ | |
15953 | * Three-particle decay. * | |
15954 | * UMO cm-energy of the decaying system (input) * | |
15955 | * AM1/2/3 masses of the decay products (input) * | |
15956 | * ECM1/2/2,PCM1/2/3 cm-energies/momenta of the decay prod. (output) * | |
15957 | * COD,COF,SIF direction cosines of the decay prod. (output) * | |
15958 | * * | |
15959 | * Threpd89: slight revision by A. Ferrari * | |
15960 | * Last change on 11-oct-93 by Alfredo Ferrari, INFN - Milan * | |
15961 | * Revised by S. Roesler, 20.11.95 * | |
15962 | ************************************************************************ | |
15963 | ||
15964 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
15965 | SAVE | |
15966 | ||
15967 | PARAMETER ( LINP = 10 , | |
15968 | & LOUT = 6 , | |
15969 | & LDAT = 9 ) | |
15970 | ||
15971 | PARAMETER ( ANGLSQ = 2.5D-31 ) | |
15972 | PARAMETER ( AZRZRZ = 1.0D-30 ) | |
15973 | PARAMETER ( ONEMNS = 0.999999999999999 D+00 ) | |
15974 | PARAMETER ( ONEPLS = 1.000000000000001 D+00 ) | |
15975 | PARAMETER ( ONEONE = 1.D+00 ) | |
15976 | PARAMETER ( TWOTWO = 2.D+00 ) | |
15977 | PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 ) | |
15978 | ||
15979 | COMMON /HNGAMR/ REDU,AMO,AMM(15) | |
15980 | ||
15981 | * flags for input different options | |
15982 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
15983 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
15984 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
15985 | ||
15986 | DIMENSION F(5),XX(5) | |
15987 | DATA EPS /AZRZRZ/ | |
15988 | ||
15989 | UMOO=UMO+UMO | |
15990 | C***S1, S2, S3 ARE THE INVARIANT MASSES OF THE PARTICLES 1, 2, 3 | |
15991 | C***J. VON NEUMANN - RANDOM - SELECTION OF S2 | |
15992 | C***CALCULATION OF THE MAXIMUM OF THE S2 - DISTRIBUTION | |
15993 | UUMO=UMO | |
15994 | AAM1=AM1 | |
15995 | AAM2=AM2 | |
15996 | AAM3=AM3 | |
15997 | GU=(AM2+AM3)**2 | |
15998 | GO=(UMO-AM1)**2 | |
15999 | * UFAK=1.0000000000001D0 | |
16000 | * IF (GU.GT.GO) UFAK=0.9999999999999D0 | |
16001 | IF (GU.GT.GO) THEN | |
16002 | UFAK=ONEMNS | |
16003 | ELSE | |
16004 | UFAK=ONEPLS | |
16005 | END IF | |
16006 | OFAK=2.D0-UFAK | |
16007 | GU=GU*UFAK | |
16008 | GO=GO*OFAK | |
16009 | DS2=(GO-GU)/99.D0 | |
16010 | AM11=AM1*AM1 | |
16011 | AM22=AM2*AM2 | |
16012 | AM33=AM3*AM3 | |
16013 | UMO2=UMO*UMO | |
16014 | RHO2=0.D0 | |
16015 | S22=GU | |
16016 | DO 124 I=1,100 | |
16017 | S21=S22 | |
16018 | S22=GU+(I-1.D0)*DS2 | |
16019 | RHO1=RHO2 | |
16020 | RHO2=DT_YLAMB(S22,UMO2,AM11)*DT_YLAMB(S22,AM22,AM33)/ | |
16021 | * (S22+EPS) | |
16022 | IF(RHO2.LT.RHO1) GO TO 125 | |
16023 | 124 CONTINUE | |
16024 | 125 S2SUP=(S22-S21)*.5D0+S21 | |
16025 | SUPRHO=DT_YLAMB(S2SUP,UMO2,AM11)*DT_YLAMB(S2SUP,AM22,AM33)/ | |
16026 | * (S2SUP+EPS) | |
16027 | SUPRHO=SUPRHO*1.05D0 | |
16028 | XO=S21-DS2 | |
16029 | IF (GU.LT.GO.AND.XO.LT.GU) XO=GU | |
16030 | IF (GU.GT.GO.AND.XO.GT.GU) XO=GU | |
16031 | XX(1)=XO | |
16032 | XX(3)=S22 | |
16033 | X1=(XO+S22)*0.5D0 | |
16034 | XX(2)=X1 | |
16035 | F(3)=RHO2 | |
16036 | F(1)=DT_YLAMB(XO,UMO2,AM11)*DT_YLAMB(XO,AM22,AM33)/(XO+EPS) | |
16037 | F(2)=DT_YLAMB(X1,UMO2,AM11)*DT_YLAMB(X1,AM22,AM33)/(X1+EPS) | |
16038 | DO 126 I=1,16 | |
16039 | X4=(XX(1)+XX(2))*0.5D0 | |
16040 | X5=(XX(2)+XX(3))*0.5D0 | |
16041 | F(4)=DT_YLAMB(X4,UMO2,AM11)*DT_YLAMB(X4,AM22,AM33)/ | |
16042 | * (X4+EPS) | |
16043 | F(5)=DT_YLAMB(X5,UMO2,AM11)*DT_YLAMB(X5,AM22,AM33)/ | |
16044 | * (X5+EPS) | |
16045 | XX(4)=X4 | |
16046 | XX(5)=X5 | |
16047 | DO 128 II=1,5 | |
16048 | IA=II | |
16049 | DO 128 III=IA,5 | |
16050 | IF (F (II).GE.F (III)) GO TO 128 | |
16051 | FH=F(II) | |
16052 | F(II)=F(III) | |
16053 | F(III)=FH | |
16054 | FH=XX(II) | |
16055 | XX(II)=XX(III) | |
16056 | XX(III)=FH | |
16057 | 128 CONTINUE | |
16058 | SUPRHO=F(1) | |
16059 | S2SUP=XX(1) | |
16060 | DO 129 II=1,3 | |
16061 | IA=II | |
16062 | DO 129 III=IA,3 | |
16063 | IF (XX(II).GE.XX(III)) GO TO 129 | |
16064 | FH=F(II) | |
16065 | F(II)=F(III) | |
16066 | F(III)=FH | |
16067 | FH=XX(II) | |
16068 | XX(II)=XX(III) | |
16069 | XX(III)=FH | |
16070 | 129 CONTINUE | |
16071 | 126 CONTINUE | |
16072 | AM23=(AM2+AM3)**2 | |
16073 | ITH=0 | |
16074 | REDU=2.D0 | |
16075 | 1 CONTINUE | |
16076 | ITH=ITH+1 | |
16077 | IF (ITH.GT.200) REDU=-9.D0 | |
16078 | IF (ITH.GT.200) GO TO 400 | |
16079 | C=DT_RNDM(REDU) | |
16080 | * S2=AM23+C*((UMO-AM1)**2-AM23) | |
16081 | S2=AM23+C*(UMO-AM1-AM2-AM3)*(UMO-AM1+AM2+AM3) | |
16082 | Y=DT_RNDM(S2) | |
16083 | Y=Y*SUPRHO | |
16084 | RHO=DT_YLAMB(S2,UMO2,AM11)*DT_YLAMB(S2,AM22,AM33)/S2 | |
16085 | IF(Y.GT.RHO) GO TO 1 | |
16086 | C***RANDOM SELECTION OF S3 AND CALCULATION OF S1 | |
16087 | S1=DT_RNDM(S2) | |
16088 | S1=S1*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)/(2.D0*S2)- | |
16089 | &RHO*.5D0 | |
16090 | S3=UMO2+AM11+AM22+AM33-S1-S2 | |
16091 | ECM1=(UMO2+AM11-S2)/UMOO | |
16092 | ECM2=(UMO2+AM22-S3)/UMOO | |
16093 | ECM3=(UMO2+AM33-S1)/UMOO | |
16094 | PCM1=SQRT((ECM1+AM1)*(ECM1-AM1)) | |
16095 | PCM2=SQRT((ECM2+AM2)*(ECM2-AM2)) | |
16096 | PCM3=SQRT((ECM3+AM3)*(ECM3-AM3)) | |
16097 | CALL DT_DSFECF(SFE,CFE) | |
16098 | C***TH IS THE ANGLE BETWEEN PARTICLES 1 AND 2 | |
16099 | C***TH1, TH2 ARE THE ANGLES BETWEEN PARTICLES 1, 2 AND THE DIRECTION OF | |
16100 | PCM12 = PCM1 * PCM2 | |
16101 | IF ( PCM12 .LT. ANGLSQ ) GO TO 200 | |
16102 | COSTH=(ECM1*ECM2+0.5D+00*(AM11+AM22-S1))/PCM12 | |
16103 | GO TO 300 | |
16104 | 200 CONTINUE | |
16105 | UW=DT_RNDM(S1) | |
16106 | COSTH=(UW-0.5D+00)*2.D+00 | |
16107 | 300 CONTINUE | |
16108 | * IF(ABS(COSTH).GT.0.9999999999999999D0) | |
16109 | * &COSTH=SIGN(0.9999999999999999D0,COSTH) | |
16110 | IF(ABS(COSTH).GT.ONEONE) | |
16111 | &COSTH=SIGN(ONEONE,COSTH) | |
16112 | IF (REDU.LT.1.D+00) RETURN | |
16113 | COSTH2=(PCM3*PCM3+PCM2*PCM2-PCM1*PCM1)/(2.D+00*PCM2*PCM3) | |
16114 | * IF(ABS(COSTH2).GT.0.9999999999999999D0) | |
16115 | * &COSTH2=SIGN(0.9999999999999999D0,COSTH2) | |
16116 | IF(ABS(COSTH2).GT.ONEONE) | |
16117 | &COSTH2=SIGN(ONEONE,COSTH2) | |
16118 | SINTH2=SQRT((ONEONE-COSTH2)*(ONEONE+COSTH2)) | |
16119 | SINTH =SQRT((ONEONE-COSTH)*(ONEONE+COSTH)) | |
16120 | SINTH1=COSTH2*SINTH-COSTH*SINTH2 | |
16121 | COSTH1=COSTH*COSTH2+SINTH2*SINTH | |
16122 | C***RANDOM SELECTION OF THE SPHERICAL COORDINATES OF THE DIRECTION OF PA | |
16123 | C***CFE, SFE ARE COS AND SIN OF THE ROTATION ANGLE OF THE SYSTEM 1, 2 AR | |
16124 | C***THE DIRECTION OF PARTICLE 3 | |
16125 | C***CALCULATION OF THE SPHERICAL COORDINATES OF PARTICLES 1, 2 | |
16126 | CX11=-COSTH1 | |
16127 | CY11=SINTH1*CFE | |
16128 | CZ11=SINTH1*SFE | |
16129 | CX22=-COSTH2 | |
16130 | CY22=-SINTH2*CFE | |
16131 | CZ22=-SINTH2*SFE | |
16132 | CALL DT_DSFECF(SIF3,COF3) | |
16133 | COD3=TWOTWO*DT_RNDM(CX11)-ONEONE | |
16134 | SID3=SQRT((1.D+00-COD3)*(1.D+00+COD3)) | |
16135 | 2 FORMAT(5F20.15) | |
16136 | COD1=CX11*COD3+CZ11*SID3 | |
16137 | CHLP=(ONEONE-COD1)*(ONEONE+COD1) | |
16138 | IF(CHLP.LT.1.D-14)WRITE(LOUT,2)COD1,COF3,SID3, | |
16139 | &CX11,CZ11 | |
16140 | SID1=SQRT(CHLP) | |
16141 | COF1=(CX11*SID3*COF3-CY11*SIF3-CZ11*COD3*COF3)/SID1 | |
16142 | SIF1=(CX11*SID3*SIF3+CY11*COF3-CZ11*COD3*SIF3)/SID1 | |
16143 | COD2=CX22*COD3+CZ22*SID3 | |
16144 | SID2=SQRT((ONEONE-COD2)*(ONEONE+COD2)) | |
16145 | COF2=(CX22*SID3*COF3-CY22*SIF3-CZ22*COD3*COF3)/SID2 | |
16146 | SIF2=(CX22*SID3*SIF3+CY22*COF3-CZ22*COD3*SIF3)/SID2 | |
16147 | 400 CONTINUE | |
16148 | * === Energy conservation check: === * | |
16149 | EOCHCK = UMO - ECM1 - ECM2 - ECM3 | |
16150 | * SID1 = SQRT ( ( ONEONE - COD1 ) * ( ONEONE + COD1 ) ) | |
16151 | * SID2 = SQRT ( ( ONEONE - COD2 ) * ( ONEONE + COD2 ) ) | |
16152 | * SID3 = SQRT ( ( ONEONE - COD3 ) * ( ONEONE + COD3 ) ) | |
16153 | PZCHCK = PCM1 * COD1 + PCM2 * COD2 + PCM3 * COD3 | |
16154 | PXCHCK = PCM1 * COF1 * SID1 + PCM2 * COF2 * SID2 | |
16155 | & + PCM3 * COF3 * SID3 | |
16156 | PYCHCK = PCM1 * SIF1 * SID1 + PCM2 * SIF2 * SID2 | |
16157 | & + PCM3 * SIF3 * SID3 | |
16158 | EOCMPR = 1.D-12 * UMO | |
16159 | IF ( ABS (EOCHCK) + ABS (PXCHCK) + ABS (PYCHCK) + ABS (PZCHCK) | |
16160 | & .GT. EOCMPR ) THEN | |
16161 | **sr 5.5.95 output-unit changed | |
16162 | IF (IOULEV(1).GT.0) THEN | |
16163 | WRITE(LOUT,*) | |
16164 | & ' *** Threpd: energy/momentum conservation failure! ***', | |
16165 | & EOCHCK,PXCHCK,PYCHCK,PZCHCK | |
16166 | WRITE(LOUT,*)' *** SID1,SID2,SID3',SID1,SID2,SID3 | |
16167 | ENDIF | |
16168 | ** | |
16169 | END IF | |
16170 | RETURN | |
16171 | END | |
16172 | ||
16173 | *$ CREATE DT_DBKLAS.FOR | |
16174 | *COPY DT_DBKLAS | |
16175 | * | |
16176 | *===dbklas=============================================================* | |
16177 | * | |
16178 | SUBROUTINE DT_DBKLAS(I,J,K,I8,I10) | |
16179 | ||
16180 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
16181 | SAVE | |
16182 | ||
16183 | PARAMETER ( LINP = 10 , | |
16184 | & LOUT = 6 , | |
16185 | & LDAT = 9 ) | |
16186 | ||
16187 | * quark-content to particle index conversion (DTUNUC 1.x) | |
16188 | COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21), | |
16189 | & IA08(6,21),IA10(6,21) | |
16190 | ||
16191 | IF (I) 20,20,10 | |
16192 | * baryons | |
16193 | 10 CONTINUE | |
16194 | CALL DT_INDEXD(J,K,IND) | |
16195 | I8 = IB08(I,IND) | |
16196 | I10 = IB10(I,IND) | |
16197 | IF (I8.LE.0) I8 = I10 | |
16198 | RETURN | |
16199 | * antibaryons | |
16200 | 20 CONTINUE | |
16201 | II = IABS(I) | |
16202 | JJ = IABS(J) | |
16203 | KK = IABS(K) | |
16204 | CALL DT_INDEXD(JJ,KK,IND) | |
16205 | I8 = IA08(II,IND) | |
16206 | I10 = IA10(II,IND) | |
16207 | IF (I8.LE.0) I8 = I10 | |
16208 | ||
16209 | RETURN | |
16210 | END | |
16211 | ||
16212 | *$ CREATE DT_INDEXD.FOR | |
16213 | *COPY DT_INDEXD | |
16214 | * | |
16215 | *===indexd=============================================================* | |
16216 | * | |
16217 | SUBROUTINE DT_INDEXD(KA,KB,IND) | |
16218 | ||
16219 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
16220 | SAVE | |
16221 | ||
16222 | PARAMETER ( LINP = 10 , | |
16223 | & LOUT = 6 , | |
16224 | & LDAT = 9 ) | |
16225 | ||
16226 | KP = KA*KB | |
16227 | KS = KA+KB | |
16228 | IF (KP.EQ.1) IND=1 | |
16229 | IF (KP.EQ.2) IND=2 | |
16230 | IF (KP.EQ.3) IND=3 | |
16231 | IF ((KP.EQ.4).AND.(KS.EQ.5)) IND=4 | |
16232 | IF (KP.EQ.5) IND=5 | |
16233 | IF ((KP.EQ.6).AND.(KS.EQ.7)) IND=6 | |
16234 | IF ((KP.EQ.4).AND.(KS.EQ.4)) IND=7 | |
16235 | IF ((KP.EQ.6).AND.(KS.EQ.5)) IND=8 | |
16236 | IF (KP.EQ.8) IND=9 | |
16237 | IF (KP.EQ.10) IND=10 | |
16238 | IF ((KP.EQ.12).AND.(KS.EQ.8)) IND=11 | |
16239 | IF (KP.EQ.9) IND=12 | |
16240 | IF ((KP.EQ.12).AND.(KS.EQ.7)) IND=13 | |
16241 | IF (KP.EQ.15) IND=14 | |
16242 | IF (KP.EQ.18) IND=15 | |
16243 | IF (KP.EQ.16) IND=16 | |
16244 | IF (KP.EQ.20) IND=17 | |
16245 | IF (KP.EQ.24) IND=18 | |
16246 | IF (KP.EQ.25) IND=19 | |
16247 | IF (KP.EQ.30) IND=20 | |
16248 | IF (KP.EQ.36) IND=21 | |
16249 | ||
16250 | RETURN | |
16251 | END | |
16252 | ||
16253 | *$ CREATE DT_DCHANT.FOR | |
16254 | *COPY DT_DCHANT | |
16255 | * | |
16256 | *===dchant=============================================================* | |
16257 | * | |
16258 | SUBROUTINE DT_DCHANT | |
16259 | ||
16260 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
16261 | SAVE | |
16262 | ||
16263 | PARAMETER ( LINP = 10 , | |
16264 | & LOUT = 6 , | |
16265 | & LDAT = 9 ) | |
16266 | ||
16267 | PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0) | |
16268 | ||
16269 | * HADRIN: decay channel information | |
16270 | PARAMETER (IDMAX9=602) | |
16271 | CHARACTER*8 ZKNAME | |
16272 | COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3) | |
16273 | ||
16274 | * particle properties (BAMJET index convention) | |
16275 | CHARACTER*8 ANAME | |
16276 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
16277 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
16278 | ||
16279 | DIMENSION HWT(IDMAX9) | |
16280 | ||
16281 | * change of weights wt from absolut values into the sum of wt of a dec. | |
16282 | DO 10 J=1,IDMAX9 | |
16283 | HWT(J) = ZERO | |
16284 | 10 CONTINUE | |
16285 | C DO 999 KKK=1,210 | |
16286 | C WRITE(LOUT,'(A8,F5.2,2E10.3,2I4,2I10)') | |
16287 | C & ANAME(KKK),AAM(KKK),GA(KKK),TAU(KKK),IICH(KKK),IIBAR(KKK), | |
16288 | C & K1(KKK),K2(KKK) | |
16289 | C 999 CONTINUE | |
16290 | C STOP | |
16291 | DO 30 I=1,210 | |
16292 | IK1 = K1(I) | |
16293 | IK2 = K2(I) | |
16294 | HV = ZERO | |
16295 | DO 20 J=IK1,IK2 | |
16296 | HV = HV+WT(J) | |
16297 | HWT(J) = HV | |
16298 | **sr 13.1.95 | |
16299 | IF (HWT(J).GT.1.0001) WRITE(LOUT,1000) HWT(J),J,I,IK1 | |
16300 | 1000 FORMAT(2X,15H ERROR IN HWT =,1F10.5,8H J,I,K1=,3I5) | |
16301 | 20 CONTINUE | |
16302 | 30 CONTINUE | |
16303 | DO 40 J=1,IDMAX9 | |
16304 | WT(J) = HWT(J) | |
16305 | 40 CONTINUE | |
16306 | ||
16307 | RETURN | |
16308 | END | |
16309 | ||
16310 | *$ CREATE DT_DDATAR.FOR | |
16311 | *COPY DT_DDATAR | |
16312 | * | |
16313 | *===ddatar=============================================================* | |
16314 | * | |
16315 | SUBROUTINE DT_DDATAR | |
16316 | ||
16317 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
16318 | SAVE | |
16319 | ||
16320 | PARAMETER ( LINP = 10 , | |
16321 | & LOUT = 6 , | |
16322 | & LDAT = 9 ) | |
16323 | ||
16324 | PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0) | |
16325 | ||
16326 | * quark-content to particle index conversion (DTUNUC 1.x) | |
16327 | COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21), | |
16328 | & IA08(6,21),IA10(6,21) | |
16329 | ||
16330 | DIMENSION IV(36),IP(36),IB(126),IBB(126),IA(126),IAA(126) | |
16331 | ||
16332 | DATA IV/ 33, 34, 38,123, 0, 0, 32, 33, 39,124, | |
16333 | & 0, 0, 36, 37, 96,127, 0, 0,126,125, | |
16334 | & 128,129,14*0/ | |
16335 | DATA IP/ 23, 14, 16,116, 0, 0, 13, 23, 25,117, | |
16336 | & 0, 0, 15, 24, 31,120, 0, 0,119,118, | |
16337 | & 121,122,14*0/ | |
16338 | DATA IB/ 0, 1, 21,140, 0, 0, 8, 22,137, 0, | |
16339 | & 0, 97,138, 0, 0,146, 0, 0, 0, 0, | |
16340 | & 0, 1, 8, 22,137, 0, 0, 0, 20,142, | |
16341 | & 0, 0, 98,139, 0, 0,147, 0, 0, 0, | |
16342 | & 0, 0, 21, 22, 97,138, 0, 0, 20, 98, | |
16343 | & 139, 0, 0, 0,145, 0, 0,148, 0, 0, | |
16344 | & 0, 0, 0,140,137,138,146, 0, 0,142, | |
16345 | & 139,147, 0, 0,145,148, 50*0/ | |
16346 | DATA IBB/53, 54,104,161, 0, 0, 55,105,162, 0, | |
16347 | & 0,107,164, 0, 0,167, 0, 0, 0, 0, | |
16348 | & 0, 54, 55,105,162, 0, 0, 56,106,163, | |
16349 | & 0, 0,108,165, 0, 0,168, 0, 0, 0, | |
16350 | & 0, 0,104,105,107,164, 0, 0,106,108, | |
16351 | & 165, 0, 0,109,166, 0, 0,169, 0, 0, | |
16352 | & 0, 0, 0,161,162,164,167, 0, 0,163, | |
16353 | & 165,168, 0, 0,166,169, 0, 0,170,47*0/ | |
16354 | DATA IA/ 0, 2, 99,152, 0, 0, 9,100,149, 0, | |
16355 | & 0,102,150, 0, 0,158, 0, 0, 0, 0, | |
16356 | & 0, 2, 9,100,149, 0, 0, 0,101,154, | |
16357 | & 0, 0,103,151, 0, 0,159, 0, 0, 0, | |
16358 | & 0, 0, 99,100,102,150, 0, 0,101,103, | |
16359 | & 151, 0, 0, 0,157, 0, 0,160, 0, 0, | |
16360 | & 0, 0, 0,152,149,150,158, 0, 0,154, | |
16361 | & 151,159, 0, 0,157,160, 50*0/ | |
16362 | DATA IAA/67, 68,110,171, 0, 0, 69,111,172, 0, | |
16363 | & 0,113,174, 0, 0,177, 0, 0, 0, 0, | |
16364 | & 0, 68, 69,111,172, 0, 0, 70,112,173, | |
16365 | & 0, 0,114,175, 0, 0,178, 0, 0, 0, | |
16366 | & 0, 0,110,111,113,174, 0, 0,112,114, | |
16367 | & 175, 0, 0,115,176, 0, 0,179, 0, 0, | |
16368 | & 0, 0, 0,171,172,174,177, 0, 0,173, | |
16369 | & 175,178, 0, 0,176,179, 0, 0,180,47*0/ | |
16370 | ||
16371 | L=0 | |
16372 | DO 2 I=1,6 | |
16373 | DO 1 J=1,6 | |
16374 | L = L+1 | |
16375 | IMPS(I,J) = IP(L) | |
16376 | IMVE(I,J) = IV(L) | |
16377 | 1 CONTINUE | |
16378 | 2 CONTINUE | |
16379 | L=0 | |
16380 | DO 4 I=1,6 | |
16381 | DO 3 J=1,21 | |
16382 | L = L+1 | |
16383 | IB08(I,J) = IB(L) | |
16384 | IB10(I,J) = IBB(L) | |
16385 | IA08(I,J) = IA(L) | |
16386 | IA10(I,J) = IAA(L) | |
16387 | 3 CONTINUE | |
16388 | 4 CONTINUE | |
16389 | C A1 = 0.88D0 | |
16390 | C B1 = 3.0D0 | |
16391 | C B2 = 3.0D0 | |
16392 | C B3 = 8.0D0 | |
16393 | C LT = 0 | |
16394 | C LB = 0 | |
16395 | C BET = 12.0D0 | |
16396 | C AS = 0.25D0 | |
16397 | C B8 = 0.33D0 | |
16398 | C AME = 0.95D0 | |
16399 | C DIQ = 0.375D0 | |
16400 | C ISU = 4 | |
16401 | ||
16402 | RETURN | |
16403 | END | |
16404 | ||
16405 | *$ CREATE DT_INITJS.FOR | |
16406 | *COPY DT_INITJS | |
16407 | * | |
16408 | *===initjs=============================================================* | |
16409 | * | |
16410 | SUBROUTINE DT_INITJS(MODE) | |
16411 | ||
16412 | ************************************************************************ | |
16413 | * Initialize JETSET paramters. * | |
16414 | * MODE = 0 default settings * | |
16415 | * = 1 PHOJET settings * | |
16416 | * = 2 DTUNUC settings * | |
16417 | * This version dated 16.02.96 is written by S. Roesler * | |
16418 | * * | |
16419 | * Last change 27.12.2006 by S. Roesler. * | |
16420 | ************************************************************************ | |
16421 | ||
16422 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
16423 | SAVE | |
16424 | ||
16425 | PARAMETER ( LINP = 10 , | |
16426 | & LOUT = 6 , | |
16427 | & LDAT = 9 ) | |
16428 | ||
16429 | PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0) | |
16430 | ||
16431 | LOGICAL LFIRST,LFIRDT,LFIRPH | |
16432 | ||
16433 | * INCLUDE '(DIMPAR)' | |
16434 | * DIMPAR taken from FLUKA | |
16435 | PARAMETER ( MXXRGN =20000 ) | |
16436 | PARAMETER ( MXXMDF = 710 ) | |
16437 | PARAMETER ( MXXMDE = 702 ) | |
16438 | PARAMETER ( MFSTCK =40000 ) | |
16439 | PARAMETER ( MESTCK = 100 ) | |
16440 | PARAMETER ( MOSTCK = 2000 ) | |
16441 | PARAMETER ( MXPRSN = 100 ) | |
16442 | PARAMETER ( MXPDPM = 800 ) | |
16443 | PARAMETER ( MXPSCS =30000 ) | |
16444 | PARAMETER ( MXGLWN = 300 ) | |
16445 | PARAMETER ( MXOUTU = 50 ) | |
16446 | PARAMETER ( NALLWP = 64 ) | |
16447 | PARAMETER ( NELEMX = 80 ) | |
16448 | PARAMETER ( MPDPDX = 18 ) | |
16449 | PARAMETER ( MXHTTR = 260 ) | |
16450 | PARAMETER ( MXSEAX = 20 ) | |
16451 | PARAMETER ( MXHTNC = MXSEAX + 1 ) | |
16452 | PARAMETER ( ICOMAX = 2400 ) | |
16453 | PARAMETER ( ICHMAX = ICOMAX + MXXMDF ) | |
16454 | PARAMETER ( NSTBIS = 304 ) | |
16455 | PARAMETER ( NQSTIS = 46 ) | |
16456 | PARAMETER ( NTSTIS = NSTBIS + NQSTIS ) | |
16457 | PARAMETER ( MXPABL = 120 ) | |
16458 | PARAMETER ( IDMAXP = 450 ) | |
16459 | PARAMETER ( IDMXDC = 2000 ) | |
16460 | PARAMETER ( MXMCIN = 410 ) | |
16461 | PARAMETER ( IHYPMX = 4 ) | |
16462 | PARAMETER ( MKBMX1 = 11 ) | |
16463 | PARAMETER ( MKBMX2 = 11 ) | |
16464 | PARAMETER ( MXIRRD = 2500 ) | |
16465 | PARAMETER ( MXTRDC = 1500 ) | |
16466 | PARAMETER ( NKTL = 17 ) | |
16467 | PARAMETER ( NBLNMX = 40000000 ) | |
16468 | ||
16469 | * INCLUDE '(PART)' | |
16470 | * PART taken from FLUKA | |
16471 | PARAMETER ( KPETA0 = 31 ) | |
16472 | PARAMETER ( KPRHOP = 32 ) | |
16473 | PARAMETER ( KPRHO0 = 33 ) | |
16474 | PARAMETER ( KPRHOM = 34 ) | |
16475 | PARAMETER ( KPOME0 = 35 ) | |
16476 | PARAMETER ( KPPHI0 = 96 ) | |
16477 | PARAMETER ( KPDEPP = 53 ) | |
16478 | PARAMETER ( KPDELP = 54 ) | |
16479 | PARAMETER ( KPDEL0 = 55 ) | |
16480 | PARAMETER ( KPDELM = 56 ) | |
16481 | PARAMETER ( KPN14P = 91 ) | |
16482 | PARAMETER ( KPN140 = 92 ) | |
16483 | * Low mass diffraction partners: | |
16484 | PARAMETER ( KDETA0 = 0 ) | |
16485 | PARAMETER ( KDRHOP = 0 ) | |
16486 | PARAMETER ( KDRHO0 = 210 ) | |
16487 | PARAMETER ( KDRHOM = 0 ) | |
16488 | PARAMETER ( KDOME0 = 210 ) | |
16489 | PARAMETER ( KDPHI0 = 210 ) | |
16490 | PARAMETER ( KDDEPP = 0 ) | |
16491 | PARAMETER ( KDDELP = 0 ) | |
16492 | PARAMETER ( KDDEL0 = 0 ) | |
16493 | PARAMETER ( KDDELM = 0 ) | |
16494 | PARAMETER ( KDN14P = 0 ) | |
16495 | PARAMETER ( KDN140 = 0 ) | |
16496 | * | |
16497 | CHARACTER*8 ANAME | |
16498 | COMMON / PART / AM (-6:IDMAXP), GA (-6:IDMAXP), | |
16499 | & TAU (-6:IDMAXP), AMDISC (-6:IDMAXP), | |
16500 | & ZMNABS (-6:IDMAXP), ATNMNA (-6:IDMAXP), | |
16501 | & ATXN14, ATMN14, RNRN14 (-10:10), | |
16502 | & ICH (-6:IDMAXP), IBAR (-6:IDMAXP), | |
16503 | & ISOSYM (-6:IDMAXP), ICHCON (-6:IDMAXP), | |
16504 | & K1 (-6:IDMAXP), K2 (-6:IDMAXP), | |
16505 | & KPTOIP (-6:IDMAXP), IPTOKP (-6:NALLWP), | |
16506 | & KPTOIA (-6:IDMAXP), IATOKP (-6:MXPABL), | |
16507 | & IDCFLG (-6:NALLWP), IPTYPE (-6:NALLWP) | |
16508 | ||
16509 | COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) | |
16510 | COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) | |
16511 | COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5) | |
16512 | ||
16513 | * flags for particle decays | |
16514 | COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20), | |
16515 | & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20), | |
16516 | & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0 | |
16517 | ||
16518 | * flags for input different options | |
16519 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
16520 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
16521 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
16522 | ||
16523 | INTEGER PYCOMP | |
16524 | ||
16525 | DIMENSION IDXSTA(40) | |
16526 | DATA IDXSTA | |
16527 | * K0s pi0 lam alam sig+ asig+ sig- asig- tet0 atet0 | |
16528 | & / 310, 111, 3122,-3122, 3222,-3222, 3112,-3112, 3322,-3322, | |
16529 | * tet- atet- om- aom- D+ D- D0 aD0 Ds+ aDs+ | |
16530 | & 3312,-3312, 3334,-3334, 411, -411, 421, -421, 431, -431, | |
16531 | * etac lamc+alamc+sigc++ sigc+ sigc0asigc++asigc+asigc0 Ksic+ | |
16532 | & 441, 4122,-4122, 4222, 4212, 4112,-4222,-4212,-4112, 4232, | |
16533 | * Ksic0 aKsic+aKsic0 sig0 asig0 | |
16534 | & 4132,-4232,-4132, 3212,-3212, 5*0/ | |
16535 | ||
16536 | DATA LFIRST,LFIRDT,LFIRPH /.TRUE.,.TRUE.,.TRUE./ | |
16537 | ||
16538 | IF (LFIRST) THEN | |
16539 | * save default settings | |
16540 | PDEF1 = PARJ(1) | |
16541 | PDEF2 = PARJ(2) | |
16542 | PDEF3 = PARJ(3) | |
16543 | PDEF5 = PARJ(5) | |
16544 | PDEF6 = PARJ(6) | |
16545 | PDEF7 = PARJ(7) | |
16546 | PDEF18 = PARJ(18) | |
16547 | PDEF19 = PARJ(19) | |
16548 | PDEF21 = PARJ(21) | |
16549 | PDEF42 = PARJ(42) | |
16550 | MDEF12 = MSTJ(12) | |
16551 | * LUJETS / PYJETS array-dimensions | |
16552 | ||
16553 | MSTU(4) = 4000 | |
16554 | ||
16555 | * increase maximum number of JETSET-error prints | |
16556 | MSTU(22) = 50000 | |
16557 | * prevent particles decaying | |
16558 | DO 1 I=1,35 | |
16559 | IF (I.LT.34) THEN | |
16560 | ||
16561 | KC = PYCOMP(IDXSTA(I)) | |
16562 | ||
16563 | IF (KC.GT.0) THEN | |
16564 | IF (I.EQ.2) THEN | |
16565 | * pi0 decay | |
16566 | C MDCY(KC,1) = 1 | |
16567 | MDCY(KC,1) = 0 | |
16568 | **cr mode | |
16569 | C ELSEIF ((I.EQ.4).OR.(I.EQ. 6).OR. | |
16570 | C & (I.EQ.8).OR.(I.EQ.10)) THEN | |
16571 | C ELSEIF (I.EQ.4) THEN | |
16572 | C MDCY(KC,1) = 1 | |
16573 | ** | |
16574 | ELSE | |
16575 | MDCY(KC,1) = 0 | |
16576 | ENDIF | |
16577 | ENDIF | |
16578 | ELSEIF (((I.EQ.34).OR.(I.EQ.35)).AND.(ISIG0.EQ.0)) THEN | |
16579 | ||
16580 | KC = PYCOMP(IDXSTA(I)) | |
16581 | ||
16582 | IF (KC.GT.0) THEN | |
16583 | MDCY(KC,1) = 0 | |
16584 | ENDIF | |
16585 | ENDIF | |
16586 | 1 CONTINUE | |
16587 | * | |
16588 | ||
16589 | * as Fluka event-generator: allow only paprop particles to be stable | |
16590 | * and let all other particles decay (i.e. those with strong decays) | |
16591 | IF (ITRSPT.EQ.1) THEN | |
16592 | DO 5 I=1,IDMAXP | |
16593 | IF (KPTOIP(I).NE.0) THEN | |
16594 | IDPDG = MPDGHA(I) | |
16595 | ||
16596 | KC = PYCOMP(IDPDG) | |
16597 | ||
16598 | IF (KC.GT.0) THEN | |
16599 | IF (MDCY(KC,1).EQ.1) THEN | |
16600 | WRITE(LOUT,*) | |
16601 | & ' DT_INITJS: Decay flag for FLUKA-', | |
16602 | & 'transport : particle should not ', | |
16603 | & 'decay : ',IDPDG,' ',ANAME(I) | |
16604 | MDCY(KC,1) = 0 | |
16605 | ENDIF | |
16606 | ENDIF | |
16607 | ENDIF | |
16608 | 5 CONTINUE | |
16609 | DO 6 KC=1,500 | |
16610 | IDPDG = KCHG(KC,4) | |
16611 | KP = MCIHAD(IDPDG) | |
16612 | IF (KP.GT.0) THEN | |
16613 | IF ((MDCY(KC,1).EQ.0).AND.(KPTOIP(KP).EQ.0).AND. | |
16614 | & (ANAME(KP).NE.'BLANK ').AND. | |
16615 | & (ANAME(KP).NE.'RNDFLV ')) THEN | |
16616 | WRITE(LOUT,*) ' DT_INITJS: Decay flag for FLUKA-', | |
16617 | & 'transport: particle should decay ', | |
16618 | & ': ',IDPDG,' ',ANAME(KP) | |
16619 | MDCY(KC,1) = 1 | |
16620 | ENDIF | |
16621 | ENDIF | |
16622 | 6 CONTINUE | |
16623 | ENDIF | |
16624 | ||
16625 | * | |
16626 | * popcorn: | |
16627 | IF (PDB.LE.ZERO) THEN | |
16628 | * no popcorn-mechanism | |
16629 | MSTJ(12) = 1 | |
16630 | ELSE | |
16631 | MSTJ(12) = 3 | |
16632 | PARJ(5) = PDB | |
16633 | ENDIF | |
16634 | * set JETSET-parameter requested by input cards | |
16635 | IF (NMSTU.GT.0) THEN | |
16636 | DO 2 I=1,NMSTU | |
16637 | MSTU(IMSTU(I)) = MSTUX(I) | |
16638 | 2 CONTINUE | |
16639 | ENDIF | |
16640 | IF (NMSTJ.GT.0) THEN | |
16641 | DO 3 I=1,NMSTJ | |
16642 | MSTJ(IMSTJ(I)) = MSTJX(I) | |
16643 | 3 CONTINUE | |
16644 | ENDIF | |
16645 | IF (NPARU.GT.0) THEN | |
16646 | DO 4 I=1,NPARU | |
16647 | PARU(IPARU(I)) = PARUX(I) | |
16648 | 4 CONTINUE | |
16649 | ENDIF | |
16650 | LFIRST = .FALSE. | |
16651 | ENDIF | |
16652 | * | |
16653 | * PARJ(1) suppression of qq-aqaq pair prod. compared to | |
16654 | * q-aq pair prod. (default: 0.1) | |
16655 | * PARJ(2) strangeness suppression (default: 0.3) | |
16656 | * PARJ(3) extra suppression of strange diquarks (default: 0.4) | |
16657 | * PARJ(6) extra suppression of sas-pair shared by B and | |
16658 | * aB in BMaB (default: 0.5) | |
16659 | * PARJ(7) extra suppression of strange meson M in BMaB | |
16660 | * configuration (default: 0.5) | |
16661 | * PARJ(18) spin 3/2 baryon suppression (default: 1.0) | |
16662 | * PARJ(21) width sigma in Gaussian p_x, p_y transverse | |
16663 | * momentum distrib. for prim. hadrons (default: 0.35) | |
16664 | * PARJ(42) b-parameter for symmetric Lund-fragmentation | |
16665 | * function (default: 0.9 GeV^-2) | |
16666 | * | |
16667 | * PHOJET settings | |
16668 | IF (MODE.EQ.1) THEN | |
16669 | * JETSET default | |
16670 | C PARJ(1) = PDEF1 | |
16671 | C PARJ(2) = PDEF2 | |
16672 | C PARJ(3) = PDEF3 | |
16673 | C PARJ(6) = PDEF6 | |
16674 | C PARJ(7) = PDEF7 | |
16675 | C PARJ(18) = PDEF18 | |
16676 | C PARJ(21) = PDEF21 | |
16677 | C PARJ(42) = PDEF42 | |
16678 | **sr 18.11.98 parameter tuning | |
16679 | C PARJ(1) = 0.092D0 | |
16680 | C PARJ(2) = 0.25D0 | |
16681 | C PARJ(3) = 0.45D0 | |
16682 | C PARJ(19) = 0.3D0 | |
16683 | C PARJ(21) = 0.45D0 | |
16684 | C PARJ(42) = 1.0D0 | |
16685 | **sr 28.04.99 parameter tuning (May 99 minor modifications) | |
16686 | PARJ(1) = 0.085D0 | |
16687 | PARJ(2) = 0.26D0 | |
16688 | PARJ(3) = 0.8D0 | |
16689 | PARJ(11) = 0.38D0 | |
16690 | PARJ(18) = 0.3D0 | |
16691 | PARJ(19) = 0.4D0 | |
16692 | PARJ(21) = 0.36D0 | |
16693 | PARJ(41) = 0.3D0 | |
16694 | PARJ(42) = 0.86D0 | |
16695 | IF (NPARJ.GT.0) THEN | |
16696 | DO 10 I=1,NPARJ | |
16697 | IF (IPARJ(I).GT.0) PARJ(IPARJ(I)) = PARJX(I) | |
16698 | 10 CONTINUE | |
16699 | ENDIF | |
16700 | IF (LFIRPH) THEN | |
16701 | WRITE(LOUT,'(1X,A)') | |
16702 | & 'DT_INITJS: JETSET-parameter for PHOJET' | |
16703 | CALL DT_JSPARA(0) | |
16704 | LFIRPH = .FALSE. | |
16705 | ENDIF | |
16706 | * DTUNUC settings | |
16707 | ELSEIF (MODE.EQ.2) THEN | |
16708 | IF (IFRAG(2).EQ.1) THEN | |
16709 | **sr parameters before 9.3.96 | |
16710 | C PARJ(2) = 0.27D0 | |
16711 | C PARJ(3) = 0.6D0 | |
16712 | C PARJ(6) = 0.75D0 | |
16713 | C PARJ(7) = 0.75D0 | |
16714 | C PARJ(21) = 0.55D0 | |
16715 | C PARJ(42) = 1.3D0 | |
16716 | **sr 18.11.98 parameter tuning | |
16717 | C PARJ(1) = 0.05D0 | |
16718 | C PARJ(2) = 0.27D0 | |
16719 | C PARJ(3) = 0.4D0 | |
16720 | C PARJ(19) = 0.2D0 | |
16721 | C PARJ(21) = 0.45D0 | |
16722 | C PARJ(42) = 1.0D0 | |
16723 | **sr 28.04.99 parameter tuning | |
16724 | PARJ(1) = 0.11D0 | |
16725 | PARJ(2) = 0.36D0 | |
16726 | PARJ(3) = 0.8D0 | |
16727 | PARJ(19) = 0.2D0 | |
16728 | PARJ(21) = 0.3D0 | |
16729 | PARJ(41) = 0.3D0 | |
16730 | PARJ(42) = 0.58D0 | |
16731 | IF (NPARJ.GT.0) THEN | |
16732 | DO 20 I=1,NPARJ | |
16733 | IF (IPARJ(I).LT.0) THEN | |
16734 | IDX = ABS(IPARJ(I)) | |
16735 | PARJ(IDX) = PARJX(I) | |
16736 | ENDIF | |
16737 | 20 CONTINUE | |
16738 | ENDIF | |
16739 | IF (LFIRDT) THEN | |
16740 | WRITE(LOUT,'(1X,A)') | |
16741 | & 'DT_INITJS: JETSET-parameter for DTUNUC' | |
16742 | CALL DT_JSPARA(0) | |
16743 | LFIRDT = .FALSE. | |
16744 | ENDIF | |
16745 | ELSEIF (IFRAG(2).EQ.2) THEN | |
16746 | PARJ(1) = 0.11D0 | |
16747 | PARJ(2) = 0.27D0 | |
16748 | PARJ(3) = 0.3D0 | |
16749 | PARJ(6) = 0.35D0 | |
16750 | PARJ(7) = 0.45D0 | |
16751 | PARJ(18) = 0.66D0 | |
16752 | C PARJ(21) = 0.55D0 | |
16753 | C PARJ(42) = 1.0D0 | |
16754 | PARJ(21) = 0.60D0 | |
16755 | PARJ(42) = 1.3D0 | |
16756 | ELSE | |
16757 | PARJ(1) = PDEF1 | |
16758 | PARJ(2) = PDEF2 | |
16759 | PARJ(3) = PDEF3 | |
16760 | PARJ(6) = PDEF6 | |
16761 | PARJ(7) = PDEF7 | |
16762 | PARJ(18) = PDEF18 | |
16763 | PARJ(21) = PDEF21 | |
16764 | PARJ(42) = PDEF42 | |
16765 | ENDIF | |
16766 | ELSE | |
16767 | PARJ(1) = PDEF1 | |
16768 | PARJ(2) = PDEF2 | |
16769 | PARJ(3) = PDEF3 | |
16770 | PARJ(5) = PDEF5 | |
16771 | PARJ(6) = PDEF6 | |
16772 | PARJ(7) = PDEF7 | |
16773 | PARJ(18) = PDEF18 | |
16774 | PARJ(19) = PDEF19 | |
16775 | PARJ(21) = PDEF21 | |
16776 | PARJ(42) = PDEF42 | |
16777 | MSTJ(12) = MDEF12 | |
16778 | ENDIF | |
16779 | ||
16780 | RETURN | |
16781 | END | |
16782 | ||
16783 | *$ CREATE DT_JSPARA.FOR | |
16784 | *COPY DT_JSPARA | |
16785 | * | |
16786 | *===jspara=============================================================* | |
16787 | * | |
16788 | SUBROUTINE DT_JSPARA(MODE) | |
16789 | ||
16790 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
16791 | SAVE | |
16792 | ||
16793 | PARAMETER ( LINP = 10 , | |
16794 | & LOUT = 6 , | |
16795 | & LDAT = 9 ) | |
16796 | ||
16797 | PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1, | |
16798 | & ONE=1.0D0,ZERO=0.0D0) | |
16799 | ||
16800 | LOGICAL LFIRST | |
16801 | ||
16802 | COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) | |
16803 | ||
16804 | DIMENSION ISTU(200),QARU(200),ISTJ(200),QARJ(200) | |
16805 | ||
16806 | DATA LFIRST /.TRUE./ | |
16807 | ||
16808 | * save the default JETSET-parameter on the first call | |
16809 | IF (LFIRST) THEN | |
16810 | DO 1 I=1,200 | |
16811 | ISTU(I) = MSTU(I) | |
16812 | QARU(I) = PARU(I) | |
16813 | ISTJ(I) = MSTJ(I) | |
16814 | QARJ(I) = PARJ(I) | |
16815 | 1 CONTINUE | |
16816 | LFIRST = .FALSE. | |
16817 | ENDIF | |
16818 | ||
16819 | WRITE(LOUT,1000) | |
16820 | 1000 FORMAT(1X,'DT_JSPARA: new value (default value)') | |
16821 | ||
16822 | * compare the default JETSET-parameter with the present values | |
16823 | DO 2 I=1,200 | |
16824 | IF ((MSTU(I).NE.ISTU(I)).AND.(I.NE.31)) THEN | |
16825 | WRITE(LOUT,1002) 'MSTU(',I,MSTU(I),ISTU(I) | |
16826 | C ISTU(I) = MSTU(I) | |
16827 | ENDIF | |
16828 | DIFF = ABS(PARU(I)-QARU(I)) | |
16829 | IF ((DIFF.GE.1.0D-5).AND.(I.NE.21)) THEN | |
16830 | WRITE(LOUT,1001) 'PARU(',I,PARU(I),QARU(I) | |
16831 | C QARU(I) = PARU(I) | |
16832 | ENDIF | |
16833 | IF (MSTJ(I).NE.ISTJ(I)) THEN | |
16834 | WRITE(LOUT,1002) 'MSTJ(',I,MSTJ(I),ISTJ(I) | |
16835 | C ISTJ(I) = MSTJ(I) | |
16836 | ENDIF | |
16837 | DIFF = ABS(PARJ(I)-QARJ(I)) | |
16838 | IF (DIFF.GE.1.0D-5) THEN | |
16839 | WRITE(LOUT,1001) 'PARJ(',I,PARJ(I),QARJ(I) | |
16840 | C QARJ(I) = PARJ(I) | |
16841 | ENDIF | |
16842 | 2 CONTINUE | |
16843 | 1001 FORMAT(12X,A5,I3,'): ',F6.3,' (',F6.3,')') | |
16844 | 1002 FORMAT(12X,A5,I3,'): ',I6,' (',I6,')') | |
16845 | ||
16846 | RETURN | |
16847 | END | |
16848 | *$ CREATE DT_FOZOCA.FOR | |
16849 | *COPY DT_FOZOCA | |
16850 | * | |
16851 | *===fozoca=============================================================* | |
16852 | * | |
16853 | SUBROUTINE DT_FOZOCA(LFZC,IREJ) | |
16854 | ||
16855 | ************************************************************************ | |
16856 | * This subroutine treats the complete FOrmation ZOne supressed intra- * | |
16857 | * nuclear CAscade. * | |
16858 | * LFZC = .true. cascade has been treated * | |
16859 | * = .false. cascade skipped * | |
16860 | * This is a completely revised version of the original FOZOKL. * | |
16861 | * This version dated 18.11.95 is written by S. Roesler * | |
16862 | ************************************************************************ | |
16863 | ||
16864 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
16865 | SAVE | |
16866 | ||
16867 | PARAMETER ( LINP = 10 , | |
16868 | & LOUT = 6 , | |
16869 | & LDAT = 9 ) | |
16870 | ||
16871 | PARAMETER (DLARGE=1.0D10,OHALF=0.5D0,ZERO=0.0D0) | |
16872 | PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0) | |
16873 | ||
16874 | LOGICAL LSTART,LCAS,LFZC | |
16875 | ||
16876 | * event history | |
16877 | ||
16878 | PARAMETER (NMXHKK=200000) | |
16879 | ||
16880 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
16881 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
16882 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
16883 | ||
16884 | * extended event history | |
16885 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
16886 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
16887 | & IHIST(2,NMXHKK) | |
16888 | ||
16889 | * rejection counter | |
16890 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
16891 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
16892 | & IREXCI(3),IRDIFF(2),IRINC | |
16893 | ||
16894 | * properties of interacting particles | |
16895 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
16896 | ||
16897 | * Glauber formalism: collision properties | |
16898 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, | |
16899 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC | |
16900 | ||
16901 | * flags for input different options | |
16902 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
16903 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
16904 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
16905 | ||
16906 | * final state after intranuclear cascade step | |
16907 | COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC | |
16908 | ||
16909 | * parameter for intranuclear cascade | |
16910 | LOGICAL LPAULI | |
16911 | COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI | |
16912 | ||
16913 | DIMENSION NCWOUN(2) | |
16914 | ||
16915 | DATA LSTART /.TRUE./ | |
16916 | ||
16917 | LFZC = .TRUE. | |
16918 | IREJ = 0 | |
16919 | ||
16920 | * skip cascade if hadron-hadron interaction or if supressed by user | |
16921 | IF (((IP.EQ.1).AND.(IT.EQ.1)).OR.(KTAUGE.LT.1)) GOTO 9999 | |
16922 | * skip cascade if not all possible chains systems are hadronized | |
16923 | DO 1 I=1,8 | |
16924 | IF (.NOT.LHADRO(I)) GOTO 9999 | |
16925 | 1 CONTINUE | |
16926 | ||
16927 | IF (LSTART) THEN | |
16928 | WRITE(LOUT,1000) KTAUGE,TAUFOR,INCMOD | |
16929 | 1000 FORMAT(/,1X,'FOZOCA: intranuclear cascade treated for a ', | |
16930 | & 'maximum of',I4,' generations',/,10X,'formation time ', | |
16931 | & 'parameter:',F5.1,' fm/c',9X,'modus:',I2) | |
16932 | IF (ITAUVE.EQ.1) WRITE(LOUT,1001) | |
16933 | IF (ITAUVE.EQ.2) WRITE(LOUT,1002) | |
16934 | 1001 FORMAT(10X,'p_t dependent formation zone',/) | |
16935 | 1002 FORMAT(10X,'constant formation zone',/) | |
16936 | LSTART = .FALSE. | |
16937 | ENDIF | |
16938 | ||
16939 | * in order to avoid wasting of cpu-time the DTEVT1-indices of nucleons | |
16940 | * which may interact with final state particles are stored in a seperate | |
16941 | * array - here all proj./target nucleon-indices (just for simplicity) | |
16942 | NOINC = 0 | |
16943 | DO 9 I=1,NPOINT(1)-1 | |
16944 | NOINC = NOINC+1 | |
16945 | IDXINC(NOINC) = I | |
16946 | 9 CONTINUE | |
16947 | ||
16948 | * initialize Pauli-principle treatment (find wounded nucleons) | |
16949 | NWOUND(1) = 0 | |
16950 | NWOUND(2) = 0 | |
16951 | NCWOUN(1) = 0 | |
16952 | NCWOUN(2) = 0 | |
16953 | DO 2 J=1,NPOINT(1) | |
16954 | DO 3 I=1,2 | |
16955 | IF (ISTHKK(J).EQ.10+I) THEN | |
16956 | NWOUND(I) = NWOUND(I)+1 | |
16957 | EWOUND(I,NWOUND(I)) = PHKK(4,J) | |
16958 | IF (IDHKK(J).EQ.2212) NCWOUN(I) = NCWOUN(I)+1 | |
16959 | ENDIF | |
16960 | 3 CONTINUE | |
16961 | 2 CONTINUE | |
16962 | ||
16963 | * modify nuclear potential for wounded nucleons | |
16964 | IPRCL = IP -NWOUND(1) | |
16965 | IPZRCL = IPZ-NCWOUN(1) | |
16966 | ITRCL = IT -NWOUND(2) | |
16967 | ITZRCL = ITZ-NCWOUN(2) | |
16968 | CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1) | |
16969 | ||
16970 | NSTART = NPOINT(4) | |
16971 | NEND = NHKK | |
16972 | ||
16973 | 7 CONTINUE | |
16974 | DO 8 I=NSTART,NEND | |
16975 | ||
16976 | IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDCH(I).LT.KTAUGE)) THEN | |
16977 | * select nucleus the cascade starts first (proj. - 1, target - -1) | |
16978 | NCAS = 1 | |
16979 | * projectile/target with probab. 1/2 | |
16980 | IF ((INCMOD.EQ.1).OR.(IDCH(I).GT.0)) THEN | |
16981 | IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS | |
16982 | * in the nucleus with highest mass | |
16983 | ELSEIF (INCMOD.EQ.2) THEN | |
16984 | IF (IP.GT.IT) THEN | |
16985 | NCAS = -NCAS | |
16986 | ELSEIF (IP.EQ.IT) THEN | |
16987 | IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS | |
16988 | ENDIF | |
16989 | * the nucleus the cascade starts first is requested to be the one | |
16990 | * moving in the direction of the secondary | |
16991 | ELSEIF (INCMOD.EQ.3) THEN | |
16992 | NCAS = INT(SIGN(1.0D0,PHKK(3,I))) | |
16993 | ENDIF | |
16994 | * check that the selected "nucleus" is not a hadron | |
16995 | IF (((NCAS.EQ. 1).AND.(IP.LE.1)).OR. | |
16996 | & ((NCAS.EQ.-1).AND.(IT.LE.1))) NCAS = -NCAS | |
16997 | ||
16998 | * treat intranuclear cascade in the nucleus selected first | |
16999 | LCAS = .FALSE. | |
17000 | CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1) | |
17001 | IF (IREJ1.NE.0) GOTO 9998 | |
17002 | * treat intranuclear cascade in the other nucleus if this isn't a had. | |
17003 | NCAS = -NCAS | |
17004 | IF (((NCAS.EQ. 1).AND.(IP.GT.1)).OR. | |
17005 | & ((NCAS.EQ.-1).AND.(IT.GT.1))) THEN | |
17006 | IF (LCAS) CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1) | |
17007 | IF (IREJ1.NE.0) GOTO 9998 | |
17008 | ENDIF | |
17009 | ||
17010 | ENDIF | |
17011 | ||
17012 | 8 CONTINUE | |
17013 | NSTART = NEND+1 | |
17014 | NEND = NHKK | |
17015 | IF (NSTART.LE.NEND) GOTO 7 | |
17016 | ||
17017 | RETURN | |
17018 | ||
17019 | 9998 CONTINUE | |
17020 | * reject this event | |
17021 | IRINC = IRINC+1 | |
17022 | IREJ = 1 | |
17023 | ||
17024 | 9999 CONTINUE | |
17025 | * intranucl. cascade not treated because of interaction properties or | |
17026 | * it is supressed by user or it was rejected or... | |
17027 | LFZC = .FALSE. | |
17028 | * reset flag characterizing direction of motion in n-n-cms | |
17029 | **sr14-11-95 | |
17030 | C DO 9990 I=NPOINT(5),NHKK | |
17031 | C IF (ISTHKK(I).EQ.-1) ISTHKK(I)=1 | |
17032 | C9990 CONTINUE | |
17033 | ||
17034 | RETURN | |
17035 | END | |
17036 | ||
17037 | *$ CREATE DT_INUCAS.FOR | |
17038 | *COPY DT_INUCAS | |
17039 | * | |
17040 | *===inucas=============================================================* | |
17041 | * | |
17042 | SUBROUTINE DT_INUCAS(IT,IP,IDXCAS,LCAS,NCAS,IREJ) | |
17043 | ||
17044 | ************************************************************************ | |
17045 | * Formation zone supressed IntraNUclear CAScade for one final state * | |
17046 | * particle. * | |
17047 | * IT, IP mass numbers of target, projectile nuclei * | |
17048 | * IDXCAS index of final state particle in DTEVT1 * | |
17049 | * NCAS = 1 intranuclear cascade in projectile * | |
17050 | * = -1 intranuclear cascade in target * | |
17051 | * This version dated 18.11.95 is written by S. Roesler * | |
17052 | ************************************************************************ | |
17053 | ||
17054 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
17055 | SAVE | |
17056 | ||
17057 | PARAMETER ( LINP = 10 , | |
17058 | & LOUT = 6 , | |
17059 | & LDAT = 9 ) | |
17060 | ||
17061 | PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10, | |
17062 | & OHALF=0.5D0,ONE=1.0D0) | |
17063 | PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0) | |
17064 | PARAMETER (TWOPI=6.283185307179586454D+00) | |
17065 | PARAMETER (PLOWH=0.01D0,PHIH=9.0D0) | |
17066 | ||
17067 | LOGICAL LABSOR,LCAS | |
17068 | ||
17069 | * event history | |
17070 | ||
17071 | PARAMETER (NMXHKK=200000) | |
17072 | ||
17073 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
17074 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
17075 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
17076 | ||
17077 | * extended event history | |
17078 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
17079 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
17080 | & IHIST(2,NMXHKK) | |
17081 | ||
17082 | * final state after inc step | |
17083 | PARAMETER (MAXFSP=10) | |
17084 | COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP | |
17085 | ||
17086 | * flags for input different options | |
17087 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
17088 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
17089 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
17090 | ||
17091 | * particle properties (BAMJET index convention) | |
17092 | CHARACTER*8 ANAME | |
17093 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
17094 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
17095 | ||
17096 | * Glauber formalism: collision properties | |
17097 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, | |
17098 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC | |
17099 | ||
17100 | * nuclear potential | |
17101 | LOGICAL LFERMI | |
17102 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, | |
17103 | & EBINDP(2),EBINDN(2),EPOT(2,210), | |
17104 | & ETACOU(2),ICOUL,LFERMI | |
17105 | ||
17106 | * parameter for intranuclear cascade | |
17107 | LOGICAL LPAULI | |
17108 | COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI | |
17109 | ||
17110 | * final state after intranuclear cascade step | |
17111 | COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC | |
17112 | ||
17113 | * nucleon-nucleon event-generator | |
17114 | CHARACTER*8 CMODEL | |
17115 | LOGICAL LPHOIN | |
17116 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
17117 | ||
17118 | * statistics: residual nuclei | |
17119 | COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2), | |
17120 | & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2), | |
17121 | & NINCST(2,4),NINCEV(2), | |
17122 | & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2), | |
17123 | & NRESPB(2),NRESCH(2),NRESEV(4), | |
17124 | & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240), | |
17125 | & NEVAFI(2,2) | |
17126 | ||
17127 | DIMENSION PCAS(2,5),PTOCAS(2),COSCAS(2,3),VTXCAS(2,4),VTXCA1(2,4), | |
17128 | & PCAS1(5),PNUC(5),BGTA(4), | |
17129 | & BGCAS(2),GACAS(2),BECAS(2), | |
17130 | & RNUC(2),BIMPC(2),VTXDST(3),IDXSPE(2),IDSPE(2),NWTMP(2) | |
17131 | ||
17132 | DATA PDIF /0.545D0/ | |
17133 | ||
17134 | IREJ = 0 | |
17135 | ||
17136 | * update counter | |
17137 | IF (NINCEV(1).NE.NEVHKK) THEN | |
17138 | NINCEV(1) = NEVHKK | |
17139 | NINCEV(2) = NINCEV(2)+1 | |
17140 | ENDIF | |
17141 | ||
17142 | * "BAMJET-index" of this hadron | |
17143 | IDCAS = IDBAM(IDXCAS) | |
17144 | IF (IDT_MCHAD(IDCAS).EQ.-1) RETURN | |
17145 | ||
17146 | * skip gammas, electrons, etc.. | |
17147 | IF (AAM(IDCAS).LT.TINY2) RETURN | |
17148 | ||
17149 | * Lorentz-trsf. into projectile rest system | |
17150 | IF (IP.GT.1) THEN | |
17151 | CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS), | |
17152 | & PHKK(4,IDXCAS),PCAS(1,1),PCAS(1,2),PCAS(1,3), | |
17153 | & PCAS(1,4),IDCAS,-2) | |
17154 | PTOCAS(1) = SQRT(PCAS(1,1)**2+PCAS(1,2)**2+PCAS(1,3)**2) | |
17155 | PCAS(1,5) = (PCAS(1,4)-PTOCAS(1))*(PCAS(1,4)+PTOCAS(1)) | |
17156 | IF (PCAS(1,5).GT.ZERO) THEN | |
17157 | PCAS(1,5) = SQRT(PCAS(1,5)) | |
17158 | ELSE | |
17159 | PCAS(1,5) = AAM(IDCAS) | |
17160 | ENDIF | |
17161 | DO 20 K=1,3 | |
17162 | COSCAS(1,K) = PCAS(1,K)/MAX(PTOCAS(1),TINY10) | |
17163 | 20 CONTINUE | |
17164 | * Lorentz-parameters | |
17165 | * particle rest system --> projectile rest system | |
17166 | BGCAS(1) = PTOCAS(1)/MAX(PCAS(1,5),TINY10) | |
17167 | GACAS(1) = PCAS(1,4)/MAX(PCAS(1,5),TINY10) | |
17168 | BECAS(1) = BGCAS(1)/GACAS(1) | |
17169 | ELSE | |
17170 | DO 21 K=1,5 | |
17171 | PCAS(1,K) = ZERO | |
17172 | IF (K.LE.3) COSCAS(1,K) = ZERO | |
17173 | 21 CONTINUE | |
17174 | PTOCAS(1) = ZERO | |
17175 | BGCAS(1) = ZERO | |
17176 | GACAS(1) = ZERO | |
17177 | BECAS(1) = ZERO | |
17178 | ENDIF | |
17179 | * Lorentz-trsf. into target rest system | |
17180 | IF (IT.GT.1) THEN | |
17181 | * LEPTO: final state particles are already in target rest frame | |
17182 | C IF (MCGENE.EQ.3) THEN | |
17183 | C PCAS(2,1) = PHKK(1,IDXCAS) | |
17184 | C PCAS(2,2) = PHKK(2,IDXCAS) | |
17185 | C PCAS(2,3) = PHKK(3,IDXCAS) | |
17186 | C PCAS(2,4) = PHKK(4,IDXCAS) | |
17187 | C ELSE | |
17188 | CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS), | |
17189 | & PHKK(4,IDXCAS),PCAS(2,1),PCAS(2,2),PCAS(2,3), | |
17190 | & PCAS(2,4),IDCAS,-3) | |
17191 | C ENDIF | |
17192 | PTOCAS(2) = SQRT(PCAS(2,1)**2+PCAS(2,2)**2+PCAS(2,3)**2) | |
17193 | PCAS(2,5) = (PCAS(2,4)-PTOCAS(2))*(PCAS(2,4)+PTOCAS(2)) | |
17194 | IF (PCAS(2,5).GT.ZERO) THEN | |
17195 | PCAS(2,5) = SQRT(PCAS(2,5)) | |
17196 | ELSE | |
17197 | PCAS(2,5) = AAM(IDCAS) | |
17198 | ENDIF | |
17199 | DO 22 K=1,3 | |
17200 | COSCAS(2,K) = PCAS(2,K)/MAX(PTOCAS(2),TINY10) | |
17201 | 22 CONTINUE | |
17202 | * Lorentz-parameters | |
17203 | * particle rest system --> target rest system | |
17204 | BGCAS(2) = PTOCAS(2)/MAX(PCAS(2,5),TINY10) | |
17205 | GACAS(2) = PCAS(2,4)/MAX(PCAS(2,5),TINY10) | |
17206 | BECAS(2) = BGCAS(2)/GACAS(2) | |
17207 | ELSE | |
17208 | DO 23 K=1,5 | |
17209 | PCAS(2,K) = ZERO | |
17210 | IF (K.LE.3) COSCAS(2,K) = ZERO | |
17211 | 23 CONTINUE | |
17212 | PTOCAS(2) = ZERO | |
17213 | BGCAS(2) = ZERO | |
17214 | GACAS(2) = ZERO | |
17215 | BECAS(2) = ZERO | |
17216 | ENDIF | |
17217 | ||
17218 | * radii of nuclei (mm) modified by the wall-depth of the Woods-Saxon- | |
17219 | * potential (see CONUCL) | |
17220 | RNUC(1) = (RPROJ+4.605D0*PDIF)*FM2MM | |
17221 | RNUC(2) = (RTARG+4.605D0*PDIF)*FM2MM | |
17222 | * impact parameter (the projectile moving along z) | |
17223 | BIMPC(1) = ZERO | |
17224 | BIMPC(2) = BIMPAC*FM2MM | |
17225 | ||
17226 | * get position of initial hadron in projectile/target rest-syst. | |
17227 | DO 3 K=1,4 | |
17228 | VTXCAS(1,K) = WHKK(K,IDXCAS) | |
17229 | VTXCAS(2,K) = VHKK(K,IDXCAS) | |
17230 | 3 CONTINUE | |
17231 | ||
17232 | ICAS = 1 | |
17233 | I2 = 2 | |
17234 | IF (NCAS.EQ.-1) THEN | |
17235 | ICAS = 2 | |
17236 | I2 = 1 | |
17237 | ENDIF | |
17238 | ||
17239 | IF (PTOCAS(ICAS).LT.TINY10) THEN | |
17240 | WRITE(LOUT,1000) PTOCAS | |
17241 | 1000 FORMAT(1X,'INUCAS: warning! zero momentum of initial', | |
17242 | & ' hadron ',/,20X,2E12.4) | |
17243 | GOTO 9999 | |
17244 | ENDIF | |
17245 | ||
17246 | * reset spectator flags | |
17247 | NSPE = 0 | |
17248 | IDXSPE(1) = 0 | |
17249 | IDXSPE(2) = 0 | |
17250 | IDSPE(1) = 0 | |
17251 | IDSPE(2) = 0 | |
17252 | ||
17253 | * formation length (in fm) | |
17254 | C IF (LCAS) THEN | |
17255 | C DEL0 = ZERO | |
17256 | C ELSE | |
17257 | DEL0 = TAUFOR*BGCAS(ICAS) | |
17258 | IF (ITAUVE.EQ.1) THEN | |
17259 | AMT = PCAS(ICAS,1)**2+PCAS(ICAS,2)**2+PCAS(ICAS,5)**2 | |
17260 | DEL0 = DEL0*PCAS(ICAS,5)**2/AMT | |
17261 | ENDIF | |
17262 | C ENDIF | |
17263 | * sample from exp(-del/del0) | |
17264 | DEL1 = -DEL0*LOG(MAX(DT_RNDM(DEL0),TINY10)) | |
17265 | * save formation time | |
17266 | TAUSA1 = DEL1/BGCAS(ICAS) | |
17267 | REL1 = TAUSA1*BGCAS(I2) | |
17268 | ||
17269 | DEL = DEL1 | |
17270 | TAUSAM = DEL/BGCAS(ICAS) | |
17271 | REL = TAUSAM*BGCAS(I2) | |
17272 | ||
17273 | * special treatment for negative particles unable to escape | |
17274 | * nuclear potential (implemented for ap, pi-, K- only) | |
17275 | LABSOR = .FALSE. | |
17276 | IF ((IICH(IDCAS).EQ.-1).AND.(IDCAS.LT.20)) THEN | |
17277 | * threshold energy = nuclear potential + Coulomb potential | |
17278 | * (nuclear potential for hadron-nucleus interactions only) | |
17279 | ETHR = AAM(IDCAS)+EPOT(ICAS,IDCAS)+ETACOU(ICAS) | |
17280 | IF (PCAS(ICAS,4).LT.ETHR) THEN | |
17281 | DO 4 K=1,5 | |
17282 | PCAS1(K) = PCAS(ICAS,K) | |
17283 | 4 CONTINUE | |
17284 | * "absorb" negative particle in nucleus | |
17285 | CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,0,IREJ1) | |
17286 | IF (IREJ1.NE.0) GOTO 9999 | |
17287 | IF (NSPE.GE.1) LABSOR = .TRUE. | |
17288 | ENDIF | |
17289 | ENDIF | |
17290 | ||
17291 | * if the initial particle has not been absorbed proceed with | |
17292 | * "normal" cascade | |
17293 | IF (.NOT.LABSOR) THEN | |
17294 | ||
17295 | * calculate coordinates of hadron at the end of the formation zone | |
17296 | * transport-time and -step in the rest system where this step is | |
17297 | * treated | |
17298 | DSTEP = DEL*FM2MM | |
17299 | DTIME = DSTEP/BECAS(ICAS) | |
17300 | RSTEP = REL*FM2MM | |
17301 | IF ((IP.GT.1).AND.(IT.GT.1)) THEN | |
17302 | RTIME = RSTEP/BECAS(I2) | |
17303 | ELSE | |
17304 | RTIME = ZERO | |
17305 | ENDIF | |
17306 | * save step whithout considering the overlapping region | |
17307 | DSTEP1 = DEL1*FM2MM | |
17308 | DTIME1 = DSTEP1/BECAS(ICAS) | |
17309 | RSTEP1 = REL1*FM2MM | |
17310 | IF ((IP.GT.1).AND.(IT.GT.1)) THEN | |
17311 | RTIME1 = RSTEP1/BECAS(I2) | |
17312 | ELSE | |
17313 | RTIME1 = ZERO | |
17314 | ENDIF | |
17315 | * transport to the end of the formation zone in this system | |
17316 | DO 5 K=1,3 | |
17317 | VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+DSTEP1*COSCAS(ICAS,K) | |
17318 | VTXCA1(I2,K) = VTXCAS(I2,K) +RSTEP1*COSCAS(I2,K) | |
17319 | VTXCAS(ICAS,K) = VTXCAS(ICAS,K)+DSTEP*COSCAS(ICAS,K) | |
17320 | VTXCAS(I2,K) = VTXCAS(I2,K) +RSTEP*COSCAS(I2,K) | |
17321 | 5 CONTINUE | |
17322 | VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME1 | |
17323 | VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME1 | |
17324 | VTXCAS(ICAS,4) = VTXCAS(ICAS,4)+DTIME | |
17325 | VTXCAS(I2,4) = VTXCAS(I2,4) +RTIME | |
17326 | ||
17327 | IF ((IP.GT.1).AND.(IT.GT.1)) THEN | |
17328 | XCAS = VTXCAS(ICAS,1) | |
17329 | YCAS = VTXCAS(ICAS,2) | |
17330 | XNCLTA = BIMPAC*FM2MM | |
17331 | RNCLPR = (RPROJ+RNUCLE)*FM2MM | |
17332 | RNCLTA = (RTARG+RNUCLE)*FM2MM | |
17333 | C RNCLPR = (RPROJ+1.605D0*PDIF)*FM2MM | |
17334 | C RNCLTA = (RTARG+1.605D0*PDIF)*FM2MM | |
17335 | C RNCLPR = (RPROJ)*FM2MM | |
17336 | C RNCLTA = (RTARG)*FM2MM | |
17337 | RCASPR = SQRT( XCAS**2 +YCAS**2) | |
17338 | RCASTA = SQRT((XCAS-XNCLTA)**2+YCAS**2) | |
17339 | IF ((RCASPR.LT.RNCLPR).AND.(RCASTA.LT.RNCLTA)) THEN | |
17340 | IF (IDCH(IDXCAS).EQ.0) NOBAM(IDXCAS) = 3 | |
17341 | ENDIF | |
17342 | ENDIF | |
17343 | ||
17344 | * check if particle is already outside of the corresp. nucleus | |
17345 | RDIST = SQRT((VTXCAS(ICAS,1)-BIMPC(ICAS))**2+ | |
17346 | & VTXCAS(ICAS,2)**2+VTXCAS(ICAS,3)**2) | |
17347 | IF (RDIST.GE.RNUC(ICAS)) THEN | |
17348 | * here: IDCH is the generation of the final state part. starting | |
17349 | * with zero for hadronization products | |
17350 | * flag particles of generation 0 being outside the nuclei after | |
17351 | * formation time (to be used for excitation energy calculation) | |
17352 | IF ((IDCH(IDXCAS).EQ.0).AND.(NOBAM(IDXCAS).LT.3)) | |
17353 | & NOBAM(IDXCAS) = NOBAM(IDXCAS)+ICAS | |
17354 | GOTO 9997 | |
17355 | ENDIF | |
17356 | DIST = DLARGE | |
17357 | DISTP = DLARGE | |
17358 | DISTN = DLARGE | |
17359 | IDXP = 0 | |
17360 | IDXN = 0 | |
17361 | ||
17362 | * already here: skip particles being outside HADRIN "energy-window" | |
17363 | * to avoid wasting of time | |
17364 | NINCHR(ICAS,1) = NINCHR(ICAS,1)+1 | |
17365 | IF ((PTOCAS(ICAS).LE.PLOWH).OR.(PTOCAS(ICAS).GE.PHIH)) THEN | |
17366 | NINCHR(ICAS,2) = NINCHR(ICAS,2)+1 | |
17367 | C WRITE(LOUT,1002) IDXCAS,IDCAS,ICAS,PTOCAS(ICAS),NEVHKK | |
17368 | C1002 FORMAT(1X,'INUCAS: warning! momentum of particle with ', | |
17369 | C & 'index ',I5,' (id: ',I3,') ',I3,/,11X,'p_tot = ', | |
17370 | C & E12.4,', above or below HADRIN-thresholds',I6) | |
17371 | NSPE = 0 | |
17372 | GOTO 9997 | |
17373 | ENDIF | |
17374 | ||
17375 | DO 7 IDXHKK=1,NOINC | |
17376 | I = IDXINC(IDXHKK) | |
17377 | * scan DTEVT1 for unwounded or excited nucleons | |
17378 | IF ((ISTHKK(I).EQ.12+ICAS).OR.(ISTHKK(I).EQ.14+ICAS)) THEN | |
17379 | DO 8 K=1,3 | |
17380 | IF (ICAS.EQ.1) THEN | |
17381 | VTXDST(K) = WHKK(K,I)-VTXCAS(1,K) | |
17382 | ELSEIF (ICAS.EQ.2) THEN | |
17383 | VTXDST(K) = VHKK(K,I)-VTXCAS(2,K) | |
17384 | ENDIF | |
17385 | 8 CONTINUE | |
17386 | POSNUC = VTXDST(1)*COSCAS(ICAS,1)+ | |
17387 | & VTXDST(2)*COSCAS(ICAS,2)+ | |
17388 | & VTXDST(3)*COSCAS(ICAS,3) | |
17389 | * check if nucleon is situated in forward direction | |
17390 | IF (POSNUC.GT.ZERO) THEN | |
17391 | * distance between hadron and this nucleon | |
17392 | DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+ | |
17393 | & VTXDST(3)**2) | |
17394 | * impact parameter | |
17395 | BIMNU2 = DISTNU**2-POSNUC**2 | |
17396 | IF (BIMNU2.LT.ZERO) THEN | |
17397 | WRITE(LOUT,1001) DISTNU,POSNUC,BIMNU2 | |
17398 | 1001 FORMAT(1X,'INUCAS: warning! inconsistent impact', | |
17399 | & ' parameter ',/,20X,3E12.4) | |
17400 | GOTO 7 | |
17401 | ENDIF | |
17402 | BIMNU = SQRT(BIMNU2) | |
17403 | * maximum impact parameter to have interaction | |
17404 | IDNUC = IDT_ICIHAD(IDHKK(I)) | |
17405 | IDNUC1 = IDT_MCHAD(IDNUC) | |
17406 | IDCAS1 = IDT_MCHAD(IDCAS) | |
17407 | DO 19 K=1,5 | |
17408 | PCAS1(K) = PCAS(ICAS,K) | |
17409 | PNUC(K) = PHKK(K,I) | |
17410 | 19 CONTINUE | |
17411 | * Lorentz-parameter for trafo into rest-system of target | |
17412 | DO 18 K=1,4 | |
17413 | BGTA(K) = PNUC(K)/MAX(PNUC(5),TINY10) | |
17414 | 18 CONTINUE | |
17415 | * transformation of projectile into rest-system of target | |
17416 | CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3), | |
17417 | & PCAS1(1),PCAS1(2),PCAS1(3),PCAS1(4), | |
17418 | & PPTOT,PX,PY,PZ,PE) | |
17419 | ** | |
17420 | C CALL DT_SIHNIN(IDCAS1,IDNUC1,PPTOT,SIGIN) | |
17421 | C CALL DT_SIHNEL(IDCAS1,IDNUC1,PPTOT,SIGEL) | |
17422 | DUMZER = ZERO | |
17423 | CALL DT_XSHN(IDCAS1,IDNUC1,PPTOT,DUMZER,SIGTOT,SIGEL) | |
17424 | CALL DT_SIHNAB(IDCAS1,IDNUC1,PPTOT,SIGAB) | |
17425 | IF (((IDCAS1.EQ.13).OR.(IDCAS1.EQ.14)).AND. | |
17426 | & (PPTOT.LT.0.15D0)) SIGEL = SIGEL/2.0D0 | |
17427 | SIGIN = SIGTOT-SIGEL-SIGAB | |
17428 | C SIGTOT = SIGIN+SIGEL+SIGAB | |
17429 | ** | |
17430 | BIMMAX = SQRT(SIGTOT/(5.0D0*TWOPI))*FM2MM | |
17431 | * check if interaction is possible | |
17432 | IF (BIMNU.LE.BIMMAX) THEN | |
17433 | * get nucleon with smallest distance and kind of interaction | |
17434 | * (elastic/inelastic) | |
17435 | IF (DISTNU.LT.DIST) THEN | |
17436 | DIST = DISTNU | |
17437 | BINT = BIMNU | |
17438 | IF (IDNUC.NE.IDSPE(1)) THEN | |
17439 | IDSPE(2) = IDSPE(1) | |
17440 | IDXSPE(2) = IDXSPE(1) | |
17441 | IDSPE(1) = IDNUC | |
17442 | ENDIF | |
17443 | IDXSPE(1) = I | |
17444 | NSPE = 1 | |
17445 | **sr | |
17446 | SELA = SIGEL | |
17447 | SABS = SIGAB | |
17448 | STOT = SIGTOT | |
17449 | C IF ((IDCAS.EQ.2).OR.(IDCAS.EQ.9)) THEN | |
17450 | C SELA = SIGEL | |
17451 | C STOT = SIGIN+SIGEL | |
17452 | C ELSE | |
17453 | C SELA = SIGEL+0.75D0*SIGIN | |
17454 | C STOT = 0.25D0*SIGIN+SELA | |
17455 | C ENDIF | |
17456 | ** | |
17457 | ENDIF | |
17458 | ENDIf | |
17459 | ENDIF | |
17460 | DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+ | |
17461 | & VTXDST(3)**2) | |
17462 | IDNUC = IDT_ICIHAD(IDHKK(I)) | |
17463 | IF (IDNUC.EQ.1) THEN | |
17464 | IF (DISTNU.LT.DISTP) THEN | |
17465 | DISTP = DISTNU | |
17466 | IDXP = I | |
17467 | POSP = POSNUC | |
17468 | ENDIF | |
17469 | ELSEIF (IDNUC.EQ.8) THEN | |
17470 | IF (DISTNU.LT.DISTN) THEN | |
17471 | DISTN = DISTNU | |
17472 | IDXN = I | |
17473 | POSN = POSNUC | |
17474 | ENDIF | |
17475 | ENDIF | |
17476 | ENDIF | |
17477 | 7 CONTINUE | |
17478 | ||
17479 | * there is no nucleon for a secondary interaction | |
17480 | IF (NSPE.EQ.0) GOTO 9997 | |
17481 | ||
17482 | C IF ((IDCAS.EQ.13).AND.((PCAS(ICAS,4)-PCAS(ICAS,5)).LT.0.1D0)) | |
17483 | C & WRITE(LOUT,*) STOT,SELA,SABS,IDXSPE | |
17484 | IF (IDXSPE(2).EQ.0) THEN | |
17485 | IF ((IDSPE(1).EQ.1).AND.(IDXN.GT.0)) THEN | |
17486 | C DO 80 K=1,3 | |
17487 | C IF (ICAS.EQ.1) THEN | |
17488 | C VTXDST(K) = WHKK(K,IDXN)-WHKK(K,IDXSPE(1)) | |
17489 | C ELSEIF (ICAS.EQ.2) THEN | |
17490 | C VTXDST(K) = VHKK(K,IDXN)-VHKK(K,IDXSPE(1)) | |
17491 | C ENDIF | |
17492 | C 80 CONTINUE | |
17493 | C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+ | |
17494 | C & VTXDST(3)**2) | |
17495 | C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSN.GT.ZERO)) THEN | |
17496 | IDXSPE(2) = IDXN | |
17497 | IDSPE(2) = 8 | |
17498 | C ELSE | |
17499 | C STOT = STOT-SABS | |
17500 | C SABS = ZERO | |
17501 | C ENDIF | |
17502 | ELSEIF ((IDSPE(1).EQ.8).AND.(IDXP.GT.0)) THEN | |
17503 | C DO 81 K=1,3 | |
17504 | C IF (ICAS.EQ.1) THEN | |
17505 | C VTXDST(K) = WHKK(K,IDXP)-WHKK(K,IDXSPE(1)) | |
17506 | C ELSEIF (ICAS.EQ.2) THEN | |
17507 | C VTXDST(K) = VHKK(K,IDXP)-VHKK(K,IDXSPE(1)) | |
17508 | C ENDIF | |
17509 | C 81 CONTINUE | |
17510 | C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+ | |
17511 | C & VTXDST(3)**2) | |
17512 | C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSP.GT.ZERO)) THEN | |
17513 | IDXSPE(2) = IDXP | |
17514 | IDSPE(2) = 1 | |
17515 | C ELSE | |
17516 | C STOT = STOT-SABS | |
17517 | C SABS = ZERO | |
17518 | C ENDIF | |
17519 | ELSE | |
17520 | STOT = STOT-SABS | |
17521 | SABS = ZERO | |
17522 | ENDIF | |
17523 | ENDIF | |
17524 | RR = DT_RNDM(DIST) | |
17525 | IF (RR.LT.SELA/STOT) THEN | |
17526 | IPROC = 2 | |
17527 | ELSEIF ((RR.GE.SELA/STOT).AND.(RR.LT.(SELA+SABS)/STOT)) THEN | |
17528 | IPROC = 3 | |
17529 | ELSE | |
17530 | IPROC = 1 | |
17531 | ENDIF | |
17532 | ||
17533 | DO 9 K=1,5 | |
17534 | PCAS1(K) = PCAS(ICAS,K) | |
17535 | PNUC(K) = PHKK(K,IDXSPE(1)) | |
17536 | 9 CONTINUE | |
17537 | IF (IPROC.EQ.3) THEN | |
17538 | * 2-nucleon absorption of pion | |
17539 | NSPE = 2 | |
17540 | CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,1,IREJ1) | |
17541 | IF (IREJ1.NE.0) GOTO 9999 | |
17542 | IF (NSPE.GE.1) LABSOR = .TRUE. | |
17543 | ELSE | |
17544 | * sample secondary interaction | |
17545 | IDNUC = IDBAM(IDXSPE(1)) | |
17546 | CALL DT_HADRIN(IDCAS,PCAS1,IDNUC,PNUC,IPROC,IREJ1) | |
17547 | IF (IREJ1.EQ.1) GOTO 9999 | |
17548 | IF (IREJ1.GT.1) GOTO 9998 | |
17549 | ENDIF | |
17550 | ENDIF | |
17551 | ||
17552 | * update arrays to include Pauli-principle | |
17553 | DO 10 I=1,NSPE | |
17554 | IF (NWOUND(ICAS).LE.299) THEN | |
17555 | NWOUND(ICAS) = NWOUND(ICAS)+1 | |
17556 | EWOUND(ICAS,NWOUND(ICAS)) = PHKK(4,IDXSPE(I)) | |
17557 | ENDIF | |
17558 | 10 CONTINUE | |
17559 | ||
17560 | * dump initial hadron for energy-momentum conservation check | |
17561 | IF (LEMCCK) | |
17562 | & CALL DT_EVTEMC(PCAS(ICAS,1),PCAS(ICAS,2),PCAS(ICAS,3), | |
17563 | & PCAS(ICAS,4),1,IDUM,IDUM) | |
17564 | ||
17565 | * dump final state particles into DTEVT1 | |
17566 | ||
17567 | * check if Pauli-principle is fulfilled | |
17568 | NPAULI = 0 | |
17569 | NWTMP(1) = NWOUND(1) | |
17570 | NWTMP(2) = NWOUND(2) | |
17571 | DO 111 I=1,NFSP | |
17572 | NPAULI = 0 | |
17573 | J1 = 2 | |
17574 | IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR. | |
17575 | & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1 | |
17576 | DO 117 J=1,J1 | |
17577 | IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 117 | |
17578 | IF (J.EQ.1) THEN | |
17579 | IDX = ICAS | |
17580 | PE = PFSP(4,I) | |
17581 | ELSE | |
17582 | IDX = I2 | |
17583 | MODE = 1 | |
17584 | IF (IDX.EQ.1) MODE = -1 | |
17585 | CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,MODE) | |
17586 | ENDIF | |
17587 | * first check if cascade step is forbidden due to Pauli-principle | |
17588 | * (in case of absorpion this step is forced) | |
17589 | IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR. | |
17590 | & (IDFSP(I).EQ.8))) THEN | |
17591 | * get nuclear potential barrier | |
17592 | POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I)) | |
17593 | IF (IDFSP(I).EQ.1) THEN | |
17594 | POTLOW = POT-EBINDP(IDX) | |
17595 | ELSE | |
17596 | POTLOW = POT-EBINDN(IDX) | |
17597 | ENDIF | |
17598 | * final state particle not able to escape nucleus | |
17599 | IF (PE.LE.POTLOW) THEN | |
17600 | * check if there are wounded nucleons | |
17601 | IF ((NWOUND(IDX).GE.1).AND.(PE.GE. | |
17602 | & EWOUND(IDX,NWOUND(IDX)))) THEN | |
17603 | NPAULI = NPAULI+1 | |
17604 | NWOUND(IDX) = NWOUND(IDX)-1 | |
17605 | ELSE | |
17606 | * interaction prohibited by Pauli-principle | |
17607 | NWOUND(1) = NWTMP(1) | |
17608 | NWOUND(2) = NWTMP(2) | |
17609 | GOTO 9997 | |
17610 | ENDIF | |
17611 | ENDIF | |
17612 | ENDIF | |
17613 | 117 CONTINUE | |
17614 | 111 CONTINUE | |
17615 | ||
17616 | NPAULI = 0 | |
17617 | NWOUND(1) = NWTMP(1) | |
17618 | NWOUND(2) = NWTMP(2) | |
17619 | ||
17620 | DO 11 I=1,NFSP | |
17621 | ||
17622 | IST = ISTHKK(IDXCAS) | |
17623 | ||
17624 | NPAULI = 0 | |
17625 | J1 = 2 | |
17626 | IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR. | |
17627 | & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1 | |
17628 | DO 17 J=1,J1 | |
17629 | IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 17 | |
17630 | IDX = ICAS | |
17631 | PE = PFSP(4,I) | |
17632 | IF (J.EQ.2) THEN | |
17633 | IDX = I2 | |
17634 | CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,NCAS) | |
17635 | ENDIF | |
17636 | * first check if cascade step is forbidden due to Pauli-principle | |
17637 | * (in case of absorpion this step is forced) | |
17638 | IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR. | |
17639 | & (IDFSP(I).EQ.8))) THEN | |
17640 | * get nuclear potential barrier | |
17641 | POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I)) | |
17642 | IF (IDFSP(I).EQ.1) THEN | |
17643 | POTLOW = POT-EBINDP(IDX) | |
17644 | ELSE | |
17645 | POTLOW = POT-EBINDN(IDX) | |
17646 | ENDIF | |
17647 | * final state particle not able to escape nucleus | |
17648 | IF (PE.LE.POTLOW) THEN | |
17649 | * check if there are wounded nucleons | |
17650 | IF ((NWOUND(IDX).GE.1).AND.(PE.GE. | |
17651 | & EWOUND(IDX,NWOUND(IDX)))) THEN | |
17652 | NWOUND(IDX) = NWOUND(IDX)-1 | |
17653 | NPAULI = NPAULI+1 | |
17654 | IST = 14+IDX | |
17655 | ELSE | |
17656 | * interaction prohibited by Pauli-principle | |
17657 | NWOUND(1) = NWTMP(1) | |
17658 | NWOUND(2) = NWTMP(2) | |
17659 | GOTO 9997 | |
17660 | ENDIF | |
17661 | **sr | |
17662 | c ELSEIF (PE.LE.POT) THEN | |
17663 | cC ELSEIF ((PE.LE.POT).AND.(NWOUND(IDX).GE.1)) THEN | |
17664 | cC NWOUND(IDX) = NWOUND(IDX)-1 | |
17665 | c** | |
17666 | c NPAULI = NPAULI+1 | |
17667 | c IST = 14+IDX | |
17668 | ENDIF | |
17669 | ENDIF | |
17670 | 17 CONTINUE | |
17671 | ||
17672 | * dump final state particles for energy-momentum conservation check | |
17673 | IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),-PFSP(3,I), | |
17674 | & -PFSP(4,I),2,IDUM,IDUM) | |
17675 | ||
17676 | PX = PFSP(1,I) | |
17677 | PY = PFSP(2,I) | |
17678 | PZ = PFSP(3,I) | |
17679 | PE = PFSP(4,I) | |
17680 | IF (ABS(IST).EQ.1) THEN | |
17681 | * transform particles back into n-n cms | |
17682 | * LEPTO: leave final state particles in target rest frame | |
17683 | C IF (MCGENE.EQ.3) THEN | |
17684 | C PFSP(1,I) = PX | |
17685 | C PFSP(2,I) = PY | |
17686 | C PFSP(3,I) = PZ | |
17687 | C PFSP(4,I) = PE | |
17688 | C ELSE | |
17689 | IMODE = ICAS+1 | |
17690 | CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I), | |
17691 | & PFSP(4,I),IDFSP(I),IMODE) | |
17692 | C ENDIF | |
17693 | ELSEIF ((ICAS.EQ.2).AND.(IST.EQ.15)) THEN | |
17694 | * target cascade but fsp got stuck in proj. --> transform it into | |
17695 | * proj. rest system | |
17696 | CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I), | |
17697 | & PFSP(4,I),IDFSP(I),-1) | |
17698 | ELSEIF ((ICAS.EQ.1).AND.(IST.EQ.16)) THEN | |
17699 | * proj. cascade but fsp got stuck in target --> transform it into | |
17700 | * target rest system | |
17701 | CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I), | |
17702 | & PFSP(4,I),IDFSP(I),1) | |
17703 | ENDIF | |
17704 | ||
17705 | * dump final state particles into DTEVT1 | |
17706 | IGEN = IDCH(IDXCAS)+1 | |
17707 | ID = IDT_IPDGHA(IDFSP(I)) | |
17708 | IXR = 0 | |
17709 | IF (LABSOR) IXR = 99 | |
17710 | CALL DT_EVTPUT(IST,ID,IDXCAS,IDXSPE(1),PFSP(1,I), | |
17711 | & PFSP(2,I),PFSP(3,I),PFSP(4,I),0,IXR,IGEN) | |
17712 | ||
17713 | * update the counter for particles which got stuck inside the nucleus | |
17714 | IF ((IST.EQ.15).OR.(IST.EQ.16)) THEN | |
17715 | NOINC = NOINC+1 | |
17716 | IDXINC(NOINC) = NHKK | |
17717 | ENDIF | |
17718 | IF (LABSOR) THEN | |
17719 | * in case of absorption the spatial treatment is an approximate | |
17720 | * solution anyway (the positions of the nucleons which "absorb" the | |
17721 | * cascade particle are not taken into consideration) therefore the | |
17722 | * particles are produced at the position of the cascade particle | |
17723 | DO 12 K=1,4 | |
17724 | WHKK(K,NHKK) = WHKK(K,IDXCAS) | |
17725 | VHKK(K,NHKK) = VHKK(K,IDXCAS) | |
17726 | 12 CONTINUE | |
17727 | ELSE | |
17728 | * DDISTL - distance the cascade particle moves to the intera. point | |
17729 | * (the position where impact-parameter = distance to the interacting | |
17730 | * nucleon), DIST - distance to the interacting nucleon at the time of | |
17731 | * formation of the cascade particle, BINT - impact-parameter of this | |
17732 | * cascade-interaction | |
17733 | DDISTL = SQRT(DIST**2-BINT**2) | |
17734 | DTIME = DDISTL/BECAS(ICAS) | |
17735 | DTIMEL = DDISTL/BGCAS(ICAS) | |
17736 | RDISTL = DTIMEL*BGCAS(I2) | |
17737 | IF ((IP.GT.1).AND.(IT.GT.1)) THEN | |
17738 | RTIME = RDISTL/BECAS(I2) | |
17739 | ELSE | |
17740 | RTIME = ZERO | |
17741 | ENDIF | |
17742 | * RDISTL, RTIME are this step and time in the rest system of the other | |
17743 | * nucleus | |
17744 | DO 13 K=1,3 | |
17745 | VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+COSCAS(ICAS,K)*DDISTL | |
17746 | VTXCA1(I2,K) = VTXCAS(I2,K) +COSCAS(I2,K) *RDISTL | |
17747 | 13 CONTINUE | |
17748 | VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME | |
17749 | VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME | |
17750 | * position of particle production is half the impact-parameter to | |
17751 | * the interacting nucleon | |
17752 | DO 14 K=1,3 | |
17753 | WHKK(K,NHKK) = OHALF*(VTXCA1(1,K)+WHKK(K,IDXSPE(1))) | |
17754 | VHKK(K,NHKK) = OHALF*(VTXCA1(2,K)+VHKK(K,IDXSPE(1))) | |
17755 | 14 CONTINUE | |
17756 | * time of production of secondary = time of interaction | |
17757 | WHKK(4,NHKK) = VTXCA1(1,4) | |
17758 | VHKK(4,NHKK) = VTXCA1(2,4) | |
17759 | ENDIF | |
17760 | ||
17761 | 11 CONTINUE | |
17762 | ||
17763 | * modify status and position of cascade particle (the latter for | |
17764 | * statistics reasons only) | |
17765 | ISTHKK(IDXCAS) = 2 | |
17766 | IF (LABSOR) ISTHKK(IDXCAS) = 19 | |
17767 | IF (.NOT.LABSOR) THEN | |
17768 | DO 15 K=1,4 | |
17769 | WHKK(K,IDXCAS) = VTXCA1(1,K) | |
17770 | VHKK(K,IDXCAS) = VTXCA1(2,K) | |
17771 | 15 CONTINUE | |
17772 | ENDIF | |
17773 | ||
17774 | DO 16 I=1,NSPE | |
17775 | IS = IDXSPE(I) | |
17776 | * dump interacting nucleons for energy-momentum conservation check | |
17777 | IF (LEMCCK) | |
17778 | & CALL DT_EVTEMC(PHKK(1,IS),PHKK(2,IS),PHKK(3,IS),PHKK(4,IS), | |
17779 | & 2,IDUM,IDUM) | |
17780 | * modify entry for interacting nucleons | |
17781 | IF (ISTHKK(IS).EQ.12+ICAS) ISTHKK(IS)=16+ICAS | |
17782 | IF (ISTHKK(IS).EQ.14+ICAS) ISTHKK(IS)=2 | |
17783 | IF (I.GE.2) THEN | |
17784 | JDAHKK(1,IS) = JDAHKK(1,IDXSPE(1)) | |
17785 | JDAHKK(2,IS) = JDAHKK(2,IDXSPE(1)) | |
17786 | ENDIF | |
17787 | 16 CONTINUE | |
17788 | ||
17789 | * check energy-momentum conservation | |
17790 | IF (LEMCCK) THEN | |
17791 | CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,500,IREJ1) | |
17792 | IF (IREJ1.NE.0) GOTO 9999 | |
17793 | ENDIF | |
17794 | ||
17795 | * update counter | |
17796 | IF (LABSOR) THEN | |
17797 | NINCCO(ICAS,1) = NINCCO(ICAS,1)+1 | |
17798 | ELSE | |
17799 | IF (IPROC.EQ.1) NINCCO(ICAS,2) = NINCCO(ICAS,2)+1 | |
17800 | IF (IPROC.EQ.2) NINCCO(ICAS,3) = NINCCO(ICAS,3)+1 | |
17801 | ENDIF | |
17802 | ||
17803 | RETURN | |
17804 | ||
17805 | 9997 CONTINUE | |
17806 | 9998 CONTINUE | |
17807 | * transport-step but no cascade step due to configuration (i.e. there | |
17808 | * is no nucleon for interaction etc.) | |
17809 | IF (LCAS) THEN | |
17810 | DO 100 K=1,4 | |
17811 | C WHKK(K,IDXCAS) = VTXCAS(1,K) | |
17812 | C VHKK(K,IDXCAS) = VTXCAS(2,K) | |
17813 | WHKK(K,IDXCAS) = VTXCA1(1,K) | |
17814 | VHKK(K,IDXCAS) = VTXCA1(2,K) | |
17815 | 100 CONTINUE | |
17816 | ENDIF | |
17817 | ||
17818 | C9998 CONTINUE | |
17819 | * no cascade-step because of configuration | |
17820 | * (i.e. hadron outside nucleus etc.) | |
17821 | LCAS = .TRUE. | |
17822 | RETURN | |
17823 | ||
17824 | 9999 CONTINUE | |
17825 | * rejection | |
17826 | IREJ = 1 | |
17827 | RETURN | |
17828 | END | |
17829 | ||
17830 | *$ CREATE DT_ABSORP.FOR | |
17831 | *COPY DT_ABSORP | |
17832 | * | |
17833 | *===absorp=============================================================* | |
17834 | * | |
17835 | SUBROUTINE DT_ABSORP(IDCAS,PCAS,NCAS,NSPE,IDSPE,IDXSPE,MODE,IREJ) | |
17836 | ||
17837 | ************************************************************************ | |
17838 | * Two-nucleon absorption of antiprotons, pi-, and K-. * | |
17839 | * Antiproton absorption is handled by HADRIN. * | |
17840 | * The following channels for meson-absorption are considered: * | |
17841 | * pi- + p + p ---> n + p * | |
17842 | * pi- + p + n ---> n + n * | |
17843 | * K- + p + p ---> sigma+ + n / Lam + p / sigma0 + p * | |
17844 | * K- + p + n ---> sigma- + n / Lam + n / sigma0 + n * | |
17845 | * K- + p + p ---> sigma- + n * | |
17846 | * IDCAS, PCAS identity, momentum of particle to be absorbed * | |
17847 | * NCAS = 1 intranuclear cascade in projectile * | |
17848 | * = -1 intranuclear cascade in target * | |
17849 | * NSPE number of spectator nucleons involved * | |
17850 | * IDXSPE(2) DTEVT1-indices of spectator nucleons involved * | |
17851 | * Revised version of the original STOPIK written by HJM and J. Ranft. * | |
17852 | * This version dated 24.02.95 is written by S. Roesler * | |
17853 | ************************************************************************ | |
17854 | ||
17855 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
17856 | SAVE | |
17857 | ||
17858 | PARAMETER ( LINP = 10 , | |
17859 | & LOUT = 6 , | |
17860 | & LDAT = 9 ) | |
17861 | ||
17862 | PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,ONE=1.0D0, | |
17863 | & ONETHI=0.3333D0,TWOTHI=0.6666D0) | |
17864 | ||
17865 | * event history | |
17866 | ||
17867 | PARAMETER (NMXHKK=200000) | |
17868 | ||
17869 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
17870 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
17871 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
17872 | ||
17873 | * extended event history | |
17874 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
17875 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
17876 | & IHIST(2,NMXHKK) | |
17877 | ||
17878 | * flags for input different options | |
17879 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
17880 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
17881 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
17882 | ||
17883 | * final state after inc step | |
17884 | PARAMETER (MAXFSP=10) | |
17885 | COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP | |
17886 | ||
17887 | * particle properties (BAMJET index convention) | |
17888 | CHARACTER*8 ANAME | |
17889 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
17890 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
17891 | ||
17892 | DIMENSION PCAS(5),IDXSPE(2),IDSPE(2),PSPE(2,5),PSPE1(5), | |
17893 | & PTOT3P(4),BG3P(4), | |
17894 | & ECMF(2),PCMF(2),CODF(2),COFF(2),SIFF(2) | |
17895 | ||
17896 | IREJ = 0 | |
17897 | NFSP = 0 | |
17898 | ||
17899 | * skip particles others than ap, pi-, K- for mode=0 | |
17900 | IF ((MODE.EQ.0).AND. | |
17901 | & (IDCAS.NE.2).AND.(IDCAS.NE.14).AND.(IDCAS.NE.16)) RETURN | |
17902 | * skip particles others than pions for mode=1 | |
17903 | * (2-nucleon absorption in intranuclear cascade) | |
17904 | IF ((MODE.EQ.1).AND. | |
17905 | & (IDCAS.NE.13).AND.(IDCAS.NE.14).AND.(IDCAS.NE.23)) RETURN | |
17906 | ||
17907 | NUCAS = NCAS | |
17908 | IF (NUCAS.EQ.-1) NUCAS = 2 | |
17909 | ||
17910 | IF (MODE.EQ.0) THEN | |
17911 | * scan spectator nucleons for nucleons being able to "absorb" | |
17912 | NSPE = 0 | |
17913 | IDXSPE(1) = 0 | |
17914 | IDXSPE(2) = 0 | |
17915 | DO 1 I=1,NHKK | |
17916 | IF ((ISTHKK(I).EQ.12+NUCAS).OR.(ISTHKK(I).EQ.14+NUCAS)) THEN | |
17917 | NSPE = NSPE+1 | |
17918 | IDXSPE(NSPE) = I | |
17919 | IDSPE(NSPE) = IDBAM(I) | |
17920 | IF ((NSPE.EQ.1).AND.(IDCAS.EQ.2)) GOTO 2 | |
17921 | IF (NSPE.EQ.2) THEN | |
17922 | IF ((IDCAS.EQ.14).AND.(IDSPE(1).EQ.8).AND. | |
17923 | & (IDSPE(2).EQ.8)) THEN | |
17924 | * there is no pi-+n+n channel | |
17925 | NSPE = 1 | |
17926 | GOTO 1 | |
17927 | ELSE | |
17928 | GOTO 2 | |
17929 | ENDIF | |
17930 | ENDIF | |
17931 | ENDIF | |
17932 | 1 CONTINUE | |
17933 | ||
17934 | 2 CONTINUE | |
17935 | ENDIF | |
17936 | * transform excited projectile nucleons (status=15) into proj. rest s. | |
17937 | DO 3 I=1,NSPE | |
17938 | DO 4 K=1,5 | |
17939 | PSPE(I,K) = PHKK(K,IDXSPE(I)) | |
17940 | 4 CONTINUE | |
17941 | 3 CONTINUE | |
17942 | ||
17943 | * antiproton absorption | |
17944 | IF ((IDCAS.EQ.2).AND.(NSPE.GE.1)) THEN | |
17945 | DO 5 K=1,5 | |
17946 | PSPE1(K) = PSPE(1,K) | |
17947 | 5 CONTINUE | |
17948 | CALL DT_HADRIN(IDCAS,PCAS,IDSPE(1),PSPE1,1,IREJ1) | |
17949 | IF (IREJ1.NE.0) GOTO 9999 | |
17950 | ||
17951 | * meson absorption | |
17952 | ELSEIF (((IDCAS.EQ.13).OR.(IDCAS.EQ.14).OR.(IDCAS.EQ.23) | |
17953 | & .OR.(IDCAS.EQ.16)).AND.(NSPE.GE.2)) THEN | |
17954 | IF (IDCAS.EQ.14) THEN | |
17955 | * pi- absorption | |
17956 | IDFSP(1) = 8 | |
17957 | IDFSP(2) = 8 | |
17958 | IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) IDFSP(2) = 1 | |
17959 | ELSEIF (IDCAS.EQ.13) THEN | |
17960 | * pi+ absorption | |
17961 | IDFSP(1) = 1 | |
17962 | IDFSP(2) = 1 | |
17963 | IF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) IDFSP(2) = 8 | |
17964 | ELSEIF (IDCAS.EQ.23) THEN | |
17965 | * pi0 absorption | |
17966 | IDFSP(1) = IDSPE(1) | |
17967 | IDFSP(2) = IDSPE(2) | |
17968 | ELSEIF (IDCAS.EQ.16) THEN | |
17969 | * K- absorption | |
17970 | R = DT_RNDM(PCAS) | |
17971 | IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) THEN | |
17972 | IF (R.LT.ONETHI) THEN | |
17973 | IDFSP(1) = 21 | |
17974 | IDFSP(2) = 8 | |
17975 | ELSEIF (R.LT.TWOTHI) THEN | |
17976 | IDFSP(1) = 17 | |
17977 | IDFSP(2) = 1 | |
17978 | ELSE | |
17979 | IDFSP(1) = 22 | |
17980 | IDFSP(2) = 1 | |
17981 | ENDIF | |
17982 | ELSEIF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) THEN | |
17983 | IDFSP(1) = 20 | |
17984 | IDFSP(2) = 8 | |
17985 | ELSE | |
17986 | IF (R.LT.ONETHI) THEN | |
17987 | IDFSP(1) = 20 | |
17988 | IDFSP(2) = 1 | |
17989 | ELSEIF (R.LT.TWOTHI) THEN | |
17990 | IDFSP(1) = 17 | |
17991 | IDFSP(2) = 8 | |
17992 | ELSE | |
17993 | IDFSP(1) = 22 | |
17994 | IDFSP(2) = 8 | |
17995 | ENDIF | |
17996 | ENDIF | |
17997 | ENDIF | |
17998 | * dump initial particles for energy-momentum cons. check | |
17999 | IF (LEMCCK) THEN | |
18000 | CALL DT_EVTEMC(PCAS(1),PCAS(2),PCAS(3),PCAS(4),1,IDUM,IDUM) | |
18001 | CALL DT_EVTEMC(PSPE(1,1),PSPE(1,2),PSPE(1,3),PSPE(1,4),2, | |
18002 | & IDUM,IDUM) | |
18003 | CALL DT_EVTEMC(PSPE(2,1),PSPE(2,2),PSPE(2,3),PSPE(2,4),2, | |
18004 | & IDUM,IDUM) | |
18005 | ENDIF | |
18006 | * get Lorentz-parameter of 3 particle initial state | |
18007 | DO 6 K=1,4 | |
18008 | PTOT3P(K) = PCAS(K)+PSPE(1,K)+PSPE(2,K) | |
18009 | 6 CONTINUE | |
18010 | P3P = SQRT(PTOT3P(1)**2+PTOT3P(2)**2+PTOT3P(3)**2) | |
18011 | AM3P = SQRT( (PTOT3P(4)-P3P)*(PTOT3P(4)+P3P) ) | |
18012 | DO 7 K=1,4 | |
18013 | BG3P(K) = PTOT3P(K)/MAX(AM3P,TINY10) | |
18014 | 7 CONTINUE | |
18015 | * 2-particle decay of the 3-particle compound system | |
18016 | CALL DT_DTWOPD(AM3P,ECMF(1),ECMF(2),PCMF(1),PCMF(2), | |
18017 | & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2), | |
18018 | & AAM(IDFSP(1)),AAM(IDFSP(2))) | |
18019 | DO 8 I=1,2 | |
18020 | SDF = SQRT((ONE-CODF(I))*(ONE+CODF(I))) | |
18021 | PX = PCMF(I)*COFF(I)*SDF | |
18022 | PY = PCMF(I)*SIFF(I)*SDF | |
18023 | PZ = PCMF(I)*CODF(I) | |
18024 | CALL DT_DALTRA(BG3P(4),BG3P(1),BG3P(2),BG3P(3),PX,PY,PZ, | |
18025 | & ECMF(I),PTOFSP,PFSP(1,I),PFSP(2,I),PFSP(3,I), | |
18026 | & PFSP(4,I)) | |
18027 | PFSP(5,I) = SQRT( (PFSP(4,I)-PTOFSP)*(PFSP(4,I)+PTOFSP) ) | |
18028 | * check consistency of kinematics | |
18029 | IF (ABS(AAM(IDFSP(I))-PFSP(5,I)).GT.TINY5) THEN | |
18030 | WRITE(LOUT,1001) IDFSP(I),AAM(IDFSP(I)),PFSP(5,I) | |
18031 | 1001 FORMAT(1X,'ABSORP: warning! inconsistent', | |
18032 | & ' tree-particle kinematics',/,20X,'id: ',I3, | |
18033 | & ' AAM = ',E10.4,' MFSP = ',E10.4) | |
18034 | ENDIF | |
18035 | * dump final state particles for energy-momentum cons. check | |
18036 | IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I), | |
18037 | & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM) | |
18038 | 8 CONTINUE | |
18039 | NFSP = 2 | |
18040 | IF (LEMCCK) THEN | |
18041 | CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,100,IREJ1) | |
18042 | IF (IREJ1.NE.0) THEN | |
18043 | WRITE(LOUT,*)'ABSORB: EMC ',AAM(IDFSP(1)),AAM(IDFSP(2)), | |
18044 | & AM3P | |
18045 | GOTO 9999 | |
18046 | ENDIF | |
18047 | ENDIF | |
18048 | ELSE | |
18049 | IF (IOULEV(3).GT.0) WRITE(LOUT,1000) IDCAS,NSPE | |
18050 | 1000 FORMAT(1X,'ABSORP: warning! absorption for particle ',I3, | |
18051 | & ' impossible',/,20X,'too few spectators (',I2,')') | |
18052 | NSPE = 0 | |
18053 | ENDIF | |
18054 | ||
18055 | RETURN | |
18056 | ||
18057 | 9999 CONTINUE | |
18058 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in ABSORP' | |
18059 | IREJ = 1 | |
18060 | RETURN | |
18061 | END | |
18062 | ||
18063 | *$ CREATE DT_HADRIN.FOR | |
18064 | *COPY DT_HADRIN | |
18065 | * | |
18066 | *===hadrin=============================================================* | |
18067 | * | |
18068 | SUBROUTINE DT_HADRIN(IDPR,PPR,IDTA,PTA,MODE,IREJ) | |
18069 | ||
18070 | ************************************************************************ | |
18071 | * Interface to the HADRIN-routines for inelastic and elastic * | |
18072 | * scattering. * | |
18073 | * IDPR,PPR(5) identity, momentum of projectile * | |
18074 | * IDTA,PTA(5) identity, momentum of target * | |
18075 | * MODE = 1 inelastic interaction * | |
18076 | * = 2 elastic interaction * | |
18077 | * Revised version of the original FHAD. * | |
18078 | * This version dated 27.10.95 is written by S. Roesler * | |
18079 | ************************************************************************ | |
18080 | ||
18081 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
18082 | SAVE | |
18083 | ||
18084 | PARAMETER ( LINP = 10 , | |
18085 | & LOUT = 6 , | |
18086 | & LDAT = 9 ) | |
18087 | ||
18088 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3, | |
18089 | & TINY2=1.0D-2,TINY1=1.0D-1,ONE=1.0D0) | |
18090 | ||
18091 | LOGICAL LCORR,LMSSG | |
18092 | ||
18093 | * flags for input different options | |
18094 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
18095 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
18096 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
18097 | ||
18098 | * final state after inc step | |
18099 | PARAMETER (MAXFSP=10) | |
18100 | COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP | |
18101 | ||
18102 | * particle properties (BAMJET index convention) | |
18103 | CHARACTER*8 ANAME | |
18104 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
18105 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
18106 | * output-common for DHADRI/ELHAIN | |
18107 | ||
18108 | * final state from HADRIN interaction | |
18109 | PARAMETER (MAXFIN=10) | |
18110 | COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN), | |
18111 | & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH | |
18112 | ||
18113 | DIMENSION PPR(5),PPR1(5),PTA(5),BGTA(4), | |
18114 | & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4),IMCORR(2) | |
18115 | ||
18116 | DATA LMSSG /.TRUE./ | |
18117 | ||
18118 | IREJ = 0 | |
18119 | NFSP = 0 | |
18120 | KCORR = 0 | |
18121 | IMCORR(1) = 0 | |
18122 | IMCORR(2) = 0 | |
18123 | LCORR = .FALSE. | |
18124 | ||
18125 | * dump initial particles for energy-momentum cons. check | |
18126 | IF (LEMCCK) THEN | |
18127 | CALL DT_EVTEMC(PPR(1),PPR(2),PPR(3),PPR(4),1,IDUM,IDUM) | |
18128 | CALL DT_EVTEMC(PTA(1),PTA(2),PTA(3),PTA(4),2,IDUM,IDUM) | |
18129 | ENDIF | |
18130 | ||
18131 | AMP2 = PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2 | |
18132 | AMT2 = PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2 | |
18133 | IF ((AMP2.LT.ZERO).OR.(AMT2.LT.ZERO).OR. | |
18134 | & (ABS(AMP2-AAM(IDPR)**2).GT.TINY5).OR. | |
18135 | & (ABS(AMT2-AAM(IDTA)**2).GT.TINY5)) THEN | |
18136 | IF (LMSSG.AND.(IOULEV(3).GT.0)) | |
18137 | & WRITE(LOUT,1000) AMP2,AAM(IDPR)**2,AMT2,AAM(IDTA)**2 | |
18138 | 1000 FORMAT(1X,'HADRIN: warning! inconsistent projectile/target', | |
18139 | & ' mass',/,20X,'AMP2 = ',E12.4,', AAM(IDPR)**2 = ', | |
18140 | & E12.4,/,20X,'AMT2 = ',E12.4,', AAM(IDTA)**2 = ',E12.4) | |
18141 | LMSSG = .FALSE. | |
18142 | LCORR = .TRUE. | |
18143 | ENDIF | |
18144 | ||
18145 | * convert initial state particles into particles which can be | |
18146 | * handled by HADRIN | |
18147 | IDHPR = IDPR | |
18148 | IDHTA = IDTA | |
18149 | IF ((IDHPR.LE.0).OR.(IDHPR.GE.111).OR.LCORR) THEN | |
18150 | IF ((IDHPR.LE.0).OR.(IDHPR.GE.111)) IDHPR = 1 | |
18151 | DO 1 K=1,4 | |
18152 | P1IN(K) = PPR(K) | |
18153 | P2IN(K) = PTA(K) | |
18154 | 1 CONTINUE | |
18155 | XM1 = AAM(IDHPR) | |
18156 | XM2 = AAM(IDHTA) | |
18157 | CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1) | |
18158 | IF (IREJ1.GT.0) THEN | |
18159 | WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.' | |
18160 | GOTO 9999 | |
18161 | ENDIF | |
18162 | DO 2 K=1,4 | |
18163 | PPR(K) = P1OUT(K) | |
18164 | PTA(K) = P2OUT(K) | |
18165 | 2 CONTINUE | |
18166 | PPR(5) = SQRT(PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2) | |
18167 | PTA(5) = SQRT(PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2) | |
18168 | ENDIF | |
18169 | ||
18170 | * Lorentz-parameter for trafo into rest-system of target | |
18171 | DO 3 K=1,4 | |
18172 | BGTA(K) = PTA(K)/PTA(5) | |
18173 | 3 CONTINUE | |
18174 | * transformation of projectile into rest-system of target | |
18175 | CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),PPR(1),PPR(2), | |
18176 | & PPR(3),PPR(4),PPRTO1,PPR1(1),PPR1(2),PPR1(3), | |
18177 | & PPR1(4)) | |
18178 | ||
18179 | * direction cosines of projectile in target rest system | |
18180 | CX = PPR1(1)/PPRTO1 | |
18181 | CY = PPR1(2)/PPRTO1 | |
18182 | CZ = PPR1(3)/PPRTO1 | |
18183 | ||
18184 | * sample inelastic interaction | |
18185 | IF (MODE.EQ.1) THEN | |
18186 | CALL DT_DHADRI(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA) | |
18187 | IF (IRH.EQ.1) GOTO 9998 | |
18188 | * sample elastic interaction | |
18189 | ELSEIF (MODE.EQ.2) THEN | |
18190 | CALL DT_ELHAIN(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA,IREJ1) | |
18191 | IF (IREJ1.NE.0) THEN | |
18192 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in HADRIN' | |
18193 | GOTO 9999 | |
18194 | ENDIF | |
18195 | IF (IRH.EQ.1) GOTO 9998 | |
18196 | ELSE | |
18197 | WRITE(LOUT,1001) MODE,INTHAD | |
18198 | 1001 FORMAT(1X,'HADRIN: warning! inconsistent interaction mode', | |
18199 | & I4,' (INTHAD =',I4,')') | |
18200 | GOTO 9999 | |
18201 | ENDIF | |
18202 | ||
18203 | * transform final state particles back into Lab. | |
18204 | DO 4 I=1,IRH | |
18205 | NFSP = NFSP+1 | |
18206 | PX = CXRH(I)*PLRH(I) | |
18207 | PY = CYRH(I)*PLRH(I) | |
18208 | PZ = CZRH(I)*PLRH(I) | |
18209 | CALL DT_DALTRA(BGTA(4),BGTA(1),BGTA(2),BGTA(3), | |
18210 | & PX,PY,PZ,ELRH(I),PTOFSP,PFSP(1,NFSP), | |
18211 | & PFSP(2,NFSP),PFSP(3,NFSP),PFSP(4,NFSP)) | |
18212 | IDFSP(NFSP) = ITRH(I) | |
18213 | AMFSP2 = PFSP(4,NFSP)**2-PFSP(1,NFSP)**2-PFSP(2,NFSP)**2- | |
18214 | & PFSP(3,NFSP)**2 | |
18215 | IF (AMFSP2.LT.-TINY3) THEN | |
18216 | WRITE(LOUT,1002) IDFSP(NFSP),PFSP(1,NFSP),PFSP(2,NFSP), | |
18217 | & PFSP(3,NFSP),PFSP(4,NFSP),AMFSP2 | |
18218 | 1002 FORMAT(1X,'HADRIN: warning! final state particle (id = ', | |
18219 | & I2,') with negative mass^2',/,1X,5E12.4) | |
18220 | GOTO 9999 | |
18221 | ELSE | |
18222 | PFSP(5,NFSP) = SQRT(ABS(AMFSP2)) | |
18223 | IF (ABS(PFSP(5,NFSP)-AAM(IDFSP(NFSP))).GT.TINY1) THEN | |
18224 | WRITE(LOUT,1003) IDFSP(NFSP),AAM(IDFSP(NFSP)), | |
18225 | & PFSP(5,NFSP) | |
18226 | 1003 FORMAT(1X,'HADRIN: warning! final state particle', | |
18227 | & ' (id = ',I2,') with inconsistent mass',/,1X, | |
18228 | & 2E12.4) | |
18229 | KCORR = KCORR+1 | |
18230 | IF (KCORR.GT.2) GOTO 9999 | |
18231 | IMCORR(KCORR) = NFSP | |
18232 | ENDIF | |
18233 | ENDIF | |
18234 | * dump final state particles for energy-momentum cons. check | |
18235 | IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I), | |
18236 | & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM) | |
18237 | 4 CONTINUE | |
18238 | ||
18239 | * transform momenta on mass shell in case of inconsistencies in | |
18240 | * HADRIN | |
18241 | IF (KCORR.GT.0) THEN | |
18242 | IF (KCORR.EQ.2) THEN | |
18243 | I1 = IMCORR(1) | |
18244 | I2 = IMCORR(2) | |
18245 | ELSE | |
18246 | IF (IMCORR(1).EQ.1) THEN | |
18247 | I1 = 1 | |
18248 | I2 = 2 | |
18249 | ELSE | |
18250 | I1 = 1 | |
18251 | I2 = IMCORR(1) | |
18252 | ENDIF | |
18253 | ENDIF | |
18254 | IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I1),PFSP(2,I1), | |
18255 | & PFSP(3,I1),PFSP(4,I1),2,IDUM,IDUM) | |
18256 | IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I2),PFSP(2,I2), | |
18257 | & PFSP(3,I2),PFSP(4,I2),2,IDUM,IDUM) | |
18258 | DO 5 K=1,4 | |
18259 | P1IN(K) = PFSP(K,I1) | |
18260 | P2IN(K) = PFSP(K,I2) | |
18261 | 5 CONTINUE | |
18262 | XM1 = AAM(IDFSP(I1)) | |
18263 | XM2 = AAM(IDFSP(I2)) | |
18264 | CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1) | |
18265 | IF (IREJ1.GT.0) THEN | |
18266 | WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.' | |
18267 | C GOTO 9999 | |
18268 | ENDIF | |
18269 | DO 6 K=1,4 | |
18270 | PFSP(K,I1) = P1OUT(K) | |
18271 | PFSP(K,I2) = P2OUT(K) | |
18272 | 6 CONTINUE | |
18273 | PFSP(5,I1) = SQRT(PFSP(4,I1)**2-PFSP(1,I1)**2 | |
18274 | & -PFSP(2,I1)**2-PFSP(3,I1)**2) | |
18275 | PFSP(5,I2) = SQRT(PFSP(4,I2)**2-PFSP(1,I2)**2 | |
18276 | & -PFSP(2,I2)**2-PFSP(3,I2)**2) | |
18277 | * dump final state particles for energy-momentum cons. check | |
18278 | IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I1),-PFSP(2,I1), | |
18279 | & -PFSP(3,I1),-PFSP(4,I1),2,IDUM,IDUM) | |
18280 | IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I2),-PFSP(2,I2), | |
18281 | & -PFSP(3,I2),-PFSP(4,I2),2,IDUM,IDUM) | |
18282 | ENDIF | |
18283 | ||
18284 | * check energy-momentum conservation | |
18285 | IF (LEMCCK) THEN | |
18286 | CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,102,IREJ1) | |
18287 | IF (IREJ1.NE.0) GOTO 9999 | |
18288 | ENDIF | |
18289 | ||
18290 | RETURN | |
18291 | ||
18292 | 9998 CONTINUE | |
18293 | IREJ = 2 | |
18294 | RETURN | |
18295 | ||
18296 | 9999 CONTINUE | |
18297 | IREJ = 1 | |
18298 | RETURN | |
18299 | END | |
18300 | ||
18301 | *$ CREATE DT_HADCOL.FOR | |
18302 | *COPY DT_HADCOL | |
18303 | * | |
18304 | *===hadcol=============================================================* | |
18305 | * | |
18306 | SUBROUTINE DT_HADCOL(IDPROJ,PPN,IDXTAR,IREJ) | |
18307 | ||
18308 | ************************************************************************ | |
18309 | * Interface to the HADRIN-routines for inelastic and elastic * | |
18310 | * scattering. This subroutine samples hadron-nucleus interactions * | |
18311 | * below DPM-threshold. * | |
18312 | * IDPROJ BAMJET-index of projectile hadron * | |
18313 | * PPN projectile momentum in target rest frame * | |
18314 | * IDXTAR DTEVT1-index of target nucleon undergoing * | |
18315 | * interaction with projectile hadron * | |
18316 | * This subroutine replaces HADHAD. * | |
18317 | * This version dated 5.5.95 is written by S. Roesler * | |
18318 | ************************************************************************ | |
18319 | ||
18320 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
18321 | SAVE | |
18322 | ||
18323 | PARAMETER ( LINP = 10 , | |
18324 | & LOUT = 6 , | |
18325 | & LDAT = 9 ) | |
18326 | ||
18327 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0) | |
18328 | ||
18329 | LOGICAL LSTART | |
18330 | ||
18331 | * event history | |
18332 | ||
18333 | PARAMETER (NMXHKK=200000) | |
18334 | ||
18335 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
18336 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
18337 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
18338 | ||
18339 | * extended event history | |
18340 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
18341 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
18342 | & IHIST(2,NMXHKK) | |
18343 | ||
18344 | * nuclear potential | |
18345 | LOGICAL LFERMI | |
18346 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, | |
18347 | & EBINDP(2),EBINDN(2),EPOT(2,210), | |
18348 | & ETACOU(2),ICOUL,LFERMI | |
18349 | ||
18350 | * interface HADRIN-DPM | |
18351 | COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA | |
18352 | ||
18353 | * parameter for intranuclear cascade | |
18354 | LOGICAL LPAULI | |
18355 | COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI | |
18356 | ||
18357 | * final state after inc step | |
18358 | PARAMETER (MAXFSP=10) | |
18359 | COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP | |
18360 | ||
18361 | * particle properties (BAMJET index convention) | |
18362 | CHARACTER*8 ANAME | |
18363 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
18364 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
18365 | ||
18366 | DIMENSION PPROJ(5),PNUC(5) | |
18367 | ||
18368 | DATA LSTART /.TRUE./ | |
18369 | ||
18370 | IREJ = 0 | |
18371 | ||
18372 | NPOINT(1) = NHKK+1 | |
18373 | ||
18374 | TAUSAV = TAUFOR | |
18375 | **sr 6/9/01 commented | |
18376 | C TAUFOR = TAUFOR/2.0D0 | |
18377 | ** | |
18378 | IF (LSTART) THEN | |
18379 | WRITE(LOUT,1000) | |
18380 | 1000 FORMAT(/,1X,'HADCOL: Scattering handled by HADRIN') | |
18381 | WRITE(LOUT,1001) TAUFOR | |
18382 | 1001 FORMAT(/,1X,'HADCOL: Formation zone parameter set to ', | |
18383 | & F5.1,' fm/c') | |
18384 | LSTART = .FALSE. | |
18385 | ENDIF | |
18386 | ||
18387 | IDNUC = IDBAM(IDXTAR) | |
18388 | IDNUC1 = IDT_MCHAD(IDNUC) | |
18389 | IDPRO1 = IDT_MCHAD(IDPROJ) | |
18390 | ||
18391 | IF ((INTHAD.EQ.1).OR.(INTHAD.EQ.2)) THEN | |
18392 | IPROC = INTHAD | |
18393 | ELSE | |
18394 | ** | |
18395 | C CALL DT_SIHNIN(IDPRO1,IDNUC1,PPN,SIGIN) | |
18396 | C CALL DT_SIHNEL(IDPRO1,IDNUC1,PPN,SIGEL) | |
18397 | DUMZER = ZERO | |
18398 | CALL DT_XSHN(IDPRO1,IDNUC1,PPN,DUMZER,SIGTOT,SIGEL) | |
18399 | SIGIN = SIGTOT-SIGEL | |
18400 | C SIGTOT = SIGIN+SIGEL | |
18401 | ** | |
18402 | IPROC = 1 | |
18403 | IF (DT_RNDM(SIGIN).LT.SIGEL/SIGTOT) IPROC = 2 | |
18404 | ENDIF | |
18405 | ||
18406 | PPROJ(1) = ZERO | |
18407 | PPROJ(2) = ZERO | |
18408 | PPROJ(3) = PPN | |
18409 | PPROJ(5) = AAM(IDPROJ) | |
18410 | PPROJ(4) = SQRT(PPROJ(5)**2+PPROJ(3)**2) | |
18411 | DO 1 K=1,5 | |
18412 | PNUC(K) = PHKK(K,IDXTAR) | |
18413 | 1 CONTINUE | |
18414 | ||
18415 | ILOOP = 0 | |
18416 | 2 CONTINUE | |
18417 | ILOOP = ILOOP+1 | |
18418 | IF (ILOOP.GT.100) GOTO 9999 | |
18419 | ||
18420 | CALL DT_HADRIN(IDPROJ,PPROJ,IDNUC,PNUC,IPROC,IREJ1) | |
18421 | IF (IREJ1.EQ.1) GOTO 9999 | |
18422 | ||
18423 | IF (IREJ1.GT.1) THEN | |
18424 | * no interaction possible | |
18425 | * require Pauli blocking | |
18426 | IF ((IDPROJ.EQ.1).AND.(PPROJ(4).LE.PFERMP(2)+PPROJ(5))) GOTO 2 | |
18427 | IF ((IDPROJ.EQ.8).AND.(PPROJ(4).LE.PFERMN(2)+PPROJ(5))) GOTO 2 | |
18428 | IF ((IIBAR(IDPROJ).NE.1).AND. | |
18429 | & (PPROJ(4).LE.EPOT(2,IDPROJ)+PPROJ(5))) GOTO 2 | |
18430 | * store incoming particle as final state particle | |
18431 | CALL DT_LTNUC(PPROJ(3),PPROJ(4),PCMS,ECMS,3) | |
18432 | CALL DT_EVTPUT(1,IDPROJ,1,0,PPROJ(1),PPROJ(2),PCMS,ECMS,0,0,0) | |
18433 | NPOINT(4) = NHKK | |
18434 | ELSE | |
18435 | * require Pauli blocking for final state nucleons | |
18436 | DO 4 I=1,NFSP | |
18437 | IF ((IDFSP(I).EQ.1).AND. | |
18438 | & (PFSP(4,I).LE.PFERMP(2)+AAM(IDFSP(I)))) GOTO 2 | |
18439 | IF ((IDFSP(I).EQ.8).AND. | |
18440 | & (PFSP(4,I).LE.PFERMN(2)+AAM(IDFSP(I)))) GOTO 2 | |
18441 | IF ((IIBAR(IDFSP(I)).NE.1).AND. | |
18442 | & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I))))GOTO 2 | |
18443 | 4 CONTINUE | |
18444 | * store final state particles | |
18445 | DO 5 I=1,NFSP | |
18446 | IST = 1 | |
18447 | IF ((IIBAR(IDFSP(I)).EQ.1).AND. | |
18448 | & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I)))) IST = 16 | |
18449 | IDHAD = IDT_IPDGHA(IDFSP(I)) | |
18450 | CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PCMS,ECMS,3) | |
18451 | CALL DT_EVTPUT(IST,IDHAD,1,IDXTAR,PFSP(1,I),PFSP(2,I), | |
18452 | & PCMS,ECMS,0,0,0) | |
18453 | IF (I.EQ.1) NPOINT(4) = NHKK | |
18454 | VHKK(1,NHKK) = 0.5D0*(VHKK(1,1)+VHKK(1,IDXTAR)) | |
18455 | VHKK(2,NHKK) = 0.5D0*(VHKK(2,1)+VHKK(2,IDXTAR)) | |
18456 | VHKK(3,NHKK) = VHKK(3,IDXTAR) | |
18457 | VHKK(4,NHKK) = VHKK(4,IDXTAR) | |
18458 | WHKK(1,NHKK) = 0.5D0*(WHKK(1,1)+WHKK(1,IDXTAR)) | |
18459 | WHKK(2,NHKK) = 0.5D0*(WHKK(2,1)+WHKK(2,IDXTAR)) | |
18460 | WHKK(3,NHKK) = WHKK(3,1) | |
18461 | WHKK(4,NHKK) = WHKK(4,1) | |
18462 | 5 CONTINUE | |
18463 | ENDIF | |
18464 | TAUFOR = TAUSAV | |
18465 | RETURN | |
18466 | ||
18467 | 9999 CONTINUE | |
18468 | IREJ = 1 | |
18469 | TAUFOR = TAUSAV | |
18470 | RETURN | |
18471 | END | |
18472 | *$ CREATE DT_GETEMU.FOR | |
18473 | *COPY DT_GETEMU | |
18474 | * | |
18475 | *===getemu=============================================================* | |
18476 | * | |
18477 | SUBROUTINE DT_GETEMU(IT,ITZ,KKMAT,MODE) | |
18478 | ||
18479 | ************************************************************************ | |
18480 | * Sampling of emulsion component to be considered as target-nucleus. * | |
18481 | * This version dated 6.5.95 is written by S. Roesler. * | |
18482 | ************************************************************************ | |
18483 | ||
18484 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
18485 | SAVE | |
18486 | ||
18487 | PARAMETER ( LINP = 10 , | |
18488 | & LOUT = 6 , | |
18489 | & LDAT = 9 ) | |
18490 | ||
18491 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10) | |
18492 | ||
18493 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
18494 | ||
18495 | * emulsion treatment | |
18496 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
18497 | & NCOMPO,IEMUL | |
18498 | ||
18499 | * Glauber formalism: flags and parameters for statistics | |
18500 | LOGICAL LPROD | |
18501 | CHARACTER*8 CGLB | |
18502 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD | |
18503 | ||
18504 | IF (MODE.EQ.0) THEN | |
18505 | SUMFRA = ZERO | |
18506 | RR = DT_RNDM(SUMFRA) | |
18507 | IT = 0 | |
18508 | ITZ = 0 | |
18509 | DO 1 ICOMP=1,NCOMPO | |
18510 | SUMFRA = SUMFRA+EMUFRA(ICOMP) | |
18511 | IF (SUMFRA.GT.RR) THEN | |
18512 | IT = IEMUMA(ICOMP) | |
18513 | ITZ = IEMUCH(ICOMP) | |
18514 | KKMAT = ICOMP | |
18515 | GOTO 2 | |
18516 | ENDIF | |
18517 | 1 CONTINUE | |
18518 | 2 CONTINUE | |
18519 | IF (IT.LE.0) THEN | |
18520 | WRITE(LOUT,'(1X,A,E12.3)') | |
18521 | & 'Warning! norm. failure within emulsion fractions', | |
18522 | & SUMFRA | |
18523 | STOP | |
18524 | ENDIF | |
18525 | ELSEIF (MODE.EQ.1) THEN | |
18526 | NDIFF = 10000 | |
18527 | DO 3 I=1,NCOMPO | |
18528 | IDIFF = ABS(IT-IEMUMA(I)) | |
18529 | IF (IDIFF.LT.NDIFF) THEN | |
18530 | KKMAT = I | |
18531 | NDIFF = IDIFF | |
18532 | ENDIF | |
18533 | 3 CONTINUE | |
18534 | ELSE | |
18535 | STOP 'DT_GETEMU' | |
18536 | ENDIF | |
18537 | ||
18538 | * bypass for variable projectile/target/energy runs: the correct | |
18539 | * Glauber data will be always loaded on kkmat=1 | |
18540 | IF (IOGLB.EQ.100) THEN | |
18541 | KKMAT = 1 | |
18542 | ENDIF | |
18543 | ||
18544 | RETURN | |
18545 | END | |
18546 | ||
18547 | *$ CREATE DT_NCLPOT.FOR | |
18548 | *COPY DT_NCLPOT | |
18549 | * | |
18550 | *===nclpot=============================================================* | |
18551 | * | |
18552 | SUBROUTINE DT_NCLPOT(IPZ,IP,ITZ,IT,AFERP,AFERT,MODE) | |
18553 | ||
18554 | ************************************************************************ | |
18555 | * Calculation of Coulomb and nuclear potential for a given configurat. * | |
18556 | * IPZ, IP charge/mass number of proj. * | |
18557 | * ITZ, IT charge/mass number of targ. * | |
18558 | * AFERP,AFERT factors modifying proj./target pot. * | |
18559 | * if =0, FERMOD is used * | |
18560 | * MODE = 0 calculation of binding energy * | |
18561 | * = 1 pre-calculated binding energy is used * | |
18562 | * This version dated 16.11.95 is written by S. Roesler. * | |
18563 | * * | |
18564 | * Last change 28.12.2006 by S. Roesler. * | |
18565 | ************************************************************************ | |
18566 | ||
18567 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
18568 | SAVE | |
18569 | ||
18570 | PARAMETER ( LINP = 10 , | |
18571 | & LOUT = 6 , | |
18572 | & LDAT = 9 ) | |
18573 | ||
18574 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2, | |
18575 | & TINY10=1.0D-10) | |
18576 | ||
18577 | LOGICAL LSTART | |
18578 | ||
18579 | * particle properties (BAMJET index convention) | |
18580 | CHARACTER*8 ANAME | |
18581 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
18582 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
18583 | ||
18584 | * nuclear potential | |
18585 | LOGICAL LFERMI | |
18586 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, | |
18587 | & EBINDP(2),EBINDN(2),EPOT(2,210), | |
18588 | & ETACOU(2),ICOUL,LFERMI | |
18589 | ||
18590 | DIMENSION IDXPOT(14) | |
18591 | * ap an lam alam sig- sig+ sig0 tet0 tet- asig- | |
18592 | DATA IDXPOT / 2, 9, 17, 18, 20, 21, 22, 97, 98, 99, | |
18593 | * asig0 asig+ atet0 atet+ | |
18594 | & 100, 101, 102, 103/ | |
18595 | ||
18596 | DATA AN /0.4D0/ | |
18597 | DATA LSTART /.TRUE./ | |
18598 | ||
18599 | IF (MODE.EQ.0) THEN | |
18600 | EBINDP(1) = ZERO | |
18601 | EBINDN(1) = ZERO | |
18602 | EBINDP(2) = ZERO | |
18603 | EBINDN(2) = ZERO | |
18604 | ENDIF | |
18605 | AIP = DBLE(IP) | |
18606 | AIPZ = DBLE(IPZ) | |
18607 | AIT = DBLE(IT) | |
18608 | AITZ = DBLE(ITZ) | |
18609 | ||
18610 | FERMIP = AFERP | |
18611 | IF (AFERP.LE.ZERO) FERMIP = FERMOD | |
18612 | FERMIT = AFERT | |
18613 | IF (AFERT.LE.ZERO) FERMIT = FERMOD | |
18614 | ||
18615 | * Fermi momenta and binding energy for projectile | |
18616 | IF ((IP.GT.1).AND.LFERMI) THEN | |
18617 | IF (MODE.EQ.0) THEN | |
18618 | C EBINDP(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ-1) | |
18619 | C EBINDN(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ) | |
18620 | BIP = AIP -ONE | |
18621 | BIPZ = AIPZ-ONE | |
18622 | ||
18623 | C EBINDP(1) = 1.0D-3*(ENERGY(ONE,ONE)+ENERGY(BIP,BIPZ) | |
18624 | C & -ENERGY(AIP,AIPZ)) | |
18625 | EBINDP(1) = 1.0D-3*(EXMSAZ(ONE,ONE ,.TRUE.,IZDUM) | |
18626 | & +EXMSAZ(BIP,BIPZ,.TRUE.,IZDUM) | |
18627 | & -EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM)) | |
18628 | ||
18629 | IF (AIP.LE.AIPZ) THEN | |
18630 | EBINDN(1) = EBINDP(1) | |
18631 | WRITE(LOUT,*) ' DT_NCLPOT: AIP.LE.AIPZ (',AIP,AIPZ,')' | |
18632 | ELSE | |
18633 | ||
18634 | C EBINDN(1) = 1.0D-3*(ENERGY(ONE,ZERO)+ENERGY(BIP,AIPZ) | |
18635 | C & -ENERGY(AIP,AIPZ)) | |
18636 | EBINDN(1) = 1.0D-3*(EXMSAZ(ONE,ZERO,.TRUE.,IZDUM) | |
18637 | & +EXMSAZ(BIP,AIPZ,.TRUE.,IZDUM) | |
18638 | & -EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM)) | |
18639 | ||
18640 | ENDIF | |
18641 | ENDIF | |
18642 | PFERMP(1) = FERMIP*AN*(AIPZ/AIP)**0.333333D0 | |
18643 | PFERMN(1) = FERMIP*AN*((AIP-AIPZ)/AIP)**0.33333D0 | |
18644 | ELSE | |
18645 | PFERMP(1) = ZERO | |
18646 | PFERMN(1) = ZERO | |
18647 | ENDIF | |
18648 | * effective nuclear potential for projectile | |
18649 | C EPOT(1,1) = PFERMP(1)**2/(2.0D0*AAM(1)) + EBINDP(1) | |
18650 | C EPOT(1,8) = PFERMN(1)**2/(2.0D0*AAM(8)) + EBINDN(1) | |
18651 | EPOT(1,1) = SQRT(PFERMP(1)**2+AAM(1)**2) -AAM(1) + EBINDP(1) | |
18652 | EPOT(1,8) = SQRT(PFERMN(1)**2+AAM(8)**2) -AAM(8) + EBINDN(1) | |
18653 | ||
18654 | * Fermi momenta and binding energy for target | |
18655 | IF ((IT.GT.1).AND.LFERMI) THEN | |
18656 | IF (MODE.EQ.0) THEN | |
18657 | C EBINDP(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ-1) | |
18658 | C EBINDN(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ) | |
18659 | BIT = AIT -ONE | |
18660 | BITZ = AITZ-ONE | |
18661 | ||
18662 | C EBINDP(2) = 1.0D-3*(ENERGY(ONE,ONE)+ENERGY(BIT,BITZ) | |
18663 | C & -ENERGY(AIT,AITZ)) | |
18664 | EBINDP(2) = 1.0D-3*(EXMSAZ(ONE,ONE, .TRUE.,IZDUM) | |
18665 | & +EXMSAZ(BIT,BITZ,.TRUE.,IZDUM) | |
18666 | & -EXMSAZ(AIT,AITZ,.TRUE.,IZDUM)) | |
18667 | ||
18668 | IF (AIT.LE.AITZ) THEN | |
18669 | EBINDN(2) = EBINDP(2) | |
18670 | WRITE(LOUT,*) ' DT_NCLPOT: AIT.LE.AIPT (',AIT,AIPT,')' | |
18671 | ELSE | |
18672 | ||
18673 | C EBINDN(2) = 1.0D-3*(ENERGY(ONE,ZERO)+ENERGY(BIT,AITZ) | |
18674 | C & -ENERGY(AIT,AITZ)) | |
18675 | EBINDN(2) = 1.0D-3*(EXMSAZ(ONE,ZERO,.TRUE.,IZDUM) | |
18676 | & +EXMSAZ(BIT,AITZ,.TRUE.,IZDUM) | |
18677 | & -EXMSAZ(AIT,AITZ,.TRUE.,IZDUM)) | |
18678 | ||
18679 | ENDIF | |
18680 | ENDIF | |
18681 | PFERMP(2) = FERMIT*AN*(AITZ/AIT)**0.333333D0 | |
18682 | PFERMN(2) = FERMIT*AN*((AIT-AITZ)/AIT)**0.33333D0 | |
18683 | ELSE | |
18684 | PFERMP(2) = ZERO | |
18685 | PFERMN(2) = ZERO | |
18686 | ENDIF | |
18687 | * effective nuclear potential for target | |
18688 | C EPOT(2,1) = PFERMP(2)**2/(2.0D0*AAM(1)) + EBINDP(2) | |
18689 | C EPOT(2,8) = PFERMN(2)**2/(2.0D0*AAM(8)) + EBINDN(2) | |
18690 | EPOT(2,1) = SQRT(PFERMP(2)**2+AAM(1)**2) -AAM(1) + EBINDP(2) | |
18691 | EPOT(2,8) = SQRT(PFERMN(2)**2+AAM(8)**2) -AAM(8) + EBINDN(2) | |
18692 | ||
18693 | DO 2 I=1,14 | |
18694 | EPOT(1,IDXPOT(I)) = EPOT(1,8) | |
18695 | EPOT(2,IDXPOT(I)) = EPOT(2,8) | |
18696 | 2 CONTINUE | |
18697 | ||
18698 | * Coulomb energy | |
18699 | ETACOU(1) = ZERO | |
18700 | ETACOU(2) = ZERO | |
18701 | IF (ICOUL.EQ.1) THEN | |
18702 | IF (IP.GT.1) | |
18703 | & ETACOU(1) = 0.001116D0*AIPZ/(1.0D0+AIP**0.333D0) | |
18704 | IF (IT.GT.1) | |
18705 | & ETACOU(2) = 0.001116D0*AITZ/(1.0D0+AIT**0.333D0) | |
18706 | ENDIF | |
18707 | ||
18708 | IF (LSTART) THEN | |
18709 | WRITE(LOUT,1000) IP,IPZ,IT,ITZ,EBINDP,EBINDN, | |
18710 | & EPOT(1,1)-EBINDP(1),EPOT(2,1)-EBINDP(2), | |
18711 | & EPOT(1,8)-EBINDN(1),EPOT(2,8)-EBINDN(2), | |
18712 | & FERMOD,ETACOU | |
18713 | 1000 FORMAT(/,/,1X,'NCLPOT: quantities for inclusion of nuclear' | |
18714 | & ,' effects',/,12X,'---------------------------', | |
18715 | & '----------------',/,/,38X,'projectile', | |
18716 | & ' target',/,/,1X,'Mass number / charge', | |
18717 | & 17X,I3,' /',I3,6X,I3,' /',I3,/,1X,'Binding energy -', | |
18718 | & ' proton (GeV) ',2E14.4,/,17X,'- neutron (GeV)' | |
18719 | & ,1X,2E14.4,/,1X,'Fermi-potential - proton (GeV)', | |
18720 | & 1X,2E14.4,/,17X,'- neutron (GeV) ',2E14.4,/,/, | |
18721 | & 1X,'Scale factor for Fermi-momentum ',F4.2,/, | |
18722 | & /,1X,'Coulomb-energy ',2(E14.4,' GeV '),/,/) | |
18723 | LSTART = .FALSE. | |
18724 | ENDIF | |
18725 | ||
18726 | RETURN | |
18727 | END | |
18728 | ||
18729 | *$ CREATE DT_RESNCL.FOR | |
18730 | *COPY DT_RESNCL | |
18731 | * | |
18732 | *===resncl=============================================================* | |
18733 | * | |
18734 | SUBROUTINE DT_RESNCL(EPN,NLOOP,MODE) | |
18735 | ||
18736 | ************************************************************************ | |
18737 | * Treatment of residual nuclei and nuclear effects. * | |
18738 | * MODE = 1 initializations * | |
18739 | * = 2 treatment of final state * | |
18740 | * This version dated 16.11.95 is written by S. Roesler. * | |
18741 | * * | |
18742 | * Last change 05.01.2007 by S. Roesler. * | |
18743 | ************************************************************************ | |
18744 | ||
18745 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
18746 | SAVE | |
18747 | ||
18748 | PARAMETER ( LINP = 10 , | |
18749 | & LOUT = 6 , | |
18750 | & LDAT = 9 ) | |
18751 | ||
18752 | PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,THREE=3.D0,TINY3=1.0D-3, | |
18753 | & TINY2=1.0D-2,TINY1=1.0D-1,TINY4=1.0D-4,TINY10=1.0D-10, | |
18754 | & ONETHI=ONE/THREE) | |
18755 | PARAMETER (AMUAMU = 0.93149432D0, | |
18756 | & FM2MM = 1.0D-12, | |
18757 | & RNUCLE = 1.12D0) | |
18758 | PARAMETER ( EMVGEV = 1.0 D-03 ) | |
18759 | PARAMETER ( AMUGEV = 0.93149432 D+00 ) | |
18760 | PARAMETER ( AMPRTN = 0.93827231 D+00 ) | |
18761 | PARAMETER ( AMNTRN = 0.93956563 D+00 ) | |
18762 | PARAMETER ( AMELCT = 0.51099906 D-03 ) | |
18763 | PARAMETER ( HLFHLF = 0.5D+00 ) | |
18764 | PARAMETER ( FERTHO = 14.33 D-09 ) | |
18765 | PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 ) | |
18766 | PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 ) | |
18767 | PARAMETER ( AMUC12 = AMUGEV - AMUNMU ) | |
18768 | ||
18769 | * event history | |
18770 | ||
18771 | PARAMETER (NMXHKK=200000) | |
18772 | ||
18773 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
18774 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
18775 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
18776 | ||
18777 | * extended event history | |
18778 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
18779 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
18780 | & IHIST(2,NMXHKK) | |
18781 | ||
18782 | * particle properties (BAMJET index convention) | |
18783 | CHARACTER*8 ANAME | |
18784 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
18785 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
18786 | ||
18787 | * flags for input different options | |
18788 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
18789 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
18790 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
18791 | ||
18792 | * nuclear potential | |
18793 | LOGICAL LFERMI | |
18794 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, | |
18795 | & EBINDP(2),EBINDN(2),EPOT(2,210), | |
18796 | & ETACOU(2),ICOUL,LFERMI | |
18797 | ||
18798 | * properties of interacting particles | |
18799 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
18800 | ||
18801 | * properties of photon/lepton projectiles | |
18802 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC | |
18803 | ||
18804 | * Lorentz-parameters of the current interaction | |
18805 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
18806 | & UMO,PPCM,EPROJ,PPROJ | |
18807 | ||
18808 | * treatment of residual nuclei: wounded nucleons | |
18809 | COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210) | |
18810 | ||
18811 | * treatment of residual nuclei: 4-momenta | |
18812 | LOGICAL LRCLPR,LRCLTA | |
18813 | COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5), | |
18814 | & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA | |
18815 | ||
18816 | DIMENSION PFSP(4),PSEC(4),PSEC0(4) | |
18817 | DIMENSION PMOMB(5000),IDXB(5000),PMOMM(10000),IDXM(10000), | |
18818 | & IDXCOR(15000),IDXOTH(NMXHKK) | |
18819 | ||
18820 | GOTO (1,2) MODE | |
18821 | ||
18822 | *------- initializations | |
18823 | 1 CONTINUE | |
18824 | ||
18825 | * initialize arrays for residual nuclei | |
18826 | DO 10 K=1,5 | |
18827 | IF (K.LE.4) THEN | |
18828 | PFSP(K) = ZERO | |
18829 | ENDIF | |
18830 | PINIPR(K) = ZERO | |
18831 | PINITA(K) = ZERO | |
18832 | PRCLPR(K) = ZERO | |
18833 | PRCLTA(K) = ZERO | |
18834 | TRCLPR(K) = ZERO | |
18835 | TRCLTA(K) = ZERO | |
18836 | 10 CONTINUE | |
18837 | SCPOT = ONE | |
18838 | NLOOP = 0 | |
18839 | ||
18840 | * correction of projectile 4-momentum for effective target pot. | |
18841 | * and Coulomb-energy (in case of hadron-nucleus interaction only) | |
18842 | IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN | |
18843 | EPNI = EPN | |
18844 | * Coulomb-energy: | |
18845 | * positively charged hadron - check energy for Coloumb pot. | |
18846 | IF (IICH(IJPROJ).EQ.1) THEN | |
18847 | THRESH = ETACOU(2)+AAM(IJPROJ) | |
18848 | IF (EPNI.LE.THRESH) THEN | |
18849 | WRITE(LOUT,1000) | |
18850 | 1000 FORMAT(/,1X,'KKINC: WARNING! projectile energy', | |
18851 | & ' below Coulomb threshold - event rejected',/) | |
18852 | ISTHKK(1) = 1 | |
18853 | RETURN | |
18854 | ENDIF | |
18855 | * negatively charged hadron - increase energy by Coulomb energy | |
18856 | ELSEIF (IICH(IJPROJ).EQ.-1) THEN | |
18857 | EPNI = EPNI+ETACOU(2) | |
18858 | ENDIF | |
18859 | IF ((IJPROJ.EQ.1).OR.(IJPROJ.EQ.8)) THEN | |
18860 | * Effective target potential | |
18861 | *sr 6.6. binding energy only (to avoid negative exc. energies) | |
18862 | C EPNI = EPNI+EPOT(2,IJPROJ) | |
18863 | EBIPOT = EBINDP(2) | |
18864 | IF ((IJPROJ.NE.1).AND.(ABS(EPOT(2,IJPROJ)).GT.5.0D-3)) | |
18865 | & EBIPOT = EBINDN(2) | |
18866 | EPNI = EPNI+ABS(EBIPOT) | |
18867 | * re-initialization of DTLTRA | |
18868 | DUM1 = ZERO | |
18869 | DUM2 = ZERO | |
18870 | CALL DT_LTINI(IJPROJ,IJTARG,EPNI,DUM1,DUM2,0) | |
18871 | ENDIF | |
18872 | ENDIF | |
18873 | ||
18874 | * projectile in n-n cms | |
18875 | IF ((IP.LE.1).AND.(IT.GT.1)) THEN | |
18876 | PMASS1 = AAM(IJPROJ) | |
18877 | C* VDM assumption | |
18878 | C IF (IJPROJ.EQ.7) PMASS1 = AAM(33) | |
18879 | IF (IJPROJ.EQ.7) PMASS1 = AAM(IJPROJ)-SQRT(VIRT) | |
18880 | PMASS2 = AAM(1) | |
18881 | PM1 = SIGN(PMASS1**2,PMASS1) | |
18882 | PM2 = SIGN(PMASS2**2,PMASS2) | |
18883 | PINIPR(4) = (UMO**2-PM2+PM1)/(TWO*UMO) | |
18884 | PINIPR(5) = PMASS1 | |
18885 | IF (PMASS1.GT.ZERO) THEN | |
18886 | PINIPR(3) = SQRT((PINIPR(4)-PINIPR(5)) | |
18887 | & *(PINIPR(4)+PINIPR(5))) | |
18888 | ELSE | |
18889 | PINIPR(3) = SQRT(PINIPR(4)**2-PM1) | |
18890 | ENDIF | |
18891 | AIT = DBLE(IT) | |
18892 | AITZ = DBLE(ITZ) | |
18893 | ||
18894 | C PINITA(5) = AIT*AMUAMU+1.0D-3*ENERGY(AIT,AITZ) | |
18895 | PINITA(5) = AIT*AMUC12+EMVGEV*EXMSAZ(AIT,AITZ,.TRUE.,IZDUM) | |
18896 | ||
18897 | CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3) | |
18898 | ELSEIF ((IP.GT.1).AND.(IT.LE.1)) THEN | |
18899 | PMASS1 = AAM(1) | |
18900 | PMASS2 = AAM(IJTARG) | |
18901 | PM1 = SIGN(PMASS1**2,PMASS1) | |
18902 | PM2 = SIGN(PMASS2**2,PMASS2) | |
18903 | PINITA(4) = (UMO**2-PM1+PM2)/(TWO*UMO) | |
18904 | PINITA(5) = PMASS2 | |
18905 | PINITA(3) = -SQRT((PINITA(4)-PINITA(5)) | |
18906 | & *(PINITA(4)+PINITA(5))) | |
18907 | AIP = DBLE(IP) | |
18908 | AIPZ = DBLE(IPZ) | |
18909 | ||
18910 | C PINIPR(5) = AIP*AMUAMU+1.0D-3*ENERGY(AIP,AIPZ) | |
18911 | PINIPR(5) = AIP*AMUC12+EMVGEV*EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM) | |
18912 | ||
18913 | CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2) | |
18914 | ELSEIF ((IP.GT.1).AND.(IT.GT.1)) THEN | |
18915 | AIP = DBLE(IP) | |
18916 | AIPZ = DBLE(IPZ) | |
18917 | ||
18918 | C PINIPR(5) = AIP*AMUAMU+1.0D-3*ENERGY(AIP,AIPZ) | |
18919 | PINIPR(5) = AIP*AMUC12+EMVGEV*EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM) | |
18920 | ||
18921 | CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2) | |
18922 | AIT = DBLE(IT) | |
18923 | AITZ = DBLE(ITZ) | |
18924 | ||
18925 | C PINITA(5) = AIT*AMUAMU+1.0D-3*ENERGY(AIT,AITZ) | |
18926 | PINITA(5) = AIT*AMUC12+EMVGEV*EXMSAZ(AIT,AITZ,.TRUE.,IZDUM) | |
18927 | ||
18928 | CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3) | |
18929 | ENDIF | |
18930 | ||
18931 | RETURN | |
18932 | ||
18933 | *------- treatment of final state | |
18934 | 2 CONTINUE | |
18935 | ||
18936 | NLOOP = NLOOP+1 | |
18937 | IF (NLOOP.GT.1) SCPOT = 0.10D0 | |
18938 | C WRITE(LOUT,*) 'event ',NEVHKK,NLOOP,SCPOT | |
18939 | ||
18940 | JPW = NPW | |
18941 | JPCW = NPCW | |
18942 | JTW = NTW | |
18943 | JTCW = NTCW | |
18944 | DO 40 K=1,4 | |
18945 | PFSP(K) = ZERO | |
18946 | 40 CONTINUE | |
18947 | ||
18948 | NOB = 0 | |
18949 | NOM = 0 | |
18950 | DO 900 I=NPOINT(4),NHKK | |
18951 | IDXOTH(I) = -1 | |
18952 | IF (ISTHKK(I).EQ.1) THEN | |
18953 | IF (IDBAM(I).EQ.7) GOTO 900 | |
18954 | IPOT = 0 | |
18955 | IOTHER = 0 | |
18956 | * particle moving into forward direction | |
18957 | IF (PHKK(3,I).GE.ZERO) THEN | |
18958 | * most likely to be effected by projectile potential | |
18959 | IPOT = 1 | |
18960 | * there is no projectile nucleus, try target | |
18961 | IF ((IP.LE.1).OR.((IP-NPW).LE.1)) THEN | |
18962 | IPOT = 2 | |
18963 | IF (IP.GT.1) IOTHER = 1 | |
18964 | * there is no target nucleus --> skip | |
18965 | IF ((IT.LE.1).OR.((IT-NTW).LE.1)) GOTO 900 | |
18966 | ENDIF | |
18967 | * particle moving into backward direction | |
18968 | ELSE | |
18969 | * most likely to be effected by target potential | |
18970 | IPOT = 2 | |
18971 | * there is no target nucleus, try projectile | |
18972 | IF ((IT.LE.1).OR.((IT-NTW).LE.1)) THEN | |
18973 | IPOT = 1 | |
18974 | IF (IT.GT.1) IOTHER = 1 | |
18975 | * there is no projectile nucleus --> skip | |
18976 | IF ((IP.LE.1).OR.((IP-NPW).LE.1)) GOTO 900 | |
18977 | ENDIF | |
18978 | ENDIF | |
18979 | IFLG = -IPOT | |
18980 | * nobam=3: particle is in overlap-region or neither inside proj. nor target | |
18981 | * =1: particle is not in overlap-region AND is inside target (2) | |
18982 | * =2: particle is not in overlap-region AND is inside projectile (1) | |
18983 | * flag particles which are inside the nucleus ipot but not in its | |
18984 | * overlap region | |
18985 | IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) IFLG = IPOT | |
18986 | IF (IDBAM(I).NE.0) THEN | |
18987 | * baryons: keep all nucleons and all others where flag is set | |
18988 | IF (IIBAR(IDBAM(I)).NE.0) THEN | |
18989 | IF ((IDBAM(I).EQ.1).OR.(IDBAM(I).EQ.8).OR.(IFLG.GT.0)) | |
18990 | & THEN | |
18991 | NOB = NOB+1 | |
18992 | PMOMB(NOB) = PHKK(3,I) | |
18993 | IDXB(NOB) = SIGN(10000000*IABS(IFLG) | |
18994 | & +1000000*IOTHER+I,IFLG) | |
18995 | ENDIF | |
18996 | * mesons: keep only those mesons where flag is set | |
18997 | ELSE | |
18998 | IF (IFLG.GT.0) THEN | |
18999 | NOM = NOM+1 | |
19000 | PMOMM(NOM) = PHKK(3,I) | |
19001 | IDXM(NOM) = 10000000*IFLG+1000000*IOTHER+I | |
19002 | ENDIF | |
19003 | ENDIF | |
19004 | ENDIF | |
19005 | ENDIF | |
19006 | 900 CONTINUE | |
19007 | * | |
19008 | * sort particles in the arrays according to increasing long. momentum | |
19009 | CALL DT_SORT1(PMOMB,IDXB,NOB,1,NOB,1) | |
19010 | CALL DT_SORT1(PMOMM,IDXM,NOM,1,NOM,1) | |
19011 | * | |
19012 | * shuffle indices into one and the same array according to the later | |
19013 | * sequence of correction | |
19014 | NCOR = 0 | |
19015 | IF (IT.GT.1) THEN | |
19016 | DO 910 I=1,NOB | |
19017 | IF (PMOMB(I).GT.ZERO) GOTO 911 | |
19018 | NCOR = NCOR+1 | |
19019 | IDXCOR(NCOR) = IDXB(I) | |
19020 | 910 CONTINUE | |
19021 | 911 CONTINUE | |
19022 | IF (IP.GT.1) THEN | |
19023 | DO 912 J=1,NOB | |
19024 | I = NOB+1-J | |
19025 | IF (PMOMB(I).LT.ZERO) GOTO 913 | |
19026 | NCOR = NCOR+1 | |
19027 | IDXCOR(NCOR) = IDXB(I) | |
19028 | 912 CONTINUE | |
19029 | 913 CONTINUE | |
19030 | ELSE | |
19031 | DO 914 I=1,NOB | |
19032 | IF (PMOMB(I).GT.ZERO) THEN | |
19033 | NCOR = NCOR+1 | |
19034 | IDXCOR(NCOR) = IDXB(I) | |
19035 | ENDIF | |
19036 | 914 CONTINUE | |
19037 | ENDIF | |
19038 | ELSE | |
19039 | DO 915 J=1,NOB | |
19040 | I = NOB+1-J | |
19041 | NCOR = NCOR+1 | |
19042 | IDXCOR(NCOR) = IDXB(I) | |
19043 | 915 CONTINUE | |
19044 | ENDIF | |
19045 | DO 925 I=1,NOM | |
19046 | IF (PMOMM(I).GT.ZERO) GOTO 926 | |
19047 | NCOR = NCOR+1 | |
19048 | IDXCOR(NCOR) = IDXM(I) | |
19049 | 925 CONTINUE | |
19050 | 926 CONTINUE | |
19051 | DO 927 J=1,NOM | |
19052 | I = NOM+1-J | |
19053 | IF (PMOMM(I).LT.ZERO) GOTO 928 | |
19054 | NCOR = NCOR+1 | |
19055 | IDXCOR(NCOR) = IDXM(I) | |
19056 | 927 CONTINUE | |
19057 | 928 CONTINUE | |
19058 | * | |
19059 | C IF (NEVHKK.EQ.484) THEN | |
19060 | C WRITE(LOUT,9000) JPCW,JPW-JPCW,JTCW,JTW-JTCW | |
19061 | C 9000 FORMAT(1X,'wounded nucleons (proj.-p,n targ.-p,n)',/,4I10) | |
19062 | C WRITE(LOUT,9001) NOB,NOM,NCOR | |
19063 | C 9001 FORMAT(1X,'produced particles (baryons,mesons,all)',3I10) | |
19064 | C WRITE(LOUT,'(/,A)') ' baryons ' | |
19065 | C DO 950 I=1,NOB | |
19066 | CC J = IABS(IDXB(I)) | |
19067 | CC INDEX = J-IABS(J/10000000)*10000000 | |
19068 | C IPOT = IABS(IDXB(I))/10000000 | |
19069 | C IOTHER = IABS(IDXB(I))/1000000-IPOT*10 | |
19070 | C INDEX = IABS(IDXB(I))-IPOT*10000000-IOTHER*1000000 | |
19071 | C WRITE(LOUT,9002) I,INDEX,IDXB(I),IDBAM(INDEX),PMOMB(I) | |
19072 | C 950 CONTINUE | |
19073 | C WRITE(LOUT,'(/,A)') ' mesons ' | |
19074 | C DO 951 I=1,NOM | |
19075 | CC INDEX = IDXM(I)-IABS(IDXM(I)/10000000)*10000000 | |
19076 | C IPOT = IABS(IDXM(I))/10000000 | |
19077 | C IOTHER = IABS(IDXM(I))/1000000-IPOT*10 | |
19078 | C INDEX = IABS(IDXM(I))-IPOT*10000000-IOTHER*1000000 | |
19079 | C WRITE(LOUT,9002) I,INDEX,IDXM(I),IDBAM(INDEX),PMOMM(I) | |
19080 | C 951 CONTINUE | |
19081 | C 9002 FORMAT(1X,4I14,E14.5) | |
19082 | C WRITE(LOUT,'(/,A)') ' all ' | |
19083 | C DO 952 I=1,NCOR | |
19084 | CC J = IABS(IDXCOR(I)) | |
19085 | CC INDEX = J-IABS(J/10000000)*10000000 | |
19086 | CC IPOT = IABS(IDXCOR(I))/10000000 | |
19087 | C IOTHER = IABS(IDXCOR(I))/1000000-IPOT*10 | |
19088 | C INDEX = IABS(IDXCOR(I))-IPOT*10000000-IOTHER*1000000 | |
19089 | C WRITE(LOUT,9003) I,INDEX,IDXCOR(I),IDBAM(INDEX) | |
19090 | C 952 CONTINUE | |
19091 | C 9003 FORMAT(1X,4I14) | |
19092 | C ENDIF | |
19093 | * | |
19094 | DO 20 ICOR=1,NCOR | |
19095 | IPOT = IABS(IDXCOR(ICOR))/10000000 | |
19096 | IOTHER = IABS(IDXCOR(ICOR))/1000000-IPOT*10 | |
19097 | I = IABS(IDXCOR(ICOR))-IPOT*10000000-IOTHER*1000000 | |
19098 | IDXOTH(I) = 1 | |
19099 | ||
19100 | IDSEC = IDBAM(I) | |
19101 | ||
19102 | * reduction of particle momentum by corresponding nuclear potential | |
19103 | * (this applies only if Fermi-momenta are requested) | |
19104 | ||
19105 | IF (LFERMI) THEN | |
19106 | ||
19107 | * Lorentz-transformation into the rest system of the selected nucleus | |
19108 | IMODE = -IPOT-1 | |
19109 | CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I), | |
19110 | & PSEC(1),PSEC(2),PSEC(3),PSEC(4),IDSEC,IMODE) | |
19111 | PSECO = SQRT(PSEC(1)**2+PSEC(2)**2+PSEC(3)**2) | |
19112 | AMSEC = SQRT(ABS((PSEC(4)-PSECO)*(PSEC(4)+PSECO))) | |
19113 | JPMOD = 0 | |
19114 | ||
19115 | CHKLEV = TINY3 | |
19116 | IF ((EPROJ.GE.1.0D4).AND.(IDSEC.EQ.7)) CHKLEV = TINY1 | |
19117 | IF (EPROJ.GE.2.0D6) CHKLEV = 1.0D0 | |
19118 | IF (ABS(AMSEC-AAM(IDSEC)).GT.CHKLEV) THEN | |
19119 | IF (IOULEV(3).GT.0) | |
19120 | & WRITE(LOUT,2000) I,NEVHKK,IDSEC,AMSEC,AAM(IDSEC) | |
19121 | 2000 FORMAT(1X,'RESNCL: inconsistent mass of particle', | |
19122 | & ' at entry ',I5,' (evt.',I8,')',/,' IDSEC: ', | |
19123 | & I4,' AMSEC: ',E12.3,' AAM(IDSEC): ',E12.3,/) | |
19124 | GOTO 23 | |
19125 | ENDIF | |
19126 | ||
19127 | DO 21 K=1,4 | |
19128 | PSEC0(K) = PSEC(K) | |
19129 | 21 CONTINUE | |
19130 | ||
19131 | * the correction for nuclear potential effects is applied to as many | |
19132 | * p/n as many nucleons were wounded; the momenta of other final state | |
19133 | * particles are corrected only if they materialize inside the corresp. | |
19134 | * nucleus (here: NOBAM = 1 part. outside proj., = 2 part. outside targ | |
19135 | * = 3 part. outside proj. and targ., >=10 in overlapping region) | |
19136 | IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) THEN | |
19137 | IF (IPOT.EQ.1) THEN | |
19138 | IF ((JPW.GT.0).AND.(IOTHER.EQ.0)) THEN | |
19139 | * this is most likely a wounded nucleon | |
19140 | **test | |
19141 | C RDIST = SQRT((VHKK(1,IPW(JPW))/FM2MM)**2 | |
19142 | C & +(VHKK(2,IPW(JPW))/FM2MM)**2 | |
19143 | C & +(VHKK(3,IPW(JPW))/FM2MM)**2) | |
19144 | C RAD = RNUCLE*DBLE(IP)**ONETHI | |
19145 | C FDEN = 1.4D0*DT_DENSIT(IP,RDIST,RAD) | |
19146 | C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC) | |
19147 | ** | |
19148 | PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC) | |
19149 | JPW = JPW-1 | |
19150 | JPMOD = 1 | |
19151 | ELSE | |
19152 | * correct only if part. was materialized inside nucleus | |
19153 | * and if it is ouside the overlapping region | |
19154 | IF ((NOBAM(I).NE.1).AND.(NOBAM(I).LT.3)) THEN | |
19155 | PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC) | |
19156 | JPMOD = 1 | |
19157 | ENDIF | |
19158 | ENDIF | |
19159 | ELSEIF (IPOT.EQ.2) THEN | |
19160 | IF ((JTW.GT.0).AND.(IOTHER.EQ.0)) THEN | |
19161 | * this is most likely a wounded nucleon | |
19162 | **test | |
19163 | C RDIST = SQRT((VHKK(1,ITW(JTW))/FM2MM)**2 | |
19164 | C & +(VHKK(2,ITW(JTW))/FM2MM)**2 | |
19165 | C & +(VHKK(3,ITW(JTW))/FM2MM)**2) | |
19166 | C RAD = RNUCLE*DBLE(IT)**ONETHI | |
19167 | C FDEN = 1.4D0*DT_DENSIT(IT,RDIST,RAD) | |
19168 | C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC) | |
19169 | ** | |
19170 | PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC) | |
19171 | JTW = JTW-1 | |
19172 | JPMOD = 1 | |
19173 | ELSE | |
19174 | * correct only if part. was materialized inside nucleus | |
19175 | IF ((NOBAM(I).NE.2).AND.(NOBAM(I).LT.3)) THEN | |
19176 | PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC) | |
19177 | JPMOD = 1 | |
19178 | ENDIF | |
19179 | ENDIF | |
19180 | ENDIF | |
19181 | ELSE | |
19182 | IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) THEN | |
19183 | PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC) | |
19184 | JPMOD = 1 | |
19185 | ENDIF | |
19186 | ENDIF | |
19187 | ||
19188 | IF (NLOOP.EQ.1) THEN | |
19189 | * Coulomb energy correction: | |
19190 | * the treatment of Coulomb potential correction is similar to the | |
19191 | * one for nuclear potential | |
19192 | IF (IDSEC.EQ.1) THEN | |
19193 | IF ((IPOT.EQ.1).AND.(JPCW.GT.0)) THEN | |
19194 | JPCW = JPCW-1 | |
19195 | ELSEIF ((IPOT.EQ.2).AND.(JTCW.GT.0)) THEN | |
19196 | JTCW = JTCW-1 | |
19197 | ELSE | |
19198 | IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25 | |
19199 | ENDIF | |
19200 | ELSE | |
19201 | IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25 | |
19202 | ENDIF | |
19203 | IF (IICH(IDSEC).EQ.1) THEN | |
19204 | * pos. particles: check if they are able to escape Coulomb potential | |
19205 | IF (PSEC(4).LT.AMSEC+ETACOU(IPOT)) THEN | |
19206 | ISTHKK(I) = 14+IPOT | |
19207 | IF (ISTHKK(I).EQ.15) THEN | |
19208 | DO 26 K=1,4 | |
19209 | PHKK(K,I) = PSEC0(K) | |
19210 | TRCLPR(K) = TRCLPR(K)+PSEC0(K) | |
19211 | 26 CONTINUE | |
19212 | IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1 | |
19213 | IF (IDSEC.EQ.1) NPCW = NPCW-1 | |
19214 | ELSEIF (ISTHKK(I).EQ.16) THEN | |
19215 | DO 27 K=1,4 | |
19216 | PHKK(K,I) = PSEC0(K) | |
19217 | TRCLTA(K) = TRCLTA(K)+PSEC0(K) | |
19218 | 27 CONTINUE | |
19219 | IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1 | |
19220 | IF (IDSEC.EQ.1) NTCW = NTCW-1 | |
19221 | ENDIF | |
19222 | GOTO 20 | |
19223 | ENDIF | |
19224 | ELSEIF (IICH(IDSEC).EQ.-1) THEN | |
19225 | * neg. particles: decrease energy by Coulomb-potential | |
19226 | PSEC(4) = PSEC(4)-ETACOU(IPOT) | |
19227 | JPMOD = 1 | |
19228 | ENDIF | |
19229 | ENDIF | |
19230 | ||
19231 | 25 CONTINUE | |
19232 | ||
19233 | IF (PSEC(4).LT.AMSEC) THEN | |
19234 | IF (IOULEV(6).GT.0) | |
19235 | & WRITE(LOUT,2001) I,IDSEC,PSEC(4),AMSEC | |
19236 | 2001 FORMAT(1X,'KKINC: particle at DTEVT1-pos. ',I5, | |
19237 | & ' is not allowed to escape nucleus',/, | |
19238 | & 8X,'id : ',I3,' reduced energy: ',E15.4, | |
19239 | & ' mass: ',E12.3) | |
19240 | ISTHKK(I) = 14+IPOT | |
19241 | IF (ISTHKK(I).EQ.15) THEN | |
19242 | DO 28 K=1,4 | |
19243 | PHKK(K,I) = PSEC0(K) | |
19244 | TRCLPR(K) = TRCLPR(K)+PSEC0(K) | |
19245 | 28 CONTINUE | |
19246 | IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1 | |
19247 | IF (IDSEC.EQ.1) NPCW = NPCW-1 | |
19248 | ELSEIF (ISTHKK(I).EQ.16) THEN | |
19249 | DO 29 K=1,4 | |
19250 | PHKK(K,I) = PSEC0(K) | |
19251 | TRCLTA(K) = TRCLTA(K)+PSEC0(K) | |
19252 | 29 CONTINUE | |
19253 | IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1 | |
19254 | IF (IDSEC.EQ.1) NTCW = NTCW-1 | |
19255 | ENDIF | |
19256 | GOTO 20 | |
19257 | ENDIF | |
19258 | ||
19259 | IF (JPMOD.EQ.1) THEN | |
19260 | PSECN = SQRT( (PSEC(4)-AMSEC)*(PSEC(4)+AMSEC) ) | |
19261 | * 4-momentum after correction for nuclear potential | |
19262 | DO 22 K=1,3 | |
19263 | PSEC(K) = PSEC(K)*PSECN/PSECO | |
19264 | 22 CONTINUE | |
19265 | ||
19266 | * store recoil momentum from particles escaping the nuclear potentials | |
19267 | DO 30 K=1,4 | |
19268 | IF (IPOT.EQ.1) THEN | |
19269 | TRCLPR(K) = TRCLPR(K)+PSEC0(K)-PSEC(K) | |
19270 | ELSEIF (IPOT.EQ.2) THEN | |
19271 | TRCLTA(K) = TRCLTA(K)+PSEC0(K)-PSEC(K) | |
19272 | ENDIF | |
19273 | 30 CONTINUE | |
19274 | ||
19275 | * transform momentum back into n-n cms | |
19276 | IMODE = IPOT+1 | |
19277 | CALL DT_LTRANS(PSEC(1),PSEC(2),PSEC(3),PSEC(4), | |
19278 | & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I), | |
19279 | & IDSEC,IMODE) | |
19280 | ENDIF | |
19281 | ||
19282 | ENDIF | |
19283 | ||
19284 | 23 CONTINUE | |
19285 | DO 31 K=1,4 | |
19286 | PFSP(K) = PFSP(K)+PHKK(K,I) | |
19287 | 31 CONTINUE | |
19288 | ||
19289 | 20 CONTINUE | |
19290 | ||
19291 | DO 33 I=NPOINT(4),NHKK | |
19292 | IF ((ISTHKK(I).EQ.1).AND.(IDXOTH(I).LT.0)) THEN | |
19293 | PFSP(1) = PFSP(1)+PHKK(1,I) | |
19294 | PFSP(2) = PFSP(2)+PHKK(2,I) | |
19295 | PFSP(3) = PFSP(3)+PHKK(3,I) | |
19296 | PFSP(4) = PFSP(4)+PHKK(4,I) | |
19297 | ENDIF | |
19298 | 33 CONTINUE | |
19299 | ||
19300 | DO 34 K=1,5 | |
19301 | PRCLPR(K) = TRCLPR(K) | |
19302 | PRCLTA(K) = TRCLTA(K) | |
19303 | 34 CONTINUE | |
19304 | ||
19305 | IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN | |
19306 | * hadron-nucleus interactions: get residual momentum from energy- | |
19307 | * momentum conservation | |
19308 | DO 32 K=1,4 | |
19309 | PRCLPR(K) = ZERO | |
19310 | PRCLTA(K) = PINIPR(K)+PINITA(K)-PFSP(K) | |
19311 | 32 CONTINUE | |
19312 | ELSE | |
19313 | * nucleus-hadron, nucleus-nucleus: get residual momentum from | |
19314 | * accumulated recoil momenta of particles leaving the spectators | |
19315 | * transform accumulated recoil momenta of residual nuclei into | |
19316 | * n-n cms | |
19317 | PZI = PRCLPR(3) | |
19318 | PEI = PRCLPR(4) | |
19319 | CALL DT_LTNUC(PZI,PEI,PRCLPR(3),PRCLPR(4),2) | |
19320 | PZI = PRCLTA(3) | |
19321 | PEI = PRCLTA(4) | |
19322 | CALL DT_LTNUC(PZI,PEI,PRCLTA(3),PRCLTA(4),3) | |
19323 | C IF (IP.GT.1) THEN | |
19324 | PRCLPR(3) = PRCLPR(3)+PINIPR(3) | |
19325 | PRCLPR(4) = PRCLPR(4)+PINIPR(4) | |
19326 | C ENDIF | |
19327 | IF (IT.GT.1) THEN | |
19328 | PRCLTA(3) = PRCLTA(3)+PINITA(3) | |
19329 | PRCLTA(4) = PRCLTA(4)+PINITA(4) | |
19330 | ENDIF | |
19331 | ENDIF | |
19332 | ||
19333 | * check momenta of residual nuclei | |
19334 | IF (LEMCCK) THEN | |
19335 | CALL DT_EVTEMC(-PINIPR(1),-PINIPR(2),-PINIPR(3),-PINIPR(4), | |
19336 | & 1,IDUM,IDUM) | |
19337 | CALL DT_EVTEMC(-PINITA(1),-PINITA(2),-PINITA(3),-PINITA(4), | |
19338 | & 2,IDUM,IDUM) | |
19339 | CALL DT_EVTEMC(PRCLPR(1),PRCLPR(2),PRCLPR(3),PRCLPR(4), | |
19340 | & 2,IDUM,IDUM) | |
19341 | CALL DT_EVTEMC(PRCLTA(1),PRCLTA(2),PRCLTA(3),PRCLTA(4), | |
19342 | & 2,IDUM,IDUM) | |
19343 | CALL DT_EVTEMC(PFSP(1),PFSP(2),PFSP(3),PFSP(4),2,IDUM,IDUM) | |
19344 | **sr 19.12. changed to avoid output when used with phojet | |
19345 | C CHKLEV = TINY3 | |
19346 | CHKLEV = TINY1 | |
19347 | CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,501,IREJ1) | |
19348 | C IF ((NEVHKK.EQ.409).OR.(NEVHKK.EQ.460).OR.(NEVHKK.EQ.765)) | |
19349 | C & CALL DT_EVTOUT(4) | |
19350 | IF (IREJ1.GT.0) RETURN | |
19351 | ENDIF | |
19352 | ||
19353 | RETURN | |
19354 | END | |
19355 | ||
19356 | *$ CREATE DT_SCN4BA.FOR | |
19357 | *COPY DT_SCN4BA | |
19358 | * | |
19359 | *===scn4ba=============================================================* | |
19360 | * | |
19361 | SUBROUTINE DT_SCN4BA | |
19362 | ||
19363 | ************************************************************************ | |
19364 | * SCan /DTEVT1/ 4 BAryons which are not able to escape nuclear pot. * | |
19365 | * This version dated 12.12.95 is written by S. Roesler. * | |
19366 | ************************************************************************ | |
19367 | ||
19368 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
19369 | SAVE | |
19370 | ||
19371 | PARAMETER ( LINP = 10 , | |
19372 | & LOUT = 6 , | |
19373 | & LDAT = 9 ) | |
19374 | ||
19375 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2, | |
19376 | & TINY10=1.0D-10) | |
19377 | ||
19378 | * event history | |
19379 | ||
19380 | PARAMETER (NMXHKK=200000) | |
19381 | ||
19382 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
19383 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
19384 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
19385 | ||
19386 | * extended event history | |
19387 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
19388 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
19389 | & IHIST(2,NMXHKK) | |
19390 | ||
19391 | * particle properties (BAMJET index convention) | |
19392 | CHARACTER*8 ANAME | |
19393 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
19394 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
19395 | ||
19396 | * properties of interacting particles | |
19397 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
19398 | ||
19399 | * nuclear potential | |
19400 | LOGICAL LFERMI | |
19401 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, | |
19402 | & EBINDP(2),EBINDN(2),EPOT(2,210), | |
19403 | & ETACOU(2),ICOUL,LFERMI | |
19404 | ||
19405 | * treatment of residual nuclei: wounded nucleons | |
19406 | COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210) | |
19407 | ||
19408 | * treatment of residual nuclei: 4-momenta | |
19409 | LOGICAL LRCLPR,LRCLTA | |
19410 | COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5), | |
19411 | & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA | |
19412 | ||
19413 | DIMENSION PLAB(2,5),PCMS(4) | |
19414 | ||
19415 | IREJ = 0 | |
19416 | ||
19417 | * get number of wounded nucleons | |
19418 | NPW = 0 | |
19419 | NPW0 = 0 | |
19420 | NPCW = 0 | |
19421 | NPSTCK = 0 | |
19422 | NTW = 0 | |
19423 | NTW0 = 0 | |
19424 | NTCW = 0 | |
19425 | NTSTCK = 0 | |
19426 | ||
19427 | ISGLPR = 0 | |
19428 | ISGLTA = 0 | |
19429 | LRCLPR = .FALSE. | |
19430 | LRCLTA = .FALSE. | |
19431 | ||
19432 | C DO 2 I=1,NHKK | |
19433 | DO 2 I=1,NPOINT(1) | |
19434 | * projectile nucleons wounded in primary interaction and in fzc | |
19435 | IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.17)) THEN | |
19436 | NPW = NPW+1 | |
19437 | IPW(NPW) = I | |
19438 | NPSTCK = NPSTCK+1 | |
19439 | IF (IDHKK(I).EQ.2212) NPCW = NPCW+1 | |
19440 | IF (ISTHKK(I).EQ.11) NPW0 = NPW0+1 | |
19441 | C IF (IP.GT.1) THEN | |
19442 | DO 5 K=1,4 | |
19443 | TRCLPR(K) = TRCLPR(K)-PHKK(K,I) | |
19444 | 5 CONTINUE | |
19445 | C ENDIF | |
19446 | * target nucleons wounded in primary interaction and in fzc | |
19447 | ELSEIF ((ISTHKK(I).EQ.12).OR.(ISTHKK(I).EQ.18)) THEN | |
19448 | NTW = NTW+1 | |
19449 | ITW(NTW) = I | |
19450 | NTSTCK = NTSTCK+1 | |
19451 | IF (IDHKK(I).EQ.2212) NTCW = NTCW+1 | |
19452 | IF (ISTHKK(I).EQ.12) NTW0 = NTW0+1 | |
19453 | IF (IT.GT.1) THEN | |
19454 | DO 6 K=1,4 | |
19455 | TRCLTA(K) = TRCLTA(K)-PHKK(K,I) | |
19456 | 6 CONTINUE | |
19457 | ENDIF | |
19458 | ELSEIF (ISTHKK(I).EQ.13) THEN | |
19459 | ISGLPR = I | |
19460 | ELSEIF (ISTHKK(I).EQ.14) THEN | |
19461 | ISGLTA = I | |
19462 | ENDIF | |
19463 | 2 CONTINUE | |
19464 | ||
19465 | DO 11 I=NPOINT(4),NHKK | |
19466 | * baryons which are unable to escape the nuclear potential of proj. | |
19467 | IF (ISTHKK(I).EQ.15) THEN | |
19468 | ISGLPR = I | |
19469 | NPSTCK = NPSTCK-1 | |
19470 | IF (IIBAR(IDBAM(I)).NE.0) THEN | |
19471 | NPW = NPW-1 | |
19472 | IF (IICH(IDBAM(I)).GT.0) NPCW = NPCW-1 | |
19473 | ENDIF | |
19474 | DO 7 K=1,4 | |
19475 | TRCLPR(K) = TRCLPR(K)+PHKK(K,I) | |
19476 | 7 CONTINUE | |
19477 | * baryons which are unable to escape the nuclear potential of targ. | |
19478 | ELSEIF (ISTHKK(I).EQ.16) THEN | |
19479 | ISGLTA = I | |
19480 | NTSTCK = NTSTCK-1 | |
19481 | IF (IIBAR(IDBAM(I)).NE.0) THEN | |
19482 | NTW = NTW-1 | |
19483 | IF (IICH(IDBAM(I)).GT.0) NTCW = NTCW-1 | |
19484 | ENDIF | |
19485 | DO 8 K=1,4 | |
19486 | TRCLTA(K) = TRCLTA(K)+PHKK(K,I) | |
19487 | 8 CONTINUE | |
19488 | ENDIF | |
19489 | 11 CONTINUE | |
19490 | ||
19491 | * residual nuclei so far | |
19492 | IRESP = IP-NPSTCK | |
19493 | IREST = IT-NTSTCK | |
19494 | ||
19495 | * ckeck for "residual nuclei" consisting of one nucleon only | |
19496 | * treat it as final state particle | |
19497 | IF (IRESP.EQ.1) THEN | |
19498 | ID = IDBAM(ISGLPR) | |
19499 | IST = ISTHKK(ISGLPR) | |
19500 | CALL DT_LTRANS(PHKK(1,ISGLPR),PHKK(2,ISGLPR), | |
19501 | & PHKK(3,ISGLPR),PHKK(4,ISGLPR), | |
19502 | & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,2) | |
19503 | IF (IST.EQ.13) THEN | |
19504 | ISTHKK(ISGLPR) = 11 | |
19505 | ELSE | |
19506 | ISTHKK(ISGLPR) = 2 | |
19507 | ENDIF | |
19508 | CALL DT_EVTPUT(1,IDHKK(ISGLPR),ISGLPR,0, | |
19509 | & PCMS(1),PCMS(2),PCMS(3),PCMS(4), | |
19510 | & IDRES(ISGLPR),IDXRES(ISGLPR),IDCH(ISGLPR)) | |
19511 | NOBAM(NHKK) = NOBAM(ISGLPR) | |
19512 | JDAHKK(1,ISGLPR) = NHKK | |
19513 | DO 21 K=1,4 | |
19514 | TRCLPR(K) = TRCLPR(K)-PHKK(K,ISGLPR) | |
19515 | 21 CONTINUE | |
19516 | ENDIF | |
19517 | IF (IREST.EQ.1) THEN | |
19518 | ID = IDBAM(ISGLTA) | |
19519 | IST = ISTHKK(ISGLTA) | |
19520 | CALL DT_LTRANS(PHKK(1,ISGLTA),PHKK(2,ISGLTA), | |
19521 | & PHKK(3,ISGLTA),PHKK(4,ISGLTA), | |
19522 | & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,3) | |
19523 | IF (IST.EQ.14) THEN | |
19524 | ISTHKK(ISGLTA) = 12 | |
19525 | ELSE | |
19526 | ISTHKK(ISGLTA) = 2 | |
19527 | ENDIF | |
19528 | CALL DT_EVTPUT(1,IDHKK(ISGLTA),ISGLTA,0, | |
19529 | & PCMS(1),PCMS(2),PCMS(3),PCMS(4), | |
19530 | & IDRES(ISGLTA),IDXRES(ISGLTA),IDCH(ISGLTA)) | |
19531 | NOBAM(NHKK) = NOBAM(ISGLTA) | |
19532 | JDAHKK(1,ISGLTA) = NHKK | |
19533 | DO 22 K=1,4 | |
19534 | TRCLTA(K) = TRCLTA(K)-PHKK(K,ISGLTA) | |
19535 | 22 CONTINUE | |
19536 | ENDIF | |
19537 | ||
19538 | * get nuclear potential corresp. to the residual nucleus | |
19539 | IPRCL = IP -NPW | |
19540 | IPZRCL = IPZ-NPCW | |
19541 | ITRCL = IT -NTW | |
19542 | ITZRCL = ITZ-NTCW | |
19543 | CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1) | |
19544 | ||
19545 | * baryons unable to escape the nuclear potential are treated as | |
19546 | * excited nucleons (ISTHKK=15,16) | |
19547 | DO 3 I=NPOINT(4),NHKK | |
19548 | IF (ISTHKK(I).EQ.1) THEN | |
19549 | ID = IDBAM(I) | |
19550 | IF ( ((ID.EQ.1).OR.(ID.EQ.8)).AND.(NOBAM(I).NE.3) ) THEN | |
19551 | * final state n and p not being outside of both nuclei are considered | |
19552 | NPOTP = 1 | |
19553 | NPOTT = 1 | |
19554 | IF ( (IP.GT.1) .AND.(IRESP.GT.1).AND. | |
19555 | & (NOBAM(I).NE.1).AND.(NPW.GT.0) ) THEN | |
19556 | * Lorentz-trsf. into proj. rest sys. for those being inside proj. | |
19557 | CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I), | |
19558 | & PHKK(4,I),PLAB(1,1),PLAB(1,2),PLAB(1,3), | |
19559 | & PLAB(1,4),ID,-2) | |
19560 | PLABT = SQRT(PLAB(1,1)**2+PLAB(1,2)**2+PLAB(1,3)**2) | |
19561 | PLAB(1,5) = SQRT(ABS( (PLAB(1,4)-PLABT)* | |
19562 | & (PLAB(1,4)+PLABT) )) | |
19563 | EKIN = PLAB(1,4)-PLAB(1,5) | |
19564 | IF (EKIN.LE.EPOT(1,ID)) NPOTP = 15 | |
19565 | IF ((ID.EQ.1).AND.(NPCW.LE.0)) NPOTP = 1 | |
19566 | ENDIF | |
19567 | IF ( (IT.GT.1) .AND.(IREST.GT.1).AND. | |
19568 | & (NOBAM(I).NE.2).AND.(NTW.GT.0) ) THEN | |
19569 | * Lorentz-trsf. into targ. rest sys. for those being inside targ. | |
19570 | CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I), | |
19571 | & PHKK(4,I),PLAB(2,1),PLAB(2,2),PLAB(2,3), | |
19572 | & PLAB(2,4),ID,-3) | |
19573 | PLABT = SQRT(PLAB(2,1)**2+PLAB(2,2)**2+PLAB(2,3)**2) | |
19574 | PLAB(2,5) = SQRT(ABS( (PLAB(2,4)-PLABT)* | |
19575 | & (PLAB(2,4)+PLABT) )) | |
19576 | EKIN = PLAB(2,4)-PLAB(2,5) | |
19577 | IF (EKIN.LE.EPOT(2,ID)) NPOTT = 16 | |
19578 | IF ((ID.EQ.1).AND.(NTCW.LE.0)) NPOTT = 1 | |
19579 | ENDIF | |
19580 | IF (PHKK(3,I).GE.ZERO) THEN | |
19581 | ISTHKK(I) = NPOTT | |
19582 | IF (NPOTP.NE.1) ISTHKK(I) = NPOTP | |
19583 | ELSE | |
19584 | ISTHKK(I) = NPOTP | |
19585 | IF (NPOTT.NE.1) ISTHKK(I) = NPOTT | |
19586 | ENDIF | |
19587 | IF (ISTHKK(I).NE.1) THEN | |
19588 | J = ISTHKK(I)-14 | |
19589 | DO 4 K=1,5 | |
19590 | PHKK(K,I) = PLAB(J,K) | |
19591 | 4 CONTINUE | |
19592 | IF (ISTHKK(I).EQ.15) THEN | |
19593 | NPW = NPW-1 | |
19594 | IF (ID.EQ.1) NPCW = NPCW-1 | |
19595 | DO 9 K=1,4 | |
19596 | TRCLPR(K) = TRCLPR(K)+PHKK(K,I) | |
19597 | 9 CONTINUE | |
19598 | ELSEIF (ISTHKK(I).EQ.16) THEN | |
19599 | NTW = NTW-1 | |
19600 | IF (ID.EQ.1) NTCW = NTCW-1 | |
19601 | DO 10 K=1,4 | |
19602 | TRCLTA(K) = TRCLTA(K)+PHKK(K,I) | |
19603 | 10 CONTINUE | |
19604 | ENDIF | |
19605 | ENDIF | |
19606 | ENDIF | |
19607 | ENDIF | |
19608 | 3 CONTINUE | |
19609 | ||
19610 | * again: get nuclear potential corresp. to the residual nucleus | |
19611 | IPRCL = IP -NPW | |
19612 | IPZRCL = IPZ-NPCW | |
19613 | ITRCL = IT -NTW | |
19614 | ITZRCL = ITZ-NTCW | |
19615 | c AFERP = 1.2D0*FERMOD*(ONE+(DBLE(IP+10-NPW0)/DBLE(IP+10))**1.1D0) | |
19616 | cC AFERP = 1.21D0*FERMOD*(ONE+(DBLE(IP+40-NPW0)/DBLE(IP+40))**1.1D0) | |
19617 | c & *(0.94D0+0.3D0*EXP(-DBLE(NPW0)/5.0D0)) /2.0D0 | |
19618 | C AFERP = 0.0D0 | |
19619 | c AFERT = 1.2D0*FERMOD*(ONE+(DBLE(IT+10-NTW0)/DBLE(IT+10))**1.1D0) | |
19620 | cC AFERT = 1.21D0*FERMOD*(ONE+(DBLE(IT+40-NTW0)/DBLE(IT+40))**1.1D0) | |
19621 | c & *(0.94D0+0.3D0*EXP(-DBLE(NTW0)/5.0D0)) /2.0D0 | |
19622 | C AFERT = 0.0D0 | |
19623 | C IF (AFERP.LT.FERMOD) AFERP = FERMOD+0.1 | |
19624 | C IF (AFERT.LT.FERMOD) AFERT = FERMOD+0.1 | |
19625 | C IF (AFERP.GT.0.85D0) AFERP = 0.85D0 | |
19626 | C IF (AFERT.GT.0.85D0) AFERT = 0.85D0 | |
19627 | AFERP = FERMOD+0.1D0 | |
19628 | AFERT = FERMOD+0.1D0 | |
19629 | ||
19630 | CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,AFERP,AFERT,1) | |
19631 | ||
19632 | RETURN | |
19633 | END | |
19634 | ||
19635 | *$ CREATE DT_FICONF.FOR | |
19636 | *COPY DT_FICONF | |
19637 | * | |
19638 | *===ficonf=============================================================* | |
19639 | * | |
19640 | SUBROUTINE DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ) | |
19641 | ||
19642 | ************************************************************************ | |
19643 | * Treatment of FInal CONFiguration including evaporation, fission and * | |
19644 | * Fermi-break-up (for light nuclei only). * | |
19645 | * Adopted from the original routine FINALE and extended to residual * | |
19646 | * projectile nuclei. * | |
19647 | * This version dated 12.12.95 is written by S. Roesler. * | |
19648 | * * | |
19649 | * Last change 27.12.2006 by S. Roesler. * | |
19650 | ************************************************************************ | |
19651 | ||
19652 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
19653 | SAVE | |
19654 | ||
19655 | PARAMETER ( LINP = 10 , | |
19656 | & LOUT = 6 , | |
19657 | & LDAT = 9 ) | |
19658 | ||
19659 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10) | |
19660 | PARAMETER (ANGLGB=5.0D-16) | |
19661 | ||
19662 | * event history | |
19663 | ||
19664 | PARAMETER (NMXHKK=200000) | |
19665 | ||
19666 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
19667 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
19668 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
19669 | ||
19670 | * extended event history | |
19671 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
19672 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
19673 | & IHIST(2,NMXHKK) | |
19674 | ||
19675 | * rejection counter | |
19676 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
19677 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
19678 | & IREXCI(3),IRDIFF(2),IRINC | |
19679 | ||
19680 | * central particle production, impact parameter biasing | |
19681 | COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR | |
19682 | ||
19683 | * particle properties (BAMJET index convention) | |
19684 | CHARACTER*8 ANAME | |
19685 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
19686 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
19687 | ||
19688 | * treatment of residual nuclei: 4-momenta | |
19689 | LOGICAL LRCLPR,LRCLTA | |
19690 | COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5), | |
19691 | & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA | |
19692 | ||
19693 | * treatment of residual nuclei: properties of residual nuclei | |
19694 | COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2), | |
19695 | & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2), | |
19696 | & NTOTFI(2),NPROFI(2) | |
19697 | ||
19698 | * statistics: residual nuclei | |
19699 | COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2), | |
19700 | & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2), | |
19701 | & NINCST(2,4),NINCEV(2), | |
19702 | & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2), | |
19703 | & NRESPB(2),NRESCH(2),NRESEV(4), | |
19704 | & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240), | |
19705 | & NEVAFI(2,2) | |
19706 | ||
19707 | * flags for input different options | |
19708 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
19709 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
19710 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
19711 | ||
19712 | * INCLUDE '(DIMPAR)' | |
19713 | * DIMPAR taken from FLUKA | |
19714 | PARAMETER ( MXXRGN =20000 ) | |
19715 | PARAMETER ( MXXMDF = 710 ) | |
19716 | PARAMETER ( MXXMDE = 702 ) | |
19717 | PARAMETER ( MFSTCK =40000 ) | |
19718 | PARAMETER ( MESTCK = 100 ) | |
19719 | PARAMETER ( MOSTCK = 2000 ) | |
19720 | PARAMETER ( MXPRSN = 100 ) | |
19721 | PARAMETER ( MXPDPM = 800 ) | |
19722 | PARAMETER ( MXPSCS =30000 ) | |
19723 | PARAMETER ( MXGLWN = 300 ) | |
19724 | PARAMETER ( MXOUTU = 50 ) | |
19725 | PARAMETER ( NALLWP = 64 ) | |
19726 | PARAMETER ( NELEMX = 80 ) | |
19727 | PARAMETER ( MPDPDX = 18 ) | |
19728 | PARAMETER ( MXHTTR = 260 ) | |
19729 | PARAMETER ( MXSEAX = 20 ) | |
19730 | PARAMETER ( MXHTNC = MXSEAX + 1 ) | |
19731 | PARAMETER ( ICOMAX = 2400 ) | |
19732 | PARAMETER ( ICHMAX = ICOMAX + MXXMDF ) | |
19733 | PARAMETER ( NSTBIS = 304 ) | |
19734 | PARAMETER ( NQSTIS = 46 ) | |
19735 | PARAMETER ( NTSTIS = NSTBIS + NQSTIS ) | |
19736 | PARAMETER ( MXPABL = 120 ) | |
19737 | PARAMETER ( IDMAXP = 450 ) | |
19738 | PARAMETER ( IDMXDC = 2000 ) | |
19739 | PARAMETER ( MXMCIN = 410 ) | |
19740 | PARAMETER ( IHYPMX = 4 ) | |
19741 | PARAMETER ( MKBMX1 = 11 ) | |
19742 | PARAMETER ( MKBMX2 = 11 ) | |
19743 | PARAMETER ( MXIRRD = 2500 ) | |
19744 | PARAMETER ( MXTRDC = 1500 ) | |
19745 | PARAMETER ( NKTL = 17 ) | |
19746 | PARAMETER ( NBLNMX = 40000000 ) | |
19747 | ||
19748 | * INCLUDE '(GENSTK)' | |
19749 | * GENSTK taken from FLUKA | |
19750 | COMMON / GENSTK / CXR (MXPSCS), CYR (MXPSCS), | |
19751 | & CZR (MXPSCS), CXRPOL (MXPSCS), CYRPOL (MXPSCS), | |
19752 | & CZRPOL (MXPSCS), TKI (MXPSCS), PLR (MXPSCS), | |
19753 | & WEI (MXPSCS), AGESEC (MXPSCS), TV , TVCMS , | |
19754 | & TVRECL, TVHEAV, TVBIND, | |
19755 | & KPART (MXPSCS), INFEXT (MXPSCS), NP0 , NP | |
19756 | ||
19757 | * INCLUDE '(RESNUC)' | |
19758 | * RESNUC from FLUKA | |
19759 | LOGICAL LRNFSS, LFRAGM | |
19760 | COMMON /RESNUC/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1, | |
19761 | & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT, | |
19762 | & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES, | |
19763 | & PYRES, PZRES, PTRES2, ANGRES, ANXRES, ANYRES, | |
19764 | & ANZRES, TVESTR, ANESTR, BHYRES (IHYPMX), | |
19765 | & KTARP, KTARN, IGREYP, IGREYN, IPDPM0, IPDPM1, | |
19766 | & IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE, ICRES, | |
19767 | & IBRES, ISTRES, ISMRES, IHYRES, IEVAPL, IEVAPH, | |
19768 | & IEVPHO, IEVNEU, IEVPRO, IEVDEU, IEVTRI, IEV3HE, | |
19769 | & IEV4HE, IDEEXG, IBTAR, ICHTAR, IBLEFT, ICLEFT, | |
19770 | & ICESTR, IBESTR, IOTHER, KHYRES (IHYPMX), | |
19771 | & LRNFSS, LFRAGM | |
19772 | ||
19773 | PARAMETER ( EMVGEV = 1.0 D-03 ) | |
19774 | PARAMETER ( AMUGEV = 0.93149432 D+00 ) | |
19775 | PARAMETER ( AMPRTN = 0.93827231 D+00 ) | |
19776 | PARAMETER ( AMNTRN = 0.93956563 D+00 ) | |
19777 | PARAMETER ( AMELCT = 0.51099906 D-03 ) | |
19778 | PARAMETER ( ELCCGS = 4.8032068 D-10 ) | |
19779 | PARAMETER ( ELCMKS = 1.60217733 D-19 ) | |
19780 | PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13 | |
19781 | & * 1.D-09 ) | |
19782 | PARAMETER ( HLFHLF = 0.5D+00 ) | |
19783 | PARAMETER ( FERTHO = 14.33 D-09 ) | |
19784 | PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 ) | |
19785 | PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 ) | |
19786 | PARAMETER ( AMUC12 = AMUGEV - AMUNMU ) | |
19787 | ||
19788 | * INCLUDE '(NUCDAT)' | |
19789 | * Taken from FLUKA | |
19790 | PARAMETER ( AMUAMU = AMUGEV ) | |
19791 | PARAMETER ( AMPROT = AMPRTN ) | |
19792 | PARAMETER ( AMNEUT = AMNTRN ) | |
19793 | PARAMETER ( AMELEC = AMELCT ) | |
19794 | PARAMETER ( R0NUCL = 1.12 D+00 ) | |
19795 | PARAMETER ( RCCOUL = 1.7 D+00 ) | |
19796 | PARAMETER ( COULPR = COUGFM ) | |
19797 | PARAMETER ( AMHYDR = AMPRTN + AMELCT ) | |
19798 | PARAMETER ( AMHTON = AMHYDR - AMNTRN ) | |
19799 | PARAMETER ( AMNTOU = AMNTRN - AMUC12 ) | |
19800 | PARAMETER ( AMUCSQ = AMUC12 * AMUC12 ) | |
19801 | PARAMETER ( EBNDAV = HLFHLF * (AMPRTN + AMNTRN) - AMUC12 ) | |
19802 | * Gammin : threshold for deexcitation gammas production, set to 1 keV | |
19803 | * (this means that up to 1 keV of energy unbalancing can occur | |
19804 | * during an event) | |
19805 | PARAMETER ( GAMMIN = 1.0D-06 ) | |
19806 | PARAMETER ( GAMNSQ = 2.0D+00 * GAMMIN * GAMMIN ) | |
19807 | * Tvepsi : "epsilon" for excitation energy, set to gammin / 100 | |
19808 | PARAMETER ( TVEPSI = GAMMIN / 100.D+00 ) | |
19809 | * | |
19810 | COMMON /NUCDAT/ AV0WEL, APFRMX, AEFRMX, AEFRMA, | |
19811 | & RDSNUC, V0WELL (2), PFRMMX (2), EFRMMX (2), | |
19812 | & EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2), | |
19813 | & VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2), | |
19814 | & PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2), | |
19815 | & EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2), | |
19816 | & ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV , | |
19817 | & AMRCSQ , ATO1O3 , ZTO1O3 , FRMRFC , | |
19818 | & ELBNDE (0:110) | |
19819 | ||
19820 | * INCLUDE '(PAREVT)' | |
19821 | * Taken from FLUKA | |
19822 | PARAMETER ( FRDIFF = 0.2D+00 ) | |
19823 | PARAMETER ( ETHSEA = 1.0D+00 ) | |
19824 | * | |
19825 | LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX, | |
19826 | & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI, | |
19827 | & LNUCRI, LPEANU, LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR, | |
19828 | & LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN | |
19829 | COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC, | |
19830 | & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY, | |
19831 | & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV, | |
19832 | & LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LPHDRC, | |
19833 | & LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR, LRVKIN, | |
19834 | & LVP2XX, LV2XNW, LNWV2X, LEVFIN | |
19835 | ||
19836 | * INCLUDE '(FHEAVY)' | |
19837 | * Taken from FLUKA | |
19838 | PARAMETER ( MXHEAV = 100 ) | |
19839 | PARAMETER ( KXHEAV = 30 ) | |
19840 | CHARACTER*8 ANHEAV | |
19841 | COMMON / FHEAVY / CXHEAV (MXHEAV), CYHEAV (MXHEAV), | |
19842 | & CZHEAV (MXHEAV), TKHEAV (MXHEAV), | |
19843 | & PHEAVY (MXHEAV), WHEAVY (MXHEAV), | |
19844 | & AGHEAV (MXHEAV), BHHEAV (IHYPMX,KXHEAV), | |
19845 | & AMHEAV (KXHEAV), AMNHEA (KXHEAV), | |
19846 | & KHEAVY (MXHEAV), INFHEA (MXHEAV), | |
19847 | & ICHEAV (KXHEAV), IBHEAV (KXHEAV), | |
19848 | & IMHEAV (KXHEAV), IHHEAV (KXHEAV), | |
19849 | & KHHEAV (IHYPMX,KXHEAV), NPHEAV | |
19850 | COMMON / FHEAVC / ANHEAV (KXHEAV) | |
19851 | ||
19852 | * event flag | |
19853 | COMMON /DTEVNO/ NEVENT,ICASCA | |
19854 | ||
19855 | DIMENSION INUC(2),IDXPAR(2),IDPAR(2),AIF(2),AIZF(2),AMRCL(2), | |
19856 | & PRCL(2,4),MO1(2),MO2(2),VRCL(2,4),WRCL(2,4), | |
19857 | & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4) | |
19858 | ||
19859 | DIMENSION EXPNUC(2),EXC(2,260),NEXC(2,260) | |
19860 | LOGICAL LLCPOT | |
19861 | DATA EXC,NEXC /520*ZERO,520*0/ | |
19862 | DATA EXPNUC /4.0D-3,4.0D-3/ | |
19863 | ||
19864 | IREJ = 0 | |
19865 | LRCLPR = .FALSE. | |
19866 | LRCLTA = .FALSE. | |
19867 | ||
19868 | * skip residual nucleus treatment if not requested or in case | |
19869 | * of central collisions | |
19870 | IF ((.NOT.LEVPRT).OR.(ICENTR.GT.0).OR.(ICENTR.EQ.-1)) RETURN | |
19871 | ||
19872 | DO 1 K=1,2 | |
19873 | IDPAR(K) = 0 | |
19874 | IDXPAR(K)= 0 | |
19875 | NTOT(K) = 0 | |
19876 | NTOTFI(K)= 0 | |
19877 | NPRO(K) = 0 | |
19878 | NPROFI(K)= 0 | |
19879 | NN(K) = 0 | |
19880 | NH(K) = 0 | |
19881 | NHPOS(K) = 0 | |
19882 | NQ(K) = 0 | |
19883 | EEXC(K) = ZERO | |
19884 | MO1(K) = 0 | |
19885 | MO2(K) = 0 | |
19886 | DO 2 I=1,4 | |
19887 | VRCL(K,I) = ZERO | |
19888 | WRCL(K,I) = ZERO | |
19889 | 2 CONTINUE | |
19890 | 1 CONTINUE | |
19891 | NFSP = 0 | |
19892 | INUC(1) = IP | |
19893 | INUC(2) = IT | |
19894 | ||
19895 | DO 3 I=1,NHKK | |
19896 | ||
19897 | * number of final state particles | |
19898 | IF (ABS(ISTHKK(I)).EQ.1) THEN | |
19899 | NFSP = NFSP+1 | |
19900 | IDFSP = IDBAM(I) | |
19901 | ENDIF | |
19902 | ||
19903 | * properties of remaining nucleon configurations | |
19904 | KF = 0 | |
19905 | IF ((ISTHKK(I).EQ.13).OR.(ISTHKK(I).EQ.15)) KF = 1 | |
19906 | IF ((ISTHKK(I).EQ.14).OR.(ISTHKK(I).EQ.16)) KF = 2 | |
19907 | IF (KF.GT.0) THEN | |
19908 | IF (MO1(KF).EQ.0) MO1(KF) = I | |
19909 | MO2(KF) = I | |
19910 | * position of residual nucleus = average position of nucleons | |
19911 | DO 4 K=1,4 | |
19912 | VRCL(KF,K) = VRCL(KF,K)+VHKK(K,I) | |
19913 | WRCL(KF,K) = WRCL(KF,K)+WHKK(K,I) | |
19914 | 4 CONTINUE | |
19915 | * total number of particles contributing to each residual nucleus | |
19916 | NTOT(KF) = NTOT(KF)+1 | |
19917 | IDTMP = IDBAM(I) | |
19918 | IDXTMP = I | |
19919 | * total charge of residual nuclei | |
19920 | NQ(KF) = NQ(KF)+IICH(IDTMP) | |
19921 | * number of protons | |
19922 | IF (IDHKK(I).EQ.2212) THEN | |
19923 | NPRO(KF) = NPRO(KF)+1 | |
19924 | * number of neutrons | |
19925 | ELSEIF (IDHKK(I).EQ.2112) THEN | |
19926 | NN(KF) = NN(KF)+1 | |
19927 | ELSE | |
19928 | * number of baryons other than n, p | |
19929 | IF (IIBAR(IDTMP).EQ.1) THEN | |
19930 | NH(KF) = NH(KF)+1 | |
19931 | IF (IICH(IDTMP).EQ.1) NHPOS(KF) = NHPOS(KF)+1 | |
19932 | ELSE | |
19933 | * any other mesons (status set to 1) | |
19934 | C WRITE(LOUT,1002) KF,IDTMP | |
19935 | C1002 FORMAT(1X,'FICONF: residual nucleus ',I2, | |
19936 | C & ' containing meson ',I4,', status set to 1') | |
19937 | ISTHKK(I) = 1 | |
19938 | IDTMP = IDPAR(KF) | |
19939 | IDXTMP = IDXPAR(KF) | |
19940 | NTOT(KF) = NTOT(KF)-1 | |
19941 | ENDIF | |
19942 | ENDIF | |
19943 | IDPAR(KF) = IDTMP | |
19944 | IDXPAR(KF) = IDXTMP | |
19945 | ENDIF | |
19946 | 3 CONTINUE | |
19947 | ||
19948 | * reject elastic events (def: one final state particle = projectile) | |
19949 | IF ((IP.EQ.1).AND.(NFSP.EQ.1).AND.(IDFSP.EQ.IJPROJ)) THEN | |
19950 | IREXCI(3) = IREXCI(3)+1 | |
19951 | GOTO 9999 | |
19952 | C RETURN | |
19953 | ENDIF | |
19954 | ||
19955 | * check if one nucleus disappeared.. | |
19956 | C IF ((IP.GT.1).AND.(NTOT(1).EQ.0).AND.(NTOT(2).NE.0)) THEN | |
19957 | C DO 5 K=1,4 | |
19958 | C PRCLTA(K) = PRCLTA(K)+PRCLPR(K) | |
19959 | C PRCLPR(K) = ZERO | |
19960 | C 5 CONTINUE | |
19961 | C ELSEIF ((IT.GT.1).AND.(NTOT(2).EQ.0).AND.(NTOT(1).NE.0)) THEN | |
19962 | C DO 6 K=1,4 | |
19963 | C PRCLPR(K) = PRCLPR(K)+PRCLTA(K) | |
19964 | C PRCLTA(K) = ZERO | |
19965 | C 6 CONTINUE | |
19966 | C ENDIF | |
19967 | ||
19968 | ICOR = 0 | |
19969 | INORCL = 0 | |
19970 | DO 7 I=1,2 | |
19971 | DO 8 K=1,4 | |
19972 | * get the average of the nucleon positions | |
19973 | VRCL(I,K) = VRCL(I,K)/MAX(NTOT(I),1) | |
19974 | WRCL(I,K) = WRCL(I,K)/MAX(NTOT(I),1) | |
19975 | IF (I.EQ.1) PRCL(1,K) = PRCLPR(K) | |
19976 | IF (I.EQ.2) PRCL(2,K) = PRCLTA(K) | |
19977 | 8 CONTINUE | |
19978 | * mass number and charge of residual nuclei | |
19979 | AIF(I) = DBLE(NTOT(I)) | |
19980 | AIZF(I) = DBLE(NPRO(I)+NHPOS(I)) | |
19981 | IF (NTOT(I).GT.1) THEN | |
19982 | * masses of residual nuclei in ground state | |
19983 | ||
19984 | C AMRCL0(I) = AIF(I)*AMUAMU+1.0D-3*ENERGY(AIF(I),AIZF(I)) | |
19985 | AMRCL0(I) = AIF(I)*AMUC12 | |
19986 | & +EMVGEV*EXMSAZ(AIF(I),AIZF(I),.TRUE.,IZDUM) | |
19987 | ||
19988 | * masses of residual nuclei | |
19989 | PTORCL = SQRT(PRCL(I,1)**2+PRCL(I,2)**2+PRCL(I,3)**2) | |
19990 | AMRCL(I) = (PRCL(I,4)-PTORCL)*(PRCL(I,4)+PTORCL) | |
19991 | IF (AMRCL(I).GT.ZERO) AMRCL(I) = SQRT(AMRCL(I)) | |
19992 | * | |
19993 | * M_res^2 < 0 : configuration not allowed | |
19994 | * | |
19995 | * a) re-calculate E_exc with scaled nuclear potential | |
19996 | * (conditional jump to label 9998) | |
19997 | * b) or reject event if N_loop(max) is exceeded | |
19998 | * (conditional jump to label 9999) | |
19999 | * | |
20000 | IF (AMRCL(I).LE.ZERO) THEN | |
20001 | IF (IOULEV(3).GT.0) | |
20002 | & WRITE(LOUT,1000) I,PRCL(I,1),PRCL(I,2),PRCL(I,3), | |
20003 | & PRCL(I,4),NTOT | |
20004 | 1000 FORMAT(1X,'warning! negative excitation energy',/, | |
20005 | & I4,4E15.4,2I4) | |
20006 | AMRCL(I) = ZERO | |
20007 | EEXC(I) = ZERO | |
20008 | IF (NLOOP.LE.500) THEN | |
20009 | GOTO 9998 | |
20010 | ELSE | |
20011 | IREXCI(2) = IREXCI(2)+1 | |
20012 | GOTO 9999 | |
20013 | ENDIF | |
20014 | * | |
20015 | * 0 < M_res < M_res0 : mass below ground-state mass | |
20016 | * | |
20017 | * a) we had residual nuclei with mass N_tot and reasonable E_exc | |
20018 | * before- assign average E_exc of those configurations to this | |
20019 | * one ( Nexc(i,N_tot) > 0 ) | |
20020 | * b) or (and this applies always if run in transport codes) go up | |
20021 | * one mass number and | |
20022 | * i) if mass now larger than proj/targ mass or if run in | |
20023 | * transport codes assign average E_exc per wounded nucleon | |
20024 | * x number of wounded nucleons (Inuc-Ntot) | |
20025 | * ii) or assign average E_exc of those configurations to this | |
20026 | * one ( Nexc(i,m) > 0 ) | |
20027 | * | |
20028 | ELSEIF ((AMRCL(I).GT.ZERO).AND.(AMRCL(I).LT.AMRCL0(I))) | |
20029 | & THEN | |
20030 | M = MIN(NTOT(I),260) | |
20031 | IF (NEXC(I,M).GT.0) THEN | |
20032 | AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M)) | |
20033 | ELSE | |
20034 | 70 CONTINUE | |
20035 | M = M+1 | |
20036 | **sr corrected 27.12.06 | |
20037 | * IF (M.GE.INUC(I)) THEN | |
20038 | * AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I)) | |
20039 | IF ((M.GE.INUC(I)).OR.(ICASCA.GT.0)) THEN | |
20040 | IF ( INUC (I) .GT. NTOT (I) ) THEN | |
20041 | AMRCL(I) = AMRCL0(I) | |
20042 | & + EXPNUC(I)*DBLE(MAX(INUC(I)-NTOT(I),0)) | |
20043 | ELSE | |
20044 | AMRCL(I) = AMRCL0(I) + 0.5D+00 * EXPNUC(I) | |
20045 | END IF | |
20046 | ** | |
20047 | ELSE | |
20048 | IF (NEXC(I,M).GT.0) THEN | |
20049 | AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M)) | |
20050 | ELSE | |
20051 | GOTO 70 | |
20052 | ENDIF | |
20053 | ENDIF | |
20054 | ENDIF | |
20055 | EEXC(I) = AMRCL(I)-AMRCL0(I) | |
20056 | ICOR = ICOR+I | |
20057 | * | |
20058 | * M_res > 2.5 x M_res0 : unreasonably(?) high E_exc | |
20059 | * | |
20060 | * a) re-calculate E_exc with scaled nuclear potential | |
20061 | * (conditional jump to label 9998) | |
20062 | * b) or reject event if N_loop(max) is exceeded | |
20063 | * (conditional jump to label 9999) | |
20064 | * | |
20065 | * | |
20066 | ELSEIF (AMRCL(I).GE.2.5D0*AMRCL0(I)) THEN | |
20067 | IF (IOULEV(3).GT.0) | |
20068 | & WRITE(LOUT,1004) I,AMRCL(I),AMRCL0(I),NTOT,NEVHKK | |
20069 | 1004 FORMAT(1X,'warning! too high excitation energy',/, | |
20070 | & I4,1P,2E15.4,3I5) | |
20071 | AMRCL(I) = ZERO | |
20072 | EEXC(I) = ZERO | |
20073 | IF (NLOOP.LE.500) THEN | |
20074 | GOTO 9998 | |
20075 | ELSE | |
20076 | IREXCI(2) = IREXCI(2)+1 | |
20077 | GOTO 9999 | |
20078 | ENDIF | |
20079 | * | |
20080 | * Otherwise (reasonable E_exc) : | |
20081 | * E_exc = M_res - M_res0 | |
20082 | * in addition: calculate and save E_exc per wounded nucleon as | |
20083 | * well as E_exc in <E_exc> counter | |
20084 | * | |
20085 | ELSE | |
20086 | * excitation energies of residual nuclei | |
20087 | EEXC(I) = AMRCL(I)-AMRCL0(I) | |
20088 | **sr 27.12.06 new excitation energy correction by A.F. | |
20089 | * | |
20090 | * all parts with Ilcopt<3 commented since not used | |
20091 | * | |
20092 | * still to be done/decided: | |
20093 | * Increase Icor and put back both residual nuclei on mass shell | |
20094 | * with the exciting correction further below. | |
20095 | * For the moment the modification in the excitation energy is simply | |
20096 | * corrected by scaling the energy of the residual nucleus. | |
20097 | * | |
20098 | LLCPOT = .TRUE. | |
20099 | ILCOPT = 3 | |
20100 | IF ( LLCPOT ) THEN | |
20101 | NNCHIT = MAX ( INUC (I) - NTOT (I), 0 ) | |
20102 | IF ( ILCOPT .LE. 2 ) THEN | |
20103 | C* Patch for Fermi momentum reduction correlated with impact parameter: | |
20104 | C FRMRDC = MIN ( (PFRMAV(INUC(I))/APFRMX)**3, ONE ) | |
20105 | C DLKPRH = 0.1D+00 + 0.5D+00 / SQRT(DBLE(INUC(I))) | |
20106 | C AKPRHO = ONE - DLKPRH | |
20107 | C* f x K rho_cen + (1-f) x 0.5 x K rho_cen = frmrdc x rho_cen | |
20108 | C FRCFLL = MAX ( 2.D+00 * FRMRDC / AKPRHO - ONE, | |
20109 | C & 0.05D+00 ) | |
20110 | C* REDORI = 0.75D+00 | |
20111 | C* REDORI = ONE | |
20112 | C REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00) | |
20113 | ELSE | |
20114 | DLKPRH = ZERO | |
20115 | RDCORE = 1.14D+00 * DBLE(INUC(I))**(ONE/3.D+00) | |
20116 | * Take out roughly one/half of the skin: | |
20117 | RDCORE = RDCORE - 0.5D+00 | |
20118 | FRCFLL = RDCORE**3 | |
20119 | PRSKIN = (RDCORE+2.4D+00)**3 - FRCFLL | |
20120 | PRSKIN = 0.5D+00 * PRSKIN / ( PRSKIN + FRCFLL ) | |
20121 | FRCFLL = ONE - PRSKIN | |
20122 | FRMRDC = FRCFLL + 0.5D+00 * PRSKIN | |
20123 | REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00) | |
20124 | END IF | |
20125 | IF ( NNCHIT .GT. 0 ) THEN | |
20126 | C IF ( ILCOPT .EQ. 1 ) THEN | |
20127 | C SKINRH = ONE - FRCFLL / (DBLE(INUC(I))-ONE) | |
20128 | C DO 1220 NCH = 1, 10 | |
20129 | C ETAETA = ( ONE - SKINRH**INUC(I) | |
20130 | C & - DBLE(INUC(I))* ( ONE - FRCFLL ) | |
20131 | C & * ( ONE - SKINRH ) ) | |
20132 | C & / ( SKINRH**INUC(I) - DBLE (INUC(I)) | |
20133 | C & * ( ONE - FRCFLL) * SKINRH ) | |
20134 | C SKINRH = SKINRH * ( ONE + ETAETA ) | |
20135 | C 1220 CONTINUE | |
20136 | C PRSKIN = SKINRH**(NNCHIT-1) | |
20137 | C ELSE IF ( ILCOPT .EQ. 2 ) THEN | |
20138 | C PRSKIN = ONE - FRCFLL | |
20139 | C END IF | |
20140 | REDCTN = ZERO | |
20141 | DO 1230 NCH = 1, NNCHIT | |
20142 | IF (DT_RNDM(PRFRMI) .LT. PRSKIN) THEN | |
20143 | PRFRMI = (( ONE - 2.D+00 * DLKPRH ) | |
20144 | & * DT_RNDM(PRFRMI))**0.333333333333D+00 | |
20145 | ELSE | |
20146 | PRFRMI = ( ONE - 2.D+00 * DLKPRH | |
20147 | & * DT_RNDM(PRFRMI))**0.333333333333D+00 | |
20148 | END IF | |
20149 | REDCTN = REDCTN + PRFRMI**2 | |
20150 | 1230 CONTINUE | |
20151 | REDCTN = REDCTN / DBLE (NNCHIT) | |
20152 | ELSE | |
20153 | REDCTN = 0.5D+00 | |
20154 | END IF | |
20155 | EEXC (I) = EEXC (I) * REDCTN / REDORI | |
20156 | AMRCL (I) = AMRCL0 (I) + EEXC (I) | |
20157 | PRCL(I,4) = SQRT ( PTORCL**2 + AMRCL(I)**2 ) | |
20158 | END IF | |
20159 | ** | |
20160 | IF (ICASCA.EQ.0) THEN | |
20161 | EXPNUC(I) = EEXC(I)/MAX(1,INUC(I)-NTOT(I)) | |
20162 | M = MIN(NTOT(I),260) | |
20163 | EXC(I,M) = EXC(I,M)+EEXC(I) | |
20164 | NEXC(I,M) = NEXC(I,M)+1 | |
20165 | ENDIF | |
20166 | ENDIF | |
20167 | ELSEIF (NTOT(I).EQ.1) THEN | |
20168 | WRITE(LOUT,1003) I | |
20169 | 1003 FORMAT(1X,'FICONF: warning! NTOT(I)=1? (I=',I3,')') | |
20170 | GOTO 9999 | |
20171 | ELSE | |
20172 | AMRCL0(I) = ZERO | |
20173 | AMRCL(I) = ZERO | |
20174 | EEXC(I) = ZERO | |
20175 | INORCL = INORCL+I | |
20176 | ENDIF | |
20177 | 7 CONTINUE | |
20178 | ||
20179 | PRCLPR(5) = AMRCL(1) | |
20180 | PRCLTA(5) = AMRCL(2) | |
20181 | ||
20182 | IF (ICOR.GT.0) THEN | |
20183 | IF (INORCL.EQ.0) THEN | |
20184 | * one or both residual nuclei consist of one nucleon only, transform | |
20185 | * this nucleon on mass shell | |
20186 | DO 9 K=1,4 | |
20187 | P1IN(K) = PRCL(1,K) | |
20188 | P2IN(K) = PRCL(2,K) | |
20189 | 9 CONTINUE | |
20190 | XM1 = AMRCL(1) | |
20191 | XM2 = AMRCL(2) | |
20192 | CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1) | |
20193 | IF (IREJ1.GT.0) THEN | |
20194 | WRITE(LOUT,*) 'ficonf-mashel rejection' | |
20195 | GOTO 9999 | |
20196 | ENDIF | |
20197 | DO 10 K=1,4 | |
20198 | PRCL(1,K) = P1OUT(K) | |
20199 | PRCL(2,K) = P2OUT(K) | |
20200 | PRCLPR(K) = P1OUT(K) | |
20201 | PRCLTA(K) = P2OUT(K) | |
20202 | 10 CONTINUE | |
20203 | PRCLPR(5) = AMRCL(1) | |
20204 | PRCLTA(5) = AMRCL(2) | |
20205 | ELSE | |
20206 | IF (IOULEV(3).GT.0) | |
20207 | & WRITE(LOUT,1001) NEVHKK,INT(AIF(1)),INT(AIZF(1)), | |
20208 | & INT(AIF(2)),INT(AIZF(2)),AMRCL0(1), | |
20209 | & AMRCL(1),AMRCL(1)-AMRCL0(1),AMRCL0(2), | |
20210 | & AMRCL(2),AMRCL(2)-AMRCL0(2) | |
20211 | 1001 FORMAT(1X,'FICONF: warning! no residual nucleus for', | |
20212 | & ' correction',/,11X,'at event',I8, | |
20213 | & ', nucleon config. 1:',2I4,' 2:',2I4, | |
20214 | & 2(/,11X,3E12.3)) | |
20215 | IF (NLOOP.LE.500) THEN | |
20216 | GOTO 9998 | |
20217 | ELSE | |
20218 | IREXCI(1) = IREXCI(1)+1 | |
20219 | ENDIF | |
20220 | ENDIF | |
20221 | ENDIF | |
20222 | ||
20223 | * update counter | |
20224 | C IF (NRESEV(1).NE.NEVHKK) THEN | |
20225 | C NRESEV(1) = NEVHKK | |
20226 | C NRESEV(2) = NRESEV(2)+1 | |
20227 | C ENDIF | |
20228 | NRESEV(2) = NRESEV(2)+1 | |
20229 | DO 15 I=1,2 | |
20230 | EXCDPM(I) = EXCDPM(I)+EEXC(I) | |
20231 | EXCDPM(I+2) = EXCDPM(I+2)+(EEXC(I)/MAX(NTOT(I),1)) | |
20232 | NRESTO(I) = NRESTO(I)+NTOT(I) | |
20233 | NRESPR(I) = NRESPR(I)+NPRO(I) | |
20234 | NRESNU(I) = NRESNU(I)+NN(I) | |
20235 | NRESBA(I) = NRESBA(I)+NH(I) | |
20236 | NRESPB(I) = NRESPB(I)+NHPOS(I) | |
20237 | NRESCH(I) = NRESCH(I)+NQ(I) | |
20238 | 15 CONTINUE | |
20239 | ||
20240 | * evaporation | |
20241 | IF (LEVPRT) THEN | |
20242 | DO 13 I=1,2 | |
20243 | * initialize evaporation counter | |
20244 | EEXCFI(I) = ZERO | |
20245 | IF ((INUC(I).GT.1).AND.(AIF(I).GT.ONE).AND. | |
20246 | & (EEXC(I).GT.ZERO)) THEN | |
20247 | * put residual nuclei into DTEVT1 | |
20248 | IDRCL = 80000 | |
20249 | JMASS = INT( AIF(I)) | |
20250 | JCHAR = INT(AIZF(I)) | |
20251 | * the following patch is required to transmit the correct excitation | |
20252 | * energy to Eventd | |
20253 | IF (ITRSPT.EQ.1) THEN | |
20254 | IF ((ABS(AMRCL(I)-AMRCL0(I)-EEXC(I)).GT.1.D-04).AND. | |
20255 | & (IOULEV(3).GT.0)) | |
20256 | & WRITE(LOUT,*) | |
20257 | & ' DT_FICONF:AMRCL(I),AMRCL0(I),EEXC(I)', | |
20258 | & AMRCL(I),AMRCL0(I),EEXC(I) | |
20259 | PRCL0 = PRCL(I,4) | |
20260 | PRCL(I,4) =SQRT(AMRCL(I)**2+PRCL(I,1)**2+PRCL(I,2)**2 | |
20261 | & +PRCL(I,3)**2) | |
20262 | IF (ABS(PRCL0-PRCL(I,4)).GT.0.1D0) THEN | |
20263 | WRITE(LOUT,*) | |
20264 | & ' PRCL(I,4) recalculated :',PRCL0,PRCL(I,4) | |
20265 | ENDIF | |
20266 | ENDIF | |
20267 | CALL DT_EVTPUT(1000,IDRCL,MO1(I),MO2(I),PRCL(I,1), | |
20268 | & PRCL(I,2),PRCL(I,3),PRCL(I,4),JMASS,JCHAR,0) | |
20269 | **sr 22.6.97 | |
20270 | NOBAM(NHKK) = I | |
20271 | ** | |
20272 | DO 14 J=1,4 | |
20273 | VHKK(J,NHKK) = VRCL(I,J) | |
20274 | WHKK(J,NHKK) = WRCL(I,J) | |
20275 | 14 CONTINUE | |
20276 | * interface to evaporation module - fill final residual nucleus into | |
20277 | * common FKRESN | |
20278 | * fill resnuc only if code is not used as event generator in Fluka | |
20279 | IF (ITRSPT.NE.1) THEN | |
20280 | PXRES = PRCL(I,1) | |
20281 | PYRES = PRCL(I,2) | |
20282 | PZRES = PRCL(I,3) | |
20283 | IBRES = NPRO(I)+NN(I)+NH(I) | |
20284 | ICRES = NPRO(I)+NHPOS(I) | |
20285 | ANOW = DBLE(IBRES) | |
20286 | ZNOW = DBLE(ICRES) | |
20287 | PTRES = SQRT(PXRES**2+PYRES**2+PZRES**2) | |
20288 | * ground state mass of the residual nucleus (should be equal to AM0T) | |
20289 | ||
20290 | AMNRES = AMRCL0(I) | |
20291 | AMMRES = AMNAMA ( AMNRES, IBRES, ICRES ) | |
20292 | ||
20293 | * common FKFINU | |
20294 | TV = ZERO | |
20295 | * kinetic energy of residual nucleus | |
20296 | TVRECL = PRCL(I,4)-AMRCL(I) | |
20297 | * excitation energy of residual nucleus | |
20298 | TVCMS = EEXC(I) | |
20299 | PTOLD = PTRES | |
20300 | PTRES = SQRT(ABS(TVRECL*(TVRECL+ | |
20301 | & 2.0D0*(AMMRES+TVCMS)))) | |
20302 | IF (PTOLD.LT.ANGLGB) THEN | |
20303 | CALL DT_RACO(PXRES,PYRES,PZRES) | |
20304 | PTOLD = ONE | |
20305 | ENDIF | |
20306 | PXRES = PXRES*PTRES/PTOLD | |
20307 | PYRES = PYRES*PTRES/PTOLD | |
20308 | PZRES = PZRES*PTRES/PTOLD | |
20309 | * zero counter of secondaries from evaporation | |
20310 | NP = 0 | |
20311 | * evaporation | |
20312 | WE = ONE | |
20313 | ||
20314 | NPHEAV = 0 | |
20315 | LRNFSS = .FALSE. | |
20316 | LFRAGM = .FALSE. | |
20317 | CALL EVEVAP(WE) | |
20318 | ||
20319 | * put evaporated particles and residual nuclei to DTEVT1 | |
20320 | MO = NHKK | |
20321 | CALL DT_EVA2HE(MO,EXCITF,I,IREJ1) | |
20322 | ENDIF | |
20323 | EEXCFI(I) = EXCITF | |
20324 | EXCEVA(I) = EXCEVA(I)+EXCITF | |
20325 | ENDIF | |
20326 | 13 CONTINUE | |
20327 | ENDIF | |
20328 | ||
20329 | RETURN | |
20330 | ||
20331 | C9998 IREXCI(1) = IREXCI(1)+1 | |
20332 | 9998 IREJ = IREJ+1 | |
20333 | 9999 CONTINUE | |
20334 | LRCLPR = .TRUE. | |
20335 | LRCLTA = .TRUE. | |
20336 | IREJ = IREJ+1 | |
20337 | RETURN | |
20338 | END | |
20339 | ||
20340 | *$ CREATE DT_EVA2HE.FOR | |
20341 | *COPY DT_EVA2HE | |
20342 | * * | |
20343 | *====eva2he============================================================* | |
20344 | * * | |
20345 | SUBROUTINE DT_EVA2HE(MO,EEXCF,IRCL,IREJ) | |
20346 | ||
20347 | ************************************************************************ | |
20348 | * Interface between common's of evaporation module (FKFINU,FKFHVY) * | |
20349 | * and DTEVT1. * | |
20350 | * MO DTEVT1-index of "mother" (residual) nucleus before evap. * | |
20351 | * EEXCF exitation energy of residual nucleus after evaporation * | |
20352 | * IRCL = 1 projectile residual nucleus * | |
20353 | * = 2 target residual nucleus * | |
20354 | * This version dated 19.04.95 is written by S. Roesler. * | |
20355 | * * | |
20356 | * Last change 27.12.2006 by S. Roesler. * | |
20357 | ************************************************************************ | |
20358 | ||
20359 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
20360 | SAVE | |
20361 | ||
20362 | PARAMETER ( LINP = 10 , | |
20363 | & LOUT = 6 , | |
20364 | & LDAT = 9 ) | |
20365 | ||
20366 | PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3) | |
20367 | ||
20368 | * event history | |
20369 | ||
20370 | PARAMETER (NMXHKK=200000) | |
20371 | ||
20372 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
20373 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
20374 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
20375 | * Note: DTEVT2 - special use for heavy fragments ! | |
20376 | * (IDRES(I) = mass number, IDXRES(I) = charge) | |
20377 | ||
20378 | * extended event history | |
20379 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
20380 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
20381 | & IHIST(2,NMXHKK) | |
20382 | ||
20383 | * particle properties (BAMJET index convention) | |
20384 | CHARACTER*8 ANAME | |
20385 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
20386 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
20387 | ||
20388 | * flags for input different options | |
20389 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
20390 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
20391 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
20392 | ||
20393 | * statistics: residual nuclei | |
20394 | COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2), | |
20395 | & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2), | |
20396 | & NINCST(2,4),NINCEV(2), | |
20397 | & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2), | |
20398 | & NRESPB(2),NRESCH(2),NRESEV(4), | |
20399 | & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240), | |
20400 | & NEVAFI(2,2) | |
20401 | ||
20402 | * treatment of residual nuclei: properties of residual nuclei | |
20403 | COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2), | |
20404 | & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2), | |
20405 | & NTOTFI(2),NPROFI(2) | |
20406 | ||
20407 | * INCLUDE '(DIMPAR)' | |
20408 | * Taken from FLUKA | |
20409 | PARAMETER ( MXXRGN =20000 ) | |
20410 | PARAMETER ( MXXMDF = 710 ) | |
20411 | PARAMETER ( MXXMDE = 702 ) | |
20412 | PARAMETER ( MFSTCK =40000 ) | |
20413 | PARAMETER ( MESTCK = 100 ) | |
20414 | PARAMETER ( MOSTCK = 2000 ) | |
20415 | PARAMETER ( MXPRSN = 100 ) | |
20416 | PARAMETER ( MXPDPM = 800 ) | |
20417 | PARAMETER ( MXPSCS =30000 ) | |
20418 | PARAMETER ( MXGLWN = 300 ) | |
20419 | PARAMETER ( MXOUTU = 50 ) | |
20420 | PARAMETER ( NALLWP = 64 ) | |
20421 | PARAMETER ( NELEMX = 80 ) | |
20422 | PARAMETER ( MPDPDX = 18 ) | |
20423 | PARAMETER ( MXHTTR = 260 ) | |
20424 | PARAMETER ( MXSEAX = 20 ) | |
20425 | PARAMETER ( MXHTNC = MXSEAX + 1 ) | |
20426 | PARAMETER ( ICOMAX = 2400 ) | |
20427 | PARAMETER ( ICHMAX = ICOMAX + MXXMDF ) | |
20428 | PARAMETER ( NSTBIS = 304 ) | |
20429 | PARAMETER ( NQSTIS = 46 ) | |
20430 | PARAMETER ( NTSTIS = NSTBIS + NQSTIS ) | |
20431 | PARAMETER ( MXPABL = 120 ) | |
20432 | PARAMETER ( IDMAXP = 450 ) | |
20433 | PARAMETER ( IDMXDC = 2000 ) | |
20434 | PARAMETER ( MXMCIN = 410 ) | |
20435 | PARAMETER ( IHYPMX = 4 ) | |
20436 | PARAMETER ( MKBMX1 = 11 ) | |
20437 | PARAMETER ( MKBMX2 = 11 ) | |
20438 | PARAMETER ( MXIRRD = 2500 ) | |
20439 | PARAMETER ( MXTRDC = 1500 ) | |
20440 | PARAMETER ( NKTL = 17 ) | |
20441 | PARAMETER ( NBLNMX = 40000000 ) | |
20442 | ||
20443 | * INCLUDE '(GENSTK)' | |
20444 | * Taken from FLUKA | |
20445 | PARAMETER ( MXP = MXPSCS ) | |
20446 | * | |
20447 | COMMON / GENSTK / CXR (MXPSCS), CYR (MXPSCS), | |
20448 | & CZR (MXPSCS), CXRPOL (MXPSCS), CYRPOL (MXPSCS), | |
20449 | & CZRPOL (MXPSCS), TKI (MXPSCS), PLR (MXPSCS), | |
20450 | & WEI (MXPSCS), AGESEC (MXPSCS), TV , TVCMS , | |
20451 | & TVRECL, TVHEAV, TVBIND, | |
20452 | & KPART (MXPSCS), INFEXT (MXPSCS), NP0 , NP | |
20453 | ||
20454 | * INCLUDE '(RESNUC)' | |
20455 | LOGICAL LRNFSS, LFRAGM | |
20456 | COMMON /RESNUC/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1, | |
20457 | & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT, | |
20458 | & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES, | |
20459 | & PYRES, PZRES, PTRES2, ANGRES, ANXRES, ANYRES, | |
20460 | & ANZRES, TVESTR, ANESTR, BHYRES (IHYPMX), | |
20461 | & KTARP, KTARN, IGREYP, IGREYN, IPDPM0, IPDPM1, | |
20462 | & IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE, ICRES, | |
20463 | & IBRES, ISTRES, ISMRES, IHYRES, IEVAPL, IEVAPH, | |
20464 | & IEVPHO, IEVNEU, IEVPRO, IEVDEU, IEVTRI, IEV3HE, | |
20465 | & IEV4HE, IDEEXG, IBTAR, ICHTAR, IBLEFT, ICLEFT, | |
20466 | & ICESTR, IBESTR, IOTHER, KHYRES (IHYPMX), | |
20467 | & LRNFSS, LFRAGM | |
20468 | * Taken from FLUKA | |
20469 | ||
20470 | * INCLUDE '(FHEAVY)' | |
20471 | * Taken from FLUKA | |
20472 | PARAMETER ( MXHEAV = 100 ) | |
20473 | PARAMETER ( KXHEAV = 30 ) | |
20474 | CHARACTER*8 ANHEAV | |
20475 | COMMON / FHEAVY / CXHEAV (MXHEAV), CYHEAV (MXHEAV), | |
20476 | & CZHEAV (MXHEAV), TKHEAV (MXHEAV), | |
20477 | & PHEAVY (MXHEAV), WHEAVY (MXHEAV), | |
20478 | & AGHEAV (MXHEAV), BHHEAV (IHYPMX,KXHEAV), | |
20479 | & AMHEAV (KXHEAV), AMNHEA (KXHEAV), | |
20480 | & KHEAVY (MXHEAV), INFHEA (MXHEAV), | |
20481 | & ICHEAV (KXHEAV), IBHEAV (KXHEAV), | |
20482 | & IMHEAV (KXHEAV), IHHEAV (KXHEAV), | |
20483 | & KHHEAV (IHYPMX,KXHEAV), NPHEAV | |
20484 | COMMON / FHEAVC / ANHEAV (KXHEAV) | |
20485 | ||
20486 | DIMENSION IPTOKP(39) | |
20487 | DATA IPTOKP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, | |
20488 | & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 99, | |
20489 | & 100, 101, 97, 102, 98, 103, 109, 115 / | |
20490 | ||
20491 | IREJ = 0 | |
20492 | ||
20493 | * skip if evaporation package is not included | |
20494 | IF (.NOT.LEVAPO) RETURN | |
20495 | ||
20496 | * update counter | |
20497 | IF (NRESEV(3).NE.NEVHKK) THEN | |
20498 | NRESEV(3) = NEVHKK | |
20499 | NRESEV(4) = NRESEV(4)+1 | |
20500 | ENDIF | |
20501 | ||
20502 | IF (LEMCCK) | |
20503 | & CALL DT_EVTEMC(PHKK(1,MO),PHKK(2,MO),PHKK(3,MO),PHKK(4,MO),1, | |
20504 | & IDUM,IDUM) | |
20505 | * mass number/charge of residual nucleus before evaporation | |
20506 | IBTOT = IDRES(MO) | |
20507 | IZTOT = IDXRES(MO) | |
20508 | ||
20509 | * protons/neutrons/gammas | |
20510 | DO 1 I=1,NP | |
20511 | PX = CXR(I)*PLR(I) | |
20512 | PY = CYR(I)*PLR(I) | |
20513 | PZ = CZR(I)*PLR(I) | |
20514 | ID = IPTOKP(KPART(I)) | |
20515 | IDPDG = IDT_IPDGHA(ID) | |
20516 | AM = ((PLR(I)+TKI(I))*(PLR(I)-TKI(I)))/ | |
20517 | & (2.0D0*MAX(TKI(I),TINY10)) | |
20518 | IF (ABS(AM-AAM(ID)).GT.TINY3) THEN | |
20519 | WRITE(LOUT,1000) ID,AM,AAM(ID) | |
20520 | 1000 FORMAT(1X,'EVA2HE: inconsistent mass of evap. ', | |
20521 | & 'particle',I3,2E10.3) | |
20522 | ENDIF | |
20523 | PE = TKI(I)+AM | |
20524 | CALL DT_EVTPUT(-1,IDPDG,MO,0,PX,PY,PZ,PE,0,0,0) | |
20525 | NOBAM(NHKK) = IRCL | |
20526 | IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM) | |
20527 | IBTOT = IBTOT-IIBAR(ID) | |
20528 | IZTOT = IZTOT-IICH(ID) | |
20529 | 1 CONTINUE | |
20530 | ||
20531 | * heavy fragments | |
20532 | DO 2 I=1,NPHEAV | |
20533 | PX = CXHEAV(I)*PHEAVY(I) | |
20534 | PY = CYHEAV(I)*PHEAVY(I) | |
20535 | PZ = CZHEAV(I)*PHEAVY(I) | |
20536 | IDHEAV = 80000 | |
20537 | AM = ((PHEAVY(I)+TKHEAV(I))*(PHEAVY(I)-TKHEAV(I)))/ | |
20538 | & (2.0D0*MAX(TKHEAV(I),TINY10)) | |
20539 | PE = TKHEAV(I)+AM | |
20540 | CALL DT_EVTPUT(-1,IDHEAV,MO,0,PX,PY,PZ,PE, | |
20541 | & IBHEAV(KHEAVY(I)),ICHEAV(KHEAVY(I)),0) | |
20542 | NOBAM(NHKK) = IRCL | |
20543 | IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM) | |
20544 | IBTOT = IBTOT-IBHEAV(KHEAVY(I)) | |
20545 | IZTOT = IZTOT-ICHEAV(KHEAVY(I)) | |
20546 | 2 CONTINUE | |
20547 | ||
20548 | IF (IBRES.GT.0) THEN | |
20549 | * residual nucleus after evaporation | |
20550 | IDNUC = 80000 | |
20551 | CALL DT_EVTPUT(1001,IDNUC,MO,0,PXRES,PYRES,PZRES,ERES, | |
20552 | & IBRES,ICRES,0) | |
20553 | NOBAM(NHKK) = IRCL | |
20554 | ENDIF | |
20555 | EEXCF = TVCMS | |
20556 | NTOTFI(IRCL) = IBRES | |
20557 | NPROFI(IRCL) = ICRES | |
20558 | IF (LEMCCK) CALL DT_EVTEMC(-PXRES,-PYRES,-PZRES,-ERES,2,IDUM,IDUM) | |
20559 | IBTOT = IBTOT-IBRES | |
20560 | IZTOT = IZTOT-ICRES | |
20561 | ||
20562 | * count events with fission | |
20563 | NEVAFI(1,IRCL) = NEVAFI(1,IRCL)+1 | |
20564 | IF (LRNFSS) NEVAFI(2,IRCL) = NEVAFI(2,IRCL)+1 | |
20565 | ||
20566 | * energy-momentum conservation check | |
20567 | IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,40,IREJ) | |
20568 | C IF (IREJ.GT.0) THEN | |
20569 | C CALL DT_EVTOUT(4) | |
20570 | C WRITE(*,*) EEXC(2),EEXCFI(2),NP,NPHEAV | |
20571 | C ENDIF | |
20572 | * baryon-number/charge conservation check | |
20573 | IF (IBTOT+IZTOT.NE.0) THEN | |
20574 | WRITE(LOUT,1001) NEVHKK,IBTOT,IZTOT | |
20575 | 1001 FORMAT(1X,'EVA2HE: baryon-number/charge conservation ', | |
20576 | & 'failure at event ',I8,' : IBTOT,IZTOT = ',2I3) | |
20577 | ENDIF | |
20578 | ||
20579 | RETURN | |
20580 | END | |
20581 | ||
20582 | *$ CREATE DT_EBIND.FOR | |
20583 | *COPY DT_EBIND | |
20584 | * | |
20585 | *===ebind==============================================================* | |
20586 | * | |
20587 | DOUBLE PRECISION FUNCTION DT_EBIND(IA,IZ) | |
20588 | ||
20589 | ************************************************************************ | |
20590 | * Binding energy for nuclei. * | |
20591 | * (Shirokov & Yudin, Yad. Fizika, Nauka, Moskva 1972) * | |
20592 | * IA mass number * | |
20593 | * IZ atomic number * | |
20594 | * This version dated 5.5.95 is updated by S. Roesler. * | |
20595 | ************************************************************************ | |
20596 | ||
20597 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
20598 | SAVE | |
20599 | ||
20600 | PARAMETER ( LINP = 10 , | |
20601 | & LOUT = 6 , | |
20602 | & LDAT = 9 ) | |
20603 | ||
20604 | PARAMETER (ZERO=0.0D0) | |
20605 | ||
20606 | DATA A1, A2, A3, A4, A5 | |
20607 | & / 0.01575D0, 0.0178D0, 0.000710D0, 0.0237D0, 0.034D0/ | |
20608 | ||
20609 | IF ((IA.LE.1).OR.(IZ.EQ.0)) THEN | |
20610 | WRITE(LOUT,'(1X,A,2I5)') 'DT_EBIND IA,IZ set EBIND=0. ',IA,IZ | |
20611 | DT_EBIND = ZERO | |
20612 | RETURN | |
20613 | ENDIF | |
20614 | AA = IA | |
20615 | DT_EBIND = A1*AA - A2*AA**0.666667D0-A3*IZ*IZ*AA**(-0.333333D0) | |
20616 | & -A4*(IA-2*IZ)**2/AA | |
20617 | IF (MOD(IA,2).EQ.1) THEN | |
20618 | IA5 = 0 | |
20619 | ELSEIF (MOD(IZ,2).EQ.1) THEN | |
20620 | IA5 = 1 | |
20621 | ELSE | |
20622 | IA5 = -1 | |
20623 | ENDIF | |
20624 | DT_EBIND = DT_EBIND - IA5*A5*AA**(-0.75D0) | |
20625 | ||
20626 | RETURN | |
20627 | END | |
20628 | ||
20629 | ************************************************************************ | |
20630 | * * | |
20631 | * DPMJET 3.0: cross section routines * | |
20632 | * * | |
20633 | ************************************************************************ | |
20634 | * | |
20635 | * | |
20636 | * SUBROUTINE DT_SHNDIF | |
20637 | * diffractive cross sections (all energies) | |
20638 | * SUBROUTINE DT_PHOXS | |
20639 | * total and inel. cross sections from PHOJET interpol. tables | |
20640 | * SUBROUTINE DT_XSHN | |
20641 | * total and el. cross sections for all energies | |
20642 | * SUBROUTINE DT_SIHNAB | |
20643 | * pion 2-nucleon absorption cross sections | |
20644 | * SUBROUTINE DT_SIGEMU | |
20645 | * cross section for target "compounds" | |
20646 | * SUBROUTINE DT_SIGGA | |
20647 | * photon nucleus cross sections | |
20648 | * SUBROUTINE DT_SIGGAT | |
20649 | * photon nucleus cross sections from tables | |
20650 | * SUBROUTINE DT_SANO | |
20651 | * anomalous hard photon-nucleon cross sections from tables | |
20652 | * SUBROUTINE DT_SIGGP | |
20653 | * photon nucleon cross sections | |
20654 | * SUBROUTINE DT_SIGVEL | |
20655 | * quasi-elastic vector meson prod. cross sections | |
20656 | * DOUBLE PRECISION FUNCTION DT_SIGVP | |
20657 | * sigma_VN(tilde) | |
20658 | * DOUBLE PRECISION FUNCTION DT_RRM2 | |
20659 | * DOUBLE PRECISION FUNCTION DT_RM2 | |
20660 | * DOUBLE PRECISION FUNCTION DT_SAM2 | |
20661 | * SUBROUTINE DT_CKMT | |
20662 | * SUBROUTINE DT_CKMTX | |
20663 | * SUBROUTINE DT_PDF0 | |
20664 | * SUBROUTINE DT_CKMTQ0 | |
20665 | * SUBROUTINE DT_CKMTDE | |
20666 | * SUBROUTINE DT_CKMTPR | |
20667 | * FUNCTION DT_CKMTFF | |
20668 | * | |
20669 | * SUBROUTINE DT_FLUINI | |
20670 | * total nucleon cross section fluctuation treatment | |
20671 | * | |
20672 | * SUBROUTINE DT_SIGTBL | |
20673 | * pre-tabulation of low-energy elastic x-sec. using SIHNEL | |
20674 | * SUBROUTINE DT_XSTABL | |
20675 | * service routines | |
20676 | * | |
20677 | * | |
20678 | *$ CREATE DT_SHNDIF.FOR | |
20679 | *COPY DT_SHNDIF | |
20680 | * | |
20681 | *===shndif===============================================================* | |
20682 | * | |
20683 | SUBROUTINE DT_SHNDIF(ECM,KPROJ,KTARG,SIGDIF,SIGDIH) | |
20684 | ||
20685 | ********************************************************************** | |
20686 | * Single diffractive hadron-nucleon cross sections * | |
20687 | * S.Roesler 14/1/93 * | |
20688 | * * | |
20689 | * The cross sections are calculated from extrapolated single * | |
20690 | * diffractive antiproton-proton cross sections (DTUJET92) using * | |
20691 | * scaling relations between total and single diffractive cross * | |
20692 | * sections. * | |
20693 | ********************************************************************** | |
20694 | ||
20695 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
20696 | SAVE | |
20697 | PARAMETER (ZERO=0.0D0) | |
20698 | ||
20699 | * particle properties (BAMJET index convention) | |
20700 | CHARACTER*8 ANAME | |
20701 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
20702 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
20703 | * | |
20704 | CSD1 = 4.201483727D0 | |
20705 | CSD4 = -0.4763103556D-02 | |
20706 | CSD5 = 0.4324148297D0 | |
20707 | * | |
20708 | CHMSD1 = 0.8519297242D0 | |
20709 | CHMSD4 = -0.1443076599D-01 | |
20710 | CHMSD5 = 0.4014954567D0 | |
20711 | * | |
20712 | EPN = (ECM**2 -AAM(KPROJ)**2 -AAM(KTARG)**2)/(2.0D0*AAM(KTARG)) | |
20713 | PPN = SQRT((EPN-AAM(KPROJ))*(EPN+AAM(KPROJ))) | |
20714 | * | |
20715 | SDIAPP = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN) | |
20716 | SHMSD = CHMSD1+CHMSD4*LOG(PPN)**2+CHMSD5*LOG(PPN) | |
20717 | FRAC = SHMSD/SDIAPP | |
20718 | * | |
20719 | GOTO( 10, 20,999,999,999,999,999, 10, 20,999, | |
20720 | & 999, 20, 20, 20, 20, 20, 10, 20, 20, 10, | |
20721 | & 10, 10, 20, 20, 20) KPROJ | |
20722 | * | |
20723 | 10 CONTINUE | |
20724 | *---------------------------- p - p , n - p , sigma0+- - p , | |
20725 | * Lambda - p | |
20726 | CSD1 = 6.004476070D0 | |
20727 | CSD4 = -0.1257784606D-03 | |
20728 | CSD5 = 0.2447335720D0 | |
20729 | SIGDIF = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN) | |
20730 | SIGDIH = FRAC*SIGDIF | |
20731 | RETURN | |
20732 | * | |
20733 | 20 CONTINUE | |
20734 | * | |
20735 | KPSCAL = 2 | |
20736 | KTSCAL = 1 | |
20737 | C F = SDIAPP/DT_SHNTOT(KPSCAL,KTSCAL,ECM,ZERO) | |
20738 | DUMZER = ZERO | |
20739 | CALL DT_XSHN(KPSCAL,KTSCAL,DUMZER,ECM,SIGTO,SIGEL) | |
20740 | F = SDIAPP/SIGTO | |
20741 | KT = 1 | |
20742 | C SIGDIF = DT_SHNTOT(KPROJ,KT,ECM,ZERO)*F | |
20743 | CALL DT_XSHN(KPROJ,KT,DUMZER,ECM,SIGTO,SIGEL) | |
20744 | SIGDIF = SIGTO*F | |
20745 | SIGDIH = FRAC*SIGDIF | |
20746 | RETURN | |
20747 | * | |
20748 | 999 CONTINUE | |
20749 | *-------------------------- leptons.. | |
20750 | SIGDIF = 1.D-10 | |
20751 | SIGDIH = 1.D-10 | |
20752 | RETURN | |
20753 | END | |
20754 | ||
20755 | *$ CREATE DT_PHOXS.FOR | |
20756 | *COPY DT_PHOXS | |
20757 | * | |
20758 | *===phoxs================================================================* | |
20759 | * | |
20760 | SUBROUTINE DT_PHOXS(KPROJ,KTARG,ECM,PLAB,STOT,SINE,SDIF1,BEL,MODE) | |
20761 | ||
20762 | ************************************************************************ | |
20763 | * Total/inelastic proton-nucleon cross sections taken from PHOJET- * | |
20764 | * interpolation tables. * | |
20765 | * This version dated 05.11.97 is written by S. Roesler * | |
20766 | ************************************************************************ | |
20767 | ||
20768 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
20769 | SAVE | |
20770 | ||
20771 | PARAMETER ( LINP = 10 , | |
20772 | & LOUT = 6 , | |
20773 | & LDAT = 9 ) | |
20774 | ||
20775 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0) | |
20776 | PARAMETER (TWOPI = 6.283185307179586454D+00, | |
20777 | & PI = TWOPI/TWO, | |
20778 | & GEV2MB = 0.38938D0) | |
20779 | ||
20780 | LOGICAL LFIRST | |
20781 | DATA LFIRST /.TRUE./ | |
20782 | ||
20783 | * nucleon-nucleon event-generator | |
20784 | CHARACTER*8 CMODEL | |
20785 | LOGICAL LPHOIN | |
20786 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
20787 | ||
20788 | * particle properties (BAMJET index convention) | |
20789 | CHARACTER*8 ANAME | |
20790 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
20791 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
20792 | ||
20793 | **PHOJET105a | |
20794 | C PARAMETER (IEETAB=10) | |
20795 | C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX | |
20796 | **PHOJET110 | |
20797 | ||
20798 | C energy-interpolation table | |
20799 | INTEGER IEETA2 | |
20800 | PARAMETER ( IEETA2 = 20 ) | |
20801 | INTEGER ISIMAX | |
20802 | DOUBLE PRECISION SIGTAB,SIGECM | |
20803 | COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX | |
20804 | ** | |
20805 | ||
20806 | IF ((MCGENE.NE.2).AND.(MODE.NE.1)) THEN | |
20807 | WRITE(LOUT,*) MCGENE | |
20808 | 1000 FORMAT(1X,'PHOXS: warning! PHOJET not initialized (',I2,')') | |
20809 | STOP | |
20810 | ENDIF | |
20811 | ||
20812 | IF (ECM.LE.ZERO) THEN | |
20813 | EPN = SQRT(AAM(KPROJ)**2+PLAB**2) | |
20814 | ECM = SQRT(AAM(KPROJ)**2+AAM(KTARG)**2+2.0D0*EPN*AAM(KTARG)) | |
20815 | ENDIF | |
20816 | ||
20817 | IF (MODE.EQ.1) THEN | |
20818 | * DL | |
20819 | DELDL = 0.0808D0 | |
20820 | EPSDL = -0.4525D0 | |
20821 | S = ECM*ECM | |
20822 | STOT = 21.7D0*S**DELDL+56.08D0*S**EPSDL | |
20823 | ALPHAP= 0.25D0 | |
20824 | BEL = 8.5D0+2.D0*ALPHAP*LOG(S) | |
20825 | SIGEL = STOT**2/(16.D0*PI*BEL*GEV2MB) | |
20826 | SINE = STOT-SIGEL | |
20827 | SDIF1 = ZERO | |
20828 | ELSE | |
20829 | * Phojet | |
20830 | IP = 1 | |
20831 | IF(ECM.LE.SIGECM(IP,1)) THEN | |
20832 | I1 = 1 | |
20833 | I2 = 1 | |
20834 | ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN | |
20835 | DO 1 I=2,ISIMAX | |
20836 | IF (ECM.LE.SIGECM(IP,I)) GOTO 2 | |
20837 | 1 CONTINUE | |
20838 | 2 CONTINUE | |
20839 | I1 = I-1 | |
20840 | I2 = I | |
20841 | ELSE | |
20842 | IF (LFIRST) THEN | |
20843 | WRITE(LOUT,'(/1X,A,2E12.3)') | |
20844 | & 'PHOXS: warning! energy above initialization limit (', | |
20845 | & ECM,SIGECM(IP,ISIMAX) | |
20846 | LFIRST = .FALSE. | |
20847 | ENDIF | |
20848 | I1 = ISIMAX | |
20849 | I2 = ISIMAX | |
20850 | ENDIF | |
20851 | FAC2 = ZERO | |
20852 | IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1)) | |
20853 | & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1)) | |
20854 | FAC1 = ONE-FAC2 | |
20855 | STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1) | |
20856 | SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1) | |
20857 | SDIF1 = FAC2*(SIGTAB(IP,30,I2)+SIGTAB(IP,32,I2))+ | |
20858 | & FAC1*(SIGTAB(IP,30,I1)+SIGTAB(IP,32,I1)) | |
20859 | BEL = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1) | |
20860 | ENDIF | |
20861 | ||
20862 | RETURN | |
20863 | END | |
20864 | ||
20865 | *$ CREATE DT_XSHN.FOR | |
20866 | *COPY DT_XSHN | |
20867 | * | |
20868 | *===xshn===============================================================* | |
20869 | * | |
20870 | SUBROUTINE DT_XSHN(IP,IT,PL,ECM,STOT,SELA) | |
20871 | ||
20872 | ************************************************************************ | |
20873 | * Total and elastic hadron-nucleon cross section. * | |
20874 | * Below 500GeV cross sections are based on the '98 data compilation * | |
20875 | * of the PDG. At higher energies PHOJET results are used (patched to * | |
20876 | * the low energy data at 500GeV). * | |
20877 | * IP projectile index (BAMJET numbering scheme) * | |
20878 | * (should be in the range 1..25) * | |
20879 | * IT target index (BAMJET numbering scheme) * | |
20880 | * (1 = proton, 8 = neutron) * | |
20881 | * PL laboratory momentum * | |
20882 | * ECM cm. energy (ignored if PL>0) * | |
20883 | * STOT total cross section * | |
20884 | * SELA elastic cross section * | |
20885 | * Last change: 24.4.99 by S. Roesler * | |
20886 | ************************************************************************ | |
20887 | ||
20888 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
20889 | SAVE | |
20890 | ||
20891 | PARAMETER ( LINP = 10 , | |
20892 | & LOUT = 6 , | |
20893 | & LDAT = 9 ) | |
20894 | ||
20895 | PARAMETER (ZERO=0.0D0,ONE=1.0D0) | |
20896 | ||
20897 | PARAMETER (NPOIN1 = 54, NPOIN2 = 8, | |
20898 | & PLABLO = 0.1D0, PTHRE = 5.0D0, PLABHI = 500.0D0) | |
20899 | PARAMETER (NPOINT = NPOIN1+NPOIN2+1) | |
20900 | ||
20901 | LOGICAL LFIRST | |
20902 | ||
20903 | * particle properties (BAMJET index convention) | |
20904 | CHARACTER*8 ANAME | |
20905 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
20906 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
20907 | ||
20908 | * nucleon-nucleon event-generator | |
20909 | CHARACTER*8 CMODEL | |
20910 | LOGICAL LPHOIN | |
20911 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
20912 | **PHOJET105a | |
20913 | C PARAMETER (IEETAB=10) | |
20914 | C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX | |
20915 | **PHOJET110 | |
20916 | ||
20917 | C energy-interpolation table | |
20918 | INTEGER IEETA2 | |
20919 | PARAMETER ( IEETA2 = 20 ) | |
20920 | INTEGER ISIMAX | |
20921 | DOUBLE PRECISION SIGTAB,SIGECM | |
20922 | COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX | |
20923 | ||
20924 | DIMENSION APL(NPOINT),ASIGTO(10,NPOINT),ASIGEL(10,NPOINT) | |
20925 | DIMENSION IDXDAT(25,2) | |
20926 | * | |
20927 | DATA APL / | |
20928 | &-1.000,-0.969,-0.937,-0.906,-0.874,-0.843,-0.811,-0.780,-0.748, | |
20929 | &-0.717,-0.685,-0.654,-0.622,-0.591,-0.560,-0.528,-0.497,-0.465, | |
20930 | &-0.434,-0.402,-0.371,-0.339,-0.308,-0.276,-0.245,-0.213,-0.182, | |
20931 | &-0.151,-0.119,-0.088,-0.056,-0.025, 0.007, 0.038, 0.070, 0.101, | |
20932 | & 0.133, 0.164, 0.196, 0.227, 0.258, 0.290, 0.321, 0.353, 0.384, | |
20933 | & 0.416, 0.447, 0.479, 0.510, 0.542, 0.573, 0.605, 0.636, 0.668, | |
20934 | & 0.699, 0.949, 1.199, 1.449, 1.699, 1.949, 2.199, 2.449, 2.699/ | |
20935 | * | |
20936 | * total cross sections: | |
20937 | * p p | |
20938 | DATA (ASIGTO(1,K),K=1,NPOINT) / | |
20939 | & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255, | |
20940 | & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646, | |
20941 | & 1.577, 1.518, 1.462, 1.420, 1.393, 1.375, 1.363, 1.356, 1.352, | |
20942 | & 1.350, 1.351, 1.359, 1.381, 1.410, 1.444, 1.487, 1.544, 1.596, | |
20943 | & 1.650, 1.672, 1.676, 1.677, 1.677, 1.675, 1.675, 1.669, 1.664, | |
20944 | & 1.658, 1.653, 1.645, 1.640, 1.634, 1.630, 1.625, 1.620, 1.617, | |
20945 | & 1.614, 1.602, 1.594, 1.589, 1.581, 1.583, 1.588, 1.596, 1.603/ | |
20946 | * pbar p | |
20947 | DATA (ASIGTO(2,K),K=1,NPOINT) / | |
20948 | & 2.778, 2.759, 2.739, 2.718, 2.697, 2.675, 2.651, 2.626, 2.598, | |
20949 | & 2.569, 2.537, 2.502, 2.471, 2.443, 2.420, 2.389, 2.361, 2.329, | |
20950 | & 2.313, 2.304, 2.268, 2.244, 2.222, 2.212, 2.178, 2.162, 2.151, | |
20951 | & 2.132, 2.109, 2.097, 2.089, 2.078, 2.063, 2.049, 2.035, 2.024, | |
20952 | & 2.014, 2.004, 1.993, 1.981, 1.970, 1.958, 1.946, 1.933, 1.921, | |
20953 | & 1.909, 1.894, 1.885, 1.871, 1.854, 1.836, 1.825, 1.816, 1.802, | |
20954 | & 1.790, 1.744, 1.694, 1.663, 1.642, 1.614, 1.623, 1.623, 1.630/ | |
20955 | * n p | |
20956 | DATA (ASIGTO(3,K),K=1,NPOINT) / | |
20957 | & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763, | |
20958 | & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115, | |
20959 | & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569, | |
20960 | & 1.547, 1.534, 1.526, 1.522, 1.520, 1.525, 1.536, 1.550, 1.566, | |
20961 | & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609, | |
20962 | & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605, | |
20963 | & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/ | |
20964 | * pi+ p | |
20965 | DATA (ASIGTO(4,K),K=1,NPOINT) / | |
20966 | & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610, | |
20967 | & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118, | |
20968 | & 2.001, 1.875, 1.801, 1.665, 1.609, 1.484, 1.412, 1.334, 1.195, | |
20969 | & 1.160, 1.166, 1.208, 1.309, 1.356, 1.394, 1.406, 1.419, 1.473, | |
20970 | & 1.540, 1.596, 1.570, 1.533, 1.516, 1.484, 1.471, 1.478, 1.492, | |
20971 | & 1.497, 1.491, 1.479, 1.465, 1.453, 1.449, 1.450, 1.444, 1.428, | |
20972 | & 1.422, 1.406, 1.384, 1.369, 1.364, 1.369, 1.374, 1.388, 1.395/ | |
20973 | * pi- p | |
20974 | DATA (ASIGTO(5,K),K=1,NPOINT) / | |
20975 | & 0.458, 0.540, 0.626, 0.718, 0.819, 0.933, 1.063, 1.208, 1.226, | |
20976 | & 1.436, 1.470, 1.594, 1.708, 1.786, 1.852, 1.836, 1.763, 1.679, | |
20977 | & 1.590, 1.492, 1.445, 1.426, 1.423, 1.433, 1.473, 1.506, 1.547, | |
20978 | & 1.660, 1.671, 1.545, 1.591, 1.687, 1.808, 1.656, 1.582, 1.543, | |
20979 | & 1.562, 1.560, 1.537, 1.540, 1.549, 1.557, 1.557, 1.551, 1.535, | |
20980 | & 1.527, 1.511, 1.510, 1.507, 1.500, 1.491, 1.483, 1.478, 1.468, | |
20981 | & 1.463, 1.435, 1.408, 1.394, 1.384, 1.380, 1.383, 1.393, 1.411/ | |
20982 | * K+ p | |
20983 | DATA (ASIGTO(6,K),K=1,NPOINT) / | |
20984 | & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, | |
20985 | & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, | |
20986 | & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.096, 1.095, | |
20987 | & 1.098, 1.105, 1.111, 1.139, 1.169, 1.209, 1.248, 1.259, 1.268, | |
20988 | & 1.262, 1.257, 1.254, 1.252, 1.250, 1.249, 1.246, 1.244, 1.244, | |
20989 | & 1.243, 1.240, 1.238, 1.237, 1.236, 1.235, 1.235, 1.236, 1.236, | |
20990 | & 1.236, 1.233, 1.238, 1.248, 1.257, 1.272, 1.292, 1.311, 1.336/ | |
20991 | * K- p | |
20992 | DATA (ASIGTO(7,K),K=1,NPOINT) / | |
20993 | & 2.003, 2.002, 2.001, 2.000, 1.999, 1.998, 1.998, 1.997, 1.997, | |
20994 | & 1.996, 1.995, 1.993, 1.990, 1.992, 1.974, 1.912, 1.865, 1.847, | |
20995 | & 1.896, 1.950, 1.827, 1.681, 1.637, 1.616, 1.589, 1.545, 1.543, | |
20996 | & 1.532, 1.603, 1.604, 1.616, 1.658, 1.700, 1.658, 1.595, 1.508, | |
20997 | & 1.493, 1.514, 1.531, 1.523, 1.501, 1.479, 1.474, 1.467, 1.463, | |
20998 | & 1.450, 1.444, 1.435, 1.426, 1.424, 1.423, 1.415, 1.401, 1.396, | |
20999 | & 1.384, 1.364, 1.330, 1.313, 1.310, 1.309, 1.317, 1.329, 1.338/ | |
21000 | * K+ n | |
21001 | DATA (ASIGTO(8,K),K=1,NPOINT) / | |
21002 | & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584, | |
21003 | & 0.631, 0.675, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931, | |
21004 | & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.102, 1.125, 1.147, | |
21005 | & 1.168, 1.187, 1.205, 1.224, 1.248, 1.279, 1.315, 1.324, 1.301, | |
21006 | & 1.285, 1.279, 1.274, 1.273, 1.272, 1.271, 1.267, 1.263, 1.261, | |
21007 | & 1.259, 1.256, 1.252, 1.247, 1.244, 1.241, 1.240, 1.240, 1.240, | |
21008 | & 1.241, 1.243, 1.245, 1.253, 1.265, 1.275, 1.293, 1.314, 1.342/ | |
21009 | * K- n | |
21010 | DATA (ASIGTO(9,K),K=1,NPOINT) / | |
21011 | & 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, | |
21012 | & 1.778, 1.778, 1.778, 1.778, 1.778, 1.779, 1.779, 1.778, 1.773, | |
21013 | & 1.765, 1.746, 1.703, 1.646, 1.561, 1.488, 1.454, 1.437, 1.437, | |
21014 | & 1.458, 1.505, 1.561, 1.588, 1.593, 1.581, 1.551, 1.500, 1.454, | |
21015 | & 1.427, 1.408, 1.390, 1.372, 1.361, 1.356, 1.351, 1.347, 1.343, | |
21016 | & 1.341, 1.340, 1.338, 1.337, 1.335, 1.334, 1.332, 1.331, 1.330, | |
21017 | & 1.330, 1.313, 1.303, 1.288, 1.288, 1.297, 1.305, 1.320, 1.342/ | |
21018 | * Lambda p | |
21019 | DATA (ASIGTO(10,K),K=1,NPOINT) / | |
21020 | & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224, | |
21021 | & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.629, | |
21022 | & 1.599, 1.576, 1.558, 1.543, 1.530, 1.520, 1.512, 1.505, 1.499, | |
21023 | & 1.495, 1.495, 1.497, 1.504, 1.514, 1.525, 1.536, 1.550, 1.567, | |
21024 | & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609, | |
21025 | & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605, | |
21026 | & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/ | |
21027 | * | |
21028 | * elastic cross sections: | |
21029 | * p p | |
21030 | DATA (ASIGEL(1,K),K=1,NPOINT) / | |
21031 | & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255, | |
21032 | & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646, | |
21033 | & 1.577, 1.518, 1.462, 1.420, 1.393, 1.374, 1.360, 1.353, 1.350, | |
21034 | & 1.351, 1.356, 1.362, 1.369, 1.376, 1.384, 1.385, 1.399, 1.397, | |
21035 | & 1.389, 1.385, 1.379, 1.366, 1.358, 1.344, 1.320, 1.294, 1.275, | |
21036 | & 1.260, 1.248, 1.235, 1.219, 1.199, 1.172, 1.144, 1.126, 1.115, | |
21037 | & 1.104, 1.013, 0.962, 0.905, 0.869, 0.845, 0.846, 0.850, 0.868/ | |
21038 | * pbar p | |
21039 | DATA (ASIGEL(2,K),K=1,NPOINT) / | |
21040 | & 1.987, 1.985, 1.983, 1.980, 1.978, 1.975, 1.971, 1.968, 1.963, | |
21041 | & 1.958, 1.951, 1.944, 1.935, 1.925, 1.914, 1.902, 1.889, 1.875, | |
21042 | & 1.859, 1.845, 1.834, 1.817, 1.792, 1.769, 1.754, 1.738, 1.720, | |
21043 | & 1.702, 1.688, 1.676, 1.667, 1.659, 1.652, 1.645, 1.640, 1.636, | |
21044 | & 1.620, 1.591, 1.562, 1.546, 1.540, 1.524, 1.496, 1.475, 1.457, | |
21045 | & 1.429, 1.402, 1.373, 1.344, 1.330, 1.306, 1.294, 1.265, 1.228, | |
21046 | & 1.204, 1.086, 0.977, 0.933, 0.914, 0.850, 0.862, 0.848, 0.845/ | |
21047 | * n p | |
21048 | DATA (ASIGEL(3,K),K=1,NPOINT) / | |
21049 | & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763, | |
21050 | & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115, | |
21051 | & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569, | |
21052 | & 1.544, 1.527, 1.514, 1.504, 1.495, 1.486, 1.476, 1.466, 1.454, | |
21053 | & 1.440, 1.425, 1.409, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304, | |
21054 | & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136, | |
21055 | & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/ | |
21056 | * pi+ p | |
21057 | DATA (ASIGEL(4,K),K=1,NPOINT) / | |
21058 | & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610, | |
21059 | & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118, | |
21060 | & 2.001, 1.875, 1.801, 1.664, 1.610, 1.479, 1.423, 1.299, 1.166, | |
21061 | & 1.097, 1.020, 0.958, 0.914, 1.013, 1.088, 1.153, 1.167, 1.235, | |
21062 | & 1.240, 1.237, 1.202, 1.135, 1.090, 1.026, 0.975, 0.941, 0.904, | |
21063 | & 0.894, 0.884, 0.862, 0.850, 0.845, 0.827, 0.805, 0.789, 0.776, | |
21064 | & 0.763, 0.686, 0.626, 0.562, 0.505, 0.518, 0.525, 0.528, 0.528/ | |
21065 | * pi- p | |
21066 | DATA (ASIGEL(5,K),K=1,NPOINT) / | |
21067 | & 0.266, 0.278, 0.294, 0.320, 0.360, 0.419, 0.503, 0.608, 0.727, | |
21068 | & 0.850, 0.968, 1.071, 1.167, 1.305, 1.369, 1.404, 1.446, 1.217, | |
21069 | & 1.112, 1.071, 1.014, 1.002, 0.996, 1.008, 1.070, 1.126, 1.209, | |
21070 | & 1.300, 1.281, 1.188, 1.156, 1.341, 1.423, 1.314, 1.171, 1.140, | |
21071 | & 1.106, 1.071, 1.011, 1.037, 1.026, 1.024, 0.988, 0.953, 0.895, | |
21072 | & 0.894, 0.880, 0.871, 0.864, 0.853, 0.837, 0.820, 0.809, 0.800, | |
21073 | & 0.782, 0.674, 0.612, 0.530, 0.521, 0.528, 0.524, 0.542, 0.569/ | |
21074 | * K+ p | |
21075 | DATA (ASIGEL(6,K),K=1,NPOINT) / | |
21076 | & 1.064, 1.065, 1.065, 1.066, 1.066, 1.066, 1.066, 1.066, 1.066, | |
21077 | & 1.065, 1.064, 1.063, 1.062, 1.062, 1.062, 1.064, 1.066, 1.070, | |
21078 | & 1.076, 1.082, 1.088, 1.096, 1.103, 1.104, 1.104, 1.102, 1.093, | |
21079 | & 1.087, 1.084, 1.079, 1.075, 1.067, 1.058, 1.040, 1.029, 1.012, | |
21080 | & 1.003, 0.985, 0.935, 0.909, 0.880, 0.846, 0.790, 0.771, 0.759, | |
21081 | & 0.743, 0.718, 0.681, 0.666, 0.645, 0.622, 0.606, 0.594, 0.584, | |
21082 | & 0.575, 0.513, 0.453, 0.403, 0.356, 0.365, 0.389, 0.430, 0.477/ | |
21083 | * K- p | |
21084 | DATA (ASIGEL(7,K),K=1,NPOINT) / | |
21085 | & 1.941, 1.936, 1.931, 1.926, 1.919, 1.912, 1.903, 1.892, 1.878, | |
21086 | & 1.863, 1.844, 1.821, 1.791, 1.755, 1.713, 1.666, 1.615, 1.561, | |
21087 | & 1.533, 1.531, 1.518, 1.511, 1.452, 1.339, 1.265, 1.233, 1.188, | |
21088 | & 1.184, 1.236, 1.316, 1.333, 1.336, 1.333, 1.277, 1.216, 1.077, | |
21089 | & 1.018, 0.912, 0.926, 0.920, 0.910, 0.894, 0.830, 0.825, 0.800, | |
21090 | & 0.788, 0.747, 0.703, 0.707, 0.689, 0.643, 0.633, 0.635, 0.618, | |
21091 | & 0.584, 0.579, 0.461, 0.403, 0.405, 0.399, 0.408, 0.418, 0.413/ | |
21092 | * K+ n | |
21093 | DATA (ASIGEL(8,K),K=1,NPOINT) / | |
21094 | & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584, | |
21095 | & 0.631, 0.676, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931, | |
21096 | & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.103, 1.126, 1.148, | |
21097 | & 1.168, 1.187, 1.205, 1.223, 1.248, 1.282, 1.269, 1.185, 1.111, | |
21098 | & 1.063, 1.031, 0.998, 0.964, 0.928, 0.889, 0.849, 0.814, 0.785, | |
21099 | & 0.760, 0.738, 0.720, 0.703, 0.688, 0.674, 0.660, 0.648, 0.635, | |
21100 | & 0.624, 0.536, 0.473, 0.442, 0.428, 0.428, 0.436, 0.453, 0.477/ | |
21101 | * K- n | |
21102 | DATA (ASIGEL(9,K),K=1,NPOINT) / | |
21103 | & 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, | |
21104 | & 1.613, 1.613, 1.613, 1.612, 1.613, 1.614, 1.614, 1.612, 1.606, | |
21105 | & 1.593, 1.564, 1.498, 1.402, 1.240, 1.071, 0.977, 0.922, 0.914, | |
21106 | & 0.961, 1.077, 1.214, 1.271, 1.290, 1.281, 1.217, 1.096, 0.979, | |
21107 | & 0.896, 0.822, 0.736, 0.655, 0.608, 0.591, 0.580, 0.569, 0.559, | |
21108 | & 0.550, 0.540, 0.531, 0.522, 0.514, 0.507, 0.500, 0.494, 0.489, | |
21109 | & 0.485, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477/ | |
21110 | * Lambda p | |
21111 | DATA (ASIGEL(10,K),K=1,NPOINT) / | |
21112 | & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224, | |
21113 | & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.630, | |
21114 | & 1.600, 1.577, 1.558, 1.542, 1.528, 1.518, 1.510, 1.505, 1.502, | |
21115 | & 1.501, 1.500, 1.499, 1.496, 1.491, 1.485, 1.477, 1.466, 1.454, | |
21116 | & 1.440, 1.425, 1.408, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304, | |
21117 | & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136, | |
21118 | & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/ | |
21119 | ||
21120 | DATA (IDXDAT(K,1),K=1,25) / | |
21121 | & 1, 2, 0, 0, 0, 0, 0, 3, 2, 0, 0,67, 4, 5, 6, 7,10, 2,67, 3, | |
21122 | & 1, 3,45, 8, 9/ | |
21123 | DATA (IDXDAT(K,2),K=1,25) / | |
21124 | & 3, 2, 0, 0, 0, 0, 0, 1, 2, 0, 0,89, 5, 4, 8, 9, 1, 2,89, 1, | |
21125 | & 3, 1,45, 6, 7/ | |
21126 | ||
21127 | DATA LFIRST /.TRUE./ | |
21128 | ||
21129 | IF (LFIRST) THEN | |
21130 | APLABL = LOG10(PLABLO) | |
21131 | APLABH = LOG10(PLABHI) | |
21132 | APTHRE = LOG10(PTHRE) | |
21133 | ADP1 = (APTHRE-APLABL)/DBLE(NPOIN1) | |
21134 | ADP2 = (APLABH-APTHRE)/DBLE(NPOIN2) | |
21135 | DUM0 = ZERO | |
21136 | PHOPLA = PLABHI | |
21137 | PHOELA = SQRT(AAM(1)**2+PHOPLA**2) | |
21138 | ECMS = SQRT(2.0D0*AAM(1)**2+2.0D0*AAM(1)*PHOELA) | |
21139 | IF (MCGENE.EQ.2) THEN | |
21140 | IF (ECMS.LE.SIGECM(1,ISIMAX)) THEN | |
21141 | CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,0) | |
21142 | ELSE | |
21143 | CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1) | |
21144 | ENDIF | |
21145 | ELSE | |
21146 | CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1) | |
21147 | ENDIF | |
21148 | PHOSEL = PHOSTO-PHOSIN | |
21149 | APHOST = LOG10(PHOSTO) | |
21150 | APHOSE = LOG10(PHOSEL) | |
21151 | LFIRST = .FALSE. | |
21152 | ENDIF | |
21153 | STOT = ZERO | |
21154 | SELA = ZERO | |
21155 | PLAB = PL | |
21156 | ECMS = ECM | |
21157 | IF ( (IP.LT.1).OR.((IT.NE.1).AND.(IT.NE.8)) ) THEN | |
21158 | WRITE(LOUT,1000) IP,IT | |
21159 | 1000 FORMAT(1X,'DT_XSHN: cross sections not implemented for ', | |
21160 | & 'proj/target',2I4) | |
21161 | STOP | |
21162 | ENDIF | |
21163 | ||
21164 | IF ((PLAB.LE.ZERO).AND.(ECMS.GT.ZERO)) THEN | |
21165 | ELAB = (ECMS**2-AAM(IP)**2-AAM(IT)**2)/(2.0D0*AAM(IT)) | |
21166 | PLAB = SQRT((ELAB-AAM(IP))*(ELAB+AAM(IP))) | |
21167 | ELSEIF ((PLAB.LE.ZERO).AND.(ECMS.LE.ZERO)) THEN | |
21168 | WRITE(LOUT,1001) PLAB,ECMS | |
21169 | 1001 FORMAT(1X,'DT_XSHN: invalid momentum/cm-energy ',2E15.5) | |
21170 | STOP | |
21171 | ENDIF | |
21172 | ||
21173 | * index of spectrum | |
21174 | IDXP = IP | |
21175 | IF (IP.GT.25) THEN | |
21176 | IF (AAM(IP).GT.ZERO) THEN | |
21177 | IF (ABS(IIBAR(IP)).GT.0) THEN | |
21178 | IDXP = 1 | |
21179 | ELSE | |
21180 | IDXP = 13 | |
21181 | ENDIF | |
21182 | ELSE | |
21183 | IDXP = 7 | |
21184 | ENDIF | |
21185 | ENDIF | |
21186 | IDXT = 1 | |
21187 | IF (IT.EQ.8) IDXT = 2 | |
21188 | IDXS = IDXDAT(IDXP,IDXT) | |
21189 | IF (IDXS.EQ.0) RETURN | |
21190 | ||
21191 | * compute momentum bin indices | |
21192 | IF (PLAB.LT.PLABLO) THEN | |
21193 | IDX0 = 1 | |
21194 | IDX1 = 1 | |
21195 | ELSEIF (PLAB.GE.PLABHI) THEN | |
21196 | IDX0 = NPOINT | |
21197 | IDX1 = NPOINT | |
21198 | ELSE | |
21199 | APLAB = LOG10(PLAB) | |
21200 | IF ((PLAB.GE.PLABLO).AND.(PLAB.LT.PTHRE )) THEN | |
21201 | IDX0 = INT((APLAB-APLABL)/ADP1)+1 | |
21202 | ELSEIF ((PLAB.GE.PTHRE ).AND.(PLAB.LT.PLABHI)) THEN | |
21203 | IDX0 = INT((APLAB-APTHRE)/ADP2)+NPOIN1+1 | |
21204 | ENDIF | |
21205 | IDX1 = IDX0+1 | |
21206 | ENDIF | |
21207 | ||
21208 | * interpolate cross section | |
21209 | IF (IDXS.GT.10) THEN | |
21210 | IDXS1 = IDXS/10 | |
21211 | IDXS2 = IDXS-10*IDXS1 | |
21212 | IF (IDX0.EQ.IDX1) THEN | |
21213 | IF (IDX0.EQ.1) THEN | |
21214 | ASTOT = 0.5D0*(ASIGTO(IDXS1,IDX0)+ASIGTO(IDXS2,IDX0)) | |
21215 | ASELA = 0.5D0*(ASIGEL(IDXS1,IDX0)+ASIGEL(IDXS2,IDX0)) | |
21216 | ELSE | |
21217 | DUM0 = ZERO | |
21218 | CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0) | |
21219 | PHOSEL = PHOSTO-PHOSIN | |
21220 | ASTOT1 = ASIGTO(IDXS1,NPOINT)-APHOST+LOG10(PHOSTO) | |
21221 | ASELA1 = ASIGEL(IDXS1,NPOINT)-APHOSE+LOG10(PHOSEL) | |
21222 | ASTOT2 = ASIGTO(IDXS2,NPOINT)-APHOST+LOG10(PHOSTO) | |
21223 | ASELA2 = ASIGEL(IDXS2,NPOINT)-APHOSE+LOG10(PHOSEL) | |
21224 | ASTOT = 0.5D0*(ASTOT1+ASTOT2) | |
21225 | ASELA = 0.5D0*(ASELA1+ASELA2) | |
21226 | ENDIF | |
21227 | ELSE | |
21228 | FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0)) | |
21229 | ASTOT1 = ASIGTO(IDXS1,IDX0)+ | |
21230 | & FAC*(ASIGTO(IDXS1,IDX1)-ASIGTO(IDXS1,IDX0)) | |
21231 | ASTOT2 = ASIGTO(IDXS2,IDX0)+ | |
21232 | & FAC*(ASIGTO(IDXS2,IDX1)-ASIGTO(IDXS2,IDX0)) | |
21233 | ASTOT = 0.5D0*(ASTOT1+ASTOT2) | |
21234 | ASELA1 = ASIGEL(IDXS1,IDX0)+ | |
21235 | & FAC*(ASIGEL(IDXS1,IDX1)-ASIGEL(IDXS1,IDX0)) | |
21236 | ASELA2 = ASIGEL(IDXS2,IDX0)+ | |
21237 | & FAC*(ASIGEL(IDXS2,IDX1)-ASIGEL(IDXS2,IDX0)) | |
21238 | ASELA = 0.5D0*(ASELA1+ASELA2) | |
21239 | ENDIF | |
21240 | ELSE | |
21241 | IF (IDX0.EQ.IDX1) THEN | |
21242 | IF (IDX0.EQ.1) THEN | |
21243 | ASTOT = ASIGTO(IDXS,IDX0) | |
21244 | ASELA = ASIGEL(IDXS,IDX0) | |
21245 | ELSE | |
21246 | DUM0 = ZERO | |
21247 | CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0) | |
21248 | PHOSEL = PHOSTO-PHOSIN | |
21249 | ASTOT = ASIGTO(IDXS,NPOINT)-APHOST+LOG10(PHOSTO) | |
21250 | ASELA = ASIGEL(IDXS,NPOINT)-APHOSE+LOG10(PHOSEL) | |
21251 | ENDIF | |
21252 | ELSE | |
21253 | FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0)) | |
21254 | ASTOT = ASIGTO(IDXS,IDX0)+ | |
21255 | & FAC*(ASIGTO(IDXS,IDX1)-ASIGTO(IDXS,IDX0)) | |
21256 | ASELA = ASIGEL(IDXS,IDX0)+ | |
21257 | & FAC*(ASIGEL(IDXS,IDX1)-ASIGEL(IDXS,IDX0)) | |
21258 | ENDIF | |
21259 | ENDIF | |
21260 | STOT = 10.0D0**ASTOT | |
21261 | SELA = 10.0D0**ASELA | |
21262 | ||
21263 | RETURN | |
21264 | END | |
21265 | ||
21266 | *$ CREATE DT_SIHNAB.FOR | |
21267 | *COPY DT_SIHNAB | |
21268 | * | |
21269 | *===sihnab===============================================================* | |
21270 | * | |
21271 | SUBROUTINE DT_SIHNAB(IDP,IDT,PLAB,SIGABS) | |
21272 | ||
21273 | ********************************************************************** | |
21274 | * Pion 2-nucleon absorption cross sections. * | |
21275 | * (sigma_tot for pi+ d --> p p, pi- d --> n n * | |
21276 | * taken from Ritchie PRC 28 (1983) 926 ) * | |
21277 | * This version dated 18.05.96 is written by S. Roesler * | |
21278 | ********************************************************************** | |
21279 | ||
21280 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
21281 | SAVE | |
21282 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY3=1.0D-3) | |
21283 | PARAMETER (AMPR = 938.0D0, | |
21284 | & AMPI = 140.0D0, | |
21285 | & AMDE = TWO*AMPR, | |
21286 | & A = -1.2D0, | |
21287 | & B = 3.5D0, | |
21288 | & C = 7.4D0, | |
21289 | & D = 5600.0D0, | |
21290 | & ER = 2136.0D0) | |
21291 | ||
21292 | SIGABS = ZERO | |
21293 | IF ( ((IDP.NE.13).AND.(IDP.NE.14).AND.(IDP.NE.23)) | |
21294 | & .OR.((IDT.NE.1).AND.(IDT.NE.8)) ) RETURN | |
21295 | PTOT = PLAB*1.0D3 | |
21296 | EKIN = SQRT(AMPI**2+PTOT**2)-AMPI | |
21297 | IF ((EKIN.LT.TINY3).OR.(EKIN.GT.400.0D0)) RETURN | |
21298 | ECM = SQRT( (AMPI+AMDE)**2+TWO*EKIN*AMDE ) | |
21299 | SIGABS = A+B/SQRT(EKIN)+C*1.0D4/((ECM-ER)**2+D) | |
21300 | * approximate 3N-abs., I=1-abs. etc. | |
21301 | SIGABS = SIGABS/0.40D0 | |
21302 | * pi0-absorption (rough approximation!!) | |
21303 | IF (IDP.EQ.23) SIGABS = 0.5D0*SIGABS | |
21304 | ||
21305 | RETURN | |
21306 | END | |
21307 | ||
21308 | *$ CREATE DT_SIGEMU.FOR | |
21309 | *COPY DT_SIGEMU | |
21310 | * | |
21311 | *===sigemu=============================================================* | |
21312 | * | |
21313 | SUBROUTINE DT_SIGEMU | |
21314 | ||
21315 | ************************************************************************ | |
21316 | * Combined cross section for target compounds. * | |
21317 | * This version dated 6.4.98 is written by S. Roesler * | |
21318 | ************************************************************************ | |
21319 | ||
21320 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
21321 | SAVE | |
21322 | ||
21323 | PARAMETER ( LINP = 10 , | |
21324 | & LOUT = 6 , | |
21325 | & LDAT = 9 ) | |
21326 | ||
21327 | PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10, | |
21328 | & OHALF=0.5D0,ONE=1.0D0) | |
21329 | ||
21330 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
21331 | ||
21332 | * Glauber formalism: cross sections | |
21333 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
21334 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
21335 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
21336 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
21337 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
21338 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
21339 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
21340 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
21341 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
21342 | & BSLOPE,NEBINI,NQBINI | |
21343 | ||
21344 | * emulsion treatment | |
21345 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
21346 | & NCOMPO,IEMUL | |
21347 | ||
21348 | * nucleon-nucleon event-generator | |
21349 | CHARACTER*8 CMODEL | |
21350 | LOGICAL LPHOIN | |
21351 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
21352 | ||
21353 | IF (MCGENE.NE.4) THEN | |
21354 | WRITE(LOUT,'(A)') ' DT_SIGEMU: Combined cross sections' | |
21355 | WRITE(LOUT,'(15X,A)') '-----------------------' | |
21356 | ENDIF | |
21357 | DO 1 IE=1,NEBINI | |
21358 | DO 2 IQ=1,NQBINI | |
21359 | SIGTOT = ZERO | |
21360 | SIGELA = ZERO | |
21361 | SIGQEP = ZERO | |
21362 | SIGQET = ZERO | |
21363 | SIGQE2 = ZERO | |
21364 | SIGPRO = ZERO | |
21365 | SIGDEL = ZERO | |
21366 | SIGDQE = ZERO | |
21367 | ERRTOT = ZERO | |
21368 | ERRELA = ZERO | |
21369 | ERRQEP = ZERO | |
21370 | ERRQET = ZERO | |
21371 | ERRQE2 = ZERO | |
21372 | ERRPRO = ZERO | |
21373 | ERRDEL = ZERO | |
21374 | ERRDQE = ZERO | |
21375 | IF (NCOMPO.GT.0) THEN | |
21376 | DO 3 IC=1,NCOMPO | |
21377 | SIGTOT = SIGTOT+EMUFRA(IC)*XSTOT(IE,IQ,IC) | |
21378 | SIGELA = SIGELA+EMUFRA(IC)*XSELA(IE,IQ,IC) | |
21379 | SIGQEP = SIGQEP+EMUFRA(IC)*XSQEP(IE,IQ,IC) | |
21380 | SIGQET = SIGQET+EMUFRA(IC)*XSQET(IE,IQ,IC) | |
21381 | SIGQE2 = SIGQE2+EMUFRA(IC)*XSQE2(IE,IQ,IC) | |
21382 | SIGPRO = SIGPRO+EMUFRA(IC)*XSPRO(IE,IQ,IC) | |
21383 | SIGDEL = SIGDEL+EMUFRA(IC)*XSDEL(IE,IQ,IC) | |
21384 | SIGDQE = SIGDQE+EMUFRA(IC)*XSDQE(IE,IQ,IC) | |
21385 | ERRTOT = ERRTOT+XETOT(IE,IQ,IC)**2 | |
21386 | ERRELA = ERRELA+XEELA(IE,IQ,IC)**2 | |
21387 | ERRQEP = ERRQEP+XEQEP(IE,IQ,IC)**2 | |
21388 | ERRQET = ERRQET+XEQET(IE,IQ,IC)**2 | |
21389 | ERRQE2 = ERRQE2+XEQE2(IE,IQ,IC)**2 | |
21390 | ERRPRO = ERRPRO+XEPRO(IE,IQ,IC)**2 | |
21391 | ERRDEL = ERRDEL+XEDEL(IE,IQ,IC)**2 | |
21392 | ERRDQE = ERRDQE+XEDQE(IE,IQ,IC)**2 | |
21393 | 3 CONTINUE | |
21394 | ERRTOT = SQRT(ERRTOT) | |
21395 | ERRELA = SQRT(ERRELA) | |
21396 | ERRQEP = SQRT(ERRQEP) | |
21397 | ERRQET = SQRT(ERRQET) | |
21398 | ERRQE2 = SQRT(ERRQE2) | |
21399 | ERRPRO = SQRT(ERRPRO) | |
21400 | ERRDEL = SQRT(ERRDEL) | |
21401 | ERRDQE = SQRT(ERRDQE) | |
21402 | ELSE | |
21403 | SIGTOT = XSTOT(IE,IQ,1) | |
21404 | SIGELA = XSELA(IE,IQ,1) | |
21405 | SIGQEP = XSQEP(IE,IQ,1) | |
21406 | SIGQET = XSQET(IE,IQ,1) | |
21407 | SIGQE2 = XSQE2(IE,IQ,1) | |
21408 | SIGPRO = XSPRO(IE,IQ,1) | |
21409 | SIGDEL = XSDEL(IE,IQ,1) | |
21410 | SIGDQE = XSDQE(IE,IQ,1) | |
21411 | ERRTOT = XETOT(IE,IQ,1) | |
21412 | ERRELA = XEELA(IE,IQ,1) | |
21413 | ERRQEP = XEQEP(IE,IQ,1) | |
21414 | ERRQET = XEQET(IE,IQ,1) | |
21415 | ERRQE2 = XEQE2(IE,IQ,1) | |
21416 | ERRPRO = XEPRO(IE,IQ,1) | |
21417 | ERRDEL = XEDEL(IE,IQ,1) | |
21418 | ERRDQE = XEDQE(IE,IQ,1) | |
21419 | ENDIF | |
21420 | IF (MCGENE.NE.4) THEN | |
21421 | WRITE(LOUT,1000) ECMNN(IE),Q2G(IQ) | |
21422 | 1000 FORMAT(/,1X,'E_cm =',F9.1,' GeV Q^2 =',F6.1,' GeV^2 :',/) | |
21423 | WRITE(LOUT,1001) SIGTOT,ERRTOT | |
21424 | 1001 FORMAT(1X,'total',32X,F10.4,' +-',F11.5,' mb') | |
21425 | WRITE(LOUT,1002) SIGELA,ERRELA | |
21426 | 1002 FORMAT(1X,'elastic',30X,F10.4,' +-',F11.5,' mb') | |
21427 | WRITE(LOUT,1003) SIGQEP,ERRQEP | |
21428 | 1003 FORMAT(1X,'quasi-elastic (A+B-->A+X)',12X,F10.4,' +-', | |
21429 | & F11.5,' mb') | |
21430 | WRITE(LOUT,1004) SIGQET,ERRQET | |
21431 | 1004 FORMAT(1X,'quasi-elastic (A+B-->X+B)',12X,F10.4,' +-', | |
21432 | & F11.5,' mb') | |
21433 | WRITE(LOUT,1005) SIGQE2,ERRQE2 | |
21434 | 1005 FORMAT(1X,'quasi-elastic (A+B-->X, excl. 2-4)',3X,F10.4, | |
21435 | & ' +-',F11.5,' mb') | |
21436 | WRITE(LOUT,1006) SIGPRO,ERRPRO | |
21437 | 1006 FORMAT(1X,'production',27X,F10.4,' +-',F11.5,' mb') | |
21438 | WRITE(LOUT,1007) SIGDEL,ERRDEL | |
21439 | 1007 FORMAT(1X,'diff-el ',27X,F10.4,' +-',F11.5,' mb') | |
21440 | WRITE(LOUT,1008) SIGDQE,ERRDQE | |
21441 | 1008 FORMAT(1X,'diff-qel ',27X,F10.4,' +-',F11.5,' mb') | |
21442 | ENDIF | |
21443 | ||
21444 | 2 CONTINUE | |
21445 | 1 CONTINUE | |
21446 | ||
21447 | RETURN | |
21448 | END | |
21449 | ||
21450 | *$ CREATE DT_SIGGA.FOR | |
21451 | *COPY DT_SIGGA | |
21452 | * | |
21453 | *===sigga==============================================================* | |
21454 | * | |
21455 | SUBROUTINE DT_SIGGA(NTI,XI,Q2I,ECMI,XNUI,STOT,ETOT,SIN,EIN,STOT0) | |
21456 | ||
21457 | ************************************************************************ | |
21458 | * Total/inelastic photon-nucleus cross sections. * | |
21459 | * !!!! Overwrites SHMAKI-initialization. Do not use it during * | |
21460 | * production runs !!!! * | |
21461 | * This version dated 27.03.96 is written by S. Roesler * | |
21462 | ************************************************************************ | |
21463 | ||
21464 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
21465 | SAVE | |
21466 | ||
21467 | PARAMETER ( LINP = 10 , | |
21468 | & LOUT = 6 , | |
21469 | & LDAT = 9 ) | |
21470 | ||
21471 | PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10, | |
21472 | & OHALF=0.5D0,ONE=1.0D0) | |
21473 | PARAMETER (AMPROT = 0.938D0) | |
21474 | ||
21475 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
21476 | ||
21477 | * Glauber formalism: cross sections | |
21478 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
21479 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
21480 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
21481 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
21482 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
21483 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
21484 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
21485 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
21486 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
21487 | & BSLOPE,NEBINI,NQBINI | |
21488 | ||
21489 | NT = NTI | |
21490 | X = XI | |
21491 | Q2 = Q2I | |
21492 | ECM = ECMI | |
21493 | XNU = XNUI | |
21494 | IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO)) | |
21495 | & ECM = SQRT(AMPROT**2-Q2+2.0D0*XNUI*AMPROT) | |
21496 | CALL DT_XSGLAU(1,NT,7,X,Q2,ECM,1,1,-1) | |
21497 | STOT = XSTOT(1,1,1) | |
21498 | ETOT = XETOT(1,1,1) | |
21499 | SIN = XSPRO(1,1,1) | |
21500 | EIN = XEPRO(1,1,1) | |
21501 | ||
21502 | RETURN | |
21503 | END | |
21504 | ||
21505 | *$ CREATE DT_SIGGAT.FOR | |
21506 | *COPY DT_SIGGAT | |
21507 | * | |
21508 | *===siggat=============================================================* | |
21509 | * | |
21510 | SUBROUTINE DT_SIGGAT(Q2I,ECMI,STOT,NT) | |
21511 | ||
21512 | ************************************************************************ | |
21513 | * Total/inelastic photon-nucleus cross sections. * | |
21514 | * Uses pre-tabulated cross section. * | |
21515 | * This version dated 29.07.96 is written by S. Roesler * | |
21516 | ************************************************************************ | |
21517 | ||
21518 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
21519 | SAVE | |
21520 | ||
21521 | PARAMETER ( LINP = 10 , | |
21522 | & LOUT = 6 , | |
21523 | & LDAT = 9 ) | |
21524 | ||
21525 | PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14, | |
21526 | & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0) | |
21527 | ||
21528 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
21529 | ||
21530 | * Glauber formalism: cross sections | |
21531 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
21532 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
21533 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
21534 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
21535 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
21536 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
21537 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
21538 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
21539 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
21540 | & BSLOPE,NEBINI,NQBINI | |
21541 | ||
21542 | NTARG = ABS(NT) | |
21543 | I1 = 1 | |
21544 | I2 = 1 | |
21545 | RATE = ONE | |
21546 | IF (NEBINI.GT.1) THEN | |
21547 | IF (ECMI.GE.ECMNN(NEBINI)) THEN | |
21548 | I1 = NEBINI | |
21549 | I2 = NEBINI | |
21550 | RATE = ONE | |
21551 | ELSEIF (ECMI.GT.ECMNN(1)) THEN | |
21552 | DO 1 I=2,NEBINI | |
21553 | IF (ECMI.LT.ECMNN(I)) THEN | |
21554 | I1 = I-1 | |
21555 | I2 = I | |
21556 | RATE = (ECMI-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1)) | |
21557 | GOTO 2 | |
21558 | ENDIF | |
21559 | 1 CONTINUE | |
21560 | 2 CONTINUE | |
21561 | ENDIF | |
21562 | ENDIF | |
21563 | J1 = 1 | |
21564 | J2 = 1 | |
21565 | RATQ = ONE | |
21566 | IF (NQBINI.GT.1) THEN | |
21567 | IF (Q2I.GE.Q2G(NQBINI)) THEN | |
21568 | J1 = NQBINI | |
21569 | J2 = NQBINI | |
21570 | RATQ = ONE | |
21571 | ELSEIF (Q2I.GT.Q2G(1)) THEN | |
21572 | DO 3 I=2,NQBINI | |
21573 | IF (Q2I.LT.Q2G(I)) THEN | |
21574 | J1 = I-1 | |
21575 | J2 = I | |
21576 | RATQ = LOG10( Q2I/MAX(Q2G(J1),TINY14))/ | |
21577 | & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14)) | |
21578 | C RATQ = (Q2I-Q2G(J1))/(Q2G(J2)-Q2G(J1)) | |
21579 | GOTO 4 | |
21580 | ENDIF | |
21581 | 3 CONTINUE | |
21582 | 4 CONTINUE | |
21583 | ENDIF | |
21584 | ENDIF | |
21585 | ||
21586 | STOT = XSTOT(I1,J1,NTARG)+ | |
21587 | & RATE*(XSTOT(I2,J1,NTARG)-XSTOT(I1,J1,NTARG))+ | |
21588 | & RATQ*(XSTOT(I1,J2,NTARG)-XSTOT(I1,J1,NTARG))+ | |
21589 | & RATE*RATQ*(XSTOT(I2,J2,NTARG)-XSTOT(I1,J2,NTARG)+ | |
21590 | & XSTOT(I1,J1,NTARG)-XSTOT(I2,J1,NTARG)) | |
21591 | ||
21592 | RETURN | |
21593 | END | |
21594 | ||
21595 | *$ CREATE DT_SANO.FOR | |
21596 | *COPY DT_SANO | |
21597 | * | |
21598 | *===sigano=============================================================* | |
21599 | * | |
21600 | DOUBLE PRECISION FUNCTION DT_SANO(ECM) | |
21601 | ||
21602 | ************************************************************************ | |
21603 | * This version dated 31.07.96 is written by S. Roesler * | |
21604 | ************************************************************************ | |
21605 | ||
21606 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
21607 | SAVE | |
21608 | ||
21609 | PARAMETER ( LINP = 10 , | |
21610 | & LOUT = 6 , | |
21611 | & LDAT = 9 ) | |
21612 | ||
21613 | PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14, | |
21614 | & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0) | |
21615 | PARAMETER (NE = 8) | |
21616 | ||
21617 | * VDM parameter for photon-nucleus interactions | |
21618 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
21619 | ||
21620 | * properties of interacting particles | |
21621 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
21622 | ||
21623 | DIMENSION ECMANO(NE),FRAANO(NE),SIGHRD(NE) | |
21624 | DATA ECMANO / | |
21625 | & 0.200D+02,0.500D+02,0.100D+03,0.200D+03,0.500D+03, | |
21626 | & 0.100D+04,0.200D+04,0.500D+04 | |
21627 | & / | |
21628 | * fixed cut (3 GeV/c) | |
21629 | DATA FRAANO / | |
21630 | & 0.085D+00,0.114D+00,0.105D+00,0.091D+00,0.073D+00, | |
21631 | & 0.062D+00,0.054D+00,0.042D+00 | |
21632 | & / | |
21633 | DATA SIGHRD / | |
21634 | & 4.0099D-04,3.3104D-03,1.1905D-02,3.6435D-02,1.3493D-01, | |
21635 | & 3.3086D-01,7.6255D-01,2.1319D+00 | |
21636 | & / | |
21637 | * running cut (based on obsolete Phojet-caluclations, bugs..) | |
21638 | C DATA FRAANO / | |
21639 | C & 0.251E+00,0.313E+00,0.279E+00,0.239E+00,0.186E+00, | |
21640 | C & 0.167E+00,0.150E+00,0.131E+00 | |
21641 | C & / | |
21642 | C DATA SIGHRD / | |
21643 | C & 6.6569E-04,4.4949E-03,1.4837E-02,4.1466E-02,1.5071E-01, | |
21644 | C & 2.5736E-01,4.5593E-01,8.2550E-01 | |
21645 | C & / | |
21646 | ||
21647 | DT_SANO = ZERO | |
21648 | IF ((ISHAD(2).NE.1).OR.(IJPROJ.NE.7)) RETURN | |
21649 | J1 = 0 | |
21650 | J2 = 0 | |
21651 | RATE = ONE | |
21652 | IF (ECM.GE.ECMANO(NE)) THEN | |
21653 | J1 = NE | |
21654 | J2 = NE | |
21655 | ELSEIF (ECM.GT.ECMANO(1)) THEN | |
21656 | DO 1 IE=2,NE | |
21657 | IF (ECM.LT.ECMANO(IE)) THEN | |
21658 | J1 = IE-1 | |
21659 | J2 = IE | |
21660 | RATE = LOG10(ECM/ECMANO(J1))/LOG10(ECMANO(J2)/ECMANO(J1)) | |
21661 | GOTO 2 | |
21662 | ENDIF | |
21663 | 1 CONTINUE | |
21664 | 2 CONTINUE | |
21665 | ENDIF | |
21666 | IF ((J1.GT.0).AND.(J2.GT.0)) THEN | |
21667 | AFRA1 = LOG10(MAX(FRAANO(J1)*SIGHRD(J1),TINY14)) | |
21668 | AFRA2 = LOG10(MAX(FRAANO(J2)*SIGHRD(J2),TINY14)) | |
21669 | DT_SANO = 10.0D0**(AFRA1+RATE*(AFRA2-AFRA1)) | |
21670 | ENDIF | |
21671 | ||
21672 | RETURN | |
21673 | END | |
21674 | ||
21675 | *$ CREATE DT_SIGGP.FOR | |
21676 | *COPY DT_SIGGP | |
21677 | * | |
21678 | *===siggp==============================================================* | |
21679 | * | |
21680 | SUBROUTINE DT_SIGGP(XI,Q2I,ECMI,XNUI,STOT,SINE,SDIR) | |
21681 | ||
21682 | ************************************************************************ | |
21683 | * Total/inelastic photon-nucleon cross sections. * | |
21684 | * This version dated 30.04.96 is written by S. Roesler * | |
21685 | ************************************************************************ | |
21686 | ||
21687 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
21688 | SAVE | |
21689 | ||
21690 | PARAMETER ( LINP = 10 , | |
21691 | & LOUT = 6 , | |
21692 | & LDAT = 9 ) | |
21693 | ||
21694 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) | |
21695 | PARAMETER (TWOPI = 6.283185307179586476925286766559D+00, | |
21696 | & PI = TWOPI/TWO, | |
21697 | & GEV2MB = 0.38938D0, | |
21698 | & ALPHEM = ONE/137.0D0) | |
21699 | ||
21700 | * particle properties (BAMJET index convention) | |
21701 | CHARACTER*8 ANAME | |
21702 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
21703 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
21704 | ||
21705 | * VDM parameter for photon-nucleus interactions | |
21706 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
21707 | ||
21708 | **PHOJET105a | |
21709 | C CHARACTER*8 MDLNA | |
21710 | C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100) | |
21711 | C PARAMETER (IEETAB=10) | |
21712 | C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX | |
21713 | **PHOJET110 | |
21714 | ||
21715 | C model switches and parameters | |
21716 | CHARACTER*8 MDLNA | |
21717 | INTEGER ISWMDL,IPAMDL | |
21718 | DOUBLE PRECISION PARMDL | |
21719 | COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400) | |
21720 | ||
21721 | C energy-interpolation table | |
21722 | INTEGER IEETA2 | |
21723 | PARAMETER ( IEETA2 = 20 ) | |
21724 | INTEGER ISIMAX | |
21725 | DOUBLE PRECISION SIGTAB,SIGECM | |
21726 | COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX | |
21727 | ** | |
21728 | ||
21729 | C PARAMETER (NPOINT=80) | |
21730 | PARAMETER (NPOINT=16) | |
21731 | DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT) | |
21732 | ||
21733 | STOT = ZERO | |
21734 | SINE = ZERO | |
21735 | SDIR = ZERO | |
21736 | ||
21737 | W2 = ECMI**2 | |
21738 | IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO)) | |
21739 | & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1) | |
21740 | Q2 = Q2I | |
21741 | X = XI | |
21742 | * photoprod. | |
21743 | IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN | |
21744 | Q2 = 0.0001D0 | |
21745 | X = Q2/(W2+Q2-AAM(1)**2) | |
21746 | * DIS | |
21747 | ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN | |
21748 | X = Q2/(W2+Q2-AAM(1)**2) | |
21749 | ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN | |
21750 | Q2 = (W2-AAM(1)**2)*X/(ONE-X) | |
21751 | ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN | |
21752 | W2 = Q2*(ONE-X)/X+AAM(1)**2 | |
21753 | ELSE | |
21754 | WRITE(LOUT,*) 'SIGGP: inconsistent input ',W2,Q2,X | |
21755 | STOP | |
21756 | ENDIF | |
21757 | ECM = SQRT(W2) | |
21758 | ||
21759 | IF (MODEGA.EQ.1) THEN | |
21760 | SCALE = SQRT(Q2) | |
21761 | CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2, | |
21762 | & IDPDF) | |
21763 | C W = SQRT(W2) | |
21764 | ||
21765 | C ALLMF2 = PHO_ALLM97(Q2,W) | |
21766 | ||
21767 | C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2 | |
21768 | STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB | |
21769 | SINE = ZERO | |
21770 | SDIR = ZERO | |
21771 | ELSEIF (MODEGA.EQ.2) THEN | |
21772 | IF (INTRGE(1).EQ.1) THEN | |
21773 | AMLO2 = (3.0D0*AAM(13))**2 | |
21774 | ELSEIF (INTRGE(1).EQ.2) THEN | |
21775 | AMLO2 = AAM(33)**2 | |
21776 | ELSE | |
21777 | AMLO2 = AAM(96)**2 | |
21778 | ENDIF | |
21779 | IF (INTRGE(2).EQ.1) THEN | |
21780 | AMHI2 = W2/TWO | |
21781 | ELSEIF (INTRGE(2).EQ.2) THEN | |
21782 | AMHI2 = W2/4.0D0 | |
21783 | ELSE | |
21784 | AMHI2 = W2 | |
21785 | ENDIF | |
21786 | AMHI20 = (ECM-AAM(1))**2 | |
21787 | IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20 | |
21788 | XAMLO = LOG( AMLO2+Q2 ) | |
21789 | XAMHI = LOG( AMHI2+Q2 ) | |
21790 | **PHOJET105a | |
21791 | C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT) | |
21792 | **PHOJET112 | |
21793 | ||
21794 | CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT) | |
21795 | ||
21796 | ** | |
21797 | SUM = ZERO | |
21798 | DO 1 J=1,NPOINT | |
21799 | AM2 = EXP(ABSZX(J))-Q2 | |
21800 | IF (AM2.LT.16.0D0) THEN | |
21801 | R = TWO | |
21802 | ELSEIF ((AM2.GE.16.0D0).AND.(AM2.LT.121.0D0)) THEN | |
21803 | R = 10.0D0/3.0D0 | |
21804 | ELSE | |
21805 | R = 11.0D0/3.0D0 | |
21806 | ENDIF | |
21807 | C FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) ) | |
21808 | FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) ) | |
21809 | & * (ONE+EPSPOL*Q2/AM2) | |
21810 | SUM = SUM+WEIGHT(J)*FAC | |
21811 | 1 CONTINUE | |
21812 | SINE = SUM | |
21813 | SDIR = DT_SIGVP(X,Q2) | |
21814 | STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*SDIR | |
21815 | SDIR = SDIR/(0.588D0+RL2+Q2) | |
21816 | C STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*DT_SIGVP(X,Q2) | |
21817 | ELSEIF (MODEGA.EQ.3) THEN | |
21818 | CALL DT_SIGGA(1,XI,Q2I,ECMI,ZERO,STOT,ETOT,SINE,EINE,DUM) | |
21819 | ELSEIF (MODEGA.EQ.4) THEN | |
21820 | * load cross sections from PHOJET interpolation table | |
21821 | IP = 1 | |
21822 | IF(ECM.LE.SIGECM(IP,1)) THEN | |
21823 | I1 = 1 | |
21824 | I2 = 1 | |
21825 | ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN | |
21826 | DO 2 I=2,ISIMAX | |
21827 | IF (ECM.LE.SIGECM(IP,I)) GOTO 3 | |
21828 | 2 CONTINUE | |
21829 | 3 CONTINUE | |
21830 | I1 = I-1 | |
21831 | I2 = I | |
21832 | ELSE | |
21833 | WRITE(LOUT,'(/1X,A,2E12.3)') | |
21834 | & 'SIGGP:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX) | |
21835 | I1 = ISIMAX | |
21836 | I2 = ISIMAX | |
21837 | ENDIF | |
21838 | FAC2 = ZERO | |
21839 | IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1)) | |
21840 | & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1)) | |
21841 | FAC1 = ONE-FAC2 | |
21842 | * cross section dependence on photon virtuality | |
21843 | FSUP1 = ZERO | |
21844 | DO 4 I=1,3 | |
21845 | FSUP1 = FSUP1+PARMDL(26+I)*(1.D0+Q2/(4.D0*PARMDL(30+I))) | |
21846 | & /(1.D0+Q2/PARMDL(30+I))**2 | |
21847 | 4 CONTINUE | |
21848 | FSUP1 = FSUP1+PARMDL(30)/(1.D0+Q2/PARMDL(34)) | |
21849 | FAC1 = FAC1*FSUP1 | |
21850 | FAC2 = FAC2*FSUP1 | |
21851 | FSUP2 = 1.0D0 | |
21852 | STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1) | |
21853 | SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1) | |
21854 | SDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1) | |
21855 | **re: | |
21856 | STOT = STOT-SDIR | |
21857 | ** | |
21858 | SDIR = SDIR/(FSUP1*FSUP2) | |
21859 | **re: | |
21860 | STOT = STOT+SDIR | |
21861 | ** | |
21862 | ENDIF | |
21863 | ||
21864 | RETURN | |
21865 | END | |
21866 | ||
21867 | *$ CREATE DT_SIGVEL.FOR | |
21868 | *COPY DT_SIGVEL | |
21869 | * | |
21870 | *===sigvel=============================================================* | |
21871 | * | |
21872 | SUBROUTINE DT_SIGVEL(XI,Q2I,ECMI,XNUI,IDXV,SVEL,SIG1,SIG2) | |
21873 | ||
21874 | ************************************************************************ | |
21875 | * Cross section for elastic vector meson production * | |
21876 | * This version dated 10.05.96 is written by S. Roesler * | |
21877 | ************************************************************************ | |
21878 | ||
21879 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
21880 | SAVE | |
21881 | ||
21882 | PARAMETER ( LINP = 10 , | |
21883 | & LOUT = 6 , | |
21884 | & LDAT = 9 ) | |
21885 | ||
21886 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) | |
21887 | PARAMETER (TWOPI = 6.283185307179586476925286766559D+00, | |
21888 | & PI = TWOPI/TWO, | |
21889 | & GEV2MB = 0.38938D0, | |
21890 | & ALPHEM = ONE/137.0D0) | |
21891 | ||
21892 | * particle properties (BAMJET index convention) | |
21893 | CHARACTER*8 ANAME | |
21894 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
21895 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
21896 | ||
21897 | * VDM parameter for photon-nucleus interactions | |
21898 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
21899 | ||
21900 | W2 = ECMI**2 | |
21901 | IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO)) | |
21902 | & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1) | |
21903 | Q2 = Q2I | |
21904 | X = XI | |
21905 | * photoprod. | |
21906 | IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN | |
21907 | Q2 = 0.0001D0 | |
21908 | X = Q2/(W2+Q2-AAM(1)**2) | |
21909 | * DIS | |
21910 | ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN | |
21911 | X = Q2/(W2+Q2-AAM(1)**2) | |
21912 | ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN | |
21913 | Q2 = (W2-AAM(1)**2)*X/(ONE-X) | |
21914 | ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN | |
21915 | W2 = Q2*(ONE-X)/X+AAM(1)**2 | |
21916 | ELSE | |
21917 | WRITE(LOUT,*) 'SIGVEL: inconsistent input ',W2,Q2,X | |
21918 | STOP | |
21919 | ENDIF | |
21920 | ECM = SQRT(W2) | |
21921 | ||
21922 | AMV = AAM(IDXV) | |
21923 | AMV2 = AMV**2 | |
21924 | ||
21925 | BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2) | |
21926 | & +0.25D0*LOG(W2/(AMV2+Q2)))*GEV2MB | |
21927 | ROSH = 0.1D0 | |
21928 | STOVP = DT_SIGVP(X,Q2)/(AMV2+Q2+RL2) | |
21929 | SELVP = STOVP**2*(ONE+ROSH**2)/(8.0D0*TWOPI*BSLOPE) | |
21930 | ||
21931 | IF (IDXV.EQ.33) THEN | |
21932 | COUPL = 0.00365D0 | |
21933 | ELSE | |
21934 | STOP | |
21935 | ENDIF | |
21936 | SIG1 = (AMV2/(AMV2+Q2))**2 * (ONE+EPSPOL*Q2/AMV2) | |
21937 | SIG2 = SELVP | |
21938 | SVEL = COUPL * (AMV2/(AMV2+Q2))**2 | |
21939 | & * (ONE+EPSPOL*Q2/AMV2) * SELVP | |
21940 | ||
21941 | RETURN | |
21942 | END | |
21943 | ||
21944 | *$ CREATE DT_SIGVP.FOR | |
21945 | *COPY DT_SIGVP | |
21946 | * | |
21947 | *===sigvp==============================================================* | |
21948 | * | |
21949 | DOUBLE PRECISION FUNCTION DT_SIGVP(XI,Q2I) | |
21950 | ||
21951 | ************************************************************************ | |
21952 | * sigma_Vp * | |
21953 | ************************************************************************ | |
21954 | ||
21955 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
21956 | SAVE | |
21957 | ||
21958 | PARAMETER ( LINP = 10 , | |
21959 | & LOUT = 6 , | |
21960 | & LDAT = 9 ) | |
21961 | ||
21962 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) | |
21963 | PARAMETER (TWOPI = 6.283185307179586476925286766559D+00, | |
21964 | & PI = TWOPI/TWO, | |
21965 | & GEV2MB = 0.38938D0, | |
21966 | & AMPROT = 0.938D0, | |
21967 | & ALPHEM = ONE/137.0D0) | |
21968 | ||
21969 | * VDM parameter for photon-nucleus interactions | |
21970 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
21971 | ||
21972 | X = XI | |
21973 | Q2 = Q2I | |
21974 | IF (XI.LE.ZERO) X = 0.0001D0 | |
21975 | IF (Q2I.LE.ZERO) Q2 = 0.0001D0 | |
21976 | ||
21977 | ECM = SQRT( Q2*(ONE-X)/X+AMPROT**2 ) | |
21978 | ||
21979 | SCALE = SQRT(Q2) | |
21980 | IF (MODEGA.EQ.1) THEN | |
21981 | CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2, | |
21982 | & IDPDF) | |
21983 | C W = ECM | |
21984 | ||
21985 | C ALLMF2 = PHO_ALLM97(Q2,W) | |
21986 | ||
21987 | C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2 | |
21988 | C STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB | |
21989 | C DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2)) | |
21990 | DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))*GEV2MB | |
21991 | ELSEIF (MODEGA.EQ.4) THEN | |
21992 | CALL DT_SIGGP(X,Q2,ECM,DUM1,STOT,DUM2,DUM3) | |
21993 | C F2 = Q2*(ONE-X)/(TWOPI**2*ALPHEM*GEV2MB) * STOT | |
21994 | DT_SIGVP = 3.0D0*PI/(ALPHEM*DT_RRM2(X,Q2)) * STOT | |
21995 | ELSE | |
21996 | STOP ' DT_SIGVP: F2 not defined for this MODEGA !' | |
21997 | ENDIF | |
21998 | ||
21999 | RETURN | |
22000 | ||
22001 | END | |
22002 | ||
22003 | *$ CREATE DT_RRM2.FOR | |
22004 | *COPY DT_RRM2 | |
22005 | * | |
22006 | *===RRM2===============================================================* | |
22007 | * | |
22008 | DOUBLE PRECISION FUNCTION DT_RRM2(X,Q2) | |
22009 | ||
22010 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
22011 | SAVE | |
22012 | ||
22013 | PARAMETER ( LINP = 10 , | |
22014 | & LOUT = 6 , | |
22015 | & LDAT = 9 ) | |
22016 | ||
22017 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) | |
22018 | PARAMETER (TWOPI = 6.283185307179586476925286766559D+00, | |
22019 | & PI = TWOPI/TWO, | |
22020 | & GEV2MB = 0.38938D0) | |
22021 | ||
22022 | * particle properties (BAMJET index convention) | |
22023 | CHARACTER*8 ANAME | |
22024 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
22025 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
22026 | ||
22027 | * VDM parameter for photon-nucleus interactions | |
22028 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
22029 | ||
22030 | S = Q2*(ONE-X)/X+AAM(1)**2 | |
22031 | ECM = SQRT(S) | |
22032 | ||
22033 | IF (INTRGE(1).EQ.1) THEN | |
22034 | AMLO2 = (3.0D0*AAM(13))**2 | |
22035 | ELSEIF (INTRGE(1).EQ.2) THEN | |
22036 | AMLO2 = AAM(33)**2 | |
22037 | ELSE | |
22038 | AMLO2 = AAM(96)**2 | |
22039 | ENDIF | |
22040 | IF (INTRGE(2).EQ.1) THEN | |
22041 | AMHI2 = S/TWO | |
22042 | ELSEIF (INTRGE(2).EQ.2) THEN | |
22043 | AMHI2 = S/4.0D0 | |
22044 | ELSE | |
22045 | AMHI2 = S | |
22046 | ENDIF | |
22047 | AMHI20 = (ECM-AAM(1))**2 | |
22048 | IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20 | |
22049 | ||
22050 | AM1C2 = 16.0D0 | |
22051 | AM2C2 = 121.0D0 | |
22052 | IF (AMHI2.LE.AM1C2) THEN | |
22053 | DT_RRM2 = TWO*DT_RM2(AMLO2,AMHI2,Q2) | |
22054 | ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN | |
22055 | DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+ | |
22056 | & 10.0D0/3.0D0*DT_RM2(AM1C2,AMHI2,Q2) | |
22057 | ELSE | |
22058 | DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+ | |
22059 | & 10.0D0/3.0D0*DT_RM2(AM1C2,AM2C2,Q2)+ | |
22060 | & 11.0D0/3.0D0*DT_RM2(AM2C2,AMHI2,Q2) | |
22061 | ENDIF | |
22062 | ||
22063 | RETURN | |
22064 | END | |
22065 | ||
22066 | *$ CREATE DT_RM2.FOR | |
22067 | *COPY DT_RM2 | |
22068 | * | |
22069 | *===RM2================================================================* | |
22070 | * | |
22071 | DOUBLE PRECISION FUNCTION DT_RM2(AMLO2,AMHI2,Q2) | |
22072 | ||
22073 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
22074 | SAVE | |
22075 | ||
22076 | PARAMETER ( LINP = 10 , | |
22077 | & LOUT = 6 , | |
22078 | & LDAT = 9 ) | |
22079 | ||
22080 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) | |
22081 | PARAMETER (TWOPI = 6.283185307179586476925286766559D+00, | |
22082 | & PI = TWOPI/TWO, | |
22083 | & GEV2MB = 0.38938D0) | |
22084 | ||
22085 | * VDM parameter for photon-nucleus interactions | |
22086 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
22087 | ||
22088 | IF (RL2.LE.ZERO) THEN | |
22089 | DT_RM2 = -ONE/(AMHI2+Q2)+Q2/(TWO*(AMHI2+Q2)**2) - | |
22090 | & (-ONE/(AMLO2+Q2)+Q2/(TWO*(AMLO2+Q2)**2)) | |
22091 | & +EPSPOL*(-Q2/(TWO*(AMHI2+Q2)**2)+Q2/(TWO*(AMLO2+Q2)**2)) | |
22092 | ELSE | |
22093 | TMPMLO = LOG(ONE+RL2/(AMLO2+Q2)) | |
22094 | TMPMHI = LOG(ONE+RL2/(AMHI2+Q2)) | |
22095 | DT_RM2 = Q2/(RL2*(AMHI2+Q2))-(Q2+RL2)/RL2**2*TMPMHI | |
22096 | & -(Q2/(RL2*(AMLO2+Q2))-(Q2+RL2)/RL2**2*TMPMLO) | |
22097 | & +EPSPOL*( | |
22098 | & -Q2/(RL2*(AMHI2+Q2))+Q2/RL2**2*TMPMHI | |
22099 | & -(-Q2/(RL2*(AMLO2+Q2))+Q2/RL2**2*TMPMLO)) | |
22100 | ENDIF | |
22101 | ||
22102 | RETURN | |
22103 | END | |
22104 | ||
22105 | *$ CREATE DT_SAM2.FOR | |
22106 | *COPY DT_SAM2 | |
22107 | * | |
22108 | *===SAM2===============================================================* | |
22109 | * | |
22110 | DOUBLE PRECISION FUNCTION DT_SAM2(Q2,ECM) | |
22111 | ||
22112 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
22113 | SAVE | |
22114 | ||
22115 | PARAMETER ( LINP = 10 , | |
22116 | & LOUT = 6 , | |
22117 | & LDAT = 9 ) | |
22118 | ||
22119 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0, | |
22120 | & TENTRD=10.0D0/3.0D0,ELVTRD=11.0D0/3.0D0) | |
22121 | PARAMETER (TWOPI = 6.283185307179586476925286766559D+00, | |
22122 | & PI = TWOPI/TWO, | |
22123 | & GEV2MB = 0.38938D0) | |
22124 | ||
22125 | * particle properties (BAMJET index convention) | |
22126 | CHARACTER*8 ANAME | |
22127 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
22128 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
22129 | ||
22130 | * VDM parameter for photon-nucleus interactions | |
22131 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
22132 | ||
22133 | S = ECM**2 | |
22134 | IF (INTRGE(1).EQ.1) THEN | |
22135 | AMLO2 = (3.0D0*AAM(13))**2 | |
22136 | ELSEIF (INTRGE(1).EQ.2) THEN | |
22137 | AMLO2 = AAM(33)**2 | |
22138 | ELSE | |
22139 | AMLO2 = AAM(96)**2 | |
22140 | ENDIF | |
22141 | IF (INTRGE(2).EQ.1) THEN | |
22142 | AMHI2 = S/TWO | |
22143 | ELSEIF (INTRGE(2).EQ.2) THEN | |
22144 | AMHI2 = S/4.0D0 | |
22145 | ELSE | |
22146 | AMHI2 = S | |
22147 | ENDIF | |
22148 | AMHI20 = (ECM-AAM(1))**2 | |
22149 | IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20 | |
22150 | ||
22151 | AM1C2 = 16.0D0 | |
22152 | AM2C2 = 121.0D0 | |
22153 | YLO = LOG(AMLO2+Q2) | |
22154 | YC1 = LOG(AM1C2+Q2) | |
22155 | YC2 = LOG(AM2C2+Q2) | |
22156 | YHI = LOG(AMHI2+Q2) | |
22157 | IF (AMHI2.LE.AM1C2) THEN | |
22158 | FACHI = TWO | |
22159 | ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN | |
22160 | FACHI = TENTRD | |
22161 | ELSE | |
22162 | FACHI = ELVTRD | |
22163 | ENDIF | |
22164 | ||
22165 | 1 CONTINUE | |
22166 | YSAM2 = YLO+(YHI-YLO)*DT_RNDM(AM1C2) | |
22167 | IF (YSAM2.LE.YC1) THEN | |
22168 | FAC = TWO | |
22169 | ELSEIF ((YSAM2.GT.YC1).AND.(YSAM2.LE.YC2)) THEN | |
22170 | FAC = TENTRD | |
22171 | ELSE | |
22172 | FAC = ELVTRD | |
22173 | ENDIF | |
22174 | WEIGMX = FACHI*(ONE-Q2*EXP( -YHI)) | |
22175 | XSAM2 = FAC *(ONE-Q2*EXP(-YSAM2)) | |
22176 | IF (DT_RNDM(YSAM2)*WEIGMX.GT.XSAM2) GOTO 1 | |
22177 | ||
22178 | DT_SAM2 = EXP(YSAM2)-Q2 | |
22179 | ||
22180 | RETURN | |
22181 | END | |
22182 | ||
22183 | *$ CREATE DT_CKMT.FOR | |
22184 | *COPY DT_CKMT | |
22185 | * | |
22186 | *===ckmt===============================================================* | |
22187 | * | |
22188 | SUBROUTINE DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL, | |
22189 | & F2,IPAR) | |
22190 | ||
22191 | ************************************************************************ | |
22192 | * This version dated 31.01.96 is written by S. Roesler * | |
22193 | ************************************************************************ | |
22194 | ||
22195 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
22196 | SAVE | |
22197 | ||
22198 | PARAMETER ( LINP = 10 , | |
22199 | & LOUT = 6 , | |
22200 | & LDAT = 9 ) | |
22201 | ||
22202 | PARAMETER (ZERO=0.0D0,TWO=2.0D0,TINY10=1.0D-10) | |
22203 | ||
22204 | PARAMETER (Q02 = 2.0D0, | |
22205 | & DQ2 = 10.05D0, | |
22206 | & Q12 = Q02+DQ2) | |
22207 | ||
22208 | DIMENSION PD(-6:6),SEA(3),VAL(2) | |
22209 | ||
22210 | CALL DT_PDF0(Q02,X,F2Q0,VAL,SEA,GLU,IPAR) | |
22211 | CALL DT_PDF0(Q12,X,F2Q1,VAL,SEA,GLU,IPAR) | |
22212 | ADQ2 = LOG10(Q12)-LOG10(Q02) | |
22213 | F2P = (F2Q1-F2Q0)/ADQ2 | |
22214 | CALL DT_CKMTX(IPAR,X,Q02,PD,F2PQ0) | |
22215 | CALL DT_CKMTX(IPAR,X,Q12,PD,F2PQ1) | |
22216 | F2PP = (F2PQ1-F2PQ0)/ADQ2 | |
22217 | FX = (F2P-F2PP)/(F2PP+LOG(DQ2)*F2PQ0+TINY10)*Q02 | |
22218 | ||
22219 | Q2 = MAX(SCALE**2.0D0,TINY10) | |
22220 | SMOOTH = 1.0D0+FX*(Q2-Q02)/Q2**2 | |
22221 | IF (Q2.LT.Q02) THEN | |
22222 | CALL DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR) | |
22223 | UPV = VAL(1) | |
22224 | DNV = VAL(2) | |
22225 | USEA = SEA(1) | |
22226 | DSEA = SEA(2) | |
22227 | STR = SEA(3) | |
22228 | CHM = 0.0D0 | |
22229 | BOT = 0.0D0 | |
22230 | TOP = 0.0D0 | |
22231 | GL = GLU | |
22232 | ELSE | |
22233 | CALL DT_CKMTX(IPAR,X,Q2,PD,F2) | |
22234 | F2 = F2*SMOOTH | |
22235 | UPV = PD(2)-PD(3) | |
22236 | DNV = PD(1)-PD(3) | |
22237 | USEA = PD(3) | |
22238 | DSEA = PD(3) | |
22239 | STR = PD(3) | |
22240 | CHM = PD(4) | |
22241 | BOT = PD(5) | |
22242 | TOP = PD(6) | |
22243 | GL = PD(0) | |
22244 | C UPV = UPV*SMOOTH | |
22245 | C DNV = DNV*SMOOTH | |
22246 | C USEA = USEA*SMOOTH | |
22247 | C DSEA = DSEA*SMOOTH | |
22248 | C STR = STR*SMOOTH | |
22249 | C CHM = CHM*SMOOTH | |
22250 | C GL = GL*SMOOTH | |
22251 | ENDIF | |
22252 | ||
22253 | RETURN | |
22254 | END | |
22255 | C | |
22256 | ||
22257 | *$ CREATE DT_CKMTX.FOR | |
22258 | *COPY DT_CKMTX | |
22259 | SUBROUTINE DT_CKMTX(IPAR,X,SCALE2,PD,F2) | |
22260 | C********************************************************************** | |
22261 | C | |
22262 | C PDF based on Regge theory, evolved with .... by .... | |
22263 | C | |
22264 | C input: IPAR 2212 proton (not installed) | |
22265 | C 45 Pomeron | |
22266 | C 100 Deuteron | |
22267 | C | |
22268 | C output: PD(-6:6) x*f(x) parton distribution functions | |
22269 | C (PDFLIB convention: d = PD(1), u = PD(2) ) | |
22270 | C | |
22271 | C********************************************************************** | |
22272 | ||
22273 | SAVE | |
22274 | DOUBLE PRECISION X,SCALE2,PD(-6:6),CDN,CUP,F2 | |
22275 | ||
22276 | PARAMETER ( LINP = 10 , | |
22277 | & LOUT = 6 , | |
22278 | & LDAT = 9 ) | |
22279 | ||
22280 | DIMENSION QQ(7) | |
22281 | C | |
22282 | Q2=SNGL(SCALE2) | |
22283 | Q1S=Q2 | |
22284 | XX=SNGL(X) | |
22285 | C QCD lambda for evolution | |
22286 | OWLAM = 0.23D0 | |
22287 | OWLAM2=OWLAM**2 | |
22288 | C Q0**2 for evolution | |
22289 | Q02 = 2.D0 | |
22290 | C | |
22291 | C | |
22292 | C the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=... | |
22293 | C q(6)=x*charm, q(7)=x*gluon | |
22294 | C | |
22295 | SB=0. | |
22296 | IF(Q2-Q02) 1,1,2 | |
22297 | 2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2)) | |
22298 | 1 CONTINUE | |
22299 | IF(IPAR.EQ.2212) THEN | |
22300 | CALL DT_CKMTPR(1,0,XX,SB,QQ(1)) | |
22301 | CALL DT_CKMTPR(2,0,XX,SB,QQ(2)) | |
22302 | CALL DT_CKMTPR(3,0,XX,SB,QQ(3)) | |
22303 | CALL DT_CKMTPR(4,0,XX,SB,QQ(4)) | |
22304 | CALL DT_CKMTPR(5,0,XX,SB,QQ(5)) | |
22305 | CALL DT_CKMTPR(8,0,XX,SB,QQ(6)) | |
22306 | CALL DT_CKMTPR(7,0,XX,SB,QQ(7)) | |
22307 | C ELSEIF (IPAR.EQ.45) THEN | |
22308 | C CALL CKMTPO(1,0,XX,SB,QQ(1)) | |
22309 | C CALL CKMTPO(2,0,XX,SB,QQ(2)) | |
22310 | C CALL CKMTPO(3,0,XX,SB,QQ(3)) | |
22311 | C CALL CKMTPO(4,0,XX,SB,QQ(4)) | |
22312 | C CALL CKMTPO(5,0,XX,SB,QQ(5)) | |
22313 | C CALL CKMTPO(8,0,XX,SB,QQ(6)) | |
22314 | C CALL CKMTPO(7,0,XX,SB,QQ(7)) | |
22315 | ELSEIF (IPAR.EQ.100) THEN | |
22316 | CALL DT_CKMTDE(1,0,XX,SB,QQ(1)) | |
22317 | CALL DT_CKMTDE(2,0,XX,SB,QQ(2)) | |
22318 | CALL DT_CKMTDE(3,0,XX,SB,QQ(3)) | |
22319 | CALL DT_CKMTDE(4,0,XX,SB,QQ(4)) | |
22320 | CALL DT_CKMTDE(5,0,XX,SB,QQ(5)) | |
22321 | CALL DT_CKMTDE(8,0,XX,SB,QQ(6)) | |
22322 | CALL DT_CKMTDE(7,0,XX,SB,QQ(7)) | |
22323 | ELSE | |
22324 | WRITE(LOUT,'(1X,A,I4,A)') | |
22325 | & 'CKMTX: IPAR =',IPAR,' not implemented!' | |
22326 | STOP | |
22327 | ENDIF | |
22328 | C | |
22329 | PD(-6) = 0.D0 | |
22330 | PD(-5) = 0.D0 | |
22331 | PD(-4) = DBLE(QQ(6)) | |
22332 | PD(-3) = DBLE(QQ(3)) | |
22333 | PD(-2) = DBLE(QQ(4)) | |
22334 | PD(-1) = DBLE(QQ(5)) | |
22335 | PD(0) = DBLE(QQ(7)) | |
22336 | PD(1) = DBLE(QQ(2)) | |
22337 | PD(2) = DBLE(QQ(1)) | |
22338 | PD(3) = DBLE(QQ(3)) | |
22339 | PD(4) = DBLE(QQ(6)) | |
22340 | PD(5) = 0.D0 | |
22341 | PD(6) = 0.D0 | |
22342 | IF(IPAR.EQ.45) THEN | |
22343 | CDN = (PD(1)-PD(-1))/2.D0 | |
22344 | CUP = (PD(2)-PD(-2))/2.D0 | |
22345 | PD(-1) = PD(-1) + CDN | |
22346 | PD(-2) = PD(-2) + CUP | |
22347 | PD(1) = PD(-1) | |
22348 | PD(2) = PD(-2) | |
22349 | ENDIF | |
22350 | F2 = 4.0D0/9.0D0*(PD(2)-PD(3)+2.0D0*PD(3))+ | |
22351 | & 1.0D0/9.0D0*(PD(1)-PD(3)+2.0D0*PD(3))+ | |
22352 | & 1.0D0/9.0D0*(2.0D0*PD(3))+4.0D0/9.0D0*(2.0D0*PD(4)) | |
22353 | END | |
22354 | C | |
22355 | ||
22356 | *$ CREATE DT_PDF0.FOR | |
22357 | *COPY DT_PDF0 | |
22358 | * | |
22359 | *===pdf0===============================================================* | |
22360 | * | |
22361 | SUBROUTINE DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR) | |
22362 | ||
22363 | ************************************************************************ | |
22364 | * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 * | |
22365 | * an F_2-ansatz given in Capella et al. PLB 337(1994)358. * | |
22366 | * IPAR = 2212 proton * | |
22367 | * = 100 deuteron * | |
22368 | * This version dated 31.01.96 is written by S. Roesler * | |
22369 | ************************************************************************ | |
22370 | ||
22371 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
22372 | SAVE | |
22373 | ||
22374 | PARAMETER ( LINP = 10 , | |
22375 | & LOUT = 6 , | |
22376 | & LDAT = 9 ) | |
22377 | ||
22378 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9) | |
22379 | ||
22380 | PARAMETER ( | |
22381 | & AA = 0.1502D0, | |
22382 | & BBDEU = 1.2D0, | |
22383 | & BUD = 0.754D0, | |
22384 | & BDD = 0.4495D0, | |
22385 | & BUP = 1.2064D0, | |
22386 | & BDP = 0.1798D0, | |
22387 | & DELTA0 = 0.07684D0, | |
22388 | & D = 1.117D0, | |
22389 | & C = 3.5489D0, | |
22390 | & A = 0.2631D0, | |
22391 | & B = 0.6452D0, | |
22392 | & ALPHAR = 0.415D0, | |
22393 | & E = 0.1D0 | |
22394 | & ) | |
22395 | ||
22396 | PARAMETER (NPOINT=16) | |
22397 | C DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT) | |
22398 | DIMENSION SEA(3),VAL(2) | |
22399 | ||
22400 | DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D)) | |
22401 | AN = 1.5D0*(1.0D0+Q2/(Q2+C)) | |
22402 | * proton, deuteron | |
22403 | IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN | |
22404 | CALL DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0) | |
22405 | SEA(1) = 0.75D0*SEA0 | |
22406 | SEA(2) = SEA(1) | |
22407 | SEA(3) = SEA(1) | |
22408 | VAL(1) = 9.0D0/4.0D0*VALU0 | |
22409 | VAL(2) = 9.0D0*VALD0 | |
22410 | GLU0 = SEA(1)/(1.0D0-X) | |
22411 | F2 = SEA0+VALU0+VALD0 | |
22412 | F2PDF = 4.0D0/9.0D0*(VAL(1)+2.0D0*SEA(1))+ | |
22413 | & 1.0D0/9.0D0*(VAL(2)+2.0D0*SEA(2))+ | |
22414 | & 1.0D0/9.0D0*(2.0D0*SEA(3)) | |
22415 | IF (ABS(F2-F2PDF).GT.TINY9) THEN | |
22416 | WRITE(LOUT,'(1X,A,2E15.5)') 'inconsistent PDF! ',F2,F2PDF | |
22417 | STOP | |
22418 | ENDIF | |
22419 | **PHOJET105a | |
22420 | C CALL GSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT) | |
22421 | **PHOJET112 | |
22422 | ||
22423 | C CALL PHO_GAUSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT) | |
22424 | ||
22425 | ** | |
22426 | C SUMQ = ZERO | |
22427 | C SUMG = ZERO | |
22428 | C DO 1 J=1,NPOINT | |
22429 | C CALL DT_CKMTQ0(Q2,ABSZX(J),IPAR,VALU0,VALD0,SEA0) | |
22430 | C VALU0 = 9.0D0/4.0D0*VALU0 | |
22431 | C VALD0 = 9.0D0*VALD0 | |
22432 | C SEA0 = 0.75D0*SEA0 | |
22433 | C SUMQ = SUMQ+ (VALU0+VALD0+6.0D0*SEA0) *WEIGHT(J) | |
22434 | C SUMG = SUMG+ (SEA0/(1.0D0-ABSZX(J))) *WEIGHT(J) | |
22435 | C 1 CONTINUE | |
22436 | C GLU = GLU0*(1.0D0-SUMQ)/SUMG | |
22437 | ELSE | |
22438 | WRITE(LOUT,'(1X,A,I4,A)') | |
22439 | & 'PDF0: IPAR =',IPAR,' not implemented!' | |
22440 | STOP | |
22441 | ENDIF | |
22442 | ||
22443 | RETURN | |
22444 | END | |
22445 | ||
22446 | *$ CREATE DT_CKMTQ0.FOR | |
22447 | *COPY DT_CKMTQ0 | |
22448 | * | |
22449 | *===ckmtq0=============================================================* | |
22450 | * | |
22451 | SUBROUTINE DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0) | |
22452 | ||
22453 | ************************************************************************ | |
22454 | * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 * | |
22455 | * an F_2-ansatz given in Capella et al. PLB 337(1994)358. * | |
22456 | * IPAR = 2212 proton * | |
22457 | * = 100 deuteron * | |
22458 | * This version dated 31.01.96 is written by S. Roesler * | |
22459 | ************************************************************************ | |
22460 | ||
22461 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
22462 | SAVE | |
22463 | ||
22464 | PARAMETER ( LINP = 10 , | |
22465 | & LOUT = 6 , | |
22466 | & LDAT = 9 ) | |
22467 | ||
22468 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9) | |
22469 | ||
22470 | PARAMETER ( | |
22471 | & AA = 0.1502D0, | |
22472 | & BBDEU = 1.2D0, | |
22473 | & BUD = 0.754D0, | |
22474 | & BDD = 0.4495D0, | |
22475 | & BUP = 1.2064D0, | |
22476 | & BDP = 0.1798D0, | |
22477 | & DELTA0 = 0.07684D0, | |
22478 | & D = 1.117D0, | |
22479 | & C = 3.5489D0, | |
22480 | & A = 0.2631D0, | |
22481 | & B = 0.6452D0, | |
22482 | & ALPHAR = 0.415D0, | |
22483 | & E = 0.1D0 | |
22484 | & ) | |
22485 | ||
22486 | DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D)) | |
22487 | AN = 1.5D0*(1.0D0+Q2/(Q2+C)) | |
22488 | * proton, deuteron | |
22489 | IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN | |
22490 | IF (IPAR.EQ.2212) THEN | |
22491 | BU = BUP | |
22492 | BD = BDP | |
22493 | ELSE | |
22494 | BU = BUD | |
22495 | BD = BDD | |
22496 | ENDIF | |
22497 | SEA0 = AA*X**(-DELTA)*(1.0D0-X)**(AN+4.0D0)* | |
22498 | & (Q2/(Q2+A))**(1.0D0+DELTA) | |
22499 | VALU0 = BU*X**(1.0D0-ALPHAR)*(1.0D0-X)**AN* | |
22500 | & (Q2/(Q2+B))**(ALPHAR) | |
22501 | VALD0 = BD*X**(1.0D0-ALPHAR)*(1.0D0-X)**(AN+1.0D0)* | |
22502 | & (Q2/(Q2+B))**(ALPHAR) | |
22503 | ELSE | |
22504 | WRITE(LOUT,'(1X,A,I4,A)') | |
22505 | & 'CKMTQ0: IPAR =',IPAR,' not implemented!' | |
22506 | STOP | |
22507 | ENDIF | |
22508 | RETURN | |
22509 | END | |
22510 | C | |
22511 | C | |
22512 | ||
22513 | *$ CREATE DT_CKMTDE.FOR | |
22514 | *COPY DT_CKMTDE | |
22515 | SUBROUTINE DT_CKMTDE(I,NDRV,X,S,ANS) | |
22516 | C | |
22517 | C********************************************************************** | |
22518 | C Deuteron - PDFs | |
22519 | C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc | |
22520 | C ANS = PDF(I) | |
22521 | C This version by S. Roesler, 30.01.96 | |
22522 | C********************************************************************** | |
22523 | ||
22524 | SAVE | |
22525 | DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000) | |
22526 | EQUIVALENCE (GF(1,1,1),DL(1)) | |
22527 | DATA DELTA/.13/ | |
22528 | C | |
22529 | DATA (DL(K),K= 1, 85) / | |
22530 | &0.351858E+00,0.388489E+00,0.325356E+00,0.325356E+00,0.325356E+00, | |
22531 | &0.325356E+00,0.445218E+01,0.000000E+00,0.419818E+00,0.459249E+00, | |
22532 | &0.391167E+00,0.391143E+00,0.391125E+00,0.391167E+00,0.628186E+01, | |
22533 | &0.703797E-01,0.498333E+00,0.540626E+00,0.467466E+00,0.467423E+00, | |
22534 | &0.467393E+00,0.467466E+00,0.837368E+01,0.151191E+00,0.587839E+00, | |
22535 | &0.633058E+00,0.554689E+00,0.554630E+00,0.554595E+00,0.554689E+00, | |
22536 | &0.107170E+02,0.242877E+00,0.688652E+00,0.736861E+00,0.653150E+00, | |
22537 | &0.653080E+00,0.653046E+00,0.653150E+00,0.132960E+02,0.345760E+00, | |
22538 | &0.800961E+00,0.852226E+00,0.763038E+00,0.762961E+00,0.762933E+00, | |
22539 | &0.763038E+00,0.160884E+02,0.460033E+00,0.924829E+00,0.979213E+00, | |
22540 | &0.884414E+00,0.884335E+00,0.884319E+00,0.884414E+00,0.190679E+02, | |
22541 | &0.585764E+00,0.106016E+01,0.111773E+01,0.101719E+01,0.101711E+01, | |
22542 | &0.101711E+01,0.101719E+01,0.222033E+02,0.722864E+00,0.120670E+01, | |
22543 | &0.126752E+01,0.116110E+01,0.116102E+01,0.116105E+01,0.116110E+01, | |
22544 | &0.254603E+02,0.871079E+00,0.136402E+01,0.142815E+01,0.131571E+01, | |
22545 | &0.131565E+01,0.131570E+01,0.131571E+01,0.288020E+02,0.102998E+01, | |
22546 | &0.153151E+01,0.159900E+01,0.148043E+01,0.148038E+01,0.148046E+01/ | |
22547 | DATA (DL(K),K= 86, 170) / | |
22548 | &0.148043E+01,0.321898E+02,0.119897E+01,0.170838E+01,0.177930E+01, | |
22549 | &0.165447E+01,0.165444E+01,0.165455E+01,0.165447E+01,0.355845E+02, | |
22550 | &0.137726E+01,0.189369E+01,0.196807E+01,0.183687E+01,0.183686E+01, | |
22551 | &0.183701E+01,0.183687E+01,0.389473E+02,0.156390E+01,0.208631E+01, | |
22552 | &0.216422E+01,0.202653E+01,0.202654E+01,0.202673E+01,0.202653E+01, | |
22553 | &0.422402E+02,0.175779E+01,0.228501E+01,0.236648E+01,0.222220E+01, | |
22554 | &0.222224E+01,0.222248E+01,0.222220E+01,0.454277E+02,0.195768E+01, | |
22555 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22556 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22557 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22558 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22559 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22560 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22561 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22562 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22563 | &0.326035E+00,0.380777E+00,0.286363E+00,0.286363E+00,0.286363E+00, | |
22564 | &0.286363E+00,0.392252E+01,-.138778E-16,0.380092E+00,0.438587E+00/ | |
22565 | DATA (DL(K),K= 171, 255) / | |
22566 | &0.337452E+00,0.337430E+00,0.337424E+00,0.337452E+00,0.532193E+01, | |
22567 | &0.553645E-01,0.440879E+00,0.503177E+00,0.395208E+00,0.395169E+00, | |
22568 | &0.395165E+00,0.395208E+00,0.686454E+01,0.117354E+00,0.508415E+00, | |
22569 | &0.574566E+00,0.459649E+00,0.459600E+00,0.459604E+00,0.459649E+00, | |
22570 | &0.853316E+01,0.185994E+00,0.582647E+00,0.652699E+00,0.530722E+00, | |
22571 | &0.530667E+00,0.530687E+00,0.530722E+00,0.103093E+02,0.261237E+00, | |
22572 | &0.663404E+00,0.737405E+00,0.608254E+00,0.608199E+00,0.608241E+00, | |
22573 | &0.608254E+00,0.121710E+02,0.342917E+00,0.750429E+00,0.828423E+00, | |
22574 | &0.691990E+00,0.691941E+00,0.692009E+00,0.691990E+00,0.140946E+02, | |
22575 | &0.430783E+00,0.843361E+00,0.925391E+00,0.781571E+00,0.781533E+00, | |
22576 | &0.781632E+00,0.781571E+00,0.160553E+02,0.524479E+00,0.941741E+00, | |
22577 | &0.102784E+01,0.876538E+00,0.876515E+00,0.876650E+00,0.876538E+00, | |
22578 | &0.180277E+02,0.623549E+00,0.104501E+01,0.113521E+01,0.976335E+00, | |
22579 | &0.976332E+00,0.976506E+00,0.976335E+00,0.199863E+02,0.727439E+00, | |
22580 | &0.115251E+01,0.124685E+01,0.108031E+01,0.108034E+01,0.108055E+01, | |
22581 | &0.108031E+01,0.219066E+02,0.835506E+00,0.126352E+01,0.136201E+01, | |
22582 | &0.118775E+01,0.118780E+01,0.118806E+01,0.118775E+01,0.237652E+02/ | |
22583 | DATA (DL(K),K= 256, 340) / | |
22584 | &0.947020E+00,0.137724E+01,0.147989E+01,0.129783E+01,0.129791E+01, | |
22585 | &0.129822E+01,0.129783E+01,0.255406E+02,0.106119E+01,0.149279E+01, | |
22586 | &0.159961E+01,0.140972E+01,0.140984E+01,0.141019E+01,0.140972E+01, | |
22587 | &0.272135E+02,0.117715E+01,0.160929E+01,0.172028E+01,0.152252E+01, | |
22588 | &0.152267E+01,0.152308E+01,0.152252E+01,0.287669E+02,0.129402E+01, | |
22589 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22590 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22591 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22592 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22593 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22594 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22595 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22596 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22597 | &0.309785E+00,0.391282E+00,0.250518E+00,0.250518E+00,0.250518E+00, | |
22598 | &0.250518E+00,0.343842E+01,-.138778E-16,0.352113E+00,0.438463E+00, | |
22599 | &0.288877E+00,0.288863E+00,0.288878E+00,0.288877E+00,0.446765E+01, | |
22600 | &0.424850E-01,0.398382E+00,0.489596E+00,0.331132E+00,0.331111E+00/ | |
22601 | DATA (DL(K),K= 341, 425) / | |
22602 | &0.331148E+00,0.331132E+00,0.555902E+01,0.888369E-01,0.448375E+00, | |
22603 | &0.544458E+00,0.377064E+00,0.377043E+00,0.377108E+00,0.377064E+00, | |
22604 | &0.669490E+01,0.138845E+00,0.501854E+00,0.602811E+00,0.426440E+00, | |
22605 | &0.426425E+00,0.426523E+00,0.426440E+00,0.785892E+01,0.192281E+00, | |
22606 | &0.558506E+00,0.664331E+00,0.478946E+00,0.478944E+00,0.479079E+00, | |
22607 | &0.478946E+00,0.903368E+01,0.248834E+00,0.617972E+00,0.728657E+00, | |
22608 | &0.534229E+00,0.534244E+00,0.534421E+00,0.534229E+00,0.102022E+02, | |
22609 | &0.308155E+00,0.679844E+00,0.795370E+00,0.591883E+00,0.591921E+00, | |
22610 | &0.592141E+00,0.591883E+00,0.113479E+02,0.369841E+00,0.743667E+00, | |
22611 | &0.864009E+00,0.651460E+00,0.651525E+00,0.651792E+00,0.651460E+00, | |
22612 | &0.124553E+02,0.433447E+00,0.808951E+00,0.934073E+00,0.712474E+00, | |
22613 | &0.712571E+00,0.712885E+00,0.712474E+00,0.135102E+02,0.498486E+00, | |
22614 | &0.875171E+00,0.100503E+01,0.774408E+00,0.774541E+00,0.774902E+00, | |
22615 | &0.774408E+00,0.144999E+02,0.564446E+00,0.941784E+00,0.107632E+01, | |
22616 | &0.836726E+00,0.836897E+00,0.837307E+00,0.836726E+00,0.154136E+02, | |
22617 | &0.630788E+00,0.100823E+01,0.114738E+01,0.898879E+00,0.899092E+00, | |
22618 | &0.899551E+00,0.898879E+00,0.162423E+02,0.696967E+00,0.107396E+01/ | |
22619 | DATA (DL(K),K= 426, 510) / | |
22620 | &0.121764E+01,0.960319E+00,0.960577E+00,0.961084E+00,0.960319E+00, | |
22621 | &0.169791E+02,0.762433E+00,0.113843E+01,0.128655E+01,0.102051E+01, | |
22622 | &0.102081E+01,0.102137E+01,0.102051E+01,0.176190E+02,0.826647E+00, | |
22623 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22624 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22625 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22626 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22627 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22628 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22629 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22630 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22631 | &0.304680E+00,0.425088E+00,0.216504E+00,0.216504E+00,0.216504E+00, | |
22632 | &0.216504E+00,0.298356E+01,0.000000E+00,0.337300E+00,0.463627E+00, | |
22633 | &0.244023E+00,0.244024E+00,0.244063E+00,0.244023E+00,0.370271E+01, | |
22634 | &0.316585E-01,0.371787E+00,0.503942E+00,0.273415E+00,0.273423E+00, | |
22635 | &0.273505E+00,0.273415E+00,0.443039E+01,0.651685E-01,0.407853E+00, | |
22636 | &0.545739E+00,0.304395E+00,0.304418E+00,0.304545E+00,0.304395E+00/ | |
22637 | DATA (DL(K),K= 511, 595) / | |
22638 | &0.515321E+01,0.100252E+00,0.445229E+00,0.588741E+00,0.336700E+00, | |
22639 | &0.336744E+00,0.336918E+00,0.336700E+00,0.586004E+01,0.136648E+00, | |
22640 | &0.483606E+00,0.632629E+00,0.370026E+00,0.370095E+00,0.370318E+00, | |
22641 | &0.370026E+00,0.654027E+01,0.174056E+00,0.522666E+00,0.677074E+00, | |
22642 | &0.404062E+00,0.404162E+00,0.404433E+00,0.404062E+00,0.718442E+01, | |
22643 | &0.212167E+00,0.562075E+00,0.721735E+00,0.438483E+00,0.438618E+00, | |
22644 | &0.438938E+00,0.438483E+00,0.778423E+01,0.250658E+00,0.601494E+00, | |
22645 | &0.766258E+00,0.472959E+00,0.473131E+00,0.473500E+00,0.472959E+00, | |
22646 | &0.833276E+01,0.289199E+00,0.640580E+00,0.810290E+00,0.507156E+00, | |
22647 | &0.507369E+00,0.507784E+00,0.507156E+00,0.882448E+01,0.327457E+00, | |
22648 | &0.678993E+00,0.853479E+00,0.540747E+00,0.541003E+00,0.541463E+00, | |
22649 | &0.540747E+00,0.925529E+01,0.365104E+00,0.716405E+00,0.895483E+00, | |
22650 | &0.573411E+00,0.573714E+00,0.574216E+00,0.573411E+00,0.962250E+01, | |
22651 | &0.401821E+00,0.752501E+00,0.935975E+00,0.604848E+00,0.605197E+00, | |
22652 | &0.605740E+00,0.604848E+00,0.992478E+01,0.437304E+00,0.786987E+00, | |
22653 | &0.974647E+00,0.634775E+00,0.635173E+00,0.635752E+00,0.634775E+00, | |
22654 | &0.101620E+02,0.471269E+00,0.819594E+00,0.101122E+01,0.662936E+00/ | |
22655 | DATA (DL(K),K= 596, 680) / | |
22656 | &0.663382E+00,0.663995E+00,0.662936E+00,0.103354E+02,0.503459E+00, | |
22657 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22658 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22659 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22660 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22661 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22662 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22663 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22664 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22665 | &0.312661E+00,0.487836E+00,0.182562E+00,0.182562E+00,0.182562E+00, | |
22666 | &0.182562E+00,0.253626E+01,0.000000E+00,0.336910E+00,0.518440E+00, | |
22667 | &0.200702E+00,0.200721E+00,0.200779E+00,0.200702E+00,0.299460E+01, | |
22668 | &0.224425E-01,0.361554E+00,0.549164E+00,0.219359E+00,0.219402E+00, | |
22669 | &0.219517E+00,0.219359E+00,0.343183E+01,0.453742E-01,0.386348E+00, | |
22670 | &0.579759E+00,0.238296E+00,0.238367E+00,0.238536E+00,0.238296E+00, | |
22671 | &0.384076E+01,0.685610E-01,0.411080E+00,0.610003E+00,0.257305E+00, | |
22672 | &0.257408E+00,0.257630E+00,0.257305E+00,0.421619E+01,0.917987E-01/ | |
22673 | DATA (DL(K),K= 681, 765) / | |
22674 | &0.435528E+00,0.639668E+00,0.276174E+00,0.276313E+00,0.276583E+00, | |
22675 | &0.276174E+00,0.455400E+01,0.114876E+00,0.459476E+00,0.668531E+00, | |
22676 | &0.294698E+00,0.294875E+00,0.295191E+00,0.294698E+00,0.485107E+01, | |
22677 | &0.137589E+00,0.482719E+00,0.696375E+00,0.312682E+00,0.312900E+00, | |
22678 | &0.313258E+00,0.312682E+00,0.510539E+01,0.159742E+00,0.505060E+00, | |
22679 | &0.722995E+00,0.329941E+00,0.330200E+00,0.330596E+00,0.329941E+00, | |
22680 | &0.531589E+01,0.181149E+00,0.526315E+00,0.748199E+00,0.346303E+00, | |
22681 | &0.346604E+00,0.347034E+00,0.346303E+00,0.548250E+01,0.201638E+00, | |
22682 | &0.546317E+00,0.771808E+00,0.361613E+00,0.361957E+00,0.362418E+00, | |
22683 | &0.361613E+00,0.560595E+01,0.221052E+00,0.564917E+00,0.793667E+00, | |
22684 | &0.375735E+00,0.376122E+00,0.376609E+00,0.375735E+00,0.568772E+01, | |
22685 | &0.239253E+00,0.581987E+00,0.813638E+00,0.388553E+00,0.388982E+00, | |
22686 | &0.389491E+00,0.388553E+00,0.572992E+01,0.256122E+00,0.597419E+00, | |
22687 | &0.831608E+00,0.399972E+00,0.400443E+00,0.400970E+00,0.399972E+00, | |
22688 | &0.573516E+01,0.271562E+00,0.611129E+00,0.847487E+00,0.409919E+00, | |
22689 | &0.410430E+00,0.410972E+00,0.409919E+00,0.570642E+01,0.285497E+00, | |
22690 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
22691 | DATA (DL(K),K= 766, 850) / | |
22692 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22693 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22694 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22695 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22696 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22697 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22698 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22699 | &0.335149E+00,0.582072E+00,0.146415E+00,0.146415E+00,0.146415E+00, | |
22700 | &0.146415E+00,0.206772E+01,0.000000E+00,0.351552E+00,0.603437E+00, | |
22701 | &0.156515E+00,0.156542E+00,0.156595E+00,0.156515E+00,0.231143E+01, | |
22702 | &0.146091E-01,0.367407E+00,0.623737E+00,0.166387E+00,0.166442E+00, | |
22703 | &0.166542E+00,0.166387E+00,0.252488E+01,0.289315E-01,0.382571E+00, | |
22704 | &0.642832E+00,0.175891E+00,0.175976E+00,0.176118E+00,0.175891E+00, | |
22705 | &0.270658E+01,0.428312E-01,0.396926E+00,0.660609E+00,0.184917E+00, | |
22706 | &0.185034E+00,0.185212E+00,0.184917E+00,0.285608E+01,0.561981E-01, | |
22707 | &0.410365E+00,0.676962E+00,0.193365E+00,0.193513E+00,0.193722E+00, | |
22708 | &0.193365E+00,0.297375E+01,0.689319E-01,0.422792E+00,0.691796E+00/ | |
22709 | DATA (DL(K),K= 851, 935) / | |
22710 | &0.201144E+00,0.201324E+00,0.201560E+00,0.201144E+00,0.306050E+01, | |
22711 | &0.809434E-01,0.434123E+00,0.705030E+00,0.208181E+00,0.208393E+00, | |
22712 | &0.208650E+00,0.208181E+00,0.311775E+01,0.921567E-01,0.444287E+00, | |
22713 | &0.716596E+00,0.214413E+00,0.214656E+00,0.214931E+00,0.214413E+00, | |
22714 | &0.314738E+01,0.102508E+00,0.453228E+00,0.726441E+00,0.219792E+00, | |
22715 | &0.220066E+00,0.220354E+00,0.219792E+00,0.315156E+01,0.111949E+00, | |
22716 | &0.460906E+00,0.734527E+00,0.224285E+00,0.224589E+00,0.224886E+00, | |
22717 | &0.224285E+00,0.313271E+01,0.120441E+00,0.467291E+00,0.740835E+00, | |
22718 | &0.227870E+00,0.228203E+00,0.228506E+00,0.227870E+00,0.309338E+01, | |
22719 | &0.127963E+00,0.472372E+00,0.745357E+00,0.230541E+00,0.230902E+00, | |
22720 | &0.231208E+00,0.230541E+00,0.303621E+01,0.134506E+00,0.476148E+00, | |
22721 | &0.748105E+00,0.232304E+00,0.232690E+00,0.232996E+00,0.232304E+00, | |
22722 | &0.296381E+01,0.140070E+00,0.478635E+00,0.749103E+00,0.233176E+00, | |
22723 | &0.233586E+00,0.233889E+00,0.233176E+00,0.287874E+01,0.144672E+00, | |
22724 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22725 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22726 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
22727 | DATA (DL(K),K= 936, 1020) / | |
22728 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22729 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22730 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22731 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22732 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22733 | &0.370162E+00,0.695827E+00,0.105823E+00,0.105823E+00,0.105823E+00, | |
22734 | &0.105823E+00,0.154556E+01,0.208167E-16,0.378214E+00,0.703794E+00, | |
22735 | &0.109539E+00,0.109554E+00,0.109571E+00,0.109539E+00,0.162770E+01, | |
22736 | &0.818783E-02,0.385258E+00,0.710067E+00,0.112818E+00,0.112847E+00, | |
22737 | &0.112879E+00,0.112818E+00,0.168578E+01,0.158212E-01,0.391264E+00, | |
22738 | &0.714648E+00,0.115620E+00,0.115666E+00,0.115709E+00,0.115620E+00, | |
22739 | &0.172175E+01,0.228667E-01,0.396214E+00,0.717539E+00,0.117923E+00, | |
22740 | &0.117985E+00,0.118037E+00,0.117923E+00,0.173756E+01,0.293009E-01, | |
22741 | &0.400098E+00,0.718759E+00,0.119711E+00,0.119790E+00,0.119848E+00, | |
22742 | &0.119711E+00,0.173541E+01,0.351123E-01,0.402915E+00,0.718332E+00, | |
22743 | &0.120979E+00,0.121074E+00,0.121137E+00,0.120979E+00,0.171755E+01, | |
22744 | &0.402951E-01,0.404672E+00,0.716292E+00,0.121728E+00,0.121840E+00/ | |
22745 | DATA (DL(K),K= 1021, 1105) / | |
22746 | &0.121905E+00,0.121728E+00,0.168619E+01,0.448514E-01,0.405385E+00, | |
22747 | &0.712681E+00,0.121967E+00,0.122095E+00,0.122161E+00,0.121967E+00, | |
22748 | &0.164352E+01,0.487902E-01,0.405077E+00,0.707551E+00,0.121712E+00, | |
22749 | &0.121855E+00,0.121920E+00,0.121712E+00,0.159162E+01,0.521265E-01, | |
22750 | &0.403778E+00,0.700963E+00,0.120984E+00,0.121141E+00,0.121204E+00, | |
22751 | &0.120984E+00,0.153245E+01,0.548814E-01,0.401525E+00,0.692984E+00, | |
22752 | &0.119809E+00,0.119980E+00,0.120040E+00,0.119809E+00,0.146780E+01, | |
22753 | &0.570807E-01,0.398361E+00,0.683691E+00,0.118218E+00,0.118402E+00, | |
22754 | &0.118457E+00,0.118218E+00,0.139928E+01,0.587542E-01,0.394333E+00, | |
22755 | &0.673166E+00,0.116244E+00,0.116440E+00,0.116490E+00,0.116244E+00, | |
22756 | &0.132834E+01,0.599355E-01,0.389495E+00,0.661496E+00,0.113924E+00, | |
22757 | &0.114131E+00,0.114175E+00,0.113924E+00,0.125620E+01,0.606602E-01, | |
22758 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22759 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22760 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22761 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22762 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
22763 | DATA (DL(K),K= 1106, 1190) / | |
22764 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22765 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22766 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22767 | &0.394012E+00,0.757115E+00,0.772117E-01,0.772117E-01,0.772117E-01, | |
22768 | &0.772117E-01,0.117279E+01,0.346945E-17,0.395841E+00,0.752988E+00, | |
22769 | &0.780501E-01,0.780655E-01,0.780723E-01,0.780501E-01,0.118528E+01, | |
22770 | &0.491697E-02,0.396627E+00,0.747223E+00,0.785386E-01,0.785692E-01, | |
22771 | &0.785806E-01,0.785386E-01,0.118242E+01,0.932754E-02,0.396401E+00, | |
22772 | &0.739901E+00,0.786820E-01,0.787273E-01,0.787413E-01,0.786820E-01, | |
22773 | &0.116673E+01,0.132427E-01,0.395190E+00,0.731092E+00,0.784870E-01, | |
22774 | &0.785464E-01,0.785613E-01,0.784870E-01,0.114033E+01,0.166738E-01, | |
22775 | &0.393030E+00,0.720878E+00,0.779683E-01,0.780410E-01,0.780555E-01, | |
22776 | &0.779683E-01,0.110528E+01,0.196392E-01,0.389962E+00,0.709342E+00, | |
22777 | &0.771427E-01,0.772280E-01,0.772409E-01,0.771427E-01,0.106344E+01, | |
22778 | &0.221591E-01,0.386027E+00,0.696571E+00,0.760304E-01,0.761276E-01, | |
22779 | &0.761378E-01,0.760304E-01,0.101653E+01,0.242567E-01,0.381274E+00, | |
22780 | &0.682657E+00,0.746543E-01,0.747623E-01,0.747692E-01,0.746543E-01/ | |
22781 | DATA (DL(K),K= 1191, 1275) / | |
22782 | &0.966057E+00,0.259571E-01,0.375752E+00,0.667695E+00,0.730389E-01, | |
22783 | &0.731569E-01,0.731598E-01,0.730389E-01,0.913345E+00,0.272876E-01, | |
22784 | &0.369514E+00,0.651782E+00,0.712104E-01,0.713374E-01,0.713358E-01, | |
22785 | &0.712104E-01,0.859530E+00,0.282763E-01,0.362616E+00,0.635021E+00, | |
22786 | &0.691957E-01,0.693307E-01,0.693243E-01,0.691957E-01,0.805566E+00, | |
22787 | &0.289524E-01,0.355116E+00,0.617511E+00,0.670220E-01,0.671640E-01, | |
22788 | &0.671526E-01,0.670220E-01,0.752235E+00,0.293453E-01,0.347072E+00, | |
22789 | &0.599357E+00,0.647162E-01,0.648642E-01,0.648478E-01,0.647162E-01, | |
22790 | &0.700161E+00,0.294844E-01,0.338543E+00,0.580659E+00,0.623046E-01, | |
22791 | &0.624578E-01,0.624363E-01,0.623046E-01,0.649828E+00,0.293983E-01, | |
22792 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22793 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22794 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22795 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22796 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22797 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22798 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
22799 | DATA (DL(K),K= 1276, 1360) / | |
22800 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22801 | &0.408305E+00,0.775318E+00,0.509141E-01,0.509141E-01,0.509141E-01, | |
22802 | &0.509141E-01,0.818839E+00,-.867362E-17,0.403619E+00,0.758058E+00, | |
22803 | &0.502245E-01,0.502351E-01,0.502337E-01,0.502245E-01,0.795347E+00, | |
22804 | &0.264045E-02,0.398068E+00,0.739709E+00,0.493454E-01,0.493661E-01, | |
22805 | &0.493626E-01,0.493454E-01,0.764942E+00,0.491508E-02,0.391719E+00, | |
22806 | &0.720394E+00,0.482952E-01,0.483253E-01,0.483192E-01,0.482952E-01, | |
22807 | &0.729624E+00,0.685202E-02,0.384627E+00,0.700222E+00,0.470896E-01, | |
22808 | &0.471285E-01,0.471194E-01,0.470896E-01,0.690906E+00,0.847433E-02, | |
22809 | &0.376851E+00,0.679300E+00,0.457475E-01,0.457946E-01,0.457822E-01, | |
22810 | &0.457475E-01,0.650078E+00,0.980774E-02,0.368452E+00,0.657739E+00, | |
22811 | &0.442875E-01,0.443419E-01,0.443261E-01,0.442875E-01,0.608239E+00, | |
22812 | &0.108769E-01,0.359490E+00,0.635646E+00,0.427281E-01,0.427892E-01, | |
22813 | &0.427698E-01,0.427281E-01,0.566280E+00,0.117061E-01,0.350026E+00, | |
22814 | &0.613128E+00,0.410878E-01,0.411549E-01,0.411320E-01,0.410878E-01, | |
22815 | &0.524918E+00,0.123191E-01,0.340122E+00,0.590292E+00,0.393848E-01, | |
22816 | &0.394571E-01,0.394308E-01,0.393848E-01,0.484713E+00,0.127393E-01/ | |
22817 | DATA (DL(K),K= 1361, 1445) / | |
22818 | &0.329838E+00,0.567240E+00,0.376363E-01,0.377132E-01,0.376836E-01, | |
22819 | &0.376363E-01,0.446084E+00,0.129888E-01,0.319236E+00,0.544074E+00, | |
22820 | &0.358589E-01,0.359396E-01,0.359068E-01,0.358589E-01,0.409328E+00, | |
22821 | &0.130888E-01,0.308374E+00,0.520890E+00,0.340678E-01,0.341517E-01, | |
22822 | &0.341160E-01,0.340678E-01,0.374641E+00,0.130594E-01,0.297312E+00, | |
22823 | &0.497781E+00,0.322772E-01,0.323636E-01,0.323253E-01,0.322772E-01, | |
22824 | &0.342135E+00,0.129195E-01,0.286106E+00,0.474837E+00,0.304999E-01, | |
22825 | &0.305882E-01,0.305474E-01,0.304999E-01,0.311854E+00,0.126863E-01, | |
22826 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22827 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22828 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22829 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22830 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22831 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22832 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22833 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22834 | &0.407248E+00,0.746438E+00,0.335640E-01,0.335640E-01,0.335640E-01/ | |
22835 | DATA (DL(K),K= 1446, 1530) / | |
22836 | &0.335640E-01,0.573540E+00,0.173472E-16,0.397516E+00,0.719825E+00, | |
22837 | &0.324649E-01,0.324735E-01,0.324698E-01,0.324649E-01,0.540770E+00, | |
22838 | &0.147177E-02,0.387197E+00,0.692869E+00,0.312911E-01,0.313075E-01, | |
22839 | &0.313000E-01,0.312911E-01,0.505972E+00,0.269995E-02,0.376365E+00, | |
22840 | &0.665689E+00,0.300576E-01,0.300811E-01,0.300699E-01,0.300576E-01, | |
22841 | &0.470389E+00,0.371147E-02,0.365085E+00,0.638387E+00,0.287770E-01, | |
22842 | &0.288070E-01,0.287922E-01,0.287770E-01,0.434885E+00,0.452768E-02, | |
22843 | &0.353423E+00,0.611066E+00,0.274623E-01,0.274980E-01,0.274797E-01, | |
22844 | &0.274623E-01,0.400103E+00,0.516996E-02,0.341442E+00,0.583823E+00, | |
22845 | &0.261256E-01,0.261663E-01,0.261448E-01,0.261256E-01,0.366541E+00, | |
22846 | &0.565807E-02,0.329207E+00,0.556753E+00,0.247782E-01,0.248234E-01, | |
22847 | &0.247989E-01,0.247782E-01,0.334555E+00,0.601048E-02,0.316777E+00, | |
22848 | &0.529946E+00,0.234308E-01,0.234798E-01,0.234525E-01,0.234308E-01, | |
22849 | &0.304384E+00,0.624451E-02,0.304214E+00,0.503489E+00,0.220932E-01, | |
22850 | &0.221452E-01,0.221155E-01,0.220932E-01,0.276170E+00,0.637618E-02, | |
22851 | &0.291575E+00,0.477462E+00,0.207739E-01,0.208286E-01,0.207966E-01, | |
22852 | &0.207739E-01,0.249976E+00,0.642028E-02,0.278917E+00,0.451941E+00/ | |
22853 | DATA (DL(K),K= 1531, 1615) / | |
22854 | &0.194809E-01,0.195376E-01,0.195037E-01,0.194809E-01,0.225809E+00, | |
22855 | &0.639038E-02,0.266293E+00,0.426995E+00,0.182209E-01,0.182791E-01, | |
22856 | &0.182436E-01,0.182209E-01,0.203629E+00,0.629880E-02,0.253754E+00, | |
22857 | &0.402686E+00,0.169996E-01,0.170587E-01,0.170219E-01,0.169996E-01, | |
22858 | &0.183361E+00,0.615665E-02,0.241347E+00,0.379071E+00,0.158217E-01, | |
22859 | &0.158814E-01,0.158436E-01,0.158217E-01,0.164907E+00,0.597385E-02, | |
22860 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22861 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22862 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22863 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22864 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22865 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22866 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22867 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22868 | &0.395106E+00,0.689399E+00,0.218554E-01,0.218554E-01,0.218554E-01, | |
22869 | &0.218554E-01,0.398362E+00,-.173472E-17,0.381441E+00,0.656777E+00, | |
22870 | &0.207816E-01,0.207886E-01,0.207844E-01,0.207816E-01,0.366703E+00/ | |
22871 | DATA (DL(K),K= 1616, 1700) / | |
22872 | &0.826643E-03,0.367505E+00,0.624578E+00,0.197001E-01,0.197133E-01, | |
22873 | &0.197053E-01,0.197001E-01,0.335573E+00,0.149886E-02,0.353373E+00, | |
22874 | &0.592889E+00,0.186195E-01,0.186383E-01,0.186266E-01,0.186195E-01, | |
22875 | &0.305590E+00,0.203730E-02,0.339106E+00,0.561783E+00,0.175468E-01, | |
22876 | &0.175705E-01,0.175555E-01,0.175468E-01,0.277136E+00,0.245817E-02, | |
22877 | &0.324766E+00,0.531331E+00,0.164887E-01,0.165166E-01,0.164986E-01, | |
22878 | &0.164887E-01,0.250424E+00,0.277666E-02,0.310411E+00,0.501599E+00, | |
22879 | &0.154510E-01,0.154825E-01,0.154618E-01,0.154510E-01,0.225588E+00, | |
22880 | &0.300658E-02,0.296100E+00,0.472648E+00,0.144390E-01,0.144735E-01, | |
22881 | &0.144504E-01,0.144390E-01,0.202681E+00,0.316040E-02,0.281885E+00, | |
22882 | &0.444535E+00,0.134570E-01,0.134940E-01,0.134689E-01,0.134570E-01, | |
22883 | &0.181693E+00,0.324944E-02,0.267820E+00,0.417309E+00,0.125091E-01, | |
22884 | &0.125481E-01,0.125212E-01,0.125091E-01,0.162572E+00,0.328396E-02, | |
22885 | &0.253953E+00,0.391017E+00,0.115984E-01,0.116389E-01,0.116106E-01, | |
22886 | &0.115984E-01,0.145235E+00,0.327313E-02,0.240328E+00,0.365695E+00, | |
22887 | &0.107275E-01,0.107690E-01,0.107396E-01,0.107275E-01,0.129575E+00, | |
22888 | &0.322510E-02,0.226989E+00,0.341375E+00,0.989805E-02,0.994030E-02/ | |
22889 | DATA (DL(K),K= 1701, 1785) / | |
22890 | &0.990998E-02,0.989805E-02,0.115477E+00,0.314713E-02,0.213972E+00, | |
22891 | &0.318081E+00,0.911149E-02,0.915408E-02,0.912316E-02,0.911149E-02, | |
22892 | &0.102820E+00,0.304556E-02,0.201311E+00,0.295830E+00,0.836852E-02, | |
22893 | &0.841111E-02,0.837984E-02,0.836852E-02,0.914804E-01,0.292596E-02, | |
22894 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22895 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22896 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22897 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22898 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22899 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22900 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22901 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22902 | &0.374678E+00,0.616087E+00,0.139531E-01,0.139531E-01,0.139531E-01, | |
22903 | &0.139531E-01,0.272491E+00,-.693889E-17,0.358052E+00,0.580345E+00, | |
22904 | &0.130624E-01,0.130680E-01,0.130641E-01,0.130624E-01,0.245861E+00, | |
22905 | &0.460255E-03,0.341487E+00,0.545719E+00,0.121971E-01,0.122076E-01, | |
22906 | &0.122002E-01,0.121971E-01,0.220877E+00,0.826785E-03,0.325046E+00/ | |
22907 | DATA (DL(K),K= 1786, 1870) / | |
22908 | &0.512244E+00,0.113599E-01,0.113748E-01,0.113641E-01,0.113599E-01, | |
22909 | &0.197730E+00,0.111366E-02,0.308783E+00,0.479952E+00,0.105534E-01, | |
22910 | &0.105720E-01,0.105585E-01,0.105534E-01,0.176497E+00,0.133192E-02, | |
22911 | &0.292747E+00,0.448868E+00,0.977938E-02,0.980112E-02,0.978518E-02, | |
22912 | &0.977938E-02,0.157150E+00,0.149139E-02,0.276986E+00,0.419015E+00, | |
22913 | &0.903955E-02,0.906394E-02,0.904584E-02,0.903955E-02,0.139631E+00, | |
22914 | &0.160093E-02,0.261546E+00,0.390412E+00,0.833509E-02,0.836165E-02, | |
22915 | &0.834171E-02,0.833509E-02,0.123850E+00,0.166838E-02,0.246467E+00, | |
22916 | &0.363074E+00,0.766687E-02,0.769516E-02,0.767369E-02,0.766687E-02, | |
22917 | &0.109695E+00,0.170073E-02,0.231787E+00,0.337008E+00,0.703540E-02, | |
22918 | &0.706500E-02,0.704230E-02,0.703540E-02,0.970428E-01,0.170416E-02, | |
22919 | &0.217542E+00,0.312218E+00,0.644083E-02,0.647137E-02,0.644772E-02, | |
22920 | &0.644083E-02,0.857658E-01,0.168409E-02,0.203759E+00,0.288701E+00, | |
22921 | &0.588300E-02,0.591415E-02,0.588981E-02,0.588300E-02,0.757385E-01, | |
22922 | &0.164528E-02,0.190467E+00,0.266449E+00,0.536147E-02,0.539292E-02, | |
22923 | &0.536812E-02,0.536147E-02,0.668383E-01,0.159185E-02,0.177686E+00, | |
22924 | &0.245447E+00,0.487551E-02,0.490698E-02,0.488195E-02,0.487551E-02/ | |
22925 | DATA (DL(K),K= 1871, 1955) / | |
22926 | &0.589492E-01,0.152735E-02,0.165434E+00,0.225677E+00,0.442416E-02, | |
22927 | &0.445543E-02,0.443037E-02,0.442416E-02,0.519652E-01,0.145483E-02, | |
22928 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22929 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22930 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22931 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22932 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22933 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22934 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22935 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22936 | &0.348042E+00,0.534691E+00,0.867977E-02,0.867977E-02,0.867977E-02, | |
22937 | &0.867977E-02,0.182547E+00,-.693889E-17,0.329349E+00,0.498248E+00, | |
22938 | &0.800724E-02,0.801198E-02,0.800836E-02,0.800724E-02,0.161948E+00, | |
22939 | &0.250949E-03,0.311047E+00,0.463485E+00,0.737155E-02,0.738040E-02, | |
22940 | &0.737356E-02,0.737155E-02,0.143267E+00,0.447662E-03,0.293181E+00, | |
22941 | &0.430377E+00,0.677169E-02,0.678409E-02,0.677441E-02,0.677169E-02, | |
22942 | &0.126447E+00,0.598803E-03,0.275787E+00,0.398907E+00,0.620726E-02/ | |
22943 | DATA (DL(K),K= 1956, 2040) / | |
22944 | &0.622265E-02,0.621051E-02,0.620726E-02,0.111401E+00,0.711280E-03, | |
22945 | &0.258900E+00,0.369051E+00,0.567741E-02,0.569532E-02,0.568106E-02, | |
22946 | &0.567741E-02,0.979944E-01,0.790986E-03,0.242550E+00,0.340785E+00, | |
22947 | &0.518138E-02,0.520134E-02,0.518531E-02,0.518138E-02,0.860936E-01, | |
22948 | &0.843227E-03,0.226765E+00,0.314083E+00,0.471828E-02,0.473987E-02, | |
22949 | &0.472238E-02,0.471828E-02,0.755615E-01,0.872644E-03,0.211568E+00, | |
22950 | &0.288916E+00,0.428714E-02,0.430998E-02,0.429133E-02,0.428714E-02, | |
22951 | &0.662627E-01,0.883319E-03,0.196981E+00,0.265252E+00,0.388691E-02, | |
22952 | &0.391065E-02,0.389112E-02,0.388691E-02,0.580684E-01,0.878818E-03, | |
22953 | &0.183020E+00,0.243053E+00,0.351645E-02,0.354077E-02,0.352060E-02, | |
22954 | &0.351645E-02,0.508578E-01,0.862228E-03,0.169696E+00,0.222280E+00, | |
22955 | &0.317451E-02,0.319914E-02,0.317858E-02,0.317451E-02,0.445190E-01, | |
22956 | &0.836224E-03,0.157017E+00,0.202888E+00,0.285982E-02,0.288450E-02, | |
22957 | &0.286376E-02,0.285982E-02,0.389523E-01,0.803096E-03,0.144987E+00, | |
22958 | &0.184832E+00,0.257101E-02,0.259553E-02,0.257480E-02,0.257101E-02, | |
22959 | &0.340677E-01,0.764787E-03,0.133605E+00,0.168060E+00,0.230670E-02, | |
22960 | &0.233087E-02,0.231031E-02,0.230670E-02,0.297820E-01,0.722929E-03/ | |
22961 | DATA (DL(K),K= 2041, 2125) / | |
22962 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22963 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22964 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22965 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22966 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22967 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22968 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22969 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22970 | &0.316867E+00,0.451111E+00,0.522815E-02,0.522815E-02,0.522815E-02, | |
22971 | &0.522815E-02,0.119118E+00,0.889046E-17,0.296950E+00,0.415915E+00, | |
22972 | &0.475497E-02,0.475914E-02,0.475574E-02,0.475497E-02,0.104204E+00, | |
22973 | &0.132513E-03,0.277735E+00,0.382805E+00,0.431809E-02,0.432582E-02, | |
22974 | &0.431944E-02,0.431809E-02,0.910279E-01,0.235347E-03,0.259241E+00, | |
22975 | &0.351694E+00,0.391455E-02,0.392531E-02,0.391637E-02,0.391455E-02, | |
22976 | &0.794222E-01,0.313322E-03,0.241485E+00,0.322517E+00,0.354249E-02, | |
22977 | &0.355575E-02,0.354464E-02,0.354249E-02,0.692354E-01,0.370408E-03, | |
22978 | &0.224480E+00,0.295202E+00,0.319987E-02,0.321518E-02,0.320226E-02/ | |
22979 | DATA (DL(K),K= 2126, 2210) / | |
22980 | &0.319987E-02,0.603106E-01,0.409866E-03,0.208235E+00,0.269681E+00, | |
22981 | &0.288490E-02,0.290184E-02,0.288744E-02,0.288490E-02,0.525034E-01, | |
22982 | &0.434663E-03,0.192759E+00,0.245887E+00,0.259589E-02,0.261407E-02, | |
22983 | &0.259852E-02,0.259589E-02,0.456838E-01,0.447393E-03,0.178054E+00, | |
22984 | &0.223752E+00,0.233123E-02,0.235033E-02,0.233390E-02,0.233123E-02, | |
22985 | &0.397318E-01,0.450314E-03,0.164120E+00,0.203207E+00,0.208941E-02, | |
22986 | &0.210910E-02,0.209206E-02,0.208941E-02,0.345396E-01,0.445394E-03, | |
22987 | &0.150954E+00,0.184182E+00,0.186896E-02,0.188897E-02,0.187155E-02, | |
22988 | &0.186896E-02,0.300131E-01,0.434333E-03,0.138548E+00,0.166608E+00, | |
22989 | &0.166844E-02,0.168854E-02,0.167096E-02,0.166844E-02,0.260692E-01, | |
22990 | &0.418584E-03,0.126892E+00,0.150412E+00,0.148650E-02,0.150648E-02, | |
22991 | &0.148891E-02,0.148650E-02,0.226325E-01,0.399380E-03,0.115971E+00, | |
22992 | &0.135523E+00,0.132180E-02,0.134148E-02,0.132409E-02,0.132180E-02, | |
22993 | &0.196374E-01,0.377764E-03,0.105767E+00,0.121870E+00,0.117308E-02, | |
22994 | &0.119231E-02,0.117524E-02,0.117308E-02,0.170312E-01,0.354610E-03, | |
22995 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22996 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
22997 | DATA (DL(K),K= 2211, 2295) / | |
22998 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22999 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23000 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23001 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23002 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23003 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23004 | &0.282579E+00,0.369670E+00,0.302765E-02,0.302765E-02,0.302765E-02, | |
23005 | &0.302765E-02,0.752529E-01,-.455365E-17,0.262229E+00,0.337209E+00, | |
23006 | &0.271512E-02,0.271883E-02,0.271564E-02,0.271512E-02,0.651086E-01, | |
23007 | &0.669321E-04,0.242857E+00,0.307069E+00,0.243269E-02,0.243953E-02, | |
23008 | &0.243360E-02,0.243269E-02,0.563252E-01,0.118744E-03,0.224455E+00, | |
23009 | &0.279111E+00,0.217687E-02,0.218631E-02,0.217808E-02,0.217687E-02, | |
23010 | &0.487143E-01,0.157767E-03,0.207014E+00,0.253223E+00,0.194534E-02, | |
23011 | &0.195689E-02,0.194675E-02,0.194534E-02,0.421227E-01,0.186063E-03, | |
23012 | &0.190523E+00,0.229293E+00,0.173585E-02,0.174909E-02,0.173741E-02, | |
23013 | &0.173585E-02,0.364156E-01,0.205286E-03,0.174969E+00,0.207218E+00, | |
23014 | &0.154647E-02,0.156100E-02,0.154811E-02,0.154647E-02,0.314732E-01/ | |
23015 | DATA (DL(K),K= 2296, 2380) / | |
23016 | &0.216964E-03,0.160335E+00,0.186895E+00,0.137545E-02,0.139092E-02, | |
23017 | &0.137713E-02,0.137545E-02,0.271927E-01,0.222455E-03,0.146604E+00, | |
23018 | &0.168227E+00,0.122121E-02,0.123733E-02,0.122290E-02,0.122121E-02, | |
23019 | &0.234852E-01,0.222947E-03,0.133756E+00,0.151116E+00,0.108234E-02, | |
23020 | &0.109881E-02,0.108400E-02,0.108234E-02,0.202747E-01,0.219474E-03, | |
23021 | &0.121765E+00,0.135471E+00,0.957502E-03,0.974107E-03,0.959112E-03, | |
23022 | &0.957502E-03,0.174932E-01,0.212928E-03,0.110606E+00,0.121198E+00, | |
23023 | &0.845493E-03,0.862024E-03,0.847037E-03,0.845493E-03,0.150824E-01, | |
23024 | &0.204075E-03,0.100250E+00,0.108210E+00,0.745196E-03,0.761482E-03, | |
23025 | &0.746662E-03,0.745196E-03,0.129965E-01,0.193573E-03,0.906661E-01, | |
23026 | &0.964191E-01,0.655569E-03,0.671466E-03,0.656948E-03,0.655569E-03, | |
23027 | &0.111930E-01,0.181962E-03,0.818218E-01,0.857412E-01,0.575637E-03, | |
23028 | &0.591030E-03,0.576925E-03,0.575637E-03,0.962922E-02,0.169687E-03, | |
23029 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23030 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23031 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23032 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23033 | DATA (DL(K),K= 2381, 2465) / | |
23034 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23035 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23036 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23037 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23038 | &0.246444E+00,0.293515E+00,0.167124E-02,0.167124E-02,0.167124E-02, | |
23039 | &0.167124E-02,0.456929E-01,-.260209E-17,0.226393E+00,0.264836E+00, | |
23040 | &0.147748E-02,0.148085E-02,0.147783E-02,0.147748E-02,0.392393E-01, | |
23041 | &0.318190E-04,0.207552E+00,0.238550E+00,0.130596E-02,0.131212E-02, | |
23042 | &0.130656E-02,0.130596E-02,0.337276E-01,0.566426E-04,0.189877E+00, | |
23043 | &0.214470E+00,0.115347E-02,0.116190E-02,0.115427E-02,0.115347E-02, | |
23044 | &0.290012E-01,0.753776E-04,0.173336E+00,0.192452E+00,0.101789E-02, | |
23045 | &0.102811E-02,0.101881E-02,0.101789E-02,0.249381E-01,0.889466E-04, | |
23046 | &0.157889E+00,0.172355E+00,0.897268E-03,0.908872E-03,0.898270E-03, | |
23047 | &0.897268E-03,0.214419E-01,0.980950E-04,0.143501E+00,0.154046E+00, | |
23048 | &0.789951E-03,0.802565E-03,0.790996E-03,0.789951E-03,0.184296E-01, | |
23049 | &0.103536E-03,0.130132E+00,0.137402E+00,0.694510E-03,0.707811E-03, | |
23050 | &0.695568E-03,0.694510E-03,0.158331E-01,0.105929E-03,0.117743E+00/ | |
23051 | DATA (DL(K),K= 2466, 2550) / | |
23052 | &0.122303E+00,0.609684E-03,0.623394E-03,0.610733E-03,0.609684E-03, | |
23053 | &0.135929E-01,0.105853E-03,0.106293E+00,0.108637E+00,0.534365E-03, | |
23054 | &0.548244E-03,0.535386E-03,0.534365E-03,0.116583E-01,0.103825E-03, | |
23055 | &0.957386E-01,0.962976E-01,0.467572E-03,0.481416E-03,0.468551E-03, | |
23056 | &0.467572E-03,0.999103E-02,0.100301E-03,0.860376E-01,0.851820E-01, | |
23057 | &0.408422E-03,0.422062E-03,0.409350E-03,0.408422E-03,0.855563E-02, | |
23058 | &0.956675E-04,0.771455E-01,0.751930E-01,0.356117E-03,0.369416E-03, | |
23059 | &0.356989E-03,0.356117E-03,0.731542E-02,0.902499E-04,0.690178E-01, | |
23060 | &0.662386E-01,0.309950E-03,0.322797E-03,0.310761E-03,0.309950E-03, | |
23061 | &0.624633E-02,0.843305E-04,0.616096E-01,0.582312E-01,0.269281E-03, | |
23062 | &0.281590E-03,0.270030E-03,0.269281E-03,0.533230E-02,0.781441E-04, | |
23063 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23064 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23065 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23066 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23067 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23068 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23069 | DATA (DL(K),K= 2551, 2635) / | |
23070 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23071 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23072 | &0.209608E+00,0.224862E+00,0.869706E-03,0.869706E-03,0.869706E-03, | |
23073 | &0.869706E-03,0.264204E-01,-.138236E-17,0.190523E+00,0.200603E+00, | |
23074 | &0.757542E-03,0.760626E-03,0.757768E-03,0.757542E-03,0.226261E-01, | |
23075 | &0.138827E-04,0.172819E+00,0.178656E+00,0.660281E-03,0.665837E-03, | |
23076 | &0.660670E-03,0.660281E-03,0.194018E-01,0.249832E-04,0.156420E+00, | |
23077 | &0.158805E+00,0.575414E-03,0.582918E-03,0.575917E-03,0.575414E-03, | |
23078 | &0.166434E-01,0.334851E-04,0.141265E+00,0.140883E+00,0.501258E-03, | |
23079 | &0.510252E-03,0.501836E-03,0.501258E-03,0.142710E-01,0.397017E-04, | |
23080 | &0.127291E+00,0.124732E+00,0.436386E-03,0.446473E-03,0.437008E-03, | |
23081 | &0.436386E-03,0.122297E-01,0.439154E-04,0.114437E+00,0.110205E+00, | |
23082 | &0.379575E-03,0.390415E-03,0.380217E-03,0.379575E-03,0.104701E-01, | |
23083 | &0.464110E-04,0.102644E+00,0.971655E-01,0.329805E-03,0.341109E-03, | |
23084 | &0.330448E-03,0.329805E-03,0.895086E-02,0.474758E-04,0.918521E-01, | |
23085 | &0.854876E-01,0.286206E-03,0.297729E-03,0.286836E-03,0.286206E-03, | |
23086 | &0.764249E-02,0.473771E-04,0.820032E-01,0.750529E-01,0.248027E-03/ | |
23087 | DATA (DL(K),K= 2636, 2720) / | |
23088 | &0.259564E-03,0.248633E-03,0.248027E-03,0.651744E-02,0.463561E-04, | |
23089 | &0.730394E-01,0.657510E-01,0.214611E-03,0.225995E-03,0.215186E-03, | |
23090 | &0.214611E-03,0.554573E-02,0.446239E-04,0.649040E-01,0.574789E-01, | |
23091 | &0.185396E-03,0.196491E-03,0.185935E-03,0.185396E-03,0.470938E-02, | |
23092 | &0.423722E-04,0.575411E-01,0.501405E-01,0.159891E-03,0.170590E-03, | |
23093 | &0.160391E-03,0.159891E-03,0.399752E-02,0.397689E-04,0.508960E-01, | |
23094 | &0.436466E-01,0.137650E-03,0.147874E-03,0.138111E-03,0.137650E-03, | |
23095 | &0.338807E-02,0.369434E-04,0.449157E-01,0.379141E-01,0.118285E-03, | |
23096 | &0.127973E-03,0.118705E-03,0.118285E-03,0.286125E-02,0.340035E-04, | |
23097 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23098 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23099 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23100 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23101 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23102 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23103 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23104 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23105 | DATA (DL(K),K= 2721, 2805) / | |
23106 | &0.173133E+00,0.165162E+00,0.420483E-03,0.420483E-03,0.420483E-03, | |
23107 | &0.420483E-03,0.143704E-01,0.418773E-17,0.155600E+00,0.145586E+00, | |
23108 | &0.360490E-03,0.363140E-03,0.360629E-03,0.360490E-03,0.123560E-01, | |
23109 | &0.533279E-05,0.139551E+00,0.128113E+00,0.309555E-03,0.314310E-03, | |
23110 | &0.309792E-03,0.309555E-03,0.106262E-01,0.982612E-05,0.124876E+00, | |
23111 | &0.112516E+00,0.265952E-03,0.272344E-03,0.266256E-03,0.265952E-03, | |
23112 | &0.913151E-02,0.133834E-04,0.111490E+00,0.986188E-01,0.228522E-03, | |
23113 | &0.236138E-03,0.228869E-03,0.228522E-03,0.783135E-02,0.160429E-04, | |
23114 | &0.993081E-01,0.862590E-01,0.196336E-03,0.204821E-03,0.196706E-03, | |
23115 | &0.196336E-03,0.670031E-02,0.178799E-04,0.882484E-01,0.752883E-01, | |
23116 | &0.168604E-03,0.177655E-03,0.168981E-03,0.168604E-03,0.572016E-02, | |
23117 | &0.189837E-04,0.782334E-01,0.655714E-01,0.144684E-03,0.154047E-03, | |
23118 | &0.145058E-03,0.144684E-03,0.487276E-02,0.194655E-04,0.691885E-01, | |
23119 | &0.569841E-01,0.124035E-03,0.133497E-03,0.124397E-03,0.124035E-03, | |
23120 | &0.413648E-02,0.194296E-04,0.610420E-01,0.494128E-01,0.106203E-03, | |
23121 | &0.115592E-03,0.106548E-03,0.106203E-03,0.350042E-02,0.189800E-04, | |
23122 | &0.537249E-01,0.427533E-01,0.908141E-04,0.999895E-04,0.911377E-04/ | |
23123 | DATA (DL(K),K= 2806, 2890) / | |
23124 | &0.908141E-04,0.295961E-02,0.182192E-04,0.471713E-01,0.369100E-01, | |
23125 | &0.775359E-04,0.863895E-04,0.778360E-04,0.775359E-04,0.249629E-02, | |
23126 | &0.172287E-04,0.413182E-01,0.317957E-01,0.660857E-04,0.745356E-04, | |
23127 | &0.663611E-04,0.660857E-04,0.209482E-02,0.160791E-04,0.361056E-01, | |
23128 | &0.273306E-01,0.562298E-04,0.642173E-04,0.564804E-04,0.562298E-04, | |
23129 | &0.175588E-02,0.148407E-04,0.314766E-01,0.234421E-01,0.477598E-04, | |
23130 | &0.552457E-04,0.479859E-04,0.477598E-04,0.147398E-02,0.135653E-04, | |
23131 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23132 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23133 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23134 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23135 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23136 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23137 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23138 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23139 | &0.138007E+00,0.115214E+00,0.185072E-03,0.185072E-03,0.185072E-03, | |
23140 | &0.185072E-03,0.722856E-02,-.380826E-17,0.122517E+00,0.100251E+00/ | |
23141 | DATA (DL(K),K= 2891, 2975) / | |
23142 | &0.155814E-03,0.158287E-03,0.155901E-03,0.155814E-03,0.630580E-02, | |
23143 | &0.155371E-05,0.108535E+00,0.870870E-01,0.131535E-03,0.135909E-03, | |
23144 | &0.131680E-03,0.131535E-03,0.547867E-02,0.304952E-05,0.959260E-01, | |
23145 | &0.754985E-01,0.111183E-03,0.116980E-03,0.111366E-03,0.111183E-03, | |
23146 | &0.473794E-02,0.433106E-05,0.845828E-01,0.653163E-01,0.940433E-04, | |
23147 | &0.100851E-03,0.942493E-04,0.940433E-04,0.407647E-02,0.533613E-05, | |
23148 | &0.744017E-01,0.563870E-01,0.795843E-04,0.870596E-04,0.798007E-04, | |
23149 | &0.795843E-04,0.349165E-02,0.606691E-05,0.652864E-01,0.485720E-01, | |
23150 | &0.673476E-04,0.752069E-04,0.675656E-04,0.673476E-04,0.297273E-02, | |
23151 | &0.652898E-05,0.571466E-01,0.417472E-01,0.569700E-04,0.649812E-04, | |
23152 | &0.571831E-04,0.569700E-04,0.251732E-02,0.675028E-05,0.498975E-01, | |
23153 | &0.358008E-01,0.481618E-04,0.561391E-04,0.483654E-04,0.481618E-04, | |
23154 | &0.212754E-02,0.677236E-05,0.434594E-01,0.306320E-01,0.406746E-04, | |
23155 | &0.484724E-04,0.408657E-04,0.406746E-04,0.179059E-02,0.662814E-05, | |
23156 | &0.377578E-01,0.261500E-01,0.343050E-04,0.418123E-04,0.344818E-04, | |
23157 | &0.343050E-04,0.149563E-02,0.635273E-05,0.327229E-01,0.222734E-01, | |
23158 | &0.288923E-04,0.360279E-04,0.290540E-04,0.288923E-04,0.124695E-02/ | |
23159 | DATA (DL(K),K= 2976, 3060) / | |
23160 | &0.598767E-05,0.282894E-01,0.189287E-01,0.242960E-04,0.310036E-04, | |
23161 | &0.244423E-04,0.242960E-04,0.104112E-02,0.556344E-05,0.243968E-01, | |
23162 | &0.160504E-01,0.203920E-04,0.266363E-04,0.205232E-04,0.203920E-04, | |
23163 | &0.863677E-03,0.510070E-05,0.209890E-01,0.135797E-01,0.170822E-04, | |
23164 | &0.228449E-04,0.171989E-04,0.170822E-04,0.711641E-03,0.462338E-05, | |
23165 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23166 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23167 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23168 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23169 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23170 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23171 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23172 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23173 | &0.105155E+00,0.752467E-01,0.719932E-04,0.719932E-04,0.719932E-04, | |
23174 | &0.719932E-04,0.328057E-02,-.758942E-18,0.920856E-01,0.645455E-01, | |
23175 | &0.592305E-04,0.615087E-04,0.592802E-04,0.592305E-04,0.295327E-02, | |
23176 | &0.945234E-07,0.804695E-01,0.552770E-01,0.489125E-04,0.528632E-04/ | |
23177 | DATA (DL(K),K= 3061, 3145) / | |
23178 | &0.489946E-04,0.489125E-04,0.261804E-02,0.365139E-06,0.701499E-01, | |
23179 | &0.472409E-01,0.404786E-04,0.456186E-04,0.405807E-04,0.404786E-04, | |
23180 | &0.229460E-02,0.686912E-06,0.610049E-01,0.402864E-01,0.335367E-04, | |
23181 | &0.394631E-04,0.336495E-04,0.335367E-04,0.198445E-02,0.981070E-06, | |
23182 | &0.529201E-01,0.342803E-01,0.278134E-04,0.342044E-04,0.279301E-04, | |
23183 | &0.278134E-04,0.169772E-02,0.122521E-05,0.457907E-01,0.291037E-01, | |
23184 | &0.230821E-04,0.296833E-04,0.231978E-04,0.230821E-04,0.144575E-02, | |
23185 | &0.140819E-05,0.395205E-01,0.246522E-01,0.191553E-04,0.257661E-04, | |
23186 | &0.192666E-04,0.191553E-04,0.122125E-02,0.152152E-05,0.340212E-01, | |
23187 | &0.208330E-01,0.158874E-04,0.223546E-04,0.159921E-04,0.158874E-04, | |
23188 | &0.101912E-02,0.156880E-05,0.292116E-01,0.175644E-01,0.131678E-04, | |
23189 | &0.193783E-04,0.132645E-04,0.131678E-04,0.847586E-03,0.156432E-05, | |
23190 | &0.250173E-01,0.147740E-01,0.109029E-04,0.167762E-04,0.109910E-04, | |
23191 | &0.109029E-04,0.705515E-03,0.151845E-05,0.213702E-01,0.123979E-01, | |
23192 | &0.901273E-05,0.144953E-04,0.909200E-05,0.901273E-05,0.581767E-03, | |
23193 | &0.143817E-05,0.182083E-01,0.103797E-01,0.743733E-05,0.124978E-04, | |
23194 | &0.750792E-05,0.743733E-05,0.475483E-03,0.133574E-05,0.154751E-01/ | |
23195 | DATA (DL(K),K= 3146, 3230) / | |
23196 | &0.867011E-02,0.612722E-05,0.107517E-04,0.618950E-05,0.612722E-05, | |
23197 | &0.390116E-03,0.122183E-05,0.131193E-01,0.722560E-02,0.503734E-05, | |
23198 | &0.922584E-05,0.509185E-05,0.503734E-05,0.319980E-03,0.110130E-05, | |
23199 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23200 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23201 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23202 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23203 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23204 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23205 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23206 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23207 | &0.754424E-01,0.449848E-01,0.236444E-04,0.236444E-04,0.236444E-04, | |
23208 | &0.236444E-04,0.129291E-02,0.113079E-17,0.650429E-01,0.379660E-01, | |
23209 | &0.187739E-04,0.207130E-04,0.187990E-04,0.187739E-04,0.124038E-02, | |
23210 | &-.327995E-06,0.559588E-01,0.319936E-01,0.149625E-04,0.182671E-04, | |
23211 | &0.150033E-04,0.149625E-04,0.113497E-02,-.464337E-06,0.480234E-01, | |
23212 | &0.269030E-01,0.119484E-04,0.161746E-04,0.119982E-04,0.119484E-04/ | |
23213 | DATA (DL(K),K= 3231, 3315) / | |
23214 | &0.100877E-02,-.490618E-06,0.411091E-01,0.225716E-01,0.954833E-05, | |
23215 | &0.143391E-04,0.960250E-05,0.954833E-05,0.883852E-03,-.461770E-06, | |
23216 | &0.350995E-01,0.188947E-01,0.763738E-05,0.127129E-04,0.769248E-05, | |
23217 | &0.763738E-05,0.760077E-03,-.403363E-06,0.298897E-01,0.157798E-01, | |
23218 | &0.611070E-05,0.112548E-04,0.616439E-05,0.611070E-05,0.639505E-03, | |
23219 | &-.335607E-06,0.253856E-01,0.131470E-01,0.488993E-05,0.994021E-05, | |
23220 | &0.494070E-05,0.488993E-05,0.534131E-03,-.267652E-06,0.215026E-01, | |
23221 | &0.109271E-01,0.391276E-05,0.875190E-05,0.395967E-05,0.391276E-05, | |
23222 | &0.445478E-03,-.205292E-06,0.181648E-01,0.906007E-02,0.312720E-05, | |
23223 | &0.767418E-05,0.316978E-05,0.312720E-05,0.366232E-03,-.154024E-06, | |
23224 | &0.153041E-01,0.749382E-02,0.249633E-05,0.670002E-05,0.253440E-05, | |
23225 | &0.249633E-05,0.297435E-03,-.112673E-06,0.128596E-01,0.618334E-02, | |
23226 | &0.199074E-05,0.582360E-05,0.202435E-05,0.199074E-05,0.242305E-03, | |
23227 | &-.794410E-07,0.107770E-01,0.508977E-02,0.158457E-05,0.503733E-05, | |
23228 | &0.161393E-05,0.158457E-05,0.196927E-03,-.546702E-07,0.900806E-02, | |
23229 | &0.417964E-02,0.125888E-05,0.433619E-05,0.128428E-05,0.125888E-05, | |
23230 | &0.158171E-03,-.364714E-07,0.751006E-02,0.342418E-02,0.998674E-06/ | |
23231 | DATA (DL(K),K= 3316, 3400) / | |
23232 | &0.371518E-05,0.102046E-05,0.998674E-06,0.126865E-03,-.228706E-07, | |
23233 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23234 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23235 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23236 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23237 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23238 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23239 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23240 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23241 | &0.496787E-01,0.236961E-01,0.607312E-05,0.607312E-05,0.607312E-05, | |
23242 | &0.607312E-05,0.415108E-03,-.140523E-17,0.420445E-01,0.196196E-01, | |
23243 | &0.443589E-05,0.603481E-05,0.444683E-05,0.443589E-05,0.444425E-03, | |
23244 | &-.375397E-06,0.355108E-01,0.162223E-01,0.321766E-05,0.587645E-05, | |
23245 | &0.323504E-05,0.321766E-05,0.432635E-03,-.593989E-06,0.299148E-01, | |
23246 | &0.133836E-01,0.231504E-05,0.562250E-05,0.233581E-05,0.231504E-05, | |
23247 | &0.395801E-03,-.699904E-06,0.251339E-01,0.110157E-01,0.164651E-05, | |
23248 | &0.526880E-05,0.166853E-05,0.164651E-05,0.344925E-03,-.733095E-06/ | |
23249 | DATA (DL(K),K= 3401, 3485) / | |
23250 | &0.210605E-01,0.904539E-02,0.115940E-05,0.485739E-05,0.118122E-05, | |
23251 | &0.115940E-05,0.294439E-03,-.715193E-06,0.175989E-01,0.740944E-02, | |
23252 | &0.808365E-06,0.441709E-05,0.829075E-06,0.808365E-06,0.249093E-03, | |
23253 | &-.665420E-06,0.146656E-01,0.605433E-02,0.555563E-06,0.396078E-05, | |
23254 | &0.574607E-06,0.555563E-06,0.205675E-03,-.600648E-06,0.121872E-01, | |
23255 | &0.493466E-02,0.375914E-06,0.350822E-05,0.393011E-06,0.375914E-06, | |
23256 | &0.166757E-03,-.529210E-06,0.100993E-01,0.401191E-02,0.250032E-06, | |
23257 | &0.307359E-05,0.265094E-06,0.250032E-06,0.135196E-03,-.456996E-06, | |
23258 | &0.834582E-02,0.325348E-02,0.162261E-06,0.266488E-05,0.175325E-06, | |
23259 | &0.162261E-06,0.108862E-03,-.388821E-06,0.687767E-02,0.263179E-02, | |
23260 | &0.102273E-06,0.228913E-05,0.113453E-06,0.102273E-06,0.865539E-04, | |
23261 | &-.326325E-06,0.565221E-02,0.212357E-02,0.620694E-07,0.194975E-05, | |
23262 | &0.715290E-07,0.620694E-07,0.687156E-04,-.270547E-06,0.463248E-02, | |
23263 | &0.170926E-02,0.351992E-07,0.164711E-05,0.431226E-07,0.351992E-07, | |
23264 | &0.543744E-04,-.222379E-06,0.378655E-02,0.137242E-02,0.178902E-07, | |
23265 | &0.138124E-05,0.244675E-07,0.178902E-07,0.426626E-04,-.181158E-06, | |
23266 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23267 | DATA (DL(K),K= 3486, 3570) / | |
23268 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23269 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23270 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23271 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23272 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23273 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23274 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23275 | &0.286141E-01,0.102357E-01,0.105702E-05,0.105702E-05,0.105702E-05, | |
23276 | &0.105702E-05,0.963318E-04,0.591070E-18,0.236608E-01,0.827483E-02, | |
23277 | &0.548552E-06,0.163293E-05,0.551993E-06,0.548552E-06,0.133058E-03, | |
23278 | &-.268677E-06,0.195282E-01,0.668247E-02,0.238780E-06,0.183459E-05, | |
23279 | &0.243802E-06,0.238780E-06,0.135119E-03,-.393414E-06,0.160742E-01, | |
23280 | &0.538444E-02,0.599864E-07,0.183277E-05,0.655085E-07,0.599864E-07, | |
23281 | &0.124554E-03,-.428349E-06,0.131940E-01,0.432750E-02,-.392825E-07, | |
23282 | &0.172071E-05,-.338391E-07,-.392825E-07,0.111121E-03,-.415550E-06, | |
23283 | &0.107996E-01,0.346954E-02,-.875089E-07,0.154604E-05,-.824926E-07, | |
23284 | &-.875089E-07,0.941854E-04,-.376855E-06,0.881435E-02,0.277463E-02/ | |
23285 | DATA (DL(K),K= 3571, 3655) / | |
23286 | &-.103962E-06,0.135013E-05,-.995446E-07,-.103962E-06,0.772195E-04, | |
23287 | &-.326008E-06,0.717317E-02,0.221313E-02,-.102844E-06,0.115335E-05, | |
23288 | &-.990733E-07,-.102844E-06,0.626565E-04,-.272858E-06,0.582050E-02, | |
23289 | &0.176061E-02,-.929503E-07,0.967229E-06,-.898064E-07,-.929503E-07, | |
23290 | &0.499930E-04,-.222828E-06,0.470908E-02,0.139692E-02,-.791495E-07, | |
23291 | &0.800414E-06,-.765797E-07,-.791495E-07,0.394181E-04,-.178141E-06, | |
23292 | &0.379875E-02,0.110542E-02,-.647230E-07,0.655119E-06,-.626567E-07, | |
23293 | &-.647230E-07,0.309999E-04,-.140000E-06,0.305549E-02,0.872447E-03, | |
23294 | &-.515215E-07,0.530834E-06,-.498829E-07,-.515215E-07,0.240354E-04, | |
23295 | &-.108633E-06,0.245058E-02,0.686769E-03,-.400234E-07,0.426835E-06, | |
23296 | &-.387401E-07,-.400234E-07,0.184613E-04,-.832544E-07,0.195984E-02, | |
23297 | &0.539209E-03,-.304312E-07,0.341169E-06,-.294373E-07,-.304312E-07, | |
23298 | &0.143512E-04,-.630818E-07,0.156297E-02,0.422273E-03,-.228633E-07, | |
23299 | &0.271199E-06,-.221014E-07,-.228633E-07,0.110898E-04,-.474683E-07, | |
23300 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23301 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23302 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23303 | DATA (DL(K),K= 3656, 3740) / | |
23304 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23305 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23306 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23307 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23308 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23309 | &0.129345E-01,0.308444E-02,0.903693E-07,0.903693E-07,0.903693E-07, | |
23310 | &0.903693E-07,0.123538E-04,-.166230E-18,0.103598E-01,0.241354E-02, | |
23311 | &0.155648E-06,-.205296E-06,0.154889E-06,0.155648E-06,0.267249E-04, | |
23312 | &0.880707E-07,0.828507E-02,0.188764E-02,0.176333E-06,-.341498E-06, | |
23313 | &0.175220E-06,0.176333E-06,0.306432E-04,0.125718E-06,0.660736E-02, | |
23314 | &0.147304E-02,0.173444E-06,-.383695E-06,0.172215E-06,0.173444E-06, | |
23315 | &0.280787E-04,0.135578E-06,0.525320E-02,0.114618E-02,0.158651E-06, | |
23316 | &-.373371E-06,0.157437E-06,0.158651E-06,0.243526E-04,0.130412E-06, | |
23317 | &0.416429E-02,0.889584E-03,0.137131E-06,-.333468E-06,0.136012E-06, | |
23318 | &0.137131E-06,0.203463E-04,0.116115E-06,0.329102E-02,0.688580E-03, | |
23319 | &0.113839E-06,-.280874E-06,0.112853E-06,0.113839E-06,0.161038E-04, | |
23320 | &0.982305E-07,0.259282E-02,0.531508E-03,0.914374E-07,-.225427E-06/ | |
23321 | DATA (DL(K),K= 3741, 3825) / | |
23322 | &0.905971E-07,0.914374E-07,0.125639E-04,0.798741E-07,0.203641E-02, | |
23323 | &0.409120E-03,0.709595E-07,-.173123E-06,0.702607E-07,0.709595E-07, | |
23324 | &0.979247E-05,0.624138E-07,0.159441E-02,0.314027E-03,0.532256E-07, | |
23325 | &-.127272E-06,0.526566E-07,0.532256E-07,0.741899E-05,0.469253E-07, | |
23326 | &0.124447E-02,0.240357E-03,0.385509E-07,-.888851E-07,0.380956E-07, | |
23327 | &0.385509E-07,0.554070E-05,0.339174E-07,0.968328E-03,0.183454E-03, | |
23328 | &0.267272E-07,-.580277E-07,0.263687E-07,0.267272E-07,0.420032E-05, | |
23329 | &0.233280E-07,0.751159E-03,0.139632E-03,0.174605E-07,-.342016E-07, | |
23330 | &0.171822E-07,0.174605E-07,0.315522E-05,0.149727E-07,0.580936E-03, | |
23331 | &0.105986E-03,0.104515E-07,-.164567E-07,0.102383E-07,0.104515E-07, | |
23332 | &0.230829E-05,0.863527E-08,0.447955E-03,0.802293E-04,0.531954E-08, | |
23333 | &-.376312E-08,0.515829E-08,0.531954E-08,0.170771E-05,0.399662E-08, | |
23334 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23335 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23336 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23337 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23338 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23339 | DATA (DL(K),K= 3826, 3910) / | |
23340 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23341 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23342 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23343 | &0.324478E-02,0.386879E-03,0.135983E-08,0.135983E-08,0.135983E-08, | |
23344 | &0.135983E-08,0.371787E-06,-.274599E-19,0.246219E-02,0.286505E-03, | |
23345 | &-.106852E-06,0.327611E-06,-.106589E-06,-.106852E-06,0.231631E-05, | |
23346 | &-.107814E-06,0.186777E-02,0.212413E-03,-.161566E-06,0.492001E-06, | |
23347 | &-.161179E-06,-.161566E-06,0.311589E-05,-.162249E-06,0.141322E-02, | |
23348 | &0.157212E-03,-.183398E-06,0.557106E-06,-.182972E-06,-.183398E-06, | |
23349 | &0.267943E-05,-.183884E-06,0.106518E-02,0.115892E-03,-.185231E-06, | |
23350 | &0.562185E-06,-.184809E-06,-.185231E-06,0.203027E-05,-.185573E-06, | |
23351 | &0.800350E-03,0.851995E-04,-.174680E-06,0.530096E-06,-.174290E-06, | |
23352 | &-.174680E-06,0.165870E-05,-.174922E-06,0.599444E-03,0.624676E-04, | |
23353 | &-.157644E-06,0.478420E-06,-.157300E-06,-.157644E-06,0.130112E-05, | |
23354 | &-.157815E-06,0.447433E-03,0.456556E-04,-.137838E-06,0.418429E-06, | |
23355 | &-.137543E-06,-.137838E-06,0.903220E-06,-.137958E-06,0.332836E-03, | |
23356 | &0.332643E-04,-.117616E-06,0.357179E-06,-.117368E-06,-.117616E-06/ | |
23357 | DATA (DL(K),K= 3911, 3995) / | |
23358 | &0.636187E-06,-.117699E-06,0.246754E-03,0.241622E-04,-.984560E-07, | |
23359 | &0.299077E-06,-.982529E-07,-.984560E-07,0.481221E-06,-.985144E-07, | |
23360 | &0.182315E-03,0.174961E-04,-.811089E-07,0.246465E-06,-.809446E-07, | |
23361 | &-.811089E-07,0.342859E-06,-.811495E-07,0.134250E-03,0.126299E-04, | |
23362 | &-.659052E-07,0.200354E-06,-.657742E-07,-.659052E-07,0.227840E-06, | |
23363 | &-.659334E-07,0.985288E-04,0.908931E-05,-.529252E-07,0.160947E-06, | |
23364 | &-.528218E-07,-.529252E-07,0.161641E-06,-.529447E-07,0.720750E-04, | |
23365 | &0.652153E-05,-.420621E-07,0.127943E-06,-.419814E-07,-.420621E-07, | |
23366 | &0.119540E-06,-.420756E-07,0.525538E-04,0.466527E-05,-.331141E-07, | |
23367 | &0.100758E-06,-.330516E-07,-.331141E-07,0.808991E-07,-.331233E-07, | |
23368 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23369 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23370 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23371 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23372 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23373 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23374 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23375 | DATA (DL(K),K= 3996, 4000) / | |
23376 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23377 | C | |
23378 | ANS = 0. | |
23379 | IF (X.GT.0.9985) RETURN | |
23380 | IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN | |
23381 | C | |
23382 | IS = S/DELTA+1 | |
23383 | IS1 = IS+1 | |
23384 | DO 1 L=1,25 | |
23385 | KL = L+NDRV*25 | |
23386 | F1(L) = GF(I,IS,KL) | |
23387 | F2(L) = GF(I,IS1,KL) | |
23388 | 1 CONTINUE | |
23389 | A1 = DT_CKMTFF(X,F1) | |
23390 | A2 = DT_CKMTFF(X,F2) | |
23391 | C A1=ALOG(A1) | |
23392 | C A2=ALOG(A2) | |
23393 | S1 = (IS-1)*DELTA | |
23394 | S2 = S1+DELTA | |
23395 | ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1) | |
23396 | C ANS=EXP(ANS) | |
23397 | RETURN | |
23398 | END | |
23399 | C | |
23400 | C | |
23401 | ||
23402 | *$ CREATE DT_CKMTPR.FOR | |
23403 | *COPY DT_CKMTPR | |
23404 | SUBROUTINE DT_CKMTPR(I,NDRV,X,S,ANS) | |
23405 | C | |
23406 | C********************************************************************** | |
23407 | C Proton - PDFs | |
23408 | C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc | |
23409 | C ANS = PDF(I) | |
23410 | C This version by S. Roesler, 31.01.96 | |
23411 | C********************************************************************** | |
23412 | ||
23413 | SAVE | |
23414 | DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000) | |
23415 | EQUIVALENCE (GF(1,1,1),DL(1)) | |
23416 | DATA DELTA/.10/ | |
23417 | C | |
23418 | DATA (DL(K),K= 1, 85) / | |
23419 | &0.367759E+00,0.350609E+00,0.325356E+00,0.325356E+00,0.325356E+00, | |
23420 | &0.325356E+00,0.533117E+01,0.138778E-16,0.427988E+00,0.409718E+00, | |
23421 | &0.382948E+00,0.382920E+00,0.382933E+00,0.382948E+00,0.686279E+01, | |
23422 | &0.611113E-01,0.494752E+00,0.475328E+00,0.447011E+00,0.446959E+00, | |
23423 | &0.446984E+00,0.447011E+00,0.855688E+01,0.128659E+00,0.568248E+00, | |
23424 | &0.547637E+00,0.517743E+00,0.517671E+00,0.517705E+00,0.517743E+00, | |
23425 | &0.104074E+02,0.202846E+00,0.648622E+00,0.626792E+00,0.595289E+00, | |
23426 | &0.595201E+00,0.595244E+00,0.595289E+00,0.124065E+02,0.283819E+00, | |
23427 | &0.735974E+00,0.712890E+00,0.679748E+00,0.679648E+00,0.679696E+00, | |
23428 | &0.679748E+00,0.145441E+02,0.371679E+00,0.830359E+00,0.805987E+00, | |
23429 | &0.771173E+00,0.771066E+00,0.771119E+00,0.771173E+00,0.168081E+02, | |
23430 | &0.466485E+00,0.931778E+00,0.906084E+00,0.869566E+00,0.869456E+00, | |
23431 | &0.869511E+00,0.869566E+00,0.191850E+02,0.568240E+00,0.104018E+01, | |
23432 | &0.101313E+01,0.974873E+00,0.974763E+00,0.974819E+00,0.974873E+00, | |
23433 | &0.216593E+02,0.676890E+00,0.115544E+01,0.112700E+01,0.108698E+01, | |
23434 | &0.108687E+01,0.108693E+01,0.108698E+01,0.242146E+02,0.792321E+00, | |
23435 | &0.127738E+01,0.124751E+01,0.120570E+01,0.120560E+01,0.120565E+01/ | |
23436 | DATA (DL(K),K= 86, 170) / | |
23437 | &0.120570E+01,0.268333E+02,0.914356E+00,0.140577E+01,0.137444E+01, | |
23438 | &0.133079E+01,0.133070E+01,0.133075E+01,0.133079E+01,0.294970E+02, | |
23439 | &0.104275E+01,0.154028E+01,0.150745E+01,0.146194E+01,0.146187E+01, | |
23440 | &0.146192E+01,0.146194E+01,0.321867E+02,0.117720E+01,0.168054E+01, | |
23441 | &0.164619E+01,0.159879E+01,0.159874E+01,0.159877E+01,0.159879E+01, | |
23442 | &0.348836E+02,0.131732E+01,0.182613E+01,0.179020E+01,0.174088E+01, | |
23443 | &0.174086E+01,0.174088E+01,0.174088E+01,0.375685E+02,0.146269E+01, | |
23444 | &0.197653E+01,0.193901E+01,0.188774E+01,0.188774E+01,0.188775E+01, | |
23445 | &0.188774E+01,0.402228E+02,0.161282E+01,0.213121E+01,0.209205E+01, | |
23446 | &0.203880E+01,0.203884E+01,0.203884E+01,0.203880E+01,0.428285E+02, | |
23447 | &0.176714E+01,0.228955E+01,0.224873E+01,0.219348E+01,0.219355E+01, | |
23448 | &0.219353E+01,0.219348E+01,0.453682E+02,0.192507E+01,0.245093E+01, | |
23449 | &0.240840E+01,0.235113E+01,0.235123E+01,0.235120E+01,0.235113E+01, | |
23450 | &0.478258E+02,0.208597E+01,0.000000E+00,0.000000E+00,0.000000E+00, | |
23451 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23452 | &0.349839E+00,0.324128E+00,0.286363E+00,0.286363E+00,0.286363E+00, | |
23453 | &0.286363E+00,0.469694E+01,0.000000E+00,0.398361E+00,0.371065E+00/ | |
23454 | DATA (DL(K),K= 171, 255) / | |
23455 | &0.331239E+00,0.331213E+00,0.331227E+00,0.331239E+00,0.586152E+01, | |
23456 | &0.481683E-01,0.451010E+00,0.422096E+00,0.380182E+00,0.380137E+00, | |
23457 | &0.380161E+00,0.380182E+00,0.711349E+01,0.100378E+00,0.507782E+00, | |
23458 | &0.477215E+00,0.433187E+00,0.433128E+00,0.433160E+00,0.433187E+00, | |
23459 | &0.844371E+01,0.156627E+00,0.568644E+00,0.536390E+00,0.490220E+00, | |
23460 | &0.490152E+00,0.490190E+00,0.490220E+00,0.984291E+01,0.216886E+00, | |
23461 | &0.633517E+00,0.599543E+00,0.551204E+00,0.551133E+00,0.551174E+00, | |
23462 | &0.551204E+00,0.113005E+02,0.281079E+00,0.702295E+00,0.666565E+00, | |
23463 | &0.616031E+00,0.615963E+00,0.616004E+00,0.616031E+00,0.128050E+02, | |
23464 | &0.349101E+00,0.774832E+00,0.737311E+00,0.684556E+00,0.684495E+00, | |
23465 | &0.684535E+00,0.684556E+00,0.143447E+02,0.420809E+00,0.850945E+00, | |
23466 | &0.811598E+00,0.756596E+00,0.756547E+00,0.756583E+00,0.756596E+00, | |
23467 | &0.159073E+02,0.496022E+00,0.930413E+00,0.889207E+00,0.831933E+00, | |
23468 | &0.831901E+00,0.831931E+00,0.831933E+00,0.174801E+02,0.574524E+00, | |
23469 | &0.101298E+01,0.969882E+00,0.910312E+00,0.910301E+00,0.910324E+00, | |
23470 | &0.910312E+00,0.190508E+02,0.656061E+00,0.109836E+01,0.105333E+01, | |
23471 | &0.991445E+00,0.991459E+00,0.991471E+00,0.991445E+00,0.206070E+02/ | |
23472 | DATA (DL(K),K= 256, 340) / | |
23473 | &0.740345E+00,0.118622E+01,0.113923E+01,0.107501E+01,0.107505E+01, | |
23474 | &0.107505E+01,0.107501E+01,0.221368E+02,0.827056E+00,0.127622E+01, | |
23475 | &0.122724E+01,0.116065E+01,0.116073E+01,0.116072E+01,0.116065E+01, | |
23476 | &0.236287E+02,0.915845E+00,0.136797E+01,0.131696E+01,0.124800E+01, | |
23477 | &0.124812E+01,0.124809E+01,0.124800E+01,0.250721E+02,0.100634E+01, | |
23478 | &0.146107E+01,0.140801E+01,0.133666E+01,0.133681E+01,0.133677E+01, | |
23479 | &0.133666E+01,0.264571E+02,0.109813E+01,0.155511E+01,0.149996E+01, | |
23480 | &0.142621E+01,0.142641E+01,0.142634E+01,0.142621E+01,0.277747E+02, | |
23481 | &0.119081E+01,0.164964E+01,0.159239E+01,0.151622E+01,0.151646E+01, | |
23482 | &0.151638E+01,0.151622E+01,0.290168E+02,0.128396E+01,0.174424E+01, | |
23483 | &0.168485E+01,0.160626E+01,0.160655E+01,0.160645E+01,0.160626E+01, | |
23484 | &0.301765E+02,0.137713E+01,0.000000E+00,0.000000E+00,0.000000E+00, | |
23485 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23486 | &0.345345E+00,0.306823E+00,0.250518E+00,0.250518E+00,0.250518E+00, | |
23487 | &0.250518E+00,0.411726E+01,-.138778E-16,0.384210E+00,0.343514E+00, | |
23488 | &0.284500E+00,0.284487E+00,0.284496E+00,0.284500E+00,0.496835E+01, | |
23489 | &0.371582E-01,0.425419E+00,0.382518E+00,0.320782E+00,0.320762E+00/ | |
23490 | DATA (DL(K),K= 341, 425) / | |
23491 | &0.320777E+00,0.320782E+00,0.585504E+01,0.765988E-01,0.468853E+00, | |
23492 | &0.423717E+00,0.359246E+00,0.359226E+00,0.359243E+00,0.359246E+00, | |
23493 | &0.676824E+01,0.118207E+00,0.514392E+00,0.466990E+00,0.399771E+00, | |
23494 | &0.399758E+00,0.399775E+00,0.399771E+00,0.769967E+01,0.161865E+00, | |
23495 | &0.561883E+00,0.512186E+00,0.442209E+00,0.442208E+00,0.442222E+00, | |
23496 | &0.442209E+00,0.864071E+01,0.207426E+00,0.611162E+00,0.559140E+00, | |
23497 | &0.486395E+00,0.486411E+00,0.486420E+00,0.486395E+00,0.958280E+01, | |
23498 | &0.254727E+00,0.662044E+00,0.607667E+00,0.532145E+00,0.532185E+00, | |
23499 | &0.532185E+00,0.532145E+00,0.105176E+02,0.303587E+00,0.714325E+00, | |
23500 | &0.657566E+00,0.579261E+00,0.579328E+00,0.579318E+00,0.579261E+00, | |
23501 | &0.114370E+02,0.353808E+00,0.767786E+00,0.708618E+00,0.627526E+00, | |
23502 | &0.627625E+00,0.627603E+00,0.627526E+00,0.123333E+02,0.405174E+00, | |
23503 | &0.822195E+00,0.760591E+00,0.676711E+00,0.676846E+00,0.676810E+00, | |
23504 | &0.676711E+00,0.131994E+02,0.457458E+00,0.877307E+00,0.813242E+00, | |
23505 | &0.726575E+00,0.726750E+00,0.726697E+00,0.726575E+00,0.140286E+02, | |
23506 | &0.510420E+00,0.932865E+00,0.866317E+00,0.776867E+00,0.777085E+00, | |
23507 | &0.777015E+00,0.776867E+00,0.148150E+02,0.563809E+00,0.988608E+00/ | |
23508 | DATA (DL(K),K= 426, 510) / | |
23509 | &0.919556E+00,0.827330E+00,0.827594E+00,0.827505E+00,0.827330E+00, | |
23510 | &0.155533E+02,0.617368E+00,0.104427E+01,0.972694E+00,0.877703E+00, | |
23511 | &0.878016E+00,0.877907E+00,0.877703E+00,0.162391E+02,0.670837E+00, | |
23512 | &0.109958E+01,0.102547E+01,0.927723E+00,0.928088E+00,0.927957E+00, | |
23513 | &0.927723E+00,0.168687E+02,0.723954E+00,0.115428E+01,0.107761E+01, | |
23514 | &0.977132E+00,0.977550E+00,0.977397E+00,0.977132E+00,0.174391E+02, | |
23515 | &0.776458E+00,0.120809E+01,0.112886E+01,0.102567E+01,0.102615E+01, | |
23516 | &0.102597E+01,0.102567E+01,0.179481E+02,0.828097E+00,0.126078E+01, | |
23517 | &0.117898E+01,0.107310E+01,0.107363E+01,0.107343E+01,0.107310E+01, | |
23518 | &0.183942E+02,0.878621E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23519 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23520 | &0.357586E+00,0.299938E+00,0.216504E+00,0.216504E+00,0.216504E+00, | |
23521 | &0.216504E+00,0.357260E+01,-.277556E-16,0.388529E+00,0.327984E+00, | |
23522 | &0.241161E+00,0.241168E+00,0.241168E+00,0.241161E+00,0.415893E+01, | |
23523 | &0.278429E-01,0.420472E+00,0.357015E+00,0.266823E+00,0.266844E+00, | |
23524 | &0.266842E+00,0.266823E+00,0.474689E+01,0.566783E-01,0.453271E+00, | |
23525 | &0.386886E+00,0.293349E+00,0.293389E+00,0.293381E+00,0.293349E+00/ | |
23526 | DATA (DL(K),K= 511, 595) / | |
23527 | &0.532982E+01,0.863668E-01,0.486793E+00,0.417464E+00,0.320608E+00, | |
23528 | &0.320673E+00,0.320657E+00,0.320608E+00,0.590219E+01,0.116779E+00, | |
23529 | &0.520887E+00,0.448601E+00,0.348454E+00,0.348549E+00,0.348523E+00, | |
23530 | &0.348454E+00,0.645868E+01,0.147773E+00,0.555403E+00,0.480149E+00, | |
23531 | &0.376740E+00,0.376870E+00,0.376831E+00,0.376740E+00,0.699440E+01, | |
23532 | &0.179201E+00,0.590183E+00,0.511950E+00,0.405314E+00,0.405482E+00, | |
23533 | &0.405429E+00,0.405314E+00,0.750493E+01,0.210912E+00,0.625064E+00, | |
23534 | &0.543845E+00,0.434019E+00,0.434229E+00,0.434159E+00,0.434019E+00, | |
23535 | &0.798636E+01,0.242750E+00,0.659882E+00,0.575673E+00,0.462696E+00, | |
23536 | &0.462952E+00,0.462864E+00,0.462696E+00,0.843528E+01,0.274558E+00, | |
23537 | &0.694472E+00,0.607271E+00,0.491188E+00,0.491492E+00,0.491385E+00, | |
23538 | &0.491188E+00,0.884885E+01,0.306178E+00,0.728669E+00,0.638478E+00, | |
23539 | &0.519337E+00,0.519690E+00,0.519563E+00,0.519337E+00,0.922480E+01, | |
23540 | &0.337451E+00,0.762311E+00,0.669133E+00,0.546987E+00,0.547392E+00, | |
23541 | &0.547244E+00,0.546987E+00,0.956139E+01,0.368224E+00,0.795240E+00, | |
23542 | &0.699084E+00,0.573988E+00,0.574447E+00,0.574277E+00,0.573988E+00, | |
23543 | &0.985744E+01,0.398346E+00,0.827302E+00,0.728181E+00,0.600196E+00/ | |
23544 | DATA (DL(K),K= 596, 680) / | |
23545 | &0.600710E+00,0.600518E+00,0.600196E+00,0.101123E+02,0.427671E+00, | |
23546 | &0.858354E+00,0.756282E+00,0.625475E+00,0.626044E+00,0.625829E+00, | |
23547 | &0.625475E+00,0.103258E+02,0.456064E+00,0.888257E+00,0.783256E+00, | |
23548 | &0.649696E+00,0.650321E+00,0.650083E+00,0.649696E+00,0.104982E+02, | |
23549 | &0.483395E+00,0.916887E+00,0.808981E+00,0.672742E+00,0.673422E+00, | |
23550 | &0.673161E+00,0.672742E+00,0.106303E+02,0.509546E+00,0.944126E+00, | |
23551 | &0.833345E+00,0.694506E+00,0.695243E+00,0.694958E+00,0.694506E+00, | |
23552 | &0.107231E+02,0.534410E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23553 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23554 | &0.390721E+00,0.304671E+00,0.182562E+00,0.182562E+00,0.182562E+00, | |
23555 | &0.182562E+00,0.303699E+01,0.693889E-17,0.414806E+00,0.325059E+00, | |
23556 | &0.199103E+00,0.199133E+00,0.199124E+00,0.199103E+00,0.339971E+01, | |
23557 | &0.198528E-01,0.438929E+00,0.345508E+00,0.215797E+00,0.215862E+00, | |
23558 | &0.215842E+00,0.215797E+00,0.374624E+01,0.398420E-01,0.462973E+00, | |
23559 | &0.365903E+00,0.232531E+00,0.232635E+00,0.232601E+00,0.232531E+00, | |
23560 | &0.407322E+01,0.598565E-01,0.486835E+00,0.386142E+00,0.249208E+00, | |
23561 | &0.249352E+00,0.249304E+00,0.249208E+00,0.437817E+01,0.797987E-01/ | |
23562 | DATA (DL(K),K= 681, 765) / | |
23563 | &0.510407E+00,0.406123E+00,0.265725E+00,0.265913E+00,0.265849E+00, | |
23564 | &0.265725E+00,0.465901E+01,0.995694E-01,0.533588E+00,0.425746E+00, | |
23565 | &0.281986E+00,0.282220E+00,0.282139E+00,0.281986E+00,0.491410E+01, | |
23566 | &0.119072E+00,0.556274E+00,0.444912E+00,0.297897E+00,0.298178E+00, | |
23567 | &0.298079E+00,0.297897E+00,0.514220E+01,0.138212E+00,0.578369E+00, | |
23568 | &0.463528E+00,0.313366E+00,0.313696E+00,0.313578E+00,0.313366E+00, | |
23569 | &0.534249E+01,0.156900E+00,0.599777E+00,0.481503E+00,0.328308E+00, | |
23570 | &0.328688E+00,0.328549E+00,0.328308E+00,0.551456E+01,0.175048E+00, | |
23571 | &0.620409E+00,0.498752E+00,0.342642E+00,0.343071E+00,0.342913E+00, | |
23572 | &0.342642E+00,0.565833E+01,0.192575E+00,0.640181E+00,0.515196E+00, | |
23573 | &0.356292E+00,0.356770E+00,0.356592E+00,0.356292E+00,0.577410E+01, | |
23574 | &0.209407E+00,0.659017E+00,0.530764E+00,0.369190E+00,0.369718E+00, | |
23575 | &0.369519E+00,0.369190E+00,0.586243E+01,0.225474E+00,0.676845E+00, | |
23576 | &0.545389E+00,0.381275E+00,0.381852E+00,0.381633E+00,0.381275E+00, | |
23577 | &0.592421E+01,0.240714E+00,0.693604E+00,0.559015E+00,0.392493E+00, | |
23578 | &0.393118E+00,0.392880E+00,0.392493E+00,0.596052E+01,0.255072E+00, | |
23579 | &0.709239E+00,0.571593E+00,0.402799E+00,0.403472E+00,0.403213E+00/ | |
23580 | DATA (DL(K),K= 766, 850) / | |
23581 | &0.402799E+00,0.597267E+01,0.268502E+00,0.723703E+00,0.583081E+00, | |
23582 | &0.412157E+00,0.412875E+00,0.412597E+00,0.412157E+00,0.596211E+01, | |
23583 | &0.280966E+00,0.736960E+00,0.593447E+00,0.420536E+00,0.421299E+00, | |
23584 | &0.421002E+00,0.420536E+00,0.593045E+01,0.292434E+00,0.748980E+00, | |
23585 | &0.602669E+00,0.427918E+00,0.428723E+00,0.428408E+00,0.427918E+00, | |
23586 | &0.587934E+01,0.302884E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23587 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23588 | &0.448390E+00,0.320678E+00,0.146415E+00,0.146415E+00,0.146415E+00, | |
23589 | &0.146415E+00,0.247594E+01,0.000000E+00,0.465760E+00,0.333734E+00, | |
23590 | &0.155974E+00,0.156013E+00,0.156000E+00,0.155974E+00,0.265633E+01, | |
23591 | &0.130329E-01,0.482525E+00,0.346293E+00,0.165233E+00,0.165311E+00, | |
23592 | &0.165285E+00,0.165233E+00,0.281612E+01,0.257304E-01,0.498626E+00, | |
23593 | &0.358294E+00,0.174131E+00,0.174249E+00,0.174209E+00,0.174131E+00, | |
23594 | &0.295484E+01,0.380345E-01,0.514008E+00,0.369688E+00,0.182622E+00, | |
23595 | &0.182779E+00,0.182724E+00,0.182622E+00,0.307242E+01,0.498976E-01, | |
23596 | &0.528624E+00,0.380432E+00,0.190660E+00,0.190856E+00,0.190786E+00, | |
23597 | &0.190660E+00,0.316911E+01,0.612760E-01,0.542428E+00,0.390485E+00/ | |
23598 | DATA (DL(K),K= 851, 935) / | |
23599 | &0.198205E+00,0.198441E+00,0.198356E+00,0.198205E+00,0.324538E+01, | |
23600 | &0.721303E-01,0.555382E+00,0.399810E+00,0.205224E+00,0.205498E+00, | |
23601 | &0.205398E+00,0.205224E+00,0.330192E+01,0.824256E-01,0.567448E+00, | |
23602 | &0.408377E+00,0.211687E+00,0.211997E+00,0.211882E+00,0.211687E+00, | |
23603 | &0.333960E+01,0.921319E-01,0.578597E+00,0.416159E+00,0.217568E+00, | |
23604 | &0.217915E+00,0.217784E+00,0.217568E+00,0.335945E+01,0.101224E+00, | |
23605 | &0.588802E+00,0.423136E+00,0.222847E+00,0.223229E+00,0.223084E+00, | |
23606 | &0.222847E+00,0.336262E+01,0.109681E+00,0.598043E+00,0.429293E+00, | |
23607 | &0.227512E+00,0.227928E+00,0.227768E+00,0.227512E+00,0.335036E+01, | |
23608 | &0.117489E+00,0.606305E+00,0.434619E+00,0.231551E+00,0.232000E+00, | |
23609 | &0.231826E+00,0.231551E+00,0.332398E+01,0.124636E+00,0.613579E+00, | |
23610 | &0.439110E+00,0.234962E+00,0.235442E+00,0.235254E+00,0.234962E+00, | |
23611 | &0.328483E+01,0.131119E+00,0.619860E+00,0.442766E+00,0.237745E+00, | |
23612 | &0.238254E+00,0.238053E+00,0.237745E+00,0.323429E+01,0.136936E+00, | |
23613 | &0.625150E+00,0.445594E+00,0.239905E+00,0.240441E+00,0.240228E+00, | |
23614 | &0.239905E+00,0.317371E+01,0.142091E+00,0.629453E+00,0.447603E+00, | |
23615 | &0.241452E+00,0.242014E+00,0.241788E+00,0.241452E+00,0.310443E+01/ | |
23616 | DATA (DL(K),K= 936, 1020) / | |
23617 | &0.146594E+00,0.632782E+00,0.448808E+00,0.242400E+00,0.242987E+00, | |
23618 | &0.242749E+00,0.242400E+00,0.302775E+01,0.150456E+00,0.635151E+00, | |
23619 | &0.449228E+00,0.242767E+00,0.243376E+00,0.243127E+00,0.242767E+00, | |
23620 | &0.294491E+01,0.153694E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23621 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23622 | &0.528765E+00,0.341825E+00,0.105823E+00,0.105823E+00,0.105823E+00, | |
23623 | &0.105823E+00,0.185069E+01,-.138778E-16,0.538124E+00,0.347118E+00, | |
23624 | &0.109762E+00,0.109780E+00,0.109774E+00,0.109762E+00,0.189644E+01, | |
23625 | &0.738880E-02,0.546541E+00,0.351712E+00,0.113300E+00,0.113336E+00, | |
23626 | &0.113324E+00,0.113300E+00,0.192700E+01,0.143076E-01,0.554014E+00, | |
23627 | &0.355607E+00,0.116431E+00,0.116485E+00,0.116466E+00,0.116431E+00, | |
23628 | &0.194356E+01,0.207515E-01,0.560546E+00,0.358805E+00,0.119150E+00, | |
23629 | &0.119222E+00,0.119196E+00,0.119150E+00,0.194722E+01,0.267179E-01, | |
23630 | &0.566139E+00,0.361311E+00,0.121459E+00,0.121549E+00,0.121515E+00, | |
23631 | &0.121459E+00,0.193921E+01,0.322084E-01,0.570802E+00,0.363134E+00, | |
23632 | &0.123359E+00,0.123467E+00,0.123426E+00,0.123359E+00,0.192071E+01, | |
23633 | &0.372262E-01,0.574542E+00,0.364286E+00,0.124858E+00,0.124983E+00/ | |
23634 | DATA (DL(K),K= 1021, 1105) / | |
23635 | &0.124933E+00,0.124858E+00,0.189295E+01,0.417774E-01,0.577372E+00, | |
23636 | &0.364779E+00,0.125961E+00,0.126103E+00,0.126046E+00,0.125961E+00, | |
23637 | &0.185710E+01,0.458703E-01,0.579307E+00,0.364629E+00,0.126681E+00, | |
23638 | &0.126839E+00,0.126774E+00,0.126681E+00,0.181432E+01,0.495154E-01, | |
23639 | &0.580363E+00,0.363857E+00,0.127029E+00,0.127202E+00,0.127130E+00, | |
23640 | &0.127029E+00,0.176571E+01,0.527252E-01,0.580561E+00,0.362483E+00, | |
23641 | &0.127020E+00,0.127208E+00,0.127128E+00,0.127020E+00,0.171231E+01, | |
23642 | &0.555142E-01,0.579923E+00,0.360529E+00,0.126670E+00,0.126872E+00, | |
23643 | &0.126785E+00,0.126670E+00,0.165511E+01,0.578985E-01,0.578474E+00, | |
23644 | &0.358021E+00,0.125998E+00,0.126213E+00,0.126119E+00,0.125998E+00, | |
23645 | &0.159501E+01,0.598958E-01,0.576241E+00,0.354987E+00,0.125022E+00, | |
23646 | &0.125249E+00,0.125148E+00,0.125022E+00,0.153284E+01,0.615248E-01, | |
23647 | &0.573252E+00,0.351453E+00,0.123762E+00,0.124000E+00,0.123893E+00, | |
23648 | &0.123762E+00,0.146934E+01,0.628056E-01,0.569539E+00,0.347450E+00, | |
23649 | &0.122240E+00,0.122488E+00,0.122375E+00,0.122240E+00,0.140517E+01, | |
23650 | &0.637587E-01,0.565134E+00,0.343008E+00,0.120476E+00,0.120733E+00, | |
23651 | &0.120615E+00,0.120476E+00,0.134093E+01,0.644054E-01,0.560071E+00/ | |
23652 | DATA (DL(K),K= 1106, 1190) / | |
23653 | &0.338158E+00,0.118493E+00,0.118758E+00,0.118635E+00,0.118493E+00, | |
23654 | &0.127712E+01,0.647671E-01,0.000000E+00,0.000000E+00,0.000000E+00, | |
23655 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23656 | &0.584093E+00,0.349173E+00,0.772117E-01,0.772117E-01,0.772117E-01, | |
23657 | &0.772117E-01,0.140433E+01,0.346945E-17,0.586736E+00,0.349017E+00, | |
23658 | &0.785355E-01,0.785519E-01,0.785448E-01,0.785355E-01,0.139434E+01, | |
23659 | &0.447504E-02,0.588402E+00,0.348237E+00,0.795437E-01,0.795759E-01, | |
23660 | &0.795617E-01,0.795437E-01,0.137550E+01,0.854114E-02,0.589124E+00, | |
23661 | &0.346861E+00,0.802498E-01,0.802970E-01,0.802758E-01,0.802498E-01, | |
23662 | &0.134918E+01,0.122148E-01,0.588930E+00,0.344912E+00,0.806656E-01, | |
23663 | &0.807271E-01,0.806990E-01,0.806656E-01,0.131652E+01,0.155101E-01, | |
23664 | &0.587849E+00,0.342417E+00,0.808055E-01,0.808805E-01,0.808457E-01, | |
23665 | &0.808055E-01,0.127862E+01,0.184435E-01,0.585912E+00,0.339402E+00, | |
23666 | &0.806843E-01,0.807718E-01,0.807306E-01,0.806843E-01,0.123648E+01, | |
23667 | &0.210315E-01,0.583151E+00,0.335894E+00,0.803173E-01,0.804166E-01, | |
23668 | &0.803692E-01,0.803173E-01,0.119104E+01,0.232909E-01,0.579599E+00, | |
23669 | &0.331923E+00,0.797205E-01,0.798308E-01,0.797775E-01,0.797205E-01/ | |
23670 | DATA (DL(K),K= 1191, 1275) / | |
23671 | &0.114317E+01,0.252394E-01,0.575288E+00,0.327516E+00,0.789107E-01, | |
23672 | &0.790310E-01,0.789721E-01,0.789107E-01,0.109362E+01,0.268946E-01, | |
23673 | &0.570253E+00,0.322704E+00,0.779045E-01,0.780341E-01,0.779698E-01, | |
23674 | &0.779045E-01,0.104307E+01,0.282745E-01,0.564530E+00,0.317515E+00, | |
23675 | &0.767190E-01,0.768570E-01,0.767878E-01,0.767190E-01,0.992143E+00, | |
23676 | &0.293974E-01,0.558155E+00,0.311981E+00,0.753713E-01,0.755169E-01, | |
23677 | &0.754432E-01,0.753713E-01,0.941341E+00,0.302812E-01,0.551166E+00, | |
23678 | &0.306131E+00,0.738784E-01,0.740308E-01,0.739528E-01,0.738784E-01, | |
23679 | &0.891113E+00,0.309441E-01,0.543599E+00,0.299995E+00,0.722571E-01, | |
23680 | &0.724154E-01,0.723336E-01,0.722571E-01,0.841829E+00,0.314037E-01, | |
23681 | &0.535494E+00,0.293603E+00,0.705237E-01,0.706871E-01,0.706019E-01, | |
23682 | &0.705237E-01,0.793794E+00,0.316774E-01,0.526888E+00,0.286986E+00, | |
23683 | &0.686941E-01,0.688619E-01,0.687736E-01,0.686941E-01,0.747249E+00, | |
23684 | &0.317823E-01,0.517822E+00,0.280172E+00,0.667836E-01,0.669551E-01, | |
23685 | &0.668640E-01,0.667836E-01,0.702381E+00,0.317346E-01,0.508333E+00, | |
23686 | &0.273189E+00,0.648068E-01,0.649814E-01,0.648879E-01,0.648068E-01, | |
23687 | &0.659330E+00,0.315501E-01,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23688 | DATA (DL(K),K= 1276, 1360) / | |
23689 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23690 | &0.622739E+00,0.340676E+00,0.509141E-01,0.509141E-01,0.509141E-01, | |
23691 | &0.509141E-01,0.980502E+00,-.173472E-17,0.617764E+00,0.335457E+00, | |
23692 | &0.507607E-01,0.507701E-01,0.507651E-01,0.507607E-01,0.944375E+00, | |
23693 | &0.242386E-02,0.611957E+00,0.329837E+00,0.504236E-01,0.504417E-01, | |
23694 | &0.504321E-01,0.504236E-01,0.905225E+00,0.455851E-02,0.605372E+00, | |
23695 | &0.323853E+00,0.499207E-01,0.499471E-01,0.499328E-01,0.499207E-01, | |
23696 | &0.864035E+00,0.642656E-02,0.598052E+00,0.317537E+00,0.492668E-01, | |
23697 | &0.493008E-01,0.492822E-01,0.492668E-01,0.821557E+00,0.804638E-02, | |
23698 | &0.590044E+00,0.310919E+00,0.484772E-01,0.485183E-01,0.484955E-01, | |
23699 | &0.484772E-01,0.778444E+00,0.943663E-02,0.581391E+00,0.304033E+00, | |
23700 | &0.475665E-01,0.476142E-01,0.475874E-01,0.475665E-01,0.735263E+00, | |
23701 | &0.106150E-01,0.572137E+00,0.296908E+00,0.465487E-01,0.466024E-01, | |
23702 | &0.465720E-01,0.465487E-01,0.692487E+00,0.115984E-01,0.562326E+00, | |
23703 | &0.289573E+00,0.454376E-01,0.454968E-01,0.454629E-01,0.454376E-01, | |
23704 | &0.650510E+00,0.124032E-01,0.552003E+00,0.282060E+00,0.442463E-01, | |
23705 | &0.443103E-01,0.442733E-01,0.442463E-01,0.609652E+00,0.130451E-01/ | |
23706 | DATA (DL(K),K= 1361, 1445) / | |
23707 | &0.541210E+00,0.274395E+00,0.429871E-01,0.430555E-01,0.430156E-01, | |
23708 | &0.429871E-01,0.570164E+00,0.135389E-01,0.529991E+00,0.266608E+00, | |
23709 | &0.416720E-01,0.417443E-01,0.417018E-01,0.416720E-01,0.532237E+00, | |
23710 | &0.138989E-01,0.518389E+00,0.258725E+00,0.403123E-01,0.403879E-01, | |
23711 | &0.403431E-01,0.403123E-01,0.496010E+00,0.141386E-01,0.506446E+00, | |
23712 | &0.250772E+00,0.389186E-01,0.389971E-01,0.389501E-01,0.389186E-01, | |
23713 | &0.461573E+00,0.142708E-01,0.494204E+00,0.242775E+00,0.375006E-01, | |
23714 | &0.375815E-01,0.375327E-01,0.375006E-01,0.428979E+00,0.143074E-01, | |
23715 | &0.481705E+00,0.234757E+00,0.360674E-01,0.361503E-01,0.361000E-01, | |
23716 | &0.360674E-01,0.398246E+00,0.142598E-01,0.468990E+00,0.226741E+00, | |
23717 | &0.346276E-01,0.347120E-01,0.346605E-01,0.346276E-01,0.369363E+00, | |
23718 | &0.141385E-01,0.456098E+00,0.218750E+00,0.331887E-01,0.332743E-01, | |
23719 | &0.332216E-01,0.331887E-01,0.342300E+00,0.139532E-01,0.443068E+00, | |
23720 | &0.210804E+00,0.317576E-01,0.318440E-01,0.317905E-01,0.317576E-01, | |
23721 | &0.317005E+00,0.137130E-01,0.000000E+00,0.000000E+00,0.000000E+00, | |
23722 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23723 | &0.631458E+00,0.318714E+00,0.335640E-01,0.335640E-01,0.335640E-01/ | |
23724 | DATA (DL(K),K= 1446, 1530) / | |
23725 | &0.335640E-01,0.686773E+00,0.346945E-17,0.620274E+00,0.310241E+00, | |
23726 | &0.329311E-01,0.329377E-01,0.329337E-01,0.329311E-01,0.646559E+00, | |
23727 | &0.135960E-02,0.608504E+00,0.301610E+00,0.322083E-01,0.322210E-01, | |
23728 | &0.322133E-01,0.322083E-01,0.606503E+00,0.252820E-02,0.596205E+00, | |
23729 | &0.292854E+00,0.314099E-01,0.314281E-01,0.314169E-01,0.314099E-01, | |
23730 | &0.567134E+00,0.352543E-02,0.583429E+00,0.284002E+00,0.305470E-01, | |
23731 | &0.305704E-01,0.305558E-01,0.305470E-01,0.528824E+00,0.436693E-02, | |
23732 | &0.570223E+00,0.275080E+00,0.296307E-01,0.296586E-01,0.296411E-01, | |
23733 | &0.296307E-01,0.491848E+00,0.506768E-02,0.556637E+00,0.266115E+00, | |
23734 | &0.286709E-01,0.287030E-01,0.286827E-01,0.286709E-01,0.456422E+00, | |
23735 | &0.564157E-02,0.542717E+00,0.257131E+00,0.276770E-01,0.277128E-01, | |
23736 | &0.276900E-01,0.276770E-01,0.422697E+00,0.610148E-02,0.528511E+00, | |
23737 | &0.248154E+00,0.266578E-01,0.266968E-01,0.266718E-01,0.266578E-01, | |
23738 | &0.390771E+00,0.645942E-02,0.514062E+00,0.239205E+00,0.256210E-01, | |
23739 | &0.256629E-01,0.256359E-01,0.256210E-01,0.360700E+00,0.672653E-02, | |
23740 | &0.499417E+00,0.230307E+00,0.245741E-01,0.246185E-01,0.245896E-01, | |
23741 | &0.245741E-01,0.332498E+00,0.691312E-02,0.484617E+00,0.221480E+00/ | |
23742 | DATA (DL(K),K= 1531, 1615) / | |
23743 | &0.235237E-01,0.235701E-01,0.235397E-01,0.235237E-01,0.306153E+00, | |
23744 | &0.702875E-02,0.469706E+00,0.212745E+00,0.224757E-01,0.225238E-01, | |
23745 | &0.224921E-01,0.224757E-01,0.281624E+00,0.708222E-02,0.454725E+00, | |
23746 | &0.204118E+00,0.214355E-01,0.214850E-01,0.214522E-01,0.214355E-01, | |
23747 | &0.258855E+00,0.708159E-02,0.439713E+00,0.195618E+00,0.204079E-01, | |
23748 | &0.204586E-01,0.204249E-01,0.204079E-01,0.237774E+00,0.703428E-02, | |
23749 | &0.424709E+00,0.187259E+00,0.193972E-01,0.194486E-01,0.194142E-01, | |
23750 | &0.193972E-01,0.218298E+00,0.694702E-02,0.409750E+00,0.179057E+00, | |
23751 | &0.184069E-01,0.184588E-01,0.184239E-01,0.184069E-01,0.200339E+00, | |
23752 | &0.682594E-02,0.394870E+00,0.171023E+00,0.174402E-01,0.174924E-01, | |
23753 | &0.174571E-01,0.174402E-01,0.183804E+00,0.667657E-02,0.380104E+00, | |
23754 | &0.163171E+00,0.164997E-01,0.165519E-01,0.165164E-01,0.164997E-01, | |
23755 | &0.168600E+00,0.650389E-02,0.000000E+00,0.000000E+00,0.000000E+00, | |
23756 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23757 | &0.619056E+00,0.288873E+00,0.218554E-01,0.218554E-01,0.218554E-01, | |
23758 | &0.218554E-01,0.477010E+00,-.867362E-17,0.602890E+00,0.278444E+00, | |
23759 | &0.211480E-01,0.211530E-01,0.211497E-01,0.211480E-01,0.440877E+00/ | |
23760 | DATA (DL(K),K= 1616, 1700) / | |
23761 | &0.767466E-03,0.586431E+00,0.268081E+00,0.204081E-01,0.204175E-01, | |
23762 | &0.204113E-01,0.204081E-01,0.406417E+00,0.141432E-02,0.569736E+00, | |
23763 | &0.257807E+00,0.196446E-01,0.196581E-01,0.196491E-01,0.196446E-01, | |
23764 | &0.373808E+00,0.195508E-02,0.552853E+00,0.247642E+00,0.188646E-01, | |
23765 | &0.188816E-01,0.188701E-01,0.188646E-01,0.343145E+00,0.240123E-02, | |
23766 | &0.535829E+00,0.237603E+00,0.180743E-01,0.180945E-01,0.180808E-01, | |
23767 | &0.180743E-01,0.314460E+00,0.276332E-02,0.518710E+00,0.227710E+00, | |
23768 | &0.172796E-01,0.173025E-01,0.172868E-01,0.172796E-01,0.287750E+00, | |
23769 | &0.305100E-02,0.501539E+00,0.217977E+00,0.164854E-01,0.165108E-01, | |
23770 | &0.164933E-01,0.164854E-01,0.262983E+00,0.327305E-02,0.484360E+00, | |
23771 | &0.208420E+00,0.156964E-01,0.157239E-01,0.157049E-01,0.156964E-01, | |
23772 | &0.240098E+00,0.343744E-02,0.467213E+00,0.199053E+00,0.149165E-01, | |
23773 | &0.149457E-01,0.149254E-01,0.149165E-01,0.219021E+00,0.355144E-02, | |
23774 | &0.450140E+00,0.189889E+00,0.141493E-01,0.141800E-01,0.141586E-01, | |
23775 | &0.141493E-01,0.199660E+00,0.362164E-02,0.433177E+00,0.180939E+00, | |
23776 | &0.133978E-01,0.134297E-01,0.134073E-01,0.133978E-01,0.181918E+00, | |
23777 | &0.365401E-02,0.416362E+00,0.172214E+00,0.126646E-01,0.126974E-01/ | |
23778 | DATA (DL(K),K= 1701, 1785) / | |
23779 | &0.126742E-01,0.126646E-01,0.165692E+00,0.365394E-02,0.399729E+00, | |
23780 | &0.163725E+00,0.119518E-01,0.119853E-01,0.119615E-01,0.119518E-01, | |
23781 | &0.150875E+00,0.362628E-02,0.383310E+00,0.155477E+00,0.112613E-01, | |
23782 | &0.112952E-01,0.112711E-01,0.112613E-01,0.137364E+00,0.357539E-02, | |
23783 | &0.367138E+00,0.147479E+00,0.105945E-01,0.106287E-01,0.106042E-01, | |
23784 | &0.105945E-01,0.125056E+00,0.350515E-02,0.351239E+00,0.139737E+00, | |
23785 | &0.995250E-02,0.998673E-02,0.996211E-02,0.995250E-02,0.113852E+00, | |
23786 | &0.341903E-02,0.335641E+00,0.132253E+00,0.933610E-02,0.937024E-02, | |
23787 | &0.934557E-02,0.933610E-02,0.103659E+00,0.332009E-02,0.320367E+00, | |
23788 | &0.125033E+00,0.874584E-02,0.877973E-02,0.875514E-02,0.874584E-02, | |
23789 | &0.943886E-01,0.321106E-02,0.000000E+00,0.000000E+00,0.000000E+00, | |
23790 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23791 | &0.591114E+00,0.254807E+00,0.139531E-01,0.139531E-01,0.139531E-01, | |
23792 | &0.139531E-01,0.326288E+00,0.000000E+00,0.571121E+00,0.243424E+00, | |
23793 | &0.133325E-01,0.133362E-01,0.133336E-01,0.133325E-01,0.296956E+00, | |
23794 | &0.429082E-03,0.551151E+00,0.232297E+00,0.127105E-01,0.127175E-01, | |
23795 | &0.127126E-01,0.127105E-01,0.269811E+00,0.785137E-03,0.531253E+00/ | |
23796 | DATA (DL(K),K= 1786, 1870) / | |
23797 | &0.221436E+00,0.120916E-01,0.121015E-01,0.120945E-01,0.120916E-01, | |
23798 | &0.244803E+00,0.107790E-02,0.511467E+00,0.210850E+00,0.114794E-01, | |
23799 | &0.114918E-01,0.114829E-01,0.114794E-01,0.221863E+00,0.131504E-02, | |
23800 | &0.491833E+00,0.200545E+00,0.108767E-01,0.108913E-01,0.108808E-01, | |
23801 | &0.108767E-01,0.200886E+00,0.150337E-02,0.472388E+00,0.190531E+00, | |
23802 | &0.102861E-01,0.103027E-01,0.102907E-01,0.102861E-01,0.181762E+00, | |
23803 | &0.164910E-02,0.453170E+00,0.180812E+00,0.970979E-02,0.972799E-02, | |
23804 | &0.971477E-02,0.970979E-02,0.164371E+00,0.175777E-02,0.434213E+00, | |
23805 | &0.171394E+00,0.914959E-02,0.916916E-02,0.915488E-02,0.914959E-02, | |
23806 | &0.148589E+00,0.183434E-02,0.415548E+00,0.162282E+00,0.860700E-02, | |
23807 | &0.862770E-02,0.861252E-02,0.860700E-02,0.134293E+00,0.188328E-02, | |
23808 | &0.397208E+00,0.153479E+00,0.808323E-02,0.810484E-02,0.808891E-02, | |
23809 | &0.808323E-02,0.121361E+00,0.190856E-02,0.379220E+00,0.144989E+00, | |
23810 | &0.757922E-02,0.760152E-02,0.758501E-02,0.757922E-02,0.109676E+00, | |
23811 | &0.191374E-02,0.361611E+00,0.136811E+00,0.709565E-02,0.711846E-02, | |
23812 | &0.710150E-02,0.709565E-02,0.991261E-01,0.190199E-02,0.344406E+00, | |
23813 | &0.128948E+00,0.663300E-02,0.665614E-02,0.663885E-02,0.663300E-02/ | |
23814 | DATA (DL(K),K= 1871, 1955) / | |
23815 | &0.896059E-01,0.187610E-02,0.327627E+00,0.121398E+00,0.619152E-02, | |
23816 | &0.621484E-02,0.619734E-02,0.619152E-02,0.810177E-01,0.183856E-02, | |
23817 | &0.311292E+00,0.114161E+00,0.577130E-02,0.579466E-02,0.577706E-02, | |
23818 | &0.577130E-02,0.732709E-01,0.179155E-02,0.295421E+00,0.107235E+00, | |
23819 | &0.537228E-02,0.539554E-02,0.537794E-02,0.537228E-02,0.662824E-01, | |
23820 | &0.173700E-02,0.280026E+00,0.100616E+00,0.499423E-02,0.501728E-02, | |
23821 | &0.499977E-02,0.499423E-02,0.599766E-01,0.167658E-02,0.265121E+00, | |
23822 | &0.943000E-01,0.463683E-02,0.465958E-02,0.464223E-02,0.463683E-02, | |
23823 | &0.542848E-01,0.161174E-02,0.000000E+00,0.000000E+00,0.000000E+00, | |
23824 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23825 | &0.551659E+00,0.219084E+00,0.867977E-02,0.867977E-02,0.867977E-02, | |
23826 | &0.867977E-02,0.218587E+00,-.173472E-16,0.528947E+00,0.207536E+00, | |
23827 | &0.819621E-02,0.819909E-02,0.819696E-02,0.819621E-02,0.196367E+00, | |
23828 | &0.234843E-03,0.506575E+00,0.196391E+00,0.772540E-02,0.773082E-02, | |
23829 | &0.772680E-02,0.772540E-02,0.176280E+00,0.427503E-03,0.484579E+00, | |
23830 | &0.185646E+00,0.726876E-02,0.727639E-02,0.727069E-02,0.726876E-02, | |
23831 | &0.158158E+00,0.583933E-03,0.462988E+00,0.175298E+00,0.682746E-02/ | |
23832 | DATA (DL(K),K= 1956, 2040) / | |
23833 | &0.683702E-02,0.682985E-02,0.682746E-02,0.141851E+00,0.708874E-03, | |
23834 | &0.441830E+00,0.165345E+00,0.640226E-02,0.641347E-02,0.640502E-02, | |
23835 | &0.640226E-02,0.127203E+00,0.806409E-03,0.421129E+00,0.155783E+00, | |
23836 | &0.599380E-02,0.600641E-02,0.599686E-02,0.599380E-02,0.114065E+00, | |
23837 | &0.880249E-03,0.400912E+00,0.146609E+00,0.560252E-02,0.561629E-02, | |
23838 | &0.560581E-02,0.560252E-02,0.102296E+00,0.933676E-03,0.381199E+00, | |
23839 | &0.137819E+00,0.522870E-02,0.524342E-02,0.523217E-02,0.522870E-02, | |
23840 | &0.917608E-01,0.969607E-03,0.362011E+00,0.129407E+00,0.487247E-02, | |
23841 | &0.488796E-02,0.487607E-02,0.487247E-02,0.823356E-01,0.990632E-03, | |
23842 | &0.343367E+00,0.121370E+00,0.453385E-02,0.454992E-02,0.453753E-02, | |
23843 | &0.453385E-02,0.739054E-01,0.999042E-03,0.325282E+00,0.113700E+00, | |
23844 | &0.421272E-02,0.422921E-02,0.421644E-02,0.421272E-02,0.663651E-01, | |
23845 | &0.996863E-03,0.307770E+00,0.106393E+00,0.390887E-02,0.392563E-02, | |
23846 | &0.391260E-02,0.390887E-02,0.596195E-01,0.985881E-03,0.290841E+00, | |
23847 | &0.994399E-01,0.362199E-02,0.363889E-02,0.362570E-02,0.362199E-02, | |
23848 | &0.535826E-01,0.967664E-03,0.274506E+00,0.928343E-01,0.335170E-02, | |
23849 | &0.336862E-02,0.335536E-02,0.335170E-02,0.481769E-01,0.943587E-03/ | |
23850 | DATA (DL(K),K= 2041, 2125) / | |
23851 | &0.258771E+00,0.865679E-01,0.309756E-02,0.311439E-02,0.310114E-02, | |
23852 | &0.309756E-02,0.433336E-01,0.914850E-03,0.243639E+00,0.806321E-01, | |
23853 | &0.285905E-02,0.287571E-02,0.286255E-02,0.285905E-02,0.389912E-01, | |
23854 | &0.882497E-03,0.229113E+00,0.750177E-01,0.263565E-02,0.265205E-02, | |
23855 | &0.263905E-02,0.263565E-02,0.350948E-01,0.847432E-03,0.215193E+00, | |
23856 | &0.697152E-01,0.242677E-02,0.244285E-02,0.243005E-02,0.242677E-02, | |
23857 | &0.315960E-01,0.810432E-03,0.000000E+00,0.000000E+00,0.000000E+00, | |
23858 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23859 | &0.503850E+00,0.183581E+00,0.522815E-02,0.522815E-02,0.522815E-02, | |
23860 | &0.522815E-02,0.142635E+00,0.123599E-16,0.479478E+00,0.172477E+00, | |
23861 | &0.488093E-02,0.488328E-02,0.488147E-02,0.488093E-02,0.126767E+00, | |
23862 | &0.124505E-03,0.455750E+00,0.161879E+00,0.455054E-02,0.455493E-02, | |
23863 | &0.455153E-02,0.455054E-02,0.112695E+00,0.225968E-03,0.432681E+00, | |
23864 | &0.151771E+00,0.423664E-02,0.424278E-02,0.423800E-02,0.423664E-02, | |
23865 | &0.100212E+00,0.307702E-03,0.410286E+00,0.142140E+00,0.393907E-02, | |
23866 | &0.394671E-02,0.394073E-02,0.393907E-02,0.891488E-01,0.372395E-03, | |
23867 | &0.388577E+00,0.132974E+00,0.365743E-02,0.366634E-02,0.365934E-02/ | |
23868 | DATA (DL(K),K= 2126, 2210) / | |
23869 | &0.365743E-02,0.793490E-01,0.422302E-03,0.367563E+00,0.124259E+00, | |
23870 | &0.339138E-02,0.340133E-02,0.339347E-02,0.339138E-02,0.706688E-01, | |
23871 | &0.459484E-03,0.347256E+00,0.115984E+00,0.314049E-02,0.315129E-02, | |
23872 | &0.314273E-02,0.314049E-02,0.629792E-01,0.485762E-03,0.327660E+00, | |
23873 | &0.108136E+00,0.290433E-02,0.291580E-02,0.290667E-02,0.290433E-02, | |
23874 | &0.561642E-01,0.502744E-03,0.308782E+00,0.100701E+00,0.268243E-02, | |
23875 | &0.269440E-02,0.268483E-02,0.268243E-02,0.501207E-01,0.511853E-03, | |
23876 | &0.290625E+00,0.936693E-01,0.247429E-02,0.248663E-02,0.247672E-02, | |
23877 | &0.247429E-02,0.447569E-01,0.514346E-03,0.273189E+00,0.870261E-01, | |
23878 | &0.227939E-02,0.229197E-02,0.228184E-02,0.227939E-02,0.399920E-01, | |
23879 | &0.511328E-03,0.256475E+00,0.807592E-01,0.209722E-02,0.210991E-02, | |
23880 | &0.209965E-02,0.209722E-02,0.357547E-01,0.503769E-03,0.240478E+00, | |
23881 | &0.748555E-01,0.192721E-02,0.193992E-02,0.192961E-02,0.192721E-02, | |
23882 | &0.319825E-01,0.492518E-03,0.225194E+00,0.693019E-01,0.176883E-02, | |
23883 | &0.178147E-02,0.177117E-02,0.176883E-02,0.286209E-01,0.478318E-03, | |
23884 | &0.210615E+00,0.640851E-01,0.162151E-02,0.163400E-02,0.162379E-02, | |
23885 | &0.162151E-02,0.256219E-01,0.461813E-03,0.196733E+00,0.591917E-01/ | |
23886 | DATA (DL(K),K= 2211, 2295) / | |
23887 | &0.148471E-02,0.149698E-02,0.148691E-02,0.148471E-02,0.229436E-01, | |
23888 | &0.443561E-03,0.183536E+00,0.546085E-01,0.135786E-02,0.136986E-02, | |
23889 | &0.135998E-02,0.135786E-02,0.205496E-01,0.424043E-03,0.171011E+00, | |
23890 | &0.503219E-01,0.124042E-02,0.125211E-02,0.124246E-02,0.124042E-02, | |
23891 | &0.184079E-01,0.403672E-03,0.000000E+00,0.000000E+00,0.000000E+00, | |
23892 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23893 | &0.450310E+00,0.149685E+00,0.302765E-02,0.302765E-02,0.302765E-02, | |
23894 | &0.302765E-02,0.901099E-01,-.108420E-17,0.425282E+00,0.139479E+00, | |
23895 | &0.279499E-02,0.279691E-02,0.279537E-02,0.279499E-02,0.794239E-01, | |
23896 | &0.632140E-04,0.401169E+00,0.129837E+00,0.257801E-02,0.258157E-02, | |
23897 | &0.257870E-02,0.257801E-02,0.700941E-01,0.114711E-03,0.377966E+00, | |
23898 | &0.120733E+00,0.237556E-02,0.238052E-02,0.237650E-02,0.237556E-02, | |
23899 | &0.619270E-01,0.156107E-03,0.355668E+00,0.112145E+00,0.218688E-02, | |
23900 | &0.219301E-02,0.218802E-02,0.218688E-02,0.547717E-01,0.188777E-03, | |
23901 | &0.334269E+00,0.104052E+00,0.201113E-02,0.201823E-02,0.201243E-02, | |
23902 | &0.201113E-02,0.484974E-01,0.213848E-03,0.313762E+00,0.964335E-01, | |
23903 | &0.184758E-02,0.185546E-02,0.184900E-02,0.184758E-02,0.429879E-01/ | |
23904 | DATA (DL(K),K= 2296, 2380) / | |
23905 | &0.232367E-03,0.294139E+00,0.892696E-01,0.169553E-02,0.170402E-02, | |
23906 | &0.169703E-02,0.169553E-02,0.381432E-01,0.245270E-03,0.275389E+00, | |
23907 | &0.825414E-01,0.155431E-02,0.156326E-02,0.155586E-02,0.155431E-02, | |
23908 | &0.338762E-01,0.253383E-03,0.257502E+00,0.762303E-01,0.142329E-02, | |
23909 | &0.143258E-02,0.142487E-02,0.142329E-02,0.301119E-01,0.257441E-03, | |
23910 | &0.240464E+00,0.703180E-01,0.130188E-02,0.131138E-02,0.130347E-02, | |
23911 | &0.130188E-02,0.267853E-01,0.258098E-03,0.224262E+00,0.647867E-01, | |
23912 | &0.118950E-02,0.119912E-02,0.119108E-02,0.118950E-02,0.238409E-01, | |
23913 | &0.255929E-03,0.208879E+00,0.596190E-01,0.108562E-02,0.109526E-02, | |
23914 | &0.108717E-02,0.108562E-02,0.212308E-01,0.251442E-03,0.194298E+00, | |
23915 | &0.547975E-01,0.989698E-03,0.999283E-03,0.991221E-03,0.989698E-03, | |
23916 | &0.189136E-01,0.245082E-03,0.180499E+00,0.503054E-01,0.901248E-03, | |
23917 | &0.910711E-03,0.902726E-03,0.901248E-03,0.168537E-01,0.237238E-03, | |
23918 | &0.167463E+00,0.461263E-01,0.819789E-03,0.829074E-03,0.821215E-03, | |
23919 | &0.819789E-03,0.150206E-01,0.228250E-03,0.155167E+00,0.422438E-01, | |
23920 | &0.744866E-03,0.753925E-03,0.746234E-03,0.744866E-03,0.133878E-01, | |
23921 | &0.218412E-03,0.143590E+00,0.386421E-01,0.676043E-03,0.684836E-03/ | |
23922 | DATA (DL(K),K= 2381, 2465) / | |
23923 | &0.677349E-03,0.676043E-03,0.119320E-01,0.207976E-03,0.132706E+00, | |
23924 | &0.353058E-01,0.612907E-03,0.621403E-03,0.614147E-03,0.612907E-03, | |
23925 | &0.106334E-01,0.197159E-03,0.000000E+00,0.000000E+00,0.000000E+00, | |
23926 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23927 | &0.393307E+00,0.118409E+00,0.167124E-02,0.167124E-02,0.167124E-02, | |
23928 | &0.167124E-02,0.547140E-01,0.433681E-17,0.368555E+00,0.109414E+00, | |
23929 | &0.152547E-02,0.152705E-02,0.152573E-02,0.152547E-02,0.479708E-01, | |
23930 | &0.303147E-04,0.344946E+00,0.101001E+00,0.139202E-02,0.139494E-02, | |
23931 | &0.139249E-02,0.139202E-02,0.421517E-01,0.552185E-04,0.322450E+00, | |
23932 | &0.931345E-01,0.126960E-02,0.127363E-02,0.127024E-02,0.126960E-02, | |
23933 | &0.371043E-01,0.753524E-04,0.301043E+00,0.857854E-01,0.115731E-02, | |
23934 | &0.116225E-02,0.115808E-02,0.115731E-02,0.327131E-01,0.913172E-04, | |
23935 | &0.280698E+00,0.789267E-01,0.105427E-02,0.105995E-02,0.105514E-02, | |
23936 | &0.105427E-02,0.288844E-01,0.103605E-03,0.261390E+00,0.725323E-01, | |
23937 | &0.959726E-03,0.965979E-03,0.960659E-03,0.959726E-03,0.255366E-01, | |
23938 | &0.112688E-03,0.243091E+00,0.665774E-01,0.872987E-03,0.879676E-03, | |
23939 | &0.873966E-03,0.872987E-03,0.226017E-01,0.119000E-03,0.225775E+00/ | |
23940 | DATA (DL(K),K= 2466, 2550) / | |
23941 | &0.610385E-01,0.793435E-03,0.800438E-03,0.794441E-03,0.793435E-03, | |
23942 | &0.200219E-01,0.122931E-03,0.209414E+00,0.558928E-01,0.720508E-03, | |
23943 | &0.727716E-03,0.721524E-03,0.720508E-03,0.177490E-01,0.124835E-03, | |
23944 | &0.193979E+00,0.511187E-01,0.653691E-03,0.661011E-03,0.654703E-03, | |
23945 | &0.653691E-03,0.157425E-01,0.125031E-03,0.179441E+00,0.466950E-01, | |
23946 | &0.592513E-03,0.599863E-03,0.593511E-03,0.592513E-03,0.139674E-01, | |
23947 | &0.123805E-03,0.165770E+00,0.426018E-01,0.536539E-03,0.543850E-03, | |
23948 | &0.537513E-03,0.536539E-03,0.123945E-01,0.121411E-03,0.152935E+00, | |
23949 | &0.388195E-01,0.485370E-03,0.492584E-03,0.486314E-03,0.485370E-03, | |
23950 | &0.109993E-01,0.118076E-03,0.140905E+00,0.353295E-01,0.438636E-03, | |
23951 | &0.445702E-03,0.439543E-03,0.438636E-03,0.976027E-02,0.113999E-03, | |
23952 | &0.129648E+00,0.321137E-01,0.395992E-03,0.402871E-03,0.396859E-03, | |
23953 | &0.395992E-03,0.865895E-02,0.109353E-03,0.119131E+00,0.291550E-01, | |
23954 | &0.357120E-03,0.363779E-03,0.357945E-03,0.357120E-03,0.767960E-02, | |
23955 | &0.104292E-03,0.109323E+00,0.264366E-01,0.321725E-03,0.328139E-03, | |
23956 | &0.322505E-03,0.321725E-03,0.680866E-02,0.989468E-04,0.100191E+00, | |
23957 | &0.239428E-01,0.289531E-03,0.295679E-03,0.290266E-03,0.289531E-03/ | |
23958 | DATA (DL(K),K= 2551, 2635) / | |
23959 | &0.603390E-02,0.934295E-04,0.000000E+00,0.000000E+00,0.000000E+00, | |
23960 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23961 | &0.334851E+00,0.904666E-01,0.869706E-03,0.869706E-03,0.869706E-03, | |
23962 | &0.869706E-03,0.316365E-01,-.311708E-17,0.311223E+00,0.828706E-01, | |
23963 | &0.784673E-03,0.785968E-03,0.784847E-03,0.784673E-03,0.277037E-01, | |
23964 | &0.134749E-04,0.288910E+00,0.758361E-01,0.708234E-03,0.710597E-03, | |
23965 | &0.708543E-03,0.708234E-03,0.243298E-01,0.247881E-04,0.267855E+00, | |
23966 | &0.693222E-01,0.639256E-03,0.642491E-03,0.639671E-03,0.639256E-03, | |
23967 | &0.214125E-01,0.340882E-04,0.248015E+00,0.632964E-01,0.576953E-03, | |
23968 | &0.580887E-03,0.577448E-03,0.576953E-03,0.188764E-01,0.415701E-04, | |
23969 | &0.229343E+00,0.577274E-01,0.520615E-03,0.525096E-03,0.521167E-03, | |
23970 | &0.520615E-03,0.166642E-01,0.474027E-04,0.211794E+00,0.525860E-01, | |
23971 | &0.469624E-03,0.474520E-03,0.470215E-03,0.469624E-03,0.147265E-01, | |
23972 | &0.517615E-04,0.195325E+00,0.478447E-01,0.423445E-03,0.428640E-03, | |
23973 | &0.424060E-03,0.423445E-03,0.130234E-01,0.548213E-04,0.179891E+00, | |
23974 | &0.434776E-01,0.381606E-03,0.387001E-03,0.382232E-03,0.381606E-03, | |
23975 | &0.115226E-01,0.567474E-04,0.165449E+00,0.394601E-01,0.343691E-03/ | |
23976 | DATA (DL(K),K= 2636, 2720) / | |
23977 | &0.349200E-03,0.344317E-03,0.343691E-03,0.101965E-01,0.576952E-04, | |
23978 | &0.151958E+00,0.357691E-01,0.309329E-03,0.314879E-03,0.309948E-03, | |
23979 | &0.309329E-03,0.902217E-02,0.578101E-04,0.139374E+00,0.323826E-01, | |
23980 | &0.278192E-03,0.283721E-03,0.278796E-03,0.278192E-03,0.798131E-02, | |
23981 | &0.572266E-04,0.127655E+00,0.292797E-01,0.249984E-03,0.255440E-03, | |
23982 | &0.250569E-03,0.249984E-03,0.705796E-02,0.560672E-04,0.116760E+00, | |
23983 | &0.264406E-01,0.224440E-03,0.229782E-03,0.225002E-03,0.224440E-03, | |
23984 | &0.623793E-02,0.544420E-04,0.106647E+00,0.238467E-01,0.201321E-03, | |
23985 | &0.206513E-03,0.201856E-03,0.201321E-03,0.550962E-02,0.524504E-04, | |
23986 | &0.972762E-01,0.214802E-01,0.180411E-03,0.185425E-03,0.180918E-03, | |
23987 | &0.180411E-03,0.486321E-02,0.501804E-04,0.886073E-01,0.193242E-01, | |
23988 | &0.161512E-03,0.166328E-03,0.161990E-03,0.161512E-03,0.428946E-02, | |
23989 | &0.477087E-04,0.806013E-01,0.173629E-01,0.144446E-03,0.149048E-03, | |
23990 | &0.144894E-03,0.144446E-03,0.378030E-02,0.451020E-04,0.732197E-01, | |
23991 | &0.155814E-01,0.129049E-03,0.133425E-03,0.129467E-03,0.129049E-03, | |
23992 | &0.332897E-02,0.424179E-04,0.000000E+00,0.000000E+00,0.000000E+00, | |
23993 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23994 | DATA (DL(K),K= 2721, 2805) / | |
23995 | &0.276761E+00,0.663170E-01,0.420483E-03,0.420483E-03,0.420483E-03, | |
23996 | &0.420483E-03,0.172075E-01,0.418773E-17,0.255003E+00,0.601925E-01, | |
23997 | &0.374768E-03,0.375776E-03,0.374876E-03,0.374768E-03,0.151410E-01, | |
23998 | &0.540038E-05,0.234664E+00,0.545789E-01,0.334420E-03,0.336252E-03, | |
23999 | &0.334612E-03,0.334420E-03,0.133594E-01,0.101360E-04,0.215665E+00, | |
24000 | &0.494328E-01,0.298611E-03,0.301108E-03,0.298867E-03,0.298611E-03, | |
24001 | &0.118079E-01,0.141555E-04,0.197941E+00,0.447203E-01,0.266766E-03, | |
24002 | &0.269787E-03,0.267068E-03,0.266766E-03,0.104461E-01,0.174750E-04, | |
24003 | &0.181428E+00,0.404089E-01,0.238391E-03,0.241815E-03,0.238726E-03, | |
24004 | &0.238391E-03,0.924609E-02,0.201244E-04,0.166064E+00,0.364687E-01, | |
24005 | &0.213061E-03,0.216782E-03,0.213417E-03,0.213061E-03,0.818507E-02, | |
24006 | &0.221467E-04,0.151790E+00,0.328719E-01,0.190418E-03,0.194343E-03, | |
24007 | &0.190785E-03,0.190418E-03,0.724366E-02,0.235974E-04,0.138548E+00, | |
24008 | &0.295925E-01,0.170150E-03,0.174202E-03,0.170521E-03,0.170150E-03, | |
24009 | &0.640614E-02,0.245354E-04,0.126282E+00,0.266063E-01,0.151991E-03, | |
24010 | &0.156104E-03,0.152359E-03,0.151991E-03,0.566089E-02,0.250221E-04, | |
24011 | &0.114939E+00,0.238907E-01,0.135710E-03,0.139827E-03,0.136071E-03/ | |
24012 | DATA (DL(K),K= 2806, 2890) / | |
24013 | &0.135710E-03,0.499773E-02,0.251191E-04,0.104465E+00,0.214245E-01, | |
24014 | &0.121106E-03,0.125180E-03,0.121455E-03,0.121106E-03,0.440691E-02, | |
24015 | &0.248850E-04,0.948101E-01,0.191879E-01,0.108002E-03,0.111994E-03, | |
24016 | &0.108337E-03,0.108002E-03,0.388094E-02,0.243760E-04,0.859247E-01, | |
24017 | &0.171625E-01,0.962435E-04,0.100124E-03,0.965624E-04,0.962435E-04, | |
24018 | &0.341379E-02,0.236445E-04,0.777613E-01,0.153309E-01,0.856948E-04, | |
24019 | &0.894394E-04,0.859960E-04,0.856948E-04,0.299910E-02,0.227378E-04, | |
24020 | &0.702736E-01,0.136770E-01,0.762337E-04,0.798235E-04,0.765166E-04, | |
24021 | &0.762337E-04,0.263116E-02,0.216984E-04,0.634174E-01,0.121859E-01, | |
24022 | &0.677528E-04,0.711742E-04,0.680169E-04,0.677528E-04,0.230551E-02, | |
24023 | &0.205642E-04,0.571500E-01,0.108434E-01,0.601554E-04,0.633990E-04, | |
24024 | &0.604008E-04,0.601554E-04,0.201791E-02,0.193681E-04,0.514305E-01, | |
24025 | &0.963651E-02,0.533545E-04,0.564148E-04,0.535814E-04,0.533545E-04, | |
24026 | &0.176404E-02,0.181381E-04,0.000000E+00,0.000000E+00,0.000000E+00, | |
24027 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24028 | &0.220700E+00,0.461964E-01,0.185072E-03,0.185072E-03,0.185072E-03, | |
24029 | &0.185072E-03,0.865568E-02,-.294090E-17,0.201438E+00,0.415162E-01/ | |
24030 | DATA (DL(K),K= 2891, 2975) / | |
24031 | &0.162774E-03,0.163610E-03,0.162842E-03,0.162774E-03,0.772611E-02, | |
24032 | &0.184134E-05,0.183625E+00,0.372730E-01,0.143469E-03,0.144974E-03, | |
24033 | &0.143588E-03,0.143469E-03,0.690038E-02,0.359959E-05,0.167162E+00, | |
24034 | &0.334245E-01,0.126634E-03,0.128666E-03,0.126791E-03,0.126634E-03, | |
24035 | &0.616000E-02,0.518075E-05,0.151966E+00,0.299378E-01,0.111904E-03, | |
24036 | &0.114340E-03,0.112088E-03,0.111904E-03,0.549219E-02,0.654232E-05, | |
24037 | &0.137959E+00,0.267821E-01,0.989836E-04,0.101716E-03,0.991845E-04, | |
24038 | &0.989836E-04,0.488896E-02,0.767008E-05,0.125065E+00,0.239289E-01, | |
24039 | &0.876157E-04,0.905559E-04,0.878269E-04,0.876157E-04,0.434253E-02, | |
24040 | &0.855860E-05,0.113213E+00,0.213524E-01,0.775899E-04,0.806611E-04, | |
24041 | &0.778055E-04,0.775899E-04,0.384886E-02,0.921640E-05,0.102335E+00, | |
24042 | &0.190285E-01,0.687292E-04,0.718676E-04,0.689446E-04,0.687292E-04, | |
24043 | &0.340422E-02,0.965961E-05,0.923671E-01,0.169353E-01,0.608829E-04, | |
24044 | &0.640353E-04,0.610944E-04,0.608829E-04,0.300332E-02,0.990752E-05, | |
24045 | &0.832476E-01,0.150523E-01,0.539242E-04,0.570473E-04,0.541291E-04, | |
24046 | &0.539242E-04,0.264288E-02,0.998320E-05,0.749179E-01,0.133608E-01, | |
24047 | &0.477459E-04,0.508046E-04,0.479422E-04,0.477459E-04,0.232088E-02/ | |
24048 | DATA (DL(K),K= 2976, 3060) / | |
24049 | &0.991147E-05,0.673221E-01,0.118435E-01,0.422554E-04,0.452220E-04, | |
24050 | &0.424417E-04,0.422554E-04,0.203376E-02,0.971603E-05,0.604073E-01, | |
24051 | &0.104845E-01,0.373730E-04,0.402263E-04,0.375483E-04,0.373730E-04, | |
24052 | &0.177791E-02,0.941959E-05,0.541231E-01,0.926900E-02,0.330304E-04, | |
24053 | &0.357544E-04,0.331943E-04,0.330304E-04,0.155117E-02,0.904408E-05, | |
24054 | &0.484216E-01,0.818347E-02,0.291681E-04,0.317517E-04,0.293202E-04, | |
24055 | &0.291681E-04,0.135108E-02,0.860921E-05,0.432578E-01,0.721549E-02, | |
24056 | &0.257333E-04,0.281694E-04,0.258738E-04,0.257333E-04,0.117463E-02, | |
24057 | &0.813214E-05,0.385889E-01,0.635362E-02,0.226802E-04,0.249648E-04, | |
24058 | &0.228093E-04,0.226802E-04,0.101941E-02,0.762814E-05,0.343746E-01, | |
24059 | &0.558739E-02,0.199682E-04,0.221003E-04,0.200863E-04,0.199682E-04, | |
24060 | &0.883469E-03,0.711035E-05,0.000000E+00,0.000000E+00,0.000000E+00, | |
24061 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24062 | &0.168205E+00,0.301419E-01,0.719932E-04,0.719932E-04,0.719932E-04, | |
24063 | &0.719932E-04,0.392825E-02,-.205998E-17,0.151922E+00,0.267932E-01, | |
24064 | &0.623634E-04,0.630456E-04,0.624028E-04,0.623634E-04,0.361412E-02, | |
24065 | &0.457084E-06,0.137042E+00,0.237932E-01,0.541981E-04,0.554098E-04/ | |
24066 | DATA (DL(K),K= 3061, 3145) / | |
24067 | &0.542663E-04,0.541981E-04,0.330342E-02,0.989813E-06,0.123446E+00, | |
24068 | &0.211038E-01,0.472163E-04,0.488314E-04,0.473050E-04,0.472163E-04, | |
24069 | &0.300140E-02,0.152631E-05,0.111042E+00,0.186954E-01,0.412159E-04, | |
24070 | &0.431273E-04,0.413184E-04,0.412159E-04,0.270826E-02,0.202092E-05, | |
24071 | &0.997395E-01,0.165410E-01,0.360433E-04,0.381615E-04,0.361542E-04, | |
24072 | &0.360433E-04,0.242968E-02,0.245400E-05,0.894558E-01,0.146159E-01, | |
24073 | &0.315670E-04,0.338178E-04,0.316822E-04,0.315670E-04,0.216928E-02, | |
24074 | &0.281218E-05,0.801130E-01,0.128978E-01,0.276779E-04,0.300002E-04, | |
24075 | &0.277940E-04,0.276779E-04,0.192603E-02,0.308878E-05,0.716379E-01, | |
24076 | &0.113663E-01,0.242878E-04,0.266317E-04,0.244024E-04,0.242878E-04, | |
24077 | &0.170100E-02,0.328451E-05,0.639623E-01,0.100031E-01,0.213246E-04, | |
24078 | &0.236502E-04,0.214357E-04,0.213246E-04,0.149649E-02,0.340483E-05, | |
24079 | &0.570222E-01,0.879131E-02,0.187277E-04,0.210033E-04,0.188341E-04, | |
24080 | &0.187277E-04,0.131163E-02,0.345656E-05,0.507574E-01,0.771565E-02, | |
24081 | &0.164465E-04,0.186476E-04,0.165471E-04,0.164465E-04,0.114469E-02, | |
24082 | &0.344782E-05,0.451118E-01,0.676223E-02,0.144396E-04,0.165480E-04, | |
24083 | &0.145339E-04,0.144396E-04,0.995649E-03,0.338831E-05,0.400330E-01/ | |
24084 | DATA (DL(K),K= 3146, 3230) / | |
24085 | &0.591841E-02,0.126720E-04,0.146744E-04,0.127597E-04,0.126720E-04, | |
24086 | &0.863829E-03,0.328754E-05,0.354720E-01,0.517273E-02,0.111137E-04, | |
24087 | &0.130013E-04,0.111946E-04,0.111137E-04,0.747293E-03,0.315403E-05, | |
24088 | &0.313830E-01,0.451477E-02,0.973915E-05,0.115067E-04,0.981339E-05, | |
24089 | &0.973915E-05,0.644664E-03,0.299600E-05,0.277237E-01,0.393511E-02, | |
24090 | &0.852687E-05,0.101721E-04,0.859457E-05,0.852687E-05,0.555034E-03, | |
24091 | &0.282099E-05,0.244545E-01,0.342521E-02,0.745784E-05,0.898076E-05, | |
24092 | &0.751926E-05,0.745784E-05,0.476998E-03,0.263530E-05,0.215390E-01, | |
24093 | &0.297737E-02,0.651555E-05,0.791817E-05,0.657100E-05,0.651555E-05, | |
24094 | &0.409096E-03,0.244427E-05,0.000000E+00,0.000000E+00,0.000000E+00, | |
24095 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24096 | &0.120694E+00,0.180081E-01,0.236444E-04,0.236444E-04,0.236444E-04, | |
24097 | &0.236444E-04,0.154817E-02,0.416656E-17,0.107713E+00,0.158098E-01, | |
24098 | &0.200945E-04,0.206098E-04,0.201146E-04,0.200945E-04,0.151249E-02, | |
24099 | &0.192118E-07,0.960063E-01,0.138667E-01,0.171552E-04,0.180593E-04, | |
24100 | &0.171894E-04,0.171552E-04,0.143574E-02,0.116516E-06,0.854477E-01, | |
24101 | &0.121473E-01,0.146986E-04,0.158894E-04,0.147425E-04,0.146986E-04/ | |
24102 | DATA (DL(K),K= 3231, 3315) / | |
24103 | &0.133744E-02,0.251060E-06,0.759386E-01,0.106275E-01,0.126329E-04, | |
24104 | &0.140252E-04,0.126830E-04,0.126329E-04,0.122900E-02,0.395272E-06, | |
24105 | &0.673865E-01,0.928577E-02,0.108901E-04,0.124142E-04,0.109436E-04, | |
24106 | &0.108901E-04,0.111367E-02,0.535145E-06,0.597062E-01,0.810254E-02, | |
24107 | &0.941160E-05,0.110108E-04,0.946648E-05,0.941160E-05,0.996785E-03, | |
24108 | &0.659421E-06,0.528194E-01,0.706039E-02,0.815165E-05,0.978016E-05, | |
24109 | &0.820627E-05,0.815165E-05,0.885152E-03,0.762600E-06,0.466540E-01, | |
24110 | &0.614371E-02,0.707299E-05,0.869464E-05,0.712616E-05,0.707299E-05, | |
24111 | &0.780484E-03,0.842072E-06,0.411433E-01,0.533850E-02,0.614470E-05, | |
24112 | &0.773135E-05,0.619559E-05,0.614470E-05,0.682563E-03,0.896683E-06, | |
24113 | &0.362261E-01,0.463223E-02,0.534297E-05,0.687330E-05,0.539102E-05, | |
24114 | &0.534297E-05,0.593317E-03,0.928176E-06,0.318459E-01,0.401364E-02, | |
24115 | &0.464848E-05,0.610690E-05,0.469333E-05,0.464848E-05,0.513720E-03, | |
24116 | &0.939174E-06,0.279510E-01,0.347266E-02,0.404483E-05,0.542054E-05, | |
24117 | &0.408628E-05,0.404483E-05,0.442713E-03,0.932117E-06,0.244935E-01, | |
24118 | &0.300029E-02,0.351893E-05,0.480507E-05,0.355692E-05,0.351893E-05, | |
24119 | &0.379744E-03,0.910085E-06,0.214299E-01,0.258845E-02,0.306021E-05/ | |
24120 | DATA (DL(K),K= 3316, 3400) / | |
24121 | &0.425313E-05,0.309476E-05,0.306021E-05,0.324785E-03,0.876365E-06, | |
24122 | &0.187200E-01,0.222996E-02,0.265958E-05,0.375823E-05,0.269081E-05, | |
24123 | &0.265958E-05,0.277080E-03,0.833755E-06,0.163273E-01,0.191840E-02, | |
24124 | &0.230942E-05,0.331477E-05,0.233747E-05,0.230942E-05,0.235661E-03, | |
24125 | &0.784780E-06,0.142185E-01,0.164805E-02,0.200337E-05,0.291797E-05, | |
24126 | &0.202844E-05,0.200337E-05,0.199949E-03,0.731774E-06,0.123631E-01, | |
24127 | &0.141382E-02,0.173596E-05,0.256351E-05,0.175824E-05,0.173596E-05, | |
24128 | &0.169376E-03,0.676674E-06,0.000000E+00,0.000000E+00,0.000000E+00, | |
24129 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24130 | &0.794823E-01,0.948208E-02,0.607312E-05,0.607312E-05,0.607312E-05, | |
24131 | &0.607312E-05,0.497062E-03,-.140523E-17,0.699344E-01,0.820355E-02, | |
24132 | &0.500852E-05,0.538347E-05,0.501731E-05,0.500852E-05,0.542262E-03, | |
24133 | &-.714686E-07,0.614560E-01,0.709106E-02,0.415227E-05,0.479898E-05, | |
24134 | &0.416702E-05,0.415227E-05,0.549985E-03,-.960102E-07,0.539240E-01, | |
24135 | &0.612155E-02,0.345977E-05,0.429563E-05,0.347839E-05,0.345977E-05, | |
24136 | &0.531288E-03,-.894946E-07,0.472426E-01,0.527757E-02,0.289508E-05, | |
24137 | &0.385164E-05,0.291595E-05,0.289508E-05,0.495120E-03,-.668594E-07/ | |
24138 | DATA (DL(K),K= 3401, 3485) / | |
24139 | &0.413245E-01,0.454380E-02,0.243524E-05,0.345851E-05,0.245713E-05, | |
24140 | &0.243524E-05,0.452156E-03,-.338861E-07,0.360903E-01,0.390658E-02, | |
24141 | &0.205923E-05,0.310726E-05,0.208123E-05,0.205923E-05,0.406686E-03, | |
24142 | &0.329349E-08,0.314681E-01,0.335393E-02,0.174861E-05,0.278918E-05, | |
24143 | &0.177007E-05,0.174861E-05,0.359402E-03,0.387747E-07,0.273932E-01, | |
24144 | &0.287528E-02,0.149082E-05,0.250013E-05,0.151127E-05,0.149082E-05, | |
24145 | &0.313779E-03,0.705560E-07,0.238068E-01,0.246132E-02,0.127582E-05, | |
24146 | &0.223699E-05,0.129498E-05,0.127582E-05,0.272195E-03,0.975744E-07, | |
24147 | &0.206558E-01,0.210383E-02,0.109488E-05,0.199657E-05,0.111257E-05, | |
24148 | &0.109488E-05,0.234227E-03,0.118651E-06,0.178921E-01,0.179558E-02, | |
24149 | &0.941584E-06,0.177694E-05,0.957733E-06,0.941584E-06,0.199907E-03, | |
24150 | &0.133780E-06,0.154726E-01,0.153020E-02,0.811157E-06,0.157680E-05, | |
24151 | &0.825743E-06,0.811157E-06,0.169849E-03,0.143581E-06,0.133582E-01, | |
24152 | &0.130209E-02,0.699567E-06,0.139481E-05,0.712624E-06,0.699567E-06, | |
24153 | &0.143794E-03,0.148591E-06,0.115137E-01,0.110634E-02,0.603631E-06, | |
24154 | &0.122977E-05,0.615228E-06,0.603631E-06,0.121163E-03,0.149477E-06, | |
24155 | &0.990774E-02,0.938615E-03,0.520920E-06,0.108072E-05,0.531148E-06/ | |
24156 | DATA (DL(K),K= 3486, 3570) / | |
24157 | &0.520920E-06,0.101725E-03,0.147055E-06,0.851194E-02,0.795146E-03, | |
24158 | &0.449441E-06,0.946634E-06,0.458405E-06,0.449441E-06,0.852238E-04, | |
24159 | &0.142064E-06,0.730103E-02,0.672622E-03,0.387542E-06,0.826497E-06, | |
24160 | &0.395353E-06,0.387542E-06,0.712290E-04,0.135149E-06,0.625244E-02, | |
24161 | &0.568155E-03,0.333888E-06,0.719316E-06,0.340658E-06,0.333888E-06, | |
24162 | &0.593824E-04,0.126902E-06,0.000000E+00,0.000000E+00,0.000000E+00, | |
24163 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24164 | &0.457819E-01,0.409492E-02,0.105702E-05,0.105702E-05,0.105702E-05, | |
24165 | &0.105702E-05,0.115350E-03,0.265810E-18,0.395724E-01,0.347873E-02, | |
24166 | &0.812397E-06,0.103880E-05,0.815187E-06,0.812397E-06,0.160406E-03, | |
24167 | &-.555147E-07,0.341639E-01,0.295295E-02,0.627904E-06,0.987449E-06, | |
24168 | &0.632305E-06,0.627904E-06,0.174490E-03,-.847266E-07,0.294481E-01, | |
24169 | &0.250329E-02,0.490075E-06,0.920197E-06,0.495305E-06,0.490075E-06, | |
24170 | &0.174490E-03,-.944763E-07,0.253423E-01,0.211912E-02,0.387225E-06, | |
24171 | &0.845257E-06,0.392760E-06,0.387225E-06,0.167111E-03,-.916775E-07, | |
24172 | &0.217735E-01,0.179138E-02,0.309989E-06,0.766697E-06,0.315473E-06, | |
24173 | &0.309989E-06,0.152540E-03,-.819158E-07,0.186760E-01,0.151211E-02/ | |
24174 | DATA (DL(K),K= 3571, 3655) / | |
24175 | &0.252109E-06,0.688927E-06,0.257316E-06,0.252109E-06,0.135295E-03, | |
24176 | &-.682145E-07,0.159921E-01,0.127447E-02,0.208612E-06,0.614302E-06, | |
24177 | &0.213410E-06,0.208612E-06,0.118648E-03,-.528734E-07,0.136704E-01, | |
24178 | &0.107254E-02,0.175203E-06,0.543807E-06,0.179526E-06,0.175203E-06, | |
24179 | &0.102484E-03,-.379748E-07,0.116656E-01,0.901214E-03,0.149064E-06, | |
24180 | &0.478363E-06,0.152890E-06,0.149064E-06,0.871530E-04,-.245007E-07, | |
24181 | &0.993760E-02,0.756074E-03,0.128274E-06,0.418496E-06,0.131610E-06, | |
24182 | &0.128274E-06,0.735682E-04,-.128491E-07,0.845081E-02,0.633315E-03, | |
24183 | &0.111313E-06,0.364260E-06,0.114187E-06,0.111313E-06,0.617706E-04, | |
24184 | &-.327698E-08,0.717398E-02,0.529654E-03,0.971373E-07,0.315568E-06, | |
24185 | &0.995871E-07,0.971373E-07,0.514764E-04,0.421954E-08,0.607950E-02, | |
24186 | &0.442265E-03,0.850687E-07,0.272228E-06,0.871375E-07,0.850687E-07, | |
24187 | &0.426580E-04,0.982709E-08,0.514311E-02,0.368716E-03,0.746164E-07, | |
24188 | &0.233927E-06,0.763489E-07,0.746164E-07,0.352463E-04,0.137715E-07, | |
24189 | &0.434349E-02,0.306920E-03,0.654439E-07,0.200291E-06,0.668838E-07, | |
24190 | &0.654439E-07,0.290260E-04,0.163078E-07,0.366196E-02,0.255085E-03, | |
24191 | &0.573307E-07,0.170932E-06,0.585192E-07,0.573307E-07,0.238196E-04/ | |
24192 | DATA (DL(K),K= 3656, 3740) / | |
24193 | &0.177037E-07,0.308217E-02,0.211681E-03,0.501185E-07,0.145441E-06, | |
24194 | &0.510931E-07,0.501185E-07,0.195033E-04,0.182028E-07,0.258987E-02, | |
24195 | &0.175396E-03,0.436915E-07,0.123415E-06,0.444860E-07,0.436915E-07, | |
24196 | &0.159423E-04,0.180204E-07,0.000000E+00,0.000000E+00,0.000000E+00, | |
24197 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24198 | &0.206951E-01,0.123383E-02,0.903693E-07,0.903693E-07,0.903693E-07, | |
24199 | &0.903693E-07,0.147928E-04,0.131925E-18,0.174566E-01,0.102241E-02, | |
24200 | &0.892028E-07,0.129792E-07,0.885875E-07,0.892028E-07,0.328931E-04, | |
24201 | &0.168541E-07,0.147092E-01,0.846741E-03,0.841992E-07,-.346085E-07, | |
24202 | &0.832249E-07,0.841992E-07,0.410825E-04,0.262547E-07,0.123736E-01, | |
24203 | &0.700287E-03,0.769173E-07,-.620958E-07,0.757563E-07,0.769173E-07, | |
24204 | &0.418512E-04,0.305542E-07,0.103910E-01,0.578275E-03,0.688622E-07, | |
24205 | &-.753692E-07,0.676306E-07,0.688622E-07,0.392599E-04,0.318183E-07, | |
24206 | &0.871109E-02,0.476815E-03,0.611778E-07,-.782788E-07,0.599557E-07, | |
24207 | &0.611778E-07,0.356221E-04,0.316149E-07,0.728984E-02,0.392546E-03, | |
24208 | &0.537256E-07,-.749101E-07,0.525642E-07,0.537256E-07,0.312295E-04, | |
24209 | &0.301630E-07,0.608951E-02,0.322656E-03,0.466227E-07,-.678673E-07/ | |
24210 | DATA (DL(K),K= 3741, 3825) / | |
24211 | &0.455521E-07,0.466227E-07,0.265816E-04,0.278681E-07,0.507758E-02, | |
24212 | &0.264779E-03,0.400790E-07,-.588670E-07,0.391148E-07,0.400790E-07, | |
24213 | &0.223044E-04,0.251720E-07,0.422604E-02,0.216927E-03,0.341205E-07, | |
24214 | &-.492124E-07,0.332680E-07,0.341205E-07,0.185283E-04,0.222885E-07, | |
24215 | &0.351082E-02,0.177427E-03,0.287480E-07,-.397442E-07,0.280058E-07, | |
24216 | &0.287480E-07,0.152122E-04,0.193702E-07,0.291126E-02,0.144878E-03, | |
24217 | &0.239699E-07,-.309608E-07,0.233320E-07,0.239699E-07,0.123840E-04, | |
24218 | &0.165481E-07,0.240962E-02,0.118102E-03,0.197695E-07,-.231453E-07, | |
24219 | &0.192276E-07,0.197695E-07,0.100316E-04,0.139043E-07,0.199075E-02, | |
24220 | &0.961132E-04,0.161186E-07,-.164194E-07,0.156628E-07,0.161186E-07, | |
24221 | &0.808648E-05,0.114903E-07,0.164168E-02,0.780880E-04,0.129826E-07, | |
24222 | &-.107955E-07,0.126029E-07,0.129826E-07,0.648861E-05,0.933575E-08, | |
24223 | &0.135135E-02,0.633381E-04,0.103192E-07,-.622051E-08,0.100055E-07, | |
24224 | &0.103192E-07,0.519042E-05,0.744979E-08,0.111036E-02,0.512898E-04, | |
24225 | &0.808255E-08,-.260101E-08,0.782557E-08,0.808255E-08,0.414192E-05, | |
24226 | &0.582811E-08,0.910718E-03,0.414657E-04,0.622640E-08,0.177583E-09, | |
24227 | &0.601750E-08,0.622640E-08,0.329729E-05,0.445766E-08,0.745657E-03/ | |
24228 | DATA (DL(K),K= 3826, 3910) / | |
24229 | &0.334694E-04,0.470431E-08,0.223586E-08,0.453577E-08,0.470431E-08, | |
24230 | &0.261981E-05,0.331859E-08,0.000000E+00,0.000000E+00,0.000000E+00, | |
24231 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24232 | &0.519165E-02,0.154752E-03,0.135983E-08,0.135983E-08,0.135983E-08, | |
24233 | &0.135983E-08,0.445189E-06,0.165858E-19,0.420352E-02,0.123002E-03, | |
24234 | &-.202651E-07,0.730203E-07,-.200511E-07,-.202651E-07,0.358557E-05, | |
24235 | &-.213089E-07,0.340143E-02,0.977718E-04,-.356451E-07,0.114908E-06, | |
24236 | &-.353066E-07,-.356451E-07,0.384652E-05,-.364475E-07,0.274771E-02, | |
24237 | &0.776124E-04,-.435588E-07,0.139200E-06,-.431556E-07,-.435588E-07, | |
24238 | &0.404834E-05,-.441752E-07,0.221524E-02,0.614950E-04,-.471629E-07, | |
24239 | &0.150069E-06,-.467352E-07,-.471629E-07,0.391615E-05,-.476355E-07, | |
24240 | &0.178268E-02,0.486476E-04,-.477545E-07,0.151420E-06,-.473296E-07, | |
24241 | &-.477545E-07,0.334100E-05,-.481163E-07,0.143185E-02,0.384202E-04, | |
24242 | &-.462359E-07,0.146515E-06,-.458316E-07,-.462359E-07,0.275426E-05, | |
24243 | &-.465126E-07,0.114781E-02,0.302894E-04,-.434031E-07,0.137587E-06, | |
24244 | &-.430295E-07,-.434031E-07,0.226010E-05,-.436143E-07,0.918288E-03, | |
24245 | &0.238367E-04,-.398089E-07,0.126321E-06,-.394715E-07,-.398089E-07/ | |
24246 | DATA (DL(K),K= 3911, 3995) / | |
24247 | &0.180947E-05,-.399700E-07,0.733193E-03,0.187249E-04,-.358525E-07, | |
24248 | &0.113940E-06,-.355529E-07,-.358525E-07,0.142045E-05,-.359751E-07, | |
24249 | &0.584227E-03,0.146823E-04,-.318183E-07,0.101291E-06,-.315563E-07, | |
24250 | &-.318183E-07,0.110919E-05,-.319115E-07,0.464586E-03,0.114914E-04, | |
24251 | &-.278936E-07,0.889550E-07,-.276671E-07,-.278936E-07,0.860964E-06, | |
24252 | &-.279643E-07,0.368700E-03,0.897731E-05,-.241972E-07,0.773096E-07, | |
24253 | &-.240033E-07,-.241972E-07,0.662825E-06,-.242508E-07,0.292013E-03, | |
24254 | &0.700034E-05,-.208001E-07,0.665779E-07,-.206356E-07,-.208001E-07, | |
24255 | &0.508061E-06,-.208406E-07,0.230814E-03,0.544870E-05,-.177366E-07, | |
24256 | &0.568734E-07,-.175982E-07,-.177366E-07,0.388493E-06,-.177672E-07, | |
24257 | &0.182078E-03,0.423324E-05,-.150157E-07,0.482316E-07,-.149000E-07, | |
24258 | &-.150157E-07,0.296111E-06,-.150387E-07,0.143349E-03,0.328297E-05, | |
24259 | &-.126295E-07,0.406343E-07,-.125335E-07,-.126295E-07,0.225104E-06, | |
24260 | &-.126468E-07,0.112639E-03,0.254145E-05,-.105595E-07,0.340280E-07, | |
24261 | &-.104803E-07,-.105595E-07,0.170871E-06,-.105726E-07,0.883377E-04, | |
24262 | &0.196395E-05,-.878062E-08,0.283380E-07,-.871555E-08,-.878062E-08, | |
24263 | &0.129517E-06,-.879039E-08,0.000000E+00,0.000000E+00,0.000000E+00/ | |
24264 | DATA (DL(K),K= 3996, 4000) / | |
24265 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
24266 | C | |
24267 | ANS = 0. | |
24268 | IF (X.GT.0.9985) RETURN | |
24269 | IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN | |
24270 | C | |
24271 | IS = S/DELTA+1 | |
24272 | IS1 = IS+1 | |
24273 | DO 1 L=1,25 | |
24274 | KL = L+NDRV*25 | |
24275 | F1(L) = GF(I,IS,KL) | |
24276 | F2(L) = GF(I,IS1,KL) | |
24277 | 1 CONTINUE | |
24278 | A1 = DT_CKMTFF(X,F1) | |
24279 | A2 = DT_CKMTFF(X,F2) | |
24280 | C A1=ALOG(A1) | |
24281 | C A2=ALOG(A2) | |
24282 | S1 = (IS-1)*DELTA | |
24283 | S2 = S1+DELTA | |
24284 | ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1) | |
24285 | C ANS=EXP(ANS) | |
24286 | RETURN | |
24287 | END | |
24288 | C | |
24289 | ||
24290 | *$ CREATE DT_CKMTFF.FOR | |
24291 | *COPY DT_CKMTFF | |
24292 | FUNCTION DT_CKMTFF(X,FVL) | |
24293 | C********************************************************************** | |
24294 | C | |
24295 | C LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE | |
24296 | C FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1. | |
24297 | C NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED | |
24298 | C IN MAIN ROUTINE. | |
24299 | C | |
24300 | C********************************************************************** | |
24301 | ||
24302 | SAVE | |
24303 | DIMENSION FVL(25),XGRID(25) | |
24304 | DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15, | |
24305 | *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/ | |
24306 | C | |
24307 | DT_CKMTFF=0. | |
24308 | DO 1 I=1,NX | |
24309 | IF(X.LT.XGRID(I)) GO TO 2 | |
24310 | 1 CONTINUE | |
24311 | 2 I=I-1 | |
24312 | IF(I.EQ.0) THEN | |
24313 | I=I+1 | |
24314 | ELSE IF(I.GT.23) THEN | |
24315 | I=23 | |
24316 | ENDIF | |
24317 | J=I+1 | |
24318 | K=J+1 | |
24319 | AXI=LOG(XGRID(I)) | |
24320 | BXI=LOG(1.-XGRID(I)) | |
24321 | AXJ=LOG(XGRID(J)) | |
24322 | BXJ=LOG(1.-XGRID(J)) | |
24323 | AXK=LOG(XGRID(K)) | |
24324 | BXK=LOG(1.-XGRID(K)) | |
24325 | FI=LOG(ABS(FVL(I)) +1.E-15) | |
24326 | FJ=LOG(ABS(FVL(J)) +1.E-16) | |
24327 | FK=LOG(ABS(FVL(K)) +1.E-17) | |
24328 | DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ) | |
24329 | ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ* | |
24330 | $ BXI))/DET | |
24331 | ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET | |
24332 | BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET | |
24333 | IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.) | |
24334 | 1RETURN | |
24335 | C IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN | |
24336 | C WRITE(6,2001) X,FVL | |
24337 | C 2001 FORMAT(8E12.4) | |
24338 | C WRITE(6,2001) ALPHA,BETA,ALOGA,DET | |
24339 | C ENDIF | |
24340 | DT_CKMTFF=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA | |
24341 | RETURN | |
24342 | END | |
24343 | ||
24344 | *$ CREATE DT_FLUINI.FOR | |
24345 | *COPY DT_FLUINI | |
24346 | * | |
24347 | *===fluini=============================================================* | |
24348 | * | |
24349 | SUBROUTINE DT_FLUINI | |
24350 | ||
24351 | ************************************************************************ | |
24352 | * Initialisation of the nucleon-nucleon cross section fluctuation * | |
24353 | * treatment. The original version by J. Ranft. * | |
24354 | * This version dated 21.04.95 is revised by S. Roesler. * | |
24355 | ************************************************************************ | |
24356 | ||
24357 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
24358 | SAVE | |
24359 | ||
24360 | PARAMETER ( LINP = 10 , | |
24361 | & LOUT = 6 , | |
24362 | & LDAT = 9 ) | |
24363 | ||
24364 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) | |
24365 | ||
24366 | PARAMETER ( A = 0.1D0, | |
24367 | & B = 0.893D0, | |
24368 | & OM = 1.1D0, | |
24369 | & N = 6, | |
24370 | & DX = 0.003D0) | |
24371 | ||
24372 | * n-n cross section fluctuations | |
24373 | PARAMETER (NBINS = 1000) | |
24374 | COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT | |
24375 | DIMENSION FLUSI(NBINS),FLUIX(NBINS) | |
24376 | ||
24377 | WRITE(LOUT,1000) | |
24378 | 1000 FORMAT(/,1X,'FLUINI: hadronic cross section fluctuations ', | |
24379 | & 'treated') | |
24380 | ||
24381 | FLUSU = ZERO | |
24382 | FLUSUU = ZERO | |
24383 | ||
24384 | DO 1 I=1,NBINS | |
24385 | X = DBLE(I)*DX | |
24386 | FLUIX(I) = X | |
24387 | FLUS = ((X-B)/(OM*B))**N | |
24388 | IF (FLUS.LE.20.0D0) THEN | |
24389 | FLUSI(I) = (X/B)*EXP(-FLUS)/(X/B+A) | |
24390 | ELSE | |
24391 | FLUSI(I) = ZERO | |
24392 | ENDIF | |
24393 | FLUSU = FLUSU+FLUSI(I) | |
24394 | 1 CONTINUE | |
24395 | DO 2 I=1,NBINS | |
24396 | FLUSUU = FLUSUU+FLUSI(I)/FLUSU | |
24397 | FLUSI(I) = FLUSUU | |
24398 | 2 CONTINUE | |
24399 | ||
24400 | C WRITE(LOUT,1001) | |
24401 | C1001 FORMAT(1X,'FLUCTUATIONS') | |
24402 | C CALL PLOT(FLUIX,FLUSI,1000,1,1000,0.0D0,0.06D0,0.0D0,0.01D0) | |
24403 | ||
24404 | DO 3 I=1,NBINS | |
24405 | AF = DBLE(I)*0.001D0 | |
24406 | DO 4 J=1,NBINS | |
24407 | IF (AF.LE.FLUSI(J)) THEN | |
24408 | FLUIXX(I) = FLUIX(J) | |
24409 | GOTO 5 | |
24410 | ENDIF | |
24411 | 4 CONTINUE | |
24412 | 5 CONTINUE | |
24413 | 3 CONTINUE | |
24414 | FLUIXX(1) = FLUIX(1) | |
24415 | FLUIXX(NBINS) = FLUIX(NBINS) | |
24416 | ||
24417 | RETURN | |
24418 | END | |
24419 | ||
24420 | *$ CREATE DT_SIGTBL.FOR | |
24421 | *COPY DT_SIGTBL | |
24422 | * | |
24423 | *===sigtab=============================================================* | |
24424 | * | |
24425 | SUBROUTINE DT_SIGTBL(JP,JT,PTOT,SIGE,MODE) | |
24426 | ||
24427 | ************************************************************************ | |
24428 | * This version dated 18.11.95 is written by S. Roesler * | |
24429 | ************************************************************************ | |
24430 | ||
24431 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
24432 | SAVE | |
24433 | ||
24434 | PARAMETER ( LINP = 10 , | |
24435 | & LOUT = 6 , | |
24436 | & LDAT = 9 ) | |
24437 | ||
24438 | PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10, | |
24439 | & OHALF=0.5D0,ONE=1.0D0) | |
24440 | PARAMETER (PLO=0.01D0,PHI=20.0D0,NBINS=150) | |
24441 | ||
24442 | LOGICAL LINIT | |
24443 | ||
24444 | * particle properties (BAMJET index convention) | |
24445 | CHARACTER*8 ANAME | |
24446 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
24447 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
24448 | ||
24449 | DIMENSION SIGEP(5,NBINS+1),SIGEN(5,NBINS+1),IDSIG(23) | |
24450 | DATA IDSIG / 1, 0, 0, 0, 0, 0, 0, 2, 0, 0, | |
24451 | & 0, 0, 3, 4, 0, 0, 0, 0, 0, 0, | |
24452 | & 0, 0, 5/ | |
24453 | DATA LINIT /.FALSE./ | |
24454 | ||
24455 | * precalculation and tabulation of elastic cross sections | |
24456 | IF (ABS(MODE).EQ.1) THEN | |
24457 | IF (MODE.EQ.1) | |
24458 | & OPEN(LDAT,FILE='outdata0/sigtab.out',STATUS='UNKNOWN') | |
24459 | PLABLX = LOG10(PLO) | |
24460 | PLABHX = LOG10(PHI) | |
24461 | DPLAB = (PLABHX-PLABLX)/DBLE(NBINS) | |
24462 | DO 1 I=1,NBINS+1 | |
24463 | PLAB = PLABLX+DBLE(I-1)*DPLAB | |
24464 | PLAB = 10**PLAB | |
24465 | DO 2 IPROJ=1,23 | |
24466 | IDX = IDSIG(IPROJ) | |
24467 | IF (IDX.GT.0) THEN | |
24468 | C CALL DT_SIHNEL(IPROJ,1,PLAB,SIGEP(IDX,I)) | |
24469 | C CALL DT_SIHNEL(IPROJ,8,PLAB,SIGEN(IDX,I)) | |
24470 | DUMZER = ZERO | |
24471 | CALL DT_XSHN(IPROJ,1,PLAB,DUMZER,SIGTOT,SIGEP(IDX,I)) | |
24472 | CALL DT_XSHN(IPROJ,8,PLAB,DUMZER,SIGTOT,SIGEN(IDX,I)) | |
24473 | ENDIF | |
24474 | 2 CONTINUE | |
24475 | IF (MODE.EQ.1) THEN | |
24476 | WRITE(LDAT,1000) PLAB,(SIGEP(IDX,I),IDX=1,5), | |
24477 | & (SIGEN(IDX,I),IDX=1,5) | |
24478 | 1000 FORMAT(F5.1,10F7.2) | |
24479 | ENDIF | |
24480 | 1 CONTINUE | |
24481 | IF (MODE.EQ.1) CLOSE(LDAT) | |
24482 | LINIT = .TRUE. | |
24483 | ELSE | |
24484 | SIGE = -ONE | |
24485 | IF (LINIT.AND.(JP.LE.23).AND.(PTOT.GE.PLO) | |
24486 | & .AND.(PTOT.LE.PHI) ) THEN | |
24487 | IDX = IDSIG(JP) | |
24488 | IF ( (IDX.GT.0).AND.((JT.EQ.1).OR.(JT.EQ.8)) ) THEN | |
24489 | PLABX = LOG10(PTOT) | |
24490 | IF (PLABX.LE.PLABLX) THEN | |
24491 | I1 = 1 | |
24492 | I2 = 1 | |
24493 | ELSEIF (PLABX.GE.PLABHX) THEN | |
24494 | I1 = NBINS+1 | |
24495 | I2 = NBINS+1 | |
24496 | ELSE | |
24497 | I1 = INT((PLABX-PLABLX)/DPLAB)+1 | |
24498 | I2 = I1+1 | |
24499 | ENDIF | |
24500 | PLAB1X = PLABLX+DBLE(I1-1)*DPLAB | |
24501 | PLAB2X = PLABLX+DBLE(I2-1)*DPLAB | |
24502 | PBIN = PLAB2X-PLAB1X | |
24503 | IF (PBIN.GT.TINY10) THEN | |
24504 | RATX = (PLABX-PLAB1X)/(PLAB2X-PLAB1X) | |
24505 | ELSE | |
24506 | RATX = ZERO | |
24507 | ENDIF | |
24508 | IF (JT.EQ.1) THEN | |
24509 | SIG1 = SIGEP(IDX,I1) | |
24510 | SIG2 = SIGEP(IDX,I2) | |
24511 | ELSE | |
24512 | SIG1 = SIGEN(IDX,I1) | |
24513 | SIG2 = SIGEN(IDX,I2) | |
24514 | ENDIF | |
24515 | SIGE = SIG1+RATX*(SIG2-SIG1) | |
24516 | ENDIF | |
24517 | ENDIF | |
24518 | ENDIF | |
24519 | ||
24520 | RETURN | |
24521 | END | |
24522 | ||
24523 | *$ CREATE DT_XSTABL.FOR | |
24524 | *COPY DT_XSTABL | |
24525 | * | |
24526 | *===xstabl=============================================================* | |
24527 | * | |
24528 | SUBROUTINE DT_XSTABL(WHAT,IXSQEL,IRATIO) | |
24529 | ||
24530 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
24531 | SAVE | |
24532 | ||
24533 | PARAMETER ( LINP = 10 , | |
24534 | & LOUT = 6 , | |
24535 | & LDAT = 9 ) | |
24536 | ||
24537 | PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10, | |
24538 | & OHALF=0.5D0,ONE=1.0D0,TWO=2.0D0) | |
24539 | LOGICAL LLAB,LELOG,LQLOG | |
24540 | ||
24541 | * particle properties (BAMJET index convention) | |
24542 | CHARACTER*8 ANAME | |
24543 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
24544 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
24545 | ||
24546 | * properties of interacting particles | |
24547 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
24548 | ||
24549 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
24550 | ||
24551 | * Glauber formalism: cross sections | |
24552 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
24553 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
24554 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
24555 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
24556 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
24557 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
24558 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
24559 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
24560 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
24561 | & BSLOPE,NEBINI,NQBINI | |
24562 | ||
24563 | * emulsion treatment | |
24564 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
24565 | & NCOMPO,IEMUL | |
24566 | ||
24567 | DIMENSION WHAT(6) | |
24568 | ||
24569 | LLAB = (WHAT(1).GT.ZERO).OR.(WHAT(2).GT.ZERO) | |
24570 | ELO = ABS(WHAT(1)) | |
24571 | EHI = ABS(WHAT(2)) | |
24572 | IF (ELO.GT.EHI) ELO = EHI | |
24573 | LELOG = WHAT(3).LT.ZERO | |
24574 | NEBINS = MAX(INT(ABS(WHAT(3))),1) | |
24575 | DEBINS = (EHI-ELO)/DBLE(NEBINS) | |
24576 | IF (LELOG) THEN | |
24577 | AELO = LOG10(ELO) | |
24578 | AEHI = LOG10(EHI) | |
24579 | ADEBIN = (AEHI-AELO)/DBLE(NEBINS) | |
24580 | ENDIF | |
24581 | Q2LO = WHAT(4) | |
24582 | Q2HI = WHAT(5) | |
24583 | IF (Q2LO.GT.Q2HI) Q2LO = Q2HI | |
24584 | LQLOG = WHAT(6).LT.ZERO | |
24585 | NQBINS = MAX(INT(ABS(WHAT(6))),1) | |
24586 | DQBINS = (Q2HI-Q2LO)/DBLE(NQBINS) | |
24587 | IF (LQLOG) THEN | |
24588 | AQ2LO = LOG10(Q2LO) | |
24589 | AQ2HI = LOG10(Q2HI) | |
24590 | ADQBIN = (AQ2HI-AQ2LO)/DBLE(NQBINS) | |
24591 | ENDIF | |
24592 | ||
24593 | IF ( ELO.EQ. EHI) NEBINS = 0 | |
24594 | IF (Q2LO.EQ.Q2HI) NQBINS = 0 | |
24595 | ||
24596 | WRITE(LOUT,1000) ELO,EHI,LLAB,IXSQEL,Q2LO,Q2HI,IJPROJ,IP,IT | |
24597 | 1000 FORMAT(/,1X,'XSTABL: E_lo =',E10.3,' GeV E_hi =',E10.3, | |
24598 | & ' GeV Lab = ',L1,' qel: ',I2,/,10X,'Q2_lo =',F10.5, | |
24599 | & ' GeV^2 Q2_hi =',F10.5,' GeV^2',/,10X,'id_p = ',I2, | |
24600 | & ' A_p = ',I3,' A_t = ',I3,/) | |
24601 | ||
24602 | C IF (IJPROJ.NE.7) THEN | |
24603 | WRITE(LOUT,'(1X,A,/)')'(E,STOT,SELA,SQEP,SQET,SQE2,SINE,SPROD)' | |
24604 | * normalize fractions of emulsion components | |
24605 | IF (NCOMPO.GT.0) THEN | |
24606 | SUMFRA = ZERO | |
24607 | DO 10 I=1,NCOMPO | |
24608 | SUMFRA = SUMFRA+EMUFRA(I) | |
24609 | 10 CONTINUE | |
24610 | IF (SUMFRA.GT.ZERO) THEN | |
24611 | DO 11 I=1,NCOMPO | |
24612 | EMUFRA(I) = EMUFRA(I)/SUMFRA | |
24613 | 11 CONTINUE | |
24614 | ENDIF | |
24615 | ENDIF | |
24616 | C ELSE | |
24617 | C WRITE(LOUT,'(1X,A,/)') '(Q2,E,STOT,ETOT,SIN,EIN,STOT0)' | |
24618 | C ENDIF | |
24619 | DO 1 I=1,NEBINS+1 | |
24620 | IF (LELOG) THEN | |
24621 | E = 10**(AELO+DBLE(I-1)*ADEBIN) | |
24622 | ELSE | |
24623 | E = ELO+DBLE(I-1)*DEBINS | |
24624 | ENDIF | |
24625 | DO 2 J=1,NQBINS+1 | |
24626 | IF (LQLOG) THEN | |
24627 | Q2 = 10**(AQ2LO+DBLE(J-1)*ADQBIN) | |
24628 | ELSE | |
24629 | Q2 = Q2LO+DBLE(J-1)*DQBINS | |
24630 | ENDIF | |
24631 | c IF (IJPROJ.NE.7) THEN | |
24632 | IF (LLAB) THEN | |
24633 | PLAB = ZERO | |
24634 | ECM = ZERO | |
24635 | CALL DT_LTINI(IJPROJ,1,E,PPN0,ECM,0) | |
24636 | ELSE | |
24637 | ECM = E | |
24638 | ENDIF | |
24639 | XI = ZERO | |
24640 | Q2I = ZERO | |
24641 | IF (IJPROJ.EQ.7) Q2I = Q2 | |
24642 | IF (NCOMPO.GT.0) THEN | |
24643 | DO 20 IC=1,NCOMPO | |
24644 | IIT = IEMUMA(IC) | |
24645 | CALL DT_XSGLAU(IP,IIT,IJPROJ,XI,Q2I,ECM,1,1,-IC) | |
24646 | 20 CONTINUE | |
24647 | ELSE | |
24648 | CALL DT_XSGLAU(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,-1) | |
24649 | C CALL AMPLIT(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,1) | |
24650 | ENDIF | |
24651 | IF (NCOMPO.GT.0) THEN | |
24652 | XTOT = ZERO | |
24653 | ETOT = ZERO | |
24654 | XELA = ZERO | |
24655 | EELA = ZERO | |
24656 | XQEP = ZERO | |
24657 | EQEP = ZERO | |
24658 | XQET = ZERO | |
24659 | EQET = ZERO | |
24660 | XQE2 = ZERO | |
24661 | EQE2 = ZERO | |
24662 | XPRO = ZERO | |
24663 | EPRO = ZERO | |
24664 | XPRO1= ZERO | |
24665 | XDEL = ZERO | |
24666 | EDEL = ZERO | |
24667 | XDQE = ZERO | |
24668 | EDQE = ZERO | |
24669 | DO 21 IC=1,NCOMPO | |
24670 | XTOT = XTOT+EMUFRA(IC)*XSTOT(1,1,IC) | |
24671 | ETOT = ETOT+EMUFRA(IC)*XETOT(1,1,IC)**2 | |
24672 | XELA = XELA+EMUFRA(IC)*XSELA(1,1,IC) | |
24673 | EELA = EELA+EMUFRA(IC)*XEELA(1,1,IC)**2 | |
24674 | XQEP = XQEP+EMUFRA(IC)*XSQEP(1,1,IC) | |
24675 | EQEP = EQEP+EMUFRA(IC)*XEQEP(1,1,IC)**2 | |
24676 | XQET = XQET+EMUFRA(IC)*XSQET(1,1,IC) | |
24677 | EQET = EQET+EMUFRA(IC)*XEQET(1,1,IC)**2 | |
24678 | XQE2 = XQE2+EMUFRA(IC)*XSQE2(1,1,IC) | |
24679 | EQE2 = EQE2+EMUFRA(IC)*XEQE2(1,1,IC)**2 | |
24680 | XPRO = XPRO+EMUFRA(IC)*XSPRO(1,1,IC) | |
24681 | EPRO = EPRO+EMUFRA(IC)*XEPRO(1,1,IC)**2 | |
24682 | XDEL = XDEL+EMUFRA(IC)*XSDEL(1,1,IC) | |
24683 | EDEL = EDEL+EMUFRA(IC)*XEDEL(1,1,IC)**2 | |
24684 | XDQE = XDQE+EMUFRA(IC)*XSDQE(1,1,IC) | |
24685 | EDQE = EDQE+EMUFRA(IC)*XEDQE(1,1,IC)**2 | |
24686 | YPRO = XSTOT(1,1,IC)-XSELA(1,1,IC) | |
24687 | & -XSQEP(1,1,IC)-XSQET(1,1,IC) | |
24688 | & -XSQE2(1,1,IC) | |
24689 | XPRO1= XPRO1+EMUFRA(IC)*YPRO | |
24690 | 21 CONTINUE | |
24691 | ETOT = SQRT(ETOT) | |
24692 | EELA = SQRT(EELA) | |
24693 | EQEP = SQRT(EQEP) | |
24694 | EQET = SQRT(EQET) | |
24695 | EQE2 = SQRT(EQE2) | |
24696 | EPRO = SQRT(EPRO) | |
24697 | EDEL = SQRT(EDEL) | |
24698 | EDQE = SQRT(EDQE) | |
24699 | WRITE(LOUT,'(8E9.3)') | |
24700 | & E,XTOT,XELA,XQEP,XQET,XQE2,XPRO,XPRO1 | |
24701 | C WRITE(LOUT,'(4E9.3)') | |
24702 | C & E,XDEL,XDQE,XDEL+XDQE | |
24703 | ELSE | |
24704 | WRITE(LOUT,'(11E10.3)') | |
24705 | & E, | |
24706 | & XSTOT(1,1,1),XSELA(1,1,1),XSQEP(1,1,1),XSQET(1,1,1), | |
24707 | & XSQE2(1,1,1),XSPRO(1,1,1), | |
24708 | & XSTOT(1,1,1)-XSELA(1,1,1)-XSQEP(1,1,1)-XSQET(1,1,1) | |
24709 | & -XSQE2(1,1,1),XSDEL(1,1,1),XSDQE(1,1,1), | |
24710 | & XSDEL(1,1,1)+XSDQE(1,1,1) | |
24711 | C WRITE(LOUT,'(4E9.3)') E,XSDEL(1,1,1),XSDQE(1,1,1), | |
24712 | C & XSDEL(1,1,1)+XSDQE(1,1,1) | |
24713 | ENDIF | |
24714 | c ELSE | |
24715 | c IF (LLAB) THEN | |
24716 | c IF (IT.GT.1) THEN | |
24717 | c IF (IXSQEL.EQ.0) THEN | |
24718 | cC CALL DT_SIGGA(IT, Q2, E,ZERO,ZERO, | |
24719 | cC CALL DT_SIGGA(IT, E,Q2,ZERO,ZERO, | |
24720 | c CALL DT_SIGGA(IT,ZERO,Q2,ZERO,E, | |
24721 | c & STOT,ETOT,SIN,EIN,STOT0) | |
24722 | c IF (IRATIO.EQ.1) THEN | |
24723 | c CALL DT_SIGGP( Q2, E,ZERO,ZERO,STGP,SIGP,SDGP) | |
24724 | cC CALL DT_SIGGP( E,Q2,ZERO,ZERO,STGP,SIGP,SDGP) | |
24725 | cC CALL DT_SIGGP(ZERO,Q2,ZERO,E,STGP,SIGP,SDGP) | |
24726 | c*!! save cross sections | |
24727 | c STOTA = STOT | |
24728 | c ETOTA = ETOT | |
24729 | c STOTP = STGP | |
24730 | c*!! | |
24731 | c STOT = STOT/(DBLE(IT)*STGP) | |
24732 | c SIN = SIN/(DBLE(IT)*SIGP) | |
24733 | c STOT0 = STGP | |
24734 | c ETOT = ZERO | |
24735 | c EIN = ZERO | |
24736 | c ENDIF | |
24737 | c ELSE | |
24738 | c WRITE(LOUT,*) | |
24739 | c & ' XSTABL: qel. xs. not implemented for nuclei' | |
24740 | c STOP | |
24741 | c ENDIF | |
24742 | c ELSE | |
24743 | c ETOT = ZERO | |
24744 | c EIN = ZERO | |
24745 | c STOT0= ZERO | |
24746 | c IF (IXSQEL.EQ.0) THEN | |
24747 | c CALL DT_SIGGP(ZERO,Q2,ZERO,E,STOT,SIN,SDIR) | |
24748 | c ELSE | |
24749 | c SIN = ZERO | |
24750 | c CALL DT_SIGVEL(ZERO,Q2,ZERO,E,IXSQEL,STOT,SIN,STOT0) | |
24751 | c ENDIF | |
24752 | c ENDIF | |
24753 | c ELSE | |
24754 | c IF (IT.GT.1) THEN | |
24755 | c IF (IXSQEL.EQ.0) THEN | |
24756 | c CALL DT_SIGGA(IT,ZERO,Q2,E,ZERO, | |
24757 | c & STOT,ETOT,SIN,EIN,STOT0) | |
24758 | c IF (IRATIO.EQ.1) THEN | |
24759 | c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STGP,SIGP,SDGP) | |
24760 | c*!! save cross sections | |
24761 | c STOTA = STOT | |
24762 | c ETOTA = ETOT | |
24763 | c STOTP = STGP | |
24764 | c*!! | |
24765 | c STOT = STOT/(DBLE(IT)*STGP) | |
24766 | c SIN = SIN/(DBLE(IT)*SIGP) | |
24767 | c STOT0 = STGP | |
24768 | c ETOT = ZERO | |
24769 | c EIN = ZERO | |
24770 | c ENDIF | |
24771 | c ELSE | |
24772 | c WRITE(LOUT,*) | |
24773 | c & ' XSTABL: qel. xs. not implemented for nuclei' | |
24774 | c STOP | |
24775 | c ENDIF | |
24776 | c ELSE | |
24777 | c ETOT = ZERO | |
24778 | c EIN = ZERO | |
24779 | c STOT0= ZERO | |
24780 | c IF (IXSQEL.EQ.0) THEN | |
24781 | c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STOT,SIN,SDIR) | |
24782 | c ELSE | |
24783 | c SIN = ZERO | |
24784 | c CALL DT_SIGVEL(ZERO,Q2,E,ZERO,IXSQEL,STOT,SIN,STOT0) | |
24785 | c ENDIF | |
24786 | c ENDIF | |
24787 | c ENDIF | |
24788 | cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,STOTA,ETOTA,STOTP,ZERO | |
24789 | cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,SDIR | |
24790 | cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,STOT0 | |
24791 | c WRITE(LOUT,'(1X,6E10.3)')Q2,E,STOT,ETOT,SIN,EIN | |
24792 | c ENDIF | |
24793 | 2 CONTINUE | |
24794 | 1 CONTINUE | |
24795 | ||
24796 | RETURN | |
24797 | END | |
24798 | ||
24799 | *$ CREATE DT_TESTXS.FOR | |
24800 | *COPY DT_TESTXS | |
24801 | * | |
24802 | *===testxs=============================================================* | |
24803 | * | |
24804 | SUBROUTINE DT_TESTXS | |
24805 | ||
24806 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
24807 | SAVE | |
24808 | ||
24809 | DIMENSION XSTOT(26,2),XSELA(26,2) | |
24810 | ||
24811 | OPEN(10,FILE='testxs_ptot.out',STATUS='UNKNOWN') | |
24812 | OPEN(11,FILE='testxs_pela.out',STATUS='UNKNOWN') | |
24813 | OPEN(12,FILE='testxs_ntot.out',STATUS='UNKNOWN') | |
24814 | OPEN(13,FILE='testxs_nela.out',STATUS='UNKNOWN') | |
24815 | DUMECM = 0.0D0 | |
24816 | PLABL = 0.01D0 | |
24817 | PLABH = 10000.0D0 | |
24818 | NBINS = 120 | |
24819 | APLABL = LOG10(PLABL) | |
24820 | APLABH = LOG10(PLABH) | |
24821 | ADPLAB = (APLABH-APLABL)/DBLE(NBINS) | |
24822 | DO 1 I=1,NBINS+1 | |
24823 | ADP = APLABL+DBLE(I-1)*ADPLAB | |
24824 | P = 10.0D0**ADP | |
24825 | DO 2 J=1,26 | |
24826 | CALL DT_XSHN(J,1,P,DUMECM,XSTOT(J,1),XSELA(J,1)) | |
24827 | CALL DT_XSHN(J,8,P,DUMECM,XSTOT(J,2),XSELA(J,2)) | |
24828 | 2 CONTINUE | |
24829 | WRITE(10,1000) P,(XSTOT(K,1),K=1,26) | |
24830 | WRITE(11,1000) P,(XSELA(K,1),K=1,26) | |
24831 | WRITE(12,1000) P,(XSTOT(K,2),K=1,26) | |
24832 | WRITE(13,1000) P,(XSELA(K,2),K=1,26) | |
24833 | 1 CONTINUE | |
24834 | 1000 FORMAT(F8.3,26F9.3) | |
24835 | ||
24836 | RETURN | |
24837 | END | |
24838 | ************************************************************************ | |
24839 | * * | |
24840 | * DTUNUC 2.0: library routines * | |
24841 | * processed by S. Roesler, 6.5.95 * | |
24842 | * * | |
24843 | ************************************************************************ | |
24844 | * | |
24845 | * 1) Handling of parton momenta | |
24846 | * SUBROUTINE MASHEL | |
24847 | * SUBROUTINE DFERMI | |
24848 | * | |
24849 | * 2) Handling of parton flavors and particle indices | |
24850 | * INTEGER FUNCTION IPDG2B | |
24851 | * INTEGER FUNCTION IB2PDG | |
24852 | * INTEGER FUNCTION IQUARK | |
24853 | * INTEGER FUNCTION IBJQUA | |
24854 | * INTEGER FUNCTION ICIHAD | |
24855 | * INTEGER FUNCTION IPDGHA | |
24856 | * INTEGER FUNCTION MCHAD | |
24857 | * SUBROUTINE FLAHAD | |
24858 | * | |
24859 | * 3) Energy-momentum and quantum number conservation check routines | |
24860 | * SUBROUTINE EMC1 | |
24861 | * SUBROUTINE EMC2 | |
24862 | * SUBROUTINE EVTEMC | |
24863 | * SUBROUTINE EVTFLC | |
24864 | * SUBROUTINE EVTCHG | |
24865 | * | |
24866 | * 4) Transformations | |
24867 | * SUBROUTINE LTINI | |
24868 | * SUBROUTINE LTRANS | |
24869 | * SUBROUTINE LTNUC | |
24870 | * SUBROUTINE DALTRA | |
24871 | * SUBROUTINE DTRAFO | |
24872 | * SUBROUTINE STTRAN | |
24873 | * SUBROUTINE MYTRAN | |
24874 | * SUBROUTINE LT2LAO | |
24875 | * SUBROUTINE LT2LAB | |
24876 | * | |
24877 | * 5) Sampling from distributions | |
24878 | * INTEGER FUNCTION NPOISS | |
24879 | * DOUBLE PRECISION FUNCTION SAMPXB | |
24880 | * DOUBLE PRECISION FUNCTION SAMPEX | |
24881 | * DOUBLE PRECISION FUNCTION SAMSQX | |
24882 | * DOUBLE PRECISION FUNCTION BETREJ | |
24883 | * DOUBLE PRECISION FUNCTION DGAMRN | |
24884 | * DOUBLE PRECISION FUNCTION DBETAR | |
24885 | * SUBROUTINE RANNOR | |
24886 | * SUBROUTINE DPOLI | |
24887 | * SUBROUTINE DSFECF | |
24888 | * SUBROUTINE RACO | |
24889 | * | |
24890 | * 6) Special functions, algorithms and service routines | |
24891 | * DOUBLE PRECISION FUNCTION YLAMB | |
24892 | * SUBROUTINE SORT | |
24893 | * SUBROUTINE SORT1 | |
24894 | * SUBROUTINE DT_XTIME | |
24895 | * | |
24896 | * 7) Random number generator package | |
24897 | * DOUBLE PRECISION FUNCTION DT_RNDM | |
24898 | * SUBROUTINE DT_RNDMST | |
24899 | * SUBROUTINE DT_RNDMIN | |
24900 | * SUBROUTINE DT_RNDMOU | |
24901 | * SUBROUTINE DT_RNDMTE | |
24902 | * | |
24903 | ************************************************************************ | |
24904 | * * | |
24905 | * 1) Handling of parton momenta * | |
24906 | * * | |
24907 | ************************************************************************ | |
24908 | *$ CREATE DT_MASHEL.FOR | |
24909 | *COPY DT_MASHEL | |
24910 | * | |
24911 | *===mashel=============================================================* | |
24912 | * | |
24913 | SUBROUTINE DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ) | |
24914 | ||
24915 | ************************************************************************ | |
24916 | * * | |
24917 | * rescaling of momenta of two partons to put both * | |
24918 | * on mass shell * | |
24919 | * * | |
24920 | * input: PA1,PA2 input momentum vectors * | |
24921 | * XM1,2 desired masses of particles afterwards * | |
24922 | * P1,P2 changed momentum vectors * | |
24923 | * * | |
24924 | * The original version is written by R. Engel. * | |
24925 | * This version dated 12.12.94 is modified by S. Roesler. * | |
24926 | ************************************************************************ | |
24927 | ||
24928 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
24929 | SAVE | |
24930 | ||
24931 | PARAMETER ( LINP = 10 , | |
24932 | & LOUT = 6 , | |
24933 | & LDAT = 9 ) | |
24934 | ||
24935 | PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0) | |
24936 | ||
24937 | DIMENSION PA1(4),PA2(4),P1(4),P2(4) | |
24938 | ||
24939 | IREJ = 0 | |
24940 | ||
24941 | * Lorentz transformation into system CMS | |
24942 | PX = PA1(1)+PA2(1) | |
24943 | PY = PA1(2)+PA2(2) | |
24944 | PZ = PA1(3)+PA2(3) | |
24945 | EE = PA1(4)+PA2(4) | |
24946 | XPTOT = SQRT(PX**2+PY**2+PZ**2) | |
24947 | XMS = (EE-XPTOT)*(EE+XPTOT) | |
24948 | IF(XMS.LT.(XM1+XM2)**2) THEN | |
24949 | C WRITE(LOUT,'(3E12.4)')XMS,XM1,XM2 | |
24950 | GOTO 9999 | |
24951 | ENDIF | |
24952 | XMS = SQRT(XMS) | |
24953 | BGX = PX/XMS | |
24954 | BGY = PY/XMS | |
24955 | BGZ = PZ/XMS | |
24956 | GAM = EE/XMS | |
24957 | CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3), | |
24958 | & PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4)) | |
24959 | * rotation angles | |
24960 | COD = P1(3)/PTOT1 | |
24961 | C SID = SQRT((ONE-COD)*(ONE+COD)) | |
24962 | PPT = SQRT(P1(1)**2+P1(2)**2) | |
24963 | SID = PPT/PTOT1 | |
24964 | COF = ONE | |
24965 | SIF = ZERO | |
24966 | IF(PTOT1*SID.GT.TINY10) THEN | |
24967 | COF = P1(1)/(SID*PTOT1) | |
24968 | SIF = P1(2)/(SID*PTOT1) | |
24969 | ANORF = SQRT(COF*COF+SIF*SIF) | |
24970 | COF = COF/ANORF | |
24971 | SIF = SIF/ANORF | |
24972 | ENDIF | |
24973 | * new CM momentum and energies (for masses XM1,XM2) | |
24974 | XM12 = SIGN(XM1**2,XM1) | |
24975 | XM22 = SIGN(XM2**2,XM2) | |
24976 | SS = XMS**2 | |
24977 | PCMP = DT_YLAMB(SS,XM12,XM22)/(2.D0*XMS) | |
24978 | EE1 = SQRT(XM12+PCMP**2) | |
24979 | EE2 = XMS-EE1 | |
24980 | * back rotation | |
24981 | MODE = 1 | |
24982 | CALL DT_MYTRAN(MODE,ZERO,ZERO,PCMP,COD,SID,COF,SIF,XX,YY,ZZ) | |
24983 | CALL DT_DALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1, | |
24984 | & PTOT1,P1(1),P1(2),P1(3),P1(4)) | |
24985 | CALL DT_DALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2, | |
24986 | & PTOT2,P2(1),P2(2),P2(3),P2(4)) | |
24987 | * check consistency | |
24988 | DEL = XMS*0.0001D0 | |
24989 | IF (ABS(PX-P1(1)-P2(1)).GT.DEL) THEN | |
24990 | IDEV = 1 | |
24991 | ELSEIF (ABS(PY-P1(2)-P2(2)).GT.DEL) THEN | |
24992 | IDEV = 2 | |
24993 | ELSEIF (ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN | |
24994 | IDEV = 3 | |
24995 | ELSEIF (ABS(EE-P1(4)-P2(4)).GT.DEL) THEN | |
24996 | IDEV = 4 | |
24997 | ELSE | |
24998 | IDEV = 0 | |
24999 | ENDIF | |
25000 | IF (IDEV.NE.0) THEN | |
25001 | WRITE(LOUT,'(/1X,A,I3)') | |
25002 | & 'MASHEL: inconsistent transformation',IDEV | |
25003 | WRITE(LOUT,'(1X,A)') 'MASHEL: input momenta/masses:' | |
25004 | WRITE(LOUT,'(1X,5E12.5)') (PA1(K),K=1,4),XM1 | |
25005 | WRITE(LOUT,'(1X,5E12.5)') (PA2(K),K=1,4),XM2 | |
25006 | WRITE(LOUT,'(1X,A)') 'MASHEL: output momenta:' | |
25007 | WRITE(LOUT,'(5X,4E12.5)') (P1(K),K=1,4) | |
25008 | WRITE(LOUT,'(5X,4E12.5)') (P2(K),K=1,4) | |
25009 | ENDIF | |
25010 | RETURN | |
25011 | ||
25012 | 9999 CONTINUE | |
25013 | IREJ = 1 | |
25014 | RETURN | |
25015 | END | |
25016 | ||
25017 | *$ CREATE DT_DFERMI.FOR | |
25018 | *COPY DT_DFERMI | |
25019 | * | |
25020 | *===dfermi=============================================================* | |
25021 | * | |
25022 | SUBROUTINE DT_DFERMI(GPART) | |
25023 | ||
25024 | ************************************************************************ | |
25025 | * Find largest of three random numbers. * | |
25026 | ************************************************************************ | |
25027 | ||
25028 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25029 | SAVE | |
25030 | ||
25031 | DIMENSION G(3) | |
25032 | ||
25033 | DO 10 I=1,3 | |
25034 | G(I)=DT_RNDM(GPART) | |
25035 | 10 CONTINUE | |
25036 | IF (G(3).LT.G(2)) GOTO 40 | |
25037 | IF (G(3).LT.G(1)) GOTO 30 | |
25038 | GPART = G(3) | |
25039 | 20 RETURN | |
25040 | 30 GPART = G(1) | |
25041 | GOTO 20 | |
25042 | 40 IF (G(2).LT.G(1)) GOTO 30 | |
25043 | GPART = G(2) | |
25044 | GOTO 20 | |
25045 | ||
25046 | END | |
25047 | ||
25048 | ************************************************************************ | |
25049 | * * | |
25050 | * 2) Handling of parton flavors and particle indices * | |
25051 | * * | |
25052 | ************************************************************************ | |
25053 | *$ CREATE IDT_IPDG2B.FOR | |
25054 | *COPY IDT_IPDG2B | |
25055 | * | |
25056 | *===ipdg2b=============================================================* | |
25057 | * | |
25058 | INTEGER FUNCTION IDT_IPDG2B(ID,NN,MODE) | |
25059 | ||
25060 | ************************************************************************ | |
25061 | * * | |
25062 | * conversion of quark numbering scheme * | |
25063 | * * | |
25064 | * input: PDG parton numbering * | |
25065 | * for diquarks: NN number of the constituent quark * | |
25066 | * (e.g. ID=2301,NN=1 -> ICONV2=1) * | |
25067 | * * | |
25068 | * output: BAMJET particle codes * | |
25069 | * 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) * | |
25070 | * 2 d 8 a-d -2 a-d * | |
25071 | * 3 s 9 a-s -3 a-s * | |
25072 | * 4 c 10 a-c -4 a-c * | |
25073 | * * | |
25074 | * This is a modified version of ICONV2 written by R. Engel. * | |
25075 | * This version dated 13.12.94 is written by S. Roesler. * | |
25076 | ************************************************************************ | |
25077 | ||
25078 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25079 | SAVE | |
25080 | ||
25081 | PARAMETER ( LINP = 10 , | |
25082 | & LOUT = 6 , | |
25083 | & LDAT = 9 ) | |
25084 | ||
25085 | IDA = ABS(ID) | |
25086 | * diquarks | |
25087 | IF (IDA.GT.6) THEN | |
25088 | KF = 3 | |
25089 | IF (IDA.GE.1000) KF = 4 | |
25090 | IDA = IDA/(10**(KF-NN)) | |
25091 | IDA = MOD(IDA,10) | |
25092 | ENDIF | |
25093 | * exchange up and dn quarks | |
25094 | IF (IDA.EQ.1) THEN | |
25095 | IDA = 2 | |
25096 | ELSEIF (IDA.EQ.2) THEN | |
25097 | IDA = 1 | |
25098 | ENDIF | |
25099 | * antiquarks | |
25100 | IF (ID.LT.0) THEN | |
25101 | IF (MODE.EQ.1) THEN | |
25102 | IDA = IDA+6 | |
25103 | ELSE | |
25104 | IDA = -IDA | |
25105 | ENDIF | |
25106 | ENDIF | |
25107 | IDT_IPDG2B = IDA | |
25108 | ||
25109 | RETURN | |
25110 | END | |
25111 | ||
25112 | *$ CREATE IDT_IB2PDG.FOR | |
25113 | *COPY IDT_IB2PDG | |
25114 | * | |
25115 | *===ib2pdg=============================================================* | |
25116 | * | |
25117 | INTEGER FUNCTION IDT_IB2PDG(ID1,ID2,MODE) | |
25118 | ||
25119 | ************************************************************************ | |
25120 | * * | |
25121 | * conversion of quark numbering scheme * | |
25122 | * * | |
25123 | * input: BAMJET particle codes * | |
25124 | * 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) * | |
25125 | * 2 d 8 a-d -2 a-d * | |
25126 | * 3 s 9 a-s -3 a-s * | |
25127 | * 4 c 10 a-c -4 a-c * | |
25128 | * * | |
25129 | * output: PDG parton numbering * | |
25130 | * * | |
25131 | * This version dated 13.12.94 is written by S. Roesler. * | |
25132 | ************************************************************************ | |
25133 | ||
25134 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25135 | SAVE | |
25136 | ||
25137 | PARAMETER ( LINP = 10 , | |
25138 | & LOUT = 6 , | |
25139 | & LDAT = 9 ) | |
25140 | ||
25141 | DIMENSION IHKKQ(-6:6),IHKKQQ(-3:3,-3:3) | |
25142 | DATA IHKKQ/-6,-5,-4,-3,-1,-2,0,2,1,3,4,5,6/ | |
25143 | DATA IHKKQQ/-3303,-3103,-3203,0,0,0,0, -3103,-1103,-2103,0,0,0,0, | |
25144 | &-3203,-2103,-2203,0,0,0,0, 0,0,0,0,0,0,0, 0,0,0,0,2203,2103,3203, | |
25145 | &0,0,0,0,2103,1103,3103, 0,0,0,0,3203,3103,3303/ | |
25146 | ||
25147 | IDA = ID1 | |
25148 | IDB = ID2 | |
25149 | IF (MODE.EQ.1) THEN | |
25150 | IF (ID1.GT.6) IDA = -(ID1-6) | |
25151 | IF (ID2.GT.6) IDB = -(ID2-6) | |
25152 | ENDIF | |
25153 | IF (ID2.EQ.0) THEN | |
25154 | IDT_IB2PDG = IHKKQ(IDA) | |
25155 | ELSE | |
25156 | IDT_IB2PDG = IHKKQQ(IDA,IDB) | |
25157 | ENDIF | |
25158 | ||
25159 | RETURN | |
25160 | END | |
25161 | ||
25162 | *$ CREATE IDT_IQUARK.FOR | |
25163 | *COPY IDT_IQUARK | |
25164 | * | |
25165 | *===ipdgqu=============================================================* | |
25166 | * | |
25167 | INTEGER FUNCTION IDT_IQUARK(K,IDBAMJ) | |
25168 | ||
25169 | ************************************************************************ | |
25170 | * * | |
25171 | * quark contents according to PDG conventions * | |
25172 | * (random selection in case of quark mixing) * | |
25173 | * * | |
25174 | * input: IDBAMJ BAMJET particle code * | |
25175 | * K 1..3 quark number * | |
25176 | * * | |
25177 | * output: 1 d (anti --> neg.) * | |
25178 | * 2 u * | |
25179 | * 3 s * | |
25180 | * 4 c * | |
25181 | * * | |
25182 | * This version written by R. Engel. * | |
25183 | ************************************************************************ | |
25184 | ||
25185 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25186 | SAVE | |
25187 | ||
25188 | IQ = IDT_IBJQUA(K,IDBAMJ) | |
25189 | * quark-antiquark | |
25190 | IF (IQ.GT.6) THEN | |
25191 | IQ = 6-IQ | |
25192 | ENDIF | |
25193 | * exchange of up and down | |
25194 | IF (ABS(IQ).EQ.1) THEN | |
25195 | IQ = SIGN(2,IQ) | |
25196 | ELSEIF (ABS(IQ).EQ.2) THEN | |
25197 | IQ = SIGN(1,IQ) | |
25198 | ENDIF | |
25199 | IDT_IQUARK = IQ | |
25200 | ||
25201 | RETURN | |
25202 | END | |
25203 | ||
25204 | *$ CREATE IDT_IBJQUA.FOR | |
25205 | *COPY IDT_IBJQUA | |
25206 | * | |
25207 | *===ibamq==============================================================* | |
25208 | * | |
25209 | INTEGER FUNCTION IDT_IBJQUA(K,IDBAMJ) | |
25210 | ||
25211 | ************************************************************************ | |
25212 | * * | |
25213 | * quark contents according to BAMJET conventions * | |
25214 | * (random selection in case of quark mixing) * | |
25215 | * * | |
25216 | * input: IDBAMJ BAMJET particle code * | |
25217 | * K 1..3 quark number * | |
25218 | * * | |
25219 | * output: 1 u 7 u bar * | |
25220 | * 2 d 8 d bar * | |
25221 | * 3 s 9 s bar * | |
25222 | * 4 c 10 c bar * | |
25223 | * * | |
25224 | * This version written by R. Engel. * | |
25225 | ************************************************************************ | |
25226 | ||
25227 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25228 | SAVE | |
25229 | ||
25230 | DIMENSION ITAB(3,210) | |
25231 | DATA ((ITAB(I,K),I=1,3),K=1,30) / | |
25232 | & 1, 1, 2, 7, 7, 8, 0, 0, 0, | |
25233 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25234 | & 0, 0, 0, 1, 2, 2, 7, 8, 8, | |
25235 | *sr 10.1.94 | |
25236 | C & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25237 | & 0, 0, 0, 0, 0, 0, 3, 8, 0, | |
25238 | * | |
25239 | & 1, 8, 0, 2, 7, 0, 1, 9, 0, | |
25240 | *sr 10.1.94 | |
25241 | C & 3, 7, 0, 0, 0, 0, 0, 0, 0, | |
25242 | & 3, 7, 0, 3, 1, 2, 9, 7, 8, | |
25243 | *sr 10.1.94 | |
25244 | C & 0, 0, 0, 2, 2, 3, 1, 1, 3, | |
25245 | & 2, 9, 0, 2, 2, 3, 1, 1, 3, | |
25246 | * | |
25247 | & 1, 2, 3, 201,202, 0, 2, 9, 0, | |
25248 | & 3, 8, 0, 0, 0, 0, 0, 0, 0, | |
25249 | & 0, 0, 0, 0, 0, 0, 0, 0, 0 / | |
25250 | DATA ((ITAB(I,K),I=1,3),K=31,60) / | |
25251 | & 3, 9, 0, 1, 8, 0, 203,204, 0, | |
25252 | & 2, 7, 0, 0, 0, 0, 1, 9, 0, | |
25253 | & 2, 9, 0, 3, 7, 0, 3, 8, 0, | |
25254 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25255 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25256 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25257 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25258 | & 0, 0, 0, 1, 1, 1, 1, 1, 2, | |
25259 | & 1, 2, 2, 2, 2, 2, 0, 0, 0, | |
25260 | & 0, 0, 0, 0, 0, 0, 0, 0, 0 / | |
25261 | DATA ((ITAB(I,K),I=1,3),K=61,90) / | |
25262 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25263 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25264 | & 7, 7, 7, 7, 7, 8, 7, 8, 8, | |
25265 | & 8, 8, 8, 0, 0, 0, 0, 0, 0, | |
25266 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25267 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25268 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25269 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25270 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25271 | & 0, 0, 0, 0, 0, 0, 0, 0, 0 / | |
25272 | DATA ((ITAB(I,K),I=1,3),K=91,120) / | |
25273 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25274 | & 0, 0, 0, 0, 0, 0, 3, 9, 0, | |
25275 | & 1, 3, 3, 2, 3, 3, 7, 7, 9, | |
25276 | & 7, 8, 9, 8, 8, 9, 7, 9, 9, | |
25277 | & 8, 9, 9, 1, 1, 3, 1, 2, 3, | |
25278 | & 2, 2, 3, 1, 3, 3, 2, 3, 3, | |
25279 | & 3, 3, 3, 7, 7, 9, 7, 8, 9, | |
25280 | & 8, 8, 9, 7, 9, 9, 8, 9, 9, | |
25281 | & 9, 9, 9, 4, 7, 0, 4, 8, 0, | |
25282 | & 2, 10, 0, 1, 10, 0, 4, 9, 0 / | |
25283 | DATA ((ITAB(I,K),I=1,3),K=121,150) / | |
25284 | & 3, 10, 0, 4, 10, 0, 4, 7, 0, | |
25285 | & 4, 8, 0, 2, 10, 0, 1, 10, 0, | |
25286 | & 4, 9, 0, 3, 10, 0, 4, 10, 0, | |
25287 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25288 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25289 | & 0, 0, 0, 1, 2, 4, 1, 3, 4, | |
25290 | & 2, 3, 4, 1, 1, 4, 0, 0, 0, | |
25291 | & 2, 2, 4, 0, 0, 0, 0, 0, 0, | |
25292 | & 3, 3, 4, 1, 4, 4, 2, 4, 4, | |
25293 | & 3, 4, 4, 7, 8, 10, 7, 9, 10 / | |
25294 | DATA ((ITAB(I,K),I=1,3),K=151,180) / | |
25295 | & 8, 9, 10, 7, 7, 10, 0, 0, 0, | |
25296 | & 8, 8, 10, 0, 0, 0, 0, 0, 0, | |
25297 | & 9, 9, 10, 7, 10, 10, 8, 10, 10, | |
25298 | & 9, 10, 10, 1, 1, 4, 1, 2, 4, | |
25299 | & 2, 2, 4, 1, 3, 4, 2, 3, 4, | |
25300 | & 3, 3, 4, 1, 4, 4, 2, 4, 4, | |
25301 | & 3, 4, 4, 4, 4, 4, 7, 7, 10, | |
25302 | & 7, 8, 10, 8, 8, 10, 7, 9, 10, | |
25303 | & 8, 9, 10, 9, 9, 10, 7, 10, 10, | |
25304 | & 8, 10, 10, 9, 10, 10, 10, 10, 10 / | |
25305 | DATA ((ITAB(I,K),I=1,3),K=181,210) / | |
25306 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25307 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25308 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25309 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25310 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25311 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25312 | & 0, 0, 0, 0, 0, 0, 1, 7, 0, | |
25313 | & 2, 8, 0, 1, 7, 0, 2, 8, 0, | |
25314 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25315 | & 0, 0, 0, 0, 0, 0, 0, 0, 0 / | |
25316 | DATA IDOLD /0/ | |
25317 | ||
25318 | ONE = 1.0D0 | |
25319 | IF (ITAB(1,IDBAMJ).LE.200) THEN | |
25320 | ID = ITAB(K,IDBAMJ) | |
25321 | ELSE | |
25322 | IF(IDOLD.NE.IDBAMJ) THEN | |
25323 | IT = AINT((ITAB(2,IDBAMJ)-ITAB(1,IDBAMJ)+0.999999D0)* | |
25324 | & DT_RNDM(ONE)+ITAB(1,IDBAMJ)) | |
25325 | ELSE | |
25326 | IDOLD = 0 | |
25327 | ENDIF | |
25328 | ID = ITAB(K,IT) | |
25329 | ENDIF | |
25330 | IDOLD = IDBAMJ | |
25331 | IDT_IBJQUA = ID | |
25332 | ||
25333 | RETURN | |
25334 | END | |
25335 | ||
25336 | *$ CREATE IDT_ICIHAD.FOR | |
25337 | *COPY IDT_ICIHAD | |
25338 | * | |
25339 | *===icihad=============================================================* | |
25340 | * | |
25341 | INTEGER FUNCTION IDT_ICIHAD(MCIND) | |
25342 | ||
25343 | ************************************************************************ | |
25344 | * Conversion of particle index PDG proposal --> BAMJET-index scheme * | |
25345 | * This is a completely new version dated 25.10.95. * | |
25346 | * Renamed to be not in conflict with the modified PHOJET-version * | |
25347 | ************************************************************************ | |
25348 | ||
25349 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25350 | SAVE | |
25351 | ||
25352 | * hadron index conversion (BAMJET <--> PDG) | |
25353 | COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22), | |
25354 | & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19), | |
25355 | & IAMCIN(210) | |
25356 | ||
25357 | IDT_ICIHAD = 0 | |
25358 | KPDG = ABS(MCIND) | |
25359 | IF ((KPDG.EQ.0).OR.(KPDG.GT.70000)) RETURN | |
25360 | IF (MCIND.LT.0) THEN | |
25361 | JSIGN = 1 | |
25362 | ELSE | |
25363 | JSIGN = 2 | |
25364 | ENDIF | |
25365 | IF (KPDG.GE.10000) THEN | |
25366 | DO 1 I=1,19 | |
25367 | IDT_ICIHAD = IBAM5(JSIGN,I) | |
25368 | IF (IPDG5(JSIGN,I).EQ.MCIND) GOTO 5 | |
25369 | IDT_ICIHAD = 0 | |
25370 | 1 CONTINUE | |
25371 | ELSEIF (KPDG.GE.1000) THEN | |
25372 | DO 2 I=1,29 | |
25373 | IDT_ICIHAD = IBAM4(JSIGN,I) | |
25374 | IF (IPDG4(JSIGN,I).EQ.MCIND) GOTO 5 | |
25375 | IDT_ICIHAD = 0 | |
25376 | 2 CONTINUE | |
25377 | ELSEIF (KPDG.GE.100) THEN | |
25378 | DO 3 I=1,22 | |
25379 | IDT_ICIHAD = IBAM3(JSIGN,I) | |
25380 | IF (IPDG3(JSIGN,I).EQ.MCIND) GOTO 5 | |
25381 | IDT_ICIHAD = 0 | |
25382 | 3 CONTINUE | |
25383 | ELSEIF (KPDG.GE.10) THEN | |
25384 | DO 4 I=1,7 | |
25385 | IDT_ICIHAD = IBAM2(JSIGN,I) | |
25386 | IF (IPDG2(JSIGN,I).EQ.MCIND) GOTO 5 | |
25387 | IDT_ICIHAD = 0 | |
25388 | 4 CONTINUE | |
25389 | ENDIF | |
25390 | 5 CONTINUE | |
25391 | ||
25392 | RETURN | |
25393 | END | |
25394 | ||
25395 | *$ CREATE IDT_IPDGHA.FOR | |
25396 | *COPY IDT_IPDGHA | |
25397 | * | |
25398 | *===ipdgha=============================================================* | |
25399 | * | |
25400 | INTEGER FUNCTION IDT_IPDGHA(MCIND) | |
25401 | ||
25402 | ************************************************************************ | |
25403 | * Conversion of particle index BAMJET-index scheme --> PDG proposal * | |
25404 | * Adopted from the original by S. Roesler. This version dated 12.5.95 * | |
25405 | * Renamed to be not in conflict with the modified PHOJET-version * | |
25406 | ************************************************************************ | |
25407 | ||
25408 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25409 | SAVE | |
25410 | ||
25411 | * hadron index conversion (BAMJET <--> PDG) | |
25412 | COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22), | |
25413 | & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19), | |
25414 | & IAMCIN(210) | |
25415 | ||
25416 | IDT_IPDGHA = IAMCIN(MCIND) | |
25417 | ||
25418 | RETURN | |
25419 | END | |
25420 | ||
25421 | *$ CREATE DT_FLAHAD.FOR | |
25422 | *COPY DT_FLAHAD | |
25423 | * | |
25424 | *===flahad=============================================================* | |
25425 | * | |
25426 | SUBROUTINE DT_FLAHAD(ID,IF1,IF2,IF3) | |
25427 | ||
25428 | ************************************************************************ | |
25429 | * sampling of FLAvor composition for HADrons/photons * | |
25430 | * ID BAMJET-id of hadron * | |
25431 | * IF1,2,3 flavor content * | |
25432 | * (u,d,s: 1,2,3; au,ad,as: -1,-1,-3) * | |
25433 | * Note: - u,d numbering as in BAMJET * | |
25434 | * - ID .le. 30 !! * | |
25435 | * This version dated 12.03.96 is written by S. Roesler * | |
25436 | ************************************************************************ | |
25437 | ||
25438 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25439 | SAVE | |
25440 | ||
25441 | * auxiliary common for reggeon exchange (DTUNUC 1.x) | |
25442 | COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6), | |
25443 | & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6), | |
25444 | & IQTCHR(-6:6),MQUARK(3,39) | |
25445 | ||
25446 | DIMENSION JSEL(3,6) | |
25447 | DATA JSEL/ 1,2,3, 2,3,1, 3,1,2, 1,3,2, 2,1,3, 3,2,1/ | |
25448 | ||
25449 | ONE = 1.0D0 | |
25450 | IF (ID.EQ.7) THEN | |
25451 | * photon (charge dependent flavour sampling) | |
25452 | K = INT(DT_RNDM(ONE)*6.D0+1.D0) | |
25453 | IF (K.LE.4) THEN | |
25454 | IF1 = 2 | |
25455 | IF2 = -2 | |
25456 | ELSE IF(K.EQ.5) THEN | |
25457 | IF1 = 1 | |
25458 | IF2 = -1 | |
25459 | ELSE | |
25460 | IF1 = 3 | |
25461 | IF2 = -3 | |
25462 | ENDIF | |
25463 | IF(DT_RNDM(ONE).LT.0.5D0) THEN | |
25464 | K = IF1 | |
25465 | IF1 = IF2 | |
25466 | IF2 = K | |
25467 | ENDIF | |
25468 | IF3 = 0 | |
25469 | ELSE | |
25470 | * hadron | |
25471 | IX = INT(1.0D0+5.99999D0*DT_RNDM(ONE)) | |
25472 | IF1 = MQUARK(JSEL(1,IX),ID) | |
25473 | IF2 = MQUARK(JSEL(2,IX),ID) | |
25474 | IF3 = MQUARK(JSEL(3,IX),ID) | |
25475 | IF ((IF1.EQ.0).AND.(IF3.NE.0)) THEN | |
25476 | IF1 = IF3 | |
25477 | IF3 = 0 | |
25478 | ELSEIF ((IF2.EQ.0).AND.(IF3.NE.0)) THEN | |
25479 | IF2 = IF3 | |
25480 | IF3 = 0 | |
25481 | ENDIF | |
25482 | ENDIF | |
25483 | ||
25484 | RETURN | |
25485 | END | |
25486 | ||
25487 | *$ CREATE IDT_MCHAD.FOR | |
25488 | *COPY IDT_MCHAD | |
25489 | * | |
25490 | *===mchad==============================================================* | |
25491 | * | |
25492 | INTEGER FUNCTION IDT_MCHAD(ITDTU) | |
25493 | ||
25494 | ************************************************************************ | |
25495 | * Conversion of particle index BAMJET-index scheme --> HADRIN index s. * | |
25496 | * Adopted from the original by S. Roesler. This version dated 6.5.95 * | |
25497 | * * | |
25498 | * Last change 28.12.2006 by S. Roesler. * | |
25499 | ************************************************************************ | |
25500 | ||
25501 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25502 | SAVE | |
25503 | ||
25504 | DIMENSION ITRANS(210) | |
25505 | DATA ITRANS / 1, 2, -1, -1, -1, -1, -1, 8, 9, -1, -1, 24, 13, 14, | |
25506 | &15, 16, 8, 9, 25, 8, 1, 8, 23, 24, 25, -1, -1, -1, -1, -1, 23, 13, | |
25507 | &23, 14, 23, 15, 24, 16, 25, 15, 24, 16, 25, 15, 24, 16, 25, 1, 8, | |
25508 | &8, 8, 1, 1, 1, 8, 8, 1, 1, 8, 8, 1, 8, 1, 8, 1, 8, 2, 2, 9, 9, 2, | |
25509 | &2, 9, 9, 2, 9, 1, 13, 23, 14, 1, 1, 8, 8, 1, 1, 23, 14, 1, 8, 1, | |
25510 | &8, 1, 8, 23, 23, 8, 8, 2, 9, 9, 9, 9, 1, 8, 8, 8, 8, 8, 2, 9, 9, | |
25511 | &9, 9, 9, 85*- 1,7*-1,1,8,-1/ | |
25512 | ||
25513 | IF ( ITDTU .GT. 0 ) THEN | |
25514 | IDT_MCHAD = ITRANS(ITDTU) | |
25515 | ELSE | |
25516 | IDT_MCHAD = -1 | |
25517 | END IF | |
25518 | ||
25519 | RETURN | |
25520 | END | |
25521 | ||
25522 | ************************************************************************ | |
25523 | * * | |
25524 | * 3) Energy-momentum and quantum number conservation check routines * | |
25525 | * * | |
25526 | ************************************************************************ | |
25527 | *$ CREATE DT_EMC1.FOR | |
25528 | *COPY DT_EMC1 | |
25529 | * | |
25530 | *===emc1===============================================================* | |
25531 | * | |
25532 | SUBROUTINE DT_EMC1(PP1,PP2,PT1,PT2,MODE,IPOS,IREJ) | |
25533 | ||
25534 | ************************************************************************ | |
25535 | * This version dated 15.12.94 is written by S. Roesler * | |
25536 | ************************************************************************ | |
25537 | ||
25538 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25539 | SAVE | |
25540 | ||
25541 | PARAMETER ( LINP = 10 , | |
25542 | & LOUT = 6 , | |
25543 | & LDAT = 9 ) | |
25544 | ||
25545 | PARAMETER (TINY10=1.0D-10) | |
25546 | ||
25547 | DIMENSION PP1(4),PP2(4),PT1(4),PT2(4) | |
25548 | ||
25549 | IREJ = 0 | |
25550 | ||
25551 | IF ((MODE.EQ.0).OR.(ABS(MODE).GT.3)) | |
25552 | & WRITE(LOUT,'(1X,A,I6)')'EMC1: not supported MODE ',MODE | |
25553 | ||
25554 | IF ((MODE.GT.0).AND.(MODE.LT.3)) THEN | |
25555 | IF (MODE.EQ.1) THEN | |
25556 | CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),1,IDUM,IDUM) | |
25557 | ELSEIF (MODE.EQ.2) THEN | |
25558 | CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),2,IDUM,IDUM) | |
25559 | ENDIF | |
25560 | CALL DT_EVTEMC(PP2(1),PP2(2),PP2(3),PP2(4),2,IDUM,IDUM) | |
25561 | CALL DT_EVTEMC(PT1(1),PT1(2),PT1(3),PT1(4),2,IDUM,IDUM) | |
25562 | CALL DT_EVTEMC(PT2(1),PT2(2),PT2(3),PT2(4),2,IDUM,IDUM) | |
25563 | ELSEIF (MODE.LT.0) THEN | |
25564 | IF (MODE.EQ.-1) THEN | |
25565 | CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),1,IDUM,IDUM) | |
25566 | ELSEIF (MODE.EQ.-2) THEN | |
25567 | CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),2,IDUM,IDUM) | |
25568 | ENDIF | |
25569 | CALL DT_EVTEMC(-PP2(1),-PP2(2),-PP2(3),-PP2(4),2,IDUM,IDUM) | |
25570 | CALL DT_EVTEMC(-PT1(1),-PT1(2),-PT1(3),-PT1(4),2,IDUM,IDUM) | |
25571 | CALL DT_EVTEMC(-PT2(1),-PT2(2),-PT2(3),-PT2(4),2,IDUM,IDUM) | |
25572 | ENDIF | |
25573 | ||
25574 | IF (ABS(MODE).EQ.3) THEN | |
25575 | CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,IPOS,IREJ1) | |
25576 | IF (IREJ1.NE.0) GOTO 9999 | |
25577 | ENDIF | |
25578 | RETURN | |
25579 | ||
25580 | 9999 CONTINUE | |
25581 | IREJ = 1 | |
25582 | RETURN | |
25583 | END | |
25584 | ||
25585 | *$ CREATE DT_EMC2.FOR | |
25586 | *COPY DT_EMC2 | |
25587 | * | |
25588 | *===emc2===============================================================* | |
25589 | * | |
25590 | SUBROUTINE DT_EMC2(IP1,IP2,IP3,IP4,IP5,MP,IN1,IN2,IN3,IN4,IN5,MN, | |
25591 | & MODE,IPOS,IREJ) | |
25592 | ||
25593 | ************************************************************************ | |
25594 | * MODE = 1 energy-momentum cons. check * | |
25595 | * = 2 flavor-cons. check * | |
25596 | * = 3 energy-momentum & flavor cons. check * | |
25597 | * = 4 energy-momentum & charge cons. check * | |
25598 | * = 5 energy-momentum & flavor & charge cons. check * | |
25599 | * This version dated 16.01.95 is written by S. Roesler * | |
25600 | ************************************************************************ | |
25601 | ||
25602 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25603 | SAVE | |
25604 | ||
25605 | PARAMETER ( LINP = 10 , | |
25606 | & LOUT = 6 , | |
25607 | & LDAT = 9 ) | |
25608 | ||
25609 | PARAMETER (TINY10=1.0D-10,ZERO=0.0D0) | |
25610 | ||
25611 | * event history | |
25612 | ||
25613 | PARAMETER (NMXHKK=200000) | |
25614 | ||
25615 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
25616 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
25617 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
25618 | ||
25619 | * extended event history | |
25620 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
25621 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
25622 | & IHIST(2,NMXHKK) | |
25623 | ||
25624 | IREJ = 0 | |
25625 | IREJ1 = 0 | |
25626 | IREJ2 = 0 | |
25627 | IREJ3 = 0 | |
25628 | ||
25629 | IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5)) | |
25630 | & CALL DT_EVTEMC(ZERO,ZERO,ZERO,ZERO,1,IDUM,IDUM) | |
25631 | IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5)) | |
25632 | & CALL DT_EVTFLC(0,IDUM,1,IDUM,IDUM) | |
25633 | IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,1,IDUM,IDUM) | |
25634 | DO 1 I=1,NHKK | |
25635 | IF ((ISTHKK(I).EQ.IP1).OR.(ISTHKK(I).EQ.IP2).OR. | |
25636 | & (ISTHKK(I).EQ.IP3).OR.(ISTHKK(I).EQ.IP4).OR. | |
25637 | & (ISTHKK(I).EQ.IP5)) THEN | |
25638 | IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4) | |
25639 | & .OR.(MODE.EQ.5)) | |
25640 | & CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I), | |
25641 | & 2,IDUM,IDUM) | |
25642 | IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5)) | |
25643 | & CALL DT_EVTFLC(IDHKK(I),MP,2,IDUM,IDUM) | |
25644 | IF ((MODE.EQ.4).OR.(MODE.EQ.5)) | |
25645 | & CALL DT_EVTCHG(IDHKK(I),2,IDUM,IDUM) | |
25646 | ENDIF | |
25647 | IF ((ISTHKK(I).EQ.IN1).OR.(ISTHKK(I).EQ.IN2).OR. | |
25648 | & (ISTHKK(I).EQ.IN3).OR.(ISTHKK(I).EQ.IN4).OR. | |
25649 | & (ISTHKK(I).EQ.IN5)) THEN | |
25650 | IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4) | |
25651 | & .OR.(MODE.EQ.5)) | |
25652 | & CALL DT_EVTEMC(-PHKK(1,I),-PHKK(2,I),-PHKK(3,I),-PHKK(4,I), | |
25653 | & 2,IDUM,IDUM) | |
25654 | IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5)) | |
25655 | & CALL DT_EVTFLC(IDHKK(I),MN,-2,IDUM,IDUM) | |
25656 | IF ((MODE.EQ.4).OR.(MODE.EQ.5)) | |
25657 | & CALL DT_EVTCHG(IDHKK(I),-2,IDUM,IDUM) | |
25658 | ENDIF | |
25659 | 1 CONTINUE | |
25660 | IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5)) | |
25661 | & CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,IPOS,IREJ1) | |
25662 | IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5)) | |
25663 | & CALL DT_EVTFLC(0,IDUM,3,IPOS,IREJ2) | |
25664 | IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,3,IPOS,IREJ3) | |
25665 | IF ((IREJ1.NE.0).OR.(IREJ2.NE.0).OR.(IREJ3.NE.0)) GOTO 9999 | |
25666 | ||
25667 | RETURN | |
25668 | ||
25669 | 9999 CONTINUE | |
25670 | IREJ = 1 | |
25671 | RETURN | |
25672 | END | |
25673 | ||
25674 | *$ CREATE DT_EVTEMC.FOR | |
25675 | *COPY DT_EVTEMC | |
25676 | * | |
25677 | *===evtemc=============================================================* | |
25678 | * | |
25679 | SUBROUTINE DT_EVTEMC(PXIO,PYIO,PZIO,EIO,IMODE,IPOS,IREJ) | |
25680 | ||
25681 | ************************************************************************ | |
25682 | * This version dated 13.12.94 is written by S. Roesler * | |
25683 | ************************************************************************ | |
25684 | ||
25685 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25686 | SAVE | |
25687 | ||
25688 | PARAMETER ( LINP = 10 , | |
25689 | & LOUT = 6 , | |
25690 | & LDAT = 9 ) | |
25691 | ||
25692 | PARAMETER (TINY1=1.0D-1,TINY2=1.0D-2,TINY4=1.0D-4,TINY10=1.0D-10, | |
25693 | & ZERO=0.0D0) | |
25694 | ||
25695 | * event history | |
25696 | ||
25697 | PARAMETER (NMXHKK=200000) | |
25698 | ||
25699 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
25700 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
25701 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
25702 | ||
25703 | * flags for input different options | |
25704 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
25705 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
25706 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
25707 | ||
25708 | IREJ = 0 | |
25709 | ||
25710 | MODE = IMODE | |
25711 | CHKLEV = TINY10 | |
25712 | IF (MODE.EQ.4) THEN | |
25713 | CHKLEV = TINY2 | |
25714 | MODE = 3 | |
25715 | ELSEIF (MODE.EQ.5) THEN | |
25716 | CHKLEV = TINY1 | |
25717 | MODE = 3 | |
25718 | ELSEIF (MODE.EQ.-1) THEN | |
25719 | CHKLEV = EIO | |
25720 | MODE = 3 | |
25721 | ENDIF | |
25722 | ||
25723 | IF (ABS(MODE).EQ.3) THEN | |
25724 | PXDEV = PX | |
25725 | PYDEV = PY | |
25726 | PZDEV = PZ | |
25727 | EDEV = E | |
25728 | IF ((IFRAG(1).EQ.2).AND.(CHKLEV.LT.TINY4)) CHKLEV = TINY4 | |
25729 | IF ((ABS(PXDEV).GT.CHKLEV).OR.(ABS(PYDEV).GT.CHKLEV).OR. | |
25730 | & (ABS(PZDEV).GT.CHKLEV).OR.(ABS(EDEV).GT.CHKLEV)) THEN | |
25731 | IF (IOULEV(2).GT.0) WRITE(LOUT,'(1X,A,I4,A,I8,A,/,4G10.3)') | |
25732 | & 'EVTEMC: energy-momentum cons. failure at pos. ',IPOS, | |
25733 | & ' event ',NEVHKK, | |
25734 | & ' ! ',PXDEV,PYDEV,PZDEV,EDEV | |
25735 | PX = 0.0D0 | |
25736 | PY = 0.0D0 | |
25737 | PZ = 0.0D0 | |
25738 | E = 0.0D0 | |
25739 | GOTO 9999 | |
25740 | ENDIF | |
25741 | PX = 0.0D0 | |
25742 | PY = 0.0D0 | |
25743 | PZ = 0.0D0 | |
25744 | E = 0.0D0 | |
25745 | RETURN | |
25746 | ENDIF | |
25747 | ||
25748 | IF (MODE.EQ.1) THEN | |
25749 | PX = 0.0D0 | |
25750 | PY = 0.0D0 | |
25751 | PZ = 0.0D0 | |
25752 | E = 0.0D0 | |
25753 | ENDIF | |
25754 | ||
25755 | PX = PX+PXIO | |
25756 | PY = PY+PYIO | |
25757 | PZ = PZ+PZIO | |
25758 | E = E+EIO | |
25759 | ||
25760 | RETURN | |
25761 | ||
25762 | 9999 CONTINUE | |
25763 | IREJ = 1 | |
25764 | RETURN | |
25765 | END | |
25766 | ||
25767 | *$ CREATE DT_EVTFLC.FOR | |
25768 | *COPY DT_EVTFLC | |
25769 | * | |
25770 | *===evtflc=============================================================* | |
25771 | * | |
25772 | SUBROUTINE DT_EVTFLC(ID,ID1,MODE,IPOS,IREJ) | |
25773 | ||
25774 | ************************************************************************ | |
25775 | * Flavor conservation check. * | |
25776 | * ID identity of particle * | |
25777 | * ID1 = 1 ID for q,aq,qq,aqaq in PDG-numbering scheme * | |
25778 | * = 2 ID for particle/resonance in BAMJET numbering scheme * | |
25779 | * = 3 ID for particle/resonance in PDG numbering scheme * | |
25780 | * MODE = 1 initialization and add ID * | |
25781 | * =-1 initialization and subtract ID * | |
25782 | * = 2 add ID * | |
25783 | * =-2 subtract ID * | |
25784 | * = 3 check flavor cons. * | |
25785 | * IPOS flag to give position of call of EVTFLC to output * | |
25786 | * unit in case of violation * | |
25787 | * This version dated 10.01.95 is written by S. Roesler * | |
25788 | ************************************************************************ | |
25789 | ||
25790 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25791 | SAVE | |
25792 | ||
25793 | PARAMETER ( LINP = 10 , | |
25794 | & LOUT = 6 , | |
25795 | & LDAT = 9 ) | |
25796 | ||
25797 | PARAMETER (TINY10=1.0D-10) | |
25798 | ||
25799 | IREJ = 0 | |
25800 | ||
25801 | IF (MODE.EQ.3) THEN | |
25802 | IF (IFL.NE.0) THEN | |
25803 | WRITE(LOUT,'(1X,A,I3,A,I3)') | |
25804 | & 'EVTFLC: flavor-conservation failure at pos. ',IPOS, | |
25805 | & ' ! IFL = ',IFL | |
25806 | IFL = 0 | |
25807 | GOTO 9999 | |
25808 | ENDIF | |
25809 | IFL = 0 | |
25810 | RETURN | |
25811 | ENDIF | |
25812 | ||
25813 | IF (MODE.EQ.1) IFL = 0 | |
25814 | IF (ID.EQ.0) RETURN | |
25815 | ||
25816 | IF (ID1.EQ.1) THEN | |
25817 | IDD = ABS(ID) | |
25818 | NQ = 1 | |
25819 | IF ((IDD.GE.100).AND.(IDD.LT.1000)) NQ = 2 | |
25820 | IF (IDD.GE.1000) NQ = 3 | |
25821 | DO 1 I=1,NQ | |
25822 | IFBAM = IDT_IPDG2B(ID,I,2) | |
25823 | IF (ABS(IFBAM).EQ.1) THEN | |
25824 | IFBAM = SIGN(2,IFBAM) | |
25825 | ELSEIF (ABS(IFBAM).EQ.2) THEN | |
25826 | IFBAM = SIGN(1,IFBAM) | |
25827 | ENDIF | |
25828 | IF (MODE.GT.0) THEN | |
25829 | IFL = IFL+IFBAM | |
25830 | ELSE | |
25831 | IFL = IFL-IFBAM | |
25832 | ENDIF | |
25833 | 1 CONTINUE | |
25834 | RETURN | |
25835 | ENDIF | |
25836 | ||
25837 | IDD = ID | |
25838 | IF (ID1.EQ.3) IDD = IDT_ICIHAD(ID) | |
25839 | IF ((ID1.EQ.2).OR.(ID1.EQ.3)) THEN | |
25840 | DO 2 I=1,3 | |
25841 | IF (MODE.GT.0) THEN | |
25842 | IFL = IFL+IDT_IQUARK(I,IDD) | |
25843 | ELSE | |
25844 | IFL = IFL-IDT_IQUARK(I,IDD) | |
25845 | ENDIF | |
25846 | 2 CONTINUE | |
25847 | ENDIF | |
25848 | RETURN | |
25849 | ||
25850 | 9999 CONTINUE | |
25851 | IREJ = 1 | |
25852 | RETURN | |
25853 | END | |
25854 | ||
25855 | *$ CREATE DT_EVTCHG.FOR | |
25856 | *COPY DT_EVTCHG | |
25857 | * | |
25858 | *===evtchg=============================================================* | |
25859 | * | |
25860 | SUBROUTINE DT_EVTCHG(ID,MODE,IPOS,IREJ) | |
25861 | ||
25862 | ************************************************************************ | |
25863 | * Charge conservation check. * | |
25864 | * ID identity of particle (PDG-numbering scheme) * | |
25865 | * MODE = 1 initialization * | |
25866 | * =-2 subtract ID-charge * | |
25867 | * = 2 add ID-charge * | |
25868 | * = 3 check charge cons. * | |
25869 | * IPOS flag to give position of call of EVTCHG to output * | |
25870 | * unit in case of violation * | |
25871 | * This version dated 10.01.95 is written by S. Roesler * | |
25872 | * Last change: s.r. 21.01.01 * | |
25873 | ************************************************************************ | |
25874 | ||
25875 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25876 | SAVE | |
25877 | ||
25878 | PARAMETER ( LINP = 10 , | |
25879 | & LOUT = 6 , | |
25880 | & LDAT = 9 ) | |
25881 | ||
25882 | * event history | |
25883 | ||
25884 | PARAMETER (NMXHKK=200000) | |
25885 | ||
25886 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
25887 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
25888 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
25889 | ||
25890 | * particle properties (BAMJET index convention) | |
25891 | CHARACTER*8 ANAME | |
25892 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
25893 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
25894 | ||
25895 | IREJ = 0 | |
25896 | ||
25897 | IF (MODE.EQ.1) THEN | |
25898 | ICH = 0 | |
25899 | IBAR = 0 | |
25900 | RETURN | |
25901 | ENDIF | |
25902 | ||
25903 | IF (MODE.EQ.3) THEN | |
25904 | IF ((ICH.NE.0).OR.(IBAR.NE.0)) THEN | |
25905 | WRITE(LOUT,'(1X,A,I3,A,2I3,A,I8)') | |
25906 | & 'EVTCHG: charge/baryo.-cons. failure at pos. ',IPOS, | |
25907 | & '! ICH/IBAR= ',ICH,IBAR,' event ',NEVHKK | |
25908 | ICH = 0 | |
25909 | IBAR = 0 | |
25910 | GOTO 9999 | |
25911 | ENDIF | |
25912 | ICH = 0 | |
25913 | IBAR = 0 | |
25914 | RETURN | |
25915 | ENDIF | |
25916 | ||
25917 | IF (ID.EQ.0) RETURN | |
25918 | ||
25919 | IDD = IDT_ICIHAD(ID) | |
25920 | * modification 21.1.01: use intrinsic phojet-functions to determine charge | |
25921 | * and baryon number | |
25922 | C IF (IDD.GT.0) THEN | |
25923 | C IF (MODE.EQ.2) THEN | |
25924 | C ICH = ICH+IICH(IDD) | |
25925 | C IBAR = IBAR+IIBAR(IDD) | |
25926 | C ELSEIF (MODE.EQ.-2) THEN | |
25927 | C ICH = ICH-IICH(IDD) | |
25928 | C IBAR = IBAR-IIBAR(IDD) | |
25929 | C ENDIF | |
25930 | C ELSE | |
25931 | C WRITE(LOUT,'(1X,A,3I6)') 'EVTCHG: (IDD = 0 !), IDD,ID=',IDD,ID | |
25932 | C CALL DT_EVTOUT(4) | |
25933 | C STOP | |
25934 | C ENDIF | |
25935 | IF (MODE.EQ.2) THEN | |
25936 | ICH = ICH+IPHO_CHR3(ID,1)/3 | |
25937 | IBAR = IBAR+IPHO_BAR3(ID,1)/3 | |
25938 | ELSEIF (MODE.EQ.-2) THEN | |
25939 | ICH = ICH-IPHO_CHR3(ID,1)/3 | |
25940 | IBAR = IBAR-IPHO_BAR3(ID,1)/3 | |
25941 | ENDIF | |
25942 | ||
25943 | RETURN | |
25944 | ||
25945 | 9999 CONTINUE | |
25946 | IREJ = 1 | |
25947 | RETURN | |
25948 | END | |
25949 | ||
25950 | ************************************************************************ | |
25951 | * * | |
25952 | * 4) Transformations * | |
25953 | * * | |
25954 | ************************************************************************ | |
25955 | *$ CREATE DT_LTINI.FOR | |
25956 | *COPY DT_LTINI | |
25957 | * | |
25958 | *===ltini==============================================================* | |
25959 | * | |
25960 | SUBROUTINE DT_LTINI(IDPR,IDTA,EPN0,PPN0,ECM0,MODE) | |
25961 | ||
25962 | ************************************************************************ | |
25963 | * Initializations of Lorentz-transformations, calculation of Lorentz- * | |
25964 | * parameters. * | |
25965 | * This version dated 13.11.95 is written by S. Roesler. * | |
25966 | ************************************************************************ | |
25967 | ||
25968 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25969 | SAVE | |
25970 | ||
25971 | PARAMETER ( LINP = 10 , | |
25972 | & LOUT = 6 , | |
25973 | & LDAT = 9 ) | |
25974 | ||
25975 | PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3, | |
25976 | & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0) | |
25977 | ||
25978 | * Lorentz-parameters of the current interaction | |
25979 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
25980 | & UMO,PPCM,EPROJ,PPROJ | |
25981 | ||
25982 | * properties of photon/lepton projectiles | |
25983 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC | |
25984 | ||
25985 | * particle properties (BAMJET index convention) | |
25986 | CHARACTER*8 ANAME | |
25987 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
25988 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
25989 | ||
25990 | * nucleon-nucleon event-generator | |
25991 | CHARACTER*8 CMODEL | |
25992 | LOGICAL LPHOIN | |
25993 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
25994 | ||
25995 | Q2 = VIRT | |
25996 | IDP = IDPR | |
25997 | IF (MCGENE.NE.3) THEN | |
25998 | * lepton-projectiles and PHOJET: initialize real photon instead | |
25999 | IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR. | |
26000 | & (IDPR.EQ.10).OR.(IDPR.EQ.11).OR. | |
26001 | & (IDPR.EQ. 5).OR.(IDPR.EQ. 6)) THEN | |
26002 | IDP = 7 | |
26003 | Q2 = ZERO | |
26004 | ENDIF | |
26005 | ENDIF | |
26006 | IDT = IDTA | |
26007 | EPN = EPN0 | |
26008 | PPN = PPN0 | |
26009 | ECM = ECM0 | |
26010 | AMP = AAM(IDP)-SQRT(ABS(Q2)) | |
26011 | AMT = AAM(IDT) | |
26012 | AMP2 = SIGN(AMP**2,AMP) | |
26013 | AMT2 = AMT**2 | |
26014 | IF (ECM0.GT.ZERO) THEN | |
26015 | EPN = (ECM**2-AMP2-AMT2)/(TWO*AMT) | |
26016 | IF (AMP2.GT.ZERO) THEN | |
26017 | PPN = SQRT((EPN+AMP)*(EPN-AMP)) | |
26018 | ELSE | |
26019 | PPN = SQRT(EPN**2-AMP2) | |
26020 | ENDIF | |
26021 | ELSE | |
26022 | IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN | |
26023 | IF (IDP.EQ.7) EPN = ABS(EPN) | |
26024 | IF (EPN.LT.ZERO) EPN = ABS(EPN)+AMP | |
26025 | IF (AMP2.GT.ZERO) THEN | |
26026 | PPN = SQRT((EPN+AMP)*(EPN-AMP)) | |
26027 | ELSE | |
26028 | PPN = SQRT(EPN**2-AMP2) | |
26029 | ENDIF | |
26030 | ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN | |
26031 | IF (AMP2.GT.ZERO) THEN | |
26032 | EPN = PPN*SQRT(ONE+(AMP/PPN)**2) | |
26033 | ELSE | |
26034 | EPN = SQRT(PPN**2+AMP2) | |
26035 | ENDIF | |
26036 | ENDIF | |
26037 | ECM = SQRT(AMP2+AMT2+TWO*AMT*EPN) | |
26038 | ENDIF | |
26039 | UMO = ECM | |
26040 | EPROJ = EPN | |
26041 | PPROJ = PPN | |
26042 | IF (AMP2.GT.ZERO) THEN | |
26043 | ETARG = (ECM**2-AMP2-AMT2)/(TWO*AMP) | |
26044 | PTARG = -SQRT((ETARG+AMT)*(ETARG-AMT)) | |
26045 | ELSE | |
26046 | ETARG = TINY10 | |
26047 | PTARG = TINY10 | |
26048 | ENDIF | |
26049 | * photon-projectiles (get momentum in cm-frame for virtuality Q^2) | |
26050 | IF (IDP.EQ.7) THEN | |
26051 | PGAMM(1) = ZERO | |
26052 | PGAMM(2) = ZERO | |
26053 | AMGAM = AMP | |
26054 | AMGAM2 = AMP2 | |
26055 | IF (ECM0.GT.ZERO) THEN | |
26056 | S = ECM0**2 | |
26057 | ELSE | |
26058 | IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN | |
26059 | S = AMGAM2+AMT2+TWO*AMT*ABS(EPN0) | |
26060 | ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN | |
26061 | S = AMGAM2+AMT2+TWO*AMT*SQRT(PPN0**2+AMGAM2) | |
26062 | ENDIF | |
26063 | ENDIF | |
26064 | PGAMM(3) = SQRT( (S**2-TWO*AMGAM2*S-TWO*AMT2*S-TWO*AMGAM2*AMT2 | |
26065 | & +AMGAM2**2+AMT2**2)/(4.0D0*S) ) | |
26066 | PGAMM(4) = SQRT(AMGAM2+PGAMM(3)**2) | |
26067 | IF (MODE.EQ.1) THEN | |
26068 | PNUCL(1) = ZERO | |
26069 | PNUCL(2) = ZERO | |
26070 | PNUCL(3) = -PGAMM(3) | |
26071 | PNUCL(4) = SQRT(S)-PGAMM(4) | |
26072 | ENDIF | |
26073 | ENDIF | |
26074 | IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR. | |
26075 | & (IDPR.EQ.10).OR.(IDPR.EQ.11)) THEN | |
26076 | PLEPT0(1) = ZERO | |
26077 | PLEPT0(2) = ZERO | |
26078 | * neglect lepton masses | |
26079 | C AMLPT2 = AAM(IDPR)**2 | |
26080 | AMLPT2 = ZERO | |
26081 | * | |
26082 | IF (ECM0.GT.ZERO) THEN | |
26083 | S = ECM0**2 | |
26084 | ELSE | |
26085 | IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN | |
26086 | S = AMLPT2+AMT2+TWO*AMT*ABS(EPN0) | |
26087 | ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN | |
26088 | S = AMLPT2+AMT2+TWO*AMT*SQRT(PPN0**2+AMLPT2) | |
26089 | ENDIF | |
26090 | ENDIF | |
26091 | PLEPT0(3) = SQRT( (S**2-TWO*AMLPT2*S-TWO*AMT2*S-TWO*AMLPT2*AMT2 | |
26092 | & +AMLPT2**2+AMT2**2)/(4.0D0*S) ) | |
26093 | PLEPT0(4) = SQRT(AMLPT2+PLEPT0(3)**2) | |
26094 | PNUCL(1) = ZERO | |
26095 | PNUCL(2) = ZERO | |
26096 | PNUCL(3) = -PLEPT0(3) | |
26097 | PNUCL(4) = SQRT(S)-PLEPT0(4) | |
26098 | ENDIF | |
26099 | * Lorentz-parameter for transformation Lab. - projectile rest system | |
26100 | IF ((IDP.EQ.7).OR.(AMP.LT.TINY10)) THEN | |
26101 | GALAB = TINY10 | |
26102 | BGLAB = TINY10 | |
26103 | BLAB = TINY10 | |
26104 | ELSE | |
26105 | GALAB = EPROJ/AMP | |
26106 | BGLAB = PPROJ/AMP | |
26107 | BLAB = BGLAB/GALAB | |
26108 | ENDIF | |
26109 | * Lorentz-parameter for transf. proj. rest sys. - nucl.-nucl. cms. | |
26110 | IF (IDP.EQ.7) THEN | |
26111 | GACMS(1) = TINY10 | |
26112 | BGCMS(1) = TINY10 | |
26113 | ELSE | |
26114 | GACMS(1) = (ETARG+AMP)/UMO | |
26115 | BGCMS(1) = PTARG/UMO | |
26116 | ENDIF | |
26117 | * Lorentz-parameter for transformation Lab. - nucl.-nucl. cms. | |
26118 | GACMS(2) = (EPROJ+AMT)/UMO | |
26119 | BGCMS(2) = PPROJ/UMO | |
26120 | PPCM = GACMS(2)*PPROJ-BGCMS(2)*EPROJ | |
26121 | ||
26122 | EPN0 = EPN | |
26123 | PPN0 = PPN | |
26124 | ECM0 = ECM | |
26125 | ||
26126 | RETURN | |
26127 | END | |
26128 | ||
26129 | *$ CREATE DT_LTRANS.FOR | |
26130 | *COPY DT_LTRANS | |
26131 | * | |
26132 | *===ltrans=============================================================* | |
26133 | * | |
26134 | SUBROUTINE DT_LTRANS(PXI,PYI,PZI,PEI,PXO,PYO,PZO,PEO,ID,MODE) | |
26135 | ||
26136 | ************************************************************************ | |
26137 | * Lorentz-transformations. * | |
26138 | * MODE = 1(-1) projectile rest syst. --> Lab (back) * | |
26139 | * = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) * | |
26140 | * = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) * | |
26141 | * This version dated 01.11.95 is written by S. Roesler. * | |
26142 | ************************************************************************ | |
26143 | ||
26144 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26145 | SAVE | |
26146 | ||
26147 | PARAMETER ( LINP = 10 , | |
26148 | & LOUT = 6 , | |
26149 | & LDAT = 9 ) | |
26150 | ||
26151 | PARAMETER (TINY3=1.0D-3,ZERO=0.0D0,TWO=2.0D0) | |
26152 | ||
26153 | PARAMETER (SQTINF=1.0D+15) | |
26154 | ||
26155 | * particle properties (BAMJET index convention) | |
26156 | CHARACTER*8 ANAME | |
26157 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
26158 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
26159 | ||
26160 | PXO = PXI | |
26161 | PYO = PYI | |
26162 | CALL DT_LTNUC(PZI,PEI,PZO,PEO,MODE) | |
26163 | ||
26164 | * check particle mass for consistency (numerical rounding errors) | |
26165 | PO = SQRT(PXO*PXO+PYO*PYO+PZO*PZO) | |
26166 | AMO2 = (PEO-PO)*(PEO+PO) | |
26167 | AMORQ2 = AAM(ID)**2 | |
26168 | AMDIF2 = ABS(AMO2-AMORQ2) | |
26169 | IF ((AMDIF2.GT.TINY3).AND.(PEO.LT.SQTINF).AND.(PO.GT.ZERO)) THEN | |
26170 | DELTA = (AMORQ2-AMO2)/(TWO*(PEO+PO)) | |
26171 | PEO = PEO+DELTA | |
26172 | PO1 = PO -DELTA | |
26173 | PXO = PXO*PO1/PO | |
26174 | PYO = PYO*PO1/PO | |
26175 | PZO = PZO*PO1/PO | |
26176 | C WRITE(6,*) 'LTRANS corrected', AMDIF2,PZI,PEI,PZO,PEO,MODE,ID | |
26177 | ENDIF | |
26178 | ||
26179 | RETURN | |
26180 | END | |
26181 | ||
26182 | *$ CREATE DT_LTNUC.FOR | |
26183 | *COPY DT_LTNUC | |
26184 | * | |
26185 | *===ltnuc==============================================================* | |
26186 | * | |
26187 | SUBROUTINE DT_LTNUC(PIN,EIN,POUT,EOUT,MODE) | |
26188 | ||
26189 | ************************************************************************ | |
26190 | * Lorentz-transformations. * | |
26191 | * PIN longitudnal momentum (input) * | |
26192 | * EIN energy (input) * | |
26193 | * POUT transformed long. momentum (output) * | |
26194 | * EOUT transformed energy (output) * | |
26195 | * MODE = 1(-1) projectile rest syst. --> Lab (back) * | |
26196 | * = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) * | |
26197 | * = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) * | |
26198 | * This version dated 01.11.95 is written by S. Roesler. * | |
26199 | ************************************************************************ | |
26200 | ||
26201 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26202 | SAVE | |
26203 | ||
26204 | PARAMETER ( LINP = 10 , | |
26205 | & LOUT = 6 , | |
26206 | & LDAT = 9 ) | |
26207 | ||
26208 | PARAMETER (ZERO=0.0D0) | |
26209 | ||
26210 | * Lorentz-parameters of the current interaction | |
26211 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
26212 | & UMO,PPCM,EPROJ,PPROJ | |
26213 | ||
26214 | BDUM1 = ZERO | |
26215 | BDUM2 = ZERO | |
26216 | PDUM1 = ZERO | |
26217 | PDUM2 = ZERO | |
26218 | IF (ABS(MODE).EQ.1) THEN | |
26219 | BG = -SIGN(BGLAB,DBLE(MODE)) | |
26220 | CALL DT_DALTRA(GALAB,BDUM1,BDUM2,-BG,PDUM1,PDUM2,PIN,EIN, | |
26221 | & DUM1,DUM2,DUM3,POUT,EOUT) | |
26222 | ELSEIF (ABS(MODE).EQ.2) THEN | |
26223 | BG = SIGN(BGCMS(1),DBLE(MODE)) | |
26224 | CALL DT_DALTRA(GACMS(1),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN, | |
26225 | & DUM1,DUM2,DUM3,POUT,EOUT) | |
26226 | ELSEIF (ABS(MODE).EQ.3) THEN | |
26227 | BG = -SIGN(BGCMS(2),DBLE(MODE)) | |
26228 | CALL DT_DALTRA(GACMS(2),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN, | |
26229 | & DUM1,DUM2,DUM3,POUT,EOUT) | |
26230 | ELSE | |
26231 | WRITE(LOUT,1000) MODE | |
26232 | 1000 FORMAT(1X,'LTNUC: not supported mode (MODE = ',I3,')') | |
26233 | EOUT = EIN | |
26234 | POUT = PIN | |
26235 | ENDIF | |
26236 | ||
26237 | RETURN | |
26238 | END | |
26239 | ||
26240 | *$ CREATE DT_DALTRA.FOR | |
26241 | *COPY DT_DALTRA | |
26242 | * | |
26243 | *===daltra=============================================================* | |
26244 | * | |
26245 | SUBROUTINE DT_DALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E) | |
26246 | ||
26247 | ************************************************************************ | |
26248 | * Arbitrary Lorentz-transformation. * | |
26249 | * Adopted from the original by S. Roesler. This version dated 15.01.95 * | |
26250 | ************************************************************************ | |
26251 | ||
26252 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26253 | SAVE | |
26254 | PARAMETER (ONE=1.0D0) | |
26255 | ||
26256 | EP = PCX*BGX+PCY*BGY+PCZ*BGZ | |
26257 | PE = EP/(GA+ONE)+EC | |
26258 | PX = PCX+BGX*PE | |
26259 | PY = PCY+BGY*PE | |
26260 | PZ = PCZ+BGZ*PE | |
26261 | P = SQRT(PX*PX+PY*PY+PZ*PZ) | |
26262 | E = GA*EC+EP | |
26263 | ||
26264 | RETURN | |
26265 | END | |
26266 | ||
26267 | *$ CREATE DT_DTRAFO.FOR | |
26268 | *COPY DT_DTRAFO | |
26269 | * | |
26270 | *====dtrafo============================================================* | |
26271 | * | |
26272 | SUBROUTINE DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM, | |
26273 | & PL,CXL,CYL,CZL,EL) | |
26274 | ||
26275 | C LORENTZ TRANSFORMATION INTO THE LAB - SYSTEM | |
26276 | ||
26277 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26278 | SAVE | |
26279 | ||
26280 | IF (ABS(COD).GT.1.0D0) COD = SIGN(1.0D0,COD) | |
26281 | SID = SQRT(1.D0-COD*COD) | |
26282 | PLX = P*SID*COF | |
26283 | PLY = P*SID*SIF | |
26284 | PCMZ = P*COD | |
26285 | PLZ = GAM*PCMZ+BGAM*ECM | |
26286 | PL = SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ) | |
26287 | EL = GAM*ECM+BGAM*PCMZ | |
26288 | C ROTATION INTO THE ORIGINAL DIRECTION | |
26289 | COZ = PLZ/PL | |
26290 | SIZ = SQRT(1.D0-COZ**2) | |
26291 | CALL DT_STTRAN(CX,CY,CZ,COZ,SIZ,SIF,COF,CXL,CYL,CZL) | |
26292 | ||
26293 | RETURN | |
26294 | END | |
26295 | ||
26296 | *$ CREATE DT_STTRAN.FOR | |
26297 | *COPY DT_STTRAN | |
26298 | * | |
26299 | *====sttran============================================================* | |
26300 | * | |
26301 | SUBROUTINE DT_STTRAN(XO,YO,ZO,CDE,SDE,SFE,CFE,X,Y,Z) | |
26302 | ||
26303 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26304 | SAVE | |
26305 | DATA ANGLSQ/1.D-30/ | |
26306 | ************************************************************************ | |
26307 | * VERSION BY J. RANFT * | |
26308 | * LEIPZIG * | |
26309 | * * | |
26310 | * THIS IS A SUBROUTINE OF FLUKA TO GIVE NEW DIRECTION COSINES * | |
26311 | * * | |
26312 | * INPUT VARIABLES: * | |
26313 | * XO,YO,ZO = ORIGINAL DIRECTION COSINES * | |
26314 | * CDE,SDE = COSINE AND SINE OF THE POLAR (THETA) * | |
26315 | * ANGLE OF "SCATTERING" * | |
26316 | * SDE = SINE OF THE POLAR (THETA) ANGLE OF "SCATTERING" * | |
26317 | * SFE,CFE = SINE AND COSINE OF THE AZIMUTHAL (PHI) ANGLE * | |
26318 | * OF "SCATTERING" * | |
26319 | * * | |
26320 | * OUTPUT VARIABLES: * | |
26321 | * X,Y,Z = NEW DIRECTION COSINES * | |
26322 | * * | |
26323 | * ROTATION OF COORDINATE SYSTEM (SEE CERN 64-47 ) * | |
26324 | ************************************************************************ | |
26325 | * | |
26326 | * | |
26327 | * Changed by A. Ferrari | |
26328 | * | |
26329 | * IF (ABS(XO)-0.0001D0) 1,1,2 | |
26330 | * 1 IF (ABS(YO)-0.0001D0) 3,3,2 | |
26331 | * 3 CONTINUE | |
26332 | A = XO**2 + YO**2 | |
26333 | IF ( A .LT. ANGLSQ ) THEN | |
26334 | X=SDE*CFE | |
26335 | Y=SDE*SFE | |
26336 | Z=CDE*ZO | |
26337 | ELSE | |
26338 | XI=SDE*CFE | |
26339 | YI=SDE*SFE | |
26340 | ZI=CDE | |
26341 | A=SQRT(A) | |
26342 | X=-YO*XI/A-ZO*XO*YI/A+XO*ZI | |
26343 | Y=XO*XI/A-ZO*YO*YI/A+YO*ZI | |
26344 | Z=A*YI+ZO*ZI | |
26345 | ENDIF | |
26346 | ||
26347 | RETURN | |
26348 | END | |
26349 | ||
26350 | *$ CREATE DT_MYTRAN.FOR | |
26351 | *COPY DT_MYTRAN | |
26352 | * | |
26353 | *===mytran=============================================================* | |
26354 | * | |
26355 | SUBROUTINE DT_MYTRAN(IMODE,XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z) | |
26356 | ||
26357 | ************************************************************************ | |
26358 | * This subroutine rotates the coordinate frame * | |
26359 | * a) theta around y * | |
26360 | * b) phi around z if IMODE = 1 * | |
26361 | * * | |
26362 | * x' cos(ph) -sin(ph) 0 cos(th) 0 sin(th) x * | |
26363 | * y' = A B = sin(ph) cos(ph) 0 . 0 1 0 y * | |
26364 | * z' 0 0 1 -sin(th) 0 cos(th) z * | |
26365 | * * | |
26366 | * and vice versa if IMODE = 0. * | |
26367 | * This version dated 5.4.94 is based on the original version DTRAN * | |
26368 | * by J. Ranft and is written by S. Roesler. * | |
26369 | ************************************************************************ | |
26370 | ||
26371 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26372 | SAVE | |
26373 | ||
26374 | PARAMETER ( LINP = 10 , | |
26375 | & LOUT = 6 , | |
26376 | & LDAT = 9 ) | |
26377 | ||
26378 | IF (IMODE.EQ.1) THEN | |
26379 | X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO | |
26380 | Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO | |
26381 | Z=-SDE *XO +CDE *ZO | |
26382 | ELSE | |
26383 | X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO | |
26384 | Y= -SFE*XO+CFE*YO | |
26385 | Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO | |
26386 | ENDIF | |
26387 | RETURN | |
26388 | END | |
26389 | ||
26390 | *$ CREATE DT_LT2LAO.FOR | |
26391 | *COPY DT_LT2LAO | |
26392 | * | |
26393 | *===lt2lab=============================================================* | |
26394 | * | |
26395 | SUBROUTINE DT_LT2LAO | |
26396 | ||
26397 | ************************************************************************ | |
26398 | * Lorentz-transformation to lab-system. This subroutine scans DTEVT1 * | |
26399 | * for final state particles/fragments defined in nucleon-nucleon-cms * | |
26400 | * and transforms them back to the lab. * | |
26401 | * This version dated 16.11.95 is written by S. Roesler * | |
26402 | ************************************************************************ | |
26403 | ||
26404 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26405 | SAVE | |
26406 | ||
26407 | PARAMETER ( LINP = 10 , | |
26408 | & LOUT = 6 , | |
26409 | & LDAT = 9 ) | |
26410 | ||
26411 | * event history | |
26412 | ||
26413 | PARAMETER (NMXHKK=200000) | |
26414 | ||
26415 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
26416 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
26417 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
26418 | ||
26419 | * extended event history | |
26420 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
26421 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
26422 | & IHIST(2,NMXHKK) | |
26423 | ||
26424 | NEND = NHKK | |
26425 | NPOINT(5) = NHKK+1 | |
26426 | IF ( (NPOINT(4).EQ.0).OR.(NEND.LT.NPOINT(4)) ) RETURN | |
26427 | DO 1 I=NPOINT(4),NEND | |
26428 | C DO 1 I=1,NEND | |
26429 | IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR. | |
26430 | & (ISTHKK(I).EQ.1001)) THEN | |
26431 | CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3) | |
26432 | NOB = NOBAM(I) | |
26433 | CALL DT_EVTPUT(ISTHKK(I),IDHKK(I),I,0,PHKK(1,I),PHKK(2,I), | |
26434 | & PZ,PE,IDRES(I),IDXRES(I),IDCH(I)) | |
26435 | IF ((ISTHKK(I).EQ.1000).OR.(ISTHKK(I).EQ.1001)) THEN | |
26436 | ISTHKK(I) = 3*ISTHKK(I) | |
26437 | NOBAM(NHKK) = NOB | |
26438 | ELSE | |
26439 | IF (ISTHKK(I).EQ.-1) NOBAM(NHKK) = NOB | |
26440 | ISTHKK(I) = SIGN(3,ISTHKK(I)) | |
26441 | ENDIF | |
26442 | JDAHKK(1,I) = NHKK | |
26443 | ENDIF | |
26444 | 1 CONTINUE | |
26445 | ||
26446 | RETURN | |
26447 | END | |
26448 | ||
26449 | *$ CREATE DT_LT2LAB.FOR | |
26450 | *COPY DT_LT2LAB | |
26451 | * | |
26452 | *===lt2lab=============================================================* | |
26453 | * | |
26454 | SUBROUTINE DT_LT2LAB | |
26455 | ||
26456 | ************************************************************************ | |
26457 | * Lorentz-transformation to lab-system. This subroutine scans DTEVT1 * | |
26458 | * for final state particles/fragments defined in nucleon-nucleon-cms * | |
26459 | * and transforms them to the lab. * | |
26460 | * This version dated 07.01.96 is written by S. Roesler * | |
26461 | ************************************************************************ | |
26462 | ||
26463 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26464 | SAVE | |
26465 | ||
26466 | PARAMETER ( LINP = 10 , | |
26467 | & LOUT = 6 , | |
26468 | & LDAT = 9 ) | |
26469 | ||
26470 | * event history | |
26471 | ||
26472 | PARAMETER (NMXHKK=200000) | |
26473 | ||
26474 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
26475 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
26476 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
26477 | ||
26478 | * extended event history | |
26479 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
26480 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
26481 | & IHIST(2,NMXHKK) | |
26482 | ||
26483 | IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN | |
26484 | DO 1 I=NPOINT(4),NHKK | |
26485 | IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR. | |
26486 | & (ISTHKK(I).EQ.1001)) THEN | |
26487 | CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3) | |
26488 | PHKK(3,I) = PZ | |
26489 | PHKK(4,I) = PE | |
26490 | ENDIF | |
26491 | 1 CONTINUE | |
26492 | ||
26493 | RETURN | |
26494 | END | |
26495 | ||
26496 | ************************************************************************ | |
26497 | * * | |
26498 | * 5) Sampling from distributions * | |
26499 | * * | |
26500 | ************************************************************************ | |
26501 | *$ CREATE IDT_NPOISS.FOR | |
26502 | *COPY IDT_NPOISS | |
26503 | * | |
26504 | *===npoiss=============================================================* | |
26505 | * | |
26506 | INTEGER FUNCTION IDT_NPOISS(AVN) | |
26507 | ||
26508 | ************************************************************************ | |
26509 | * Sample according to Poisson distribution with Poisson parameter AVN. * | |
26510 | * The original version written by J. Ranft. * | |
26511 | * This version dated 11.1.95 is written by S. Roesler. * | |
26512 | ************************************************************************ | |
26513 | ||
26514 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26515 | SAVE | |
26516 | ||
26517 | PARAMETER ( LINP = 10 , | |
26518 | & LOUT = 6 , | |
26519 | & LDAT = 9 ) | |
26520 | ||
26521 | EXPAVN = EXP(-AVN) | |
26522 | K = 1 | |
26523 | A = 1.0D0 | |
26524 | ||
26525 | 10 CONTINUE | |
26526 | A = DT_RNDM(A)*A | |
26527 | IF (A.GE.EXPAVN) THEN | |
26528 | K = K+1 | |
26529 | GOTO 10 | |
26530 | ENDIF | |
26531 | IDT_NPOISS = K-1 | |
26532 | ||
26533 | RETURN | |
26534 | END | |
26535 | ||
26536 | *$ CREATE DT_SAMPXB.FOR | |
26537 | *COPY DT_SAMPXB | |
26538 | * | |
26539 | *===sampxb=============================================================* | |
26540 | * | |
26541 | DOUBLE PRECISION FUNCTION DT_SAMPXB(X1,X2,B) | |
26542 | ||
26543 | ************************************************************************ | |
26544 | * Sampling from f(x)=1./SQRT(X**2+B**2) between x1 and x2. * | |
26545 | * Processed by S. Roesler, 6.5.95 * | |
26546 | ************************************************************************ | |
26547 | ||
26548 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26549 | SAVE | |
26550 | PARAMETER (TWO=2.0D0) | |
26551 | ||
26552 | A1 = LOG(X1+SQRT(X1**2+B**2)) | |
26553 | A2 = LOG(X2+SQRT(X2**2+B**2)) | |
26554 | AN = A2-A1 | |
26555 | A = AN*DT_RNDM(A1)+A1 | |
26556 | BB = EXP(A) | |
26557 | DT_SAMPXB = (BB**2-B**2)/(TWO*BB) | |
26558 | ||
26559 | RETURN | |
26560 | END | |
26561 | ||
26562 | *$ CREATE DT_SAMPEX.FOR | |
26563 | *COPY DT_SAMPEX | |
26564 | * | |
26565 | *===sampex=============================================================* | |
26566 | * | |
26567 | DOUBLE PRECISION FUNCTION DT_SAMPEX(X1,X2) | |
26568 | ||
26569 | ************************************************************************ | |
26570 | * Sampling from f(x)=1./x between x1 and x2. * | |
26571 | * Processed by S. Roesler, 6.5.95 * | |
26572 | ************************************************************************ | |
26573 | ||
26574 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26575 | SAVE | |
26576 | PARAMETER (ONE=1.0D0) | |
26577 | ||
26578 | R = DT_RNDM(X1) | |
26579 | AL1 = LOG(X1) | |
26580 | AL2 = LOG(X2) | |
26581 | DT_SAMPEX = EXP((ONE-R)*AL1+R*AL2) | |
26582 | ||
26583 | RETURN | |
26584 | END | |
26585 | ||
26586 | *$ CREATE DT_SAMSQX.FOR | |
26587 | *COPY DT_SAMSQX | |
26588 | * | |
26589 | *===samsqx=============================================================* | |
26590 | * | |
26591 | DOUBLE PRECISION FUNCTION DT_SAMSQX(X1,X2) | |
26592 | ||
26593 | ************************************************************************ | |
26594 | * Sampling from f(x)=1./x^0.5 between x1 and x2. * | |
26595 | * Processed by S. Roesler, 6.5.95 * | |
26596 | ************************************************************************ | |
26597 | ||
26598 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26599 | SAVE | |
26600 | PARAMETER (ONE=1.0D0) | |
26601 | ||
26602 | R = DT_RNDM(X1) | |
26603 | DT_SAMSQX = (R*SQRT(X2)+(ONE-R)*SQRT(X1))**2 | |
26604 | ||
26605 | RETURN | |
26606 | END | |
26607 | ||
26608 | *$ CREATE DT_SAMPLW.FOR | |
26609 | *COPY DT_SAMPLW | |
26610 | * | |
26611 | *===samplw=============================================================* | |
26612 | * | |
26613 | DOUBLE PRECISION FUNCTION DT_SAMPLW(XMIN,XMAX,B) | |
26614 | ||
26615 | ************************************************************************ | |
26616 | * Sampling from f(x)=1/x^b between x_min and x_max. * | |
26617 | * S. Roesler, 18.4.98 * | |
26618 | ************************************************************************ | |
26619 | ||
26620 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26621 | SAVE | |
26622 | PARAMETER (ONE=1.0D0) | |
26623 | ||
26624 | R = DT_RNDM(B) | |
26625 | IF (B.EQ.ONE) THEN | |
26626 | DT_SAMPLW = EXP(R*LOG(XMAX)+(ONE-R)*LOG(XMIN)) | |
26627 | ELSE | |
26628 | ONEMB = ONE-B | |
26629 | DT_SAMPLW = (R*XMAX**ONEMB+(ONE-R)*XMIN**ONEMB)**(ONE/ONEMB) | |
26630 | ENDIF | |
26631 | ||
26632 | RETURN | |
26633 | END | |
26634 | ||
26635 | *$ CREATE DT_BETREJ.FOR | |
26636 | *COPY DT_BETREJ | |
26637 | * | |
26638 | *===betrej=============================================================* | |
26639 | * | |
26640 | DOUBLE PRECISION FUNCTION DT_BETREJ(GAM,ETA,XMIN,XMAX) | |
26641 | ||
26642 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26643 | SAVE | |
26644 | ||
26645 | PARAMETER ( LINP = 10 , | |
26646 | & LOUT = 6 , | |
26647 | & LDAT = 9 ) | |
26648 | ||
26649 | PARAMETER (ONE=1.0D0) | |
26650 | ||
26651 | IF (XMIN.GE.XMAX)THEN | |
26652 | WRITE (LOUT,500) XMIN,XMAX | |
26653 | 500 FORMAT(1X,'DT_BETREJ: XMIN<XMAX execution stopped ',2F10.5) | |
26654 | STOP | |
26655 | ENDIF | |
26656 | ||
26657 | 10 CONTINUE | |
26658 | XX = XMIN+(XMAX-XMIN)*DT_RNDM(ETA) | |
26659 | BETMAX = XMIN**(GAM-ONE)*(ONE-XMIN)**(ETA-ONE) | |
26660 | YY = BETMAX*DT_RNDM(XX) | |
26661 | BETXX = XX**(GAM-ONE)*(ONE-XX)**(ETA-ONE) | |
26662 | IF (YY.GT.BETXX) GOTO 10 | |
26663 | DT_BETREJ = XX | |
26664 | ||
26665 | RETURN | |
26666 | END | |
26667 | ||
26668 | *$ CREATE DT_DGAMRN.FOR | |
26669 | *COPY DT_DGAMRN | |
26670 | * | |
26671 | *===dgamrn=============================================================* | |
26672 | * | |
26673 | DOUBLE PRECISION FUNCTION DT_DGAMRN(ALAM,ETA) | |
26674 | ||
26675 | ************************************************************************ | |
26676 | * Sampling from Gamma-distribution. * | |
26677 | * F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA) * | |
26678 | * Processed by S. Roesler, 6.5.95 * | |
26679 | ************************************************************************ | |
26680 | ||
26681 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26682 | SAVE | |
26683 | PARAMETER (ZERO=0.0D0,TINY9=1.0D-9,ONE=1.0D0) | |
26684 | ||
26685 | NCOU = 0 | |
26686 | N = INT(ETA) | |
26687 | F = ETA-DBLE(N) | |
26688 | IF (F.EQ.ZERO) GOTO 20 | |
26689 | 10 R = DT_RNDM(F) | |
26690 | NCOU = NCOU+1 | |
26691 | IF (NCOU.GE.11) GOTO 20 | |
26692 | IF (R.LT.F/(F+2.71828D0)) GOTO 30 | |
26693 | YYY = LOG(DT_RNDM(R)+TINY9)/F | |
26694 | IF (ABS(YYY).GT.50.0D0) GOTO 20 | |
26695 | Y = EXP(YYY) | |
26696 | IF (LOG(DT_RNDM(Y)+TINY9).GT.-Y) GOTO 10 | |
26697 | GOTO 40 | |
26698 | 20 Y = 0.0D0 | |
26699 | GOTO 50 | |
26700 | 30 Y = ONE-LOG(DT_RNDM(Y)+TINY9) | |
26701 | IF (DT_RNDM(R).GT.Y**(F-ONE)) GOTO 10 | |
26702 | 40 IF (N.EQ.0) GOTO 70 | |
26703 | 50 Z = 1.0D0 | |
26704 | DO 60 I = 1,N | |
26705 | 60 Z = Z*DT_RNDM(Z) | |
26706 | Y = Y-LOG(Z+TINY9) | |
26707 | 70 DT_DGAMRN = Y/ALAM | |
26708 | ||
26709 | RETURN | |
26710 | END | |
26711 | ||
26712 | *$ CREATE DT_DBETAR.FOR | |
26713 | *COPY DT_DBETAR | |
26714 | * | |
26715 | *===dbetar=============================================================* | |
26716 | * | |
26717 | DOUBLE PRECISION FUNCTION DT_DBETAR(GAM,ETA) | |
26718 | ||
26719 | ************************************************************************ | |
26720 | * Sampling from Beta -distribution between 0.0 and 1.0 * | |
26721 | * F(X)=X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM)/(GAMM(GAM)*GAMM(ETA))* | |
26722 | * Processed by S. Roesler, 6.5.95 * | |
26723 | ************************************************************************ | |
26724 | ||
26725 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26726 | SAVE | |
26727 | ||
26728 | Y = DT_DGAMRN(1.0D0,GAM) | |
26729 | Z = DT_DGAMRN(1.0D0,ETA) | |
26730 | DT_DBETAR = Y/(Y+Z) | |
26731 | ||
26732 | RETURN | |
26733 | END | |
26734 | ||
26735 | *$ CREATE DT_RANNOR.FOR | |
26736 | *COPY DT_RANNOR | |
26737 | * | |
26738 | *===rannor=============================================================* | |
26739 | * | |
26740 | SUBROUTINE DT_RANNOR(X,Y) | |
26741 | ||
26742 | ************************************************************************ | |
26743 | * Sampling from Gaussian distribution. * | |
26744 | * Processed by S. Roesler, 6.5.95 * | |
26745 | ************************************************************************ | |
26746 | ||
26747 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26748 | SAVE | |
26749 | PARAMETER (TINY10=1.0D-10) | |
26750 | ||
26751 | CALL DT_DSFECF(SFE,CFE) | |
26752 | V = MAX(TINY10,DT_RNDM(X)) | |
26753 | A = SQRT(-2.D0*LOG(V)) | |
26754 | X = A*SFE | |
26755 | Y = A*CFE | |
26756 | ||
26757 | RETURN | |
26758 | END | |
26759 | ||
26760 | *$ CREATE DT_DPOLI.FOR | |
26761 | *COPY DT_DPOLI | |
26762 | * | |
26763 | *===dpoli==============================================================* | |
26764 | * | |
26765 | SUBROUTINE DT_DPOLI(CS,SI) | |
26766 | ||
26767 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26768 | SAVE | |
26769 | ||
26770 | U = DT_RNDM(CS) | |
26771 | CS = DT_RNDM(U) | |
26772 | IF (U.LT.0.5D0) CS=-CS | |
26773 | SI = SQRT(1.0D0-CS*CS+1.0D-10) | |
26774 | ||
26775 | RETURN | |
26776 | END | |
26777 | ||
26778 | *$ CREATE DT_DSFECF.FOR | |
26779 | *COPY DT_DSFECF | |
26780 | * | |
26781 | *===dsfecf=============================================================* | |
26782 | * | |
26783 | SUBROUTINE DT_DSFECF(SFE,CFE) | |
26784 | ||
26785 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26786 | SAVE | |
26787 | PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0) | |
26788 | ||
26789 | 1 CONTINUE | |
26790 | X = DT_RNDM(SFE) | |
26791 | Y = DT_RNDM(X) | |
26792 | XX = X*X | |
26793 | YY = Y*Y | |
26794 | XY = XX+YY | |
26795 | IF (XY.GT.ONE) GOTO 1 | |
26796 | CFE = (XX-YY)/XY | |
26797 | SFE = TWO*X*Y/XY | |
26798 | IF (DT_RNDM(X).LT.OHALF) SFE = -SFE | |
26799 | RETURN | |
26800 | END | |
26801 | ||
26802 | *$ CREATE DT_RACO.FOR | |
26803 | *COPY DT_RACO | |
26804 | * | |
26805 | *===raco===============================================================* | |
26806 | * | |
26807 | SUBROUTINE DT_RACO(WX,WY,WZ) | |
26808 | ||
26809 | ************************************************************************ | |
26810 | * Direction cosines of random uniform (isotropic) direction in three * | |
26811 | * dimensional space * | |
26812 | * Processed by S. Roesler, 20.11.95 * | |
26813 | ************************************************************************ | |
26814 | ||
26815 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26816 | SAVE | |
26817 | PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0) | |
26818 | ||
26819 | 10 CONTINUE | |
26820 | X = TWO*DT_RNDM(WX)-ONE | |
26821 | Y = DT_RNDM(X) | |
26822 | X2 = X*X | |
26823 | Y2 = Y*Y | |
26824 | IF (X2+Y2.GT.ONE) GOTO 10 | |
26825 | ||
26826 | CFE = (X2-Y2)/(X2+Y2) | |
26827 | SFE = TWO*X*Y/(X2+Y2) | |
26828 | * z = 1/2 [ 1 + cos (theta) ] | |
26829 | Z = DT_RNDM(X) | |
26830 | * 1/2 sin (theta) | |
26831 | WZ = SQRT(Z*(ONE-Z)) | |
26832 | WX = TWO*WZ*CFE | |
26833 | WY = TWO*WZ*SFE | |
26834 | WZ = TWO*Z-ONE | |
26835 | ||
26836 | RETURN | |
26837 | END | |
26838 | ||
26839 | ************************************************************************ | |
26840 | * * | |
26841 | * 6) Special functions, algorithms and service routines * | |
26842 | * * | |
26843 | ************************************************************************ | |
26844 | *$ CREATE DT_YLAMB.FOR | |
26845 | *COPY DT_YLAMB | |
26846 | * | |
26847 | *===ylamb==============================================================* | |
26848 | * | |
26849 | DOUBLE PRECISION FUNCTION DT_YLAMB(X,Y,Z) | |
26850 | ||
26851 | ************************************************************************ | |
26852 | * * | |
26853 | * auxiliary function for three particle decay mode * | |
26854 | * (standard LAMBDA**(1/2) function) * | |
26855 | * * | |
26856 | * Adopted from an original version written by R. Engel. * | |
26857 | * This version dated 12.12.94 is written by S. Roesler. * | |
26858 | ************************************************************************ | |
26859 | ||
26860 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26861 | SAVE | |
26862 | ||
26863 | YZ = Y-Z | |
26864 | XLAM = X*X-2.D0*X*(Y+Z)+YZ*YZ | |
26865 | IF (XLAM.LE.0.D0) XLAM = ABS(XLAM) | |
26866 | DT_YLAMB = SQRT(XLAM) | |
26867 | ||
26868 | RETURN | |
26869 | END | |
26870 | ||
26871 | *$ CREATE DT_SORT.FOR | |
26872 | *COPY DT_SORT | |
26873 | * | |
26874 | *===sort1==============================================================* | |
26875 | * | |
26876 | SUBROUTINE DT_SORT(A,N,I0,I1,MODE) | |
26877 | ||
26878 | ************************************************************************ | |
26879 | * This subroutine sorts entries in A in increasing/decreasing order * | |
26880 | * of A(3,i). * | |
26881 | * MODE = 1 increasing in A(3,i=1..N) * | |
26882 | * = 2 decreasing in A(3,i=1..N) * | |
26883 | * This version dated 21.04.95 is revised by S. Roesler * | |
26884 | ************************************************************************ | |
26885 | ||
26886 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26887 | SAVE | |
26888 | ||
26889 | DIMENSION A(3,N) | |
26890 | ||
26891 | M = I1 | |
26892 | 10 CONTINUE | |
26893 | M = I1-1 | |
26894 | IF (M.LE.0) RETURN | |
26895 | L = 0 | |
26896 | DO 20 I=I0,M | |
26897 | J = I+1 | |
26898 | IF (MODE.EQ.1) THEN | |
26899 | IF (A(3,I).LE.A(3,J)) GOTO 20 | |
26900 | ELSE | |
26901 | IF (A(3,I).GE.A(3,J)) GOTO 20 | |
26902 | ENDIF | |
26903 | B = A(3,I) | |
26904 | C = A(1,I) | |
26905 | D = A(2,I) | |
26906 | A(3,I) = A(3,J) | |
26907 | A(2,I) = A(2,J) | |
26908 | A(1,I) = A(1,J) | |
26909 | A(3,J) = B | |
26910 | A(1,J) = C | |
26911 | A(2,J) = D | |
26912 | L = 1 | |
26913 | 20 CONTINUE | |
26914 | IF (L.EQ.1) GOTO 10 | |
26915 | ||
26916 | RETURN | |
26917 | END | |
26918 | ||
26919 | *$ CREATE DT_SORT1.FOR | |
26920 | *COPY DT_SORT1 | |
26921 | * | |
26922 | *===sort1==============================================================* | |
26923 | * | |
26924 | SUBROUTINE DT_SORT1(A,IDX,N,I0,I1,MODE) | |
26925 | ||
26926 | ************************************************************************ | |
26927 | * This subroutine sorts entries in A in increasing/decreasing order * | |
26928 | * of A(i). * | |
26929 | * MODE = 1 increasing in A(i=1..N) * | |
26930 | * = 2 decreasing in A(i=1..N) * | |
26931 | * This version dated 21.04.95 is revised by S. Roesler * | |
26932 | ************************************************************************ | |
26933 | ||
26934 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26935 | SAVE | |
26936 | ||
26937 | DIMENSION A(N),IDX(N) | |
26938 | ||
26939 | M = I1 | |
26940 | 10 CONTINUE | |
26941 | M = I1-1 | |
26942 | IF (M.LE.0) RETURN | |
26943 | L = 0 | |
26944 | DO 20 I=I0,M | |
26945 | J = I+1 | |
26946 | IF (MODE.EQ.1) THEN | |
26947 | IF (A(I).LE.A(J)) GOTO 20 | |
26948 | ELSE | |
26949 | IF (A(I).GE.A(J)) GOTO 20 | |
26950 | ENDIF | |
26951 | B = A(I) | |
26952 | A(I) = A(J) | |
26953 | A(J) = B | |
26954 | IX = IDX(I) | |
26955 | IDX(I) = IDX(J) | |
26956 | IDX(J) = IX | |
26957 | L = 1 | |
26958 | 20 CONTINUE | |
26959 | IF (L.EQ.1) GOTO 10 | |
26960 | ||
26961 | RETURN | |
26962 | END | |
26963 | ||
26964 | *$ CREATE DT_XTIME.FOR | |
26965 | *COPY DT_XTIME | |
26966 | * | |
26967 | *===xtime==============================================================* | |
26968 | * | |
26969 | SUBROUTINE DT_XTIME | |
26970 | ||
26971 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26972 | SAVE | |
26973 | ||
26974 | PARAMETER ( LINP = 10 , | |
26975 | & LOUT = 6 , | |
26976 | & LDAT = 9 ) | |
26977 | ||
26978 | CHARACTER DAT*9,TIM*11 | |
26979 | ||
26980 | DAT = ' ' | |
26981 | TIM = ' ' | |
26982 | C CALL GETDAT(IYEAR,IMONTH,IDAY) | |
26983 | C CALL GETTIM(IHOUR,IMINUT,ISECND,IHSCND) | |
26984 | ||
26985 | C CALL DATE(DAT) | |
26986 | C CALL TIME(TIM) | |
26987 | C WRITE(LOUT,1000) DAT,TIM | |
26988 | 1000 FORMAT(/,2X,'Date: ',A9,3X,'Time: ',A11,/) | |
26989 | ||
26990 | RETURN | |
26991 | END | |
26992 | ||
26993 | ************************************************************************ | |
26994 | * * | |
26995 | * 7) Random number generator package * | |
26996 | * * | |
26997 | * THIS IS A PACKAGE CONTAINING A RANDOM NUMBER GENERATOR AND * | |
26998 | * SERVICE ROUTINES. * | |
26999 | * THE ALGORITHM IS FROM * | |
27000 | * 'TOWARD A UNVERSAL RANDOM NUMBER GENERATOR' * | |
27001 | * G.MARSAGLIA, A.ZAMAN ; FSU-SCRI-87-50 * | |
27002 | * IMPLEMENTATION BY K. HAHN DEC. 88, * | |
27003 | * THIS GENERATOR SHOULD NOT DEPEND ON THE HARD WARE ( IF A REAL HAS * | |
27004 | * AT LEAST 24 SIGNIFICANT BITS IN INTERNAL REPRESENTATION ), * | |
27005 | * THE PERIOD IS ABOUT 2**144, * | |
27006 | * TIME FOR ONE CALL AT IBM-XT IS ABOUT 0.7 MILLISECONDS, * | |
27007 | * THE PACKAGE CONTAINS * | |
27008 | * FUNCTION DT_RNDM(I) : GENERATOR * | |
27009 | * SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB4): INITIALIZATION * | |
27010 | * SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) : PUT SEED TO GENERATOR * | |
27011 | * SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) : TAKE SEED FROM GENERATOR * | |
27012 | * SUBROUTINE DT_RNDMTE(IO) : TEST OF GENERATOR * | |
27013 | *--- * | |
27014 | * FUNCTION DT_RNDM(I) * | |
27015 | * GIVES UNIFORMLY DISTRIBUTED RANDOM NUMBERS IN (0..1) * | |
27016 | * I - DUMMY VARIABLE, NOT USED * | |
27017 | * SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1) * | |
27018 | * INITIALIZES THE GENERATOR, MUST BE CALLED BEFORE USING DT_RNDM * | |
27019 | * NA1,NA2,NA3,NB1 - VALUES FOR INITIALIZING THE GENERATOR * | |
27020 | * NA? MUST BE IN 1..178 AND NOT ALL 1 * | |
27021 | * 12,34,56 ARE THE STANDARD VALUES * | |
27022 | * NB1 MUST BE IN 1..168 * | |
27023 | * 78 IS THE STANDARD VALUE * | |
27024 | * SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) * | |
27025 | * PUTS SEED TO GENERATOR ( BRINGS GENERATOR IN THE SAME STATUS * | |
27026 | * AS AFTER THE LAST DT_RNDMOU CALL ) * | |
27027 | * U(97),C,CD,CM,I,J - SEED VALUES AS TAKEN FROM DT_RNDMOU * | |
27028 | * SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) * | |
27029 | * TAKES SEED FROM GENERATOR * | |
27030 | * U(97),C,CD,CM,I,J - SEED VALUES * | |
27031 | * SUBROUTINE DT_RNDMTE(IO) * | |
27032 | * TEST OF THE GENERATOR * | |
27033 | * IO - DEFINES OUTPUT * | |
27034 | * = 0 OUTPUT ONLY IF AN ERROR IS DETECTED * | |
27035 | * = 1 OUTPUT INDEPENDEND ON AN ERROR * | |
27036 | * DT_RNDMTE USES DT_RNDMIN AND DT_RNDMOU TO BRING GENERATOR TO * | |
27037 | * SAME STATUS * | |
27038 | * AS BEFORE CALL OF DT_RNDMTE * | |
27039 | ************************************************************************ | |
27040 | *$ CREATE DT_RNDM.FOR | |
27041 | *COPY DT_RNDM | |
27042 | * | |
27043 | *===rndm===============================================================* | |
27044 | * | |
27045 | c$$$ DOUBLE PRECISION FUNCTION DT_RNDM(VDUMMY) | |
27046 | c$$$ | |
27047 | c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27048 | c$$$ SAVE | |
27049 | c$$$ | |
27050 | c$$$* counter of calls to random number generator | |
27051 | c$$$* uncomment if needed | |
27052 | c$$$C COMMON /DTRNCT/ IRNCT0,IRNCT1 | |
27053 | c$$$C LOGICAL LFIRST | |
27054 | c$$$C DATA LFIRST /.TRUE./ | |
27055 | c$$$ | |
27056 | c$$$* counter of calls to random number generator | |
27057 | c$$$* uncomment if needed | |
27058 | c$$$C IF (LFIRST) THEN | |
27059 | c$$$C IRNCT0 = 0 | |
27060 | c$$$C IRNCT1 = 0 | |
27061 | c$$$C LFIRST = .FALSE. | |
27062 | c$$$C ENDIF | |
27063 | c$$$ | |
27064 | c$$$ DT_RNDM = FLRNDM(VDUMMY) | |
27065 | c$$$* counter of calls to random number generator | |
27066 | c$$$* uncomment if needed | |
27067 | c$$$C IRNCT1 = IRNCT1+1 | |
27068 | c$$$ | |
27069 | c$$$ RETURN | |
27070 | c$$$ END | |
27071 | c$$$ | |
27072 | c$$$*$ CREATE DT_RNDMST.FOR | |
27073 | c$$$*COPY DT_RNDMST | |
27074 | c$$$* | |
27075 | c$$$*===rndmst=============================================================* | |
27076 | c$$$* | |
27077 | c$$$ SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1) | |
27078 | c$$$ | |
27079 | c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27080 | c$$$ SAVE | |
27081 | c$$$ | |
27082 | c$$$* random number generator | |
27083 | c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J | |
27084 | c$$$ | |
27085 | c$$$ MA1 = NA1 | |
27086 | c$$$ MA2 = NA2 | |
27087 | c$$$ MA3 = NA3 | |
27088 | c$$$ MB1 = NB1 | |
27089 | c$$$ I = 97 | |
27090 | c$$$ J = 33 | |
27091 | c$$$ DO 20 II2 = 1,97 | |
27092 | c$$$ S = 0 | |
27093 | c$$$ T = 0.5D0 | |
27094 | c$$$ DO 10 II1 = 1,24 | |
27095 | c$$$ MAT = MOD(MOD(MA1*MA2,179)*MA3,179) | |
27096 | c$$$ MA1 = MA2 | |
27097 | c$$$ MA2 = MA3 | |
27098 | c$$$ MA3 = MAT | |
27099 | c$$$ MB1 = MOD(53*MB1+1,169) | |
27100 | c$$$ IF ( MOD(MB1*MAT,64).GE.32 ) S = S+T | |
27101 | c$$$ 10 T = 0.5D0*T | |
27102 | c$$$ 20 U(II2) = S | |
27103 | c$$$ C = 362436.0D0/16777216.0D0 | |
27104 | c$$$ CD = 7654321.0D0/16777216.0D0 | |
27105 | c$$$ CM = 16777213.0D0/16777216.0D0 | |
27106 | c$$$ RETURN | |
27107 | c$$$ END | |
27108 | c$$$ | |
27109 | c$$$*$ CREATE DT_RNDMIN.FOR | |
27110 | c$$$*COPY DT_RNDMIN | |
27111 | c$$$* | |
27112 | c$$$*===rndmin=============================================================* | |
27113 | c$$$* | |
27114 | c$$$ SUBROUTINE DT_RNDMIN(UIN,CIN,CDIN,CMIN,IIN,JIN) | |
27115 | c$$$ | |
27116 | c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27117 | c$$$ SAVE | |
27118 | c$$$ | |
27119 | c$$$* random number generator | |
27120 | c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J | |
27121 | c$$$ | |
27122 | c$$$ DIMENSION UIN(97) | |
27123 | c$$$ | |
27124 | c$$$ DO 10 KKK = 1,97 | |
27125 | c$$$ 10 U(KKK) = UIN(KKK) | |
27126 | c$$$ C = CIN | |
27127 | c$$$ CD = CDIN | |
27128 | c$$$ CM = CMIN | |
27129 | c$$$ I = IIN | |
27130 | c$$$ J = JIN | |
27131 | c$$$ | |
27132 | c$$$ RETURN | |
27133 | c$$$ END | |
27134 | c$$$ | |
27135 | c$$$*$ CREATE DT_RNDMOU.FOR | |
27136 | c$$$*COPY DT_RNDMOU | |
27137 | c$$$* | |
27138 | c$$$*===rndmou=============================================================* | |
27139 | c$$$* | |
27140 | c$$$ SUBROUTINE DT_RNDMOU(UOUT,COUT,CDOUT,CMOUT,IOUT,JOUT) | |
27141 | c$$$ | |
27142 | c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27143 | c$$$ SAVE | |
27144 | c$$$ | |
27145 | c$$$* random number generator | |
27146 | c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J | |
27147 | c$$$ | |
27148 | c$$$ DIMENSION UOUT(97) | |
27149 | c$$$ | |
27150 | c$$$ DO 10 KKK = 1,97 | |
27151 | c$$$ 10 UOUT(KKK) = U(KKK) | |
27152 | c$$$ COUT = C | |
27153 | c$$$ CDOUT = CD | |
27154 | c$$$ CMOUT = CM | |
27155 | c$$$ IOUT = I | |
27156 | c$$$ JOUT = J | |
27157 | c$$$ | |
27158 | c$$$ RETURN | |
27159 | c$$$ END | |
27160 | c$$$ | |
27161 | c$$$*$ CREATE DT_RNDMTE.FOR | |
27162 | c$$$*COPY DT_RNDMTE | |
27163 | c$$$* | |
27164 | c$$$*===rndmte=============================================================* | |
27165 | c$$$* | |
27166 | c$$$ SUBROUTINE DT_RNDMTE(IO) | |
27167 | c$$$ | |
27168 | c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27169 | c$$$ SAVE | |
27170 | c$$$ | |
27171 | c$$$ DIMENSION UU(97),U(6),X(6),D(6) | |
27172 | c$$$ DATA U / 6533892.D0, 14220222.D0, 7275067.D0, 6172232.D0, | |
27173 | c$$$ +8354498.D0, 10633180.D0/ | |
27174 | c$$$ | |
27175 | c$$$ CALL DT_RNDMOU(UU,CC,CCD,CCM,II,JJ) | |
27176 | c$$$ CALL DT_RNDMST(12,34,56,78) | |
27177 | c$$$ DO 10 II1 = 1,20000 | |
27178 | c$$$ 10 XX = DT_RNDM(XX) | |
27179 | c$$$ SD = 0.0D0 | |
27180 | c$$$ DO 20 II2 = 1,6 | |
27181 | c$$$ X(II2) = 4096.D0*(4096.D0*DT_RNDM(SD)) | |
27182 | c$$$ D(II2) = X(II2)-U(II2) | |
27183 | c$$$ 20 SD = SD+D(II2) | |
27184 | c$$$ CALL DT_RNDMIN(UU,CC,CCD,CCM,II,JJ) | |
27185 | c$$$**sr 24.01.95 | |
27186 | c$$$C IF ( IO.EQ. 1.OR. SD.NE.0. 0) WRITE(6,500) (U(I),X(I),D(I),I=1,6) | |
27187 | c$$$ IF ((IO.EQ.1).OR.(SD.NE.0.0)) THEN | |
27188 | c$$$C WRITE(6,1000) | |
27189 | c$$$ 1000 FORMAT(/,/,1X,'DT_RNDMTE: Test of random-number generator...', | |
27190 | c$$$ & ' passed') | |
27191 | c$$$ ENDIF | |
27192 | c$$$** | |
27193 | c$$$ RETURN | |
27194 | c$$$ 500 FORMAT(' === TEST OF THE RANDOM-GENERATOR ===',/, | |
27195 | c$$$ &' EXPECTED VALUE CALCULATED VALUE DIFFERENCE',/, 6(F17. | |
27196 | c$$$ &1,F20.1,F15.3,/), ' === END OF TEST ;', | |
27197 | c$$$ &' GENERATOR HAS THE SAME STATUS AS BEFORE CALLING DT_RNDMTE') | |
27198 | c$$$ END | |
27199 | * | |
27200 | *$ CREATE PHO_RNDM.FOR | |
27201 | *COPY PHO_RNDM | |
27202 | * | |
27203 | *===pho_rndm===========================================================* | |
27204 | * | |
27205 | DOUBLE PRECISION FUNCTION PHO_RNDM(DUMMY) | |
27206 | ||
27207 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27208 | SAVE | |
27209 | ||
27210 | PHO_RNDM = DT_RNDM(DUMMY) | |
27211 | ||
27212 | RETURN | |
27213 | END | |
27214 | ||
27215 | *$ CREATE PYR.FOR | |
27216 | *COPY PYR | |
27217 | * | |
27218 | *===pyr================================================================* | |
27219 | * | |
27220 | DOUBLE PRECISION FUNCTION PYR(IDUMMY) | |
27221 | ||
27222 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27223 | SAVE | |
27224 | ||
27225 | DUMMY = DBLE(IDUMMY) | |
27226 | PYR = DT_RNDM(DUMMY) | |
27227 | ||
27228 | RETURN | |
27229 | END | |
27230 | *$ CREATE DT_TITLE.FOR | |
27231 | *COPY DT_TITLE | |
27232 | * | |
27233 | *===title==============================================================* | |
27234 | * | |
27235 | SUBROUTINE DT_TITLE | |
27236 | ||
27237 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27238 | SAVE | |
27239 | ||
27240 | PARAMETER ( LINP = 10 , | |
27241 | & LOUT = 6 , | |
27242 | & LDAT = 9 ) | |
27243 | ||
27244 | CHARACTER*6 CVERSI | |
27245 | CHARACTER*11 CCHANG | |
27246 | DATA CVERSI,CCHANG /'3.0-5 ','31 Oct 2008'/ | |
27247 | ||
27248 | CALL DT_XTIME | |
27249 | WRITE(LOUT,1000) CVERSI,CCHANG | |
27250 | 1000 FORMAT(1X,'+-------------------------------------------------', | |
27251 | & '----------------------+',/, | |
27252 | & 1X,'|',71X,'|',/, | |
27253 | & 1X,'|',26X,'DPMJET version ',A6,24X,'|',/, | |
27254 | & 1X,'|',71X,'|',/, | |
27255 | & 1X,'|',22X,'(Last change: ',A11,')',23X,'|',/, | |
27256 | & 1X,'|',71X,'|',/, | |
27257 | & 1X,'|',12X,'Authors: Stefan Roesler (CERN)',27X,'|',/, | |
27258 | & 1X,'|',21X,'Ralph Engel (FZ Karlsruhe)',19X,'|',/, | |
27259 | & 1X,'|',21X,'Johannes Ranft (Siegen Univ.)',19X,'|',/, | |
27260 | C & 1X,'|',71X,'|',/, | |
27261 | C & 1X,'|',12X,'http://home.cern.ch/~sroesler/dpmjet3.html', | |
27262 | C & 17X,'|',/, | |
27263 | & 1X,'|',71X,'|',/, | |
27264 | & 1X,'+-------------------------------------------------', | |
27265 | & '----------------------+',/, | |
27266 | & 1X,'| Please send suggestions, bug reports, etc. to: ', | |
27267 | & 'Stefan.Roesler@cern.ch |',/, | |
27268 | & 1X,'+-------------------------------------------------', | |
27269 | & '----------------------+',/) | |
27270 | ||
27271 | RETURN | |
27272 | END | |
27273 | ||
27274 | *$ CREATE DT_EVTINI.FOR | |
27275 | *COPY DT_EVTINI | |
27276 | * | |
27277 | *===evtini=============================================================* | |
27278 | * | |
27279 | SUBROUTINE DT_EVTINI | |
27280 | ||
27281 | ************************************************************************ | |
27282 | * Initialization of DTEVT1. * | |
27283 | * This version dated 15.01.94 is written by S. Roesler * | |
27284 | ************************************************************************ | |
27285 | ||
27286 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27287 | SAVE | |
27288 | ||
27289 | PARAMETER ( LINP = 10 , | |
27290 | & LOUT = 6 , | |
27291 | & LDAT = 9 ) | |
27292 | ||
27293 | * event history | |
27294 | ||
27295 | PARAMETER (NMXHKK=200000) | |
27296 | ||
27297 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
27298 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
27299 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
27300 | ||
27301 | * extended event history | |
27302 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
27303 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
27304 | & IHIST(2,NMXHKK) | |
27305 | ||
27306 | * event flag | |
27307 | COMMON /DTEVNO/ NEVENT,ICASCA | |
27308 | ||
27309 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
27310 | ||
27311 | * emulsion treatment | |
27312 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
27313 | & NCOMPO,IEMUL | |
27314 | ||
27315 | * initialization of DTEVT1/DTEVT2 | |
27316 | NEND = NHKK | |
27317 | IF (NEVENT.EQ.1) NEND = NMXHKK | |
27318 | NHKK = 0 | |
27319 | NEVHKK = NEVENT | |
27320 | DO 1 I=1,NEND | |
27321 | ISTHKK(I) = 0 | |
27322 | IDHKK(I) = 0 | |
27323 | JMOHKK(1,I) = 0 | |
27324 | JMOHKK(2,I) = 0 | |
27325 | JDAHKK(1,I) = 0 | |
27326 | JDAHKK(2,I) = 0 | |
27327 | IDRES(I) = 0 | |
27328 | IDXRES(I) = 0 | |
27329 | NOBAM(I) = 0 | |
27330 | IDCH(I) = 0 | |
27331 | IHIST(1,I) = 0 | |
27332 | IHIST(2,I) = 0 | |
27333 | DO 2 J=1,4 | |
27334 | PHKK(J,I) = 0.0D0 | |
27335 | VHKK(J,I) = 0.0D0 | |
27336 | WHKK(J,I) = 0.0D0 | |
27337 | 2 CONTINUE | |
27338 | PHKK(5,I) = 0.0D0 | |
27339 | 1 CONTINUE | |
27340 | DO 3 I=1,10 | |
27341 | NPOINT(I) = 0 | |
27342 | 3 CONTINUE | |
27343 | CALL DT_CHASTA(-1) | |
27344 | ||
27345 | C* initialization of DTLTRA | |
27346 | C IF (NCOMPO.GT.0) CALL DT_LTINI(ID,EPN,PPN,ECM) | |
27347 | ||
27348 | RETURN | |
27349 | END | |
27350 | ||
27351 | *$ CREATE DT_STATIS.FOR | |
27352 | *COPY DT_STATIS | |
27353 | * | |
27354 | *===statis=============================================================* | |
27355 | * | |
27356 | SUBROUTINE DT_STATIS(MODE) | |
27357 | ||
27358 | ************************************************************************ | |
27359 | * Initialization and output of run-statistics. * | |
27360 | * MODE = 1 initialization * | |
27361 | * = 2 output * | |
27362 | * This version dated 23.01.94 is written by S. Roesler * | |
27363 | ************************************************************************ | |
27364 | ||
27365 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27366 | SAVE | |
27367 | ||
27368 | PARAMETER ( LINP = 10 , | |
27369 | & LOUT = 6 , | |
27370 | & LDAT = 9 ) | |
27371 | ||
27372 | PARAMETER (TINY3=1.0D-3) | |
27373 | ||
27374 | * statistics | |
27375 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
27376 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
27377 | & ICEVTG(8,0:30) | |
27378 | ||
27379 | * rejection counter | |
27380 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
27381 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
27382 | & IREXCI(3),IRDIFF(2),IRINC | |
27383 | ||
27384 | * central particle production, impact parameter biasing | |
27385 | COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR | |
27386 | ||
27387 | * various options for treatment of partons (DTUNUC 1.x) | |
27388 | * (chain recombination, Cronin,..) | |
27389 | LOGICAL LCO2CR,LINTPT | |
27390 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, | |
27391 | & LCO2CR,LINTPT | |
27392 | ||
27393 | * nucleon-nucleon event-generator | |
27394 | CHARACTER*8 CMODEL | |
27395 | LOGICAL LPHOIN | |
27396 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
27397 | ||
27398 | * flags for particle decays | |
27399 | COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20), | |
27400 | & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20), | |
27401 | & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0 | |
27402 | ||
27403 | * diquark-breaking mechanism | |
27404 | COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3 | |
27405 | ||
27406 | DIMENSION PP(4),PT(4) | |
27407 | ||
27408 | GOTO (1,2) MODE | |
27409 | ||
27410 | * initialization | |
27411 | 1 CONTINUE | |
27412 | ||
27413 | * initialize statistics counter | |
27414 | ICREQU = 0 | |
27415 | ICSAMP = 0 | |
27416 | ICCPRO = 0 | |
27417 | ICDPR = 0 | |
27418 | ICDTA = 0 | |
27419 | ICRJSS = 0 | |
27420 | ICVV2S = 0 | |
27421 | DO 10 I=1,9 | |
27422 | ICRES(I) = 0 | |
27423 | ICCHAI(1,I) = 0 | |
27424 | ICCHAI(2,I) = 0 | |
27425 | 10 CONTINUE | |
27426 | * initialize rejection counter | |
27427 | IRPT = 0 | |
27428 | IRHHA = 0 | |
27429 | LOMRES = 0 | |
27430 | LOBRES = 0 | |
27431 | IRFRAG = 0 | |
27432 | IREVT = 0 | |
27433 | IRRES(1) = 0 | |
27434 | IRRES(2) = 0 | |
27435 | IRCHKI(1) = 0 | |
27436 | IRCHKI(2) = 0 | |
27437 | IRCRON(1) = 0 | |
27438 | IRCRON(2) = 0 | |
27439 | IRCRON(3) = 0 | |
27440 | IRDIFF(1) = 0 | |
27441 | IRDIFF(2) = 0 | |
27442 | IRINC = 0 | |
27443 | DO 11 I=1,5 | |
27444 | ICDIFF(I) = 0 | |
27445 | 11 CONTINUE | |
27446 | DO 12 I=1,8 | |
27447 | DO 13 J=0,30 | |
27448 | ICEVTG(I,J) = 0 | |
27449 | 13 CONTINUE | |
27450 | 12 CONTINUE | |
27451 | ||
27452 | RETURN | |
27453 | ||
27454 | * output | |
27455 | 2 CONTINUE | |
27456 | ||
27457 | * statistics counter | |
27458 | WRITE(LOUT,1000) | |
27459 | 1000 FORMAT(/,/,1X,'STATIS:',20X,'statistics of the run',/, | |
27460 | & 28X,'---------------------') | |
27461 | WRITE(LOUT,1001) ICREQU,ICSAMP,DBLE(ICSAMP)/DBLE(ICREQU) | |
27462 | 1001 FORMAT(/,1X,'number of events requested / sampled',13X, | |
27463 | & I8,' / ',I8,/,1X,'number of samp. evts per requested ', | |
27464 | & 'event',11X,F9.1) | |
27465 | IF (ICDIFF(1).NE.0) THEN | |
27466 | WRITE(LOUT,1009) ICDIFF | |
27467 | 1009 FORMAT(/,1X,'diffractive events: total ',I8,/,49X, | |
27468 | & 'low mass high mass',/,24X,'single diffraction', | |
27469 | & 7X,I8,4X,I8,/,24X,'double diffraction',7X,I8,4X,I8) | |
27470 | ENDIF | |
27471 | IF (ICENTR.GT.0) THEN | |
27472 | WRITE(LOUT,1002) DBLE(ICCPRO)/DBLE(ICSAMP), | |
27473 | & DBLE(ICSAMP)/DBLE(ICCPRO) | |
27474 | 1002 FORMAT(/,1X,'central production:',/,2X,'mean number', | |
27475 | & ' of sampled Glauber-events per event',9X,F9.1,/, | |
27476 | & 2X,'fraction of production cross section',21X,F10.6) | |
27477 | ENDIF | |
27478 | WRITE(LOUT,1003) DBLE(ICDPR)/DBLE(ICSAMP), | |
27479 | & DBLE(ICDTA)/DBLE(ICSAMP) | |
27480 | 1003 FORMAT(/,54X,'proj. targ.',/,1X,'average number of wounded', | |
27481 | & ' nucleons after x-sampling',2(4X,F6.2)) | |
27482 | ||
27483 | IF (MCGENE.EQ.1) THEN | |
27484 | WRITE(LOUT,1004) DBLE(ICRJSS)/DBLE(ICSAMP) | |
27485 | 1004 FORMAT(/,1X,'mean number of sea-sea chain rejections per', | |
27486 | & ' event',3X,F9.1) | |
27487 | IF (ISICHA.EQ.1) THEN | |
27488 | WRITE(LOUT,1005) DBLE(ICVV2S)/DBLE(ICSAMP) | |
27489 | 1005 FORMAT(/,1X,'Reggeon contribution:',/,1X,'mean number ', | |
27490 | & 'of single chains per event',13X,F9.1) | |
27491 | ENDIF | |
27492 | WRITE(LOUT,1006) | |
27493 | 1006 FORMAT(/,1X,'chain system statistics: (per event)',/, | |
27494 | & 23X,'mean number of chains mean number of chains',/, | |
27495 | & 23X,'sampled hadronized having mass of a reso.') | |
27496 | WRITE(LOUT,1007) (DBLE(ICCHAI(1,J))/(2.0D0*DBLE(ICSAMP)), | |
27497 | & DBLE(ICCHAI(2,J))/(2.0D0*DBLE(ICREQU)), | |
27498 | & DBLE(ICRES(J))/(2.0D0*DBLE(ICREQU)),J=1,8), | |
27499 | & DBLE(ICCHAI(2,9))/MAX(DBLE(ICCHAI(1,9)),TINY3) | |
27500 | 1007 FORMAT(1X,'sea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/, | |
27501 | & 1X,'disea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/, | |
27502 | & 1X,'sea - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/, | |
27503 | & 1X,'sea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/, | |
27504 | & 1X,'disea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/, | |
27505 | & 1X,'valence - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/, | |
27506 | & 1X,'valence - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/, | |
27507 | & 1X,'valence - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/, | |
27508 | & 1X,'fused chains ',18X,F4.1,17X,F4.1,/) | |
27509 | WRITE(LOUT,1008) | |
27510 | & (DBLE(IRCRON(I))/MAX(DBLE(IRCRON(1)),TINY3),I=2,3), | |
27511 | & DBLE(IRPT)/DBLE(ICREQU),(DBLE(IRRES(I))/DBLE(ICREQU),I=1,2), | |
27512 | & DBLE(LOMRES)/DBLE(ICREQU),DBLE(LOBRES)/DBLE(ICREQU), | |
27513 | & (DBLE(IRCHKI(I))/DBLE(ICREQU),I=1,2), | |
27514 | & (DBLE(IRDIFF(I))/DBLE(ICREQU),I=1,2), | |
27515 | & DBLE(IRHHA)/DBLE(ICREQU), | |
27516 | & DBLE(IRFRAG)/DBLE(ICREQU),DBLE(IREVT)/DBLE(ICREQU), | |
27517 | & (DBLE(IREXCI(I))/DBLE(ICREQU),I=1,2),IREXCI(3) | |
27518 | 1008 FORMAT(/,1X,'Rejection counter: (NEVT = no. of events)',/,/, | |
27519 | & 1X,'Cronin-effect (CRONIN)',15X,'IRCRON(2)/IRCRON(1) = ', | |
27520 | & F7.2,/,38X,'IRCRON(3)/IRCRON(1) = ',F7.2,/,1X, | |
27521 | & 'Intrins. p_t (GETSPT)',21X,'IRPT /NEVT = ',F7.2,/, | |
27522 | & 1X,'Chain mass corr. for resonances (EVTRES)',2X, | |
27523 | & 'IRRES(1) /NEVT = ',F7.2,/,33X,'(CH2RES) IRRES(2) /', | |
27524 | & 'NEVT = ',F7.2,/,43X,'LOMRES /NEVT = ',F7.2,/, | |
27525 | & 43X,'LOBRES /NEVT = ',F7.2,/,1X,'Kinem. corr. of', | |
27526 | & ' 2-chain systems (CHKINE) IRCHKI(1)/NEVT = ',F7.2,/, | |
27527 | & 43X,'IRCHKI(2)/NEVT = ',F7.2,/,1X,'Diffraction',31X, | |
27528 | & 'IRDIFF(1)/NEVT = ',F7.2,/,43X,'IRDIFF(2)/NEVT = ', | |
27529 | & F7.2,/,1X,'Total no. of rej.', | |
27530 | & ' in chain-systems treatment (GETCSY)',/,43X, | |
27531 | & 'IRHHA /NEVT = ',F7.2,/,1X,'Fragmentation (EVTFRA)', | |
27532 | & ' (not yet used!)',4X,'IRFRAG /NEVT = ',F7.2,/, | |
27533 | & 1X,'Total no. of rej. in DPM-treatment of one event', | |
27534 | & ' (EVENTA)',/,43X,'IREVT /NEVT = ',F7.2,/,1X, | |
27535 | & 'Treatment of final nucleon conf.',10X,'IREXCI(1)/NEVT = ' | |
27536 | & ,F7.2,/,43X,'IREXCI(2)/NEVT = ',F7.2,/,48X, | |
27537 | & 'IREXCI(3) = ',I5,/) | |
27538 | ELSEIF (MCGENE.EQ.2) THEN | |
27539 | WRITE(LOUT,1010) ELOJET | |
27540 | 1010 FORMAT(/,/,1X,'PHOJET-treatment of chain systems above ', | |
27541 | & F4.1,' GeV') | |
27542 | WRITE(LOUT,1011) | |
27543 | 1011 FORMAT(/,1X,'1. chain system statistics - total numbers:',/, | |
27544 | & 30X,'--------------',/,/,12X,'s-s',5X,'d-s',5X,'s-d', | |
27545 | & 5X,'s-v',5X,'d-v',5X,'v-s',5X,'v-d',5X,'v-v') | |
27546 | WRITE(LOUT,1012) ((ICEVTG(I,J),I=1,8),J=0,1), | |
27547 | & (INT(ICCHAI(2,I)/2.0D0),I=1,8), | |
27548 | & (ICEVTG(I,2),I=1,8),(ICEVTG(I,29),I=1,8), | |
27549 | & ((ICEVTG(I,J),I=1,8),J=3,7), | |
27550 | & ((ICEVTG(I,J),I=1,8),J=19,21), | |
27551 | & (ICEVTG(I,8),I=1,8), | |
27552 | & ((ICEVTG(I,J),I=1,8),J=22,24), | |
27553 | & (ICEVTG(I,9),I=1,8), | |
27554 | & ((ICEVTG(I,J),I=1,8),J=25,28), | |
27555 | & ((ICEVTG(I,J),I=1,8),J=10,18) | |
27556 | 1012 FORMAT(/,1X,'req.to.',8I8,/,/,1X,'low rq.',8I8,/,1X,'low ac.', | |
27557 | & 8I8,/,/,1X,'PHOJET ',8I8,/,' sngl ',8I8,/,/, | |
27558 | & ' no-dif.',8I8,/, | |
27559 | & ' el-sca.',8I8,/,' qel-sc.',8I8,/,' dbl-Po.',8I8,/, | |
27560 | & ' diff-1 ',8I8,/,' low ',8I8,/,' high ',8I8,/, | |
27561 | & ' h-diff',8I8,/,' diff-2 ',8I8,/,' low ',8I8,/, | |
27562 | & ' high ',8I8,/,' h-diff',8I8,/,' dbl-di.',8I8,/, | |
27563 | & ' lo-lo ',8I8,/,' hi-hi ',8I8,/,' lo-hi ',8I8,/, | |
27564 | & ' hi-lo ',8I8,/, | |
27565 | & ' dir-ga.',8I8,/,/,' dir-1 ',8I8,/,' dir-2 ',8I8,/, | |
27566 | & ' dbl-dir',8I8,/,' s-Pom. ',8I8,/,' h-Pom. ',8I8,/, | |
27567 | & ' s-Reg. ',8I8,/,' enh-trg',8I8,/,' enh-log',8I8) | |
27568 | WRITE(LOUT,1013) | |
27569 | 1013 FORMAT(/,1X,'2. chain system statistics -', | |
27570 | & ' mean numbers per evt:',/,30X,'---------------------', | |
27571 | & /,/,16X,'s-s',7X,'d-s',7X,'s-d') | |
27572 | WRITE(LOUT,1014) | |
27573 | & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=0,1), | |
27574 | & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=1,3), | |
27575 | & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=2,18) | |
27576 | 1014 FORMAT(/,1X,'req.to. ',3E10.2,/,/,1X,'low rq. ',3E10.2,/, | |
27577 | & 1X,'low ac. ',3E10.2,/,/,1X,'PHOJET ',3E10.2,/,/, | |
27578 | & ' no-dif. ',3E10.2,/,' el-sca. ',3E10.2,/, | |
27579 | & ' qel-sc. ',3E10.2,/,' dbl-Po. ',3E10.2,/, | |
27580 | & ' diff-1 ',3E10.2,/,' diff-2 ',3E10.2,/, | |
27581 | & ' dbl-di. ',3E10.2,/,' dir-ga. ',3E10.2,/,/, | |
27582 | & ' dir-1 ',3E10.2,/,' dir-2 ',3E10.2,/, | |
27583 | & ' dbl-dir ',3E10.2,/,' s-Pom. ',3E10.2,/, | |
27584 | & ' h-Pom. ',3E10.2,/,' s-Reg. ',3E10.2,/, | |
27585 | & ' enh-trg ',3E10.2,/,' enh-log ',3E10.2) | |
27586 | WRITE(LOUT,1015) | |
27587 | 1015 FORMAT(/,16X,'s-v',7X,'d-v',7X,'v-s',7X,'v-d',7X,'v-v') | |
27588 | WRITE(LOUT,1016) | |
27589 | & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=0,1), | |
27590 | & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=4,8), | |
27591 | & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=2,18) | |
27592 | 1016 FORMAT(/,1X,'req.to. ',5E10.2,/,/,1X,'low rq. ',5E10.2,/, | |
27593 | & 1X,'low ac. ',5E10.2,/,/,1X,'PHOJET ',5E10.2,/,/, | |
27594 | & ' no-dif. ',5E10.2,/,' el-sca. ',5E10.2,/, | |
27595 | & ' qel-sc. ',5E10.2,/,' dbl-Po. ',5E10.2,/, | |
27596 | & ' diff-1 ',5E10.2,/,' diff-2 ',5E10.2,/, | |
27597 | & ' dbl-di. ',5E10.2,/,' dir-ga. ',5E10.2,/,/, | |
27598 | & ' dir-1 ',5E10.2,/,' dir-2 ',5E10.2,/, | |
27599 | & ' dbl-dir ',5E10.2,/,' s-Pom. ',5E10.2,/, | |
27600 | & ' h-Pom. ',5E10.2,/,' s-Reg. ',5E10.2,/, | |
27601 | & ' enh-trg ',5E10.2,/,' enh-log ',5E10.2) | |
27602 | ||
27603 | ENDIF | |
27604 | CALL DT_CHASTA(1) | |
27605 | ||
27606 | IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0) | |
27607 | & .OR.(PDBSEA(3).GT.0.0D0)) THEN | |
27608 | WRITE(LOUT,*)'YGS1S,YGS2S,YUS1S,YUS2S', | |
27609 | & DBRKA(1,1)+DBRKA(2,1),DBRKA(1,2)+DBRKA(2,2), | |
27610 | & DBRKA(1,3)+DBRKA(2,3),DBRKA(1,4)+DBRKA(2,4) | |
27611 | WRITE(LOUT,*)'YGS1R,YGS2R,YUS1R,YUS2R', | |
27612 | & DBRKR(1,1)+DBRKR(2,1),DBRKR(1,2)+DBRKR(2,2), | |
27613 | & DBRKR(1,3)+DBRKR(2,3),DBRKR(1,4)+DBRKR(2,4) | |
27614 | WRITE(LOUT,*)'YGSA1S,YGSA2S,YUSA1S,YUSA2S', | |
27615 | & DBRKA(1,5)+DBRKA(2,5),DBRKA(1,6)+DBRKA(2,6), | |
27616 | & DBRKA(1,7)+DBRKA(2,7),DBRKA(1,8)+DBRKA(2,8) | |
27617 | WRITE(LOUT,*)'YGSA1R,YGSA2R,YUSA1R,YUSA2R', | |
27618 | & DBRKR(1,5)+DBRKR(2,5),DBRKR(1,6)+DBRKR(2,6), | |
27619 | & DBRKR(1,7)+DBRKR(2,7),DBRKR(1,8)+DBRKR(2,8) | |
27620 | WRITE(LOUT,*)'YG31S,YG32S,YU31S,YU32S', | |
27621 | & DBRKA(3,1),DBRKA(3,2), | |
27622 | & DBRKA(3,3),DBRKA(3,4) | |
27623 | WRITE(LOUT,*)'YG31R,YG32R,YU31R,YU32R', | |
27624 | & DBRKR(3,1),DBRKR(3,2), | |
27625 | & DBRKR(3,3),DBRKR(3,4) | |
27626 | WRITE(LOUT,*)'YG3A1S,YG3A2S,YU3A1S,YU3A2S', | |
27627 | & DBRKA(3,5),DBRKA(3,6), | |
27628 | & DBRKA(3,7),DBRKA(3,8) | |
27629 | WRITE(LOUT,*)'YG3A1R,YG3A2R,YU3A1R,YU3A2R', | |
27630 | & DBRKR(3,5),DBRKR(3,6), | |
27631 | & DBRKR(3,7),DBRKR(3,8) | |
27632 | ENDIF | |
27633 | ||
27634 | FAC = 1.0D0 | |
27635 | IF (MCGENE.EQ.2) THEN | |
27636 | ||
27637 | C CALL PHO_PHIST(-2,SIGMAX) | |
27638 | CALL PHO_EVENT(-2,PP,PT,FAC,IREJ1) | |
27639 | ||
27640 | ENDIF | |
27641 | ||
27642 | CALL DT_XTIME | |
27643 | ||
27644 | RETURN | |
27645 | END | |
27646 | ||
27647 | *$ CREATE DT_EVTOUT.FOR | |
27648 | *COPY DT_EVTOUT | |
27649 | * | |
27650 | *===evtout=============================================================* | |
27651 | * | |
27652 | SUBROUTINE DT_EVTOUT(MODE) | |
27653 | ||
27654 | ************************************************************************ | |
27655 | * MODE = 1 plot content of complete DTEVT1 to out. unit * | |
27656 | * 3 plot entries of extended DTEVT1 (DTEVT2) * | |
27657 | * 4 plot entries of DTEVT1 and DTEVT2 * | |
27658 | * This version dated 11.12.94 is written by S. Roesler * | |
27659 | ************************************************************************ | |
27660 | ||
27661 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27662 | SAVE | |
27663 | ||
27664 | PARAMETER ( LINP = 10 , | |
27665 | & LOUT = 6 , | |
27666 | & LDAT = 9 ) | |
27667 | ||
27668 | * event history | |
27669 | ||
27670 | PARAMETER (NMXHKK=200000) | |
27671 | ||
27672 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
27673 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
27674 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
27675 | ||
27676 | DIMENSION IRANGE(NMXHKK) | |
27677 | ||
27678 | IF (MODE.EQ.2) RETURN | |
27679 | ||
27680 | CALL DT_EVTPLO(IRANGE,MODE) | |
27681 | ||
27682 | RETURN | |
27683 | END | |
27684 | ||
27685 | *$ CREATE DT_EVTPLO.FOR | |
27686 | *COPY DT_EVTPLO | |
27687 | * | |
27688 | *===evtplo=============================================================* | |
27689 | * | |
27690 | SUBROUTINE DT_EVTPLO(IRANGE,MODE) | |
27691 | ||
27692 | ************************************************************************ | |
27693 | * MODE = 1 plot content of complete DTEVT1 to out. unit * | |
27694 | * 2 plot entries of DTEVT1 given by IRANGE * | |
27695 | * 3 plot entries of extended DTEVT1 (DTEVT2) * | |
27696 | * 4 plot entries of DTEVT1 and DTEVT2 * | |
27697 | * 5 plot rejection counter * | |
27698 | * This version dated 11.12.94 is written by S. Roesler * | |
27699 | ************************************************************************ | |
27700 | ||
27701 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27702 | SAVE | |
27703 | ||
27704 | PARAMETER ( LINP = 10 , | |
27705 | & LOUT = 6 , | |
27706 | & LDAT = 9 ) | |
27707 | ||
27708 | CHARACTER*16 CHAU | |
27709 | ||
27710 | * event history | |
27711 | ||
27712 | PARAMETER (NMXHKK=200000) | |
27713 | ||
27714 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
27715 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
27716 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
27717 | ||
27718 | * extended event history | |
27719 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
27720 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
27721 | & IHIST(2,NMXHKK) | |
27722 | ||
27723 | * rejection counter | |
27724 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
27725 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
27726 | & IREXCI(3),IRDIFF(2),IRINC | |
27727 | ||
27728 | DIMENSION IRANGE(NMXHKK) | |
27729 | ||
27730 | IF ((MODE.EQ.1).OR.(MODE.EQ.4)) THEN | |
27731 | WRITE(LOUT,1000) | |
27732 | 1000 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTEVT1/',/, | |
27733 | & 15X,' --------------------------',/,/, | |
27734 | & ' ST ID M1 M2 D1 D2 PX PY', | |
27735 | & ' PZ E M',/) | |
27736 | DO 1 I=1,NHKK | |
27737 | WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I), | |
27738 | & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I), | |
27739 | & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I), | |
27740 | & PHKK(5,I) | |
27741 | C WRITE(LOUT,1011) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I), | |
27742 | C & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I), | |
27743 | C & PHKK(3,I),PHKK(4,I) | |
27744 | C WRITE(LOUT,'(4E15.4)') | |
27745 | C & VHKK(1,I),VHKK(2,I),VHKK(3,I),VHKK(4,I) | |
27746 | 1001 FORMAT(I5,I5,I6,4I5,3F7.3,F8.3,F8.4) | |
27747 | 1011 FORMAT(I5,I5,I6,4I5,2E15.5) | |
27748 | 1 CONTINUE | |
27749 | WRITE(LOUT,*) | |
27750 | C DO 4 I=1,NHKK | |
27751 | C WRITE(LOUT,1006) I,ISTHKK(I), | |
27752 | C & VHKK(1,I),VHKK(2,I),VHKK(3,I),WHKK(1,I), | |
27753 | C & WHKK(2,I),WHKK(3,I) | |
27754 | C1006 FORMAT(1X,I4,I6,6E10.3) | |
27755 | C 4 CONTINUE | |
27756 | ENDIF | |
27757 | ||
27758 | IF (MODE.EQ.2) THEN | |
27759 | WRITE(LOUT,1000) | |
27760 | NC = 0 | |
27761 | 2 CONTINUE | |
27762 | NC = NC+1 | |
27763 | IF (IRANGE(NC).EQ.-100) GOTO 9999 | |
27764 | I = IRANGE(NC) | |
27765 | WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I), | |
27766 | & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I), | |
27767 | & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I), | |
27768 | & PHKK(5,I) | |
27769 | GOTO 2 | |
27770 | ENDIF | |
27771 | ||
27772 | IF ((MODE.EQ.3).OR.(MODE.EQ.4)) THEN | |
27773 | WRITE(LOUT,1002) | |
27774 | 1002 FORMAT(/,1X,'EVTPLO:',14X, | |
27775 | & ' content of COMMON /DTEVT1/,/DTEVT2/',/, | |
27776 | & 15X,' -----------------------------------',/,/, | |
27777 | & ' ST ID M1 M2 D1 D2 IDR IDXR', | |
27778 | & ' NOBAM IDCH M',/) | |
27779 | DO 3 I=1,NHKK | |
27780 | C IF ((ISTHKK(I).GT.10).OR.(ISTHKK(I).EQ.1)) THEN | |
27781 | KF = IDHKK(I) | |
27782 | IDCHK = KF/10000 | |
27783 | IF ((((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND. | |
27784 | & (KF.NE.80000)).OR.(IDHKK(I).EQ.99999)) KF = 92 | |
27785 | ||
27786 | CALL PYNAME(KF,CHAU) | |
27787 | ||
27788 | WRITE(LOUT,1003) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I), | |
27789 | & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I), | |
27790 | & IDRES(I),IDXRES(I),NOBAM(I),IDCH(I), | |
27791 | & PHKK(5,I),CHAU | |
27792 | 1003 FORMAT(I5,I5,I6,4I5,4I4,F8.4,2X,A) | |
27793 | C ENDIF | |
27794 | 3 CONTINUE | |
27795 | ENDIF | |
27796 | ||
27797 | IF (MODE.EQ.5) THEN | |
27798 | WRITE(LOUT,1004) | |
27799 | 1004 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTREJC/',/, | |
27800 | & 15X,' --------------------------',/) | |
27801 | WRITE(LOUT,1005) IRPT,IRHHA,IRRES,LOMRES,LOBRES,IREMC,IRFRAG, | |
27802 | & IRSEA,IRCRON | |
27803 | 1005 FORMAT(1X,'IRPT = ',I5,' IRHHA = ',I5,/, | |
27804 | & 1X,'IRRES = ',2I5,' LOMRES = ',I5,' LOBRES = ',I5,/, | |
27805 | & 1X,'IREMC = ',10I5,/, | |
27806 | & 1X,'IRFRAG = ',I5,' IRSEA = ',I5,' IRCRON = ',I5,/) | |
27807 | ENDIF | |
27808 | ||
27809 | 9999 RETURN | |
27810 | END | |
27811 | ||
27812 | *$ CREATE DT_EVTPUT.FOR | |
27813 | *COPY DT_EVTPUT | |
27814 | * | |
27815 | *===evtput=============================================================* | |
27816 | * | |
27817 | SUBROUTINE DT_EVTPUT(IST,ID,M1,M2,PX,PY,PZ,E,IDR,IDXR,IDC) | |
27818 | ||
27819 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27820 | SAVE | |
27821 | ||
27822 | PARAMETER ( LINP = 10 , | |
27823 | & LOUT = 6 , | |
27824 | & LDAT = 9 ) | |
27825 | ||
27826 | PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,TINY3=1.0D-3, | |
27827 | & TINY2=1.0D-2,SQTINF=1.0D+15,ZERO=0.0D0) | |
27828 | ||
27829 | * event history | |
27830 | ||
27831 | PARAMETER (NMXHKK=200000) | |
27832 | ||
27833 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
27834 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
27835 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
27836 | ||
27837 | * extended event history | |
27838 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
27839 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
27840 | & IHIST(2,NMXHKK) | |
27841 | ||
27842 | * Lorentz-parameters of the current interaction | |
27843 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
27844 | & UMO,PPCM,EPROJ,PPROJ | |
27845 | ||
27846 | * particle properties (BAMJET index convention) | |
27847 | CHARACTER*8 ANAME | |
27848 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
27849 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
27850 | ||
27851 | C IF (MODE.GT.100) THEN | |
27852 | C WRITE(LOUT,'(1X,A,I5,A,I5)') | |
27853 | C & 'EVTPUT: reset NHKK = ',NHKK,' to NHKK =',NHKK-MODE+100 | |
27854 | C NHKK = NHKK-MODE+100 | |
27855 | C RETURN | |
27856 | C ENDIF | |
27857 | MO1 = M1 | |
27858 | MO2 = M2 | |
27859 | NHKK = NHKK+1 | |
27860 | ||
27861 | IF (NHKK.GT.NMXHKK) THEN | |
27862 | WRITE(LOUT,1000) NHKK | |
27863 | 1000 FORMAT(1X,'EVTPUT: NHKK exeeds NMXHKK = ',I7, | |
27864 | & '! program execution stopped..') | |
27865 | STOP | |
27866 | ENDIF | |
27867 | IF (M1.LT.0) MO1 = NHKK+M1 | |
27868 | IF (M2.LT.0) MO2 = NHKK+M2 | |
27869 | ISTHKK(NHKK) = IST | |
27870 | IDHKK(NHKK) = ID | |
27871 | JMOHKK(1,NHKK) = MO1 | |
27872 | JMOHKK(2,NHKK) = MO2 | |
27873 | JDAHKK(1,NHKK) = 0 | |
27874 | JDAHKK(2,NHKK) = 0 | |
27875 | IDRES(NHKK) = IDR | |
27876 | IDXRES(NHKK) = IDXR | |
27877 | IDCH(NHKK) = IDC | |
27878 | ** here we need to do something.. | |
27879 | IF (ID.EQ.88888) THEN | |
27880 | IDMO1 = ABS(IDHKK(MO1)) | |
27881 | IDMO2 = ABS(IDHKK(MO2)) | |
27882 | IF ((IDMO1.LT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 3 | |
27883 | IF ((IDMO1.LT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 4 | |
27884 | IF ((IDMO1.GT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 5 | |
27885 | IF ((IDMO1.GT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 6 | |
27886 | ELSE | |
27887 | NOBAM(NHKK) = 0 | |
27888 | ENDIF | |
27889 | IDBAM(NHKK) = IDT_ICIHAD(ID) | |
27890 | IF (MO1.GT.0) THEN | |
27891 | IF (JDAHKK(1,MO1).NE.0) THEN | |
27892 | JDAHKK(2,MO1) = NHKK | |
27893 | ELSE | |
27894 | JDAHKK(1,MO1) = NHKK | |
27895 | ENDIF | |
27896 | ENDIF | |
27897 | IF (MO2.GT.0) THEN | |
27898 | IF (JDAHKK(1,MO2).NE.0) THEN | |
27899 | JDAHKK(2,MO2) = NHKK | |
27900 | ELSE | |
27901 | JDAHKK(1,MO2) = NHKK | |
27902 | ENDIF | |
27903 | ENDIF | |
27904 | C IF ((IDBAM(NHKK).GT.0).AND.(IDBAM(NHKK).NE.7)) THEN | |
27905 | C PTOT = SQRT(PX**2+PY**2+PZ**2) | |
27906 | C AM0 = SQRT(ABS( (E-PTOT)*(E+PTOT) )) | |
27907 | C AMRQ = AAM(IDBAM(NHKK)) | |
27908 | C AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ) | |
27909 | C IF ((ABS(AMDIF2).GT.TINY3).AND.(E.LT.SQTINF).AND. | |
27910 | C & (PTOT.GT.ZERO)) THEN | |
27911 | C DELTA = -AMDIF2/(2.0D0*(E+PTOT)) | |
27912 | CC DELTA = (AMRQ2-AM2)/(2.0D0*(E+PTOT)) | |
27913 | C E = E+DELTA | |
27914 | C PTOT1 = PTOT-DELTA | |
27915 | C PX = PX*PTOT1/PTOT | |
27916 | C PY = PY*PTOT1/PTOT | |
27917 | C PZ = PZ*PTOT1/PTOT | |
27918 | C ENDIF | |
27919 | C ENDIF | |
27920 | PHKK(1,NHKK) = PX | |
27921 | PHKK(2,NHKK) = PY | |
27922 | PHKK(3,NHKK) = PZ | |
27923 | PHKK(4,NHKK) = E | |
27924 | PTOT = SQRT( PX**2+PY**2+PZ**2 ) | |
27925 | IF ((IDHKK(NHKK).GE.22).AND.(IDHKK(NHKK).LE.24)) THEN | |
27926 | PHKK(5,NHKK) = PHKK(4,NHKK)**2-PTOT**2 | |
27927 | PHKK(5,NHKK) = SIGN(SQRT(ABS(PHKK(5,NHKK))),PHKK(5,NHKK)) | |
27928 | ELSE | |
27929 | PHKK(5,NHKK) = (PHKK(4,NHKK)-PTOT)*(PHKK(4,NHKK)+PTOT) | |
27930 | C IF ((PHKK(5,NHKK).LT.0.0D0).AND.(ABS(PHKK(5,NHKK)).GT.TINY4)) | |
27931 | C & WRITE(LOUT,'(1X,A,G10.3)') | |
27932 | C & 'EVTPUT: negative mass**2 ',PHKK(5,NHKK) | |
27933 | PHKK(5,NHKK) = SQRT(ABS(PHKK(5,NHKK))) | |
27934 | ENDIF | |
27935 | IDCHK = ID/10000 | |
27936 | IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.(ID.NE.80000)) THEN | |
27937 | * special treatment for chains: | |
27938 | * z coordinate of chain in Lab = pos. of target nucleon | |
27939 | * time of chain-creation in Lab = time of passage of projectile | |
27940 | * nucleus at pos. of taget nucleus | |
27941 | C VHKK(1,NHKK) = 0.5D0*(VHKK(1,MO1)+VHKK(1,MO2)) | |
27942 | C VHKK(2,NHKK) = 0.5D0*(VHKK(2,MO1)+VHKK(2,MO2)) | |
27943 | VHKK(1,NHKK) = VHKK(1,MO2) | |
27944 | VHKK(2,NHKK) = VHKK(2,MO2) | |
27945 | VHKK(3,NHKK) = VHKK(3,MO2) | |
27946 | VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB | |
27947 | C WHKK(1,NHKK) = 0.5D0*(WHKK(1,MO1)+WHKK(1,MO2)) | |
27948 | C WHKK(2,NHKK) = 0.5D0*(WHKK(2,MO1)+WHKK(2,MO2)) | |
27949 | WHKK(1,NHKK) = WHKK(1,MO1) | |
27950 | WHKK(2,NHKK) = WHKK(2,MO1) | |
27951 | WHKK(3,NHKK) = WHKK(3,MO1) | |
27952 | WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB | |
27953 | ELSE | |
27954 | IF (MO1.GT.0) THEN | |
27955 | DO 1 I=1,4 | |
27956 | VHKK(I,NHKK) = VHKK(I,MO1) | |
27957 | WHKK(I,NHKK) = WHKK(I,MO1) | |
27958 | 1 CONTINUE | |
27959 | ELSE | |
27960 | DO 2 I=1,4 | |
27961 | VHKK(I,NHKK) = ZERO | |
27962 | WHKK(I,NHKK) = ZERO | |
27963 | 2 CONTINUE | |
27964 | ENDIF | |
27965 | ENDIF | |
27966 | ||
27967 | RETURN | |
27968 | END | |
27969 | ||
27970 | *$ CREATE DT_CHASTA.FOR | |
27971 | *COPY DT_CHASTA | |
27972 | * | |
27973 | *===chasta=============================================================* | |
27974 | * | |
27975 | SUBROUTINE DT_CHASTA(MODE) | |
27976 | ||
27977 | ************************************************************************ | |
27978 | * This subroutine performs CHAin STAtistics and checks sequence of * | |
27979 | * partons in dtevt1 and sorts them with projectile partons coming * | |
27980 | * first if necessary. * | |
27981 | * * | |
27982 | * This version dated 8.5.00 is written by S. Roesler. * | |
27983 | ************************************************************************ | |
27984 | ||
27985 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27986 | SAVE | |
27987 | ||
27988 | PARAMETER ( LINP = 10 , | |
27989 | & LOUT = 6 , | |
27990 | & LDAT = 9 ) | |
27991 | ||
27992 | CHARACTER*5 CCHTYP | |
27993 | ||
27994 | * event history | |
27995 | ||
27996 | PARAMETER (NMXHKK=200000) | |
27997 | ||
27998 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
27999 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
28000 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
28001 | ||
28002 | * extended event history | |
28003 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
28004 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
28005 | & IHIST(2,NMXHKK) | |
28006 | ||
28007 | * pointer to chains in hkkevt common (used by qq-breaking mechanisms) | |
28008 | PARAMETER (MAXCHN=10000) | |
28009 | COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN | |
28010 | ||
28011 | DIMENSION ICHCFG(10,10,9,2),ICHTYP(5,5), | |
28012 | & CCHTYP(9),ICHSTA(10),ITOT(10) | |
28013 | DATA ICHCFG /1800*0/ | |
28014 | DATA (ICHTYP(1,K),K=1,5) / 0, 1, 3, 0, 0/ | |
28015 | DATA (ICHTYP(2,K),K=1,5) / 2, 0, 0, 5, 0/ | |
28016 | DATA (ICHTYP(3,K),K=1,5) / 4, 0, 0, 7, 0/ | |
28017 | DATA (ICHTYP(4,K),K=1,5) / 0, 6, 8, 0, 0/ | |
28018 | DATA (ICHTYP(5,K),K=1,5) / 0, 0, 0, 0, 9/ | |
28019 | DATA ICHSTA / 21, 22, 31, 32, 41, 42, 51, 52, 61, 62/ | |
28020 | DATA CCHTYP / ' q aq','aq q ',' q d ',' d q ','aq ad', | |
28021 | & 'ad aq',' d ad','ad d ',' g g '/ | |
28022 | * | |
28023 | * initialization | |
28024 | * | |
28025 | IF (MODE.EQ.-1) THEN | |
28026 | NCHAIN = 0 | |
28027 | * | |
28028 | * loop over DTEVT1 and analyse chain configurations | |
28029 | * | |
28030 | ELSEIF (MODE.EQ.0) THEN | |
28031 | DO 21 IDX=NPOINT(3),NHKK | |
28032 | IDCHK = IDHKK(IDX)/10000 | |
28033 | IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND. | |
28034 | & (IDHKK(IDX).NE.80000).AND. | |
28035 | & (ISTHKK(IDX).NE.2).AND.(IDRES(IDX).EQ.0)) THEN | |
28036 | IF (JMOHKK(1,IDX).GT.JMOHKK(2,IDX)) THEN | |
28037 | WRITE(LOUT,*) ' CHASTA: JMOHKK(1,x) > JMOHKK(2,x) ', | |
28038 | & ' at entry ',IDX | |
28039 | GOTO 21 | |
28040 | ENDIF | |
28041 | * | |
28042 | IST1 = ABS(ISTHKK(JMOHKK(1,IDX))) | |
28043 | IST2 = ABS(ISTHKK(JMOHKK(2,IDX))) | |
28044 | IMO1 = IST1/10 | |
28045 | IMO1 = IST1-10*IMO1 | |
28046 | IMO2 = IST2/10 | |
28047 | IMO2 = IST2-10*IMO2 | |
28048 | * swop parton entries if necessary since we need projectile partons | |
28049 | * to come first in the common | |
28050 | IF (IMO1.GT.IMO2) THEN | |
28051 | NPTN = JMOHKK(2,IDX)-JMOHKK(1,IDX)+1 | |
28052 | DO 22 K=1,NPTN/2 | |
28053 | I0 = JMOHKK(1,IDX)-1+K | |
28054 | I1 = JMOHKK(2,IDX)+1-K | |
28055 | ITMP = ISTHKK(I0) | |
28056 | ISTHKK(I0) = ISTHKK(I1) | |
28057 | ISTHKK(I1) = ITMP | |
28058 | ITMP = IDHKK(I0) | |
28059 | IDHKK(I0) = IDHKK(I1) | |
28060 | IDHKK(I1) = ITMP | |
28061 | IF (JDAHKK(1,JMOHKK(1,I0)).EQ.I0) | |
28062 | & JDAHKK(1,JMOHKK(1,I0)) = I1 | |
28063 | IF (JDAHKK(2,JMOHKK(1,I0)).EQ.I0) | |
28064 | & JDAHKK(2,JMOHKK(1,I0)) = I1 | |
28065 | IF (JDAHKK(1,JMOHKK(2,I0)).EQ.I0) | |
28066 | & JDAHKK(1,JMOHKK(2,I0)) = I1 | |
28067 | IF (JDAHKK(2,JMOHKK(2,I0)).EQ.I0) | |
28068 | & JDAHKK(2,JMOHKK(2,I0)) = I1 | |
28069 | IF (JDAHKK(1,JMOHKK(1,I1)).EQ.I1) | |
28070 | & JDAHKK(1,JMOHKK(1,I1)) = I0 | |
28071 | IF (JDAHKK(2,JMOHKK(1,I1)).EQ.I1) | |
28072 | & JDAHKK(2,JMOHKK(1,I1)) = I0 | |
28073 | IF (JDAHKK(1,JMOHKK(2,I1)).EQ.I1) | |
28074 | & JDAHKK(1,JMOHKK(2,I1)) = I0 | |
28075 | IF (JDAHKK(2,JMOHKK(2,I1)).EQ.I1) | |
28076 | & JDAHKK(2,JMOHKK(2,I1)) = I0 | |
28077 | ITMP = JMOHKK(1,I0) | |
28078 | JMOHKK(1,I0) = JMOHKK(1,I1) | |
28079 | JMOHKK(1,I1) = ITMP | |
28080 | ITMP = JMOHKK(2,I0) | |
28081 | JMOHKK(2,I0) = JMOHKK(2,I1) | |
28082 | JMOHKK(2,I1) = ITMP | |
28083 | ITMP = JDAHKK(1,I0) | |
28084 | JDAHKK(1,I0) = JDAHKK(1,I1) | |
28085 | JDAHKK(1,I1) = ITMP | |
28086 | ITMP = JDAHKK(2,I0) | |
28087 | JDAHKK(2,I0) = JDAHKK(2,I1) | |
28088 | JDAHKK(2,I1) = ITMP | |
28089 | DO 23 J=1,4 | |
28090 | RTMP1 = PHKK(J,I0) | |
28091 | RTMP2 = VHKK(J,I0) | |
28092 | RTMP3 = WHKK(J,I0) | |
28093 | PHKK(J,I0) = PHKK(J,I1) | |
28094 | VHKK(J,I0) = VHKK(J,I1) | |
28095 | WHKK(J,I0) = WHKK(J,I1) | |
28096 | PHKK(J,I1) = RTMP1 | |
28097 | VHKK(J,I1) = RTMP2 | |
28098 | WHKK(J,I1) = RTMP3 | |
28099 | 23 CONTINUE | |
28100 | RTMP1 = PHKK(5,I0) | |
28101 | PHKK(5,I0) = PHKK(5,I1) | |
28102 | PHKK(5,I1) = RTMP1 | |
28103 | ITMP = IDRES(I0) | |
28104 | IDRES(I0) = IDRES(I1) | |
28105 | IDRES(I1) = ITMP | |
28106 | ITMP = IDXRES(I0) | |
28107 | IDXRES(I0) = IDXRES(I1) | |
28108 | IDXRES(I1) = ITMP | |
28109 | ITMP = NOBAM(I0) | |
28110 | NOBAM(I0) = NOBAM(I1) | |
28111 | NOBAM(I1) = ITMP | |
28112 | ITMP = IDBAM(I0) | |
28113 | IDBAM(I0) = IDBAM(I1) | |
28114 | IDBAM(I1) = ITMP | |
28115 | ITMP = IDCH(I0) | |
28116 | IDCH(I0) = IDCH(I1) | |
28117 | IDCH(I1) = ITMP | |
28118 | ITMP = IHIST(1,I0) | |
28119 | IHIST(1,I0) = IHIST(1,I1) | |
28120 | IHIST(1,I1) = ITMP | |
28121 | ITMP = IHIST(2,I0) | |
28122 | IHIST(2,I0) = IHIST(2,I1) | |
28123 | IHIST(2,I1) = ITMP | |
28124 | 22 CONTINUE | |
28125 | ENDIF | |
28126 | IST1 = ABS(ISTHKK(JMOHKK(1,IDX))) | |
28127 | IST2 = ABS(ISTHKK(JMOHKK(2,IDX))) | |
28128 | * | |
28129 | * parton 1 (projectile side) | |
28130 | IF (IST1.EQ.21) THEN | |
28131 | IDX1 = 1 | |
28132 | ELSEIF (IST1.EQ.22) THEN | |
28133 | IDX1 = 2 | |
28134 | ELSEIF (IST1.EQ.31) THEN | |
28135 | IDX1 = 3 | |
28136 | ELSEIF (IST1.EQ.32) THEN | |
28137 | IDX1 = 4 | |
28138 | ELSEIF (IST1.EQ.41) THEN | |
28139 | IDX1 = 5 | |
28140 | ELSEIF (IST1.EQ.42) THEN | |
28141 | IDX1 = 6 | |
28142 | ELSEIF (IST1.EQ.51) THEN | |
28143 | IDX1 = 7 | |
28144 | ELSEIF (IST1.EQ.52) THEN | |
28145 | IDX1 = 8 | |
28146 | ELSEIF (IST1.EQ.61) THEN | |
28147 | IDX1 = 9 | |
28148 | ELSEIF (IST1.EQ.62) THEN | |
28149 | IDX1 = 10 | |
28150 | ELSE | |
28151 | c WRITE(LOUT,*) | |
28152 | c & ' CHASTA: unknown parton status flag (', | |
28153 | c & IST1,') at entry ',JMOHKK(1,IDX),'(',IDX,')' | |
28154 | GOTO 21 | |
28155 | ENDIF | |
28156 | ID = IDHKK(JMOHKK(1,IDX)) | |
28157 | IF (ABS(ID).LE.4) THEN | |
28158 | IF (ID.GT.0) THEN | |
28159 | ITYP1 = 1 | |
28160 | ELSE | |
28161 | ITYP1 = 2 | |
28162 | ENDIF | |
28163 | ELSEIF (ABS(ID).GE.1000) THEN | |
28164 | IF (ID.GT.0) THEN | |
28165 | ITYP1 = 3 | |
28166 | ELSE | |
28167 | ITYP1 = 4 | |
28168 | ENDIF | |
28169 | ELSEIF (ID.EQ.21) THEN | |
28170 | ITYP1 = 5 | |
28171 | ELSE | |
28172 | WRITE(LOUT,*) | |
28173 | & ' CHASTA: inconsistent parton identity (', | |
28174 | & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')' | |
28175 | GOTO 21 | |
28176 | ENDIF | |
28177 | * | |
28178 | * parton 2 (target side) | |
28179 | IF (IST2.EQ.21) THEN | |
28180 | IDX2 = 1 | |
28181 | ELSEIF (IST2.EQ.22) THEN | |
28182 | IDX2 = 2 | |
28183 | ELSEIF (IST2.EQ.31) THEN | |
28184 | IDX2 = 3 | |
28185 | ELSEIF (IST2.EQ.32) THEN | |
28186 | IDX2 = 4 | |
28187 | ELSEIF (IST2.EQ.41) THEN | |
28188 | IDX2 = 5 | |
28189 | ELSEIF (IST2.EQ.42) THEN | |
28190 | IDX2 = 6 | |
28191 | ELSEIF (IST2.EQ.51) THEN | |
28192 | IDX2 = 7 | |
28193 | ELSEIF (IST2.EQ.52) THEN | |
28194 | IDX2 = 8 | |
28195 | ELSEIF (IST2.EQ.61) THEN | |
28196 | IDX2 = 9 | |
28197 | ELSEIF (IST2.EQ.62) THEN | |
28198 | IDX2 = 10 | |
28199 | ELSE | |
28200 | c WRITE(LOUT,*) | |
28201 | c & ' CHASTA: unknown parton status flag (', | |
28202 | c & IST2,') at entry ',JMOHKK(2,IDX),'(',IDX,')' | |
28203 | GOTO 21 | |
28204 | ENDIF | |
28205 | ID = IDHKK(JMOHKK(2,IDX)) | |
28206 | IF (ABS(ID).LE.4) THEN | |
28207 | IF (ID.GT.0) THEN | |
28208 | ITYP2 = 1 | |
28209 | ELSE | |
28210 | ITYP2 = 2 | |
28211 | ENDIF | |
28212 | ELSEIF (ABS(ID).GE.1000) THEN | |
28213 | IF (ID.GT.0) THEN | |
28214 | ITYP2 = 3 | |
28215 | ELSE | |
28216 | ITYP2 = 4 | |
28217 | ENDIF | |
28218 | ELSEIF (ID.EQ.21) THEN | |
28219 | ITYP2 = 5 | |
28220 | ELSE | |
28221 | WRITE(LOUT,*) | |
28222 | & ' CHASTA: inconsistent parton identity (', | |
28223 | & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')' | |
28224 | GOTO 21 | |
28225 | ENDIF | |
28226 | * | |
28227 | * fill counter | |
28228 | ITYPE = ICHTYP(ITYP1,ITYP2) | |
28229 | IF (ITYPE.NE.0) THEN | |
28230 | ICHCFG(IDX1,IDX2,ITYPE,1) =ICHCFG(IDX1,IDX2,ITYPE,1)+1 | |
28231 | NGLUON = JMOHKK(2,IDX)-JMOHKK(1,IDX)-1 | |
28232 | ICHCFG(IDX1,IDX2,ITYPE,2) = | |
28233 | & ICHCFG(IDX1,IDX2,ITYPE,2)+NGLUON | |
28234 | ||
28235 | NCHAIN = NCHAIN+1 | |
28236 | IF (NCHAIN.GT.MAXCHN) THEN | |
28237 | WRITE(LOUT,*) ' CHASTA: NCHAIN > MAXCHN ! ', | |
28238 | & NCHAIN,MAXCHN | |
28239 | STOP | |
28240 | ENDIF | |
28241 | IDXCHN(1,NCHAIN) = IDX | |
28242 | IDXCHN(2,NCHAIN) = ITYPE | |
28243 | ELSE | |
28244 | WRITE(LOUT,*) | |
28245 | & ' CHASTA: inconsistent chain at entry ',IDX | |
28246 | GOTO 21 | |
28247 | ENDIF | |
28248 | ENDIF | |
28249 | 21 CONTINUE | |
28250 | * | |
28251 | * write statistics to output unit | |
28252 | * | |
28253 | ELSEIF (MODE.EQ.1) THEN | |
28254 | WRITE(LOUT,'(/,A)') ' CHASTA: generated chain configurations' | |
28255 | DO 31 I=1,10 | |
28256 | WRITE(LOUT,'(/,2A)') | |
28257 | & ' -----------------------------------------', | |
28258 | & '------------------------------------' | |
28259 | WRITE(LOUT,'(2A)') | |
28260 | & ' p\\t 21 22 31 32 41', | |
28261 | & ' 42 51 52 61 62' | |
28262 | WRITE(LOUT,'(2A)') | |
28263 | & ' -----------------------------------------', | |
28264 | & '------------------------------------' | |
28265 | DO 32 J=1,10 | |
28266 | ITOT(J) = 0 | |
28267 | DO 33 K=1,9 | |
28268 | ITOT(J) = ITOT(J)+ICHCFG(I,J,K,1) | |
28269 | 33 CONTINUE | |
28270 | 32 CONTINUE | |
28271 | WRITE(LOUT,'(1X,I2,5X,10I7,/)') ICHSTA(I),(ITOT(J),J=1,10) | |
28272 | DO 34 K=1,9 | |
28273 | ISUM = 0 | |
28274 | DO 35 J=1,10 | |
28275 | ISUM = ISUM+ICHCFG(I,J,K,1) | |
28276 | 35 CONTINUE | |
28277 | IF (ISUM.GT.0) | |
28278 | & WRITE(LOUT,'(1X,A5,2X,10I7)') | |
28279 | & CCHTYP(K),(ICHCFG(I,J,K,1),J=1,10) | |
28280 | 34 CONTINUE | |
28281 | C WRITE(LOUT,'(2A)') | |
28282 | C & ' -----------------------------------------', | |
28283 | C & '-------------------------------' | |
28284 | 31 CONTINUE | |
28285 | * | |
28286 | ELSE | |
28287 | WRITE(LOUT,*) ' CHASTA: MODE ',MODE,' not supported !' | |
28288 | STOP | |
28289 | ENDIF | |
28290 | ||
28291 | RETURN | |
28292 | END | |
28293 | *$ CREATE PHO_PHIST.FOR | |
28294 | *COPY PHO_PHIST | |
28295 | * | |
28296 | *===pohist=============================================================* | |
28297 | * | |
28298 | SUBROUTINE PHO_PHIST(IMODE,WEIGHT) | |
28299 | ||
28300 | IMPLICIT DOUBLE PRECISION (A-H,O-X,Z) | |
28301 | SAVE | |
28302 | ||
28303 | PARAMETER ( LINP = 10 , | |
28304 | & LOUT = 6 , | |
28305 | & LDAT = 9 ) | |
28306 | ||
28307 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
28308 | ||
28309 | * Glauber formalism: cross sections | |
28310 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
28311 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
28312 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
28313 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
28314 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
28315 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
28316 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
28317 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
28318 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
28319 | & BSLOPE,NEBINI,NQBINI | |
28320 | ||
28321 | ILAB = 0 | |
28322 | IF (IMODE.EQ.10) THEN | |
28323 | IMODE = 1 | |
28324 | ILAB = 1 | |
28325 | ENDIF | |
28326 | IF (ABS(IMODE).LT.1000) THEN | |
28327 | * PHOJET-statistics | |
28328 | C CALL POHISX(IMODE,WEIGHT) | |
28329 | IF (IMODE.EQ.-1) THEN | |
28330 | MODE = 1 | |
28331 | XSTOT(1,1,1) = WEIGHT | |
28332 | ENDIF | |
28333 | IF (IMODE.EQ. 1) MODE = 2 | |
28334 | IF (IMODE.EQ.-2) MODE = 3 | |
28335 | IF (MODE.EQ.2) CALL DT_SWPPHO(ILAB) | |
28336 | C IF (MODE.EQ.3) WRITE(LOUT,*) | |
28337 | C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization' | |
28338 | CALL DT_HISTOG(MODE) | |
28339 | CALL DT_USRHIS(MODE) | |
28340 | ELSE | |
28341 | * DTUNUC-statistics | |
28342 | MODE = IMODE/1000 | |
28343 | C IF (MODE.EQ.3) WRITE(LOUT,*) | |
28344 | C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization' | |
28345 | CALL DT_HISTOG(MODE) | |
28346 | CALL DT_USRHIS(MODE) | |
28347 | ENDIF | |
28348 | ||
28349 | RETURN | |
28350 | END | |
28351 | ||
28352 | *$ CREATE DT_SWPPHO.FOR | |
28353 | *COPY DT_SWPPHO | |
28354 | * | |
28355 | *===swppho=============================================================* | |
28356 | * | |
28357 | SUBROUTINE DT_SWPPHO(ILAB) | |
28358 | ||
28359 | IMPLICIT DOUBLE PRECISION (A-H,O-X,Z) | |
28360 | SAVE | |
28361 | ||
28362 | PARAMETER ( LINP = 10 , | |
28363 | & LOUT = 6 , | |
28364 | & LDAT = 9 ) | |
28365 | ||
28366 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14) | |
28367 | ||
28368 | LOGICAL LSTART | |
28369 | ||
28370 | * event history | |
28371 | ||
28372 | PARAMETER (NMXHKK=200000) | |
28373 | ||
28374 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
28375 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
28376 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
28377 | ||
28378 | * extended event history | |
28379 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
28380 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
28381 | & IHIST(2,NMXHKK) | |
28382 | ||
28383 | * flags for input different options | |
28384 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
28385 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
28386 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
28387 | ||
28388 | * properties of photon/lepton projectiles | |
28389 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC | |
28390 | ||
28391 | **PHOJET105a | |
28392 | C PARAMETER (NMXHEP=2000) | |
28393 | C COMMON/HEPEVS/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP), | |
28394 | C &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP) | |
28395 | C COMMON /GLOCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2) | |
28396 | C COMMON /PLASAV/ PLAB | |
28397 | **PHOJET110 | |
28398 | C standard particle data interface | |
28399 | INTEGER NMXHEP | |
28400 | ||
28401 | PARAMETER (NMXHEP=4000) | |
28402 | ||
28403 | INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP | |
28404 | DOUBLE PRECISION PHEP,VHEP | |
28405 | COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP), | |
28406 | & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP), | |
28407 | & VHEP(4,NMXHEP) | |
28408 | C extension to standard particle data interface (PHOJET specific) | |
28409 | INTEGER IMPART,IPHIST,ICOLOR | |
28410 | COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP) | |
28411 | ||
28412 | C global event kinematics and particle IDs | |
28413 | INTEGER IFPAP,IFPAB | |
28414 | DOUBLE PRECISION ECM,PCM,PMASS,PVIRT | |
28415 | COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2) | |
28416 | ** | |
28417 | DATA ICOUNT/0/ | |
28418 | ||
28419 | DATA LSTART /.TRUE./ | |
28420 | ||
28421 | C IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0).AND.LSTART) THEN | |
28422 | IF ((IFRAME.EQ.1).AND.LSTART) THEN | |
28423 | UMO = ECM | |
28424 | ELA = ZERO | |
28425 | PLA = ZERO | |
28426 | IDP = IDT_ICIHAD(IFPAP(1)) | |
28427 | IDT = IDT_ICIHAD(IFPAP(2)) | |
28428 | VIRT = PVIRT(1) | |
28429 | CALL DT_LTINI(IDP,IDT,ELA,PLA,UMO,0) | |
28430 | PLAB = PLA | |
28431 | LSTART = .FALSE. | |
28432 | ENDIF | |
28433 | ||
28434 | NHKK = 0 | |
28435 | ICOUNT = ICOUNT+1 | |
28436 | C NEVHKK = NEVHEP | |
28437 | NEVHKK = ICOUNT | |
28438 | IF (MOD(ICOUNT,500).EQ.0) WRITE(LOUT,*)' SWPPHO: event # ',ICOUNT | |
28439 | DO 1 I=3,NHEP | |
28440 | IF (ISTHEP(I).EQ.1) THEN | |
28441 | NHKK = NHKK+1 | |
28442 | ISTHKK(NHKK) = 1 | |
28443 | IDHKK(NHKK) = IDHEP(I) | |
28444 | JMOHKK(1,NHKK) = 0 | |
28445 | JMOHKK(2,NHKK) = 0 | |
28446 | JDAHKK(1,NHKK) = 0 | |
28447 | JDAHKK(2,NHKK) = 0 | |
28448 | DO 2 K=1,4 | |
28449 | PHKK(K,NHKK) = PHEP(K,I) | |
28450 | VHKK(K,NHKK) = ZERO | |
28451 | WHKK(K,NHKK) = ZERO | |
28452 | 2 CONTINUE | |
28453 | IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0)) | |
28454 | & CALL DT_LTNUC(PHEP(3,I),PHEP(4,I), | |
28455 | & PHKK(3,NHKK),PHKK(4,NHKK),-3) | |
28456 | PHKK(5,NHKK) = PHEP(5,I) | |
28457 | IDRES(NHKK) = 0 | |
28458 | IDXRES(NHKK) = 0 | |
28459 | NOBAM(NHKK) = 0 | |
28460 | IDBAM(NHKK) = IDT_ICIHAD(IDHEP(I)) | |
28461 | IDCH(NHKK) = 0 | |
28462 | ENDIF | |
28463 | 1 CONTINUE | |
28464 | ||
28465 | RETURN | |
28466 | END | |
28467 | ||
28468 | *$ CREATE DT_HISTOG.FOR | |
28469 | *COPY DT_HISTOG | |
28470 | * | |
28471 | *===histog=============================================================* | |
28472 | * | |
28473 | SUBROUTINE DT_HISTOG(MODE) | |
28474 | ||
28475 | ************************************************************************ | |
28476 | * This version dated 25.03.96 is written by S. Roesler * | |
28477 | ************************************************************************ | |
28478 | ||
28479 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
28480 | SAVE | |
28481 | ||
28482 | PARAMETER ( LINP = 10 , | |
28483 | & LOUT = 6 , | |
28484 | & LDAT = 9 ) | |
28485 | ||
28486 | LOGICAL LFSP,LRNL | |
28487 | ||
28488 | * event history | |
28489 | ||
28490 | PARAMETER (NMXHKK=200000) | |
28491 | ||
28492 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
28493 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
28494 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
28495 | ||
28496 | * extended event history | |
28497 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
28498 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
28499 | & IHIST(2,NMXHKK) | |
28500 | ||
28501 | * event flag used for histograms | |
28502 | COMMON /DTNORM/ ICEVT,IEVHKK | |
28503 | ||
28504 | * flags for activated histograms | |
28505 | COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL | |
28506 | ||
28507 | IEVHKK = NEVHKK | |
28508 | GOTO (1,2,3) MODE | |
28509 | ||
28510 | *------------------------------------------------------------------ | |
28511 | * initialization | |
28512 | 1 CONTINUE | |
28513 | ICEVT = 0 | |
28514 | IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,1) | |
28515 | IF (IHISPP(2).EQ.1) CALL DT_HIMULT(1) | |
28516 | ||
28517 | RETURN | |
28518 | *------------------------------------------------------------------ | |
28519 | * filling of histogram with event-record | |
28520 | 2 CONTINUE | |
28521 | ICEVT = ICEVT+1 | |
28522 | ||
28523 | DO 20 I=1,NHKK | |
28524 | CALL DT_SWPFSP(I,LFSP,LRNL) | |
28525 | IF (LFSP) THEN | |
28526 | IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,2) | |
28527 | IF (IHISPP(2).EQ.1) CALL DT_HIMULT(2) | |
28528 | ENDIF | |
28529 | IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,5) | |
28530 | 20 CONTINUE | |
28531 | IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,4) | |
28532 | ||
28533 | RETURN | |
28534 | *------------------------------------------------------------------ | |
28535 | * output | |
28536 | 3 CONTINUE | |
28537 | IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,3) | |
28538 | IF (IHISPP(2).EQ.1) CALL DT_HIMULT(3) | |
28539 | ||
28540 | RETURN | |
28541 | END | |
28542 | ||
28543 | *$ CREATE DT_SWPFSP.FOR | |
28544 | *COPY DT_SWPFSP | |
28545 | * | |
28546 | *===swpfsp=============================================================* | |
28547 | * | |
28548 | SUBROUTINE DT_SWPFSP(IDX,LFSP,LRNL) | |
28549 | ||
28550 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
28551 | SAVE | |
28552 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14) | |
28553 | PARAMETER (TWOPI=6.283185307179586476925286766559D+00, | |
28554 | & PI =TWOPI/TWO, | |
28555 | & BOG =TWOPI/360.0D0) | |
28556 | ||
28557 | * event history | |
28558 | ||
28559 | PARAMETER (NMXHKK=200000) | |
28560 | ||
28561 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
28562 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
28563 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
28564 | ||
28565 | * extended event history | |
28566 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
28567 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
28568 | & IHIST(2,NMXHKK) | |
28569 | ||
28570 | * particle properties (BAMJET index convention) | |
28571 | CHARACTER*8 ANAME | |
28572 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
28573 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
28574 | ||
28575 | * Lorentz-parameters of the current interaction | |
28576 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
28577 | & UMO,PPCM,EPROJ,PPROJ | |
28578 | ||
28579 | * flags for input different options | |
28580 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
28581 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
28582 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
28583 | ||
28584 | * INCLUDE '(DIMPAR)' | |
28585 | * Taken from FLUKA | |
28586 | PARAMETER ( MXXRGN =20000 ) | |
28587 | PARAMETER ( MXXMDF = 710 ) | |
28588 | PARAMETER ( MXXMDE = 702 ) | |
28589 | PARAMETER ( MFSTCK =40000 ) | |
28590 | PARAMETER ( MESTCK = 100 ) | |
28591 | PARAMETER ( MOSTCK = 2000 ) | |
28592 | PARAMETER ( MXPRSN = 100 ) | |
28593 | PARAMETER ( MXPDPM = 800 ) | |
28594 | PARAMETER ( MXPSCS =30000 ) | |
28595 | PARAMETER ( MXGLWN = 300 ) | |
28596 | PARAMETER ( MXOUTU = 50 ) | |
28597 | PARAMETER ( NALLWP = 64 ) | |
28598 | PARAMETER ( NELEMX = 80 ) | |
28599 | PARAMETER ( MPDPDX = 18 ) | |
28600 | PARAMETER ( MXHTTR = 260 ) | |
28601 | PARAMETER ( MXSEAX = 20 ) | |
28602 | PARAMETER ( MXHTNC = MXSEAX + 1 ) | |
28603 | PARAMETER ( ICOMAX = 2400 ) | |
28604 | PARAMETER ( ICHMAX = ICOMAX + MXXMDF ) | |
28605 | PARAMETER ( NSTBIS = 304 ) | |
28606 | PARAMETER ( NQSTIS = 46 ) | |
28607 | PARAMETER ( NTSTIS = NSTBIS + NQSTIS ) | |
28608 | PARAMETER ( MXPABL = 120 ) | |
28609 | PARAMETER ( IDMAXP = 450 ) | |
28610 | PARAMETER ( IDMXDC = 2000 ) | |
28611 | PARAMETER ( MXMCIN = 410 ) | |
28612 | PARAMETER ( IHYPMX = 4 ) | |
28613 | PARAMETER ( MKBMX1 = 11 ) | |
28614 | PARAMETER ( MKBMX2 = 11 ) | |
28615 | PARAMETER ( MXIRRD = 2500 ) | |
28616 | PARAMETER ( MXTRDC = 1500 ) | |
28617 | PARAMETER ( NKTL = 17 ) | |
28618 | PARAMETER ( NBLNMX = 40000000 ) | |
28619 | ||
28620 | * INCLUDE '(PAREVT)' | |
28621 | * Taken from FLUKA | |
28622 | PARAMETER ( FRDIFF = 0.2D+00 ) | |
28623 | PARAMETER ( ETHSEA = 1.0D+00 ) | |
28624 | * | |
28625 | LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX, | |
28626 | & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI, | |
28627 | & LNUCRI, LPEANU, LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR, | |
28628 | & LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN | |
28629 | COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC, | |
28630 | & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY, | |
28631 | & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV, | |
28632 | & LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LPHDRC, | |
28633 | & LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR, LRVKIN, | |
28634 | & LVP2XX, LV2XNW, LNWV2X, LEVFIN | |
28635 | ||
28636 | * temporary storage for one final state particle | |
28637 | LOGICAL LFRAG,LGREY,LBLACK | |
28638 | COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN, | |
28639 | & SINTHE,COSTHE,THETA,THECMS, | |
28640 | & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF, | |
28641 | & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF, | |
28642 | & LFRAG,LGREY,LBLACK | |
28643 | ||
28644 | LOGICAL LFSP,LRNL | |
28645 | ||
28646 | LFSP = .FALSE. | |
28647 | LRNL = .FALSE. | |
28648 | ISTRNL = 1000 | |
28649 | MULDEF = 1 | |
28650 | IF (LEVPRT) ISTRNL = 1001 | |
28651 | ||
28652 | IF (ABS(ISTHKK(IDX)).EQ.1) THEN | |
28653 | IST = ISTHKK(IDX) | |
28654 | IDPDG = IDHKK(IDX) | |
28655 | LFRAG = .FALSE. | |
28656 | IF (IDHKK(IDX).LT.80000) THEN | |
28657 | IDBJT = IDBAM(IDX) | |
28658 | IBARY = IIBAR(IDBJT) | |
28659 | ICHAR = IICH(IDBJT) | |
28660 | AMASS = AAM(IDBJT) | |
28661 | ELSEIF (IDHKK(IDX).EQ.80000) THEN | |
28662 | IDBJT = 0 | |
28663 | IBARY = IDRES(IDX) | |
28664 | ICHAR = IDXRES(IDX) | |
28665 | AMASS = PHKK(5,IDX) | |
28666 | INUT = IBARY-ICHAR | |
28667 | IF ((ICHAR.EQ.1).AND.(INUT.EQ.1)) IDBJT = 116 | |
28668 | IF ((ICHAR.EQ.1).AND.(INUT.EQ.2)) IDBJT = 117 | |
28669 | IF ((ICHAR.EQ.2).AND.(INUT.EQ.1)) IDBJT = 118 | |
28670 | IF ((ICHAR.EQ.2).AND.(INUT.EQ.2)) IDBJT = 119 | |
28671 | IF (IDBJT.EQ.0) LFRAG = .TRUE. | |
28672 | ELSE | |
28673 | GOTO 9999 | |
28674 | ENDIF | |
28675 | PE = PHKK(4,IDX) | |
28676 | PX = PHKK(1,IDX) | |
28677 | PY = PHKK(2,IDX) | |
28678 | PZ = PHKK(3,IDX) | |
28679 | PT2 = PX**2+PY**2 | |
28680 | PT = SQRT(PT2) | |
28681 | PTOT = SQRT(PT2+PZ**2) | |
28682 | SINTHE = PT/MAX(PTOT,TINY14) | |
28683 | COSTHE = PZ/MAX(PTOT,TINY14) | |
28684 | IF (COSTHE.GT.ONE) THEN | |
28685 | THETA = ZERO | |
28686 | ELSEIF (COSTHE.LT.-ONE) THEN | |
28687 | THETA = TWOPI/2.0D0 | |
28688 | ELSE | |
28689 | THETA = ACOS(COSTHE) | |
28690 | ENDIF | |
28691 | EKIN = PE-AMASS | |
28692 | **sr 15.4.96 new E_t-definition | |
28693 | IF (IBARY.GT.0) THEN | |
28694 | ET = EKIN*SINTHE | |
28695 | ELSEIF (IBARY.LT.0) THEN | |
28696 | ET = (EKIN+TWO*AMASS)*SINTHE | |
28697 | ELSE | |
28698 | ET = PE*SINTHE | |
28699 | ENDIF | |
28700 | ** | |
28701 | XLAB = PZ/MAX(PPROJ,TINY14) | |
28702 | C XLAB = PE/MAX(EPROJ,TINY14) | |
28703 | BETA = SQRT(ABS( (ONE-AMASS/MAX(PE,TINY14)) | |
28704 | & *(ONE+AMASS/MAX(PE,TINY14)) )) | |
28705 | PPLUS = PE+PZ | |
28706 | PMINUS = PE-PZ | |
28707 | IF (PMINUS.GT.TINY14) THEN | |
28708 | YY = 0.5D0*LOG(ABS(PPLUS/PMINUS)) | |
28709 | ELSE | |
28710 | YY = 100.0D0 | |
28711 | ENDIF | |
28712 | IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN | |
28713 | ETA = -LOG(TAN(THETA/TWO)) | |
28714 | ELSE | |
28715 | ETA = 100.0D0 | |
28716 | ENDIF | |
28717 | IF (IFRAME.EQ.1) THEN | |
28718 | CALL DT_LTNUC(PZ,PE,PZCMS,EECMS,3) | |
28719 | PPLUS = EECMS+PZCMS | |
28720 | PMINUS = EECMS-PZCMS | |
28721 | IF ((PPLUS*PMINUS).GT.TINY14) THEN | |
28722 | YYCMS = 0.5D0*LOG(ABS(PPLUS/PMINUS)) | |
28723 | ELSE | |
28724 | YYCMS = 100.0D0 | |
28725 | ENDIF | |
28726 | PTOTCM = SQRT(PT2+PZCMS**2) | |
28727 | COSTH = PZCMS/MAX(PTOTCM,TINY14) | |
28728 | IF (COSTH.GT.ONE) THEN | |
28729 | THECMS = ZERO | |
28730 | ELSEIF (COSTH.LT.-ONE) THEN | |
28731 | THECMS = TWOPI/2.0D0 | |
28732 | ELSE | |
28733 | THECMS = ACOS(COSTH) | |
28734 | ENDIF | |
28735 | IF ((THECMS.GT.TINY14).AND.((PI-THECMS).GT.TINY14)) THEN | |
28736 | ETACMS = -LOG(TAN(THECMS/TWO)) | |
28737 | ELSE | |
28738 | ETACMS = 100.0D0 | |
28739 | ENDIF | |
28740 | XF = PZCMS/MAX(PPCM,TINY14) | |
28741 | THECMS = THECMS/BOG | |
28742 | ELSE | |
28743 | PZCMS = PZ | |
28744 | EECMS = PE | |
28745 | YYCMS = YY | |
28746 | ETACMS = ETA | |
28747 | XF = XLAB | |
28748 | THECMS = THETA/BOG | |
28749 | ENDIF | |
28750 | THETA = THETA/BOG | |
28751 | ||
28752 | * set flag for "grey/black" | |
28753 | LGREY = .FALSE. | |
28754 | LBLACK = .FALSE. | |
28755 | EK = EKIN | |
28756 | IF (IDHKK(IDX).EQ.80000) EK = EKIN/DBLE(IBARY) | |
28757 | IF (MULDEF.EQ.1) THEN | |
28758 | * EMU01-Def. | |
28759 | IF ( ( (IDBJT.EQ. 1).AND.(EK.GT. 26.0D-3).AND. | |
28760 | & (EK.LE.375.0D-3) ).OR. | |
28761 | & ( (IDBJT.EQ.13).AND.(EK.GT. 12.0D-3).AND. | |
28762 | & (EK.LE. 56.0D-3) ).OR. | |
28763 | & ( (IDBJT.EQ.14).AND.(EK.GT. 12.0D-3).AND. | |
28764 | & (EK.LE. 56.0D-3) ).OR. | |
28765 | & ( (IDBJT.EQ.15).AND.(EK.GT. 20.0D-3).AND. | |
28766 | & (EK.LE.198.0D-3) ).OR. | |
28767 | & ( (IDBJT.EQ.16).AND.(EK.GT. 20.0D-3).AND. | |
28768 | & (EK.LE.198.0D-3) ).OR. | |
28769 | & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND. | |
28770 | & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND. | |
28771 | & (IDBJT.NE.16).AND. | |
28772 | & (BETA.GT.0.23D0).AND.(BETA.LE.0.70D0) ) ) | |
28773 | & LGREY = .TRUE. | |
28774 | IF ( ( (IDBJT.EQ. 1).AND.(EK.LE. 26.0D-3) ).OR. | |
28775 | & ( (IDBJT.EQ.13).AND.(EK.LE. 12.0D-3) ).OR. | |
28776 | & ( (IDBJT.EQ.14).AND.(EK.LE. 12.0D-3) ).OR. | |
28777 | & ( (IDBJT.EQ.15).AND.(EK.LE. 20.0D-3) ).OR. | |
28778 | & ( (IDBJT.EQ.16).AND.(EK.LE. 20.0D-3) ).OR. | |
28779 | & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND. | |
28780 | & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND. | |
28781 | & (IDBJT.NE.16).AND.(BETA.LE.0.23D0) ) ) | |
28782 | & LBLACK = .TRUE. | |
28783 | ELSE | |
28784 | * common Def. | |
28785 | IF ((BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)) LGREY=.TRUE. | |
28786 | IF (BETA.LE.0.23D0) LBLACK=.TRUE. | |
28787 | ENDIF | |
28788 | LFSP = .TRUE. | |
28789 | ELSEIF (ABS(ISTHKK(IDX)).EQ.ISTRNL) THEN | |
28790 | IST = ISTHKK(IDX) | |
28791 | IDPDG = IDHKK(IDX) | |
28792 | LFRAG = .TRUE. | |
28793 | IDBJT = 0 | |
28794 | IBARY = IDRES(IDX) | |
28795 | ICHAR = IDXRES(IDX) | |
28796 | AMASS = PHKK(5,IDX) | |
28797 | PE = PHKK(4,IDX) | |
28798 | PX = PHKK(1,IDX) | |
28799 | PY = PHKK(2,IDX) | |
28800 | PZ = PHKK(3,IDX) | |
28801 | PT2 = PX**2+PY**2 | |
28802 | PT = SQRT(PT2) | |
28803 | PTOT = SQRT(PT2+PZ**2) | |
28804 | SINTHE = PT/MAX(PTOT,TINY14) | |
28805 | COSTHE = PZ/MAX(PTOT,TINY14) | |
28806 | IF (COSTHE.GT.ONE) THEN | |
28807 | THETA = ZERO | |
28808 | ELSEIF (COSTHE.LT.-ONE) THEN | |
28809 | THETA = TWOPI/2.0D0 | |
28810 | ELSE | |
28811 | THETA = ACOS(COSTHE) | |
28812 | ENDIF | |
28813 | EKIN = PE-AMASS | |
28814 | **sr 15.4.96 new E_t-definition | |
28815 | C ET = PE*SINTHE | |
28816 | ET = EKIN*SINTHE | |
28817 | ** | |
28818 | IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN | |
28819 | ETA = -LOG(TAN(THETA/TWO)) | |
28820 | ELSE | |
28821 | ETA = 100.0D0 | |
28822 | ENDIF | |
28823 | THETA = THETA/BOG | |
28824 | LRNL = .TRUE. | |
28825 | ENDIF | |
28826 | ||
28827 | 9999 CONTINUE | |
28828 | RETURN | |
28829 | END | |
28830 | ||
28831 | *$ CREATE DT_HIMULT.FOR | |
28832 | *COPY DT_HIMULT | |
28833 | * | |
28834 | *===himult=============================================================* | |
28835 | * | |
28836 | SUBROUTINE DT_HIMULT(MODE) | |
28837 | ||
28838 | ************************************************************************ | |
28839 | * Tables of average energies/multiplicities. * | |
28840 | * This version dated 30.08.2000 is written by S. Roesler * | |
28841 | ************************************************************************ | |
28842 | ||
28843 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
28844 | SAVE | |
28845 | ||
28846 | PARAMETER ( LINP = 10 , | |
28847 | & LOUT = 6 , | |
28848 | & LDAT = 9 ) | |
28849 | ||
28850 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14) | |
28851 | ||
28852 | PARAMETER (SWMEXP=1.7D0) | |
28853 | ||
28854 | CHARACTER*8 ANAMEH(4) | |
28855 | ||
28856 | * particle properties (BAMJET index convention) | |
28857 | CHARACTER*8 ANAME | |
28858 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
28859 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
28860 | ||
28861 | * temporary storage for one final state particle | |
28862 | LOGICAL LFRAG,LGREY,LBLACK | |
28863 | COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN, | |
28864 | & SINTHE,COSTHE,THETA,THECMS, | |
28865 | & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF, | |
28866 | & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF, | |
28867 | & LFRAG,LGREY,LBLACK | |
28868 | ||
28869 | * event flag used for histograms | |
28870 | COMMON /DTNORM/ ICEVT,IEVHKK | |
28871 | ||
28872 | * Lorentz-parameters of the current interaction | |
28873 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
28874 | & UMO,PPCM,EPROJ,PPROJ | |
28875 | ||
28876 | PARAMETER (NOPART=210) | |
28877 | DIMENSION AVMULT(4,NOPART),AVE(4,NOPART),AVSWM(4,NOPART), | |
28878 | & AVPT(4,NOPART),IAVPT(4,NOPART) | |
28879 | DATA ANAMEH /'DEUTERON','3-H ','3-HE ','4-HE '/ | |
28880 | ||
28881 | GOTO (1,2,3) MODE | |
28882 | ||
28883 | *------------------------------------------------------------------ | |
28884 | * initialization | |
28885 | 1 CONTINUE | |
28886 | DO 10 I=1,NOPART | |
28887 | DO 11 J=1,4 | |
28888 | AVMULT(J,I) = ZERO | |
28889 | AVE(J,I) = ZERO | |
28890 | AVSWM(J,I) = ZERO | |
28891 | AVPT(J,I) = ZERO | |
28892 | IAVPT(J,I) = 0 | |
28893 | 11 CONTINUE | |
28894 | 10 CONTINUE | |
28895 | ||
28896 | RETURN | |
28897 | ||
28898 | *------------------------------------------------------------------ | |
28899 | * filling of histogram with event-record | |
28900 | 2 CONTINUE | |
28901 | IF (PE.LT.0.0D0) THEN | |
28902 | WRITE(LOUT,*) ' HIMULT: PE < 0 ! ',PE | |
28903 | RETURN | |
28904 | ENDIF | |
28905 | IF (.NOT.LFRAG) THEN | |
28906 | IVEL = 2 | |
28907 | IF (LGREY) IVEL = 3 | |
28908 | IF (LBLACK) IVEL = 4 | |
28909 | AVE(1,IDBJT) = AVE(1,IDBJT) +PE | |
28910 | AVE(IVEL,IDBJT) = AVE(IVEL,IDBJT)+PE | |
28911 | AVPT(1,IDBJT) = AVPT(1,IDBJT) +PT | |
28912 | AVPT(IVEL,IDBJT) = AVPT(IVEL,IDBJT)+PT | |
28913 | IAVPT(1,IDBJT) = IAVPT(1,IDBJT) +1 | |
28914 | IAVPT(IVEL,IDBJT) = IAVPT(IVEL,IDBJT)+1 | |
28915 | AVSWM(1,IDBJT) = AVSWM(1,IDBJT) +PE**SWMEXP | |
28916 | AVSWM(IVEL,IDBJT) = AVSWM(IVEL,IDBJT)+PE**SWMEXP | |
28917 | AVMULT(1,IDBJT) = AVMULT(1,IDBJT) +ONE | |
28918 | AVMULT(IVEL,IDBJT) = AVMULT(IVEL,IDBJT)+ONE | |
28919 | IF (IDBJT.LT.116) THEN | |
28920 | * total energy, multiplicity | |
28921 | AVE(1,30) = AVE(1,30) +PE | |
28922 | AVE(IVEL,30) = AVE(IVEL,30)+PE | |
28923 | AVPT(1,30) = AVPT(1,30) +PT | |
28924 | AVPT(IVEL,30) = AVPT(IVEL,30)+PT | |
28925 | IAVPT(1,30) = IAVPT(1,30) +1 | |
28926 | IAVPT(IVEL,30) = IAVPT(IVEL,30)+1 | |
28927 | AVSWM(1,30) = AVSWM(1,30)+PE**SWMEXP | |
28928 | AVSWM(IVEL,30) = AVSWM(IVEL,30)+PE**SWMEXP | |
28929 | AVMULT(1,30) = AVMULT(1,30) +ONE | |
28930 | AVMULT(IVEL,30) = AVMULT(IVEL,30)+ONE | |
28931 | * charged energy, multiplicity | |
28932 | IF (ICHAR.LT.0) THEN | |
28933 | AVE(1,26) = AVE(1,26) +PE | |
28934 | AVE(IVEL,26) = AVE(IVEL,26)+PE | |
28935 | AVPT(1,26) = AVPT(1,26) +PT | |
28936 | AVPT(IVEL,26) = AVPT(IVEL,26)+PT | |
28937 | IAVPT(1,26) = IAVPT(1,26) +1 | |
28938 | IAVPT(IVEL,26) = IAVPT(IVEL,26)+1 | |
28939 | AVSWM(1,26) = AVSWM(1,26) +PE**SWMEXP | |
28940 | AVSWM(IVEL,26) = AVSWM(IVEL,26)+PE**SWMEXP | |
28941 | AVMULT(1,26) = AVMULT(1,26) +ONE | |
28942 | AVMULT(IVEL,26) = AVMULT(IVEL,26)+ONE | |
28943 | ENDIF | |
28944 | IF (ICHAR.NE.0) THEN | |
28945 | AVE(1,27) = AVE(1,27) +PE | |
28946 | AVE(IVEL,27) = AVE(IVEL,27)+PE | |
28947 | AVPT(1,27) = AVPT(1,27) +PT | |
28948 | AVPT(IVEL,27) = AVPT(IVEL,27)+PT | |
28949 | IAVPT(1,27) = IAVPT(1,27) +1 | |
28950 | IAVPT(IVEL,27) = IAVPT(IVEL,27)+1 | |
28951 | AVSWM(1,27) = AVSWM(1,27) +PE**SWMEXP | |
28952 | AVSWM(IVEL,27) = AVSWM(IVEL,27)+PE**SWMEXP | |
28953 | AVMULT(1,27) = AVMULT(1,27) +ONE | |
28954 | AVMULT(IVEL,27) = AVMULT(IVEL,27)+ONE | |
28955 | ENDIF | |
28956 | ENDIF | |
28957 | ENDIF | |
28958 | ||
28959 | RETURN | |
28960 | ||
28961 | *------------------------------------------------------------------ | |
28962 | * output | |
28963 | 3 CONTINUE | |
28964 | WRITE(LOUT,3000) | |
28965 | 3000 FORMAT(/,1X,'HIMULT:',21X,'particle - statistics',/, | |
28966 | & 29X,'---------------------',/) | |
28967 | IF (MULDEF.EQ.1) THEN | |
28968 | WRITE(LOUT,'(1X,A,/)') 'fast/grey/black: EMU-def.' | |
28969 | ELSE | |
28970 | BETGRE = 0.7D0 | |
28971 | BETBLC = 0.23D0 | |
28972 | WRITE(LOUT,3002) BETGRE,BETGRE,BETBLC,BETBLC | |
28973 | 3002 FORMAT(1X,'fast: beta > ',F4.2,' grey: ',F4.2,' > beta > ' | |
28974 | & ,F4.2,' black: beta < ',F4.2,/) | |
28975 | ENDIF | |
28976 | WRITE(LOUT,3003) SWMEXP | |
28977 | 3003 FORMAT(1X,'particle |',12X,'average multiplicity',/, | |
28978 | & 13X,'| total fast', | |
28979 | C & ' grey black K f(',F3.1,')',/,1X, | |
28980 | & ' grey black <pt> f(',F3.1,')',/,1X, | |
28981 | & '------------+--------------', | |
28982 | & '-------------------------------------------------') | |
28983 | DO 30 I=1,NOPART | |
28984 | DO 31 J=1,4 | |
28985 | AVMULT(J,I) = AVMULT(J,I)/DBLE(MAX(ICEVT,1)) | |
28986 | AVE(J,I) = AVE(J,I)/DBLE(MAX(ICEVT,1))/EPROJ | |
28987 | AVPT(J,I) = AVPT(J,I)/DBLE(MAX(IAVPT(J,I),1)) | |
28988 | AVSWM(J,I) = AVSWM(J,I)/DBLE(MAX(ICEVT,1))/EPROJ**SWMEXP | |
28989 | 31 CONTINUE | |
28990 | IF (I.LE.115) THEN | |
28991 | WRITE(LOUT,3004) ANAME(I),I, | |
28992 | & AVMULT(1,I),AVMULT(2,I), | |
28993 | & AVMULT(3,I),AVMULT(4,I), | |
28994 | C & AVE(1,I),AVSWM(1,I) | |
28995 | & AVPT(1,I),AVSWM(1,I) | |
28996 | ELSEIF (I.LE.119) THEN | |
28997 | WRITE(LOUT,3004) ANAMEH(I-115),I, | |
28998 | & AVMULT(1,I),AVMULT(2,I), | |
28999 | & AVMULT(3,I),AVMULT(4,I), | |
29000 | C & AVE(1,I),AVSWM(1,I) | |
29001 | & AVPT(1,I),AVSWM(1,I) | |
29002 | ENDIF | |
29003 | 3004 FORMAT(1X,A8,I4,'| ',2F13.6,2F9.5,2F9.5) | |
29004 | 30 CONTINUE | |
29005 | **temporary | |
29006 | C WRITE(LOUT,'(A,F7.3)') ' number of charged heavy particles: ', | |
29007 | C & AVMULT(3,27)+AVMULT(4,27) | |
29008 | ** | |
29009 | ||
29010 | RETURN | |
29011 | END | |
29012 | ||
29013 | *$ CREATE DT_HISTAT.FOR | |
29014 | *COPY DT_HISTAT | |
29015 | * | |
29016 | *===histat=============================================================* | |
29017 | * | |
29018 | SUBROUTINE DT_HISTAT(IDX,MODE) | |
29019 | ||
29020 | ************************************************************************ | |
29021 | * This version dated 26.02.96 is written by S. Roesler * | |
29022 | * * | |
29023 | * Last change 27.12.2006 by S. Roesler. * | |
29024 | ************************************************************************ | |
29025 | ||
29026 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
29027 | SAVE | |
29028 | ||
29029 | PARAMETER ( LINP = 10 , | |
29030 | & LOUT = 6 , | |
29031 | & LDAT = 9 ) | |
29032 | ||
29033 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14) | |
29034 | PARAMETER (NDIM=199) | |
29035 | ||
29036 | * event history | |
29037 | ||
29038 | PARAMETER (NMXHKK=200000) | |
29039 | ||
29040 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
29041 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
29042 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
29043 | ||
29044 | * extended event history | |
29045 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
29046 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
29047 | & IHIST(2,NMXHKK) | |
29048 | ||
29049 | * particle properties (BAMJET index convention) | |
29050 | CHARACTER*8 ANAME | |
29051 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
29052 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
29053 | ||
29054 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
29055 | ||
29056 | * Glauber formalism: cross sections | |
29057 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
29058 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
29059 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
29060 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
29061 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
29062 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
29063 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
29064 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
29065 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
29066 | & BSLOPE,NEBINI,NQBINI | |
29067 | ||
29068 | * emulsion treatment | |
29069 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
29070 | & NCOMPO,IEMUL | |
29071 | ||
29072 | * properties of interacting particles | |
29073 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
29074 | ||
29075 | * rejection counter | |
29076 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
29077 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
29078 | & IREXCI(3),IRDIFF(2),IRINC | |
29079 | ||
29080 | * statistics: residual nuclei | |
29081 | COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2), | |
29082 | & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2), | |
29083 | & NINCST(2,4),NINCEV(2), | |
29084 | & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2), | |
29085 | & NRESPB(2),NRESCH(2),NRESEV(4), | |
29086 | & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240), | |
29087 | & NEVAFI(2,2) | |
29088 | ||
29089 | * parameter for intranuclear cascade | |
29090 | LOGICAL LPAULI | |
29091 | COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI | |
29092 | ||
29093 | * INCLUDE '(DIMPAR)' | |
29094 | * Taken from FLUKA | |
29095 | PARAMETER ( MXXRGN =20000 ) | |
29096 | PARAMETER ( MXXMDF = 710 ) | |
29097 | PARAMETER ( MXXMDE = 702 ) | |
29098 | PARAMETER ( MFSTCK =40000 ) | |
29099 | PARAMETER ( MESTCK = 100 ) | |
29100 | PARAMETER ( MOSTCK = 2000 ) | |
29101 | PARAMETER ( MXPRSN = 100 ) | |
29102 | PARAMETER ( MXPDPM = 800 ) | |
29103 | PARAMETER ( MXPSCS =30000 ) | |
29104 | PARAMETER ( MXGLWN = 300 ) | |
29105 | PARAMETER ( MXOUTU = 50 ) | |
29106 | PARAMETER ( NALLWP = 64 ) | |
29107 | PARAMETER ( NELEMX = 80 ) | |
29108 | PARAMETER ( MPDPDX = 18 ) | |
29109 | PARAMETER ( MXHTTR = 260 ) | |
29110 | PARAMETER ( MXSEAX = 20 ) | |
29111 | PARAMETER ( MXHTNC = MXSEAX + 1 ) | |
29112 | PARAMETER ( ICOMAX = 2400 ) | |
29113 | PARAMETER ( ICHMAX = ICOMAX + MXXMDF ) | |
29114 | PARAMETER ( NSTBIS = 304 ) | |
29115 | PARAMETER ( NQSTIS = 46 ) | |
29116 | PARAMETER ( NTSTIS = NSTBIS + NQSTIS ) | |
29117 | PARAMETER ( MXPABL = 120 ) | |
29118 | PARAMETER ( IDMAXP = 450 ) | |
29119 | PARAMETER ( IDMXDC = 2000 ) | |
29120 | PARAMETER ( MXMCIN = 410 ) | |
29121 | PARAMETER ( IHYPMX = 4 ) | |
29122 | PARAMETER ( MKBMX1 = 11 ) | |
29123 | PARAMETER ( MKBMX2 = 11 ) | |
29124 | PARAMETER ( MXIRRD = 2500 ) | |
29125 | PARAMETER ( MXTRDC = 1500 ) | |
29126 | PARAMETER ( NKTL = 17 ) | |
29127 | PARAMETER ( NBLNMX = 40000000 ) | |
29128 | ||
29129 | * INCLUDE '(PAREVT)' | |
29130 | * Taken from FLUKA | |
29131 | PARAMETER ( FRDIFF = 0.2D+00 ) | |
29132 | PARAMETER ( ETHSEA = 1.0D+00 ) | |
29133 | * | |
29134 | LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX, | |
29135 | & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI, | |
29136 | & LNUCRI, LPEANU, LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR, | |
29137 | & LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN | |
29138 | COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC, | |
29139 | & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY, | |
29140 | & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV, | |
29141 | & LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LPHDRC, | |
29142 | & LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR, LRVKIN, | |
29143 | & LVP2XX, LV2XNW, LNWV2X, LEVFIN | |
29144 | ||
29145 | * INCLUDE '(FRBKCM)' | |
29146 | * Taken from FLUKA | |
29147 | * Maximum number of fragments to be emitted: | |
29148 | PARAMETER ( MXFFBK = 6 ) | |
29149 | PARAMETER ( MXZFBK = 10 ) | |
29150 | PARAMETER ( MXNFBK = 12 ) | |
29151 | PARAMETER ( MXAFBK = 16 ) | |
29152 | PARAMETER ( MXASST = 25 ) | |
29153 | PARAMETER ( NXAFBK = MXAFBK + 1 ) | |
29154 | PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 + MXASST - NXAFBK ) | |
29155 | PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 + MXASST - NXAFBK ) | |
29156 | PARAMETER ( MXPSST = 700 ) | |
29157 | * Maximum number of pre-computed break-up combinations | |
29158 | PARAMETER ( MXPPFB = 42500 ) | |
29159 | * Maximum number of break-up combinations, including special | |
29160 | * run-time ones: | |
29161 | PARAMETER ( MXPSFB = 43000 ) | |
29162 | * Base for J multiplicity encoding: | |
29163 | PARAMETER ( IBFRBK = 73 ) | |
29164 | * Maximum Ibfrbk exponent to avoid overflow of I*4(roughly at 2.1x10^9) | |
29165 | * it must be (Ibfrbk-1) + (Ibfrbk-1)*Ibfrbk + (Ibfrbk-1)*Ibfrbk^2 + ... | |
29166 | * ... + (Ibfrbk-1)*Ibfrbk^Jpwfbx < 2100000000, | |
29167 | * --> Ibfrbk^(Jpwfbx+1) < 2100000000 | |
29168 | PARAMETER ( JPWFBX = 4 ) | |
29169 | LOGICAL LFRMBK, LNCMSS | |
29170 | COMMON / FRBKCM / AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST), | |
29171 | & WEIFBK (MXPSST), GAMFBK (MXPSST), EXFRBK (MXPSFB), | |
29172 | & SDMFBK (MXPSFB), COUFBK (MXPSFB), CENFBK (MXPSFB), | |
29173 | & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK, FRBKLS, | |
29174 | & IFRBKN (MXPSST), IFRBKZ (MXPSST), | |
29175 | & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST), | |
29176 | & IPSIND (0:NXNFBK,0:NXZFBK,2), JPSIND (0:MXASST), | |
29177 | & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK), | |
29178 | & IFBCHA (9,MXPSFB), IPOSST, IPOSFB, IFBSTF, IFBPSF, | |
29179 | & IFBFRB, IFBCHN, IFBNC1, IFBNC2, NBUFBK, LFRMBK, LNCMSS | |
29180 | ||
29181 | * INCLUDE '(EVAFLG)' | |
29182 | * Taken from FLUKA | |
29183 | LOGICAL LOLDEV, LUFULL, LNWLOW, LASMEN, LGMCMP, LGDRFT, LDSCLV, | |
29184 | & LDSCGM, LNDSLD, LMNJPR, LBRPEN, LNWBRP, LIFKEY, LOLDSM, | |
29185 | & LNAIPR, LGUSPR, LFLKCO, LLVMOD, LHVEVP, LHVECN, LHVCAL, | |
29186 | & LHVRAL, LHVSGF, LTMCRR, LBZZCR, LQCSKP | |
29187 | COMMON / EVAFLG / BRPNFR (0:2), EBRPFR (0:2), EMVBRP (0:2), | |
29188 | & ILVMOD, JLVMOD, JSIPFL, IMSSFR, JMSSFR, IEVFSS, MXAHEV, | |
29189 | & MXZHEV, IFHVFL, IFKYMX, IGMCMP, MPMODE, MSMODE, MUMODE, | |
29190 | & MFMODE, MEMODE, MRMODE, ITMCRR, IASYCR, IFSBCR, IFSSBR, | |
29191 | & LOLDEV, LUFULL, LNWLOW, LASMEN, LGMCMP, LGDRFT, LDSCLV, | |
29192 | & LDSCGM, LNDSLD, LMNJPR, LBRPEN, LNWBRP, LIFKEY, LOLDSM, | |
29193 | & LNAIPR, LGUSPR, LFLKCO, LLVMOD, LHVEVP, LHVECN, LHVCAL, | |
29194 | & LHVRAL, LHVSGF, LTMCRR, LBZZCR, LQCSKP | |
29195 | ||
29196 | * temporary storage for one final state particle | |
29197 | LOGICAL LFRAG,LGREY,LBLACK | |
29198 | COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN, | |
29199 | & SINTHE,COSTHE,THETA,THECMS, | |
29200 | & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF, | |
29201 | & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF, | |
29202 | & LFRAG,LGREY,LBLACK | |
29203 | ||
29204 | * event flag used for histograms | |
29205 | COMMON /DTNORM/ ICEVT,IEVHKK | |
29206 | ||
29207 | * statistics: double-Pomeron exchange | |
29208 | COMMON /DTFLG2/ INTFLG,IPOPO | |
29209 | ||
29210 | DIMENSION EMUSAM(NCOMPX) | |
29211 | ||
29212 | CHARACTER*13 CMSG(3) | |
29213 | DATA CMSG /'not requested','not requested','not requested'/ | |
29214 | ||
29215 | GOTO (1,2,3,4,5) MODE | |
29216 | ||
29217 | *------------------------------------------------------------------ | |
29218 | * initialization | |
29219 | 1 CONTINUE | |
29220 | * emulsion treatment | |
29221 | IF (NCOMPO.GT.0) THEN | |
29222 | DO 10 I=1,NCOMPX | |
29223 | EMUSAM(I) = ZERO | |
29224 | 10 CONTINUE | |
29225 | ENDIF | |
29226 | * common /DTSTA2/, statistics on i.n.c., residual nuclei, evap. | |
29227 | NINCGE = 0 | |
29228 | DO 11 I=1,2 | |
29229 | EXCDPM(I) = ZERO | |
29230 | EXCDPM(I+2) = ZERO | |
29231 | EXCEVA(I) = ZERO | |
29232 | NINCWO(I) = 0 | |
29233 | NINCEV(I) = 0 | |
29234 | NRESTO(I) = 0 | |
29235 | NRESPR(I) = 0 | |
29236 | NRESNU(I) = 0 | |
29237 | NRESBA(I) = 0 | |
29238 | NRESPB(I) = 0 | |
29239 | NRESCH(I) = 0 | |
29240 | NRESEV(I) = 0 | |
29241 | NRESEV(I+2) = 0 | |
29242 | NEVAGA(I) = 0 | |
29243 | NEVAHT(I) = 0 | |
29244 | NEVAFI(1,I) = 0 | |
29245 | NEVAFI(2,I) = 0 | |
29246 | DO 12 J=1,6 | |
29247 | IF (J.LE.2) NINCHR(I,J) = 0 | |
29248 | IF (J.LE.3) NINCCO(I,J) = 0 | |
29249 | IF (J.LE.4) NINCST(I,J) = 0 | |
29250 | NEVA(I,J) = 0 | |
29251 | 12 CONTINUE | |
29252 | DO 13 J=1,210 | |
29253 | NEVAHY(1,I,J) = 0 | |
29254 | NEVAHY(2,I,J) = 0 | |
29255 | 13 CONTINUE | |
29256 | 11 CONTINUE | |
29257 | MAXGEN = 0 | |
29258 | **dble Po statistics. | |
29259 | KPOPO = 0 | |
29260 | ||
29261 | RETURN | |
29262 | *------------------------------------------------------------------ | |
29263 | * filling of histogram with event-record | |
29264 | 2 CONTINUE | |
29265 | IF (IST.EQ.-1) THEN | |
29266 | IF (.NOT.LFRAG) THEN | |
29267 | IF (IDPDG.EQ.2212) THEN | |
29268 | NEVA(NOBAM(IDX),1) = NEVA(NOBAM(IDX),1)+1 | |
29269 | ELSEIF (IDPDG.EQ.2112) THEN | |
29270 | NEVA(NOBAM(IDX),2) = NEVA(NOBAM(IDX),2)+1 | |
29271 | ELSEIF (IDPDG.EQ.22) THEN | |
29272 | NEVAGA(NOBAM(IDX)) = NEVAGA(NOBAM(IDX))+1 | |
29273 | ELSEIF (IDPDG.EQ.80000) THEN | |
29274 | IF (IDBJT.EQ.116) THEN | |
29275 | NEVA(NOBAM(IDX),3) = NEVA(NOBAM(IDX),3)+1 | |
29276 | ELSEIF (IDBJT.EQ.117) THEN | |
29277 | NEVA(NOBAM(IDX),4) = NEVA(NOBAM(IDX),4)+1 | |
29278 | ELSEIF (IDBJT.EQ.118) THEN | |
29279 | NEVA(NOBAM(IDX),5) = NEVA(NOBAM(IDX),5)+1 | |
29280 | ELSEIF (IDBJT.EQ.119) THEN | |
29281 | NEVA(NOBAM(IDX),6) = NEVA(NOBAM(IDX),6)+1 | |
29282 | ENDIF | |
29283 | ENDIF | |
29284 | ELSE | |
29285 | * heavy fragments (here: fission products only) | |
29286 | NEVAHY(NOBAM(IDX),1,IBARY) = NEVAHY(NOBAM(IDX),1,IBARY)+1 | |
29287 | NEVAHY(NOBAM(IDX),2,ICHAR) = NEVAHY(NOBAM(IDX),2,ICHAR)+1 | |
29288 | NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1 | |
29289 | ENDIF | |
29290 | ELSEIF ((IST.EQ.1).AND.(.NOT.LFRAG)) THEN | |
29291 | IF (IDCH(IDX).GT.MAXGEN) MAXGEN = IDCH(IDX) | |
29292 | ENDIF | |
29293 | ||
29294 | RETURN | |
29295 | *------------------------------------------------------------------ | |
29296 | * output | |
29297 | 3 CONTINUE | |
29298 | ||
29299 | **dble Po statistics. | |
29300 | C WRITE(LOUT,'(1X,A,2I7,2E12.4)') | |
29301 | C & '# evts. / # dble-Po. evts / s_in / s_popo :', | |
29302 | C & ICEVT,KPOPO,XSPRO(1,1,1),XSPRO(1,1,1)*DBLE(KPOPO)/DBLE(ICEVT) | |
29303 | ||
29304 | * emulsion treatment | |
29305 | IF (NCOMPO.GT.0) THEN | |
29306 | WRITE(LOUT,3000) | |
29307 | 3000 FORMAT(/,1X,'HISTAT:',14X,'statistics - target emulsion',/, | |
29308 | & 22X,'----------------------------',/,/,19X, | |
29309 | & 'mass charge fraction',/,39X, | |
29310 | & 'input treated',/) | |
29311 | DO 30 I=1,NCOMPO | |
29312 | WRITE(LOUT,3013) I,IEMUMA(I),IEMUCH(I),EMUFRA(I), | |
29313 | & EMUSAM(I)/DBLE(ICEVT) | |
29314 | 3013 FORMAT(12X,I2,1X,2I8,6X,F7.3,5X,F7.3) | |
29315 | 30 CONTINUE | |
29316 | ENDIF | |
29317 | ||
29318 | * i.n.c. statistics: output | |
29319 | WRITE(LOUT,3001) ICEVT,NRESEV(2),IRINC | |
29320 | 3001 FORMAT(/,1X,'HISTAT:',14X,'statistics - intranuclear cascade',/, | |
29321 | & 22X,'---------------------------------',/,/,1X, | |
29322 | & 'no. of events for normalization: (accepted final events,', | |
29323 | & ' evt)',4X,I6,/,34X,'(events before evap.-step, evt1)',I6, | |
29324 | & /,1X,'no. of rejected events due to intranuclear', | |
29325 | & ' cascade',15X,I6,/) | |
29326 | ICEV = MAX(ICEVT,1) | |
29327 | ICEV1 = ICEV | |
29328 | IF (LEVPRT) ICEV1 = MAX(NRESEV(2),1) | |
29329 | WRITE(LOUT,3002) | |
29330 | & (DBLE(NINCWO(I))/DBLE(ICEV),I=1,2), | |
29331 | & ((DBLE(NINCST(I,J))/DBLE(ICEV),I=1,2),J=1,4), | |
29332 | & KTAUGE,DBLE(NINCGE)/DBLE(ICEV), | |
29333 | & (DBLE(NINCCO(I,1)+NINCCO(I,2)+NINCCO(I,3))/DBLE(ICEV1),I=1,2), | |
29334 | & (DBLE(NINCCO(I,2))/DBLE(ICEV1),I=1,2), | |
29335 | & (DBLE(NINCCO(I,3))/DBLE(ICEV1),I=1,2), | |
29336 | & (DBLE(NINCCO(I,1))/DBLE(ICEV1),I=1,2) | |
29337 | 3002 FORMAT(1X,'no. of wounded nucl. in proj./ target (mean per evt)', | |
29338 | & 5X,F6.2,' /',F6.2,/,1X,'no. of particles unable to escape', | |
29339 | & ' proj./ target (mean per evt)',/,8X,'baryons: pos. ', | |
29340 | & F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3,/,8X, | |
29341 | & 'mesons: pos. ',F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3, | |
29342 | & /,1X,'maximum no. of generations treated (maximum allowed:' | |
29343 | & ,I4,')',/,43X,'(mean per evt)',5X,F6.2,/,1X,'no. of sec.', | |
29344 | & ' interactions in proj./ target (mean per evt1)', | |
29345 | & F7.3,' /',F7.3,/,8X,'out of which by inelastic', | |
29346 | & ' interactions',12X,F7.3,' /',F7.3,/,21X,'by elastic ', | |
29347 | & 'interactions',14X,F7.3,' /',F7.3,/,21X,'by absorption ', | |
29348 | & '(ap, K-, pi- only) ',F7.3,' /',F7.3,/) | |
29349 | WRITE(LOUT,3003) NRESEV(2),NRESEV(4),IREXCI, | |
29350 | & IREXCI(1)+IREXCI(2)+IREXCI(3) | |
29351 | 3003 FORMAT(/,1X,'HISTAT:',14X,'statistics - residual nuclei, ', | |
29352 | & 'evaporation',/,22X,'-----------------------------', | |
29353 | & '------------',/,/,1X,'no. of events for normal.: ', | |
29354 | & '(events handled by FICONF, evt)',7X,I6,/,28X,'(events', | |
29355 | & ' passing the evap.-step, evt1) ',I6,/,1X,'no. of', | |
29356 | & ' rejected events (',I4,',',I4,',',I4,')',22X,I6,/) | |
29357 | ||
29358 | WRITE(LOUT,3004) | |
29359 | 3004 FORMAT(/,22X,'1) before evaporation-step:',/) | |
29360 | ICEV = MAX(NRESEV(2),1) | |
29361 | WRITE(LOUT,3005) | |
29362 | & (DBLE(NRESTO(I))/DBLE(ICEV),I=1,2), | |
29363 | & (DBLE(NRESPR(I))/DBLE(ICEV),I=1,2), | |
29364 | & (DBLE(NRESNU(I))/DBLE(ICEV),I=1,2), | |
29365 | & (DBLE(NRESBA(I))/DBLE(ICEV),I=1,2), | |
29366 | & (DBLE(NRESPB(I))/DBLE(ICEV),I=1,2), | |
29367 | & (DBLE(NRESCH(I))/DBLE(ICEV),I=1,2), | |
29368 | & (EXCDPM(I)/DBLE(ICEV),I=1,2), | |
29369 | & (EXCDPM(I+2)/DBLE(ICEV),I=1,2) | |
29370 | 3005 FORMAT(1X,'residual nuclei: (mean values per evt)',12X, | |
29371 | & 'proj. / target',/,/,8X,'total number of particles',15X, | |
29372 | & 2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X, | |
29373 | & 'neutrons',18X,2F9.3,/,22X,'baryons',19X,2F9.3,/,22X, | |
29374 | & 'pos. baryons',14X,2F9.3,/,8X,'total charge',28X,2F9.3,/, | |
29375 | & /,8X,'excitation energy (bef. evap.-step) ',2E11.3,/, | |
29376 | & 8X,'excitation energy per nucleon ',2E11.3,/,/) | |
29377 | ||
29378 | * evaporation / fission / fragmentation statistics: output | |
29379 | ICEV = MAX(NRESEV(2),1) | |
29380 | ICEV1 = MAX(NRESEV(4),1) | |
29381 | NTEVA1 = | |
29382 | & NEVA(1,1)+NEVA(1,2)+NEVA(1,3)+NEVA(1,4)+NEVA(1,5)+NEVA(1,6) | |
29383 | NTEVA2 = | |
29384 | & NEVA(2,1)+NEVA(2,2)+NEVA(2,3)+NEVA(2,4)+NEVA(2,5)+NEVA(2,6) | |
29385 | IF (LEVPRT) THEN | |
29386 | ||
29387 | IF (IEVFSS.EQ.1) CMSG(1) = 'requested ' | |
29388 | ||
29389 | IF (LFRMBK) CMSG(2) = 'requested ' | |
29390 | IF (LDEEXG) CMSG(3) = 'requested ' | |
29391 | WRITE(LOUT,3006) | |
29392 | & CMSG, | |
29393 | & DBLE(NTEVA1)/DBLE(ICEV1),DBLE(NTEVA2)/DBLE(ICEV1), | |
29394 | & (DBLE(NEVA(I,1))/DBLE(ICEV1),I=1,2), | |
29395 | & (DBLE(NEVA(I,2))/DBLE(ICEV1),I=1,2), | |
29396 | & (DBLE(NEVA(I,3))/DBLE(ICEV1),I=1,2), | |
29397 | & (DBLE(NEVA(I,4))/DBLE(ICEV1),I=1,2), | |
29398 | & (DBLE(NEVA(I,5))/DBLE(ICEV1),I=1,2), | |
29399 | & (DBLE(NEVA(I,6))/DBLE(ICEV1),I=1,2), | |
29400 | & (DBLE(NEVAGA(I))/DBLE(ICEV1),I=1,2), | |
29401 | & (DBLE(NEVAHT(I))/DBLE(ICEV1),I=1,2) | |
29402 | 3006 FORMAT(22X,'2) after evaporation-step:',/,/,1X,'Fission:', | |
29403 | & 13X,A13,/,1X,'Fermi-Break-up:',6X,A13,/,1X,'Gamma-', | |
29404 | & 'deexcitation:',2X,A13,/,/, | |
29405 | & 1X,'evaporation/deexcitation: (mean values per evt1) ', | |
29406 | & 'proj. / target',/,/,8X,'total number of evap. particles', | |
29407 | & 9X,2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X, | |
29408 | & 'neutrons',18X,2F9.3,/,22X,'deuterons',17X,2F9.3,/,22X, | |
29409 | & '3-H',23X,2F9.3,/,22X,'3-He',22X,2F9.3,/,22X,'4-He',22X, | |
29410 | & 2F9.3,/,8X,'nucl. deexcit. gammas',19X,2F9.3,/,8X, | |
29411 | & 'heavy fragments',25X,2F9.3,/) | |
29412 | ||
29413 | IF (IEVFSS.EQ.1) THEN | |
29414 | ||
29415 | WRITE(LOUT,3007) NEVAFI(1,1),NEVAFI(1,2), | |
29416 | & NEVAFI(2,1),NEVAFI(2,2), | |
29417 | & DBLE(NEVAFI(2,1))/DBLE(MAX(NEVAFI(1,1),1))*100.0D0, | |
29418 | & DBLE(NEVAFI(2,2))/DBLE(MAX(NEVAFI(1,2),1))*100.0D0 | |
29419 | 3007 FORMAT(1X,'Fission: total number of events',14X,2I9,/ | |
29420 | & 12X,'out of which fission occured',8X,2I9,/, | |
29421 | & 50X,'(',F5.2,'%) (',F5.2,'%)',/) | |
29422 | ENDIF | |
29423 | ||
29424 | C IF ((LFRMBK).OR.(IEVFSS.EQ.1)) THEN | |
29425 | ||
29426 | C WRITE(LOUT,3008) | |
29427 | C3008 FORMAT(1X,'heavy fragments - statistics:',7X,'charge', | |
29428 | C & ' proj. / target',/) | |
29429 | C DO 31 I=1,210 | |
29430 | C IF ((NEVAHY(1,2,I).NE.0).OR.(NEVAHY(2,2,I).NE.0)) THEN | |
29431 | C WRITE(LOUT,3009) I, | |
29432 | C & (DBLE(NEVAHY(K,2,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2) | |
29433 | C3009 FORMAT(38X,I3,3X,2E12.3) | |
29434 | C ENDIF | |
29435 | C 31 CONTINUE | |
29436 | C WRITE(LOUT,3010) | |
29437 | C3010 FORMAT(1X,'heavy fragments - statistics:',7X,'mass ', | |
29438 | C & ' proj. / target',/) | |
29439 | C DO 32 I=1,210 | |
29440 | C IF ((NEVAHY(1,1,I).NE.0).OR.(NEVAHY(2,1,I).NE.0)) THEN | |
29441 | C WRITE(LOUT,3011) I, | |
29442 | C & (DBLE(NEVAHY(K,1,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2) | |
29443 | C3011 FORMAT(38X,I3,3X,2E12.3) | |
29444 | C ENDIF | |
29445 | C 32 CONTINUE | |
29446 | C WRITE(LOUT,*) | |
29447 | C ENDIF | |
29448 | ELSE | |
29449 | WRITE(LOUT,3012) | |
29450 | 3012 FORMAT(22X,'2) after evaporation-step:',/,/,1X, | |
29451 | & 'Evaporation: not requested',/) | |
29452 | ENDIF | |
29453 | ||
29454 | RETURN | |
29455 | *------------------------------------------------------------------ | |
29456 | * filling of histogram with event-record | |
29457 | 4 CONTINUE | |
29458 | * emulsion treatment | |
29459 | IF (NCOMPO.GT.0) THEN | |
29460 | DO 40 I=1,NCOMPO | |
29461 | IF (IT.EQ.IEMUMA(I)) THEN | |
29462 | EMUSAM(I) = EMUSAM(I)+ONE | |
29463 | ENDIF | |
29464 | 40 CONTINUE | |
29465 | ENDIF | |
29466 | NINCGE = NINCGE+MAXGEN | |
29467 | MAXGEN = 0 | |
29468 | **dble Po statistics. | |
29469 | IF (IPOPO.EQ.1) KPOPO = KPOPO+1 | |
29470 | ||
29471 | RETURN | |
29472 | *------------------------------------------------------------------ | |
29473 | * filling of histogram with event-record | |
29474 | 5 CONTINUE | |
29475 | IF ((ISTHKK(IDX).EQ.15).OR.(ISTHKK(IDX).EQ.16)) THEN | |
29476 | IB = IIBAR(IDBAM(IDX)) | |
29477 | IC = IICH(IDBAM(IDX)) | |
29478 | J = ISTHKK(IDX)-14 | |
29479 | IF ( ((ABS(IB).EQ.1).AND.(IC.EQ.1)).OR.(IC.EQ.0) ) THEN | |
29480 | NINCST(J,1) = NINCST(J,1)+1 | |
29481 | ELSEIF ((ABS(IB).EQ.1).AND.(IC.EQ.-1)) THEN | |
29482 | NINCST(J,2) = NINCST(J,2)+1 | |
29483 | ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ. 1)) THEN | |
29484 | NINCST(J,3) = NINCST(J,3)+1 | |
29485 | ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ.-1)) THEN | |
29486 | NINCST(J,4) = NINCST(J,4)+1 | |
29487 | ENDIF | |
29488 | ELSEIF (ISTHKK(IDX).EQ.17) THEN | |
29489 | NINCWO(1) = NINCWO(1)+1 | |
29490 | ELSEIF (ISTHKK(IDX).EQ.18) THEN | |
29491 | NINCWO(2) = NINCWO(2)+1 | |
29492 | ELSEIF (ISTHKK(IDX).EQ.1001) THEN | |
29493 | IB = IDRES(IDX) | |
29494 | IC = IDXRES(IDX) | |
29495 | IF (IC.GT.0) THEN | |
29496 | NEVAHY(NOBAM(IDX),1,IB) = NEVAHY(NOBAM(IDX),1,IB)+1 | |
29497 | NEVAHY(NOBAM(IDX),2,IC) = NEVAHY(NOBAM(IDX),2,IC)+1 | |
29498 | ENDIF | |
29499 | NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1 | |
29500 | ENDIF | |
29501 | ||
29502 | RETURN | |
29503 | END | |
29504 | *$ CREATE DT_NEWHGR.FOR | |
29505 | *COPY DT_NEWHGR | |
29506 | * | |
29507 | *===newhgr=============================================================* | |
29508 | * | |
29509 | SUBROUTINE DT_NEWHGR(XLIM1,XLIM2,XLIM3,XLIMB,IBIN,IREFN) | |
29510 | ||
29511 | ************************************************************************ | |
29512 | * * | |
29513 | * Histogram initialization. * | |
29514 | * * | |
29515 | * input: XLIM1/XLIM2 lower/upper edge of histogram-window * | |
29516 | * XLIM3 bin size * | |
29517 | * IBIN > 0 number of bins in equidistant lin. binning * | |
29518 | * = -1 reset histograms * | |
29519 | * < -1 |IBIN| number of bins in equidistant log. * | |
29520 | * binning or log. binning in user def. struc. * | |
29521 | * XLIMB(*) user defined bin structure * | |
29522 | * * | |
29523 | * The bin structure is sensitive to * | |
29524 | * XLIM1, XLIM3, IBIN if XLIM3 > 0 (lin.) * | |
29525 | * XLIM1, XLIM2, IBIN if XLIM3 = 0 (lin. & log.) * | |
29526 | * XLIMB, IBIN if XLIM3 < 0 * | |
29527 | * * | |
29528 | * * | |
29529 | * output: IREFN histogram index * | |
29530 | * (= -1 for inconsistent histogr. request) * | |
29531 | * * | |
29532 | * This subroutine is based on a original version by R. Engel. * | |
29533 | * This version dated 22.4.95 is written by S. Roesler. * | |
29534 | ************************************************************************ | |
29535 | ||
29536 | IMPLICIT DOUBLE PRECISION(A-H,O-Z) | |
29537 | SAVE | |
29538 | ||
29539 | PARAMETER ( LINP = 10 , | |
29540 | & LOUT = 6 , | |
29541 | & LDAT = 9 ) | |
29542 | ||
29543 | LOGICAL LSTART | |
29544 | ||
29545 | PARAMETER (ZERO = 0.0D0, | |
29546 | & TINY = 1.0D-10) | |
29547 | ||
29548 | DIMENSION XLIMB(*) | |
29549 | ||
29550 | * histograms | |
29551 | ||
29552 | PARAMETER (NHIS=150, NDIM=250) | |
29553 | ||
29554 | COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS), | |
29555 | & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL | |
29556 | ||
29557 | * auxiliary common for histograms | |
29558 | COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS) | |
29559 | ||
29560 | DATA LSTART /.TRUE./ | |
29561 | ||
29562 | * reset histogram counter | |
29563 | IF (LSTART.OR.(IBIN.EQ.-1)) THEN | |
29564 | IHISL = 0 | |
29565 | IF (IBIN.EQ.-1) RETURN | |
29566 | LSTART = .FALSE. | |
29567 | ENDIF | |
29568 | ||
29569 | IHIS = IHISL+1 | |
29570 | * check for maximum number of allowed histograms | |
29571 | IF (IHIS.GT.NHIS) THEN | |
29572 | WRITE(LOUT,1003) IHIS,NHIS,IHIS | |
29573 | 1003 FORMAT(1X,'NEWHGR: warning! number of histograms (', | |
29574 | & I4,') exceeds array size (',I4,')',/,21X, | |
29575 | & 'histogram',I3,' skipped!') | |
29576 | GOTO 9999 | |
29577 | ENDIF | |
29578 | ||
29579 | IREFN = IHIS | |
29580 | IBINS(IHIS) = ABS(IBIN) | |
29581 | * check requested number of bins | |
29582 | IF (IBINS(IHIS).GE.NDIM) THEN | |
29583 | WRITE(LOUT,1000) IBIN,NDIM,NDIM | |
29584 | 1000 FORMAT(1X,'NEWHGR: warning! number of bins (', | |
29585 | & I3,') exceeds array size (',I3,')',/,21X, | |
29586 | & 'and will be reset to ',I3) | |
29587 | IBINS(IHIS) = NDIM | |
29588 | ENDIF | |
29589 | IF (IBINS(IHIS).EQ.0) THEN | |
29590 | WRITE(LOUT,1001) IBIN,IHIS | |
29591 | 1001 FORMAT(1X,'NEWHGR: warning! inconsistent number of', | |
29592 | & ' bins (',I3,')',/,21X,'histogram',I3,' skipped!') | |
29593 | GOTO 9999 | |
29594 | ENDIF | |
29595 | ||
29596 | * initialize arrays | |
29597 | DO 1 I=1,NDIM | |
29598 | DO 2 K=1,3 | |
29599 | HIST(K,IHIS,I) = ZERO | |
29600 | HIST(K+3,IHIS,I) = ZERO | |
29601 | TMPHIS(K,IHIS,I) = ZERO | |
29602 | 2 CONTINUE | |
29603 | HIST(7,IHIS,I) = ZERO | |
29604 | 1 CONTINUE | |
29605 | DENTRY(1,IHIS)= ZERO | |
29606 | DENTRY(2,IHIS)= ZERO | |
29607 | OVERF(IHIS) = ZERO | |
29608 | UNDERF(IHIS) = ZERO | |
29609 | TMPUFL(IHIS) = ZERO | |
29610 | TMPOFL(IHIS) = ZERO | |
29611 | ||
29612 | * bin str. sensitive to lower edge, bin size, and numb. of bins | |
29613 | IF (XLIM3.GT.ZERO) THEN | |
29614 | DO 3 K=1,IBINS(IHIS)+1 | |
29615 | HIST(1,IHIS,K) = XLIM1+DBLE(K-1)*XLIM3 | |
29616 | 3 CONTINUE | |
29617 | ISWI(IHIS) = 1 | |
29618 | * bin str. sensitive to lower/upper edge and numb. of bins | |
29619 | ELSEIF (XLIM3.EQ.ZERO) THEN | |
29620 | * linear binning | |
29621 | IF (IBIN.GT.0) THEN | |
29622 | XLOW = XLIM1 | |
29623 | XHI = XLIM2 | |
29624 | IF (XLIM2.LE.XLIM1) THEN | |
29625 | WRITE(LOUT,1002) XLIM1,XLIM2 | |
29626 | 1002 FORMAT(1X,'NEWHGR: warning! inconsistent x-range', | |
29627 | & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')') | |
29628 | GOTO 9999 | |
29629 | ENDIF | |
29630 | ISWI(IHIS) = 1 | |
29631 | ELSEIF (IBIN.LT.-1) THEN | |
29632 | * logarithmic binning | |
29633 | IF ((XLIM1.LE.ZERO).OR.(XLIM2.LE.ZERO)) THEN | |
29634 | WRITE(LOUT,1004) XLIM1,XLIM2 | |
29635 | 1004 FORMAT(1X,'NEWHGR: warning! inconsistent log. ', | |
29636 | & 'binning',/,21X,'(XLIM1,XLIM2 = ',2E11.4,')') | |
29637 | GOTO 9999 | |
29638 | ENDIF | |
29639 | IF (XLIM2.LE.XLIM1) THEN | |
29640 | WRITE(LOUT,1005) XLIM1,XLIM2 | |
29641 | 1005 FORMAT(1X,'NEWHGR: warning! inconsistent x-range', | |
29642 | & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')') | |
29643 | GOTO 9999 | |
29644 | ENDIF | |
29645 | XLOW = LOG10(XLIM1) | |
29646 | XHI = LOG10(XLIM2) | |
29647 | ISWI(IHIS) = 3 | |
29648 | ENDIF | |
29649 | DX = ABS(XHI-XLOW)/DBLE(MAX(IBINS(IHIS),1)) | |
29650 | DO 4 K=1,IBINS(IHIS)+1 | |
29651 | HIST(1,IHIS,K) = XLOW+DBLE(K-1)*DX | |
29652 | 4 CONTINUE | |
29653 | ELSE | |
29654 | * user defined bin structure | |
29655 | DO 5 K=1,IBINS(IHIS)+1 | |
29656 | IF (IBIN.GT.0) THEN | |
29657 | HIST(1,IHIS,K) = XLIMB(K) | |
29658 | ISWI(IHIS) = 2 | |
29659 | ELSEIF (IBIN.LT.-1) THEN | |
29660 | HIST(1,IHIS,K) = LOG10(XLIMB(K)) | |
29661 | ISWI(IHIS) = 4 | |
29662 | ENDIF | |
29663 | 5 CONTINUE | |
29664 | ENDIF | |
29665 | ||
29666 | * histogram accepted | |
29667 | IHISL = IHIS | |
29668 | ||
29669 | RETURN | |
29670 | ||
29671 | 9999 CONTINUE | |
29672 | IREFN = -1 | |
29673 | RETURN | |
29674 | END | |
29675 | ||
29676 | *$ CREATE DT_FILHGR.FOR | |
29677 | *COPY DT_FILHGR | |
29678 | * | |
29679 | *===filhgr=============================================================* | |
29680 | * | |
29681 | SUBROUTINE DT_FILHGR(XI,YI,IHIS,NEVT) | |
29682 | ||
29683 | ************************************************************************ | |
29684 | * * | |
29685 | * Scoring for histogram IHIS. * | |
29686 | * * | |
29687 | * This subroutine is based on a original version by R. Engel. * | |
29688 | * This version dated 23.4.95 is written by S. Roesler. * | |
29689 | ************************************************************************ | |
29690 | ||
29691 | IMPLICIT DOUBLE PRECISION(A-H,O-Z) | |
29692 | SAVE | |
29693 | ||
29694 | PARAMETER ( LINP = 10 , | |
29695 | & LOUT = 6 , | |
29696 | & LDAT = 9 ) | |
29697 | ||
29698 | PARAMETER (ZERO = 0.0D0, | |
29699 | & ONE = 1.0D0, | |
29700 | & TINY = 1.0D-10) | |
29701 | ||
29702 | * histograms | |
29703 | ||
29704 | PARAMETER (NHIS=150, NDIM=250) | |
29705 | ||
29706 | COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS), | |
29707 | & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL | |
29708 | ||
29709 | * auxiliary common for histograms | |
29710 | COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS) | |
29711 | ||
29712 | DATA NCEVT /1/ | |
29713 | ||
29714 | X = XI | |
29715 | Y = YI | |
29716 | ||
29717 | * dump content of temorary arrays into histograms | |
29718 | IF ((NEVT.NE.NCEVT).OR.(NEVT.LT.0)) THEN | |
29719 | CALL DT_EVTHIS(IDUM) | |
29720 | NCEVT = NEVT | |
29721 | ENDIF | |
29722 | ||
29723 | * check histogram index | |
29724 | IF (IHIS.EQ.-1) RETURN | |
29725 | IF ((IHIS.LT.1).OR.(IHIS.GT.IHISL)) THEN | |
29726 | C WRITE(LOUT,1000) IHIS,IHISL | |
29727 | 1000 FORMAT(1X,'FILHGR: warning! histogram index',I4, | |
29728 | & ' out of range (1..',I3,')') | |
29729 | RETURN | |
29730 | ENDIF | |
29731 | ||
29732 | IF ((ISWI(IHIS).EQ.1).OR.(ISWI(IHIS).EQ.3)) THEN | |
29733 | * bin structure not explicitly given | |
29734 | IF ((ISWI(IHIS).EQ.3).AND.(X.GT.ZERO)) X = LOG10(X) | |
29735 | DX = ABS(HIST(1,IHIS,2)-HIST(1,IHIS,1)) | |
29736 | IF (X.LT.HIST(1,IHIS,1)) THEN | |
29737 | I1 = 0 | |
29738 | ELSE | |
29739 | I1 = INT( (X-HIST(1,IHIS,1))/MAX(DX,TINY) )+1 | |
29740 | ENDIF | |
29741 | ||
29742 | ELSEIF ((ISWI(IHIS).EQ.2).OR.(ISWI(IHIS).EQ.4)) THEN | |
29743 | * user defined bin structure | |
29744 | IF ((ISWI(IHIS).EQ.4).AND.(X.GT.ZERO)) X = LOG10(X) | |
29745 | IF (X.LT.HIST(1,IHIS,1)) THEN | |
29746 | I1 = 0 | |
29747 | ELSE IF (X.GT.HIST(1,IHIS,IBINS(IHIS)+1)) THEN | |
29748 | I1 = IBINS(IHIS)+1 | |
29749 | ELSE | |
29750 | * binary sort algorithm | |
29751 | KMIN = 0 | |
29752 | KMAX = IBINS(IHIS)+1 | |
29753 | 1 CONTINUE | |
29754 | IF ((KMAX-KMIN).EQ.1) GOTO 2 | |
29755 | KK = (KMAX+KMIN)/2 | |
29756 | IF (X.LE.HIST(1,IHIS,KK)) THEN | |
29757 | KMAX=KK | |
29758 | ELSE | |
29759 | KMIN=KK | |
29760 | ENDIF | |
29761 | GOTO 1 | |
29762 | 2 CONTINUE | |
29763 | I1 = KMIN | |
29764 | ENDIF | |
29765 | ||
29766 | ELSE | |
29767 | WRITE(LOUT,1001) | |
29768 | 1001 FORMAT(1X,'FILHGR: warning! histogram not initialized') | |
29769 | RETURN | |
29770 | ENDIF | |
29771 | ||
29772 | * scoring | |
29773 | IF (I1.LE.0) THEN | |
29774 | TMPUFL(IHIS) = TMPUFL(IHIS)+ONE | |
29775 | ELSEIF (I1.LE.IBINS(IHIS)) THEN | |
29776 | TMPHIS(1,IHIS,I1) = TMPHIS(1,IHIS,I1)+ONE | |
29777 | IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN | |
29778 | TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+10**X | |
29779 | ELSE | |
29780 | TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+X | |
29781 | ENDIF | |
29782 | TMPHIS(3,IHIS,I1) = TMPHIS(3,IHIS,I1)+Y | |
29783 | ELSE | |
29784 | TMPOFL(IHIS) = TMPOFL(IHIS)+ONE | |
29785 | ENDIF | |
29786 | ||
29787 | RETURN | |
29788 | END | |
29789 | ||
29790 | *$ CREATE DT_EVTHIS.FOR | |
29791 | *COPY DT_EVTHIS | |
29792 | * | |
29793 | *===evthis=============================================================* | |
29794 | * | |
29795 | SUBROUTINE DT_EVTHIS(NEVT) | |
29796 | ||
29797 | ************************************************************************ | |
29798 | * Dump content of temorary histograms into /DTHIS1/. This subroutine * | |
29799 | * is called after each event and for the last event before any call * | |
29800 | * to OUTHGR. * | |
29801 | * NEVT number of events dumped, this is only needed to * | |
29802 | * get the normalization after the last event * | |
29803 | * This version dated 23.4.95 is written by S. Roesler. * | |
29804 | ************************************************************************ | |
29805 | ||
29806 | IMPLICIT DOUBLE PRECISION(A-H,O-Z) | |
29807 | SAVE | |
29808 | ||
29809 | PARAMETER ( LINP = 10 , | |
29810 | & LOUT = 6 , | |
29811 | & LDAT = 9 ) | |
29812 | ||
29813 | LOGICAL LNOETY | |
29814 | ||
29815 | PARAMETER (ZERO = 0.0D0, | |
29816 | & ONE = 1.0D0, | |
29817 | & TINY = 1.0D-10) | |
29818 | ||
29819 | * histograms | |
29820 | ||
29821 | PARAMETER (NHIS=150, NDIM=250) | |
29822 | ||
29823 | COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS), | |
29824 | & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL | |
29825 | ||
29826 | * auxiliary common for histograms | |
29827 | COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS) | |
29828 | ||
29829 | DATA NCEVT /0/ | |
29830 | ||
29831 | NCEVT = NCEVT+1 | |
29832 | NEVT = NCEVT | |
29833 | ||
29834 | DO 1 I=1,IHISL | |
29835 | LNOETY = .TRUE. | |
29836 | DO 2 J=1,IBINS(I) | |
29837 | IF (TMPHIS(1,I,J).GT.ZERO) THEN | |
29838 | LNOETY = .FALSE. | |
29839 | HIST(2,I,J) = HIST(2,I,J)+ONE | |
29840 | HIST(7,I,J) = HIST(7,I,J)+TMPHIS(1,I,J) | |
29841 | DENTRY(2,I) = DENTRY(2,I)+TMPHIS(1,I,J) | |
29842 | AVX = TMPHIS(2,I,J)/TMPHIS(1,I,J) | |
29843 | HIST(3,I,J) = HIST(3,I,J)+TMPHIS(3,I,J)*AVX | |
29844 | HIST(4,I,J) = HIST(4,I,J)+TMPHIS(3,I,J)*AVX**2 | |
29845 | HIST(5,I,J) = HIST(5,I,J)+TMPHIS(3,I,J) | |
29846 | HIST(6,I,J) = HIST(6,I,J)+TMPHIS(3,I,J)**2 | |
29847 | TMPHIS(1,I,J) = ZERO | |
29848 | TMPHIS(2,I,J) = ZERO | |
29849 | TMPHIS(3,I,J) = ZERO | |
29850 | ENDIF | |
29851 | 2 CONTINUE | |
29852 | IF (LNOETY) THEN | |
29853 | IF (TMPUFL(I).GT.ZERO) THEN | |
29854 | UNDERF(I) = UNDERF(I)+ONE | |
29855 | TMPUFL(I) = ZERO | |
29856 | ELSEIF (TMPOFL(I).GT.ZERO) THEN | |
29857 | OVERF(I) = OVERF(I)+ONE | |
29858 | TMPOFL(I) = ZERO | |
29859 | ENDIF | |
29860 | ELSE | |
29861 | DENTRY(1,I) = DENTRY(1,I)+ONE | |
29862 | ENDIF | |
29863 | 1 CONTINUE | |
29864 | ||
29865 | RETURN | |
29866 | END | |
29867 | ||
29868 | *$ CREATE DT_OUTHGR.FOR | |
29869 | *COPY DT_OUTHGR | |
29870 | * | |
29871 | *===outhgr=============================================================* | |
29872 | * | |
29873 | SUBROUTINE DT_OUTHGR(I1,I2,I3,I4,I5,I6,CHEAD,IHEAD,NEVTS,FAC, | |
29874 | & ILOGY,INORM,NMODE) | |
29875 | ||
29876 | ************************************************************************ | |
29877 | * * | |
29878 | * Plot histogram(s) to standard output unit * | |
29879 | * * | |
29880 | * I1..6 indices of histograms to be plotted * | |
29881 | * CHEAD,IHEAD header string,integer * | |
29882 | * NEVTS number of events * | |
29883 | * FAC scaling factor * | |
29884 | * ILOGY = 1 logarithmic y-axis * | |
29885 | * INORM normalization * | |
29886 | * = 0 no further normalization (FAC is obsolete) * | |
29887 | * = 1 per event and bin width * | |
29888 | * = 2 per entry and bin width * | |
29889 | * = 3 per bin entry * | |
29890 | * = 4 per event and "bin width" x1^2...x2^2 * | |
29891 | * = 5 per event and "log. bin width" ln x1..ln x2 * | |
29892 | * = 6 per event * | |
29893 | * MODE = 0 no output but normalization applied * | |
29894 | * = 1 all valid histograms separately (small frame) * | |
29895 | * all valid histograms separately (small frame) * | |
29896 | * = -1 and tables as histograms * | |
29897 | * = 2 all valid histograms (one plot, wide frame) * | |
29898 | * all valid histograms (one plot, wide frame) * | |
29899 | * = -2 and tables as histograms * | |
29900 | * * | |
29901 | * * | |
29902 | * Note: All histograms to be plotted with one call to this * | |
29903 | * subroutine and |MODE|=2 must have the same bin structure! * | |
29904 | * There is no test included ensuring this fact. * | |
29905 | * * | |
29906 | * This version dated 23.4.95 is written by S. Roesler. * | |
29907 | ************************************************************************ | |
29908 | ||
29909 | IMPLICIT DOUBLE PRECISION(A-H,O-Z) | |
29910 | SAVE | |
29911 | ||
29912 | PARAMETER ( LINP = 10 , | |
29913 | & LOUT = 6 , | |
29914 | & LDAT = 9 ) | |
29915 | ||
29916 | CHARACTER*72 CHEAD | |
29917 | ||
29918 | PARAMETER (ZERO = 0.0D0, | |
29919 | & IZERO = 0, | |
29920 | & ONE = 1.0D0, | |
29921 | & TWO = 2.0D0, | |
29922 | & OHALF = 0.5D0, | |
29923 | & EPS = 1.0D-5, | |
29924 | & TINY = 1.0D-8, | |
29925 | & SMALL = -1.0D8, | |
29926 | & RLARGE = 1.0D8 ) | |
29927 | ||
29928 | * histograms | |
29929 | ||
29930 | PARAMETER (NHIS=150, NDIM=250) | |
29931 | ||
29932 | COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS), | |
29933 | & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL | |
29934 | ||
29935 | PARAMETER (NDIM2 = 2*NDIM) | |
29936 | DIMENSION XX(NDIM2),YY(NDIM2) | |
29937 | ||
29938 | PARAMETER (NHISTO = 6) | |
29939 | DIMENSION YY1(NDIM,NHISTO),XX1(NDIM,NHISTO),IDX1(NHISTO), | |
29940 | & IDX(NHISTO) | |
29941 | ||
29942 | CHARACTER*43 CNORM(0:8) | |
29943 | DATA CNORM /'no further normalization ', | |
29944 | & 'per event and bin width ', | |
29945 | & 'per entry1 and bin width ', | |
29946 | & 'per bin entry ', | |
29947 | & 'per event and "bin width" x1^2...x2^2 ', | |
29948 | & 'per event and "log. bin width" ln x1..ln x2', | |
29949 | & 'per event ', | |
29950 | & 'per bin entry1 ', | |
29951 | & 'per entry2 and bin width '/ | |
29952 | ||
29953 | IDX1(1) = I1 | |
29954 | IDX1(2) = I2 | |
29955 | IDX1(3) = I3 | |
29956 | IDX1(4) = I4 | |
29957 | IDX1(5) = I5 | |
29958 | IDX1(6) = I6 | |
29959 | ||
29960 | MODE = NMODE | |
29961 | ||
29962 | * initialization if "wide frame" is requested | |
29963 | IF (ABS(MODE).EQ.2) THEN | |
29964 | DO 1 I=1,NHISTO | |
29965 | DO 2 J=1,NDIM | |
29966 | XX1(J,I) = ZERO | |
29967 | YY1(J,I) = ZERO | |
29968 | 2 CONTINUE | |
29969 | 1 CONTINUE | |
29970 | ENDIF | |
29971 | ||
29972 | * plot header | |
29973 | WRITE(LOUT,'(/1X,A,I3,/,1X,70A1)') CHEAD,IHEAD,('=',II=1,70) | |
29974 | ||
29975 | * check histogram indices | |
29976 | NHI = 0 | |
29977 | DO 3 I=1,NHISTO | |
29978 | IF ((IDX1(I).GE.1).AND.(IDX1(I).LE.IHISL)) THEN | |
29979 | IF (ISWI(IDX1(I)).NE.0) THEN | |
29980 | IF (DENTRY(1,IDX1(I)).LT.ONE) THEN | |
29981 | WRITE(LOUT,1000) | |
29982 | & IDX1(I),UNDERF(IDX1(I)),OVERF(IDX1(I)) | |
29983 | 1000 FORMAT(/,1X,'OUTHGR: warning! no entries in', | |
29984 | & ' histogram ',I3,/,21X,'underflows:',F10.0, | |
29985 | & ' overflows: ',F10.0) | |
29986 | ELSE | |
29987 | NHI = NHI+1 | |
29988 | IDX(NHI) = IDX1(I) | |
29989 | ENDIF | |
29990 | ENDIF | |
29991 | ENDIF | |
29992 | 3 CONTINUE | |
29993 | IF (NHI.EQ.0) THEN | |
29994 | WRITE(LOUT,1001) | |
29995 | 1001 FORMAT(/,1X,'OUTHGR: warning! histogram indices not valid') | |
29996 | RETURN | |
29997 | ENDIF | |
29998 | ||
29999 | * check normalization request | |
30000 | IF ( ((FAC.EQ.ZERO).AND.(INORM.NE.0)).OR. | |
30001 | & ((NEVTS.LT.1).AND.((INORM.EQ.1).OR.(INORM.EQ.4).OR. | |
30002 | & (INORM.EQ.5).OR.(INORM.EQ.6))).OR. | |
30003 | & (INORM.LT.0).OR.(INORM.GT.8) ) THEN | |
30004 | WRITE(LOUT,1002) NEVTS,INORM,FAC | |
30005 | 1002 FORMAT(/,1X,'OUTHGR: warning! normalization request not ', | |
30006 | & 'valid',/,21X,'NEVTS = ',I7,4X,'INORM = ',I2,4X, | |
30007 | & 'FAC = ',E11.4) | |
30008 | RETURN | |
30009 | ENDIF | |
30010 | ||
30011 | WRITE(LOUT,'(/,1X,A,I8)') 'number of events:',NEVTS | |
30012 | ||
30013 | * apply normalization | |
30014 | DO 4 N=1,NHI | |
30015 | ||
30016 | I = IDX(N) | |
30017 | ||
30018 | IF (ISWI(I).EQ.1) THEN | |
30019 | WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I) | |
30020 | 1003 FORMAT(/,1X,'histo.',I4,', linear binning from',2X,E10.4, | |
30021 | & ' to',2X,E10.4,',',2X,I3,' bins') | |
30022 | ELSEIF (ISWI(I).EQ.2) THEN | |
30023 | WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I) | |
30024 | WRITE(LOUT,1007) | |
30025 | 1007 FORMAT(1X,'user defined bin structure') | |
30026 | ELSEIF (ISWI(I).EQ.3) THEN | |
30027 | WRITE(LOUT,1004) | |
30028 | & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I) | |
30029 | 1004 FORMAT(/,1X,'histo.',I4,', logar. binning from',2X,E10.4, | |
30030 | & ' to',2X,E10.4,',',2X,I3,' bins') | |
30031 | ELSEIF (ISWI(I).EQ.4) THEN | |
30032 | WRITE(LOUT,1004) | |
30033 | & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I) | |
30034 | WRITE(LOUT,1007) | |
30035 | ELSE | |
30036 | WRITE(LOUT,1008) ISWI(I) | |
30037 | 1008 FORMAT(/,1X,'warning! inconsistent bin structure flag ',I4) | |
30038 | ENDIF | |
30039 | WRITE(LOUT,1005) DENTRY(1,I),DENTRY(2,I),UNDERF(I),OVERF(I) | |
30040 | 1005 FORMAT(13X,'entries:',2F9.0,' underfl.:',F8.0, | |
30041 | & ' overfl.:',F8.0) | |
30042 | WRITE(LOUT,1009) CNORM(INORM) | |
30043 | 1009 FORMAT(1X,'normalization: ',A,/) | |
30044 | ||
30045 | DO 5 K=1,IBINS(I) | |
30046 | CALL DT_GETBIN(I,K,NEVTS,INORM,XLOW,XHI,XMEAN,YMEAN,YERR) | |
30047 | YMEAN = FAC*YMEAN | |
30048 | YERR = FAC*YERR | |
30049 | WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,YERR,HIST(2,I,K) | |
30050 | WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,YERR,HIST(2,I,K) | |
30051 | 1006 FORMAT(1X,5E11.3) | |
30052 | * small frame | |
30053 | II = 2*K | |
30054 | XX(II-1) = HIST(1,I,K) | |
30055 | XX(II) = HIST(1,I,K+1) | |
30056 | YY(II-1) = YMEAN | |
30057 | YY(II) = YMEAN | |
30058 | * wide frame | |
30059 | XX1(K,N) = XMEAN | |
30060 | IF ((ISWI(I).EQ.3).OR.(ISWI(I).EQ.4)) | |
30061 | & XX1(K,N) = LOG10(XMEAN) | |
30062 | YY1(K,N) = YMEAN | |
30063 | 5 CONTINUE | |
30064 | ||
30065 | * plot small frame | |
30066 | IF (ABS(MODE).EQ.1) THEN | |
30067 | IBIN2 = 2*IBINS(I) | |
30068 | WRITE(LOUT,'(/,1X,A)') 'Preview:' | |
30069 | IF(ILOGY.EQ.1) THEN | |
30070 | CALL DT_XGLOGY(IBIN2,1,XX,YY,YY) | |
30071 | ELSE | |
30072 | CALL DT_XGRAPH(IBIN2,1,XX,YY,YY) | |
30073 | ENDIF | |
30074 | ENDIF | |
30075 | ||
30076 | 4 CONTINUE | |
30077 | ||
30078 | * plot wide frame | |
30079 | IF (ABS(MODE).EQ.2) THEN | |
30080 | WRITE(LOUT,'(/,1X,A)') 'Preview:' | |
30081 | NSIZE = NDIM*NHISTO | |
30082 | DXLOW = HIST(1,IDX(1),1) | |
30083 | DDX = ABS(HIST(1,IDX(1),2)-HIST(1,IDX(1),1)) | |
30084 | YLOW = RLARGE | |
30085 | YHI = SMALL | |
30086 | DO 6 I=1,NHISTO | |
30087 | DO 7 J=1,NDIM | |
30088 | IF (YY1(J,I).LT.YLOW) THEN | |
30089 | IF (ILOGY.EQ.1) THEN | |
30090 | IF (YY1(J,I).GT.ZERO) YLOW = YY1(J,I) | |
30091 | ELSE | |
30092 | YLOW = YY1(J,I) | |
30093 | ENDIF | |
30094 | ENDIF | |
30095 | IF (YY1(J,I).GT.YHI) YHI = YY1(J,I) | |
30096 | 7 CONTINUE | |
30097 | 6 CONTINUE | |
30098 | DY = (YHI-YLOW)/DBLE(NDIM) | |
30099 | IF (DY.LE.ZERO) THEN | |
30100 | WRITE(LOUT,'(1X,A,6I4,A,2E12.4)') | |
30101 | & 'OUTHGR: warning! zero bin width for histograms ', | |
30102 | & IDX,': ',YLOW,YHI | |
30103 | RETURN | |
30104 | ENDIF | |
30105 | IF (ILOGY.EQ.1) THEN | |
30106 | YLOW = LOG10(YLOW) | |
30107 | DY = (LOG10(YHI)-YLOW)/100.0D0 | |
30108 | DO 8 I=1,NHISTO | |
30109 | DO 9 J=1,NDIM | |
30110 | IF (YY1(J,I).LE.ZERO) THEN | |
30111 | YY1(J,I) = YLOW | |
30112 | ELSE | |
30113 | YY1(J,I) = LOG10(YY1(J,I)) | |
30114 | ENDIF | |
30115 | 9 CONTINUE | |
30116 | 8 CONTINUE | |
30117 | ENDIF | |
30118 | CALL DT_SRPLOT(XX1,YY1,NSIZE,NHISTO,NDIM,DXLOW,DDX,YLOW,DY) | |
30119 | ENDIF | |
30120 | ||
30121 | RETURN | |
30122 | END | |
30123 | ||
30124 | *$ CREATE DT_GETBIN.FOR | |
30125 | *COPY DT_GETBIN | |
30126 | * | |
30127 | *===getbin=============================================================* | |
30128 | * | |
30129 | SUBROUTINE DT_GETBIN(IHIS,IBIN,KEVT,NORM,XLOW,XHI, | |
30130 | & XMEAN,YMEAN,YERR) | |
30131 | ||
30132 | ************************************************************************ | |
30133 | * This version dated 23.4.95 is written by S. Roesler. * | |
30134 | ************************************************************************ | |
30135 | ||
30136 | IMPLICIT DOUBLE PRECISION(A-H,O-Z) | |
30137 | SAVE | |
30138 | ||
30139 | PARAMETER ( LINP = 10 , | |
30140 | & LOUT = 6 , | |
30141 | & LDAT = 9 ) | |
30142 | ||
30143 | PARAMETER (ZERO = 0.0D0, | |
30144 | & ONE = 1.0D0, | |
30145 | & TINY35 = 1.0D-35) | |
30146 | ||
30147 | * histograms | |
30148 | ||
30149 | PARAMETER (NHIS=150, NDIM=250) | |
30150 | ||
30151 | COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS), | |
30152 | & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL | |
30153 | ||
30154 | XLOW = HIST(1,IHIS,IBIN) | |
30155 | XHI = HIST(1,IHIS,IBIN+1) | |
30156 | IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN | |
30157 | XLOW = 10**XLOW | |
30158 | XHI = 10**XHI | |
30159 | ENDIF | |
30160 | IF (NORM.EQ.2) THEN | |
30161 | DX = XHI-XLOW | |
30162 | NEVT = INT(DENTRY(1,IHIS)) | |
30163 | ELSEIF (NORM.EQ.3) THEN | |
30164 | DX = ONE | |
30165 | NEVT = INT(HIST(2,IHIS,IBIN)) | |
30166 | ELSEIF (NORM.EQ.4) THEN | |
30167 | DX = XHI**2-XLOW**2 | |
30168 | NEVT = KEVT | |
30169 | ELSEIF (NORM.EQ.5) THEN | |
30170 | DX = LOG(ABS(XHI))-LOG(ABS(XLOW)) | |
30171 | NEVT = KEVT | |
30172 | ELSEIF (NORM.EQ.6) THEN | |
30173 | DX = ONE | |
30174 | NEVT = KEVT | |
30175 | ELSEIF (NORM.EQ.7) THEN | |
30176 | DX = ONE | |
30177 | NEVT = INT(HIST(7,IHIS,IBIN)) | |
30178 | ELSEIF (NORM.EQ.8) THEN | |
30179 | DX = XHI-XLOW | |
30180 | NEVT = INT(DENTRY(2,IHIS)) | |
30181 | ELSE | |
30182 | DX = ABS(XHI-XLOW) | |
30183 | NEVT = KEVT | |
30184 | ENDIF | |
30185 | IF (ABS(DX).LT.TINY35) DX = ONE | |
30186 | NEVT = MAX(NEVT,1) | |
30187 | YMEAN = HIST(5,IHIS,IBIN)/DX/DBLE(NEVT) | |
30188 | YMEAN2 = HIST(6,IHIS,IBIN)/DX**2/DBLE(NEVT) | |
30189 | YERR = SQRT(ABS(YMEAN2-YMEAN**2))/SQRT(DBLE(NEVT)) | |
30190 | YSUM = HIST(5,IHIS,IBIN) | |
30191 | IF (ABS(YSUM).LT.TINY35) YSUM = ONE | |
30192 | C XMEAN = HIST(3,IHIS,IBIN)/YSUM/MAX(HIST(2,IHIS,IBIN),ONE) | |
30193 | XMEAN = HIST(3,IHIS,IBIN)/YSUM | |
30194 | IF (XMEAN.EQ.ZERO) XMEAN = XLOW | |
30195 | ||
30196 | RETURN | |
30197 | END | |
30198 | ||
30199 | *$ CREATE DT_JOIHIS.FOR | |
30200 | *COPY DT_JOIHIS | |
30201 | * | |
30202 | *===joihis=============================================================* | |
30203 | * | |
30204 | SUBROUTINE DT_JOIHIS(IH1,IH2,COPER,FAC1,FAC2,KEVT,NORM,ILOGY,MODE) | |
30205 | ||
30206 | ************************************************************************ | |
30207 | * * | |
30208 | * Operation on histograms. * | |
30209 | * * | |
30210 | * input: IH1,IH2 histogram indices to be joined * | |
30211 | * COPER character defining the requested operation, * | |
30212 | * i.e. '+', '-', '*', '/' * | |
30213 | * FAC1,FAC2 factors for joining, i.e. * | |
30214 | * FAC1*histo1 COPER FAC2*histo2 * | |
30215 | * * | |
30216 | * This version dated 23.4.95 is written by S. Roesler. * | |
30217 | ************************************************************************ | |
30218 | ||
30219 | IMPLICIT DOUBLE PRECISION(A-H,O-Z) | |
30220 | SAVE | |
30221 | ||
30222 | PARAMETER ( LINP = 10 , | |
30223 | & LOUT = 6 , | |
30224 | & LDAT = 9 ) | |
30225 | ||
30226 | CHARACTER COPER*1 | |
30227 | ||
30228 | PARAMETER (ZERO = 0.0D0, | |
30229 | & ONE = 1.0D0, | |
30230 | & OHALF = 0.5D0, | |
30231 | & TINY8 = 1.0D-8, | |
30232 | & SMALL = -1.0D8, | |
30233 | & RLARGE = 1.0D8 ) | |
30234 | ||
30235 | * histograms | |
30236 | ||
30237 | PARAMETER (NHIS=150, NDIM=250) | |
30238 | ||
30239 | COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS), | |
30240 | & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL | |
30241 | ||
30242 | PARAMETER (NDIM2 = 2*NDIM) | |
30243 | DIMENSION XX(NDIM2),YY(NDIM2),YY1(NDIM),XX1(NDIM) | |
30244 | ||
30245 | CHARACTER*43 CNORM(0:6) | |
30246 | DATA CNORM /'no further normalization ', | |
30247 | & 'per event and bin width ', | |
30248 | & 'per entry and bin width ', | |
30249 | & 'per bin entry ', | |
30250 | & 'per event and "bin width" x1^2...x2^2 ', | |
30251 | & 'per event and "log. bin width" ln x1..ln x2', | |
30252 | & 'per event '/ | |
30253 | ||
30254 | * check histogram indices | |
30255 | IF ((IH1.LT. 1).OR.(IH2.LT. 1).OR. | |
30256 | & (IH1.GT.IHISL).OR.(IH2.GT.IHISL)) THEN | |
30257 | WRITE(LOUT,1000) IH1,IH2,IHISL | |
30258 | 1000 FORMAT(1X,'JOIHIS: warning! inconsistent histogram ', | |
30259 | & 'indices (',I3,',',I3,'),',/,21X,'valid range: 1,',I3) | |
30260 | GOTO 9999 | |
30261 | ENDIF | |
30262 | ||
30263 | * check bin structure of histograms to be joined | |
30264 | IF (IBINS(IH1).NE.IBINS(IH2)) THEN | |
30265 | WRITE(LOUT,1001) IH1,IH2,IBINS(IH1),IBINS(IH2) | |
30266 | 1001 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3, | |
30267 | & ' and ',I3,' failed',/,21X, | |
30268 | & 'due to different numbers of bins (',I3,',',I3,')') | |
30269 | GOTO 9999 | |
30270 | ENDIF | |
30271 | DO 1 K=1,IBINS(IH1)+1 | |
30272 | IF (ABS(HIST(1,IH1,K)-HIST(1,IH2,K)).GT.TINY8) THEN | |
30273 | WRITE(LOUT,1002) IH1,IH2,K,HIST(1,IH1,K),HIST(1,IH2,K) | |
30274 | 1002 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3, | |
30275 | & ' and ',I3,' failed at bin edge ',I3,/,21X, | |
30276 | & 'X1,X2 = ',2E11.4) | |
30277 | GOTO 9999 | |
30278 | ENDIF | |
30279 | 1 CONTINUE | |
30280 | ||
30281 | WRITE(LOUT,1003) IH1,IH2,COPER,FAC1,FAC2 | |
30282 | 1003 FORMAT(1X,'JOIHIS: joining histograms ',I3,',',I3,' with ', | |
30283 | & 'operation ',A,/,11X,'and factors ',2E11.4) | |
30284 | WRITE(LOUT,1004) CNORM(NORM) | |
30285 | 1004 FORMAT(1X,'normalization: ',A,/) | |
30286 | ||
30287 | DO 2 K=1,IBINS(IH1) | |
30288 | CALL DT_GETBIN(IH1,K,KEVT,NORM,XLOW1,XHI1,XMEAN1,YMEAN1,YERR1) | |
30289 | CALL DT_GETBIN(IH2,K,KEVT,NORM,XLOW2,XHI2,XMEAN2,YMEAN2,YERR2) | |
30290 | XLOW = XLOW1 | |
30291 | XHI = XHI1 | |
30292 | XMEAN = OHALF*(XMEAN1+XMEAN2) | |
30293 | IF (COPER.EQ.'+') THEN | |
30294 | YMEAN = FAC1*YMEAN1+FAC2*YMEAN2 | |
30295 | ELSEIF (COPER.EQ.'*') THEN | |
30296 | YMEAN = FAC1*YMEAN1*FAC2*YMEAN2 | |
30297 | ELSEIF (COPER.EQ.'/') THEN | |
30298 | IF (YMEAN2.EQ.ZERO) THEN | |
30299 | YMEAN = ZERO | |
30300 | ELSE | |
30301 | IF (FAC2.EQ.ZERO) FAC2 = ONE | |
30302 | YMEAN = FAC1*YMEAN1/(FAC2*YMEAN2) | |
30303 | ENDIF | |
30304 | ELSE | |
30305 | GOTO 9998 | |
30306 | ENDIF | |
30307 | WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K) | |
30308 | WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K) | |
30309 | 1006 FORMAT(1X,5E11.3) | |
30310 | * small frame | |
30311 | II = 2*K | |
30312 | XX(II-1) = HIST(1,IH1,K) | |
30313 | XX(II) = HIST(1,IH1,K+1) | |
30314 | YY(II-1) = YMEAN | |
30315 | YY(II) = YMEAN | |
30316 | * wide frame | |
30317 | XX1(K) = XMEAN | |
30318 | IF ((ISWI(IH1).EQ.3).OR.(ISWI(IH1).EQ.4)) XX1(K) = LOG10(XMEAN) | |
30319 | YY1(K) = YMEAN | |
30320 | 2 CONTINUE | |
30321 | ||
30322 | * plot small frame | |
30323 | IF (ABS(MODE).EQ.1) THEN | |
30324 | IBIN2 = 2*IBINS(IH1) | |
30325 | WRITE(LOUT,'(/,1X,A)') 'Preview:' | |
30326 | IF(ILOGY.EQ.1) THEN | |
30327 | CALL DT_XGLOGY(IBIN2,1,XX,YY,YY) | |
30328 | ELSE | |
30329 | CALL DT_XGRAPH(IBIN2,1,XX,YY,YY) | |
30330 | ENDIF | |
30331 | ENDIF | |
30332 | ||
30333 | * plot wide frame | |
30334 | IF (ABS(MODE).EQ.2) THEN | |
30335 | WRITE(LOUT,'(/,1X,A)') 'Preview:' | |
30336 | NSIZE = NDIM | |
30337 | DXLOW = HIST(1,IH1,1) | |
30338 | DDX = ABS(HIST(1,IH1,2)-HIST(1,IH1,1)) | |
30339 | YLOW = RLARGE | |
30340 | YHI = SMALL | |
30341 | DO 3 I=1,NDIM | |
30342 | IF (YY1(I).LT.YLOW) THEN | |
30343 | IF (ILOGY.EQ.1) THEN | |
30344 | IF (YY1(I).GT.ZERO) YLOW = YY1(I) | |
30345 | ELSE | |
30346 | YLOW = YY1(I) | |
30347 | ENDIF | |
30348 | ENDIF | |
30349 | IF (YY1(I).GT.YHI) YHI = YY1(I) | |
30350 | 3 CONTINUE | |
30351 | DY = (YHI-YLOW)/DBLE(NDIM) | |
30352 | IF (DY.LE.ZERO) THEN | |
30353 | WRITE(LOUT,'(1X,A,2I4,A,2E12.4)') | |
30354 | & 'JOIHIS: warning! zero bin width for histograms ', | |
30355 | & IH1,IH2,': ',YLOW,YHI | |
30356 | RETURN | |
30357 | ENDIF | |
30358 | IF (ILOGY.EQ.1) THEN | |
30359 | YLOW = LOG10(YLOW) | |
30360 | DY = (LOG10(YHI)-YLOW)/100.0D0 | |
30361 | DO 4 I=1,NDIM | |
30362 | IF (YY1(I).LE.ZERO) THEN | |
30363 | YY1(I) = YLOW | |
30364 | ELSE | |
30365 | YY1(I) = LOG10(YY1(I)) | |
30366 | ENDIF | |
30367 | 4 CONTINUE | |
30368 | ENDIF | |
30369 | CALL DT_SRPLOT(XX1,YY1,NSIZE,1,NDIM,DXLOW,DDX,YLOW,DY) | |
30370 | ENDIF | |
30371 | ||
30372 | RETURN | |
30373 | ||
30374 | 9998 CONTINUE | |
30375 | WRITE(LOUT,1005) COPER | |
30376 | 1005 FORMAT(1X,'JOIHIS: unknown operation ',A) | |
30377 | ||
30378 | 9999 CONTINUE | |
30379 | RETURN | |
30380 | END | |
30381 | ||
30382 | *$ CREATE DT_XGRAPH.FOR | |
30383 | *COPY DT_XGRAPH | |
30384 | * | |
30385 | *===qgraph=============================================================* | |
30386 | * | |
30387 | SUBROUTINE DT_XGRAPH(N,IARG,X,Y1,Y2) | |
30388 | C*********************************************************************** | |
30389 | C | |
30390 | C calculate quasi graphic picture with 25 lines and 79 columns | |
30391 | C ranges will be chosen automatically | |
30392 | C | |
30393 | C input N dimension of input fields | |
30394 | C IARG number of curves (fields) to plot | |
30395 | C X field of X | |
30396 | C Y1 field of Y1 | |
30397 | C Y2 field of Y2 | |
30398 | C | |
30399 | C This subroutine is written by R. Engel. | |
30400 | C*********************************************************************** | |
30401 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
30402 | SAVE | |
30403 | ||
30404 | PARAMETER ( LINP = 10 , | |
30405 | & LOUT = 6 , | |
30406 | & LDAT = 9 ) | |
30407 | ||
30408 | C | |
30409 | DIMENSION X(N),Y1(N),Y2(N) | |
30410 | PARAMETER (EPS=1.D-30) | |
30411 | PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20) | |
30412 | CHARACTER SYMB(5) | |
30413 | CHARACTER COL(0:149,0:49) | |
30414 | C | |
30415 | DATA SYMB /'0','e','z','#','x'/ | |
30416 | C | |
30417 | ISPALT=IBREIT-10 | |
30418 | C | |
30419 | C*** automatic range fitting | |
30420 | C | |
30421 | XMAX=X(1) | |
30422 | XMIN=X(1) | |
30423 | DO 600 I=1,N | |
30424 | XMAX=MAX(X(I),XMAX) | |
30425 | XMIN=MIN(X(I),XMIN) | |
30426 | 600 CONTINUE | |
30427 | XZOOM=(XMAX-XMIN)/DBLE(ISPALT) | |
30428 | C | |
30429 | ITEST=0 | |
30430 | DO 1100 K=0,IZEIL-1 | |
30431 | ITEST=ITEST+1 | |
30432 | IF (ITEST.EQ.IYRAST) THEN | |
30433 | DO 1010 L=1,ISPALT-1 | |
30434 | COL(L,K)='-' | |
30435 | 1010 CONTINUE | |
30436 | COL(ISPALT,K)='+' | |
30437 | ITEST=0 | |
30438 | DO 1020 L=0,ISPALT-1,IXRAST | |
30439 | COL(L,K)='+' | |
30440 | 1020 CONTINUE | |
30441 | ELSE | |
30442 | DO 1030 L=1,ISPALT-1 | |
30443 | COL(L,K)=' ' | |
30444 | 1030 CONTINUE | |
30445 | DO 1040 L=0,ISPALT-1,IXRAST | |
30446 | COL(L,K)='|' | |
30447 | 1040 CONTINUE | |
30448 | COL(ISPALT,K)='|' | |
30449 | ENDIF | |
30450 | 1100 CONTINUE | |
30451 | C | |
30452 | C*** plot curve Y1 | |
30453 | C | |
30454 | YMAX=Y1(1) | |
30455 | YMIN=Y1(1) | |
30456 | DO 500 I=1,N | |
30457 | YMAX=MAX(Y1(I),YMAX) | |
30458 | YMIN=MIN(Y1(I),YMIN) | |
30459 | 500 CONTINUE | |
30460 | IF(IARG.GT.1) THEN | |
30461 | DO 550 I=1,N | |
30462 | YMAX=MAX(Y2(I),YMAX) | |
30463 | YMIN=MIN(Y2(I),YMIN) | |
30464 | 550 CONTINUE | |
30465 | ENDIF | |
30466 | YMAX=(YMAX-YMIN)/40.0D0+YMAX | |
30467 | YMIN=YMIN-(YMAX-YMIN)/40.0D0 | |
30468 | YZOOM=(YMAX-YMIN)/DBLE(IZEIL) | |
30469 | IF(YZOOM.LT.EPS) THEN | |
30470 | WRITE(LOUT,'(1X,A)') | |
30471 | & 'XGRAPH:WARNING: MIN = MAX, OUTPUT SUPPRESSED' | |
30472 | RETURN | |
30473 | ENDIF | |
30474 | C | |
30475 | C*** plot curve Y1 | |
30476 | C | |
30477 | ILAST=-1 | |
30478 | LLAST=-1 | |
30479 | DO 1200 K=1,N | |
30480 | L=NINT((X(K)-XMIN)/XZOOM) | |
30481 | I=NINT((YMAX-Y1(K))/YZOOM) | |
30482 | IF(ILAST.GE.0) THEN | |
30483 | LD = L-LLAST | |
30484 | ID = I-ILAST | |
30485 | DO 55 II=0,LD,SIGN(1,LD) | |
30486 | DO 66 KK=0,ID,SIGN(1,ID) | |
30487 | COL(II+LLAST,KK+ILAST)=SYMB(1) | |
30488 | 66 CONTINUE | |
30489 | 55 CONTINUE | |
30490 | ELSE | |
30491 | COL(L,I)=SYMB(1) | |
30492 | ENDIF | |
30493 | ILAST = I | |
30494 | LLAST = L | |
30495 | 1200 CONTINUE | |
30496 | C | |
30497 | IF(IARG.GT.1) THEN | |
30498 | C | |
30499 | C*** plot curve Y2 | |
30500 | C | |
30501 | DO 1250 K=1,N | |
30502 | L=NINT((X(K)-XMIN)/XZOOM) | |
30503 | I=NINT((YMAX-Y2(K))/YZOOM) | |
30504 | COL(L,I)=SYMB(2) | |
30505 | 1250 CONTINUE | |
30506 | ENDIF | |
30507 | C | |
30508 | C*** write it | |
30509 | C | |
30510 | WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT) | |
30511 | C | |
30512 | C*** write range of X | |
30513 | C | |
30514 | XZOOM = (XMAX-XMIN)/DBLE(7) | |
30515 | WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7) | |
30516 | C | |
30517 | DO 1300 K=0,IZEIL-1 | |
30518 | YPOS=YMAX-((DBLE(K)+0.5D0)*YZOOM) | |
30519 | WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT) | |
30520 | 110 FORMAT(1X,1PE9.2,70A1) | |
30521 | 1300 CONTINUE | |
30522 | C | |
30523 | C*** write range of X | |
30524 | C | |
30525 | XZOOM = (XMAX-XMIN)/DBLE(7) | |
30526 | WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7) | |
30527 | WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT) | |
30528 | 120 FORMAT(6X,7(1PE10.3)) | |
30529 | END | |
30530 | ||
30531 | *$ CREATE DT_XGLOGY.FOR | |
30532 | *COPY DT_XGLOGY | |
30533 | * | |
30534 | *===qglogy=============================================================* | |
30535 | * | |
30536 | SUBROUTINE DT_XGLOGY(N,IARG,X,Y1,Y2) | |
30537 | C*********************************************************************** | |
30538 | C | |
30539 | C calculate quasi graphic picture with 25 lines and 79 columns | |
30540 | C logarithmic y axis | |
30541 | C ranges will be chosen automatically | |
30542 | C | |
30543 | C input N dimension of input fields | |
30544 | C IARG number of curves (fields) to plot | |
30545 | C X field of X | |
30546 | C Y1 field of Y1 | |
30547 | C Y2 field of Y2 | |
30548 | C | |
30549 | C This subroutine is written by R. Engel. | |
30550 | C*********************************************************************** | |
30551 | C | |
30552 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
30553 | SAVE | |
30554 | ||
30555 | PARAMETER ( LINP = 10 , | |
30556 | & LOUT = 6 , | |
30557 | & LDAT = 9 ) | |
30558 | ||
30559 | DIMENSION X(N),Y1(N),Y2(N) | |
30560 | PARAMETER (EPS=1.D-30) | |
30561 | PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20) | |
30562 | CHARACTER SYMB(5) | |
30563 | CHARACTER COL(0:149,0:49) | |
30564 | PARAMETER (DEPS = 1.D-10) | |
30565 | C | |
30566 | DATA SYMB /'0','e','z','#','x'/ | |
30567 | C | |
30568 | ISPALT=IBREIT-10 | |
30569 | C | |
30570 | C*** automatic range fitting | |
30571 | C | |
30572 | XMAX=X(1) | |
30573 | XMIN=X(1) | |
30574 | DO 600 I=1,N | |
30575 | XMAX=MAX(X(I),XMAX) | |
30576 | XMIN=MIN(X(I),XMIN) | |
30577 | 600 CONTINUE | |
30578 | XZOOM=(XMAX-XMIN)/DBLE(ISPALT) | |
30579 | C | |
30580 | ITEST=0 | |
30581 | DO 1100 K=0,IZEIL-1 | |
30582 | ITEST=ITEST+1 | |
30583 | IF (ITEST.EQ.IYRAST) THEN | |
30584 | DO 1010 L=1,ISPALT-1 | |
30585 | COL(L,K)='-' | |
30586 | 1010 CONTINUE | |
30587 | COL(ISPALT,K)='+' | |
30588 | ITEST=0 | |
30589 | DO 1020 L=0,ISPALT-1,IXRAST | |
30590 | COL(L,K)='+' | |
30591 | 1020 CONTINUE | |
30592 | ELSE | |
30593 | DO 1030 L=1,ISPALT-1 | |
30594 | COL(L,K)=' ' | |
30595 | 1030 CONTINUE | |
30596 | DO 1040 L=0,ISPALT-1,IXRAST | |
30597 | COL(L,K)='|' | |
30598 | 1040 CONTINUE | |
30599 | COL(ISPALT,K)='|' | |
30600 | ENDIF | |
30601 | 1100 CONTINUE | |
30602 | C | |
30603 | C*** plot curve Y1 | |
30604 | C | |
30605 | YMAX=Y1(1) | |
30606 | YMIN=MAX(Y1(1),EPS) | |
30607 | DO 500 I=1,N | |
30608 | YMAX =MAX(Y1(I),YMAX) | |
30609 | IF(Y1(I).GT.EPS) THEN | |
30610 | IF(YMIN.EQ.EPS) THEN | |
30611 | YMIN = Y1(I)/10.D0 | |
30612 | ELSE | |
30613 | YMIN = MIN(Y1(I),YMIN) | |
30614 | ENDIF | |
30615 | ENDIF | |
30616 | 500 CONTINUE | |
30617 | IF(IARG.GT.1) THEN | |
30618 | DO 550 I=1,N | |
30619 | YMAX=MAX(Y2(I),YMAX) | |
30620 | IF(Y2(I).GT.EPS) THEN | |
30621 | IF(YMIN.EQ.EPS) THEN | |
30622 | YMIN = Y2(I) | |
30623 | ELSE | |
30624 | YMIN = MIN(Y2(I),YMIN) | |
30625 | ENDIF | |
30626 | ENDIF | |
30627 | 550 CONTINUE | |
30628 | ENDIF | |
30629 | C | |
30630 | DO 560 I=1,N | |
30631 | Y1(I) = MAX(Y1(I),YMIN) | |
30632 | 560 CONTINUE | |
30633 | IF(IARG.GT.1) THEN | |
30634 | DO 570 I=1,N | |
30635 | Y2(I) = MAX(Y2(I),YMIN) | |
30636 | 570 CONTINUE | |
30637 | ENDIF | |
30638 | C | |
30639 | IF(YMAX.LE.YMIN) THEN | |
30640 | WRITE(LOUT,'(/1X,A,2E12.3,/)') | |
30641 | & 'XGLOGY:ERROR:YMIN,YMAX ',YMIN,YMAX | |
30642 | WRITE(LOUT,'(1X,A)') 'MIN = MAX, OUTPUT SUPPRESSED' | |
30643 | RETURN | |
30644 | ENDIF | |
30645 | C | |
30646 | YMA=(LOG10(YMAX)-LOG10(YMIN))/20.0D0+LOG10(YMAX) | |
30647 | YMI=LOG10(YMIN)-(LOG10(YMAX)-LOG10(YMIN))/20.0D0 | |
30648 | YZOOM=(YMA-YMI)/DBLE(IZEIL) | |
30649 | IF(YZOOM.LT.EPS) THEN | |
30650 | WRITE(LOUT,'(1X,A)') | |
30651 | & 'XGLOGY:WARNING: MIN = MAX, OUTPUT SUPPRESSED' | |
30652 | RETURN | |
30653 | ENDIF | |
30654 | C | |
30655 | C*** plot curve Y1 | |
30656 | C | |
30657 | ILAST=-1 | |
30658 | LLAST=-1 | |
30659 | DO 1200 K=1,N | |
30660 | L=NINT((X(K)-XMIN)/XZOOM) | |
30661 | I=NINT((YMA-LOG10(Y1(K)))/YZOOM) | |
30662 | IF(ILAST.GE.0) THEN | |
30663 | LD = L-LLAST | |
30664 | ID = I-ILAST | |
30665 | DO 55 II=0,LD,SIGN(1,LD) | |
30666 | DO 66 KK=0,ID,SIGN(1,ID) | |
30667 | COL(II+LLAST,KK+ILAST)=SYMB(1) | |
30668 | 66 CONTINUE | |
30669 | 55 CONTINUE | |
30670 | ELSE | |
30671 | COL(L,I)=SYMB(1) | |
30672 | ENDIF | |
30673 | ILAST = I | |
30674 | LLAST = L | |
30675 | 1200 CONTINUE | |
30676 | C | |
30677 | IF(IARG.GT.1) THEN | |
30678 | C | |
30679 | C*** plot curve Y2 | |
30680 | C | |
30681 | DO 1250 K=1,N | |
30682 | L=NINT((X(K)-XMIN)/XZOOM) | |
30683 | I=NINT((YMA-LOG10(Y2(K)))/YZOOM) | |
30684 | COL(L,I)=SYMB(2) | |
30685 | 1250 CONTINUE | |
30686 | ENDIF | |
30687 | C | |
30688 | C*** write it | |
30689 | C | |
30690 | WRITE(LOUT,'(2X,A)') '(LOGARITHMIC Y AXIS)' | |
30691 | WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT) | |
30692 | C | |
30693 | C*** write range of X | |
30694 | C | |
30695 | XZOOM1 = (XMAX-XMIN)/DBLE(7) | |
30696 | WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7) | |
30697 | C | |
30698 | DO 1300 K=0,IZEIL-1 | |
30699 | YPOS=10.D0**(YMA-((DBLE(K)+0.5D0)*YZOOM)) | |
30700 | WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT) | |
30701 | 110 FORMAT(1X,1PE9.2,70A1) | |
30702 | 1300 CONTINUE | |
30703 | C | |
30704 | C*** write range of X | |
30705 | C | |
30706 | WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7) | |
30707 | WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT) | |
30708 | 120 FORMAT(6X,7(1PE10.3)) | |
30709 | C | |
30710 | END | |
30711 | ||
30712 | *$ CREATE DT_SRPLOT.FOR | |
30713 | *COPY DT_SRPLOT | |
30714 | * | |
30715 | *===plot===============================================================* | |
30716 | * | |
30717 | SUBROUTINE DT_SRPLOT(X,Y,N,M,MM,XO,DX,YO,DY) | |
30718 | ||
30719 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
30720 | SAVE | |
30721 | ||
30722 | PARAMETER ( LINP = 10 , | |
30723 | & LOUT = 6 , | |
30724 | & LDAT = 9 ) | |
30725 | ||
30726 | * | |
30727 | * initial version | |
30728 | * J. Ranft, (FORTRAN-Programmierung,J.R.,Teubner, Leipzig, 72) | |
30729 | * This is a subroutine of fluka to plot Y across the page | |
30730 | * as a function of X down the page. Up to 37 curves can be | |
30731 | * plotted in the same picture with different plotting characters. | |
30732 | * Output of first 10 overprinted characters addad by FB 88 | |
30733 | * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - | |
30734 | * | |
30735 | * Input Variables: | |
30736 | * X = array containing the values of X | |
30737 | * Y = array containing the values of Y | |
30738 | * N = number of values in X and in Y | |
30739 | * can exceed the fixed number of lines | |
30740 | * M = number of different curves X,Y are containing | |
30741 | * MM = number of points in each curve i.e. N=M*MM | |
30742 | * XO = smallest value of X to be plotted | |
30743 | * DX = increment of X between subsequent lines | |
30744 | * YO = smallest value of Y to be plotted | |
30745 | * DY = increment of Y between subsequent character spaces | |
30746 | * | |
30747 | * other variables used inside: | |
30748 | * XX = numbers along the X-coordinate axis | |
30749 | * YY = numbers along the Y-coordinate axis | |
30750 | * LL = ten lines temporary storage for the plot | |
30751 | * L = character set used to plot different curves | |
30752 | * LOV = memorizes overprinted symbols | |
30753 | * the first 10 overprinted symbols are printed on | |
30754 | * the end of the line to avoid ambiguities | |
30755 | * (added by FB as considered quite helpful) | |
30756 | * | |
30757 | ********************************************************************* | |
30758 | * | |
30759 | DIMENSION XX(61),YY(61),LL(101,10) | |
30760 | DIMENSION X(N),Y(N),L(40),LOV(40,10) | |
30761 | DATA L/ | |
30762 | 11H*,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1HZ, | |
30763 | 21H+,1HA,1HO,1HB,1HC,1HD,1HE,1HF,1HG,1HH, | |
30764 | 31HI,1HJ,1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR, | |
30765 | 41HS,1HT,1HU,1HV,1HW,1HX,1HY,1H1,1H-,1H / | |
30766 | * | |
30767 | * | |
30768 | MN=51 | |
30769 | DO 10 I=1,MN | |
30770 | AI=I-1 | |
30771 | 10 XX(I)=XO+AI*DX | |
30772 | DO 20 I=1,11 | |
30773 | AI=I-1 | |
30774 | 20 YY(I)=YO+10.0D0*AI*DY | |
30775 | WRITE(LOUT, 500) (YY(I),I=1,11) | |
30776 | MMN=MN-1 | |
30777 | * | |
30778 | * | |
30779 | DO 90 JJ=1,MMN,10 | |
30780 | JJJ=JJ-1 | |
30781 | DO 30 I=1,101 | |
30782 | DO 30 J=1,10 | |
30783 | 30 LL(I,J)=L(40) | |
30784 | DO 40 I=1,101 | |
30785 | 40 LL(I,1)=L(39) | |
30786 | DO 50 I=1,101,10 | |
30787 | DO 50 J=1,10 | |
30788 | 50 LL(I,J)=L(38) | |
30789 | DO 60 I=1,40 | |
30790 | DO 60 J=1,10 | |
30791 | 60 LOV(I,J)=L(40) | |
30792 | * | |
30793 | * | |
30794 | DO 70 I=1,M | |
30795 | DO 70 J=1,MM | |
30796 | II=J+(I-1)*MM | |
30797 | AIX=(X(II)-(XO-DX/2.0D0))/DX+1.0D0 | |
30798 | AIY=(Y(II)-(YO-DY/2.0D0))/DY+1.0D0 | |
30799 | AIX=AIX-DBLE(JJJ) | |
30800 | * changed Sept.88 by FB to avoid INTEGER OVERFLOW | |
30801 | IF( AIX .GT. 1.D0.AND. AIX .LT. 11.D0.AND. AIY .GT. 1.D0.AND | |
30802 | + . AIY .LT. 102.D0) THEN | |
30803 | IX=INT(AIX) | |
30804 | IY=INT(AIY) | |
30805 | IF( IX.GT. 0.AND. IX.LE. 10.AND. IY.GT. 0.AND. IY.LE. 101) | |
30806 | + THEN | |
30807 | IF(LL(IY,IX).NE.L(38).AND.LL(IY,IX).NE.L(39)) LOV(I,IX) | |
30808 | + =LL(IY,IX) | |
30809 | LL(IY,IX)=L(I) | |
30810 | ENDIF | |
30811 | ENDIF | |
30812 | 70 CONTINUE | |
30813 | * | |
30814 | * | |
30815 | DO 80 I=1,10 | |
30816 | II=I+JJJ | |
30817 | III=II+1 | |
30818 | WRITE(LOUT,510) XX(II),XX(III) , (LL(J,I),J=1,101) , | |
30819 | & (LOV(J,I),J=1,10) | |
30820 | 80 CONTINUE | |
30821 | 90 CONTINUE | |
30822 | * | |
30823 | * | |
30824 | WRITE(LOUT, 520) | |
30825 | WRITE(LOUT, 500) (YY(I),I=1,11) | |
30826 | RETURN | |
30827 | * | |
30828 | 500 FORMAT(11X,11(1PE10.2),11HOVERPRINTED) | |
30829 | 510 FORMAT(1X,2(1PE10.2),101A1,1H ,10A1) | |
30830 | 520 FORMAT(20X,10('1---------'),'1') | |
30831 | END | |
30832 | *$ CREATE DT_DEFSET.FOR | |
30833 | *COPY DT_DEFSET | |
30834 | * | |
30835 | *===defset=============================================================* | |
30836 | * | |
30837 | BLOCK DATA DT_DEFSET | |
30838 | ||
30839 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
30840 | SAVE | |
30841 | ||
30842 | * flags for input different options | |
30843 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
30844 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
30845 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
30846 | ||
30847 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
30848 | ||
30849 | * emulsion treatment | |
30850 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
30851 | & NCOMPO,IEMUL | |
30852 | ||
30853 | * / DTFLG1 / | |
30854 | DATA IFRAG / 2, 1 / | |
30855 | DATA IRESCO / 1 / | |
30856 | DATA IMSHL / 1 / | |
30857 | DATA IRESRJ / 0 / | |
30858 | DATA IOULEV / -1, -1, -1, -1, -1, -1 / | |
30859 | DATA LEMCCK / .FALSE. / | |
30860 | DATA LHADRO / .FALSE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE., | |
30861 | & .TRUE.,.TRUE.,.TRUE./ | |
30862 | DATA LSEADI / .TRUE. / | |
30863 | DATA LEVAPO / .TRUE. / | |
30864 | DATA IFRAME / 1 / | |
30865 | DATA ITRSPT / 0 / | |
30866 | ||
30867 | * / DTCOMP / | |
30868 | DATA EMUFRA / NCOMPX*0.0D0 / | |
30869 | DATA IEMUMA / NCOMPX*1 / | |
30870 | DATA IEMUCH / NCOMPX*1 / | |
30871 | DATA NCOMPO / 0 / | |
30872 | DATA IEMUL / 0 / | |
30873 | ||
30874 | END | |
30875 | ||
30876 | *$ CREATE DT_HADPRP.FOR | |
30877 | *COPY DT_HADPRP | |
30878 | * | |
30879 | *===hadprp=============================================================* | |
30880 | * | |
30881 | BLOCK DATA DT_HADPRP | |
30882 | ||
30883 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
30884 | SAVE | |
30885 | ||
30886 | * auxiliary common for reggeon exchange (DTUNUC 1.x) | |
30887 | COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6), | |
30888 | & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6), | |
30889 | & IQTCHR(-6:6),MQUARK(3,39) | |
30890 | ||
30891 | * hadron index conversion (BAMJET <--> PDG) | |
30892 | COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22), | |
30893 | & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19), | |
30894 | & IAMCIN(210) | |
30895 | ||
30896 | * names of hadrons used in input-cards | |
30897 | CHARACTER*8 BTYPE | |
30898 | COMMON /DTPAIN/ BTYPE(30) | |
30899 | ||
30900 | * / DTQUAR / | |
30901 | *----------------------------------------------------------------------* | |
30902 | * * | |
30903 | * Quark content of particles: * | |
30904 | * index quark el. charge bar. charge isospin isospin3 * | |
30905 | * 1 = u 2/3 1/3 1/2 1/2 * | |
30906 | * -1 = ubar -2/3 -1/3 1/2 -1/2 * | |
30907 | * 2 = d -1/3 1/3 1/2 -1/2 * | |
30908 | * -2 = dbar 1/3 -1/3 1/2 1/2 * | |
30909 | * 3 = s -1/3 1/3 0 0 * | |
30910 | * -3 = sbar 1/3 -1/3 0 0 * | |
30911 | * 4 = c 2/3 1/3 0 0 * | |
30912 | * -4 = cbar -2/3 -1/3 0 0 * | |
30913 | * 5 = b -1/3 1/3 0 0 * | |
30914 | * -5 = bbar 1/3 -1/3 0 0 * | |
30915 | * 6 = t 2/3 1/3 0 0 * | |
30916 | * -6 = tbar -2/3 -1/3 0 0 * | |
30917 | * * | |
30918 | * Mquark = particle quark composition (Paprop numbering) * | |
30919 | * Iqechr = electric charge ( in 1/3 unit ) * | |
30920 | * Iqbchr = baryonic charge ( in 1/3 unit ) * | |
30921 | * Iqichr = isospin ( in 1/2 unit ), z component * | |
30922 | * Iqschr = strangeness * | |
30923 | * Iqcchr = charm * | |
30924 | * Iquchr = beauty * | |
30925 | * Iqtchr = ...... * | |
30926 | * * | |
30927 | *----------------------------------------------------------------------* | |
30928 | DATA IQECHR / -2, 1, -2, 1, 1, -2, 0, 2, -1, -1, 2, -1, 2 / | |
30929 | DATA IQBCHR / 6*-1, 0, 6*1 / | |
30930 | DATA IQICHR / 4*0, 1, -1, 0, 1, -1, 4*0 / | |
30931 | DATA IQSCHR / 3*0, 1, 5*0, -1, 3*0 / | |
30932 | DATA IQCCHR / 2*0, -1, 7*0, 1, 2*0 / | |
30933 | DATA IQUCHR / 0, 1, 9*0, -1, 0 / | |
30934 | DATA IQTCHR / -1, 11*0, 1 / | |
30935 | DATA MQUARK / | |
30936 | & 2, 1, 1, -2,-1,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
30937 | & 0, 0, 0, 0, 0, 0, 2, 2, 1, -2,-2,-1, 0, 0, 0, | |
30938 | & 0, 0, 0, 0, 0, 0, 1,-2, 0, 2,-1, 0, 1,-3, 0, | |
30939 | & 3,-1, 0, 1, 2, 3, -1,-2,-3, 0, 0, 0, 2, 2, 3, | |
30940 | & 1, 1, 3, 1, 2, 3, 1,-1, 0, 2,-3, 0, 3,-2, 0, | |
30941 | & 2,-2, 0, 3,-3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
30942 | & -1,-1,-3, -1,-2,-3, -2,-2,-3, 1, 3, 3, -1,-3,-3, | |
30943 | & 2, 3, 3, -2,-3,-3, 3, 3, 3, -3,-3,-3 / | |
30944 | ||
30945 | * / DTHAIC / | |
30946 | * (renamed) (HAdron InDex COnversion) | |
30947 | * translation table version filled up by r.e. 25.01.94 * | |
30948 | DATA IAMCIN / | |
30949 | &2212,-2212,11,-11,12, -12,22,2112,-2112,-13, | |
30950 | &13,130,211,-211,321, -321,3122,-3122,310,3112, | |
30951 | &3222,3212,111,311,-311, 0,0,0,0,0, | |
30952 | &221,213,113,-213,223, 323,313,-323,-313,10323, | |
30953 | &10313,-10323,-10313,30323,30313, -30323,-30313,3224,3214,3114, | |
30954 | &3216,3218,2224,2214,2114, 1114,12224,12214,12114,11114, | |
30955 | &99999,99999,22212,22112,32124, 31214,-2224,-2214,-2114,-1114, | |
30956 | &-12224,-12214,-12114,-11114,-2124, -1214,4*99999, | |
30957 | &5*99999, 5*99999, | |
30958 | &4*99999,331, 333,3322,3312,-3222,-3212, | |
30959 | &-3112,-3322,-3312,3224,3214, 3114,3324,3314,3334,-3224, | |
30960 | &-3214,-3114,-3324,-3314,-3334, 421,411,-411,-421,431, | |
30961 | &-431,441,423,413,-413, -423,433,-433,20443,443, | |
30962 | &-15,15,16,-16,14, -14,4122,4232,4132,4222, | |
30963 | &4212,4112,3*99999, 3*99999,-4122,-4232, | |
30964 | &-4132,-4222,-4212,-4112,99999, 5*99999, | |
30965 | &5*99999, 5*99999, | |
30966 | &10*99999, | |
30967 | &5*99999 , 20211,20111,-20211,99999,20321, | |
30968 | &-20321,20311,-20311,7*99999 , | |
30969 | &7*99999,12212,12112,99999/ | |
30970 | ||
30971 | * / DTHAIC / | |
30972 | * (HAdron InDex COnversion) | |
30973 | DATA (IPDG2(1,K),K=1,7) | |
30974 | & / -11, -12, -13, -15, -16, -14, 0/ | |
30975 | DATA (IBAM2(1,K),K=1,7) | |
30976 | & / 4, 6, 10, 131, 134, 136, 0/ | |
30977 | DATA (IPDG2(2,K),K=1,7) | |
30978 | & / 11, 12, 22, 13, 15, 16, 14/ | |
30979 | DATA (IBAM2(2,K),K=1,7) | |
30980 | & / 3, 5, 7, 11, 132, 133, 135/ | |
30981 | DATA (IPDG3(1,K),K=1,22) | |
30982 | & / -211, -321, -311, -213, -323, -313, -411, -421, | |
30983 | & -431, -413, -423, -433, 0, 0, 0, 0, | |
30984 | & 0, 0, 0, 0, 0, 0/ | |
30985 | DATA (IBAM3(1,K),K=1,22) | |
30986 | & / 14, 16, 25, 34, 38, 39, 118, 119, | |
30987 | & 121, 125, 126, 128, 0, 0, 0, 0, | |
30988 | & 0, 0, 0, 0, 0, 0/ | |
30989 | DATA (IPDG3(2,K),K=1,22) | |
30990 | & / 130, 211, 321, 310, 111, 311, 221, 213, | |
30991 | & 113, 223, 323, 313, 331, 333, 421, 411, | |
30992 | & 431, 441, 423, 413, 433, 443/ | |
30993 | DATA (IBAM3(2,K),K=1,22) | |
30994 | & / 12, 13, 15, 19, 23, 24, 31, 32, | |
30995 | & 33, 35, 36, 37, 95, 96, 116, 117, | |
30996 | & 120, 122, 123, 124, 127, 130/ | |
30997 | DATA (IPDG4(1,K),K=1,29) | |
30998 | & / -2212, -2112, -3122, -2224, -2214, -2114, -1114, -2124, | |
30999 | & -1214, -3222, -3212, -3112, -3322, -3312, -3224, -3214, | |
31000 | & -3114, -3324, -3314, -3334, -4122, -4232, -4132, -4222, | |
31001 | & -4212, -4112, 0, 0, 0/ | |
31002 | DATA (IBAM4(1,K),K=1,29) | |
31003 | & / 2, 9, 18, 67, 68, 69, 70, 75, | |
31004 | & 76, 99, 100, 101, 102, 103, 110, 111, | |
31005 | & 112, 113, 114, 115, 149, 150, 151, 152, | |
31006 | & 153, 154, 0, 0, 0/ | |
31007 | DATA (IPDG4(2,K),K=1,29) | |
31008 | & / 2212, 2112, 3122, 3112, 3222, 3212, 3224, 3214, | |
31009 | & 3114, 3216, 3218, 2224, 2214, 2114, 1114, 3322, | |
31010 | & 3312, 3224, 3214, 3114, 3324, 3314, 3334, 4122, | |
31011 | & 4232, 4132, 4222, 4212, 4112/ | |
31012 | DATA (IBAM4(2,K),K=1,29) | |
31013 | & / 1, 8, 17, 20, 21, 22, 48, 49, | |
31014 | & 50, 51, 52, 53, 54, 55, 56, 97, | |
31015 | & 98, 104, 105, 106, 107, 108, 109, 137, | |
31016 | & 138, 139, 140, 141, 142/ | |
31017 | DATA (IPDG5(1,K),K=1,19) | |
31018 | & /-10323,-10313,-30323,-30313,-12224,-12214,-12114,-11114, | |
31019 | & -20211,-20321,-20311, 0, 0, 0, 0, 0, | |
31020 | & 0, 0, 0/ | |
31021 | DATA (IBAM5(1,K),K=1,19) | |
31022 | & / 42, 43, 46, 47, 71, 72, 73, 74, | |
31023 | & 188, 191, 193, 0, 0, 0, 0, 0, | |
31024 | & 0, 0, 0/ | |
31025 | DATA (IPDG5(2,K),K=1,19) | |
31026 | & / 10323, 10313, 30323, 30313, 12224, 12214, 12114, 11114, | |
31027 | & 22212, 22112, 32124, 31214, 20443, 20211, 20111, 20321, | |
31028 | & 20311, 12212, 12112/ | |
31029 | DATA (IBAM5(2,K),K=1,19) | |
31030 | & / 40, 41, 44, 45, 57, 58, 59, 60, | |
31031 | & 63, 64, 65, 66, 129, 186, 187, 190, | |
31032 | & 192, 208, 209/ | |
31033 | ||
31034 | * / DTPAIN / | |
31035 | * internal particle names | |
31036 | DATA BTYPE / 'PROTON ' , 'APROTON ' , 'ELECTRON' , 'POSITRON' , | |
31037 | &'NEUTRIE ' , 'ANEUTRIE' , 'PHOTON ' , 'NEUTRON ' , 'ANEUTRON' , | |
31038 | &'MUON+ ' , 'MUON- ' , 'KAONLONG' , 'PION+ ' , 'PION- ' , | |
31039 | &'KAON+ ' , 'KAON- ' , 'LAMBDA ' , 'ALAMBDA ' , 'KAONSHRT' , | |
31040 | &'SIGMA- ' , 'SIGMA+ ' , 'SIGMAZER' , 'PIZERO ' , 'KAONZERO' , | |
31041 | &'AKAONZER' , 'NEUTRIM ' , 'ANEUTRIM' , 'NEUTRIT ' , 'ANEUTRIT' , | |
31042 | &'BLANK ' / | |
31043 | ||
31044 | END | |
31045 | ||
31046 | *$ CREATE DT_BLKD46.FOR | |
31047 | *COPY DT_BLKD46 | |
31048 | * | |
31049 | *===blkd46=============================================================* | |
31050 | * | |
31051 | BLOCK DATA DT_BLKD46 | |
31052 | ||
31053 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
31054 | SAVE | |
31055 | ||
31056 | PARAMETER ( AMELCT = 0.51099906 D-03 ) | |
31057 | PARAMETER ( AMMUON = 0.105658389 D+00 ) | |
31058 | ||
31059 | * particle properties (BAMJET index convention) | |
31060 | CHARACTER*8 ANAME | |
31061 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
31062 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
31063 | ||
31064 | * / DTPART / | |
31065 | * Particle masses Engel version JETSET compatible | |
31066 | C DATA (AAM(K),K=1,85) / | |
31067 | C & .9383D+00, .9383D+00, AMELCT , AMELCT , .0000D+00, | |
31068 | C & .0000D+00, .0000D+00, .9396D+00, .9396D+00, AMMUON , | |
31069 | C & AMMUON , .4977D+00, .1396D+00, .1396D+00, .4936D+00, | |
31070 | C & .4936D+00, .1116D+01, .1116D+01, .4977D+00, .1197D+01, | |
31071 | C & .1189D+01, .1193D+01, .1350D+00, .4977D+00, .4977D+00, | |
31072 | C & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00, | |
31073 | C & .5488D+00, .7669D+00, .7700D+00, .7669D+00, .7820D+00, | |
31074 | C & .8921D+00, .8962D+00, .8921D+00, .8962D+00, .1300D+01, | |
31075 | C & .1300D+01, .1300D+01, .1300D+01, .1421D+01, .1421D+01, | |
31076 | C & .1421D+01, .1421D+01, .1383D+01, .1384D+01, .1387D+01, | |
31077 | C & .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01, | |
31078 | C & .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01, | |
31079 | C & .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01, | |
31080 | C & .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01, | |
31081 | C & .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01, | |
31082 | C & .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00, | |
31083 | C & .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01 / | |
31084 | C DATA (AAM(K),K=86,183) / | |
31085 | C & .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01, | |
31086 | C & .1700D+01, .1700D+01, .1820D+01, .2030D+01, .9575D+00, | |
31087 | C & .1019D+01, .1315D+01, .1321D+01, .1189D+01, .1193D+01, | |
31088 | C & .1197D+01, .1315D+01, .1321D+01, .1383D+01, .1384D+01, | |
31089 | C & .1387D+01, .1532D+01, .1535D+01, .1672D+01, .1383D+01, | |
31090 | C & .1384D+01, .1387D+01, .1532D+01, .1535D+01, .1672D+01, | |
31091 | C & .1865D+01, .1869D+01, .1869D+01, .1865D+01, .1969D+01, | |
31092 | C & .1969D+01, .2980D+01, .2007D+01, .2010D+01, .2010D+01, | |
31093 | C & .2007D+01, .2113D+01, .2113D+01, .3686D+01, .3097D+01, | |
31094 | C & .1784D+01, .1784D+01, .0000D+00, .0000D+00, .0000D+00, | |
31095 | C & .0000D+00, .2285D+01, .2460D+01, .2460D+01, .2452D+01, | |
31096 | C & .2453D+01, .2454D+01, .2560D+01, .2560D+01, .2730D+01, | |
31097 | C & .3610D+01, .3610D+01, .3790D+01, .2285D+01, .2460D+01, | |
31098 | C & .2460D+01, .2452D+01, .2453D+01, .2454D+01, .2560D+01, | |
31099 | C & .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01, | |
31100 | C & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01, | |
31101 | C & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01, | |
31102 | C & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01, | |
31103 | C & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01, | |
31104 | C & .1250D+01, .1250D+01, .1250D+01 / | |
31105 | C DATA (AAM ( I ), I = 184,210 ) / | |
31106 | C & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00, | |
31107 | C & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00, | |
31108 | C & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00, | |
31109 | C & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00, | |
31110 | C & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00, | |
31111 | C & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00, | |
31112 | C & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00, | |
31113 | C & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00, | |
31114 | C & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/ | |
31115 | * sr 25.1.06: particle masses adjusted to Pythia | |
31116 | DATA (AAM(K),K=1,85) / | |
31117 | & .938270E+00,.938270E+00, AMELCT , AMELCT ,.000000E+00, | |
31118 | & .000000E+00,.000000E+00,.939570E+00,.939570E+00, AMMUON , | |
31119 | & AMMUON ,.497670E+00,.139570E+00,.139570E+00,.493600E+00, | |
31120 | & .493600E+00,.111568E+01,.111568E+01,.497670E+00,.119744E+01, | |
31121 | & .118937E+01,.119255E+01,.134980E+00,.497670E+00,.497670E+00, | |
31122 | & .0000D+00, .0000D+00, .0000D+00 , .0000D+00, .0000D+00, | |
31123 | & .547450E+00,.766900E+00,.768500E+00,.766900E+00,.781940E+00, | |
31124 | & .891600E+00,.896100E+00,.891600E+00,.896100E+00,.129000E+01, | |
31125 | & .129000E+01,.129000E+01,.129000E+01, .1421D+01, .1421D+01, | |
31126 | & .1421D+01, .1421D+01,.138280E+01,.138370E+01,.138720E+01, | |
31127 | & .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01, | |
31128 | & .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01, | |
31129 | & .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01, | |
31130 | & .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01, | |
31131 | & .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01, | |
31132 | & .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00, | |
31133 | & .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01 / | |
31134 | DATA (AAM(K),K=86,183) / | |
31135 | & .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01, | |
31136 | & .1700D+01, .1700D+01, .1820D+01, .2030D+01,.957770E+00, | |
31137 | & .101940E+01,.131490E+01,.132130E+01,.118937E+01,.119255E+01, | |
31138 | & .119744E+01,.131490E+01,.132130E+01,.138280E+01,.138370E+01, | |
31139 | & .138720E+01,.153180E+01, .1535D+01,.167245E+01,.138280E+01, | |
31140 | & .138370E+01,.138720E+01,.153180E+01, .1535D+01,.167245E+01, | |
31141 | & .186450E+01,.186930E+01,.186930E+01,.186450E+01,.196850E+01, | |
31142 | & .196850E+01,.297980E+01,.200670E+01, .2010D+01, .2010D+01, | |
31143 | & .200670E+01,.211240E+01,.211240E+01, .3686D+01,.309688E+01, | |
31144 | & .177700E+01,.177700E+01, .0000D+00, .0000D+00, .0000D+00, | |
31145 | & .0000D+00,.228490E+01,.246560E+01,.247030E+01,.245290E+01, | |
31146 | & .245350E+01,.245210E+01, .2560D+01, .2560D+01, .2730D+01, | |
31147 | & .3610D+01, .3610D+01, .3790D+01,.228490E+01,.246560E+01, | |
31148 | & .2460D+01,.245290E+01,.245350E+01,.245210E+01, .2560D+01, | |
31149 | & .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01, | |
31150 | & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01, | |
31151 | & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01, | |
31152 | & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01, | |
31153 | & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01, | |
31154 | & .1250D+01, .1250D+01, .1250D+01 / | |
31155 | DATA (AAM ( I ), I = 184,210 ) / | |
31156 | & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00, | |
31157 | & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00, | |
31158 | & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00, | |
31159 | & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00, | |
31160 | & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00, | |
31161 | & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00, | |
31162 | & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00, | |
31163 | & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00, | |
31164 | & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/ | |
31165 | * Particle mean lives | |
31166 | DATA (TAU(K),K=1,183) / | |
31167 | & .1000D+19, .1000D+19, .1000D+19, .1000D+19, .1000D+19, | |
31168 | & .1000D+19, .1000D+19, .9180D+03, .9180D+03, .2200D-05, | |
31169 | & .2200D-05, .5200D-07, .2600D-07, .2600D-07, .1200D-07, | |
31170 | & .1200D-07, .2600D-09, .2600D-09, .9000D-10, .1500D-09, | |
31171 | & .8000D-10, .5000D-14, .8000D-16, .0000D+00, .0000D+00, | |
31172 | & 70*.0000D+00, | |
31173 | & .0000D+00, .3000D-09, .1700D-09, .8000D-10, .1000D-13, | |
31174 | & .1500D-09, .3000D-09, .1700D-09, .0000D+00, .0000D+00, | |
31175 | & .0000D+00, .0000D+00, .0000D+00, .1000D-09, .0000D+00, | |
31176 | & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .1000D-09, | |
31177 | & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00, | |
31178 | & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00, | |
31179 | & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00, | |
31180 | & .9000D-11, .9000D-11, .9000D-11, .9000D-11, .1000D+19, | |
31181 | & .1000D+19, .0000D+00, .0000D+00, .0000D+00, .0000D+00, | |
31182 | & 40*.0000D+00, | |
31183 | & .0000D+00, .0000D+00, .0000D+00 / | |
31184 | DATA ( TAU ( I ), I = 184,210 ) / | |
31185 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, | |
31186 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, | |
31187 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, | |
31188 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, | |
31189 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, | |
31190 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, | |
31191 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, | |
31192 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, | |
31193 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00/ | |
31194 | * Resonance width Gamma in GeV | |
31195 | DATA (GA(K),K= 1,85) / | |
31196 | & 30*.0000D+00, | |
31197 | & .8500D-06, .1520D+00, .1520D+00, .1520D+00, .1000D-01, | |
31198 | & .7900D-01, .7900D-01, .7900D-01, .7900D-01, .4500D+00, | |
31199 | & .4500D+00, .4500D+00, .4500D+00, .1080D+00, .1080D+00, | |
31200 | & .1080D+00, .1080D+00, .5000D-01, .5000D-01, .5000D-01, | |
31201 | & .8500D-01, .1800D+00, .1150D+00, .1150D+00, .1150D+00, | |
31202 | & .1150D+00, .2000D+00, .2000D+00, .2000D+00, .2000D+00, | |
31203 | & .2000D+00, .2000D+00, .1000D+00, .1000D+00, .2000D+00, | |
31204 | & .2000D+00, .1150D+00, .1150D+00, .1150D+00, .1150D+00, | |
31205 | & .2000D+00, .2000D+00, .2000D+00, .2000D+00, .1000D+00, | |
31206 | & .1000D+00, .2000D+00, .1000D+00, .1000D+00, .1000D+00, | |
31207 | & .1000D+00, .1000D+00, .1000D+00, .1000D+00, .2000D+00 / | |
31208 | DATA (GA(K),K= 86,183) / | |
31209 | & .2000D+00, .2000D+00, .2000D+00, .1500D+00, .1500D+00, | |
31210 | & .1500D+00, .1500D+00, .8500D-01, .1800D+00, .2000D-02, | |
31211 | & .4000D-02, .0000D+00, .0000D+00, .0000D+00, .0000D+00, | |
31212 | & .0000D+00, .0000D+00, .0000D+00, .3400D-01, .3400D-01, | |
31213 | & .3600D-01, .9000D-02, .9000D-02, .0000D+00, .3400D-01, | |
31214 | & .3400D-01, .3600D-01, .9000D-02, .9000D-02, .0000D+00, | |
31215 | & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00, | |
31216 | & .0000D+00, .0000D+00, .5000D-02, .2000D-02, .2000D-02, | |
31217 | & .5000D-02, .2000D-02, .2000D-02, .2000D-03, .7000D-03, | |
31218 | & 50*.0000D+00, | |
31219 | & .3000D+00, .3000D+00, .3000D+00 / | |
31220 | DATA ( GA ( I ), I = 184,210 ) / | |
31221 | & 2.00000000000000D-01, 2.00000000000000D-01, 3.00000000000000D-01, | |
31222 | & 3.00000000000000D-01, 3.00000000000000D-01, 2.70000000000000D-01, | |
31223 | & 2.50000000000000D-01, 2.50000000000000D-01, 2.50000000000000D-01, | |
31224 | & 2.50000000000000D-01, 1.50000000000000D-01, 1.50000000000000D-01, | |
31225 | & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01, | |
31226 | & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01, | |
31227 | & 6.00000000000000D-02, 6.00000000000000D-02, 6.00000000000000D-02, | |
31228 | & 6.00000000000000D-02, 5.50000000000000D-02, 5.50000000000000D-02, | |
31229 | & 2.00000000000000D-01, 2.00000000000000D-01, 0.00000000000000D+00/ | |
31230 | * Particle names | |
31231 | * S+1385+Sigma+(1385) L02030+Lambda0(2030) | |
31232 | * Rho77=Rho(770) Om783=Omega(783) K*14=K*(1420) and so on | |
31233 | * designation N*@@ means N*@1(@2) | |
31234 | DATA (ANAME(K),K=1,85) / | |
31235 | & 'P ','AP ','E- ','E+ ','NUE ', | |
31236 | & 'ANUE ','GAM ','NEU ','ANEU ','MUE+ ', | |
31237 | & 'MUE- ','K0L ','PI+ ','PI- ','K+ ', | |
31238 | & 'K- ','LAM ','ALAM ','K0S ','SIGM- ', | |
31239 | & 'SIGM+ ','SIGM0 ','PI0 ','K0 ','AK0 ', | |
31240 | & 'BLANK ','BLANK ','BLANK ','BLANK ','BLANK ', | |
31241 | & 'ETA550 ','RHO+77 ','RHO077 ','RHO-77 ','OM0783 ', | |
31242 | & 'K*+892 ','K*0892 ','K*-892 ','AK*089 ','KA+125 ', | |
31243 | & 'KA0125 ','KA-125 ','AKA012 ','K*+142 ','K*0142 ', | |
31244 | & 'K*-142 ','AK*014 ','S+1385 ','S01385 ','S-1385 ', | |
31245 | & 'L01820 ','L02030 ','N*++12 ','N*+ 12 ','N*012 ', | |
31246 | & 'N*-12 ','N*++16 ','N*+16 ','N*016 ','N*-16 ', | |
31247 | & 'N*+14 ','N*014 ','N*+15 ','N*015 ','N*+18 ', | |
31248 | & 'N*018 ','AN--12 ','AN*-12 ','AN*012 ','AN*+12 ', | |
31249 | & 'AN--16 ','AN*-16 ','AN*016 ','AN*+16 ','AN*-15 ', | |
31250 | & 'AN*015 ','DE*=24 ','RPI+49 ','RPI049 ','RPI-49 ', | |
31251 | & 'PIN++ ','PIN+0 ','PIN+- ','PIN-0 ','PPPI ' / | |
31252 | DATA (ANAME(K),K=86,183) / | |
31253 | & 'PNPI ','APPPI ','APNPI ','K+PPI ','K-PPI ', | |
31254 | & 'K+NPI ','K-NPI ','S+1820 ','S-2030 ','ETA* ', | |
31255 | & 'PHI ','TETA0 ','TETA- ','ASIG- ','ASIG0 ', | |
31256 | & 'ASIG+ ','ATETA0 ','ATETA+ ','SIG*+ ','SIG*0 ', | |
31257 | & 'SIG*- ','TETA*0 ','TETA* ','OMEGA- ','ASIG*- ', | |
31258 | & 'ASIG*0 ','ASIG*+ ','ATET*0 ','ATET*+ ','OMEGA+ ', | |
31259 | & 'D0 ','D+ ','D- ','AD0 ','F+ ', | |
31260 | & 'F- ','ETAC ','D*0 ','D*+ ','D*- ', | |
31261 | & 'AD*0 ','F*+ ','F*- ','PSI ','JPSI ', | |
31262 | & 'TAU+ ','TAU- ','NUET ','ANUET ','NUEM ', | |
31263 | & 'ANUEM ','C0+ ','A+ ','A0 ','C1++ ', | |
31264 | & 'C1+ ','C10 ','S+ ','S0 ','T0 ', | |
31265 | & 'XU++ ','XD+ ','XS+ ','AC0- ','AA- ', | |
31266 | & 'AA0 ','AC1-- ','AC1- ','AC10 ','AS- ', | |
31267 | & 'AS0 ','AT0 ','AXU-- ','AXD- ','AXS ', | |
31268 | & 'C1*++ ','C1*+ ','C1*0 ','S*+ ','S*0 ', | |
31269 | & 'T*0 ','XU*++ ','XD*+ ','XS*+ ','TETA++ ', | |
31270 | & 'AC1*-- ','AC1*- ','AC1*0 ','AS*- ','AS*0 ', | |
31271 | & 'AT*0 ','AXU*-- ','AXD*- ','AXS*- ','ATET-- ', | |
31272 | & 'RO ','R+ ','R- ' / | |
31273 | DATA ( ANAME ( I ), I = 184,210 ) / | |
31274 | &'AN*-14 ','AN*014 ','PI+130 ','PI0130 ','PI-130 ','F01400 ', | |
31275 | &'K*+146 ','K*-146 ','K*0146 ','AK0146 ','L01600 ','AL0160 ', | |
31276 | &'S+1660 ','S01660 ','S-1660 ','AS-166 ','AS0166 ','AS+166 ', | |
31277 | &'X01950 ','X-1950 ','AX0195 ','AX+195 ','OM-225 ','AOM+22 ', | |
31278 | &'N*+14 ','N*014 ','BLANK '/ | |
31279 | * Charge of particles and resonances | |
31280 | DATA (IICH ( I ), I = 1,210 ) / | |
31281 | & 1, -1, -1, 1, 0, 0, 0, 0, 0, 1, -1, 0, 1, -1, 1, | |
31282 | & -1, 0, 0, 0, -1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
31283 | & 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0, | |
31284 | & -1, 0, 1, 0, -1, 0, 0, 2, 1, 0, -1, 2, 1, 0, -1, | |
31285 | & 1, 0, 1, 0, 1, 0, -2, -1, 0, 1, -2, -1, 0, 1, -1, | |
31286 | & 0, 1, 1, 0, -1, 2, 1, 0, -1, 2, 1, 0, -1, 2, 0, | |
31287 | & 1, -1, 1, -1, 0, 0, 0, -1, -1, 0, 1, 0, 1, 1, 0, | |
31288 | & -1, 0, -1, -1, -1, 0, 1, 0, 1, 1, 0, 1, -1, 0, 1, | |
31289 | & -1, 0, 0, 1, -1, 0, 1, -1, 0, 0, 1, -1, 0, 0, 0, | |
31290 | & 0, 1, 1, 0, 2, 1, 0, 1, 0, 0, 2, 1, 1, -1, -1, | |
31291 | & 0, -2, -1, 0, -1, 0, 0, -2, -1, -1, 2, 1, 0, 1, 0, | |
31292 | & 0, 2, 1, 1, 2, -2, -1, 0, -1, 0, 0, -2, -1, -1, -2, | |
31293 | & 0, 1, -1, -1, 0, 1, 0, -1, 0, 1, -1, 0, 0, 0, 0, | |
31294 | & 1, 0, -1, -1, 0, 1, 0, -1, 0, 1, -1, 1, 1, 0, 0/ | |
31295 | * Particle baryonic charges | |
31296 | DATA (IIBAR ( I ), I = 1,210 ) / | |
31297 | & 1, -1, 0, 0, 0, 0, 0, 1, -1, 0, 0, 0, 0, 0, 0, | |
31298 | & 0, 1, -1, 0, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, | |
31299 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
31300 | & 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, | |
31301 | & 1, 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1, | |
31302 | & -1, 2, 0, 0, 0, 1, 1, 1, 1, 2, 2, 0, 0, 1, 1, | |
31303 | & 1, 1, 1, 1, 0, 0, 1, 1, -1, -1, -1, -1, -1, 1, 1, | |
31304 | & 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, 0, 0, 0, 0, 0, | |
31305 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
31306 | & 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, -1, -1, | |
31307 | & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 1, 1, 1, 1, 1, | |
31308 | & 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, | |
31309 | & 0, 0, 0, -1, -1, 0, 0, 0, 0, 0, 0, 0, 0, 1, -1, | |
31310 | & 1, 1, 1, -1, -1, -1, 1, 1, -1, -1, 1, -1, 1, 1, 0/ | |
31311 | * First number of decay channels used for resonances | |
31312 | * and decaying particles | |
31313 | DATA K1/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 16, 17, | |
31314 | & 18, 24, 30, 34, 38, 40, 41, 43, 44, 136, 138, 330, 327, 328, | |
31315 | & 2*330, 46, 51, 52, 54, 55, 58, | |
31316 | * 50 | |
31317 | & 60, 62, 64, 66, 68, 70, 72, 74, 82, 90, 98, 106, 109, 112, 114, | |
31318 | & 123, 140, 141, 143, 145, 146, 150, 157, 164, 168, 174, 180, 187, | |
31319 | & 194, 202, 210, 211, 213, 215, 216, 220, 227, 234, 238, 245, 252, | |
31320 | * 85 | |
31321 | & 254, 255, 256, 257, 259, 262, 265, 267, 269, 272, 276, 279, 282, | |
31322 | & 286, 290, 293, 299, 331, 335, 339, 340, 341, 343, 344, 345, 346, | |
31323 | & 347, 350, 353, 356, 358, 360, 363, 366, 369, 372, 374, 376, 379, | |
31324 | & 383, 385, 387, 391, 394, 397, 400, 402, 405, 408, 410, 412, 414, | |
31325 | & 417, 420, 425, 430, 431, 432, 433, 434, 448, 452, 457, 458, 459, | |
31326 | & 460, 461, 462, 466, 468, 470, 472, 486, 490, 495, 496, 497, 498, | |
31327 | & 499, 500, 504, 506, 508, 510, 511, 512, 513, 514, 515, 516, 517, | |
31328 | & 518, 519, 522, 523, 524, 525, 526, 527, 528, 529, 530, 531, 534, | |
31329 | & 537, 539, 541, 547, 553, 558, 563, 568, 572, 573, 574, 575, 576, | |
31330 | & 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588, 589, | |
31331 | & 590, 596, 602 / | |
31332 | * Last number of decay channels used for resonances | |
31333 | * and decaying particles | |
31334 | DATA K2/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 15, 16, 17, | |
31335 | & 23, 29, 31, 35, 39, 40, 42, 43, 45, 137, 139, 330, 327, 328, | |
31336 | & 2* 330, 50, 51, 53, 54, 57, | |
31337 | * 50 | |
31338 | & 59, 61, 63, 65, 67, 69, 71, 73, 81, 89, 97, 105, 108, 111, 113, | |
31339 | & 122, 135, 140, 142, 144, 145, 149, 156, 163, 167, 173, 179, 186, | |
31340 | & 193, 201, 209, 210, 212, 214, 215, 219, 226, 233, 237, 244, 251, | |
31341 | * 85 | |
31342 | & 253, 254, 255, 256, 258, 261, 264, 266, 268, 271, 275, 278, 281, | |
31343 | & 285, 289, 292, 298, 307, 334, 338, 339, 340, 342, 343, 344, 345, | |
31344 | & 346, 349, 352, 355, 357, 359, 362, 365, 368, 371, 373, 375, 378, | |
31345 | & 382, 384, 386, 390, 393, 396, 399, 401, 404, 407, 409, 411, 413, | |
31346 | & 416, 419, 424, 429, 430, 431, 432, 433, 447, 451, 456, 457, 458, | |
31347 | & 459, 460, 461, 465, 467, 469, 471, 485, 489, 494, 495, 496, 497, | |
31348 | & 498, 499, 503, 505, 507, 509, 510, 511, 512, 513, 514, 515, 516, | |
31349 | & 517, 518, 521, 522, 523, 524, 525, 526, 527, 528, 529, 530, 533, | |
31350 | & 536, 538, 540, 546, 552, 557, 562, 567, 571, 572, 573, 574, 575, | |
31351 | & 576, 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588, | |
31352 | & 589, 595, 601, 602 / | |
31353 | ||
31354 | END | |
31355 | ||
31356 | *$ CREATE DT_BLKD47.FOR | |
31357 | *COPY DT_BLKD47 | |
31358 | * | |
31359 | *===blkd47=============================================================* | |
31360 | * | |
31361 | BLOCK DATA DT_BLKD47 | |
31362 | ||
31363 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
31364 | SAVE | |
31365 | ||
31366 | * HADRIN: decay channel information | |
31367 | PARAMETER (IDMAX9=602) | |
31368 | CHARACTER*8 ZKNAME | |
31369 | COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3) | |
31370 | ||
31371 | * Name of decay channel | |
31372 | * Designation N*@ means N*@1(1236) | |
31373 | * @1=# means ++, @1 = = means -- | |
31374 | * Designation P+/0/- means Pi+/Pi0/Pi- , respectively | |
31375 | DATA (ZKNAME(K),K= 1, 85) / | |
31376 | & 'P ','AP ','E- ','E+ ','NUE ', | |
31377 | & 'ANUE ','GAM ','PE-NUE ','APEANU ','EANUNU ', | |
31378 | & 'E-NUAN ','3PI0 ','PI+-0 ','PIMUNU ','PIE-NU ', | |
31379 | & 'MU+NUE ','MU-NUE ','MU+NUE ','PI+PI0 ','PI++- ', | |
31380 | & 'PI+00 ','M+P0NU ','E+P0NU ','MU-NU ','PI-0 ', | |
31381 | & 'PI+-- ','PI-00 ','M-P0NU ','E-P0NU ','PPI- ', | |
31382 | & 'NPI0 ','PD-NUE ','PM-NUE ','APPI+ ','ANPI0 ', | |
31383 | & 'APE+NU ','APM+NU ','PI+PI- ','PI0PI0 ','NPI- ', | |
31384 | & 'PPI0 ','NPI+ ','LAGA ','GAGA ','GAE+E- ', | |
31385 | & 'GAGA ','GAGAP0 ','PI000 ','PI+-0 ','PI+-GA ', | |
31386 | & 'PI+0 ','PI+- ','PI00 ','PI-0 ','PI+-0 ', | |
31387 | & 'PI+- ','PI0GA ','K+PI0 ','K0PI+ ','KOPI0 ', | |
31388 | & 'K+PI- ','K-PI0 ','AK0PI- ','AK0PI0 ','K-PI+ ', | |
31389 | & 'K+PI0 ','K0PI+ ','K0PI0 ','K+PI- ','K-PI0 ', | |
31390 | & 'K0PI- ','AK0PI0 ','K-PI+ ','K+PI0 ','K0PI+ ', | |
31391 | & 'K+89P0 ','K08PI+ ','K+RO77 ','K0RO+7 ','K+OM07 ', | |
31392 | & 'K+E055 ','K0PI0 ','K+PI+ ','K089P0 ','K+8PI- ' / | |
31393 | DATA (ZKNAME(K),K= 86,170) / | |
31394 | & 'K0R077 ','K+R-77 ','K+R-77 ','K0OM07 ','K0E055 ', | |
31395 | & 'K-PI0 ','K0PI- ','K-89P0 ','AK08P- ','K-R077 ', | |
31396 | & 'AK0R-7 ','K-OM07 ','K-E055 ','AK0PI0 ','K-PI+ ', | |
31397 | & 'AK08P0 ','K-8PI+ ','AK0R07 ','AK0OM7 ','AK0E05 ', | |
31398 | & 'LA0PI+ ','SI0PI+ ','SI+PI0 ','LA0PI0 ','SI+PI- ', | |
31399 | & 'SI-PI+ ','LA0PI- ','SI0PI- ','NEUAK0 ','PK- ', | |
31400 | & 'SI+PI- ','SI0PI0 ','SI-PI+ ','LA0ET0 ','S+1PI- ', | |
31401 | & 'S-1PI+ ','SO1PI0 ','NEUAK0 ','PK- ','LA0PI0 ', | |
31402 | & 'LA0OM0 ','LA0RO0 ','SI+RO- ','SI-RO+ ','SI0RO0 ', | |
31403 | & 'LA0ET0 ','SI0ET0 ','SI+PI- ','SI-PI+ ','SI0PI0 ', | |
31404 | & 'K0S ','K0L ','K0S ','K0L ','P PI+ ', | |
31405 | & 'P PI0 ','N PI+ ','P PI- ','N PI0 ','N PI- ', | |
31406 | & 'P PI+ ','N*#PI0 ','N*+PI+ ','PRHO+ ','P PI0 ', | |
31407 | & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ', | |
31408 | & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ', | |
31409 | & 'N*-PI+ ','PRHO- ','NRHO0 ','N PI- ','N*0PI- ', | |
31410 | & 'N*-PI0 ','NRHO- ','PETA0 ','N*#PI- ','N*+PI0 ' / | |
31411 | DATA (ZKNAME(K),K=171,255) / | |
31412 | & 'N*0PI+ ','PRHO0 ','NRHO+ ','NETA0 ','N*+PI- ', | |
31413 | & 'N*0PI0 ','N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ', | |
31414 | & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ', | |
31415 | & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ', | |
31416 | & 'N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ','N PI+ ', | |
31417 | & 'PRHO0 ','NRHO+ ','LAMK+ ','S+ K0 ','S0 K+ ', | |
31418 | & 'PETA0 ','P PI- ','N PI0 ','PRHO- ','NRHO0 ', | |
31419 | & 'LAMK0 ','S0 K0 ','S- K+ ','NETA/ ','APPI- ', | |
31420 | & 'APPI0 ','ANPI- ','APPI+ ','ANPI0 ','ANPI+ ', | |
31421 | & 'APPI- ','AN*=P0 ','AN*-P- ','APRHO- ','APPI0 ', | |
31422 | & 'ANPI- ','AN*=P+ ','AN*-P0 ','AN*0P- ','APRHO0 ', | |
31423 | & 'ANRHO- ','APPI+ ','ANPI0 ','AN*-P+ ','AN*0P0 ', | |
31424 | & 'AN*+P- ','APRHO+ ','ANRHO0 ','ANPI+ ','AN*0P+ ', | |
31425 | & 'AN*+P0 ','ANRHO+ ','APPI0 ','ANPI- ','AN*=P+ ', | |
31426 | & 'AN*-P0 ','AN*0P- ','APRHO0 ','ANRHO- ','APPI+, ', | |
31427 | & 'ANPI0 ','AN*-P+ ','AN*0P0 ','AN*+P- ','APRHO+ ', | |
31428 | & 'ANRHO0 ','PN*014 ','NN*=14 ','PI+0 ','PI+- ' / | |
31429 | DATA (ZKNAME(K),K=256,340) / | |
31430 | & 'PI-0 ','P+0 ','N++ ','P+- ','P00 ', | |
31431 | & 'N+0 ','N+- ','N00 ','P-0 ','N-0 ', | |
31432 | & 'P-- ','PPPI0 ','PNPI+ ','PNPI0 ','PPPI- ', | |
31433 | & 'NNPI+ ','APPPI0 ','APNPI+ ','ANNPI0 ','ANPPI- ', | |
31434 | & 'APNPI0 ','APPPI- ','ANNPI- ','K+PPI0 ','K+NPI+ ', | |
31435 | & 'K0PPI0 ','K-PPI0 ','K-NPI+ ','AKPPI- ','AKNPI0 ', | |
31436 | & 'K+NPI0 ','K+PPI- ','K0PPI0 ','K0NPI+ ','K-NPI0 ', | |
31437 | & 'K-PPI- ','AKNPI- ','PAK0 ','SI+PI0 ','SI0PI+ ', | |
31438 | & 'SI+ETA ','S+1PI0 ','S01PI+ ','NEUK- ','LA0PI- ', | |
31439 | & 'SI-OM0 ','LA0RO- ','SI0RO- ','SI-RO0 ','SI-ET0 ', | |
31440 | & 'SI0PI- ','SI-0 ','BLANC ','BLANC ','BLANC ', | |
31441 | & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ', | |
31442 | & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ', | |
31443 | & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ', | |
31444 | & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ', | |
31445 | & 'EPI+- ','EPI00 ','GAPI+- ','GAGA* ','K+- ', | |
31446 | & 'KLKS ','PI+-0 ','EGA ','LPI0 ','LPI ' / | |
31447 | DATA (ZKNAME(K),K=341,425) / | |
31448 | & 'APPI0 ','ANPI- ','ALAGA ','ANPI ','ALPI0 ', | |
31449 | & 'ALPI+ ','LAPI+ ','SI+PI0 ','SI0PI+ ','LAPI0 ', | |
31450 | & 'SI+PI- ','SI-PI+ ','LAPI- ','SI-PI0 ','SI0PI- ', | |
31451 | & 'TE0PI0 ','TE-PI+ ','TE0PI- ','TE-PI0 ','TE0PI ', | |
31452 | & 'TE-PI ','LAK- ','ALPI- ','AS-PI0 ','AS0PI- ', | |
31453 | & 'ALPI0 ','AS+PI- ','AS-PI+ ','ALPI+ ','AS+PI0 ', | |
31454 | & 'AS0PI+ ','AT0PI0 ','AT+PI- ','AT0PI+ ','AT+PI0 ', | |
31455 | & 'AT0PI ','AT+PI ','ALK+ ','K-PI+ ','K-PI+0 ', | |
31456 | & 'K0PI+- ','K0PI0 ','K-PI++ ','AK0PI+ ','K+PI-- ', | |
31457 | & 'K0PI- ','K+PI- ','K+PI-0 ','AKPI-+ ','AK0PI0 ', | |
31458 | & 'ETAPIF ','K++- ','K+AK0 ','ETAPI- ','K--+ ', | |
31459 | & 'K-K0 ','PI00 ','PI+- ','GAGA ','D0PI0 ', | |
31460 | & 'D0GA ','D0PI+ ','D+PI0 ','DFGA ','AD0PI- ', | |
31461 | & 'D-PI0 ','D-GA ','AD0PI0 ','AD0GA ','F+GA ', | |
31462 | & 'F+GA ','F-GA ','F-GA ','PSPI+- ','PSPI00 ', | |
31463 | & 'PSETA ','E+E- ','MUE+- ','PI+-0 ','M+NN ', | |
31464 | & 'E+NN ','RHO+NT ','PI+ANT ','K*+ANT ','M-NN ' / | |
31465 | DATA (ZKNAME(K),K=426,510) / | |
31466 | & 'E-NN ','RHO-NT ','PI-NT ','K*-NT ','NUET ', | |
31467 | & 'ANUET ','NUEM ','ANUEM ','SI+ETA ','SI+ET* ', | |
31468 | & 'PAK0 ','TET0K+ ','SI*+ET ','N*+AK0 ','N*++K- ', | |
31469 | & 'LAMRO+ ','SI0RO+ ','SI+RO0 ','SI+OME ','PAK*0 ', | |
31470 | & 'N*+AK* ','N*++K* ','SI+AK0 ','TET0PI ','SI+AK* ', | |
31471 | & 'TET0RO ','SI0AK* ','SI+K*- ','TET0OM ','TET-RO ', | |
31472 | & 'SI*0AK ','C0+PI+ ','C0+PI0 ','C0+PI- ','A+GAM ', | |
31473 | & 'A0GAM ','TET0AK ','TET0K* ','OM-RO+ ','OM-PI+ ', | |
31474 | & 'C1++AK ','A+PI+ ','C0+AK0 ','A0PI+ ','A+AK0 ', | |
31475 | & 'T0PI+ ','ASI-ET ','ASI-E* ','APK0 ','ATET0K ', | |
31476 | & 'ASI*-E ','AN*-K0 ','AN*--K ','ALAMRO ','ASI0RO ', | |
31477 | & 'ASI-RO ','ASI-OM ','APK*0 ','AN*-K* ','AN*--K ', | |
31478 | & 'ASI-K0 ','ATETPI ','ASI-K* ','ATETRO ','ASI0K* ', | |
31479 | & 'ASI-K* ','ATE0OM ','ATE+RO ','ASI*0K ','AC-PI- ', | |
31480 | & 'AC-PI0 ','AC-PI+ ','AA-GAM ','AA0GAM ','ATET0K ', | |
31481 | & 'ATE0K* ','AOM+RO ','AOM+PI ','AC1--K ','AA-PI- ', | |
31482 | & 'AC0-K0 ','AA0PI- ','AA-K0 ','AT0PI- ','C1++GA ' / | |
31483 | DATA (ZKNAME(K),K=511,540) / | |
31484 | & 'C1++GA ','C10GAM ','S+GAM ','S0GAM ','T0GAM ', | |
31485 | & 'XU++GA ','XD+GAM ','XS+GAM ','A+AKPI ','T02PI+ ', | |
31486 | & 'C1++2K ','AC1--G ','AC1-GA ','AC10GA ','AS-GAM ', | |
31487 | & 'AS0GAM ','AT0GAM ','AXU--G ','AXD-GA ','AXS-GA ', | |
31488 | & 'AA-KPI ','AT02PI ','AC1--K ','RH-PI+ ','RH+PI- ', | |
31489 | & 'RH3PI0 ','RH0PI+ ','RH+PI0 ','RH0PI- ','RH-PI0 ' / | |
31490 | DATA (ZKNAME(I),I=541,602)/ | |
31491 | & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHO0','ANRHO-','ANETA ', | |
31492 | & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0','RH0PI+','RH+PI0', | |
31493 | & '3PI+00','3PI-++','F0PI+ ','RH+PI-','RH0PI0','3PI000','3PI0+-', | |
31494 | & 'F0PI0 ','RH0PI-','RH-PI0','3PI-00','3PI--+','F0PI- ','PI0PI0', | |
31495 | & 'PI+PI-','K+K- ','K0AK0 ','L01600','AL0160','K*+146','K*-146', | |
31496 | & 'K*0146','AK0146','S+1660','S01660','S-1660','AS-166','AS0166', | |
31497 | & 'AS+166','X01690','X-1690','AX0169','AX+169','OM-225','AOM+22', | |
31498 | & 'N*PPI0','N*NPI+','N*P2P0','N*PP+-','N*D+P0','N*D0P+','N*NPI0', | |
31499 | & 'N*PPI-','N*N2P0','N*NP+-','N*D+P-','N*D0P0','BLANK '/ | |
31500 | * Weight of decay channel | |
31501 | DATA (WT(K),K= 1, 85) / | |
31502 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, | |
31503 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, | |
31504 | & .1000D+01, .2100D+00, .1200D+00, .2700D+00, .4000D+00, | |
31505 | & .1000D+01, .1000D+01, .6400D+00, .2100D+00, .6000D-01, | |
31506 | & .2000D-01, .3000D-01, .4000D-01, .6400D+00, .2100D+00, | |
31507 | & .6000D-01, .2000D-01, .3000D-01, .4000D-01, .6400D+00, | |
31508 | & .3600D+00, .0000D+00, .0000D+00, .6400D+00, .3600D+00, | |
31509 | & .0000D+00, .0000D+00, .6900D+00, .3100D+00, .1000D+01, | |
31510 | & .5200D+00, .4800D+00, .1000D+01, .9900D+00, .1000D-01, | |
31511 | & .3800D+00, .3000D-01, .3000D+00, .2400D+00, .5000D-01, | |
31512 | & .1000D+01, .1000D+01, .0000D+00, .1000D+01, .9000D+00, | |
31513 | & .1000D-01, .9000D-01, .3300D+00, .6700D+00, .3300D+00, | |
31514 | & .6700D+00, .3300D+00, .6700D+00, .3300D+00, .6700D+00, | |
31515 | & .3300D+00, .6700D+00, .3300D+00, .6700D+00, .3300D+00, | |
31516 | & .6700D+00, .3300D+00, .6700D+00, .1900D+00, .3800D+00, | |
31517 | & .9000D-01, .2000D+00, .3000D-01, .4000D-01, .5000D-01, | |
31518 | & .2000D-01, .1900D+00, .3800D+00, .9000D-01, .2000D+00 / | |
31519 | DATA (WT(K),K= 86,170) / | |
31520 | & .3000D-01, .4000D-01, .5000D-01, .2000D-01, .1900D+00, | |
31521 | & .3800D+00, .9000D-01, .2000D+00, .3000D-01, .4000D-01, | |
31522 | & .5000D-01, .2000D-01, .1900D+00, .3800D+00, .9000D-01, | |
31523 | & .2000D+00, .3000D-01, .4000D-01, .5000D-01, .2000D-01, | |
31524 | & .8800D+00, .6000D-01, .6000D-01, .8800D+00, .6000D-01, | |
31525 | & .6000D-01, .8800D+00, .1200D+00, .1900D+00, .1900D+00, | |
31526 | & .1600D+00, .1600D+00, .1700D+00, .3000D-01, .3000D-01, | |
31527 | & .3000D-01, .4000D-01, .1000D+00, .1000D+00, .2000D+00, | |
31528 | & .1200D+00, .1000D+00, .4000D-01, .4000D-01, .5000D-01, | |
31529 | & .7500D-01, .7500D-01, .3000D-01, .3000D-01, .4000D-01, | |
31530 | & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01, | |
31531 | & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01, | |
31532 | & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00, | |
31533 | & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00, | |
31534 | & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01, | |
31535 | & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00, | |
31536 | & .2700D+00, .3000D+00, .4000D+00, .2000D+00, .1250D+00 / | |
31537 | DATA (WT(K),K=171,255) / | |
31538 | & .7500D-01, .7500D-01, .1250D+00, .4000D+00, .7500D-01, | |
31539 | & .1250D+00, .2000D+00, .1250D+00, .7500D-01, .1800D+00, | |
31540 | & .3700D+00, .1300D+00, .8000D-01, .4000D-01, .7000D-01, | |
31541 | & .1300D+00, .3700D+00, .1800D+00, .4000D-01, .8000D-01, | |
31542 | & .1300D+00, .1300D+00, .7000D-01, .7000D-01, .1300D+00, | |
31543 | & .2300D+00, .4700D+00, .5000D-01, .2000D-01, .1000D-01, | |
31544 | & .2000D-01, .1300D+00, .7000D-01, .4700D+00, .2300D+00, | |
31545 | & .5000D-01, .1000D-01, .2000D-01, .2000D-01, .1000D+01, | |
31546 | & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01, | |
31547 | & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00, | |
31548 | & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00, | |
31549 | & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01, | |
31550 | & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00, | |
31551 | & .2700D+00, .3000D+00, .1800D+00, .3700D+00, .1300D+00, | |
31552 | & .8000D-01, .4000D-01, .7000D-01, .1300D+00, .3700D+00, | |
31553 | & .1800D+00, .4000D-01, .8000D-01, .1300D+00, .1300D+00, | |
31554 | & .7000D-01, .5000D+00, .5000D+00, .1000D+01, .1000D+01 / | |
31555 | DATA (WT(K),K=256,340) / | |
31556 | & .1000D+01, .8000D+00, .2000D+00, .6000D+00, .3000D+00, | |
31557 | & .1000D+00, .6000D+00, .3000D+00, .1000D+00, .8000D+00, | |
31558 | & .2000D+00, .3300D+00, .6700D+00, .6600D+00, .1700D+00, | |
31559 | & .1700D+00, .3200D+00, .1700D+00, .3200D+00, .1900D+00, | |
31560 | & .3300D+00, .3300D+00, .3400D+00, .3000D+00, .5000D-01, | |
31561 | & .6500D+00, .3800D+00, .1200D+00, .3800D+00, .1200D+00, | |
31562 | & .3800D+00, .1200D+00, .3800D+00, .1200D+00, .3000D+00, | |
31563 | & .5000D-01, .6500D+00, .3800D+00, .2500D+00, .2500D+00, | |
31564 | & .2000D-01, .5000D-01, .5000D-01, .2000D+00, .2000D+00, | |
31565 | & .1200D+00, .1000D+00, .7000D-01, .7000D-01, .1400D+00, | |
31566 | & .5000D-01, .5000D-01, .1000D+01, .1000D+01, .1000D+01, | |
31567 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, | |
31568 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, | |
31569 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, | |
31570 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, | |
31571 | & .4800D+00, .2400D+00, .2600D+00, .2000D-01, .4700D+00, | |
31572 | & .3500D+00, .1500D+00, .3000D-01, .1000D+01, .1000D+01 / | |
31573 | DATA (WT(K),K=341,425) / | |
31574 | & .5200D+00, .4800D+00, .1000D+01, .1000D+01, .1000D+01, | |
31575 | & .1000D+01, .9000D+00, .5000D-01, .5000D-01, .9000D+00, | |
31576 | & .5000D-01, .5000D-01, .9000D+00, .5000D-01, .5000D-01, | |
31577 | & .3300D+00, .6700D+00, .6700D+00, .3300D+00, .2500D+00, | |
31578 | & .2500D+00, .5000D+00, .9000D+00, .5000D-01, .5000D-01, | |
31579 | & .9000D+00, .5000D-01, .5000D-01, .9000D+00, .5000D-01, | |
31580 | & .5000D-01, .3300D+00, .6700D+00, .6700D+00, .3300D+00, | |
31581 | & .2500D+00, .2500D+00, .5000D+00, .1000D+00, .5000D+00, | |
31582 | & .1600D+00, .2400D+00, .7000D+00, .3000D+00, .7000D+00, | |
31583 | & .3000D+00, .1000D+00, .5000D+00, .1600D+00, .2400D+00, | |
31584 | & .3000D+00, .4000D+00, .3000D+00, .3000D+00, .4000D+00, | |
31585 | & .3000D+00, .4900D+00, .4900D+00, .2000D-01, .5500D+00, | |
31586 | & .4500D+00, .6800D+00, .3000D+00, .2000D-01, .6800D+00, | |
31587 | & .3000D+00, .2000D-01, .5500D+00, .4500D+00, .9000D+00, | |
31588 | & .1000D+00, .9000D+00, .1000D+00, .6000D+00, .3000D+00, | |
31589 | & .1000D+00, .1000D+00, .1000D+00, .8000D+00, .2800D+00, | |
31590 | & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .2800D+00 / | |
31591 | DATA (WT(K),K=426,510) / | |
31592 | & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .1000D+01, | |
31593 | & .1000D+01, .1000D+01, .1000D+01, .2000D-01, .3000D-01, | |
31594 | & .7000D-01, .2000D-01, .2000D-01, .4000D-01, .1300D+00, | |
31595 | & .7000D-01, .6000D-01, .6000D-01, .2000D+00, .1400D+00, | |
31596 | & .4000D-01, .1000D+00, .2500D+00, .3000D-01, .3000D+00, | |
31597 | & .4200D+00, .2200D+00, .3500D+00, .1900D+00, .1600D+00, | |
31598 | & .8000D-01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, | |
31599 | & .1000D+01, .3700D+00, .2000D+00, .3600D+00, .7000D-01, | |
31600 | & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00, | |
31601 | & .5000D+00, .2000D-01, .3000D-01, .7000D-01, .2000D-01, | |
31602 | & .2000D-01, .4000D-01, .1300D+00, .7000D-01, .6000D-01, | |
31603 | & .6000D-01, .2000D+00, .1400D+00, .4000D-01, .1000D+00, | |
31604 | & .2500D+00, .3000D-01, .3000D+00, .4200D+00, .2200D+00, | |
31605 | & .3500D+00, .1900D+00, .1600D+00, .8000D-01, .1000D+01, | |
31606 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .3700D+00, | |
31607 | & .2000D+00, .3600D+00, .7000D-01, .5000D+00, .5000D+00, | |
31608 | & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01 / | |
31609 | DATA (WT(K),K=511,540) / | |
31610 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, | |
31611 | & .1000D+01, .1000D+01, .1000D+01, .3000D+00, .3000D+00, | |
31612 | & .4000D+00, .1000D+01, .1000D+01, .1000D+01, .1000D+01, | |
31613 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, | |
31614 | & .3000D+00, .3000D+00, .4000D+00, .3300D+00, .3300D+00, | |
31615 | & .3400D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00 / | |
31616 | C | |
31617 | DATA (WT(I),I=541,602) / .0D+00, .3334D+00, .2083D+00, 2*.125D+00, | |
31618 | & .2083D+00, .0D+00, .125D+00, .2083D+00, .3334D+00, .2083D+00, | |
31619 | & .125D+00, 0.2D+00, 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00, | |
31620 | & 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00, 0.2D+00, 0.3D+00, | |
31621 | & 0.3D+00, 0.0D+00, 0.31D+00, 0.62D+00, 0.035D+00, 0.035D+00, | |
31622 | & 18*1.D+00, 0.5D+00, 0.16D+00, 2*0.12D+00, 2*0.05D+00, 0.5D+00, | |
31623 | & 0.16D+00, 2*0.12D+00, 2*0.05D+00, 1.D+00 / | |
31624 | * Particle numbers in decay channel | |
31625 | DATA (NZK(K,1),K= 1,170) / | |
31626 | & 1, 2, 3, 4, 5, 6, 7, 1, 2, 4, | |
31627 | & 3, 23, 13, 13, 13, 10, 11, 10, 13, 13, | |
31628 | & 13, 10, 4, 11, 14, 14, 14, 11, 3, 1, | |
31629 | & 8, 1, 1, 2, 9, 2, 2, 13, 23, 8, | |
31630 | & 1, 8, 17, 7, 7, 7, 23, 23, 13, 13, | |
31631 | & 13, 13, 23, 14, 13, 13, 23, 15, 24, 24, | |
31632 | & 15, 16, 25, 25, 16, 15, 24, 24, 15, 16, | |
31633 | & 24, 25, 16, 15, 24, 36, 37, 15, 24, 15, | |
31634 | & 15, 24, 15, 37, 36, 24, 15, 24, 24, 16, | |
31635 | & 24, 38, 39, 16, 25, 16, 16, 25, 16, 39, | |
31636 | & 38, 25, 16, 25, 25, 17, 22, 21, 17, 21, | |
31637 | & 20, 17, 22, 8, 1, 21, 22, 20, 17, 48, | |
31638 | & 50, 49, 8, 1, 17, 17, 17, 21, 20, 22, | |
31639 | & 17, 22, 21, 20, 22, 19, 12, 19, 12, 1, | |
31640 | & 1, 8, 1, 8, 8, 1, 53, 54, 1, 1, | |
31641 | & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55, | |
31642 | & 56, 1, 8, 8, 55, 56, 8, 1, 53, 54 / | |
31643 | DATA (NZK(K,1),K=171,340) / | |
31644 | & 55, 1, 8, 8, 54, 55, 56, 1, 8, 1, | |
31645 | & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55, | |
31646 | & 56, 1, 8, 1, 8, 1, 8, 17, 21, 22, | |
31647 | & 1, 1, 8, 1, 8, 17, 22, 20, 8, 2, | |
31648 | & 2, 9, 2, 9, 9, 2, 67, 68, 2, 2, | |
31649 | & 9, 67, 68, 69, 2, 9, 2, 9, 68, 69, | |
31650 | & 70, 2, 9, 9, 69, 70, 9, 2, 9, 67, | |
31651 | & 68, 69, 2, 9, 2, 9, 68, 69, 70, 2, | |
31652 | & 9, 1, 8, 13, 13, 14, 1, 8, 1, 1, | |
31653 | & 8, 8, 8, 1, 8, 1, 1, 1, 1, 1, | |
31654 | & 8, 2, 2, 9, 9, 2, 2, 9, 15, 15, | |
31655 | & 24, 16, 16, 25, 25, 15, 15, 24, 24, 16, | |
31656 | & 16, 25, 1, 21, 22, 21, 48, 49, 8, 17, | |
31657 | & 20, 17, 22, 20, 20, 22, 20, 0, 0, 0, | |
31658 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
31659 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
31660 | & 31, 31, 13, 7, 15, 12, 13, 31, 17, 17 / | |
31661 | DATA (NZK(K,1),K=341,510) / | |
31662 | & 2, 9, 18, 9, 18, 18, 17, 21, 22, 17, | |
31663 | & 21, 20, 17, 20, 22, 97, 98, 97, 98, 97, | |
31664 | & 98, 17, 18, 99, 100, 18, 101, 99, 18, 101, | |
31665 | & 100, 102, 103, 102, 103, 102, 103, 18, 16, 16, | |
31666 | & 24, 24, 16, 25, 15, 24, 15, 15, 25, 25, | |
31667 | & 31, 15, 15, 31, 16, 16, 23, 13, 7, 116, | |
31668 | & 116, 116, 117, 117, 119, 118, 118, 119, 119, 120, | |
31669 | & 120, 121, 121, 130, 130, 130, 4, 10, 13, 10, | |
31670 | & 4, 32, 13, 36, 11, 3, 34, 14, 38, 133, | |
31671 | & 134, 135, 136, 21, 21, 1, 97, 104, 54, 53, | |
31672 | & 17, 22, 21, 21, 1, 54, 53, 21, 97, 21, | |
31673 | & 97, 22, 21, 97, 98, 105, 137, 137, 137, 138, | |
31674 | & 139, 97, 97, 109, 109, 140, 138, 137, 139, 138, | |
31675 | & 145, 99, 99, 2, 102, 110, 68, 67, 18, 100, | |
31676 | & 99, 99, 2, 68, 67, 99, 102, 99, 102, 100, | |
31677 | & 99, 102, 103, 111, 149, 149, 149, 150, 151, 113, | |
31678 | & 113, 115, 115, 152, 150, 149, 151, 150, 157, 140 / | |
31679 | DATA (NZK(K,1),K=511,540) / | |
31680 | & 141, 142, 143, 144, 145, 146, 147, 148, 138, 145, | |
31681 | & 140, 152, 153, 154, 155, 156, 157, 158, 159, 160, | |
31682 | & 150, 157, 152, 34, 32, 33, 33, 32, 33, 34 / | |
31683 | DATA (NZK(I,1),I=541,602) / 2, 67, 68, 69, 2, 9, 9, 68, 69, | |
31684 | & 70, 2, 9, 33, 32, 13, 14, 189, 32, 34, 23, 23, 189, 33, 34, 14, | |
31685 | & 14, 189, 23, 13, 15, 24, 36, 38, 37, 39, 194, 195, 196, 197, | |
31686 | & 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 1, 8, 1, 1, 54, | |
31687 | & 55, 8, 1, 8, 8, 54, 55, 210/ | |
31688 | DATA (NZK(K,2),K= 1,170) / | |
31689 | & 0, 0, 0, 0, 0, 0, 0, 3, 4, 6, | |
31690 | & 5, 23, 14, 11, 3, 5, 5, 5, 23, 13, | |
31691 | & 23, 23, 23, 5, 23, 13, 23, 23, 23, 14, | |
31692 | & 23, 3, 11, 13, 23, 4, 10, 14, 23, 14, | |
31693 | & 23, 13, 7, 7, 4, 7, 7, 23, 14, 14, | |
31694 | & 23, 14, 23, 23, 14, 14, 7, 23, 13, 23, | |
31695 | & 14, 23, 14, 23, 13, 23, 13, 23, 14, 23, | |
31696 | & 14, 23, 13, 23, 13, 23, 13, 33, 32, 35, | |
31697 | & 31, 23, 14, 23, 14, 33, 34, 35, 31, 23, | |
31698 | & 14, 23, 14, 33, 34, 35, 31, 23, 13, 23, | |
31699 | & 13, 33, 32, 35, 31, 13, 13, 23, 23, 14, | |
31700 | & 13, 14, 14, 25, 16, 14, 23, 13, 31, 14, | |
31701 | & 13, 23, 25, 16, 23, 35, 33, 34, 32, 33, | |
31702 | & 31, 31, 14, 13, 23, 0, 0, 0, 0, 13, | |
31703 | & 23, 13, 14, 23, 14, 13, 23, 13, 78, 23, | |
31704 | & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23, | |
31705 | & 13, 80, 79, 14, 14, 23, 80, 31, 14, 23 / | |
31706 | DATA (NZK(K,2),K=171,340) / | |
31707 | & 13, 79, 78, 31, 14, 23, 13, 80, 79, 23, | |
31708 | & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23, | |
31709 | & 13, 80, 79, 23, 13, 33, 32, 15, 24, 15, | |
31710 | & 31, 14, 23, 34, 33, 24, 24, 15, 31, 14, | |
31711 | & 23, 14, 13, 23, 13, 14, 23, 14, 80, 23, | |
31712 | & 14, 13, 23, 14, 79, 80, 13, 23, 13, 23, | |
31713 | & 14, 78, 79, 13, 13, 23, 78, 23, 14, 13, | |
31714 | & 23, 14, 79, 80, 13, 23, 13, 23, 14, 78, | |
31715 | & 79, 62, 61, 23, 14, 23, 13, 13, 13, 23, | |
31716 | & 13, 13, 23, 14, 14, 14, 1, 8, 8, 1, | |
31717 | & 8, 1, 8, 8, 1, 8, 1, 8, 1, 8, | |
31718 | & 1, 1, 8, 1, 8, 8, 1, 1, 8, 8, | |
31719 | & 1, 8, 25, 23, 13, 31, 23, 13, 16, 14, | |
31720 | & 35, 34, 34, 33, 31, 14, 23, 0, 0, 0, | |
31721 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
31722 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
31723 | & 13, 23, 14, 7, 16, 19, 14, 7, 23, 14 / | |
31724 | DATA (NZK(K,2),K=341,510) / | |
31725 | & 23, 14, 7, 13, 23, 13, 13, 23, 13, 23, | |
31726 | & 14, 13, 14, 23, 14, 23, 13, 14, 23, 14, | |
31727 | & 23, 16, 14, 23, 14, 23, 14, 13, 13, 23, | |
31728 | & 13, 23, 14, 13, 23, 13, 23, 15, 13, 13, | |
31729 | & 13, 23, 13, 13, 14, 14, 14, 14, 14, 23, | |
31730 | & 13, 16, 25, 14, 15, 24, 23, 14, 7, 23, | |
31731 | & 7, 13, 23, 7, 14, 23, 7, 23, 7, 7, | |
31732 | & 7, 7, 7, 13, 23, 31, 3, 11, 14, 135, | |
31733 | & 5, 134, 134, 134, 136, 6, 133, 133, 133, 0, | |
31734 | & 0, 0, 0, 31, 95, 25, 15, 31, 95, 16, | |
31735 | & 32, 32, 33, 35, 39, 39, 38, 25, 13, 39, | |
31736 | & 32, 39, 38, 35, 32, 39, 13, 23, 14, 7, | |
31737 | & 7, 25, 37, 32, 13, 25, 13, 25, 13, 25, | |
31738 | & 13, 31, 95, 24, 16, 31, 24, 15, 34, 34, | |
31739 | & 33, 35, 37, 37, 36, 24, 14, 37, 34, 37, | |
31740 | & 36, 35, 34, 37, 14, 23, 13, 7, 7, 24, | |
31741 | & 39, 34, 14, 24, 14, 24, 14, 24, 14, 7 / | |
31742 | DATA (NZK(K,2),K=511,540) / | |
31743 | & 7, 7, 7, 7, 7, 7, 7, 7, 25, 13, | |
31744 | & 25, 7, 7, 7, 7, 7, 7, 7, 7, 7, | |
31745 | & 24, 14, 24, 13, 14, 23, 13, 23, 14, 23 / | |
31746 | DATA (NZK(I,2),I=541,602) / 31, 13, 23, 14, 79, 80, 31, 13, 23, | |
31747 | & 14, 78, 79, 13, 23, 23, 13, 13, 14, 13, 23, 13, 23, 14, 23, 23, | |
31748 | & 14, 14, 23, 14, 16, 25, | |
31749 | & 4*23, 14*0, 23, 13, 23, 13, 23, 13, 23, 14, | |
31750 | & 23, 13, 14, 23, 0 / | |
31751 | DATA (NZK(K,3),K= 1,170) / | |
31752 | & 0, 0, 0, 0, 0, 0, 0, 5, 6, 5, | |
31753 | & 6, 23, 23, 5, 5, 0, 0, 0, 0, 14, | |
31754 | & 23, 5, 5, 0, 0, 14, 23, 5, 5, 0, | |
31755 | & 0, 5, 5, 0, 0, 5, 5, 0, 0, 0, | |
31756 | & 0, 0, 0, 0, 3, 0, 7, 23, 23, 7, | |
31757 | & 0, 0, 0, 0, 23, 0, 0, 0, 0, 0, | |
31758 | & 110*0 / | |
31759 | DATA (NZK(K,3),K=171,340) / | |
31760 | & 80*0, | |
31761 | & 0, 0, 0, 0, 0, 0, 23, 13, 14, 23, | |
31762 | & 23, 14, 23, 23, 23, 14, 23, 13, 23, 14, | |
31763 | & 13, 23, 13, 23, 14, 23, 14, 14, 23, 13, | |
31764 | & 13, 23, 13, 14, 23, 23, 14, 23, 13, 23, | |
31765 | & 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, | |
31766 | & 30*0, | |
31767 | & 14, 23, 7, 0, 0, 0, 23, 0, 0, 0 / | |
31768 | DATA (NZK(K,3),K=341,510) / | |
31769 | & 30*0, | |
31770 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 23, | |
31771 | & 14, 0, 13, 0, 14, 0, 0, 23, 13, 0, | |
31772 | & 0, 15, 0, 0, 16, 0, 0, 0, 0, 0, | |
31773 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
31774 | & 0, 0, 0, 14, 23, 0, 0, 0, 23, 134, | |
31775 | & 134, 0, 0, 0, 133, 133, 0, 0, 0, 0, | |
31776 | & 80*0 / | |
31777 | DATA (NZK(K,3),K=511,540) / | |
31778 | & 0, 0, 0, 0, 0, 0, 0, 0, 13, 13, | |
31779 | & 25, 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
31780 | & 14, 14, 24, 0, 0, 0, 0, 0, 0, 0 / | |
31781 | DATA (NZK(I,3),I=541,602) / 12*0, 2*0, 23, 13, 0, 2*0, 23, 14, 0, | |
31782 | & 2*0, 23, 13, 0, 4*0, 18*0, 2*0, 23, 14, 2*0, 2*0, 23, 14, 2*0, 0/ | |
31783 | ||
31784 | END | |
31785 | ||
31786 | *$ CREATE DT_XHOINI.FOR | |
31787 | *COPY DT_XHOINI | |
31788 | * | |
31789 | *====phoini============================================================* | |
31790 | * | |
31791 | SUBROUTINE DT_XHOINI | |
31792 | C SUBROUTINE DT_PHOINI | |
31793 | ||
31794 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
31795 | SAVE | |
31796 | ||
31797 | PARAMETER ( LINP = 10 , | |
31798 | & LOUT = 6 , | |
31799 | & LDAT = 9 ) | |
31800 | ||
31801 | RETURN | |
31802 | END | |
31803 | ||
31804 | *$ CREATE DT_XVENTB.FOR | |
31805 | *COPY DT_XVENTB | |
31806 | * | |
31807 | *====eventb============================================================* | |
31808 | * | |
31809 | SUBROUTINE DT_XVENTB(NCSY,IREJ) | |
31810 | C SUBROUTINE DT_EVENTB(NCSY,IREJ) | |
31811 | ||
31812 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
31813 | SAVE | |
31814 | ||
31815 | PARAMETER ( LINP = 10 , | |
31816 | & LOUT = 6 , | |
31817 | & LDAT = 9 ) | |
31818 | ||
31819 | WRITE(LOUT,1000) | |
31820 | 1000 FORMAT(1X,'EVENTB: PHOJET-package requested but not linked!') | |
31821 | STOP | |
31822 | ||
31823 | END | |
31824 | ||
31825 | *$ CREATE DT_XVENT.FOR | |
31826 | *COPY DT_XVENT | |
31827 | * | |
31828 | *===event==============================================================* | |
31829 | * | |
31830 | SUBROUTINE DT_XVENT(IDUM,PP,PT,DUM,IREJ) | |
31831 | C SUBROUTINE EVENT(IDUM,PP,PT,DUM,IREJ) | |
31832 | ||
31833 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
31834 | SAVE | |
31835 | ||
31836 | DIMENSION PP(4),PT(4) | |
31837 | ||
31838 | RETURN | |
31839 | END | |
31840 | ||
31841 | *$ CREATE DT_XOHISX.FOR | |
31842 | *COPY DT_XOHISX | |
31843 | * | |
31844 | *===pohisx=============================================================* | |
31845 | * | |
31846 | SUBROUTINE DT_XOHISX(I,X) | |
31847 | C SUBROUTINE POHISX(I,X) | |
31848 | ||
31849 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
31850 | SAVE | |
31851 | ||
31852 | RETURN | |
31853 | END | |
31854 | ||
31855 | *$ CREATE PHO_LHIST.FOR | |
31856 | *COPY PHO_LHIST | |
31857 | * | |
31858 | *===poluhi=============================================================* | |
31859 | * | |
31860 | SUBROUTINE PHO_LHIST(I,X) | |
31861 | ||
31862 | ** | |
31863 | ||
31864 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
31865 | SAVE | |
31866 | ||
31867 | RETURN | |
31868 | END | |
31869 | ||
31870 | *$ CREATE PDFSET.FOR | |
31871 | *COPY PDFSET | |
31872 | * | |
31873 | C********************************************************************** | |
31874 | C | |
31875 | C dummy subroutines, remove to link PDFLIB | |
31876 | C | |
31877 | C********************************************************************** | |
31878 | SUBROUTINE PDFSET(PARAM,VALUE) | |
31879 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
31880 | DIMENSION PARAM(20),VALUE(20) | |
31881 | CHARACTER*20 PARAM | |
31882 | END | |
31883 | ||
31884 | *$ CREATE STRUCTM.FOR | |
31885 | *COPY STRUCTM | |
31886 | * | |
31887 | SUBROUTINE STRUCTM(XI,SCALE2,UV,DV,US,DS,SS,CS,BS,TS,GL) | |
31888 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
31889 | END | |
31890 | ||
31891 | *$ CREATE STRUCTP.FOR | |
31892 | *COPY STRUCTP | |
31893 | * | |
31894 | SUBROUTINE STRUCTP(XI,SCALE2,P2,IP2,UV,DV,US,DS,SS,CS,BS,TS,GL) | |
31895 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
31896 | END | |
31897 | ||
31898 | *$ CREATE DT_DIQBRK.FOR | |
31899 | *COPY DT_DIQBRK | |
31900 | * | |
31901 | *===diqbrk=============================================================* | |
31902 | * | |
31903 | SUBROUTINE DT_XIQBRK | |
31904 | C SUBROUTINE DT_DIQBRK | |
31905 | ||
31906 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
31907 | SAVE | |
31908 | ||
31909 | STOP 'diquark-breaking not implemeted !' | |
31910 | ||
31911 | RETURN | |
31912 | END | |
31913 | *$ CREATE DT_ELHAIN.FOR | |
31914 | *COPY DT_ELHAIN | |
31915 | * | |
31916 | *===elhain=============================================================* | |
31917 | * | |
31918 | SUBROUTINE DT_ELHAIN(IP,PLA,ELAB,CX,CY,CZ,IT,IREJ) | |
31919 | ||
31920 | ************************************************************************ | |
31921 | * Elastic hadron-hadron scattering. * | |
31922 | * This is a revised version of the original. * | |
31923 | * This version dated 03.04.98 is written by S. Roesler * | |
31924 | ************************************************************************ | |
31925 | ||
31926 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
31927 | SAVE | |
31928 | ||
31929 | PARAMETER ( LINP = 10 , | |
31930 | & LOUT = 6 , | |
31931 | & LDAT = 9 ) | |
31932 | ||
31933 | PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0, | |
31934 | & TINY10=1.0D-10) | |
31935 | ||
31936 | PARAMETER (ENNTHR = 3.5D0) | |
31937 | PARAMETER (PLOWH=0.01D0,PHIH=9.0D0, | |
31938 | & BLOWB=0.05D0,BHIB=0.2D0, | |
31939 | & BLOWM=0.1D0, BHIM=2.0D0) | |
31940 | ||
31941 | * particle properties (BAMJET index convention) | |
31942 | CHARACTER*8 ANAME | |
31943 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
31944 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
31945 | ||
31946 | * final state from HADRIN interaction | |
31947 | PARAMETER (MAXFIN=10) | |
31948 | COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN), | |
31949 | & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH | |
31950 | ||
31951 | C DATA TSLOPE /10.0D0/ | |
31952 | ||
31953 | IREJ = 0 | |
31954 | ||
31955 | 1 CONTINUE | |
31956 | ||
31957 | PLAB = SQRT( (ELAB-AAM(IP))*(ELAB+AAM(IP)) ) | |
31958 | EKIN = ELAB-AAM(IP) | |
31959 | * kinematical quantities in cms of the hadrons | |
31960 | AMP2 = AAM(IP)**2 | |
31961 | AMT2 = AAM(IT)**2 | |
31962 | S = AMP2+AMT2+TWO*ELAB*AAM(IT) | |
31963 | ECM = SQRT(S) | |
31964 | ECMP = OHALF*ECM+(AMP2-AMT2)/(TWO*ECM) | |
31965 | PCM = SQRT( (ECMP-AAM(IP))*(ECMP+AAM(IP)) ) | |
31966 | ||
31967 | * nucleon-nucleon scattering at E_kin<3.5: use DT_TSAMCS(HETC-KFA) | |
31968 | IF ( ((IP.EQ.1).OR.(IP.EQ.8)).AND. | |
31969 | & ((IT.EQ.1).OR.(IT.EQ.8)).AND.(EKIN.LT.ENNTHR) ) THEN | |
31970 | * TSAMCS treats pp and np only, therefore change pn into np and | |
31971 | * nn into pp | |
31972 | IF (IT.EQ.1) THEN | |
31973 | KPROJ = IP | |
31974 | ELSE | |
31975 | KPROJ = 8 | |
31976 | IF (IP.EQ.8) KPROJ = 1 | |
31977 | ENDIF | |
31978 | CALL DT_TSAMCS(KPROJ,EKIN,CTCMS) | |
31979 | T = TWO*PCM**2*(CTCMS-ONE) | |
31980 | ||
31981 | * very crude treatment otherwise: sample t from exponential dist. | |
31982 | ELSE | |
31983 | * momentum transfer t | |
31984 | TMAX = TWO*TWO*PCM**2 | |
31985 | RR = (PLAB-PLOWH)/(PHIH-PLOWH) | |
31986 | IF (IIBAR(IP).NE.0) THEN | |
31987 | TSLOPE = BLOWB+RR*(BHIB-BLOWB) | |
31988 | ELSE | |
31989 | TSLOPE = BLOWM+RR*(BHIM-BLOWM) | |
31990 | ENDIF | |
31991 | FMAX = EXP(-TSLOPE*TMAX)-ONE | |
31992 | R = DT_RNDM(RR) | |
31993 | T = LOG(ONE+R*FMAX+TINY10)/TSLOPE | |
31994 | IF (T.GT.ZERO) T = LOG(ONE+R*FMAX)/TSLOPE | |
31995 | ENDIF | |
31996 | ||
31997 | * target hadron in Lab after scattering | |
31998 | ELRH(2) = (TWO*AMT2-T)/(TWO*AAM(IT)) | |
31999 | PLRH(2) = SQRT( ABS(ELRH(2)-AAM(IT))*(ELRH(2)+AAM(IT)) ) | |
32000 | IF (PLRH(2).LE.TINY10) THEN | |
32001 | C WRITE(*,*)'ELHAIN: T,PLRH(2) ',T,PLRH(2) | |
32002 | GOTO 1 | |
32003 | ENDIF | |
32004 | * projectile hadron in Lab after scattering | |
32005 | ELRH(1) = ELAB+AAM(IT)-ELRH(2) | |
32006 | PLRH(1) = SQRT( ABS(ELRH(1)-AAM(IP))*(ELRH(1)+AAM(IP)) ) | |
32007 | * scattering angle of projectile in Lab | |
32008 | CTLABP = (T-TWO*AMP2+TWO*ELAB*ELRH(1))/(TWO*PLAB*PLRH(1)) | |
32009 | STLABP = SQRT( (ONE-CTLABP)*(ONE+CTLABP) ) | |
32010 | CALL DT_DSFECF(SPLABP,CPLABP) | |
32011 | * direction cosines of projectile in Lab | |
32012 | CALL DT_STTRAN(CX,CY,CZ,CTLABP,STLABP,SPLABP,CPLABP, | |
32013 | & CXRH(1),CYRH(1),CZRH(1)) | |
32014 | * scattering angle of target in Lab | |
32015 | PLLABT = PLAB-CTLABP*PLRH(1) | |
32016 | CTLABT = PLLABT/PLRH(2) | |
32017 | STLABT = SQRT( (ONE-CTLABT)*(ONE+CTLABT) ) | |
32018 | * direction cosines of target in Lab | |
32019 | CALL DT_STTRAN(CX,CY,CZ,CTLABT,STLABT,-SPLABP,-CPLABP, | |
32020 | & CXRH(2),CYRH(2),CZRH(2)) | |
32021 | * fill /HNFSPA/ | |
32022 | IRH = 2 | |
32023 | ITRH(1) = IP | |
32024 | ITRH(2) = IT | |
32025 | ||
32026 | RETURN | |
32027 | END | |
32028 | ||
32029 | *$ CREATE DT_TSAMCS.FOR | |
32030 | *COPY DT_TSAMCS | |
32031 | * | |
32032 | *===tsamcs=============================================================* | |
32033 | * | |
32034 | SUBROUTINE DT_TSAMCS(KPROJ,EKIN,CST) | |
32035 | ||
32036 | ************************************************************************ | |
32037 | * Sampling of cos(theta) for nucleon-proton scattering according to * | |
32038 | * hetkfa2/bertini parametrization. * | |
32039 | * This is a revised version of the original (HJM 24/10/88) * | |
32040 | * This version dated 28.10.95 is written by S. Roesler * | |
32041 | ************************************************************************ | |
32042 | ||
32043 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
32044 | SAVE | |
32045 | ||
32046 | PARAMETER ( LINP = 10 , | |
32047 | & LOUT = 6 , | |
32048 | & LDAT = 9 ) | |
32049 | ||
32050 | PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0, | |
32051 | & TINY10=1.0D-10) | |
32052 | ||
32053 | DIMENSION DCLIN(195),DCHN(143),DCHNA(36),DCHNB(60) | |
32054 | DIMENSION PDCI(60),PDCH(55) | |
32055 | ||
32056 | DATA (DCLIN(I),I=1,80) / | |
32057 | & 5.000D-01, 1.000D+00, 0.000D+00, 1.000D+00, 0.000D+00, | |
32058 | & 4.993D-01, 9.881D-01, 5.963D-02, 9.851D-01, 5.945D-02, | |
32059 | & 4.936D-01, 8.955D-01, 5.224D-01, 8.727D-01, 5.091D-01, | |
32060 | & 4.889D-01, 8.228D-01, 8.859D-01, 7.871D-01, 8.518D-01, | |
32061 | & 4.874D-01, 7.580D-01, 1.210D+00, 7.207D-01, 1.117D+00, | |
32062 | & 4.912D-01, 6.969D-01, 1.516D+00, 6.728D-01, 1.309D+00, | |
32063 | & 5.075D-01, 6.471D-01, 1.765D+00, 6.667D-01, 1.333D+00, | |
32064 | & 5.383D-01, 6.054D-01, 1.973D+00, 7.059D-01, 1.176D+00, | |
32065 | & 5.397D-01, 5.990D-01, 2.005D+00, 7.023D-01, 1.191D+00, | |
32066 | & 5.336D-01, 6.083D-01, 1.958D+00, 6.959D-01, 1.216D+00, | |
32067 | & 5.317D-01, 6.075D-01, 1.962D+00, 6.897D-01, 1.241D+00, | |
32068 | & 5.300D-01, 6.016D-01, 1.992D+00, 6.786D-01, 1.286D+00, | |
32069 | & 5.281D-01, 6.063D-01, 1.969D+00, 6.786D-01, 1.286D+00, | |
32070 | & 5.280D-01, 5.960D-01, 2.020D+00, 6.667D-01, 1.333D+00, | |
32071 | & 5.273D-01, 5.920D-01, 2.040D+00, 6.604D-01, 1.358D+00, | |
32072 | & 5.273D-01, 5.862D-01, 2.069D+00, 6.538D-01, 1.385D+00/ | |
32073 | DATA (DCLIN(I),I=81,160) / | |
32074 | & 5.223D-01, 5.980D-01, 2.814D+00, 6.538D-01, 1.385D+00, | |
32075 | & 5.202D-01, 5.969D-01, 2.822D+00, 6.471D-01, 1.412D+00, | |
32076 | & 5.183D-01, 5.881D-01, 2.883D+00, 6.327D-01, 1.469D+00, | |
32077 | & 5.159D-01, 5.866D-01, 2.894D+00, 6.250D-01, 1.500D+00, | |
32078 | & 5.133D-01, 5.850D-01, 2.905D+00, 6.170D-01, 1.532D+00, | |
32079 | & 5.106D-01, 5.833D-01, 2.917D+00, 6.087D-01, 1.565D+00, | |
32080 | & 5.084D-01, 5.801D-01, 2.939D+00, 6.000D-01, 1.600D+00, | |
32081 | & 5.063D-01, 5.763D-01, 2.966D+00, 5.909D-01, 1.636D+00, | |
32082 | & 5.036D-01, 5.730D-01, 2.989D+00, 5.814D-01, 1.674D+00, | |
32083 | & 5.014D-01, 5.683D-01, 3.022D+00, 5.714D-01, 1.714D+00, | |
32084 | & 4.986D-01, 5.641D-01, 3.051D+00, 5.610D-01, 1.756D+00, | |
32085 | & 4.964D-01, 5.580D-01, 3.094D+00, 5.500D-01, 1.800D+00, | |
32086 | & 4.936D-01, 5.573D-01, 3.099D+00, 5.431D-01, 1.827D+00, | |
32087 | & 4.909D-01, 5.509D-01, 3.144D+00, 5.313D-01, 1.875D+00, | |
32088 | & 4.885D-01, 5.512D-01, 3.142D+00, 5.263D-01, 1.895D+00, | |
32089 | & 4.857D-01, 5.437D-01, 3.194D+00, 5.135D-01, 1.946D+00/ | |
32090 | DATA (DCLIN(I),I=161,195) / | |
32091 | & 4.830D-01, 5.353D-01, 3.253D+00, 5.000D-01, 2.000D+00, | |
32092 | & 4.801D-01, 5.323D-01, 3.274D+00, 4.915D-01, 2.034D+00, | |
32093 | & 4.770D-01, 5.228D-01, 3.341D+00, 4.767D-01, 2.093D+00, | |
32094 | & 4.738D-01, 5.156D-01, 3.391D+00, 4.643D-01, 2.143D+00, | |
32095 | & 4.701D-01, 5.010D-01, 3.493D+00, 4.444D-01, 2.222D+00, | |
32096 | & 4.672D-01, 4.990D-01, 3.507D+00, 4.375D-01, 2.250D+00, | |
32097 | & 4.634D-01, 4.856D-01, 3.601D+00, 4.194D-01, 2.323D+00/ | |
32098 | ||
32099 | DATA PDCI / | |
32100 | & 4.400D+02, 1.896D-01, 1.931D-01, 1.982D-01, 1.015D-01, | |
32101 | & 1.029D-01, 4.180D-02, 4.228D-02, 4.282D-02, 4.350D-02, | |
32102 | & 2.204D-02, 2.236D-02, 5.900D+02, 1.433D-01, 1.555D-01, | |
32103 | & 1.774D-01, 1.000D-01, 1.128D-01, 5.132D-02, 5.600D-02, | |
32104 | & 6.158D-02, 6.796D-02, 3.660D-02, 3.820D-02, 6.500D+02, | |
32105 | & 1.192D-01, 1.334D-01, 1.620D-01, 9.527D-02, 1.141D-01, | |
32106 | & 5.283D-02, 5.952D-02, 6.765D-02, 7.878D-02, 4.796D-02, | |
32107 | & 6.957D-02, 8.000D+02, 4.872D-02, 6.694D-02, 1.152D-01, | |
32108 | & 9.348D-02, 1.368D-01, 6.912D-02, 7.953D-02, 9.577D-02, | |
32109 | & 1.222D-01, 7.755D-02, 9.525D-02, 1.000D+03, 3.997D-02, | |
32110 | & 5.456D-02, 9.804D-02, 8.084D-02, 1.208D-01, 6.520D-02, | |
32111 | & 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02, 1.093D-01/ | |
32112 | ||
32113 | DATA PDCH / | |
32114 | & 1.000D+03, 9.453D-02, 9.804D-02, 8.084D-02, 1.208D-01, | |
32115 | & 6.520D-02, 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02, | |
32116 | & 1.093D-01, 1.400D+03, 1.072D-01, 7.450D-02, 6.645D-02, | |
32117 | & 1.136D-01, 6.750D-02, 8.580D-02, 1.110D-01, 1.530D-01, | |
32118 | & 1.010D-01, 1.350D-01, 2.170D+03, 4.004D-02, 3.013D-02, | |
32119 | & 2.664D-02, 5.511D-02, 4.240D-02, 7.660D-02, 1.364D-01, | |
32120 | & 2.300D-01, 1.670D-01, 2.010D-01, 2.900D+03, 1.870D-02, | |
32121 | & 1.804D-02, 1.320D-02, 2.970D-02, 2.860D-02, 5.160D-02, | |
32122 | & 1.020D-01, 2.400D-01, 2.250D-01, 3.370D-01, 4.400D+03, | |
32123 | & 1.196D-03, 8.784D-03, 1.517D-02, 2.874D-02, 2.488D-02, | |
32124 | & 4.464D-02, 8.330D-02, 2.008D-01, 2.360D-01, 3.567D-01/ | |
32125 | ||
32126 | DATA (DCHN(I),I=1,90) / | |
32127 | & 4.770D-01, 4.750D-01, 4.715D-01, 4.685D-01, 4.650D-01, | |
32128 | & 4.610D-01, 4.570D-01, 4.550D-01, 4.500D-01, 4.450D-01, | |
32129 | & 4.405D-01, 4.350D-01, 4.300D-01, 4.250D-01, 4.200D-01, | |
32130 | & 4.130D-01, 4.060D-01, 4.000D-01, 3.915D-01, 3.840D-01, | |
32131 | & 3.760D-01, 3.675D-01, 3.580D-01, 3.500D-01, 3.400D-01, | |
32132 | & 3.300D-01, 3.200D-01, 3.100D-01, 3.000D-01, 2.900D-01, | |
32133 | & 2.800D-01, 2.700D-01, 2.600D-01, 2.500D-01, 2.400D-01, | |
32134 | & 2.315D-01, 2.240D-01, 2.150D-01, 2.060D-01, 2.000D-01, | |
32135 | & 1.915D-01, 1.850D-01, 1.780D-01, 1.720D-01, 1.660D-01, | |
32136 | & 1.600D-01, 1.550D-01, 1.500D-01, 1.450D-01, 1.400D-01, | |
32137 | & 1.360D-01, 1.320D-01, 1.280D-01, 1.250D-01, 1.210D-01, | |
32138 | & 1.180D-01, 1.150D-01, 1.120D-01, 1.100D-01, 1.070D-01, | |
32139 | & 1.050D-01, 1.030D-01, 1.010D-01, 9.900D-02, 9.700D-02, | |
32140 | & 9.550D-02, 9.480D-02, 9.400D-02, 9.200D-02, 9.150D-02, | |
32141 | & 9.100D-02, 9.000D-02, 8.990D-02, 8.900D-02, 8.850D-02, | |
32142 | & 8.750D-02, 8.700D-02, 8.650D-02, 8.550D-02, 8.500D-02, | |
32143 | & 8.499D-02, 8.450D-02, 8.350D-02, 8.300D-02, 8.250D-02, | |
32144 | & 8.150D-02, 8.100D-02, 8.030D-02, 8.000D-02, 7.990D-02/ | |
32145 | DATA (DCHN(I),I=91,143) / | |
32146 | & 7.980D-02, 7.950D-02, 7.900D-02, 7.860D-02, 7.800D-02, | |
32147 | & 7.750D-02, 7.650D-02, 7.620D-02, 7.600D-02, 7.550D-02, | |
32148 | & 7.530D-02, 7.500D-02, 7.499D-02, 7.498D-02, 7.480D-02, | |
32149 | & 7.450D-02, 7.400D-02, 7.350D-02, 7.300D-02, 7.250D-02, | |
32150 | & 7.230D-02, 7.200D-02, 7.100D-02, 7.050D-02, 7.020D-02, | |
32151 | & 7.000D-02, 6.999D-02, 6.995D-02, 6.993D-02, 6.991D-02, | |
32152 | & 6.990D-02, 6.870D-02, 6.850D-02, 6.800D-02, 6.780D-02, | |
32153 | & 6.750D-02, 6.700D-02, 6.650D-02, 6.630D-02, 6.600D-02, | |
32154 | & 6.550D-02, 6.525D-02, 6.510D-02, 6.500D-02, 6.499D-02, | |
32155 | & 6.498D-02, 6.496D-02, 6.494D-02, 6.493D-02, 6.490D-02, | |
32156 | & 6.488D-02, 6.485D-02, 6.480D-02/ | |
32157 | ||
32158 | DATA DCHNA / | |
32159 | & 6.300D+02, 7.810D-02, 1.421D-01, 1.979D-01, 2.479D-01, | |
32160 | & 3.360D-01, 5.400D-01, 7.236D-01, 1.000D+00, 1.540D+03, | |
32161 | & 2.225D-01, 3.950D-01, 5.279D-01, 6.298D-01, 7.718D-01, | |
32162 | & 9.405D-01, 9.835D-01, 1.000D+00, 2.560D+03, 2.625D-01, | |
32163 | & 4.550D-01, 5.963D-01, 7.020D-01, 8.380D-01, 9.603D-01, | |
32164 | & 9.903D-01, 1.000D+00, 3.520D+03, 4.250D-01, 6.875D-01, | |
32165 | & 8.363D-01, 9.163D-01, 9.828D-01, 1.000D+00, 1.000D+00, | |
32166 | & 1.000D+00/ | |
32167 | ||
32168 | DATA DCHNB / | |
32169 | & 6.300D+02, 3.800D-02, 7.164D-02, 1.275D-01, 2.171D-01, | |
32170 | & 3.227D-01, 4.091D-01, 5.051D-01, 6.061D-01, 7.074D-01, | |
32171 | & 8.434D-01, 1.000D+00, 2.040D+03, 1.200D-01, 2.115D-01, | |
32172 | & 3.395D-01, 5.295D-01, 7.251D-01, 8.511D-01, 9.487D-01, | |
32173 | & 9.987D-01, 1.000D+00, 1.000D+00, 1.000D+00, 2.200D+03, | |
32174 | & 1.344D-01, 2.324D-01, 3.754D-01, 5.674D-01, 7.624D-01, | |
32175 | & 8.896D-01, 9.808D-01, 1.000D+00, 1.000D+00, 1.000D+00, | |
32176 | & 1.000D+00, 2.850D+03, 2.330D-01, 4.130D-01, 6.610D-01, | |
32177 | & 9.010D-01, 9.970D-01, 1.000D+00, 1.000D+00, 1.000D+00, | |
32178 | & 1.000D+00, 1.000D+00, 1.000D+00, 3.500D+03, 3.300D-01, | |
32179 | & 5.450D-01, 7.950D-01, 1.000D+00, 1.000D+00, 1.000D+00, | |
32180 | & 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00/ | |
32181 | ||
32182 | CST = ONE | |
32183 | IF (EKIN.GT.3.5D0) RETURN | |
32184 | C | |
32185 | IF(KPROJ.EQ.8) GOTO 101 | |
32186 | IF(KPROJ.EQ.1) GOTO 102 | |
32187 | C* INVALID REACTION | |
32188 | WRITE(LOUT,'(A,I5/A)') | |
32189 | & ' INVALID PARTICLE TYPE IN DNUPRE - KPROJ=',KPROJ, | |
32190 | & ' COS(THETA) = 1D0 RETURNED' | |
32191 | RETURN | |
32192 | C-------------------------------- NP ELASTIC SCATTERING---------- | |
32193 | 101 CONTINUE | |
32194 | IF (EKIN.GT.0.740D0)GOTO 1000 | |
32195 | IF (EKIN.LT.0.300D0)THEN | |
32196 | C EKIN .LT. 300 MEV | |
32197 | IDAT=1 | |
32198 | ELSE | |
32199 | C 300 MEV < EKIN < 740 MEV | |
32200 | IDAT=6 | |
32201 | END IF | |
32202 | C | |
32203 | ENER=EKIN | |
32204 | IE=INT(ABS(ENER/0.020D0)) | |
32205 | UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0 | |
32206 | C FORWARD/BACKWARD DECISION | |
32207 | K=IDAT+5*IE | |
32208 | BWFW=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K) | |
32209 | IF (DT_RNDM(CST).LT.BWFW)THEN | |
32210 | VALUE2=-1D0 | |
32211 | K=K+1 | |
32212 | ELSE | |
32213 | VALUE2=1D0 | |
32214 | K=K+3 | |
32215 | END IF | |
32216 | C | |
32217 | COEF=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K) | |
32218 | RND=DT_RNDM(COEF) | |
32219 | C | |
32220 | IF(RND.LT.COEF)THEN | |
32221 | CST=DT_RNDM(RND) | |
32222 | CST=CST*VALUE2 | |
32223 | ELSE | |
32224 | R1=DT_RNDM(CST) | |
32225 | R2=DT_RNDM(R1) | |
32226 | R3=DT_RNDM(R2) | |
32227 | R4=DT_RNDM(R3) | |
32228 | C | |
32229 | IF(VALUE2.GT.0.0)THEN | |
32230 | CST=MAX(R1,R2,R3,R4) | |
32231 | GOTO 1500 | |
32232 | ELSE | |
32233 | R5=DT_RNDM(R4) | |
32234 | C | |
32235 | IF (IDAT.EQ.1)THEN | |
32236 | CST=-MAX(R1,R2,R3,R4,R5) | |
32237 | ELSE | |
32238 | R6=DT_RNDM(R5) | |
32239 | R7=DT_RNDM(R6) | |
32240 | CST=-MAX(R1,R2,R3,R4,R5,R6,R7) | |
32241 | END IF | |
32242 | C | |
32243 | END IF | |
32244 | C | |
32245 | END IF | |
32246 | C | |
32247 | GOTO 1500 | |
32248 | C | |
32249 | C******** EKIN .GT. 0.74 GEV | |
32250 | C | |
32251 | 1000 ENER=EKIN - 0.66D0 | |
32252 | C IE=ABS(ENER/0.02) | |
32253 | IE=INT(ENER/0.02D0) | |
32254 | EMEV=EKIN*1D3 | |
32255 | C | |
32256 | UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0 | |
32257 | K=IE | |
32258 | BWFW=(DCHN(K+1)-DCHN(K))*UNIV + DCHN(K) | |
32259 | RND=DT_RNDM(BWFW) | |
32260 | C FORWARD NEUTRON | |
32261 | IF (RND.GE.BWFW)THEN | |
32262 | DO 1200 K=10,36,9 | |
32263 | IF (DCHNA(K).GT.EMEV) THEN | |
32264 | UNIVE=(EMEV-DCHNA(K-9))/(DCHNA(K)-DCHNA(K-9)) | |
32265 | UNIV=DT_RNDM(UNIVE) | |
32266 | DO 1100 I=1,8 | |
32267 | II=K+I | |
32268 | P=(DCHNA(II)-DCHNA(II-9))*UNIVE + DCHNA(II-9) | |
32269 | C | |
32270 | IF (P.GT.UNIV)THEN | |
32271 | UNIV=DT_RNDM(UNIVE) | |
32272 | FLTI=DBLE(I)-UNIV | |
32273 | GOTO(290,290,290,290,330,340,350,360) I | |
32274 | END IF | |
32275 | 1100 CONTINUE | |
32276 | END IF | |
32277 | 1200 CONTINUE | |
32278 | C | |
32279 | ELSE | |
32280 | C BACKWARD NEUTRON | |
32281 | DO 1400 K=13,60,12 | |
32282 | IF (DCHNB(K).GT.EMEV) THEN | |
32283 | UNIVE=(EMEV-DCHNB(K-12))/(DCHNB(K)-DCHNB(K-12)) | |
32284 | UNIV=DT_RNDM(UNIVE) | |
32285 | DO 1300 I=1,11 | |
32286 | II=K+I | |
32287 | P=(DCHNB(II)-DCHNB(II-12))*UNIVE + DCHNB(II-12) | |
32288 | C | |
32289 | IF (P.GT.UNIV)THEN | |
32290 | UNIV=DT_RNDM(P) | |
32291 | FLTI=DBLE(I)-UNIV | |
32292 | GOTO(120,120,140,150,160,160,180,190,200,210,220) I | |
32293 | END IF | |
32294 | 1300 CONTINUE | |
32295 | END IF | |
32296 | 1400 CONTINUE | |
32297 | END IF | |
32298 | C | |
32299 | 120 CST=1.0D-2*FLTI-1.0D0 | |
32300 | GOTO 1500 | |
32301 | 140 CST=2.0D-2*UNIV-0.98D0 | |
32302 | GOTO 1500 | |
32303 | 150 CST=4.0D-2*UNIV-0.96D0 | |
32304 | GOTO 1500 | |
32305 | 160 CST=6.0D-2*FLTI-1.16D0 | |
32306 | GOTO 1500 | |
32307 | 180 CST=8.0D-2*UNIV-0.80D0 | |
32308 | GOTO 1500 | |
32309 | 190 CST=1.0D-1*UNIV-0.72D0 | |
32310 | GOTO 1500 | |
32311 | 200 CST=1.2D-1*UNIV-0.62D0 | |
32312 | GOTO 1500 | |
32313 | 210 CST=2.0D-1*UNIV-0.50D0 | |
32314 | GOTO 1500 | |
32315 | 220 CST=3.0D-1*(UNIV-1.0D0) | |
32316 | GOTO 1500 | |
32317 | C | |
32318 | 290 CST=1.0D0-2.5d-2*FLTI | |
32319 | GOTO 1500 | |
32320 | 330 CST=0.85D0+0.5D-1*UNIV | |
32321 | GOTO 1500 | |
32322 | 340 CST=0.70D0+1.5D-1*UNIV | |
32323 | GOTO 1500 | |
32324 | 350 CST=0.50D0+2.0D-1*UNIV | |
32325 | GOTO 1500 | |
32326 | 360 CST=0.50D0*UNIV | |
32327 | C | |
32328 | 1500 RETURN | |
32329 | C | |
32330 | C----------------------------------- PP ELASTIC SCATTERING ------- | |
32331 | C | |
32332 | 102 CONTINUE | |
32333 | EMEV=EKIN*1D3 | |
32334 | C | |
32335 | IF (EKIN.LE.0.500D0) THEN | |
32336 | RND=DT_RNDM(EMEV) | |
32337 | CST=2.0D0*RND-1.0D0 | |
32338 | RETURN | |
32339 | C | |
32340 | ELSEIF (EKIN.LT.1.0D0) THEN | |
32341 | DO 2200 K=13,60,12 | |
32342 | IF (PDCI(K).GT.EMEV) THEN | |
32343 | UNIVE=(EMEV-PDCI(K-12))/(PDCI(K)-PDCI(K-12)) | |
32344 | UNIV=DT_RNDM(UNIVE) | |
32345 | SUM=0 | |
32346 | DO 2100 I=1,11 | |
32347 | II=K+I | |
32348 | SUM=SUM + (PDCI(II)-PDCI(II-12))*UNIVE + PDCI(II-12) | |
32349 | C | |
32350 | IF (UNIV.LT.SUM)THEN | |
32351 | UNIV=DT_RNDM(SUM) | |
32352 | FLTI=DBLE(I)-UNIV | |
32353 | GOTO(55,55,55,60,60,65,65,65,65,70,70) I | |
32354 | END IF | |
32355 | 2100 CONTINUE | |
32356 | END IF | |
32357 | 2200 CONTINUE | |
32358 | ELSE | |
32359 | DO 2400 K=12,55,11 | |
32360 | IF (PDCH(K).GT.EMEV) THEN | |
32361 | UNIVE=(EMEV-PDCH(K-11))/(PDCH(K)-PDCH(K-11)) | |
32362 | UNIV=DT_RNDM(UNIVE) | |
32363 | SUM=0.0D0 | |
32364 | DO 2300 I=1,10 | |
32365 | II=K+I | |
32366 | SUM=SUM + (PDCH(II)-PDCH(II-11))*UNIVE + PDCH(II-11) | |
32367 | C | |
32368 | IF (UNIV.LT.SUM)THEN | |
32369 | UNIV=DT_RNDM(SUM) | |
32370 | FLTI=UNIV+DBLE(I) | |
32371 | GOTO(50,55,60,60,65,65,65,65,70,70) I | |
32372 | END IF | |
32373 | 2300 CONTINUE | |
32374 | END IF | |
32375 | 2400 CONTINUE | |
32376 | END IF | |
32377 | C | |
32378 | 50 CST=0.4D0*UNIV | |
32379 | GOTO 2500 | |
32380 | 55 CST=0.2D0*FLTI | |
32381 | GOTO 2500 | |
32382 | 60 CST=0.3D0+0.1D0*FLTI | |
32383 | GOTO 2500 | |
32384 | 65 CST=0.6D0+0.04D0*FLTI | |
32385 | GOTO 2500 | |
32386 | 70 CST=0.78D0+0.02D0*FLTI | |
32387 | C | |
32388 | 2500 CONTINUE | |
32389 | IF (DT_RNDM(CST).GT.0.5D0) CST=-CST | |
32390 | C | |
32391 | RETURN | |
32392 | END | |
32393 | ||
32394 | *$ CREATE DT_DHADRI.FOR | |
32395 | *COPY DT_DHADRI | |
32396 | * | |
32397 | *===dhadri=============================================================* | |
32398 | * | |
32399 | SUBROUTINE DT_DHADRI(N,PLAB,ELAB,CX,CY,CZ,ITTA) | |
32400 | ||
32401 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
32402 | SAVE | |
32403 | ||
32404 | PARAMETER ( LINP = 10 , | |
32405 | & LOUT = 6 , | |
32406 | & LDAT = 9 ) | |
32407 | ||
32408 | C | |
32409 | C----------------------------- | |
32410 | C*** INPUT VARIABLES LIST: | |
32411 | C*** SAMPLING OF HADRON NUCLEON INTERACTION FOR (ABOUT) 0.1 LE PLAB LE 6 | |
32412 | C*** GEV/C LABORATORY MOMENTUM REGION | |
32413 | C*** N - PROJECTILE HADRON INDEX | |
32414 | C*** PLAB - LABORATORY MOMENTUM OF N (GEV/C) | |
32415 | C*** ELAB - LABORATORY ENERGY OF N (GEV) | |
32416 | C*** CX,CY,CZ - DIRECTION COSINES OF N IN THE LABORATORY SYSTEM | |
32417 | C*** ITTA - TARGET NUCLEON INDEX | |
32418 | C*** OUTPUT VARIABLES LIST OF PARTICLE CHARACTERISTICS IN /FINLSP/ | |
32419 | C IR COUNTS THE NUMBER OF PRODUCED PARTICLES | |
32420 | C*** ITR - PARTICLE INDEX, CXR,CYR,CZR - DIRECTION COSINES (LAB. SYST.) | |
32421 | C*** ELR,PLR LAB. ENERGY AND LAB. MOMENTUM OF THE SAMPLED PARTICLE | |
32422 | C*** RESPECT., UNITS (GEV/C AND GEV) | |
32423 | C---------------------------- | |
32424 | ||
32425 | COMMON /HNGAMR/ REDU,AMO,AMM(15) | |
32426 | ||
32427 | COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17) | |
32428 | ||
32429 | COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184), | |
32430 | & NRK(2,268),NURE(30,2) | |
32431 | ||
32432 | * particle properties (BAMJET index convention), | |
32433 | * (dublicate of DTPART for HADRIN) | |
32434 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), | |
32435 | & K1H(110),K2H(110) | |
32436 | ||
32437 | COMMON /HNSPLI/ WTI(460),NZKI(460,3) | |
32438 | ||
32439 | COMMON /HNMETL/ CXS(149),CYS(149),CZS(149),ELS(149),PLS(149), | |
32440 | & ITS(149),IS | |
32441 | ||
32442 | COMMON /HNDRUN/ RUNTES,EFTES | |
32443 | ||
32444 | * particle properties (BAMJET index convention) | |
32445 | CHARACTER*8 ANAME | |
32446 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
32447 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
32448 | ||
32449 | * final state from HADRIN interaction | |
32450 | PARAMETER (MAXFIN=10) | |
32451 | COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN), | |
32452 | & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH | |
32453 | ||
32454 | DIMENSION ITPRF(110) | |
32455 | DATA NNN/0/ | |
32456 | DATA UMODA/0./ | |
32457 | DATA ITPRF/-1,-1,5*1,-1,-1,1,1,1,-1,-1,-1,-1,6*1,-1,-1,-1,85*1/ | |
32458 | LOWP=0 | |
32459 | IF (N.LE.0.OR.N.GE.111)N=1 | |
32460 | IF (ITPRF( N ).GT.0 .OR. ITTA.GT.8) THEN | |
32461 | GOTO 280 | |
32462 | * WRITE (6,1000) | |
32463 | * + ' FALSE USE OF THE PARTICLE TYPE INDEX: N, ITTA', N, ITTA | |
32464 | * STOP | |
32465 | *1000 FORMAT (3(5H ****/),A,2I4,3(5H ****/)) | |
32466 | * + 45H FALSE USE OF THE PARTICLE TYPE INDEX, N,LUE ,I4,3(5H ****/)) | |
32467 | ENDIF | |
32468 | IATMPT=0 | |
32469 | IF (ABS(PLAB-5.0D0).LT.4.99999D0) GO TO 20 | |
32470 | C IF(IPRI.GE.1) WRITE (6,1010) PLAB | |
32471 | C STOP | |
32472 | 1010 FORMAT ( ' PROJECTILE HADRON MOMENTUM OUTSIDE OF THE | |
32473 | + ALLOWED REGION, PLAB=',1E15.5) | |
32474 | ||
32475 | 20 CONTINUE | |
32476 | UMODAT=N*1.11111D0+ITTA*2.19291D0 | |
32477 | IF(UMODAT.NE.UMODA) CALL DT_DCALUM(N,ITTA) | |
32478 | UMODA=UMODAT | |
32479 | 30 IATMPT=0 | |
32480 | LOWP=LOWP+1 | |
32481 | 40 CONTINUE | |
32482 | IMACH=0 | |
32483 | REDU=2.0D0 | |
32484 | IF (LOWP.GT.20) THEN | |
32485 | C WRITE(LOUT,*) ' jump 1' | |
32486 | GO TO 280 | |
32487 | ENDIF | |
32488 | NNN=N | |
32489 | IF (NNN.EQ.N) GO TO 50 | |
32490 | RUNTES=0.0D0 | |
32491 | EFTES=0.0D0 | |
32492 | 50 CONTINUE | |
32493 | IS=1 | |
32494 | IRH=0 | |
32495 | IST=1 | |
32496 | NSTAB=23 | |
32497 | IRE=NURE(N,1) | |
32498 | IF(ITTA.GT.1) IRE=NURE(N,2) | |
32499 | C | |
32500 | C----------------------------- | |
32501 | C*** IE,AMT,ECM,SI DETERMINATION | |
32502 | C---------------------------- | |
32503 | CALL DT_DSIGIN(IRE,PLAB,N,IE,AMT ,AMN,ECM,SI,ITTA) | |
32504 | IANTH=-1 | |
32505 | **sr | |
32506 | C IF (AMH(1).NE.0.93828D0) IANTH=1 | |
32507 | IF (AMH(1).NE.0.9383D0) IANTH=1 | |
32508 | ** | |
32509 | IF (IANTH.GE.0) SI=1.0D0 | |
32510 | ECMMH=ECM | |
32511 | C | |
32512 | C----------------------------- | |
32513 | C ENERGY INDEX | |
32514 | C IRE CHARACTERIZES THE REACTION | |
32515 | C IE IS THE ENERGY INDEX | |
32516 | C---------------------------- | |
32517 | IF (SI.LT.1.D-6) THEN | |
32518 | C WRITE(LOUT,*) ' jump 2' | |
32519 | GO TO 280 | |
32520 | ENDIF | |
32521 | IF (N.LE.NSTAB) GO TO 60 | |
32522 | RUNTES=RUNTES+1.0D0 | |
32523 | IF (RUNTES.LT.20.D0) WRITE(LOUT,1020)N | |
32524 | 1020 FORMAT(3H N=,I10,30H THE PROEKTILE IS A RESONANCE ) | |
32525 | IF(IBARH(N).EQ.1) N=8 | |
32526 | IF(IBARH(N).EQ.-1) N=9 | |
32527 | 60 CONTINUE | |
32528 | IMACH=IMACH+1 | |
32529 | **sr 19.2.97: loop for direct channel suppression | |
32530 | C IF (IMACH.GT.10) THEN | |
32531 | IF (IMACH.GT.1000) THEN | |
32532 | ** | |
32533 | C WRITE(LOUT,*) ' jump 3' | |
32534 | GO TO 280 | |
32535 | ENDIF | |
32536 | ECM =ECMMH | |
32537 | AMN2=AMN**2 | |
32538 | AMT2=AMT**2 | |
32539 | ECMN=(ECM**2+AMN2-AMT2)/(2.0D0*ECM ) | |
32540 | IF(ECMN.LE.AMN) ECMN=AMN | |
32541 | PCMN=SQRT(ECMN**2-AMN2) | |
32542 | GAM=(ELAB+AMT)/ECM | |
32543 | BGAM=PLAB/ECM | |
32544 | IF (IANTH.GE.0) ECM=2.1D0 | |
32545 | C | |
32546 | C----------------------------- | |
32547 | C*** RANDOM CHOICE OF REACTION CHANNEL | |
32548 | C---------------------------- | |
32549 | IST=0 | |
32550 | VV=DT_RNDM(AMN2) | |
32551 | VV=VV-1.D-17 | |
32552 | C | |
32553 | C----------------------------- | |
32554 | C*** PLACE REDUCED VERSION | |
32555 | C---------------------------- | |
32556 | IIEI=IEII(IRE) | |
32557 | IDWK=IEII(IRE+1)-IIEI | |
32558 | IIWK=IRII(IRE) | |
32559 | IIKI=IKII(IRE) | |
32560 | C | |
32561 | C----------------------------- | |
32562 | C*** SHRINKAGE TO THE CONSIDERED ENERGY REGION FOR THE USE OF WEIGHTS | |
32563 | C---------------------------- | |
32564 | HECM=ECM | |
32565 | HUMO=2.0D0*UMO(IIEI+IDWK)-UMO(IIEI+IDWK-1) | |
32566 | IF (HUMO.LT.ECM) ECM=HUMO | |
32567 | C | |
32568 | C----------------------------- | |
32569 | C*** INTERPOLATION PREPARATION | |
32570 | C---------------------------- | |
32571 | ECMO=UMO(IE) | |
32572 | ECM1=UMO(IE-1) | |
32573 | DECM=ECMO-ECM1 | |
32574 | DEC=ECMO-ECM | |
32575 | C | |
32576 | C----------------------------- | |
32577 | C*** RANDOM LOOP | |
32578 | C---------------------------- | |
32579 | IK=0 | |
32580 | WKK=0.0D0 | |
32581 | WICOR=0.0D0 | |
32582 | 70 IK=IK+1 | |
32583 | IWK=IIWK+(IK-1)*IDWK+IE-IIEI | |
32584 | WOK=WK(IWK) | |
32585 | WDK=WOK-WK(IWK-1) | |
32586 | C | |
32587 | C----------------------------- | |
32588 | C*** TESTVARIABLE WICO/WICOR: IF CHANNEL IK HAS THE SAME WEIGHTS LIKE IK | |
32589 | C GO TO NEXT CHANNEL, BECAUSE WKK((IK))-WKK((IK-1))=0, IK CAN NOT | |
32590 | C CONTRIBUTE | |
32591 | C---------------------------- | |
32592 | IF (PLAB.LT.PLABF(IIEI+2)) WDK=0.0D0 | |
32593 | WICO=WOK*1.23459876D0+WDK*1.735218469D0 | |
32594 | IF (WICO.EQ.WICOR) GO TO 70 | |
32595 | IF (UMO(IIEI+IDWK).LT.HECM) WDK=0.0D0 | |
32596 | WICOR=WICO | |
32597 | C | |
32598 | C----------------------------- | |
32599 | C*** INTERPOLATION IN CHANNEL WEIGHTS | |
32600 | C---------------------------- | |
32601 | EKLIM=-THRESH(IIKI+IK) | |
32602 | IELIM=IDT_IEFUND(EKLIM,IRE) | |
32603 | DELIM=UMO(IELIM)+EKLIM | |
32604 | *+1.D-16 | |
32605 | DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0 | |
32606 | IF (DELIM*DELIM-DETE*DETE) 90,90,80 | |
32607 | 80 DECC=DELIM | |
32608 | GO TO 100 | |
32609 | 90 DECC=DECM | |
32610 | 100 CONTINUE | |
32611 | WKK=WOK-WDK*DEC/(DECC+1.D-9) | |
32612 | C | |
32613 | C----------------------------- | |
32614 | C*** RANDOM CHOICE | |
32615 | C---------------------------- | |
32616 | C | |
32617 | IF (VV.GT.WKK) GO TO 70 | |
32618 | C | |
32619 | C***IK IS THE REACTION CHANNEL | |
32620 | C---------------------------- | |
32621 | INRK=IKII(IRE)+IK | |
32622 | ECM=HECM | |
32623 | I1001 =0 | |
32624 | C | |
32625 | 110 CONTINUE | |
32626 | IT1=NRK(1,INRK) | |
32627 | AM1=DT_DAMG(IT1) | |
32628 | IT2=NRK(2,INRK) | |
32629 | AM2=DT_DAMG(IT2) | |
32630 | AMS=AM1+AM2 | |
32631 | I1001=I1001+1 | |
32632 | IF (I1001.GT.50) GO TO 60 | |
32633 | C | |
32634 | IF (IT2*AMS.GT.IT2*ECM) GO TO 110 | |
32635 | IT11=IT1 | |
32636 | IT22=IT2 | |
32637 | IF (IANTH.GE.0) ECM=ELAB+AMT+0.00001D0 | |
32638 | AM11=AM1 | |
32639 | AM22=AM2 | |
32640 | IF (IT2.GT.0) GO TO 120 | |
32641 | **sr 19.2.97: supress direct channel for pp-collisions | |
32642 | IF ((N.EQ.1).AND.(ITTA.EQ.1).AND.(IT2.LE.0)) THEN | |
32643 | RR = DT_RNDM(AM11) | |
32644 | IF (RR.LE.0.75D0) GOTO 60 | |
32645 | ENDIF | |
32646 | ** | |
32647 | C | |
32648 | C----------------------------- | |
32649 | C INCLUSION OF DIRECT RESONANCES | |
32650 | C RANDOM CHOICE OF DECAY CHANNELS OF THE DIRECT RESONANCE IT1 | |
32651 | C------------------------ | |
32652 | KZ1=K1H(IT1) | |
32653 | IST=IST+1 | |
32654 | IECO=0 | |
32655 | ECO=ECM | |
32656 | GAM=(ELAB+AMT)/ECO | |
32657 | BGAM=PLAB/ECO | |
32658 | CXS(1)=CX | |
32659 | CYS(1)=CY | |
32660 | CZS(1)=CZ | |
32661 | GO TO 170 | |
32662 | 120 CONTINUE | |
32663 | WW=DT_RNDM(ECO) | |
32664 | IF(WW.LT. 0.5D0) GO TO 130 | |
32665 | IT1=IT22 | |
32666 | IT2=IT11 | |
32667 | AM1=AM22 | |
32668 | AM2=AM11 | |
32669 | 130 CONTINUE | |
32670 | C | |
32671 | C----------------------------- | |
32672 | C THE FIRST PARTICLE IS DEFINED TO BE THE FORWARD GOING ONE AT SMALL T | |
32673 | IBN=IBARH(N) | |
32674 | IB1=IBARH(IT1) | |
32675 | IT11=IT1 | |
32676 | IT22=IT2 | |
32677 | AM11=AM1 | |
32678 | AM22=AM2 | |
32679 | IF(IB1.EQ.IBN) GO TO 140 | |
32680 | IT1=IT22 | |
32681 | IT2=IT11 | |
32682 | AM1=AM22 | |
32683 | AM2=AM11 | |
32684 | 140 CONTINUE | |
32685 | C----------------------------- | |
32686 | C***IT1,IT2 ARE THE CREATED PARTICLES | |
32687 | C***MOMENTA AND DIRECTION COSINA IN THE CM - SYSTEM | |
32688 | C------------------------ | |
32689 | CALL DT_DTWOPA(ECM1,ECM2,PCM1,PCM2,COD1,COD2,COF1,COF2,SIF1,SIF2, | |
32690 | *IT1,IT2,ECM,ECMN,PCMN,N,AM1,AM2) | |
32691 | IST=IST+1 | |
32692 | ITS(IST)=IT1 | |
32693 | AMM(IST)=AM1 | |
32694 | C | |
32695 | C----------------------------- | |
32696 | C***TRANSFORMATION INTO LAB SYSTEM AND ROTATION | |
32697 | C---------------------------- | |
32698 | CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD1,COF1,SIF1, | |
32699 | &PCM1,ECM1,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST)) | |
32700 | IST=IST+1 | |
32701 | ITS(IST)=IT2 | |
32702 | AMM(IST)=AM2 | |
32703 | CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD2,COF2,SIF2, | |
32704 | *PCM2,ECM2,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST)) | |
32705 | 150 CONTINUE | |
32706 | C | |
32707 | C----------------------------- | |
32708 | C***TEST STABLE OR UNSTABLE | |
32709 | C---------------------------- | |
32710 | IF(ITS(IST).GT.NSTAB) GO TO 160 | |
32711 | IRH=IRH+1 | |
32712 | C | |
32713 | C----------------------------- | |
32714 | C***IRH IS THE NUMBER OF THE FINAL STABLE PARTICLE | |
32715 | C---------------------------- | |
32716 | C* IF (REDU.LT.0.D0) GO TO 1009 | |
32717 | ITRH(IRH)=ITS(IST) | |
32718 | PLRH(IRH)=PLS(IST) | |
32719 | CXRH(IRH)=CXS(IST) | |
32720 | CYRH(IRH)=CYS(IST) | |
32721 | CZRH(IRH)=CZS(IST) | |
32722 | ELRH(IRH)=ELS(IST) | |
32723 | IST=IST-1 | |
32724 | IF(IST.GE.1) GO TO 150 | |
32725 | GO TO 260 | |
32726 | 160 CONTINUE | |
32727 | C | |
32728 | C RANDOM CHOICE OF DECAY CHANNELS | |
32729 | C---------------------------- | |
32730 | C | |
32731 | IT=ITS(IST) | |
32732 | ECO=AMM(IST) | |
32733 | GAM=ELS(IST)/ECO | |
32734 | BGAM=PLS(IST)/ECO | |
32735 | IECO=0 | |
32736 | KZ1=K1H(IT) | |
32737 | 170 CONTINUE | |
32738 | IECO=IECO+1 | |
32739 | VV=DT_RNDM(GAM) | |
32740 | VV=VV-1.D-17 | |
32741 | IIK=KZ1-1 | |
32742 | 180 IIK=IIK+1 | |
32743 | IF (VV.GT.WTI(IIK)) GO TO 180 | |
32744 | C | |
32745 | C IIK IS THE DECAY CHANNEL | |
32746 | C---------------------------- | |
32747 | IT1=NZKI(IIK,1) | |
32748 | I310=0 | |
32749 | 190 CONTINUE | |
32750 | I310=I310+1 | |
32751 | AM1=DT_DAMG(IT1) | |
32752 | IT2=NZKI(IIK,2) | |
32753 | AM2=DT_DAMG(IT2) | |
32754 | IF (IT2-1.LT.0) GO TO 240 | |
32755 | IT3=NZKI(IIK,3) | |
32756 | AM3=DT_DAMG(IT3) | |
32757 | AMS=AM1+AM2+AM3 | |
32758 | C | |
32759 | C IF IIK-KIN.LIM.GT.ACTUAL TOTAL CM-ENERGY, DO AGAIN RANDOM IIK-CHOICE | |
32760 | C---------------------------- | |
32761 | IF (IECO.LE.10) GO TO 200 | |
32762 | IATMPT=IATMPT+1 | |
32763 | IF(IATMPT.GT.3) THEN | |
32764 | C WRITE(LOUT,*) ' jump 4' | |
32765 | GO TO 280 | |
32766 | ENDIF | |
32767 | GO TO 40 | |
32768 | 200 CONTINUE | |
32769 | IF (I310.GT.50) GO TO 170 | |
32770 | IF (AMS.GT.ECO) GO TO 190 | |
32771 | C | |
32772 | C FOR THE DECAY CHANNEL | |
32773 | C IT1,IT2, IT3 ARE THE PRODUCED PARTICLES FROM IT | |
32774 | C---------------------------- | |
32775 | IF (REDU.LT.0.D0) GO TO 30 | |
32776 | ITWTHC=0 | |
32777 | REDU=2.0D0 | |
32778 | IF(IT3.EQ.0) GO TO 220 | |
32779 | 210 CONTINUE | |
32780 | ITWTH=1 | |
32781 | CALL DT_DTHREP(ECO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,SIF1, | |
32782 | *COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3) | |
32783 | GO TO 230 | |
32784 | 220 CALL DT_DTWOPD(ECO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1, | |
32785 | &COD2,COF2,SIF2,AM1,AM2) | |
32786 | ITWTH=-1 | |
32787 | IT3=0 | |
32788 | 230 CONTINUE | |
32789 | ITWTHC=ITWTHC+1 | |
32790 | IF (REDU.GT.0.D0) GO TO 240 | |
32791 | REDU=2.0D0 | |
32792 | IF (ITWTHC.GT.100) GO TO 30 | |
32793 | IF (ITWTH) 220,220,210 | |
32794 | 240 CONTINUE | |
32795 | ITS(IST )=IT1 | |
32796 | IF (IT2-1.LT.0) GO TO 250 | |
32797 | ITS(IST+1) =IT2 | |
32798 | ITS(IST+2)=IT3 | |
32799 | RX=CXS(IST) | |
32800 | RY=CYS(IST) | |
32801 | RZ=CZS(IST) | |
32802 | AMM(IST)=AM1 | |
32803 | CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD1,COF1,SIF1,PCM1,ECM1, | |
32804 | *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST)) | |
32805 | IST=IST+1 | |
32806 | AMM(IST)=AM2 | |
32807 | CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD2,COF2,SIF2,PCM2,ECM2, | |
32808 | *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST)) | |
32809 | IF (IT3.LE.0) GO TO 250 | |
32810 | IST=IST+1 | |
32811 | AMM(IST)=AM3 | |
32812 | CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD3,COF3,SIF3,PCM3,ECM3, | |
32813 | *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST)) | |
32814 | 250 CONTINUE | |
32815 | GO TO 150 | |
32816 | 260 CONTINUE | |
32817 | 270 CONTINUE | |
32818 | RETURN | |
32819 | 280 CONTINUE | |
32820 | C | |
32821 | C---------------------------- | |
32822 | C | |
32823 | C ZERO CROSS SECTION CASE | |
32824 | C---------------------------- | |
32825 | C | |
32826 | IRH=1 | |
32827 | ITRH(1)=N | |
32828 | CXRH(1)=CX | |
32829 | CYRH(1)=CY | |
32830 | CZRH(1)=CZ | |
32831 | ELRH(1)=ELAB | |
32832 | PLRH(1)=PLAB | |
32833 | RETURN | |
32834 | END | |
32835 | ||
32836 | *$ CREATE DT_RUNTT.FOR | |
32837 | *COPY DT_RUNTT | |
32838 | * | |
32839 | *===runtt==============================================================* | |
32840 | * | |
32841 | BLOCK DATA DT_RUNTT | |
32842 | ||
32843 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
32844 | SAVE | |
32845 | ||
32846 | COMMON /HNDRUN/ RUNTES,EFTES | |
32847 | ||
32848 | DATA RUNTES,EFTES /100.D0,100.D0/ | |
32849 | ||
32850 | END | |
32851 | ||
32852 | *$ CREATE DT_NONAME.FOR | |
32853 | *COPY DT_NONAME | |
32854 | * | |
32855 | *===noname=============================================================* | |
32856 | * | |
32857 | BLOCK DATA DT_NONAME | |
32858 | ||
32859 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
32860 | SAVE | |
32861 | ||
32862 | * slope parameters for HADRIN interactions | |
32863 | COMMON /HNSLOP/ SM(25),BBM(25),BBB(25) | |
32864 | ||
32865 | COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17) | |
32866 | ||
32867 | C DATAS DATAS DATAS DATAS DATAS | |
32868 | C****** ********* | |
32869 | DATA IKII/ 0, 15, 41, 67, 82, 93, 110, 133, 148, 159, 172, 183, | |
32870 | & 207, 224, 241, 252, 268 / | |
32871 | DATA IEII/ 0, 21, 46, 71, 92, 109, 126, 143, 160, 173, 186, 199, | |
32872 | & 220, 241, 262, 279, 296 / | |
32873 | DATA IRII/ 0, 315, 965, 1615, 1930, 2117, 2406, 2797, 3052, 3195, | |
32874 | & 3364, 3507, 4011, 4368, 4725, 4912, 5184/ | |
32875 | ||
32876 | C | |
32877 | C MASSES FOR THE SLOPE B(M) IN GEV | |
32878 | C SLOPE B(M) FOR AN MESONIC SYSTEM | |
32879 | C SLOPE B(M) FOR A BARYONIC SYSTEM | |
32880 | ||
32881 | * | |
32882 | DATA SM,BBM,BBB/ 0.8D0, 0.85D0, 0.9D0, 0.95D0, 1.D0, | |
32883 | & 1.05D0, 1.1D0, 1.15D0, 1.2D0, 1.25D0, | |
32884 | & 1.3D0, 1.35D0, 1.4D0, 1.45D0, 1.5D0, | |
32885 | & 1.55D0, 1.6D0, 1.65D0, 1.7D0, 1.75D0, | |
32886 | & 1.8D0, 1.85D0, 1.9D0, 1.95D0, 2.D0, | |
32887 | & 15.6D0, 14.95D0, 14.3D0, 13.65D0, 13.D0, | |
32888 | & 12.35D0, 11.7D0, 10.85D0, 10.D0, 9.15D0, | |
32889 | & 8.3D0, 7.8D0, 7.3D0, 7.25D0, 7.2D0, | |
32890 | & 6.95D0, 6.7D0, 6.6D0, 6.5D0, 6.3D0, | |
32891 | & 6.1D0, 5.85D0, 5.6D0, 5.35D0, 5.1D0, | |
32892 | & 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, | |
32893 | & 14.2D0, 13.4D0, 12.6D0, | |
32894 | & 11.8D0, 11.2D0, 10.6D0, 9.8D0, 9.D0, | |
32895 | & 8.25D0, 7.5D0, 6.25D0, 5.D0, 4.5D0, 5*4.D0 / | |
32896 | * | |
32897 | END | |
32898 | ||
32899 | *$ CREATE DT_DAMG.FOR | |
32900 | *COPY DT_DAMG | |
32901 | * | |
32902 | *===damg===============================================================* | |
32903 | * | |
32904 | DOUBLE PRECISION FUNCTION DT_DAMG(IT) | |
32905 | ||
32906 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
32907 | SAVE | |
32908 | ||
32909 | * particle properties (BAMJET index convention), | |
32910 | * (dublicate of DTPART for HADRIN) | |
32911 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), | |
32912 | & K1H(110),K2H(110) | |
32913 | ||
32914 | DIMENSION GASUNI(14) | |
32915 | DATA GASUNI/ | |
32916 | *-1.D0,-.98D0,-.95D0,-.87D0,-.72D0,-.48D0, | |
32917 | *-.17D0,.17D0,.48D0,.72D0,.87D0,.95D0,.98D0,1.D0/ | |
32918 | DATA GAUNO/2.352D0/ | |
32919 | DATA GAUNON/2.4D0/ | |
32920 | DATA IO/14/ | |
32921 | DATA NSTAB/23/ | |
32922 | ||
32923 | I=1 | |
32924 | IF (IT.LE.0) GO TO 30 | |
32925 | IF (IT.LE.NSTAB) GO TO 20 | |
32926 | DGAUNI=GAUNO*GAUNON/DBLE(IO-1) | |
32927 | VV=DT_RNDM(DGAUNI) | |
32928 | VV=VV*2.0D0-1.0D0+1.D-16 | |
32929 | 10 CONTINUE | |
32930 | VO=GASUNI(I) | |
32931 | I=I+1 | |
32932 | V1=GASUNI(I) | |
32933 | IF (VV.GT.V1) GO TO 10 | |
32934 | UNIGA=DGAUNI*(DBLE(I)-2.0D0+(VV-VO+1.D-16)/ | |
32935 | & (V1-VO)-(DBLE(IO)-1.0D0)*0.5D0) | |
32936 | DAM=GAH(IT)*UNIGA/GAUNO | |
32937 | AAM=AMH(IT)+DAM | |
32938 | DT_DAMG=AAM | |
32939 | RETURN | |
32940 | 20 CONTINUE | |
32941 | DT_DAMG=AMH(IT) | |
32942 | RETURN | |
32943 | 30 CONTINUE | |
32944 | DT_DAMG=0.0D0 | |
32945 | RETURN | |
32946 | END | |
32947 | ||
32948 | *$ CREATE DT_DCALUM.FOR | |
32949 | *COPY DT_DCALUM | |
32950 | * | |
32951 | *===dcalum=============================================================* | |
32952 | * | |
32953 | SUBROUTINE DT_DCALUM(N,ITTA) | |
32954 | ||
32955 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
32956 | SAVE | |
32957 | ||
32958 | C*** C.M.S.-ENERGY AND REACTION CHANNEL THRESHOLD CALCULATION | |
32959 | ||
32960 | * particle properties (BAMJET index convention), | |
32961 | * (dublicate of DTPART for HADRIN) | |
32962 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), | |
32963 | & K1H(110),K2H(110) | |
32964 | ||
32965 | COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17) | |
32966 | ||
32967 | COMMON /HNSPLI/ WTI(460),NZKI(460,3) | |
32968 | ||
32969 | COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184), | |
32970 | & NRK(2,268),NURE(30,2) | |
32971 | ||
32972 | IRE=NURE(N,ITTA/8+1) | |
32973 | IEO=IEII(IRE)+1 | |
32974 | IEE=IEII(IRE +1) | |
32975 | AM1=AMH(N ) | |
32976 | AM12=AM1**2 | |
32977 | AM2=AMH(ITTA) | |
32978 | AM22=AM2**2 | |
32979 | DO 10 IE=IEO,IEE | |
32980 | PLAB2=PLABF(IE)**2 | |
32981 | ELAB=SQRT(AM12+AM22+2.0D0*SQRT(PLAB2+AM12)*AM2) | |
32982 | UMO(IE)=ELAB | |
32983 | 10 CONTINUE | |
32984 | IKO=IKII(IRE)+1 | |
32985 | IKE=IKII(IRE +1) | |
32986 | UMOO=UMO(IEO) | |
32987 | DO 30 IK=IKO,IKE | |
32988 | IF(NRK(2,IK).GT.0) GO TO 30 | |
32989 | IKI=NRK(1,IK) | |
32990 | AMSS=5.0D0 | |
32991 | K11=K1H(IKI) | |
32992 | K22=K2H(IKI) | |
32993 | DO 20 IK1=K11,K22 | |
32994 | IN=NZKI(IK1,1) | |
32995 | AMS=AMH(IN) | |
32996 | IN=NZKI(IK1,2) | |
32997 | IF(IN.GT.0)AMS=AMS+AMH(IN) | |
32998 | IN=NZKI(IK1,3) | |
32999 | IF(IN.GT.0) AMS=AMS+AMH(IN) | |
33000 | IF (AMS.LT.AMSS) AMSS=AMS | |
33001 | 20 CONTINUE | |
33002 | IF(UMOO.LT.AMSS) UMOO=AMSS | |
33003 | THRESH(IK)=UMOO | |
33004 | 30 CONTINUE | |
33005 | RETURN | |
33006 | END | |
33007 | ||
33008 | *$ CREATE DT_DCHANH.FOR | |
33009 | *COPY DT_DCHANH | |
33010 | * | |
33011 | *===dchanh=============================================================* | |
33012 | * | |
33013 | SUBROUTINE DT_DCHANH | |
33014 | ||
33015 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
33016 | SAVE | |
33017 | ||
33018 | PARAMETER ( LINP = 10 , | |
33019 | & LOUT = 6 , | |
33020 | & LDAT = 9 ) | |
33021 | ||
33022 | * particle properties (BAMJET index convention), | |
33023 | * (dublicate of DTPART for HADRIN) | |
33024 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), | |
33025 | & K1H(110),K2H(110) | |
33026 | ||
33027 | COMMON /HNSPLI/ WTI(460),NZKI(460,3) | |
33028 | ||
33029 | COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17) | |
33030 | ||
33031 | COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184), | |
33032 | & NRK(2,268),NURE(30,2) | |
33033 | ||
33034 | DIMENSION HWT(460),HWK(40),SI(5184) | |
33035 | EQUIVALENCE (WK(1),SI(1)) | |
33036 | C-------------------- | |
33037 | C*** USE ONLY FOR DATAPREPARATION OF PURE HADRIN | |
33038 | C*** CALCULATION OF REACTION- AND DECAY-CHANNEL-WEIGHTS, | |
33039 | C*** THRESHOLD ENERGIES+MOMENTA OF REACTION CHNLS. | |
33040 | C*** CHANGE OF WT- AND WK-INPUTDATA INTO WEIGHTS FOR THE M.-C.-PROCEDURE | |
33041 | C*** (ADDED ONE TO EACH OTHER FOR CORRESPONDING CHANNELS) | |
33042 | C-------------------------- | |
33043 | IREG=16 | |
33044 | DO 90 IRE=1,IREG | |
33045 | IWKO=IRII(IRE) | |
33046 | IEE=IEII(IRE+1)-IEII(IRE) | |
33047 | IKE=IKII(IRE+1)-IKII(IRE) | |
33048 | IEO=IEII(IRE)+1 | |
33049 | IIKA=IKII(IRE) | |
33050 | * modifications to suppress elestic scattering 24/07/91 | |
33051 | DO 80 IE=1,IEE | |
33052 | SIS=1.D-14 | |
33053 | SINORC=0.0D0 | |
33054 | DO 10 IK=1,IKE | |
33055 | IWK=IWKO+IEE*(IK-1)+IE | |
33056 | IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0 | |
33057 | SIS=SIS+SI(IWK)*SINORC | |
33058 | 10 CONTINUE | |
33059 | SIIN(IEO+IE-1)=SIS | |
33060 | SIO=0.D0 | |
33061 | IF (SIS.GE.1.D-12) GO TO 20 | |
33062 | SIS=1.D0 | |
33063 | SIO=1.D0 | |
33064 | 20 CONTINUE | |
33065 | SINORC=0.0D0 | |
33066 | DO 30 IK=1,IKE | |
33067 | IWK=IWKO+IEE*(IK-1)+IE | |
33068 | IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0 | |
33069 | SIO=SIO+SI(IWK)*SINORC/SIS | |
33070 | HWK(IK)=SIO | |
33071 | 30 CONTINUE | |
33072 | DO 40 IK=1,IKE | |
33073 | IWK=IWKO+IEE*(IK-1)+IE | |
33074 | 40 WK(IWK)=HWK(IK) | |
33075 | IIKI=IKII(IRE) | |
33076 | DO 70 IK=1,IKE | |
33077 | AM111=0.D0 | |
33078 | INRK1=NRK(1,IIKI+IK) | |
33079 | IF (INRK1.GT.0) AM111=AMH(INRK1) | |
33080 | AM222=0.D0 | |
33081 | INRK2=NRK(2,IIKI+IK) | |
33082 | IF (INRK2.GT.0) AM222=AMH(INRK2) | |
33083 | THRESH(IIKI+IK)=AM111 +AM222 | |
33084 | IF (INRK2-1.GE.0) GO TO 60 | |
33085 | INRKK=K1H(INRK1) | |
33086 | AMSS=5.D0 | |
33087 | INRKO=K2H(INRK1) | |
33088 | DO 50 INRK1=INRKK,INRKO | |
33089 | INZK1=NZKI(INRK1,1) | |
33090 | INZK2=NZKI(INRK1,2) | |
33091 | INZK3=NZKI(INRK1,3) | |
33092 | IF (INZK1.LE.0.OR.INZK1.GT.110) GO TO 50 | |
33093 | IF (INZK2.LE.0.OR.INZK2.GT.110) GO TO 50 | |
33094 | IF (INZK3.LE.0.OR.INZK3.GT.110) GO TO 50 | |
33095 | C WRITE (6,310)INRK1,INZK1,INZK2,INZK3 | |
33096 | 1000 FORMAT (4I10) | |
33097 | AMS=AMH(INZK1)+AMH(INZK2) | |
33098 | IF (INZK3-1.GE.0) AMS=AMS+AMH(INZK3) | |
33099 | IF (AMSS.GT.AMS) AMSS=AMS | |
33100 | 50 CONTINUE | |
33101 | AMS=AMSS | |
33102 | IF (AMS.LT.UMO(IEO)) AMS=UMO(IEO) | |
33103 | THRESH(IIKI+IK)=AMS | |
33104 | 60 CONTINUE | |
33105 | 70 CONTINUE | |
33106 | 80 CONTINUE | |
33107 | 90 CONTINUE | |
33108 | DO 100 J=1,460 | |
33109 | 100 HWT(J)=0.D0 | |
33110 | DO 120 I=1,110 | |
33111 | IK1=K1H(I) | |
33112 | IK2=K2H(I) | |
33113 | HV=0.D0 | |
33114 | IF (IK2.GT.460)IK2=460 | |
33115 | IF (IK1.LE.0)IK1=1 | |
33116 | DO 110 J=IK1,IK2 | |
33117 | HV=HV+WTI(J) | |
33118 | HWT(J)=HV | |
33119 | JI=J | |
33120 | 110 CONTINUE | |
33121 | IF (ABS(HV-1.0D0).GT.1.D-4) WRITE(LOUT,1010)I,JI,HV | |
33122 | 1010 FORMAT (35H ERROR IN HWT, FALSE USE OF CHANWH ,2I6,F10.2) | |
33123 | 120 CONTINUE | |
33124 | DO 130 J=1,460 | |
33125 | 130 WTI(J)=HWT(J) | |
33126 | RETURN | |
33127 | END | |
33128 | ||
33129 | *$ CREATE DT_DHADDE.FOR | |
33130 | *COPY DT_DHADDE | |
33131 | * | |
33132 | *===dhadde=============================================================* | |
33133 | * | |
33134 | SUBROUTINE DT_DHADDE | |
33135 | ||
33136 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
33137 | SAVE | |
33138 | ||
33139 | * particle properties (BAMJET index convention) | |
33140 | CHARACTER*8 ANAME | |
33141 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
33142 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
33143 | ||
33144 | * HADRIN: decay channel information | |
33145 | PARAMETER (IDMAX9=602) | |
33146 | CHARACTER*8 ZKNAME | |
33147 | COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3) | |
33148 | ||
33149 | * particle properties (BAMJET index convention), | |
33150 | * (dublicate of DTPART for HADRIN) | |
33151 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), | |
33152 | & K1H(110),K2H(110) | |
33153 | ||
33154 | COMMON /HNSPLI/ WTI(460),NZKI(460,3) | |
33155 | ||
33156 | * decay channel information for HADRIN | |
33157 | COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16), | |
33158 | & K1Z(16),K2Z(16),WTZ(153),II22, | |
33159 | & NZK1(153),NZK2(153),NZK3(153) | |
33160 | ||
33161 | DATA IRETUR/0/ | |
33162 | ||
33163 | IRETUR=IRETUR+1 | |
33164 | AMH(31)=0.48D0 | |
33165 | IF (IRETUR.GT.1) RETURN | |
33166 | DO 10 I=1,94 | |
33167 | AMH(I) = AAM(I) | |
33168 | GAH(I) = GA(I) | |
33169 | TAUH(I) = TAU(I) | |
33170 | ICHH(I) = IICH(I) | |
33171 | IBARH(I) = IIBAR(I) | |
33172 | K1H(I) = K1(I) | |
33173 | K2H(I) = K2(I) | |
33174 | 10 CONTINUE | |
33175 | **sr | |
33176 | C AMH(1)=0.93828D0 | |
33177 | AMH(1)=0.9383D0 | |
33178 | ** | |
33179 | AMH(2)=AMH(1) | |
33180 | DO 20 I=26,30 | |
33181 | K1H(I)=452 | |
33182 | K2H(I)=452 | |
33183 | 20 CONTINUE | |
33184 | DO 30 I=1,307 | |
33185 | WTI(I) = WT(I) | |
33186 | NZKI(I,1) = NZK(I,1) | |
33187 | NZKI(I,2) = NZK(I,2) | |
33188 | NZKI(I,3) = NZK(I,3) | |
33189 | 30 CONTINUE | |
33190 | DO 40 I=1,16 | |
33191 | L=I+94 | |
33192 | AMH(L)=AMZ(I) | |
33193 | GAH( L)=GAZ(I) | |
33194 | TAUH( L)=TAUZ(I) | |
33195 | ICHH( L)=ICHZ(I) | |
33196 | IBARH( L)=IBARZ(I) | |
33197 | K1H( L)=K1Z(I) | |
33198 | K2H( L)=K2Z(I) | |
33199 | 40 CONTINUE | |
33200 | DO 50 I=1,153 | |
33201 | L=I+307 | |
33202 | WTI(L) = WTZ(I) | |
33203 | NZKI(L,3) = NZK3(I) | |
33204 | NZKI(L,2) = NZK2(I) | |
33205 | NZKI(L,1) = NZK1(I) | |
33206 | 50 CONTINUE | |
33207 | RETURN | |
33208 | END | |
33209 | ||
33210 | *$ CREATE IDT_IEFUND.FOR | |
33211 | *COPY IDT_IEFUND | |
33212 | * | |
33213 | *===iefund=============================================================* | |
33214 | * | |
33215 | INTEGER FUNCTION IDT_IEFUND(PL,IRE) | |
33216 | ||
33217 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
33218 | SAVE | |
33219 | ||
33220 | C*****IEFUN CALCULATES A MOMENTUM INDEX | |
33221 | ||
33222 | PARAMETER ( LINP = 10 , | |
33223 | & LOUT = 6 , | |
33224 | & LDAT = 9 ) | |
33225 | ||
33226 | COMMON /HNDRUN/ RUNTES,EFTES | |
33227 | ||
33228 | COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17) | |
33229 | ||
33230 | COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184), | |
33231 | & NRK(2,268),NURE(30,2) | |
33232 | ||
33233 | IPLA=IEII(IRE)+1 | |
33234 | *+1 | |
33235 | IPLE=IEII(IRE+1) | |
33236 | IF (PL.LT.0.) GO TO 30 | |
33237 | DO 10 I=IPLA,IPLE | |
33238 | J=I-IPLA+1 | |
33239 | IF (PL.LE.PLABF(I)) GO TO 60 | |
33240 | 10 CONTINUE | |
33241 | I=IPLE | |
33242 | IF ( EFTES.GT.40.D0) GO TO 20 | |
33243 | EFTES=EFTES+1.0D0 | |
33244 | WRITE(LOUT,1000)PL,J | |
33245 | 20 CONTINUE | |
33246 | GO TO 70 | |
33247 | 30 CONTINUE | |
33248 | DO 40 I=IPLA,IPLE | |
33249 | J=I-IPLA+1 | |
33250 | IF (-PL.LE.UMO(I)) GO TO 60 | |
33251 | 40 CONTINUE | |
33252 | I=IPLE | |
33253 | IF ( EFTES.GT.40.D0) GO TO 50 | |
33254 | EFTES=EFTES+1.0D0 | |
33255 | WRITE(LOUT,1000)PL,I | |
33256 | 50 CONTINUE | |
33257 | 60 CONTINUE | |
33258 | 70 CONTINUE | |
33259 | IDT_IEFUND=I | |
33260 | RETURN | |
33261 | 1000 FORMAT(14H PLAB OR -ECM=,E12.4,27H IS OUT OF CONSIDERED RANGE , | |
33262 | +7H IEFUN=,I5) | |
33263 | END | |
33264 | ||
33265 | *$ CREATE DT_DSIGIN.FOR | |
33266 | *COPY DT_DSIGIN | |
33267 | * | |
33268 | *===dsigin=============================================================* | |
33269 | * | |
33270 | SUBROUTINE DT_DSIGIN(IRE ,PLAB,N,IE ,AMT ,AMN,ECM ,SI ,ITAR) | |
33271 | ||
33272 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
33273 | SAVE | |
33274 | ||
33275 | * particle properties (BAMJET index convention), | |
33276 | * (dublicate of DTPART for HADRIN) | |
33277 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), | |
33278 | & K1H(110),K2H(110) | |
33279 | ||
33280 | COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17) | |
33281 | ||
33282 | COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184), | |
33283 | & NRK(2,268),NURE(30,2) | |
33284 | ||
33285 | IE=IDT_IEFUND(PLAB,IRE) | |
33286 | IF (IE.LE.IEII(IRE)) IE=IE+1 | |
33287 | AMT=AMH(ITAR) | |
33288 | AMN=AMH(N) | |
33289 | AMN2=AMN*AMN | |
33290 | AMT2=AMT*AMT | |
33291 | ECM=SQRT(AMN2+AMT2+2.0D0*AMT*SQRT(AMN2+PLAB**2)) | |
33292 | C*** INTERPOLATION PREPARATION | |
33293 | ECMO=UMO(IE) | |
33294 | ECM1=UMO(IE-1) | |
33295 | DECM=ECMO-ECM1 | |
33296 | DEC=ECMO-ECM | |
33297 | IIKI=IKII(IRE)+1 | |
33298 | EKLIM=-THRESH(IIKI) | |
33299 | WOK=SIIN(IE) | |
33300 | WDK=WOK-SIIN(IE-1) | |
33301 | IF (ECM.GT.ECMO) WDK=0.0D0 | |
33302 | C*** INTERPOLATION IN CHANNEL WEIGHTS | |
33303 | IELIM=IDT_IEFUND(EKLIM,IRE) | |
33304 | DELIM=UMO(IELIM)+EKLIM | |
33305 | *+1.D-16 | |
33306 | DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0 | |
33307 | IF (DELIM*DELIM-DETE*DETE) 20,20,10 | |
33308 | 10 DECC=DELIM | |
33309 | GO TO 30 | |
33310 | 20 DECC=DECM | |
33311 | 30 CONTINUE | |
33312 | WKK=WOK-WDK*DEC/(DECC+1.D-9) | |
33313 | IF (WKK.LT.0.0D0) WKK=0.0D0 | |
33314 | SI=WKK+1.D-12 | |
33315 | IF (-EKLIM.GT.ECM) SI=1.D-14 | |
33316 | RETURN | |
33317 | END | |
33318 | ||
33319 | *$ CREATE DT_DTCHOI.FOR | |
33320 | *COPY DT_DTCHOI | |
33321 | * | |
33322 | *===dtchoi=============================================================* | |
33323 | * | |
33324 | SUBROUTINE DT_DTCHOI(T,P,PP,E,EE,I,II,N,AM1,AM2) | |
33325 | ||
33326 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
33327 | SAVE | |
33328 | ||
33329 | C **************************** | |
33330 | C TCHOIC CALCULATES A RANDOM VALUE | |
33331 | C FOR THE FOUR-MOMENTUM-TRANSFER T | |
33332 | C **************************** | |
33333 | ||
33334 | * particle properties (BAMJET index convention), | |
33335 | * (dublicate of DTPART for HADRIN) | |
33336 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), | |
33337 | & K1H(110),K2H(110) | |
33338 | ||
33339 | * slope parameters for HADRIN interactions | |
33340 | COMMON /HNSLOP/ SM(25),BBM(25),BBB(25) | |
33341 | ||
33342 | AMA=AM1 | |
33343 | AMB=AM2 | |
33344 | IF (I.GT.30.AND.II.GT.30) GO TO 20 | |
33345 | III=II | |
33346 | AM3=AM2 | |
33347 | IF (I.LE.30) GO TO 10 | |
33348 | III=I | |
33349 | AM3=AM1 | |
33350 | 10 CONTINUE | |
33351 | GO TO 30 | |
33352 | 20 CONTINUE | |
33353 | III=II | |
33354 | AM3=AM2 | |
33355 | IF (AMA.LE.AMB) GO TO 30 | |
33356 | III=I | |
33357 | AM3=AM1 | |
33358 | 30 CONTINUE | |
33359 | IB=IBARH(III) | |
33360 | AMA=AM3 | |
33361 | K=INT((AMA-0.75D0)/0.05D0) | |
33362 | IF (K-2.LT.0) K=1 | |
33363 | IF (K-26.GE.0) K=25 | |
33364 | IF (IB)50,40,50 | |
33365 | 40 BM=BBM(K) | |
33366 | GO TO 60 | |
33367 | 50 BM=BBB(K) | |
33368 | 60 CONTINUE | |
33369 | C NORMALIZATION | |
33370 | TMIN=-2.0D0*(E*EE-P*PP)+AMH(N)**2+AM1 **2 | |
33371 | TMAX=-2.0D0*(E*EE+P*PP)+AMH(N)**2+AM1 **2 | |
33372 | VB=DT_RNDM(TMIN) | |
33373 | **sr test | |
33374 | C IF (VB.LT.0.2D0) BM=BM*0.1 | |
33375 | C **0.5 | |
33376 | BM = BM*5.05D0 | |
33377 | ** | |
33378 | TMI=BM*TMIN | |
33379 | TMA=BM*TMAX | |
33380 | ETMA=0.D0 | |
33381 | IF (ABS(TMA).GT.120.D0) GO TO 70 | |
33382 | ETMA=EXP(TMA) | |
33383 | 70 CONTINUE | |
33384 | AN=(1.0D0/BM)*(EXP(TMI)-ETMA) | |
33385 | C*** RANDOM CHOICE OF THE T - VALUE | |
33386 | R=DT_RNDM(TMI) | |
33387 | T=(1.0D0/BM)*LOG(ETMA+R*AN*BM) | |
33388 | RETURN | |
33389 | END | |
33390 | ||
33391 | *$ CREATE DT_DTWOPA.FOR | |
33392 | *COPY DT_DTWOPA | |
33393 | * | |
33394 | *===dtwopa=============================================================* | |
33395 | * | |
33396 | SUBROUTINE DT_DTWOPA(E1,E2,P1,P2,COD1,COD2,COF1,COF2,SIF1,SIF2, | |
33397 | &IT1,IT2,UMOO,ECM,P,N,AM1,AM2) | |
33398 | ||
33399 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
33400 | SAVE | |
33401 | ||
33402 | C ****************************************************** | |
33403 | C QUASI TWO PARTICLE PRODUCTION | |
33404 | C TWOPAR CALCULATES THE ENERGYS AND THE MOMENTA | |
33405 | C FOR THE CREATED PARTICLES OR RESONANCES IT1 AND IT2 | |
33406 | C IN THE CM - SYSTEM | |
33407 | C COD1,COD2,COF1,COF2,SIF1,SIF2 ARE THE ANGLES FOR | |
33408 | C SPHERICAL COORDINATES | |
33409 | C ****************************************************** | |
33410 | ||
33411 | * particle properties (BAMJET index convention), | |
33412 | * (dublicate of DTPART for HADRIN) | |
33413 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), | |
33414 | & K1H(110),K2H(110) | |
33415 | ||
33416 | AMA=AM1 | |
33417 | AMB=AM2 | |
33418 | AMA2=AMA*AMA | |
33419 | E1=((UMOO-AMB)*(UMOO+AMB) + AMA2)/(2.0D0*UMOO) | |
33420 | E2=UMOO - E1 | |
33421 | IF (E1.LT.AMA*1.00001D0) E1=AMA*1.00001D0 | |
33422 | AMTE=(E1-AMA)*(E1+AMA) | |
33423 | AMTE=AMTE+1.D-18 | |
33424 | P1=SQRT(AMTE) | |
33425 | P2=P1 | |
33426 | C / P2 / = / P1 / BUT OPPOSITE DIRECTIONS | |
33427 | C DETERMINATION OF THE ANGLES | |
33428 | C COS(THETA1)=COD1 COS(THETA2)=COD2 | |
33429 | C SIN(PHI1)=SIF1 SIN(PHI2)=SIF2 | |
33430 | C COS(PHI1)=COF1 COS(PHI2)=COF2 | |
33431 | C PHI IS UNIFORMLY DISTRIBUTED IN ( 0,2*PI ) | |
33432 | CALL DT_DSFECF(COF1,SIF1) | |
33433 | COF2=-COF1 | |
33434 | SIF2=-SIF1 | |
33435 | C CALCULATION OF THETA1 | |
33436 | CALL DT_DTCHOI(TR,P,P1,ECM,E1,IT1,IT2,N,AM1,AM2) | |
33437 | COD1=(TR-AMA2-AMH(N)*AMH(N)+2.0D0*ECM*E1)/(2.0D0*P*P1+1.D-18) | |
33438 | IF (COD1.GT.0.9999999D0) COD1=0.9999999D0 | |
33439 | COD2=-COD1 | |
33440 | RETURN | |
33441 | END | |
33442 | ||
33443 | *$ CREATE DT_ZK.FOR | |
33444 | *COPY DT_ZK | |
33445 | * | |
33446 | *===zk=================================================================* | |
33447 | * | |
33448 | BLOCK DATA DT_ZK | |
33449 | ||
33450 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
33451 | SAVE | |
33452 | ||
33453 | * decay channel information for HADRIN | |
33454 | COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16), | |
33455 | & K1Z(16),K2Z(16),WTZ(153),II22, | |
33456 | & NZK1(153),NZK2(153),NZK3(153) | |
33457 | ||
33458 | * decay channel information for HADRIN | |
33459 | CHARACTER*8 ANAMZ,ZKNAM4,ZKNAM5,ZKNAM6 | |
33460 | COMMON /HNADDN/ ANAMZ(16),ZKNAM4(9),ZKNAM5(90),ZKNAM6(54) | |
33461 | ||
33462 | * Particle masses in GeV * | |
33463 | DATA AMZ/ 3*2.2D0, 0.9576D0, 3*1.887D0, 2.4D0, 2.03D0, 2*1.44D0, | |
33464 | & 2*1.7D0, 3*0.D0/ | |
33465 | * Resonance width Gamma in GeV * | |
33466 | DATA GAZ/ 3*.2D0, .1D0, 4*.2D0, .18D0, 2*.2D0, 2*.15D0, 3*0.D0 / | |
33467 | * Mean life time in seconds * | |
33468 | DATA TAUZ / 16*0.D0 / | |
33469 | * Charge of particles and resonances * | |
33470 | DATA ICHZ/ 0, 1, 3*0, 1, -1, 0, 1, -1, 0, 0, 1 , 3*0 / | |
33471 | * Baryonic charge * | |
33472 | DATA IBARZ/ 2, 7*0, 1, -1, -1, 1, 1, 3*0 / | |
33473 | * First number of decay channels used for resonances * | |
33474 | * and decaying particles * | |
33475 | DATA K1Z/ 308,310,313,317,322,365,393,421,425,434,440,446,449, | |
33476 | & 3*460/ | |
33477 | * Last number of decay channels used for resonances * | |
33478 | * and decaying particles * | |
33479 | DATA K2Z/ 309,312,316,321,364,392,420,424,433,439,445,448,451, | |
33480 | & 3*460/ | |
33481 | * Weight of decay channel * | |
33482 | DATA WTZ/ .17D0, .83D0, 2*.33D0, .34D0, .17D0, 2*.33D0, .17D0, | |
33483 | & .01D0, .13D0, .36D0, .27D0, .23D0, .0014D0, .0029D0, .0014D0, | |
33484 | & .0029D0, 4*.0007D0, .0517D0, .0718D0, .0144D0, .0431D0, .0359D0, | |
33485 | & .0718D0, .0014D0, .0273D0, .0014D0, .0431D0, 2*.0129D0, .0259D0, | |
33486 | & .0517D0, .0359D0, .0014D0, 2*.0144D0, .0129D0, .0014D0, .0259D0, | |
33487 | & .0359D0, .0072D0, .0474D0, .0948D0, .0259D0, .0072D0, .0144D0, | |
33488 | & .0287D0, .0431D0, .0144D0, .0287D0, .0474D0, .0144D0, .0075D0, | |
33489 | & .0057D0, .0019D0, .0038D0, .0095D0, 2*.0014D0, .0191D0, .0572D0, | |
33490 | & .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0, .0686D0,.0172D0, | |
33491 | & .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0, .0190D0, | |
33492 | & .0057D0, .0019D0, .0038D0, .0095D0, .0014D0, .0014D0, .0191D0, | |
33493 | & .0572D0, .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0,.0686D0, | |
33494 | & .0172D0, .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0, | |
33495 | & .0190D0, 4*.25D0, 2*.2D0, .12D0, .1D0, .07D0, .07D0, .14D0, | |
33496 | & 2*.05D0, .0D0, .3334D0, .2083D0, 2*.125D0, .2083D0, .0D0, .125D0, | |
33497 | & .2083D0, .3334D0, .2083D0, .125D0, .3D0, .05D0, .65D0, .3D0, | |
33498 | & .05D0, .65D0, 9*1.D0 / | |
33499 | * Particle numbers in decay channel * | |
33500 | DATA NZK1/ 8, 1, 2, 9, 1, 2, 9, 2, 9, 7, 13, 31, 15, 24, 23, 13, | |
33501 | & 23, 13, 2*23, 14, 13, 23, 31, 98, 2*33, 32, 23, 14, 13, 35, 2*23, | |
33502 | & 14, 13, 33, 23, 98, 31, 23, 14, 13, 35, 2*33, 32, 23, 35, 33, 32, | |
33503 | & 98, 5*35, 4*13, 23, 13, 98, 32, 33, 23, 13, 23, 13, 14, 13, 32, | |
33504 | & 13, 98, 23, 13, 2*32, 13, 33, 32, 98, 2*35, 4*14, 23, 14, 98, | |
33505 | & 2*34, 23, 14, 23, 2*14, 13, 34, 14, 98, 23, 14, 2*34, 14, 33, 32, | |
33506 | & 98, 2*35, 104, 61, 105, 62, 1, 17, 21, 17, 22, 2*21, 22, 21, 2, | |
33507 | & 67, 68, 69, 2, 2*9, 68, 69, 70, 2, 9, 2*24, 15, 2*25, 16, 9*0/ | |
33508 | DATA NZK2/ 2*8, 1, 8, 9, 2*8, 2*1, 7, 14, 13, 16, 25, 23, 14, 23, | |
33509 | & 14, 31, 33, 32, 34, 35, 31, 23, 31, 33, 34, 31, 32, 34, 31, 33, | |
33510 | & 32, 2*33, 35, 31, 33, 31, 33, 32, 34, 35, 31, 33, 34, 35, 31, | |
33511 | & 4*33, 32, 3*35, 2*23, 13, 31, 32, 33, 13, 31, 32, 2*31, 32, 33, | |
33512 | & 32, 32, 35, 31, 2*32, 33, 31, 33, 35, 33, 3*32, 35, 2*23, 14, | |
33513 | & 31, 34, 33, 14, 31, 33, 2*31, 34, 32, 33, 34, 35, 31, 2*34, 33, | |
33514 | & 31, 33, 35, 33, 2*34, 33, 35, 1, 2, 8, 9, 25, 13, 35, 2*32, 33, | |
33515 | & 31, 13, 23, 31, 13, 23, 14, 79, 80, 31, 13, 23, 14, 78, 79, 8, | |
33516 | & 1, 8, 1, 8, 1, 9*0 / | |
33517 | DATA NZK3/ 23, 14, 2*13, 23, 13, 2*23, 14, 0, 7, 14, 4*0, 2*23, | |
33518 | & 10*0, 33, 2*31, 0, 33, 34, 32, 34, 0, 35, 0, 31, 3*35, 0, 3*31, | |
33519 | & 35, 31, 33, 34, 31, 33, 34, 31, 33, 35, 0, 23, 14, 6*0, 32, 3*33, | |
33520 | & 32, 34, 0, 35, 0, 2*35, 2*31, 35, 32, 34, 31, 33, 32, 0, 23, 13, | |
33521 | & 6*0, 34, 2*33, 34, 33, 34, 0, 35, 0,2*35, 2*31, 35, 2*34, 31, | |
33522 | & 2*34, 25*0, 23, 2*14, 23, 2*13, 9*0 / | |
33523 | * Particle names * | |
33524 | DATA ANAMZ / 'NNPI', 'ANPPI', 'ANNPI', ' ETS ',' PAP ',' PAN ', | |
33525 | & 'APN', 'DEO ', 'S+2030', 'AN*-14', 'AN*014','KONPI ','AKOPPI', | |
33526 | & 3*'BLANK' / | |
33527 | * Name of decay channel * | |
33528 | DATA ZKNAM4/'NNPI0','PNPI-','APPPI+','ANNPI+','ANPPI0','APNPI+', | |
33529 | & 'ANNPI0','APPPI0','ANPPI-'/ | |
33530 | DATA ZKNAM5/' GAGA ','P+P-GA','ETP+P-','K+K- ','K0AK0 ', | |
33531 | & ' POPO ',' P+P- ','POPOPO','P+P0P-','P0ET ','&0R0 ','P-R+ ', | |
33532 | & 'P+R- ','POOM ',' ETET ','ETSP0 ','R0ET ',' R0R0 ','R+R- ', | |
33533 | & 'P0ETR0','P-ETR+','P+ETR-',' OMET ','P0R0R0','P0R+R-','P-R+R0', | |
33534 | & 'P+R-R0','R0OM ','P0ETOM','ETSR0 ','ETETET','P0R0OM','P-R+OM', | |
33535 | & 'P+R-OM','OMOM ','R0ETET','R0R0ET','R+R-ET','P0OMOM','OMETET', | |
33536 | & 'R0R0R0','R+R0R-','ETSRET','OMR0R0','OMR+R-','OMOMET','OMOMR0', | |
33537 | & 'OMOMOM', | |
33538 | & ' P+PO ','P+POPO','P+P+P-','P+ET ','P0R+ ','P+R0 ','ETSP+ ', | |
33539 | & 'R+ET ',' R0R+ ','POETR+','P+ETR0','POR+R-','P+R0R0','P-R+R+', | |
33540 | & 'P+R-R+','R+OM ','P+ETOM','ETSR+ ','POR+OM','P+R0OM','R+ETET', | |
33541 | & 'R+R0ET','P+OMOM','R0R0R+','R+R+R-','ETSR+E','OMR+R0','OMOMR+', | |
33542 | & 'P-PO ','P-POPO','P-P-P+','P-ET ','POR- ','P-R0 ','ETSP- ', | |
33543 | & 'R-ET ','R-R0 ','POETR-','P-ETR0','POR-R0','P-R+R-','P-R0R0'/ | |
33544 | DATA ZKNAM6/'P+R-R-','R-OM ','P-ETOM','ETSR- ','POR-OM','P-R0OM', | |
33545 | & 'R-ETET','R-R0ET','P-OMOM','R0R0R-','R+R-R-','ETSR-E','OMR0R-', | |
33546 | & 'OMOMR-', 'PAN-14','APN+14','NAN014','ANN014','PAKO ','LPI+ ', | |
33547 | & 'SI+OM','LAMRO+','SI0RO+','SI+RO0','SI+ETA','SI0PI+','SI+PI0', | |
33548 | & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHOO','ANRHO-','ANETA ', | |
33549 | & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0', | |
33550 | & 'KONPIO','KOPPI-','K+NPI-','AKOPPO','AKONP+','K-PPI+', | |
33551 | & 9*'BLANK'/ | |
33552 | *= end*block.zk * | |
33553 | END | |
33554 | ||
33555 | *$ CREATE DT_BLKD43.FOR | |
33556 | *COPY DT_BLKD43 | |
33557 | * | |
33558 | *===blkd43=============================================================* | |
33559 | * | |
33560 | BLOCK DATA DT_BLKD43 | |
33561 | ||
33562 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
33563 | SAVE | |
33564 | ||
33565 | * | |
33566 | *=== reac =============================================================* | |
33567 | * | |
33568 | *----------------------------------------------------------------------* | |
33569 | * * | |
33570 | * Created on 10 december 1991 by Alfredo Ferrari & Paola Sala * | |
33571 | * Infn - Milan * | |
33572 | * * | |
33573 | * Last change on 10-dec-91 by Alfredo Ferrari * | |
33574 | * * | |
33575 | * This is the original common reac of Hadrin * | |
33576 | * * | |
33577 | *----------------------------------------------------------------------* | |
33578 | * | |
33579 | ||
33580 | COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184), | |
33581 | & NRK(2,268),NURE(30,2) | |
33582 | ||
33583 | DIMENSION | |
33584 | & UMOPI(92), UMOKC(68), UMOP(39), UMON(63), UMOK0(34), | |
33585 | & PLAPI(92), PLAKC(68), PLAP(39), PLAN(63), PLAK0(34), | |
33586 | & SPIKP1(315), SPIKPU(278), SPIKPV(372), | |
33587 | & SPIKPW(278), SPIKPX(372), SPIKP4(315), | |
33588 | & SPIKP5(187), SPIKP6(289), | |
33589 | & SKMPEL(102), SPIKP7(289), SKMNEL(68), SPIKP8(187), | |
33590 | & SPIKP9(143), SPIKP0(169), SPKPV(143), | |
33591 | & SAPPEL(105), SPIKPE(399), SAPNEL(84), SPIKPZ(273), | |
33592 | & SANPEL(84) , SPIKPF(273), | |
33593 | & SPKP15(187), SPKP16(272), | |
33594 | & NRKPI(164), NRKKC(132), NRKP(70), NRKN(116), NRKK0(54), | |
33595 | & NURELN(60) | |
33596 | * | |
33597 | DIMENSION NRKLIN(532) | |
33598 | EQUIVALENCE (NRK(1,1), NRKLIN(1)) | |
33599 | EQUIVALENCE ( UMO( 1), UMOPI(1)), ( UMO( 93), UMOKC(1)) | |
33600 | EQUIVALENCE ( UMO(161), UMOP(1)), ( UMO(200), UMON(1)) | |
33601 | EQUIVALENCE ( UMO(263), UMOK0(1)) | |
33602 | EQUIVALENCE ( PLABF( 1), PLAPI(1)), ( PLABF( 93), PLAKC(1)) | |
33603 | EQUIVALENCE ( PLABF(161), PLAP(1)), ( PLABF(200), PLAN(1)) | |
33604 | EQUIVALENCE ( PLABF(263), PLAK0(1)) | |
33605 | EQUIVALENCE ( WK( 1), SPIKP1(1)), ( WK( 316), SPIKPU(1)) | |
33606 | EQUIVALENCE ( WK( 594), SPIKPV(1)), ( WK( 966), SPIKPW(1)) | |
33607 | EQUIVALENCE ( WK(1244), SPIKPX(1)), ( WK(1616), SPIKP4(1)) | |
33608 | EQUIVALENCE ( WK(1931), SPIKP5(1)), ( WK(2118), SPIKP6(1)) | |
33609 | EQUIVALENCE ( WK(2407), SKMPEL(1)), ( WK(2509), SPIKP7(1)) | |
33610 | EQUIVALENCE ( WK(2798), SKMNEL(1)), ( WK(2866), SPIKP8(1)) | |
33611 | EQUIVALENCE ( WK(3053), SPIKP9(1)), ( WK(3196), SPIKP0(1)) | |
33612 | EQUIVALENCE ( WK(3365), SPKPV(1)), ( WK(3508), SAPPEL(1)) | |
33613 | EQUIVALENCE ( WK(3613), SPIKPE(1)), ( WK(4012), SAPNEL(1)) | |
33614 | EQUIVALENCE ( WK(4096), SPIKPZ(1)), ( WK(4369), SANPEL(1)) | |
33615 | EQUIVALENCE ( WK(4453), SPIKPF(1)), ( WK(4726), SPKP15(1)) | |
33616 | EQUIVALENCE ( WK(4913), SPKP16(1)) | |
33617 | EQUIVALENCE (NRK(1,1), NRKLIN(1)) | |
33618 | EQUIVALENCE (NRKLIN( 1), NRKPI(1)), (NRKLIN( 165), NRKKC(1)) | |
33619 | EQUIVALENCE (NRKLIN( 297), NRKP(1)), (NRKLIN( 367), NRKN(1)) | |
33620 | EQUIVALENCE (NRKLIN( 483), NRKK0(1)) | |
33621 | EQUIVALENCE (NURE(1,1), NURELN(1)) | |
33622 | * | |
33623 | **** pi- p data * | |
33624 | **** pi+ n data * | |
33625 | DATA PLAPI / 0.D0, .3D0, .5D0, .6D0, .7D0, .8D0, .9D0, .95D0,1.D0, | |
33626 | & 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0, | |
33627 | & 3.D0, 3.5D0, 4.D0, 0.D0, .285D0, .4D0, .45D0, .5D0, .6D0, .7D0, | |
33628 | & .75D0, .8D0, .85D0, .9D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, | |
33629 | & 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0, | |
33630 | & .285D0, .4D0, .45D0, .5D0, .6D0, .7D0, .75D0, .8D0, .85D0, .9D0, | |
33631 | & 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0, | |
33632 | & 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0, .3D0, .5D0, .6D0, .7D0, | |
33633 | & .8D0, .9D0, .95D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, | |
33634 | & 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0 / | |
33635 | DATA PLAKC / | |
33636 | & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0, | |
33637 | & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0, | |
33638 | & 3.51D0, 3.84D0, 4.16D0, 4.49D0, | |
33639 | & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0, | |
33640 | & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0, | |
33641 | & 3.51D0, 3.84D0, 4.16D0, 4.49D0, | |
33642 | & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0, | |
33643 | & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0, | |
33644 | & 3.51D0, 3.84D0, 4.16D0, 4.49D0, | |
33645 | & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0, | |
33646 | & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0, | |
33647 | & 3.51D0, 3.84D0, 4.16D0, 4.49D0/ | |
33648 | DATA PLAK0 / | |
33649 | & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0, | |
33650 | & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0, | |
33651 | & 3.51D0, 3.84D0, 4.16D0, 4.49D0, | |
33652 | & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0, | |
33653 | & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0, | |
33654 | & 3.51D0, 3.84D0, 4.16D0, 4.49D0/ | |
33655 | * pp pn np nn * | |
33656 | DATA PLAP / | |
33657 | & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0, | |
33658 | & 3.43D0, 3.75D0, 4.07D0, 4.43D0, | |
33659 | & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0, | |
33660 | & 3.43D0, 3.75D0, 4.07D0, 4.43D0, | |
33661 | & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0, | |
33662 | & 3.43D0, 3.75D0, 4.07D0, 4.43D0 / | |
33663 | * app apn anp ann * | |
33664 | DATA PLAN / | |
33665 | & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0, | |
33666 | & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0, | |
33667 | & 3.43D0, 3.75D0, 4.07D0, 4.43D0, | |
33668 | & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0, | |
33669 | & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0, | |
33670 | & 3.43D0, 3.75D0, 4.07D0, 4.43D0, | |
33671 | & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0, | |
33672 | & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0, | |
33673 | & 3.43D0, 3.75D0, 4.07D0, 4.43D0 / | |
33674 | DATA SIIN / 296*0.D0 / | |
33675 | DATA UMOPI/ 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0, | |
33676 | & 1.557D0,1.615D0,1.6435D0, | |
33677 | & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0, | |
33678 | & 2.286D0,2.366D0,2.482D0,2.56D0, | |
33679 | & 2.735D0,2.90D0, | |
33680 | & 1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0, | |
33681 | & 1.496D0,1.527D0,1.557D0, | |
33682 | & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0, | |
33683 | & 2.071D0,2.159D0,2.286D0,2.366D0, | |
33684 | & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0, | |
33685 | & 1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0, | |
33686 | & 1.496D0,1.527D0,1.557D0, | |
33687 | & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0, | |
33688 | & 2.071D0,2.159D0,2.286D0,2.366D0, | |
33689 | & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0, | |
33690 | & 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0, | |
33691 | & 1.557D0,1.615D0,1.6435D0, | |
33692 | & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0, | |
33693 | & 2.286D0,2.366D0,2.482D0,2.56D0, | |
33694 | & 2.735D0, 2.90D0/ | |
33695 | DATA UMOKC/ 1.44D0, | |
33696 | & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0, | |
33697 | & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0, | |
33698 | & 3.1D0,1.44D0, | |
33699 | & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0, | |
33700 | & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0, | |
33701 | & 3.1D0,1.44D0, | |
33702 | & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0, | |
33703 | & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0, | |
33704 | & 3.1D0,1.44D0, | |
33705 | & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0, | |
33706 | & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0, | |
33707 | & 3.1D0/ | |
33708 | DATA UMOK0/ 1.44D0, | |
33709 | & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0, | |
33710 | & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0, | |
33711 | & 3.1D0,1.44D0, | |
33712 | & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0, | |
33713 | & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0, | |
33714 | & 3.1D0/ | |
33715 | * pp pn np nn * | |
33716 | DATA UMOP/ | |
33717 | & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0, | |
33718 | & 3.D0,3.1D0,3.2D0, | |
33719 | & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0, | |
33720 | & 3.D0,3.1D0,3.2D0, | |
33721 | & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0, | |
33722 | & 3.D0,3.1D0,3.2D0/ | |
33723 | * app apn anp ann * | |
33724 | DATA UMON / | |
33725 | & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0, | |
33726 | & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0, | |
33727 | & 3.D0,3.1D0,3.2D0, | |
33728 | & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0, | |
33729 | & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0, | |
33730 | & 3.D0,3.1D0,3.2D0, | |
33731 | & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0, | |
33732 | & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0, | |
33733 | & 3.D0,3.1D0,3.2D0/ | |
33734 | **** reaction channel state particles * | |
33735 | DATA NRKPI / 13, 1, 15, 21, 81, 0, 13, 54, 23, 53, 13, 63, 13, 58, | |
33736 | & 23, 57, 13, 65, 1, 32, 53, 31, 54, 32, 53, 33, 53, 35, 63, 32, | |
33737 | & 13, 8, 23, 1, 17, 15, 21, 24, 22, 15, 82, 0, 61, 0, 13, 55, 23, | |
33738 | & 54, 14, 53, 13, 64, 23, 63, 13, 59, 23, 58, 14, 57, 13, 66, 23, | |
33739 | & 65, 1, 31, 8, 32, 1, 33, 1, 35, 54, 31, 55, 32, 54, 33, 53, 34, | |
33740 | & 54, 35, 14, 1, 23, 8, 17, 24, 20, 15, 22, 24, 83, 0, 62, 0, 14, | |
33741 | & 54, 23, 55, 13, 56, 14, 63, 23, 64, 14, 58, 23, 59, 13, 60, 14, | |
33742 | & 65, 23, 66, 8, 31, 1, 34, 8, 33, 8, 35, 55, 31, 54, 34, 55, 33, | |
33743 | & 56, 32, 55, 35, 14, 8, 24, 20, 84, 0, 14, 55, 23, 56, 14, 64, 14, | |
33744 | & 59, 23, 60, 14, 66, 8, 34, 56, 31, 55, 34, 56, 33, 56, 35, 64,34/ | |
33745 | DATA NRKKC/ 15, 1, 89, 0, 24, 53, 15, 54, 1, 36, 1, 40, 1, 44, 36, | |
33746 | & 63, 15, 63, 45, 53, 44, 54, 15, 8, 24, 1, 91, 0, 24, 54, 15, 55, | |
33747 | & 8, 36, 1, 37, 8, 40, 1, 41, 8, 44, 1, 45, 36, 64, 37, 63, 15, 64, | |
33748 | & 24, 63, 45, 54, 44, 55, 16, 1, 25, 8, 17, 23, 21, 14, 20, | |
33749 | & 13, 22, 23, 90, 0, 38, 1, 39, 8, 16, 54, 25, 55, 1, 42, 8, 43, | |
33750 | & 16, 63, 25, 64, 39, 64, 38, 63, 46, 54, 47, 55, 8, 47, 1, 46, 52, | |
33751 | & 0, 51, 0, 16, 8, 17, 14, 20, 23, 22, 14, 92, 0, 8, 38, 16, 55, | |
33752 | & 25, 56, 8, 42, 16, 64, 38, 64, 46, 55, 47, 56, 8, 46, 94, 0 / | |
33753 | * * | |
33754 | * k0 p k0 n ak0 p ak/ n * | |
33755 | * * | |
33756 | DATA NRKK0 / 24, 8, 106, 0, 15, 56, 24, 55, 37, 8, 41, 8, 45, 8, | |
33757 | & 37, 64, 24, 64, 44, 56, 45, 55, 25, 1, 17, 13, 22, 13, 21, 23, | |
33758 | & 107, 0, 39, 1, 25, 54, 16, 53, 43, 1, 25, 63, 39, 63, 47, 54, 46, | |
33759 | & 53, 47, 1, 103, 0, 93, 0/ | |
33760 | * pp pn np nn * | |
33761 | DATA NRKP / 1, 1, 85, 0, 8, 53, 1, 54, 1, 63, 8, 57, 1, 58, 2*54, | |
33762 | & 53, 55, 63, 54, 64, 53, 1, 8, 86, 0, 8, 54, 1, 55, 8, 63, 1, 64, | |
33763 | & 8, 58, 1, 59, 64, 54, 63, 55, 54, 55, 53, 56, 77, 0, 2*8, 95, 0, | |
33764 | & 8, 55, 1, 56, 8, 64, 8, 59, 1, 60, 2*55, 54, 56, 64, 55, 63, 56 / | |
33765 | * app apn anp ann * | |
33766 | DATA NRKN/ 1, 2, 17, 18, 15, 16, 8, 9, 13, 14, 99, 0, 87, 0, 1, | |
33767 | & 68, 8, 69, 2, 54, 9, 55, 102, 0, 2, 63, 9, 64, 1, 75, 8, 76, 53, | |
33768 | & 67, 54, 68, 55, 69, 56, 70, 63, 68, 64, 69, 75, 54, 76, 55, 2, 8, | |
33769 | & 18, 20, 16, 24, 14, 23, 101, 0, 88, 0, 2, 55, 9, 56, 1, 67, 8, | |
33770 | & 68, 2, 64, 8, 75, 2, 59, 8, 72, 68, 55, 67, 54, 69, 56, 1, 9, 18, | |
33771 | & 21, 15, 25, 13, 23, 100, 0, 96, 0, 2, 53, 9, 54, 1, 69, 8, 70, 1, | |
33772 | & 76, 9, 63, 1, 73, 9, 58, 55, 70, 53, 68, 54, 69 / | |
33773 | **** channel cross section * | |
33774 | DATA SPIKP1/ 0.D0, 300.D0, 40.D0, 20.D0, 13.D0,8.5D0,8.D0, 9.5D0, | |
33775 | & 12.D0,14.D0,15.5D0,20.D0,17.D0,13.D0,10.D0,9.D0,8.5D0,8.D0,7.8D0, | |
33776 | & 7.3D0, 6.7D0, 9*0.D0,.23D0,.35D0,.7D0,.52D0,.4D0,.3D0,.2D0,.15D0, | |
33777 | & .13D0, .11D0, .09D0, .07D0, 0.D0, .033D0,.8D0,1.35D0,1.35D0,.5D0, | |
33778 | & 15*0.D0, 3*0.D0,.00D0,0.80D0,2.2D0,3.6D0,4.6D0,4.7D0,3.5D0,2.4D0, | |
33779 | &1.8D0,1.4D0,.75D0,.47D0,.25D0,.13D0,.08D0,6*0.D0,0.D0,1.2D0,3.3D0, | |
33780 | & 5.4D0,6.9D0,7.3D0,5.3D0,3.6D0,2.7D0,2.2D0,1.1D0,.73D0,.4D0,.22D0, | |
33781 | & .12D0,9*0.D0,.0D0,0.D0,2.0D0,4.4D0,6.8D0,9.9D0,7.9D0,6.0D0,3.8D0, | |
33782 | &2.5D0,2.D0,1.4D0,1.D0,.6D0,.35D0,10*0.D0,.25D0,.55D0,.75D0,1.25D0, | |
33783 | & 1.9D0,2.D0,1.8D0,1.5D0,1.25D0,1.D0,.8D0,6*0.D0,4*0.D0,.4D0,.85D0, | |
33784 | & 1.1D0, 1.85D0, 2.8D0, 3.D0,2.7D0,2.2D0,1.85D0,1.5D0,1.2D0,6*0.D0, | |
33785 | & 6*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0, 5.6D0, | |
33786 | & 5.2D0, 6*0.D0, 2*0.D0, .0D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0, | |
33787 | & 2.75D0, 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 6*0.D0, 3*0.D0, | |
33788 | & .0D0, .45D0, 1.4D0, 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0, | |
33789 | & 8*0.D0, 5*0.D0, .0D0, .0D0, .6D0, .8D0, .95D0, .8D0, .7D0, .6D0, | |
33790 | & .5D0, .4D0, 6*0.D0, 5*0.D0, .0D0, .00D0, .85D0, 1.2D0, 1.4D0, | |
33791 | & 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 6*0.D0, 5*0.D0, .0D0, .00D0, | |
33792 | & 1.D0, 1.5D0, 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 6*0.D0, | |
33793 | & 10*0.D0, .5D0, 2.0D0, 3.3D0, 5.4D0, 7.D0 / | |
33794 | **** pi+ n data * | |
33795 | DATA SPIKPU/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 20.D0, | |
33796 | & 20.D0, 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0, | |
33797 | & 10.D0, 10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0, | |
33798 | & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0, | |
33799 | & 4.2D0, 7.5D0, 3.4D0, 2.5D0, 2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0, | |
33800 | & .6D0, .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0, | |
33801 | & .48D0, .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0, | |
33802 | & .065D0, .05D0, .04D0, 12*0.D0, .2D0, .25D0, .25D0, .2D0, .1D0, | |
33803 | & .08D0, .06D0, .045D0, .03D0, .02D0, .01D0, .005D0, .003D0, | |
33804 | & 12*0.D0, .3D0, .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0, | |
33805 | & .09D0, .08D0, .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0, | |
33806 | & 3.1D0, 4.5D0, 2.D0, 18*0.D0, 3*.0D0, 0.D0, 0.D0, 4.0D0, 11.D0, | |
33807 | & 11.4D0, 10.3D0, 7.5D0, 6.8D0, 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0, | |
33808 | & .35D0, 13*0.D0, .1D0, .34D0, .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0, | |
33809 | & 2.3D0, 1.6D0, .95D0, .45D0, .28D0, .15D0, 10*0.D0, 2*0.D0, .17D0, | |
33810 | & .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0, 6.2D0, 4.4D0, 3.D0, 1.8D0, | |
33811 | & .9D0, .53D0, .28D0, 10*0.D0, 2*0.D0, .25D0, .82D0, | |
33812 | & 1.3D0, 1.9D0, 2.8D0, 5.5D0 , 8.D0, 5.7D0, 3.9D0, 2.35D0, 1.15D0, | |
33813 | & .69D0, .37D0, 10*0.D0, 7*0.D0, .0D0, .34D0, 1.5D0, 3.47D0, | |
33814 | & 5.87D0, 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/ | |
33815 | * | |
33816 | DATA SPIKPV/ 7*0.D0, .00D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0, | |
33817 | & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 6*0.D0, 10*0.D0, .2D0, | |
33818 | & .6D0, .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0, | |
33819 | & 1.D0, .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0, | |
33820 | & 3.5D0, 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0, | |
33821 | & .31D0, .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0, | |
33822 | & .23D0, 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0, | |
33823 | & 5.D0, 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0, | |
33824 | & 2.5D0, 3*0.D0, 3*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0, | |
33825 | & 1.5D0, 1.1D0, .8D0, .7D0, .55D0, .3D0, 10*0.D0, 9*0.D0, .1D0, | |
33826 | & .4D0, 1.D0, 1.4D0, 2.2D0, 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0, | |
33827 | & .8D0, .6D0, .4D0, 12*0.D0, .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0, | |
33828 | & 3.8D0, 3.3D0, 2.45D0, 2.05D0, 1.65D0, 1.2D0, .9D0, .6D0, 3*0.D0, | |
33829 | & 9*0.D0, .10D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0, | |
33830 | & 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, 13*0.D0, .2D0, .5D0, .7D0, | |
33831 | & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, | |
33832 | & 17*0.D0, .2D0, .5D0, .85D0, 2.D0, 2.15D0, 2.05D0, 1.75D0, 1.D0, | |
33833 | & 17*0.D0, .13D0, .33D0, .57D0, 1.33D0, 1.43D0, 1.36D0, 1.17D0, | |
33834 | & .67D0, 17*0.D0, .07D0, .17D0, .28D0, .67D0, .72D0, .69D0, .58D0, | |
33835 | & .33D0,17*0.D0,.4D0, .7D0, 1.D0, 1.6D0, 1.8D0, 2.3D0,1.9D0,1.7D0 / | |
33836 | **** pi- p data * | |
33837 | DATA SPIKPW/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 2*20.D0, | |
33838 | & 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0, | |
33839 | & 2*10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0, | |
33840 | & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0, | |
33841 | & 4.2D0, 7.5D0, 3.4D0, 2*2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0, .6D0, | |
33842 | & .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0, .48D0, | |
33843 | & .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0, .065D0, | |
33844 | & .05D0, .04D0, 12*0.D0, .2D0, 2*.25D0, .2D0, .1D0, .08D0, .06D0, | |
33845 | & .045D0, .03D0, .02D0, .01D0, .005D0, .003D0, 12*0.D0, .3D0, | |
33846 | & .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0, .09D0, .08D0, | |
33847 | & .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0, 3.1D0, 4.5D0, | |
33848 | & 2.D0, 23*0.D0, 4.0D0, 11.D0, 11.4D0, 10.3D0, 7.5D0, 6.8D0, | |
33849 | & 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0, .35D0, 13*0.D0, .1D0, .34D0, | |
33850 | & .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0, 2.3D0, 1.6D0, .95D0, .45D0, | |
33851 | & .28D0, .15D0, 12*0.D0, .17D0, .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0, | |
33852 | & 6.2D0, 4.4D0, 3.D0, 1.8D0, .9D0, .53D0, .28D0, 12*0.D0, .25D0, | |
33853 | & .82D0, 1.3D0, 1.9D0, 2.8D0, 5.5D0, 8.D0, 5.7D0, 3.9D0, 2.35D0, | |
33854 | & 1.15D0, .69D0, .37D0, 18*0.D0, .34D0, 1.5D0, 3.47D0, 5.87D0, | |
33855 | & 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/ | |
33856 | * | |
33857 | DATA SPIKPX/ 8*0.D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0, | |
33858 | & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 16*0.D0, .2D0, .6D0, | |
33859 | & .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0, 1.D0, | |
33860 | & .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0, 3.5D0, | |
33861 | & 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0, .31D0, | |
33862 | & .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0, .23D0, | |
33863 | & 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0, 5.D0, | |
33864 | & 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0, 2.5D0, | |
33865 | & 6*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0, 1.5D0, 1.1D0, | |
33866 | & .8D0, .7D0, .55D0, .3D0, 19*0.D0, .1D0, .4D0, 1.D0, 1.4D0, 2.2D0, | |
33867 | & 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0, .8D0, .6D0, .4D0, 12*0.D0, | |
33868 | & .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0, 3.8D0, 3.3D0, 2.45D0, 2.05D0, | |
33869 | & 1.65D0, 1.2D0, .9D0, .6D0, 12*0.D0, .10D0, .2D0, .5D0, .7D0, | |
33870 | & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, | |
33871 | & 13*0.D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, | |
33872 | & 1.35D0, 1.15D0, .95D0, .7D0, 17*0.D0, .2D0, .5D0, .85D0, 2.D0, | |
33873 | & 2.15D0, 2.05D0, 1.75D0, 1.D0, 17*0.D0, .13D0, .33D0, .57D0, | |
33874 | & 1.33D0, 1.43D0, 1.36D0, 1.17D0, .67D0, 17*0.D0, .07D0, .17D0, | |
33875 | & .28D0, .67D0, .72D0, .69D0, .58D0, .33D0, 17*0.D0, .4D0, .7D0, | |
33876 | & 1.D0, 1.6D0, 1.8D0, 2.3D0, 1.9D0, 1.7D0 / | |
33877 | **** pi- n data * | |
33878 | DATA SPIKP4 / 0.D0, 300.D0, 40.D0, 20.D0, 13.D0, 8.5D0, 8.D0, | |
33879 | & 9.5D0, 12.D0, 14.D0, 15.5D0, 20.D0, 17.D0, 13.D0, 10.D0, 9.D0, | |
33880 | & 8.5D0, 8.D0, 7.8D0, 7.3D0, 6.7D0, 9*0.D0, .23D0, .35D0, .7D0, | |
33881 | & .52D0, .4D0, .3D0, .2D0, .15D0, .13D0, .11D0, .09D0, .07D0, 0.D0, | |
33882 | & .033D0, .8D0, 2*1.35D0, .5D0, 19*0.D0, 0.8D0, 2.2D0, 3.6D0, | |
33883 | & 4.6D0, 4.7D0, 3.5D0, 2.4D0, 1.8D0, 1.4D0, .75D0, .47D0, .25D0, | |
33884 | & .13D0, .08D0, 7*0.D0, 1.2D0, 3.3D0, 5.4D0, 6.9D0, 7.3D0, 5.3D0, | |
33885 | & 3.6D0, 2.7D0, 2.2D0, 1.1D0, .73D0, .4D0, .22D0, .12D0, 11*0.D0, | |
33886 | & 2.0D0, 4.4D0, 6.8D0, 9.9D0, 7.9D0, 6.0D0, 3.8D0, 2.5D0, 2.D0, | |
33887 | & 1.4D0, 1.D0, .6D0, .35D0, 10*0.D0, .25D0, .55D0, .75D0, 1.25D0, | |
33888 | & 1.9D0, 2.D0, 1.8D0, 1.5D0, 1.25D0, 1.D0, .8D0, 10*0.D0, .4D0, | |
33889 | & .85D0, 1.1D0, 1.85D0, 2.8D0, 3.D0, 2.7D0, 2.2D0, 1.85D0, 1.5D0, | |
33890 | & 1.2D0, 12*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0, | |
33891 | & 5.6D0, 5.2D0, 9*0.D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0, 2.75D0, | |
33892 | & 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 10*0.D0, .45D0, 1.4D0, | |
33893 | & 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0, 15*0.D0, .6D0, | |
33894 | & .8D0, .95D0, .8D0, .7D0, .6D0, .5D0, .4D0, 13*0.D0, .85D0, 1.2D0, | |
33895 | & 1.4D0, 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 13*0.D0, 1.D0, 1.5D0, | |
33896 | & 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 16*0.D0, .5D0, 2.0D0, | |
33897 | & 3.3D0, 5.4D0, 7.D0 / | |
33898 | **** k+ p data * | |
33899 | DATA SPIKP5/ 0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0, | |
33900 | & 7.D0, 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0, | |
33901 | & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 13*0.D0, 0.9D0, | |
33902 | & 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0, | |
33903 | & .45D0, .21D0, .2D0, 3*0.D0, .9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, | |
33904 | & 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0, | |
33905 | & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0, 1.4D0, | |
33906 | & 1.2D0, 1.05D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0, 2*1.D0, .9D0, | |
33907 | & .7D0, .4D0, .3D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.2D0, | |
33908 | & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, | |
33909 | & 1.71D0, 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0, | |
33910 | & 3.5D0, 2.85D0, 2.35D0, 2.01D0, 1.8D0, 12*0.D0, .1D0, .8D0,2.05D0, | |
33911 | & 3.31D0, 3.5D0, 12*0.D0, .034D0, .2D0, .75D0, 1.04D0, 1.24D0 / | |
33912 | **** k+ n data * | |
33913 | DATA SPIKP6/ 0.D0, 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0, | |
33914 | & 1.5D0, 1.2D0, 1.D0, .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0, | |
33915 | & 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0, 1.5D0, 1.2D0, 1.D0, | |
33916 | & .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0, .5D0, 1.3D0, 2.8D0, | |
33917 | & 2.3D0, 1.6D0, .9D0, 13*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, | |
33918 | & 2.D0, 1.7D0, 1.5D0,1.2D0,.9D0,.6D0,.45D0,.21D0,.2D0,3*0.D0,0.9D0, | |
33919 | & 2.5D0, 3.D0, 2.5D0, 2.3D0,2.D0,1.7D0,1.5D0,1.2D0,.9D0,.6D0,.45D0, | |
33920 | & .21D0, .2D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.D0,1.8D0,1.7D0,1.4D0, | |
33921 | & 1.2D0,1.15D0,.9D0,.66D0,.5D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.1D0, | |
33922 | & 1.8D0,1.7D0,1.4D0,1.2D0, 1.15D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0, | |
33923 | & 2*1.D0, .9D0, .7D0, .4D0, .35D0, .2D0, 9*0.D0, .3D0, 2*1.D0,.9D0, | |
33924 | & .7D0, .4D0, .35D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.4D0,3.5D0,4.25D0, | |
33925 | & 4.55D0, 4.85D0, 4.9D0, 9*0.D0, .1D0, 1.D0, 2.4D0, 3.5D0, 4.25D0, | |
33926 | & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, | |
33927 | & 1.71D0, 1.6D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0, | |
33928 | & 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0,4.4D0,4.D0,3.5D0,2.85D0, | |
33929 | & 2.35D0, 2.01D0, 1.8D0, 6*0.D0, 1.4D0,3.8D0,5.D0,4.7D0,4.4D0,4.D0, | |
33930 | & 3.5D0,2.85D0,2.35D0,2.01D0,1.8D0,12*0.D0,.1D0,.8D0,2.05D0,3.31D0, | |
33931 | & 3.5D0, 12*0.D0, .034D0,.2D0,.75D0,1.04D0,1.24D0 / | |
33932 | **** k- p data * | |
33933 | DATA SKMPEL/ 0.D0, 35.D0, 22.D0, 25.D0, 17.D0, 9.D0, 9.5D0, 8.D0, | |
33934 | & 7.D0, 6.5D0, 6.1D0, 5.D0, 4.8D0, 4.6D0, 4.45D0, 4.3D0, 4.2D0, | |
33935 | & 0.D0, 8.D0, 3.5D0, 8.D0, 3.D0, 1.9D0, 1.7D0, 1.D0, .9D0, .8D0, | |
33936 | & .75D0, .5D0, .42D0, .38D0, .34D0, .25D0, .2D0, | |
33937 | & 0.D0, 3.D0, 3.2D0, 3.5D0, 1.5D0, 1.4D0, 1.1D0, .6D0, .5D0, | |
33938 | & .35D0, .28D0, .25D0, .18D0, .12D0, .1D0, .08D0, .04D0, | |
33939 | & 0.D0, 8.5D0, 2.4D0, 1.7D0, 1.3D0, 1.3D0, 1.1D0, .5D0, | |
33940 | & .4D0, .4D0, .35D0, .3D0, .28D0, .2D0, .16D0, .13D0, .11D0, | |
33941 | & 0.D0, 7.D0, 4.8D0, 1.4D0, 1.9D0, .9D0, .4D0, .2D0, .13D0, | |
33942 | & .1D0, .08D0, .06D0, .04D0, .02D0, .015D0, .01D0, .01D0, | |
33943 | & 0.D0, 5.5D0, 1.D0, .8D0, .75D0, .32D0, .2D0, .1D0, .09D0, | |
33944 | & .08D0, .065D0, .05D0, .04D0, .022D0, .017D0, 2*.01D0/ | |
33945 | DATA SPIKP7 / 0.D0, .56D0, 1.46D0, 3.16D0, 2.01D0, 1.28D0, .74D0, | |
33946 | & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, | |
33947 | & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 4*0.D0, | |
33948 | & 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0, 1.57D0, | |
33949 | & 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0, 3.03D0, | |
33950 | & 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, | |
33951 | & .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0, 2.8D0, | |
33952 | & 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, | |
33953 | & .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, | |
33954 | & .45D0, .39D0, .22D0, .07D0, 0.D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, | |
33955 | & 1.01D0, .78D0, .45D0, .39D0, .22D0, .07D0, 0.D0, 6*0.D0, 1.71D0, | |
33956 | & 4.26D0, 5.6D0, 5.57D0, 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0, | |
33957 | & 2.25D0, 2.D0, 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0, | |
33958 | & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0, .22D0, | |
33959 | & .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 10*0.D0, .22D0, .8D0, | |
33960 | & .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0, .3D0, .7D0,1.D0, | |
33961 | & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0, 1.72D0, 2.69D0, | |
33962 | & 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 9*0.D0, .11D0, 1.72D0, | |
33963 | & 2.69D0, 3.92D0, 4.76D0, 5.1D0, 5.44D0, 5.3D0, 5*0.D0,9.2D0,4.7D0, | |
33964 | & 1.9D0, 10*0.D0, 2.5D0, 15.D0, 21.5D0, 15.3D0, 3.D0, 1.5D0, | |
33965 | & 10*0.D0/ | |
33966 | ***** k- n data * | |
33967 | DATA SKMNEL/0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0, | |
33968 | & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0, | |
33969 | & 0.D0, 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0, | |
33970 | & 1.9D0, .9D0, .5D0, .3D0, .24D0, .2D0, .18D0, .1D0, .09D0, | |
33971 | & 0.D0, 1.8D0, 2.D0, 1.1D0, .9D0, .5D0, .5D0, .4D0, .4D0, | |
33972 | & .2D0, .1D0, .06D0, .05D0, .04D0, .03D0, .02D0, .02D0, | |
33973 | & 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0, .7D0, .65D0, | |
33974 | & .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0, .03D0/ | |
33975 | DATA SPIKP8/0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0, | |
33976 | & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, | |
33977 | & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, | |
33978 | & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, | |
33979 | & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0, | |
33980 | & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, | |
33981 | & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0, | |
33982 | & 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, .45D0, | |
33983 | & .39D0, .22D0, .07D0, 0.D0, | |
33984 | & 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0, | |
33985 | & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, | |
33986 | & 10*0.D0, .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, | |
33987 | & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, | |
33988 | & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, | |
33989 | & 9*0.D0, .11D0, 1.72D0, 2.69D0, 3.92D0, 4.76D0, | |
33990 | & 5.10D0, 5.44D0, 5.3D0, | |
33991 | & 4*0.D0, 0.00D0, 9.2D0, 4.7D0, 1.9D0, 9*0.D0/ | |
33992 | ***** p p data * | |
33993 | DATA SPIKP9/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0, | |
33994 | & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0, | |
33995 | & 0.D0, 3.6D0, 1.7D0, 10*0.D0, | |
33996 | & .0D0, 0.D0, 8.7D0, 17.7D0, 18.8D0, 15.9D0, | |
33997 | & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0, | |
33998 | & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0, | |
33999 | & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0, | |
34000 | & 5*0.D0, 4.6D0, 10.2D0, 15.1D0, | |
34001 | & 16.9D0, 16.5D0, 11.D0, 5.5D0, 3.5D0, | |
34002 | & 10*0.D0, 4.3D0, 7.6D0, 9.D0, | |
34003 | & 10*0.D0, 1.7D0, 2.6D0, 3.D0, | |
34004 | & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0, | |
34005 | & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0, | |
34006 | & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0, | |
34007 | & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/ | |
34008 | ***** p n data * | |
34009 | DATA SPIKP0/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0, | |
34010 | & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0, | |
34011 | & 0.D0, 1.8D0, .2D0, 12*0.D0, | |
34012 | & 3.2D0, 6.05D0, 9.9D0, 5.1D0, | |
34013 | & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0, | |
34014 | & 2*.0D0, 3.2D0, 6.05D0, 9.9D0, 5.1D0, | |
34015 | & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0, | |
34016 | & 5*0.D0, 4.6D0, 10.2D0, 15.1D0, | |
34017 | & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0, | |
34018 | & 5*0.D0, 4.6D0, 10.2D0, 15.1D0, | |
34019 | & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0, | |
34020 | & 10*0.D0, .7D0, 5.1D0, 8.D0, | |
34021 | & 10*0.D0, .7D0, 5.1D0, 8.D0, | |
34022 | & 10*.0D0, .3D0, 2.8D0, 4.7D0, | |
34023 | & 10*.0D0, .3D0, 2.8D0, 4.7D0, | |
34024 | & 7*0.D0, 1.2D0, 2.5D0, 3.5D0, 6.D0, 5.3D0, 2.9D0, | |
34025 | & 7*0.D0, 1.7D0, 3.6D0, 5.4D0, 9.D0, 7.6D0, 4.2D0, | |
34026 | & 5*0.D0, 7.7D0, 6.1D0, 2.9D0, 5*0.D0/ | |
34027 | * nn - data * | |
34028 | * * | |
34029 | DATA SPKPV/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0, | |
34030 | & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0, | |
34031 | & 0.D0, 3.6D0, 1.7D0, 12*0.D0, | |
34032 | & 8.7D0, 17.7D0, 18.8D0, 15.9D0, | |
34033 | & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0, | |
34034 | & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0, | |
34035 | & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0, | |
34036 | & 5*0.D0, 4.6D0, 10.2D0, 15.1D0, 16.9D0, 16.5D0, | |
34037 | & 11.D0, 5.5D0, 3.5D0, | |
34038 | & 10*0.D0, 4.3D0, 7.6D0, 9.D0, | |
34039 | & 10*0.D0, 1.7D0, 2.6D0, 3.D0, | |
34040 | & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0, | |
34041 | & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0, | |
34042 | & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0, | |
34043 | & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/ | |
34044 | **************** ap - p - data * | |
34045 | DATA SAPPEL/ 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, | |
34046 | & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0, | |
34047 | & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0, | |
34048 | & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0, | |
34049 | & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0, | |
34050 | & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0, | |
34051 | & 0.D0, 55.D0, 50.D0, 25.D0, 15.D0, 15.D0, 14.D0, 12.D0, | |
34052 | & 10.D0, 7.D0, 6.D0, 4.D0, 3.3D0, 2.8D0, 2.4D0, 2.D0, 1.8D0, | |
34053 | & 1.55D0, 1.3D0, .95D0, .75D0, | |
34054 | & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, | |
34055 | & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0, | |
34056 | & .01D0, .008D0, .006D0, .005D0/ | |
34057 | DATA SPIKPE/0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0, | |
34058 | & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0, | |
34059 | & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, | |
34060 | & 9*0.D0, 2.D0, 2.5D0, .2D0, 19*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0, | |
34061 | & 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0, .3D0, 1.4D0, | |
34062 | & 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0, | |
34063 | & .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, | |
34064 | & .3D0, 10*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, | |
34065 | & .6D0, .5D0, .4D0, .3D0, 9*0.D0, .6D0, 2.5D0, 5.D0, 5.2D0, 5.1D0, | |
34066 | & 5.4D0, 5.8D0, 2.8D0, 2.1D0, 1.8D0, 1.6D0, 1.2D0, 13*0.D0, 1.3D0, | |
34067 | & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0, | |
34068 | & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0, | |
34069 | & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0, | |
34070 | & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 14*0.D0, .2D0, | |
34071 | & .5D0, 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, | |
34072 | & 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0, | |
34073 | & 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0, 1.6D0, | |
34074 | & 1.4D0, 1.1D0, .9D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0, | |
34075 | & .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, | |
34076 | & 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0 / | |
34077 | **************** ap - n - data * | |
34078 | DATA SAPNEL/ | |
34079 | & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, | |
34080 | & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0, | |
34081 | & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0, | |
34082 | & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, | |
34083 | & .85D0, 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, | |
34084 | & .14D0, .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0, | |
34085 | & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, | |
34086 | & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0, | |
34087 | & .01D0, .008D0, .006D0, .005D0 / | |
34088 | DATA SPIKPZ/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0, | |
34089 | & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0, | |
34090 | & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0, | |
34091 | & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, | |
34092 | & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, | |
34093 | & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, | |
34094 | & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, | |
34095 | & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, | |
34096 | & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0, | |
34097 | & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0, | |
34098 | & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0, | |
34099 | & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, | |
34100 | & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0, | |
34101 | & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 / | |
34102 | * * | |
34103 | * * | |
34104 | **************** an - p - data * | |
34105 | * * | |
34106 | DATA SANPEL/ | |
34107 | & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, 50.D0, | |
34108 | & 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0, | |
34109 | & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0, .05D0, | |
34110 | & .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0, | |
34111 | & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0, | |
34112 | & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0, | |
34113 | & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, .25D0, | |
34114 | & .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0, | |
34115 | & .01D0, .008D0, .006D0, .005D0 / | |
34116 | DATA SPIKPF/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0, | |
34117 | & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0, | |
34118 | & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0, | |
34119 | & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, | |
34120 | & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, | |
34121 | & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, | |
34122 | & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, | |
34123 | & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, | |
34124 | & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0, | |
34125 | & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0, | |
34126 | & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0, | |
34127 | & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, | |
34128 | & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0, | |
34129 | & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 / | |
34130 | **** ko - n - data * | |
34131 | DATA SPKP15/0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0, 7.D0, | |
34132 | & 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0, | |
34133 | & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 10*0.D0, | |
34134 | & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, | |
34135 | & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0, | |
34136 | & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, | |
34137 | & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0, | |
34138 | & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0, | |
34139 | & 1.4D0, 1.2D0, 1.05D0, .9D0, .66D0, .5D0, | |
34140 | & 7*0.D0, .3D0, 1.D0, 1.D0, .9D0, .7D0, .4D0, .30D0, .2D0, | |
34141 | & 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.20D0, 4.55D0, | |
34142 | & 4.85D0, 4.9D0, | |
34143 | & 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0, 1.6D0, | |
34144 | & 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0, 3.5D0, | |
34145 | & 2.85D0, 2.35D0, 2.01D0, 1.8D0, | |
34146 | & 12*0.D0, .1D0, .8D0, 2.05D0, 3.31D0, 3.5D0, | |
34147 | & 12*0.D0, .034D0, .20D0, .75D0, 1.04D0, 1.24D0 / | |
34148 | **** ako - p - data * | |
34149 | DATA SPKP16/ 0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0, | |
34150 | & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0, 0.D0, | |
34151 | & 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0, 1.9D0, .9D0, .5D0, | |
34152 | & .3D0, .24D0, .2D0, .18D0, .1D0, .09D0, 0.D0, 1.8D0, 2.D0, 1.1D0, | |
34153 | & .9D0, .5D0, .5D0, .4D0, .4D0, .2D0, .1D0, .06D0, .05D0, .04D0, | |
34154 | & .03D0, .02D0, .02D0, 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0, | |
34155 | & .7D0, .65D0, .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0, | |
34156 | & .03D0, 0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0, | |
34157 | & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0, | |
34158 | & 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0, | |
34159 | & 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, | |
34160 | & 1.01D0, .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0, | |
34161 | & 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, | |
34162 | & .5D0, .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, | |
34163 | & .45D0, .39D0, .22D0, .07D0, 7*0.D0, 1.71D0, 4.26D0, 5.6D0,5.57D0, | |
34164 | & 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0, | |
34165 | & .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0, | |
34166 | & .3D0, .7D0, 1.D0, 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0, | |
34167 | & 1.72D0, 2.69D0, 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 5*0.D0, | |
34168 | & 9.2D0, 4.7D0, 1.9D0, 9*0.D0, .0D0,2.5D0,15.D0, | |
34169 | & 21.5D0, 15.3D0, 3.D0, 1.5D0, 10*0.D0 / | |
34170 | DATA NURELN/9, 12, 5*0, 10, 14, 3*0, 1, 3, 5, 7, 6*0, 2, 6, 16, | |
34171 | & 5*0, 10, 13, 5*0, 11, 12, 3*0, 2, 4, 6, 8, 6*0, 3, 15, 7, 5*0 / | |
34172 | *= end*block.blkdt3 * | |
34173 | END | |
34174 | *$ CREATE DT_QEL_POL.FOR | |
34175 | *COPY DT_QEL_POL | |
34176 | * | |
34177 | *===qel_pol============================================================* | |
34178 | * | |
34179 | SUBROUTINE DT_QEL_POL(ENU,LTYP,P21,P22,P23,P24,P25) | |
34180 | ||
34181 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
34182 | SAVE | |
34183 | ||
34184 | CALL DT_MASS_INI | |
34185 | CALL DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25) | |
34186 | ||
34187 | RETURN | |
34188 | END | |
34189 | ||
34190 | *$ CREATE DT_GEN_QEL.FOR | |
34191 | *COPY DT_GEN_QEL | |
34192 | C================================================================== | |
34193 | C Generation of a Quasi-Elastic neutrino scattering | |
34194 | C================================================================== | |
34195 | * | |
34196 | *===gen_qel============================================================* | |
34197 | * | |
34198 | SUBROUTINE DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25) | |
34199 | ||
34200 | C...Generate a quasi-elastic neutrino/antineutrino | |
34201 | C. Interaction on a nuclear target | |
34202 | C. INPUT : LTYP = neutrino type (1,...,6) | |
34203 | C. ENU (GeV) = neutrino energy | |
34204 | C---------------------------------------------------- | |
34205 | ||
34206 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
34207 | SAVE | |
34208 | ||
34209 | PARAMETER ( LINP = 10 , | |
34210 | & LOUT = 6 , | |
34211 | & LDAT = 9 ) | |
34212 | PARAMETER (MAXLND=4000) | |
34213 | COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5) | |
34214 | ||
34215 | * nuclear potential | |
34216 | LOGICAL LFERMI | |
34217 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, | |
34218 | & EBINDP(2),EBINDN(2),EPOT(2,210), | |
34219 | & ETACOU(2),ICOUL,LFERMI | |
34220 | ||
34221 | * steering flags for qel neutrino scattering modules | |
34222 | COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC | |
34223 | **sr - removed (not needed) | |
34224 | C COMMON /CBAD/ LBAD, NBAD | |
34225 | C COMMON /CNUC/ XMN,XMN2,PFERMI,EFERMI,EBIND,EB2,C0 | |
34226 | ** | |
34227 | ||
34228 | DIMENSION PI(3),PO(3) | |
34229 | CJR+ | |
34230 | DATA ININU/0/ | |
34231 | CJR- | |
34232 | C REAL*8 DBETA(3) | |
34233 | C REAL*8 MN(2), ML0(6), ML, ML2, MI, MI2, MF, MF2 | |
34234 | DIMENSION DBETA(3),DBETB(3),AMN(2),AML0(6) | |
34235 | DATA AMN /0.93827231D0, 0.93956563D0/ | |
34236 | DATA AML0 /2*0.51100D-03,2*0.105659D0, 2*1.777D0/ | |
34237 | DATA INIPRI/0/ | |
34238 | ||
34239 | C DATA PFERMI/0.22D0/ | |
34240 | CGB+...Binding Energy | |
34241 | DATA EBIND/0.008D0/ | |
34242 | CGB-... | |
34243 | ||
34244 | ININU=ININU+1 | |
34245 | IF(ININU.EQ.1)NDSIG=0 | |
34246 | LBAD = 0 | |
34247 | enu0=enu | |
34248 | c write(*,*) enu0 | |
34249 | C...Lepton mass | |
34250 | AML = AML0(LTYP) ! massa leptoni | |
34251 | AML2 = AML**2 ! massa leptoni **2 | |
34252 | C...Particle labels (LUND) | |
34253 | N = 5 | |
34254 | K(1,1) = 21 | |
34255 | K(2,1) = 21 | |
34256 | K(3,1) = 21 | |
34257 | K(3,3) = 1 | |
34258 | K(4,1) = 1 | |
34259 | K(4,3) = 1 | |
34260 | K(5,1) = 1 | |
34261 | K(5,3) = 2 | |
34262 | K0 = (LTYP-1)/2 ! 2 | |
34263 | K1 = LTYP/2 ! 2 | |
34264 | KA = 12 + 2*K0 ! 16 | |
34265 | IS = -1 + 2*LTYP - 4*K1 ! -1 +10 -8 = 1 | |
34266 | K(1,2) = IS*KA | |
34267 | K(4,2) = IS*(KA-1) | |
34268 | K(3,2) = IS*24 | |
34269 | LNU = 2 - LTYP + 2*K1 ! 2 - 5 + 2 = - 1 | |
34270 | IF (LNU .EQ. 2) THEN | |
34271 | K(2,2) = 2212 | |
34272 | K(5,2) = 2112 | |
34273 | AMI = AMN(1) | |
34274 | AMF = AMN(2) | |
34275 | CJR+ | |
34276 | PFERMI=PFERMN(2) | |
34277 | CJR- | |
34278 | ELSE | |
34279 | K(2,2) = 2112 | |
34280 | K(5,2) = 2212 | |
34281 | AMI = AMN(2) | |
34282 | AMF = AMN(1) | |
34283 | CJR+ | |
34284 | PFERMI=PFERMP(2) | |
34285 | CJR- | |
34286 | ENDIF | |
34287 | AMI2 = AMI**2 | |
34288 | AMF2 = AMF**2 | |
34289 | ||
34290 | DO IGB=1,5 | |
34291 | P(3,IGB) = 0. | |
34292 | P(4,IGB) = 0. | |
34293 | P(5,IGB) = 0. | |
34294 | END DO | |
34295 | ||
34296 | NTRY = 0 | |
34297 | CGB+... | |
34298 | EFMAX = SQRT(PFERMI**2 + AMI2) -AMI ! max. Fermi Energy | |
34299 | ENWELL = EFMAX + EBIND ! depth of nuclear potential well | |
34300 | CGB-... | |
34301 | ||
34302 | 100 CONTINUE | |
34303 | ||
34304 | C...4-momentum initial lepton | |
34305 | P(1,5) = 0. ! massa | |
34306 | P(1,4) = ENU0 ! energia | |
34307 | P(1,1) = 0. ! px | |
34308 | P(1,2) = 0. ! py | |
34309 | P(1,3) = ENU0 ! pz | |
34310 | ||
34311 | C PF = PFERMI*PYR(0)**(1./3.) | |
34312 | c write(23,*) PYR(0) | |
34313 | c write(*,*) 'Pfermi=',PF | |
34314 | c PF = 0. | |
34315 | NTRY=NTRY+1 | |
34316 | C IF(ntry.GT.2) WRITE(*,*) ntry,enu0,k2 | |
34317 | IF (NTRY .GT. 500) THEN | |
34318 | LBAD = 1 | |
34319 | WRITE (LOUT,1001) NBAD, ENU | |
34320 | RETURN | |
34321 | ENDIF | |
34322 | C CT = -1. + 2.*PYR(0) | |
34323 | c CT = -1. | |
34324 | C ST = SQRT(1.-CT*CT) | |
34325 | C F = 2.*3.1415926*PYR(0) | |
34326 | c F = 0. | |
34327 | ||
34328 | C P(2,4) = SQRT(PF*PF + MI2) - EBIND ! energia | |
34329 | C P(2,1) = PF*ST*COS(F) ! px | |
34330 | C P(2,2) = PF*ST*SIN(F) ! py | |
34331 | C P(2,3) = PF*CT ! pz | |
34332 | C P(2,5) = SQRT(P(2,4)**2-PF*PF) ! massa | |
34333 | P(2,1) = P21 | |
34334 | P(2,2) = P22 | |
34335 | P(2,3) = P23 | |
34336 | P(2,4) = P24 | |
34337 | P(2,5) = P25 | |
34338 | beta1=-p(2,1)/p(2,4) | |
34339 | beta2=-p(2,2)/p(2,4) | |
34340 | beta3=-p(2,3)/p(2,4) | |
34341 | N=2 | |
34342 | C WRITE(6,*)' before transforming into target rest frame' | |
34343 | ||
34344 | CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3) | |
34345 | ||
34346 | C print*,' nucl. rest fram ( fermi incl.) prima della rotazione' | |
34347 | N=5 | |
34348 | ||
34349 | phi11=atan(p(1,2)/p(1,3)) | |
34350 | pi(1)=p(1,1) | |
34351 | pi(2)=p(1,2) | |
34352 | pi(3)=p(1,3) | |
34353 | ||
34354 | CALL DT_TESTROT(PI,Po,PHI11,1) | |
34355 | DO ll=1,3 | |
34356 | IF(abs(po(ll)).LT.1.D-07) po(ll)=0. | |
34357 | END DO | |
34358 | c WRITE(*,*) po | |
34359 | p(1,1)=po(1) | |
34360 | p(1,2)=po(2) | |
34361 | p(1,3)=po(3) | |
34362 | phi12=atan(p(1,1)/p(1,3)) | |
34363 | ||
34364 | pi(1)=p(1,1) | |
34365 | pi(2)=p(1,2) | |
34366 | pi(3)=p(1,3) | |
34367 | CALL DT_TESTROT(Pi,Po,PHI12,2) | |
34368 | DO ll=1,3 | |
34369 | IF(abs(po(ll)).LT.1.D-07) po(ll)=0. | |
34370 | END DO | |
34371 | c WRITE(*,*) po | |
34372 | p(1,1)=po(1) | |
34373 | p(1,2)=po(2) | |
34374 | p(1,3)=po(3) | |
34375 | ||
34376 | enu=p(1,4) | |
34377 | ||
34378 | C...Kinematical limits in Q**2 | |
34379 | c S = P(2,5)**2 + 2.*ENU*(P(2,4)-P(2,3)) ! ???? | |
34380 | S = P(2,5)**2 + 2.*ENU*P(2,5) | |
34381 | SQS = SQRT(S) ! E centro massa | |
34382 | IF (SQS .LT. (AML + AMF + 3.E-03)) GOTO 100 | |
34383 | ELF = (S-AMF2+AML2)/(2.*SQS) ! energia leptone finale p | |
34384 | PSTAR = (S-P(2,5)**2)/(2.*SQS) ! p* neutrino nel c.m. | |
34385 | PLF = SQRT(ELF**2-AML2) ! 3-momento leptone finale | |
34386 | Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF) ! + o - | |
34387 | Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF) ! according con cos(theta) | |
34388 | IF (Q2MIN .LT. 0.) Q2MIN = 0. ! ??? non fisico | |
34389 | ||
34390 | C...Generate Q**2 | |
34391 | DSIGMAX = DT_DSQEL_Q2 (LTYP,ENU, Q2MIN) | |
34392 | 200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0) | |
34393 | DSIG = DT_DSQEL_Q2 (LTYP,ENU, Q2) | |
34394 | IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200 | |
34395 | CALL DT_QGAUS(Q2MIN,Q2MAX,DSIGEV,ENU,LTYP) | |
34396 | NDSIG=NDSIG+1 | |
34397 | C WRITE(6,*)' Q2,Q2min,Q2MAX,DSIGEV', | |
34398 | C &Q2,Q2min,Q2MAX,DSIGEV | |
34399 | ||
34400 | C...c.m. frame. Neutrino along z axis | |
34401 | DETOT = (P(1,4)) + (P(2,4)) ! e totale | |
34402 | DBETA(1) = ((P(1,1)) + (P(2,1)))/DETOT ! px1+px2/etot = beta_x | |
34403 | DBETA(2) = ((P(1,2)) + (P(2,2)))/DETOT ! | |
34404 | DBETA(3) = ((P(1,3)) + (P(2,3)))/DETOT ! | |
34405 | c WRITE(*,*) | |
34406 | c WRITE(*,*) | |
34407 | C WRITE(*,*) 'Input values laboratory frame' | |
34408 | N=2 | |
34409 | ||
34410 | CALL PYROBO(0,0,0.0D0,0.0D0,-DBETA(1),-DBETA(2),-DBETA(3)) | |
34411 | ||
34412 | N=5 | |
34413 | c STHETA = ULANGL(P(1,3),P(1,1)) | |
34414 | c write(*,*) 'stheta' ,stheta | |
34415 | c stheta=0. | |
34416 | c CALL PYROBO (0,0,-STHETA,0.,0.D0,0.D0,0.D0) | |
34417 | c WRITE(*,*) | |
34418 | c WRITE(*,*) | |
34419 | C WRITE(*,*) 'Output values cm frame' | |
34420 | C...Kinematic in c.m. frame | |
34421 | CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF) ! cos(theta) cm | |
34422 | STSTAR = SQRT(1.-CTSTAR**2) | |
34423 | PHI = 6.28319*PYR(0) ! random phi tra 0 e 2*pi | |
34424 | P(4,5) = AML ! massa leptone | |
34425 | P(4,4) = ELF ! e leptone | |
34426 | P(4,3) = PLF*CTSTAR ! px | |
34427 | P(4,1) = PLF*STSTAR*COS(PHI) ! py | |
34428 | P(4,2) = PLF*STSTAR*SIN(PHI) ! pz | |
34429 | ||
34430 | P(5,5) = AMF ! barione | |
34431 | P(5,4) = (S+AMF2-AML2)/(2.*SQS)! e barione | |
34432 | P(5,3) = -P(4,3) ! px | |
34433 | P(5,1) = -P(4,1) ! py | |
34434 | P(5,2) = -P(4,2) ! pz | |
34435 | ||
34436 | P(3,5) = -Q2 | |
34437 | P(3,1) = P(1,1)-P(4,1) | |
34438 | P(3,2) = P(1,2)-P(4,2) | |
34439 | P(3,3) = P(1,3)-P(4,3) | |
34440 | P(3,4) = P(1,4)-P(4,4) | |
34441 | ||
34442 | C...Transform back to laboratory frame | |
34443 | C WRITE(*,*) 'before going back to nucl rest frame' | |
34444 | c CALL PYROBO (0,0,STHETA,0.,0.D0,0.D0,0.D0) | |
34445 | N=5 | |
34446 | ||
34447 | CALL PYROBO(0,0,0.0D0,0.0D0,DBETA(1),DBETA(2),DBETA(3)) | |
34448 | ||
34449 | C WRITE(*,*) 'Now back in nucl rest frame' | |
34450 | IF(LTYP.GE.3) CALL DT_PREPOLA(Q2,LTYP,ENU) | |
34451 | ||
34452 | c******************************************** | |
34453 | ||
34454 | DO kw=1,5 | |
34455 | pi(1)=p(kw,1) | |
34456 | pi(2)=p(kw,2) | |
34457 | pi(3)=p(kw,3) | |
34458 | CALL DT_TESTROT(Pi,Po,PHI12,3) | |
34459 | DO ll=1,3 | |
34460 | IF(abs(po(ll)).LT.1.D-07) po(ll)=0. | |
34461 | END DO | |
34462 | p(kw,1)=po(1) | |
34463 | p(kw,2)=po(2) | |
34464 | p(kw,3)=po(3) | |
34465 | END DO | |
34466 | c******************************************** | |
34467 | ||
34468 | DO kw=1,5 | |
34469 | pi(1)=p(kw,1) | |
34470 | pi(2)=p(kw,2) | |
34471 | pi(3)=p(kw,3) | |
34472 | CALL DT_TESTROT(Pi,Po,PHI11,4) | |
34473 | DO ll=1,3 | |
34474 | IF(abs(po(ll)).LT.1.D-07) po(ll)=0. | |
34475 | END DO | |
34476 | p(kw,1)=po(1) | |
34477 | p(kw,2)=po(2) | |
34478 | p(kw,3)=po(3) | |
34479 | END DO | |
34480 | ||
34481 | c******************************************** | |
34482 | ||
34483 | C WRITE(*,*) 'Now back in lab frame' | |
34484 | ||
34485 | CALL PYROBO(1,5,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3) | |
34486 | ||
34487 | CGB+... | |
34488 | C...test (on final momentum of nucleon) if Fermi-blocking | |
34489 | C...is operating | |
34490 | ENUCL = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2 + P(5,5)**2) | |
34491 | & - P(5,5) | |
34492 | IF (ENUCL.LT. EFMAX) THEN | |
34493 | IF(INIPRI.LT.10)THEN | |
34494 | INIPRI=INIPRI+1 | |
34495 | C WRITE(6,*)' qel: Pauli ENUCL.LT.EFMAX ', ENUCL,EFMAX | |
34496 | C...the interaction is not possible due to Pauli-Blocking and | |
34497 | C...it must be resampled | |
34498 | ENDIF | |
34499 | GOTO 100 | |
34500 | ELSE IF (ENUCL.LT.ENWELL.and.ENUCL.GE.EFMAX) THEN | |
34501 | IF(INIPRI.LT.10)THEN | |
34502 | INIPRI=INIPRI+1 | |
34503 | C WRITE(6,*)' qel: inside ENUCL.LT.ENWELL ', ENUCL,ENWELL | |
34504 | ENDIF | |
34505 | C Reject (J:R) here all these events | |
34506 | C are otherwise rejected in dpmjet | |
34507 | GOTO 100 | |
34508 | C...the interaction is possible, but the nucleon remains inside | |
34509 | C...the nucleus. The nucleus is therefore left excited. | |
34510 | C...We treat this case as a nucleon with 0 kinetic energy. | |
34511 | C P(5,5) = AMF | |
34512 | C P(5,4) = AMF | |
34513 | C P(5,1) = 0. | |
34514 | C P(5,2) = 0. | |
34515 | C P(5,3) = 0. | |
34516 | ELSE IF (ENUCL.GE.ENWELL) THEN | |
34517 | C WRITE(6,*)' qel ENUCL.GE.ENWELL ',ENUCL,ENWELL | |
34518 | C...the interaction is possible, the nucleon can exit the nucleus | |
34519 | C...but the nuclear well depth must be subtracted. The nucleus could be | |
34520 | C...left in an excited state. | |
34521 | Pstart = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2) | |
34522 | C P(5,4) = ENUCL-ENWELL + AMF | |
34523 | Pnucl = SQRT(P(5,4)**2-AMF**2) | |
34524 | C...The 3-momentum is scaled assuming that the direction remains | |
34525 | C...unaffected | |
34526 | P(5,1) = P(5,1) * Pnucl/Pstart | |
34527 | P(5,2) = P(5,2) * Pnucl/Pstart | |
34528 | P(5,3) = P(5,3) * Pnucl/Pstart | |
34529 | C WRITE(6,*)' qel new P(5,4) ',P(5,4) | |
34530 | ENDIF | |
34531 | CGB-... | |
34532 | DSIGSU=DSIGSU+DSIGEV | |
34533 | ||
34534 | GA=P(4,4)/P(4,5) | |
34535 | BGX=P(4,1)/P(4,5) | |
34536 | BGY=P(4,2)/P(4,5) | |
34537 | BGZ=P(4,3)/P(4,5) | |
34538 | * | |
34539 | DBETB(1)=BGX/GA | |
34540 | DBETB(2)=BGY/GA | |
34541 | DBETB(3)=BGZ/GA | |
34542 | IF(NEUDEC.EQ.1.OR.NEUDEC.EQ.2) THEN | |
34543 | ||
34544 | CALL PYROBO(6,8,0.0D0,0.0D0,DBETB(1),DBETB(2),DBETB(3)) | |
34545 | ||
34546 | ENDIF | |
34547 | c | |
34548 | C PRINT*,' FINE EVENTO ' | |
34549 | enu=enu0 | |
34550 | RETURN | |
34551 | ||
34552 | 1001 FORMAT(2X, 'DT_GEN_QEL : event rejected ', I5, G10.3) | |
34553 | END | |
34554 | ||
34555 | *$ CREATE DT_MASS_INI.FOR | |
34556 | *COPY DT_MASS_INI | |
34557 | C==================================================================== | |
34558 | C. Masses | |
34559 | C==================================================================== | |
34560 | * | |
34561 | *===mass_ini===========================================================* | |
34562 | * | |
34563 | SUBROUTINE DT_MASS_INI | |
34564 | C...Initialize the kinematics for the quasi-elastic cross section | |
34565 | ||
34566 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
34567 | SAVE | |
34568 | ||
34569 | * particle masses used in qel neutrino scattering modules | |
34570 | COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6), | |
34571 | & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN, | |
34572 | & EMPROTSQ,EMNEUTSQ,EMNSQ | |
34573 | ||
34574 | EML(1) = 0.51100D-03 ! e- | |
34575 | EML(2) = EML(1) ! e+ | |
34576 | EML(3) = 0.105659D0 ! mu- | |
34577 | EML(4) = EML(3) ! mu+ | |
34578 | EML(5) = 1.7777D0 ! tau- | |
34579 | EML(6) = EML(5) ! tau+ | |
34580 | EMPROT = 0.93827231D0 ! p | |
34581 | EMNEUT = 0.93956563D0 ! n | |
34582 | EMPROTSQ = EMPROT**2 | |
34583 | EMNEUTSQ = EMNEUT**2 | |
34584 | EMN = (EMPROT + EMNEUT)/2. | |
34585 | EMNSQ = EMN**2 | |
34586 | DO J=1,3 | |
34587 | J0 = 2*(J-1) | |
34588 | EMN1(J0+1) = EMNEUT | |
34589 | EMN1(J0+2) = EMPROT | |
34590 | EMN2(J0+1) = EMPROT | |
34591 | EMN2(J0+2) = EMNEUT | |
34592 | ENDDO | |
34593 | DO J=1,6 | |
34594 | EMLSQ(J) = EML(J)**2 | |
34595 | ETQE(J) = ((EMN2(J)+ EML(J))**2-EMN1(J)**2)/(2.*EMN1(J)) | |
34596 | ENDDO | |
34597 | RETURN | |
34598 | END | |
34599 | ||
34600 | *$ CREATE DT_DSQEL_Q2.FOR | |
34601 | *COPY DT_DSQEL_Q2 | |
34602 | * | |
34603 | *===dsqel_q2===========================================================* | |
34604 | * | |
34605 | DOUBLE PRECISION FUNCTION DT_DSQEL_Q2 (JTYP,ENU, Q2) | |
34606 | ||
34607 | C...differential cross section for Quasi-Elastic scattering | |
34608 | C. nu + N -> l + N' | |
34609 | C. From Llewellin Smith Phys.Rep. 3C, 261, (1971). | |
34610 | C. | |
34611 | C. INPUT : JTYP = 1,...,6 nu_e, ...., nubar_tau | |
34612 | C. ENU (GeV) = Neutrino energy | |
34613 | C. Q2 (GeV**2) = (Transfer momentum)**2 | |
34614 | C. | |
34615 | C. OUTPUT : DSQEL_Q2 = differential cross section : | |
34616 | C. dsigma/dq**2 (10**-38 cm+2/GeV**2) | |
34617 | C------------------------------------------------------------------ | |
34618 | ||
34619 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
34620 | SAVE | |
34621 | ||
34622 | * particle masses used in qel neutrino scattering modules | |
34623 | COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6), | |
34624 | & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN, | |
34625 | & EMPROTSQ,EMNEUTSQ,EMNSQ | |
34626 | **sr - removed (not needed) | |
34627 | C COMMON /CAXIAL/ FA0, AXIAL2 | |
34628 | ** | |
34629 | ||
34630 | DIMENSION SS(6) | |
34631 | DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2 | |
34632 | DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/ | |
34633 | DATA AXIAL2 /1.03D0/ ! to be checked | |
34634 | ||
34635 | FA0=-1.253D0 | |
34636 | CSI = 3.71D0 ! ??? | |
34637 | GVE = 1.D0/ (1.D0 + Q2/0.84D0**2)**2 ! G_e(q**2) | |
34638 | GVM = (1.D0+CSI)*GVE ! G_m (q**2) | |
34639 | X = Q2/(EMN*EMN) ! emn=massa barione | |
34640 | XA = X/4.D0 | |
34641 | FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM) | |
34642 | FV2 = 1.D0/(1.D0+XA)*(GVM-GVE) | |
34643 | FA = FA0/(1.D0 + Q2/AXIAL2)**2 | |
34644 | FFA = FA*FA | |
34645 | FFV1 = FV1*FV1 | |
34646 | FFV2 = FV2*FV2 | |
34647 | RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp) | |
34648 | A1 = (4.D0+X)*FFA - (4.D0-X)*FFV1 + X*FFV2*(1.D0-XA)+4*X*FV1*FV2 | |
34649 | A2 = -RM * ((FV1 + FV2)**2 + FFA) | |
34650 | AA = (XA+0.25D0*RM)*(A1 + A2) | |
34651 | BB = -X*FA*(FV1 + FV2) | |
34652 | CC = 0.25D0*(FFA + FFV1 + XA*FFV2) | |
34653 | SU = (4.D0*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN) | |
34654 | DT_DSQEL_Q2 = C0*(AA + SS(JTYP)*BB*SU + CC*SU*SU) / (ENU*ENU) ! | |
34655 | IF(DT_DSQEL_Q2 .LT. 0.D0) DT_DSQEL_Q2 = 0.D0 | |
34656 | ||
34657 | RETURN | |
34658 | END | |
34659 | ||
34660 | *$ CREATE DT_PREPOLA.FOR | |
34661 | *COPY DT_PREPOLA | |
34662 | * | |
34663 | *===prepola============================================================* | |
34664 | * | |
34665 | SUBROUTINE DT_PREPOLA(Q2,JTYP,ENU) | |
34666 | ||
34667 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
34668 | SAVE | |
34669 | c | |
34670 | c By G. Battistoni and E. Scapparone (sept. 1997) | |
34671 | c According to: | |
34672 | c Albright & Jarlskog, Nucl Phys B84 (1975) 467 | |
34673 | c | |
34674 | c | |
34675 | PARAMETER (MAXLND=4000) | |
34676 | COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5) | |
34677 | ||
34678 | COMMON /QNPOL/ POLARX(4),PMODUL | |
34679 | ||
34680 | * particle masses used in qel neutrino scattering modules | |
34681 | COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6), | |
34682 | & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN, | |
34683 | & EMPROTSQ,EMNEUTSQ,EMNSQ | |
34684 | ||
34685 | * steering flags for qel neutrino scattering modules | |
34686 | COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC | |
34687 | **sr - removed (not needed) | |
34688 | C COMMON /CAXIAL/ FA0, AXIAL2 | |
34689 | C COMMON /TAUTAU/Q(4,5),ETL,PXL,PYL,PZL, | |
34690 | C & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN | |
34691 | ** | |
34692 | REAL*8 POL(4,4),BB2(3) | |
34693 | DIMENSION SS(6) | |
34694 | C DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2 | |
34695 | DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/ | |
34696 | **sr uncommented since common block CAXIAL is now commented | |
34697 | DATA AXIAL2 /1.03D0/ ! to be checked | |
34698 | ** | |
34699 | ||
34700 | RML=P(4,5) | |
34701 | RMM=0.93960D+00 | |
34702 | FM2 = RMM**2 | |
34703 | MPI = 0.135D+00 | |
34704 | OLDQ2=Q2 | |
34705 | FA0=-1.253D+00 | |
34706 | CSI = 3.71D+00 ! | |
34707 | GVE = 1.D0/ (1.D0 + Q2/(0.84D+00)**2)**2 ! G_e(q**2) | |
34708 | GVM = (1.D0+CSI)*GVE ! G_m (q**2) | |
34709 | X = Q2/(EMN*EMN) ! emn=massa barione | |
34710 | XA = X/4.D0 | |
34711 | FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM) | |
34712 | FV2 = 1.D0/(1.D0+XA)*(GVM-GVE) | |
34713 | FA = FA0/(1.D0 + Q2/AXIAL2**2)**2 | |
34714 | FFA = FA*FA | |
34715 | FFV1 = FV1*FV1 | |
34716 | FFV2 = FV2*FV2 | |
34717 | FP=2.D0*FA*RMM/(MPI**2 + Q2) | |
34718 | RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp) | |
34719 | A1 = (4.D0+X)*FFA-(4.D0-X)*FFV1+X*FFV2*(1.D0-XA)+4.D0*X*FV1*FV2 | |
34720 | A2 = -RM * ((FV1 + FV2)**2 + FFA) | |
34721 | AA = (XA+0.25D+00*RM)*(A1 + A2) | |
34722 | BB = -X*FA*(FV1 + FV2) | |
34723 | CC = 0.25D+00*(FFA + FFV1 + XA*FFV2) | |
34724 | SU = (4.D+00*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN) | |
34725 | ||
34726 | OMEGA1=FFA+XA*(FFA+(FV1+FV2)**2 ) ! articolo di ll...-smith | |
34727 | OMEGA2=4.D+00*CC | |
34728 | OMEGA3=2.D+00*FA*(FV1+FV2) | |
34729 | OMEGA4P=(-(FV1+FV2)**2-(FA+2*FP)**2+(4.0D+00+ | |
34730 | 1 (Q2/FM2))*FP**2) | |
34731 | OMEGA5=OMEGA2 | |
34732 | OMEGA4=(OMEGA4P-OMEGA2+2*OMEGA5)/4.D+00 | |
34733 | WW1=2.D+00*OMEGA1*EMN**2 | |
34734 | WW2=2.D+00*OMEGA2*EMN**2 | |
34735 | WW3=2.D+00*OMEGA3*EMN**2 | |
34736 | WW4=2.D+00*OMEGA4*EMN**2 | |
34737 | WW5=2.D+00*OMEGA5*EMN**2 | |
34738 | ||
34739 | DO I=1,3 | |
34740 | BB2(I)=-P(4,I)/P(4,4) | |
34741 | END DO | |
34742 | c WRITE(*,*) | |
34743 | c WRITE(*,*) | |
34744 | c WRITE(*,*) 'Prepola: ready to transform to lepton rest frame' | |
34745 | N=5 | |
34746 | ||
34747 | CALL PYROBO(0,0,0.0D0,0.0D0,BB2(1),BB2(2),BB2(3)) | |
34748 | ||
34749 | * NOW PARTICLES ARE IN THE SCATTERED LEPTON REST FRAME | |
34750 | c WRITE(*,*) | |
34751 | c WRITE(*,*) | |
34752 | c WRITE(*,*) 'Prepola: now in lepton rest frame' | |
34753 | EE=ENU | |
34754 | QM2=Q2+RML**2 | |
34755 | U=Q2/(2.*RMM) | |
34756 | FRAC=QM2*WW1 + (2.D+00*EE*(EE-U) - 0.5D+00*QM2)*WW2 - SS(JTYP)* | |
34757 | + (0.5D+00/(RMM**2))*(2.D+00*RMM*EE*Q2 - U*QM2)*WW3 + | |
34758 | + ((RML**2)/(2.D+00*FM2))*(QM2*WW4-2.D+00*RMM*EE*WW5) !<=FM2 inv di RMM!! | |
34759 | ||
34760 | FACTK=2.D+00*WW1 -WW2 -SS(JTYP)*(EE/RMM)*WW3 +((EE-U)/RMM)*WW5 | |
34761 | + - ((RML**2)/FM2)*WW4 !<=FM2 inv di RMM!! | |
34762 | ||
34763 | FACTP=2.D+00*EE/RMM*WW2 - (QM2/(2.D+00*RMM**2))*(SS(JTYP)*WW3+WW5) | |
34764 | ||
34765 | DO I=1,3 | |
34766 | POL(4,I)=RML*SS(JTYP)*(FACTK*P(1,I)+FACTP*P(2,I))/FRAC | |
34767 | POLARX(I)=POL(4,I) | |
34768 | END DO | |
34769 | ||
34770 | PMODUL=0.D0 | |
34771 | DO I=1,3 | |
34772 | PMODUL=PMODUL+POL(4,I)**2 | |
34773 | END DO | |
34774 | ||
34775 | IF(JTYP.GT.4.AND.NEUDEC.GT.0) THEN | |
34776 | IF(NEUDEC.EQ.1) THEN | |
34777 | CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-2),POLARX(3), | |
34778 | + ETL,PXL,PYL,PZL, | |
34779 | + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN) | |
34780 | c | |
34781 | c Tau has decayed in muon | |
34782 | c | |
34783 | ENDIF | |
34784 | IF(NEUDEC.EQ.2) THEN | |
34785 | CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-4),POLARX(3), | |
34786 | + ETL,PXL,PYL,PZL, | |
34787 | + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN) | |
34788 | c | |
34789 | c Tau has decayed in electron | |
34790 | c | |
34791 | ENDIF | |
34792 | K(4,1)=15 | |
34793 | K(4,4) = 6 | |
34794 | K(4,5) = 8 | |
34795 | N=N+3 | |
34796 | c | |
34797 | c fill common for muon(electron) | |
34798 | c | |
34799 | P(6,1)=PXL | |
34800 | P(6,2)=PYL | |
34801 | P(6,3)=PZL | |
34802 | P(6,4)=ETL | |
34803 | K(6,1)=1 | |
34804 | IF(JTYP.EQ.5) THEN | |
34805 | IF(NEUDEC.EQ.1) THEN | |
34806 | P(6,5)=EML(JTYP-2) | |
34807 | K(6,2)=13 | |
34808 | ELSEIF(NEUDEC.EQ.2) THEN | |
34809 | P(6,5)=EML(JTYP-4) | |
34810 | K(6,2)=11 | |
34811 | ENDIF | |
34812 | ELSEIF(JTYP.EQ.6) THEN | |
34813 | IF(NEUDEC.EQ.1) THEN | |
34814 | K(6,2)=-13 | |
34815 | ELSEIF(NEUDEC.EQ.2) THEN | |
34816 | K(6,2)=-11 | |
34817 | ENDIF | |
34818 | END IF | |
34819 | K(6,3)=4 | |
34820 | K(6,4)=0 | |
34821 | K(6,5)=0 | |
34822 | c | |
34823 | c fill common for tau_(anti)neutrino | |
34824 | c | |
34825 | P(7,1)=PXB | |
34826 | P(7,2)=PYB | |
34827 | P(7,3)=PZB | |
34828 | P(7,4)=ETB | |
34829 | P(7,5)=0. | |
34830 | K(7,1)=1 | |
34831 | IF(JTYP.EQ.5) THEN | |
34832 | K(7,2)=16 | |
34833 | ELSEIF(JTYP.EQ.6) THEN | |
34834 | K(7,2)=-16 | |
34835 | END IF | |
34836 | K(7,3)=4 | |
34837 | K(7,4)=0 | |
34838 | K(7,5)=0 | |
34839 | c | |
34840 | c Fill common for muon(electron)_(anti)neutrino | |
34841 | c | |
34842 | P(8,1)=PXN | |
34843 | P(8,2)=PYN | |
34844 | P(8,3)=PZN | |
34845 | P(8,4)=ETN | |
34846 | P(8,5)=0. | |
34847 | K(8,1)=1 | |
34848 | IF(JTYP.EQ.5) THEN | |
34849 | IF(NEUDEC.EQ.1) THEN | |
34850 | K(8,2)=-14 | |
34851 | ELSEIF(NEUDEC.EQ.2) THEN | |
34852 | K(8,2)=-12 | |
34853 | ENDIF | |
34854 | ELSEIF(JTYP.EQ.6) THEN | |
34855 | IF(NEUDEC.EQ.1) THEN | |
34856 | K(8,2)=14 | |
34857 | ELSEIF(NEUDEC.EQ.2) THEN | |
34858 | K(8,2)=12 | |
34859 | ENDIF | |
34860 | END IF | |
34861 | K(8,3)=4 | |
34862 | K(8,4)=0 | |
34863 | K(8,5)=0 | |
34864 | ENDIF | |
34865 | c WRITE(*,*) | |
34866 | c WRITE(*,*) | |
34867 | ||
34868 | c IF(PMODUL.GE.1.D+00) THEN | |
34869 | c WRITE(*,*) 'Pol',(POLARX(I),I=1,3) | |
34870 | c write(*,*) pmodul | |
34871 | c DO I=1,3 | |
34872 | c POL(4,I)=POL(4,I)/PMODUL | |
34873 | c POLARX(I)=POL(4,I) | |
34874 | c END DO | |
34875 | c PMODUL=0. | |
34876 | c DO I=1,3 | |
34877 | c PMODUL=PMODUL+POL(4,I)**2 | |
34878 | c END DO | |
34879 | c WRITE(*,*) 'Pol',(POLARX(I),I=1,3) | |
34880 | c | |
34881 | c ENDIF | |
34882 | ||
34883 | c WRITE(*,*) 'PMODUL = ',PMODUL | |
34884 | ||
34885 | c WRITE(*,*) | |
34886 | c WRITE(*,*) | |
34887 | c WRITE(*,*) 'prepola: Now back to nucl rest frame' | |
34888 | ||
34889 | CALL PYROBO(1,5,0.0D0,0.0D0,-BB2(1),-BB2(2),-BB2(3)) | |
34890 | ||
34891 | XDC = V(4,1)+V(4,5)*P(4,1)/P(4,5) | |
34892 | YDC = V(4,2)+V(4,5)*P(4,2)/P(4,5) | |
34893 | ZDC = V(4,3)+V(4,5)*P(4,3)/P(4,5) | |
34894 | DO NDC =6,8 | |
34895 | V(NDC,1) = XDC | |
34896 | V(NDC,2) = YDC | |
34897 | V(NDC,3) = ZDC | |
34898 | END DO | |
34899 | ||
34900 | RETURN | |
34901 | END | |
34902 | ||
34903 | *$ CREATE DT_TESTROT.FOR | |
34904 | *COPY DT_TESTROT | |
34905 | * | |
34906 | *===testrot============================================================* | |
34907 | * | |
34908 | SUBROUTINE DT_TESTROT(PI,PO,PHI,MODE) | |
34909 | ||
34910 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
34911 | SAVE | |
34912 | ||
34913 | DIMENSION ROT(3,3),PI(3),PO(3) | |
34914 | ||
34915 | IF (MODE.EQ.1) THEN | |
34916 | ROT(1,1) = 1.D0 | |
34917 | ROT(1,2) = 0.D0 | |
34918 | ROT(1,3) = 0.D0 | |
34919 | ROT(2,1) = 0.D0 | |
34920 | ROT(2,2) = COS(PHI) | |
34921 | ROT(2,3) = -SIN(PHI) | |
34922 | ROT(3,1) = 0.D0 | |
34923 | ROT(3,2) = SIN(PHI) | |
34924 | ROT(3,3) = COS(PHI) | |
34925 | ELSEIF (MODE.EQ.2) THEN | |
34926 | ROT(1,1) = 0.D0 | |
34927 | ROT(1,2) = 1.D0 | |
34928 | ROT(1,3) = 0.D0 | |
34929 | ROT(2,1) = COS(PHI) | |
34930 | ROT(2,2) = 0.D0 | |
34931 | ROT(2,3) = -SIN(PHI) | |
34932 | ROT(3,1) = SIN(PHI) | |
34933 | ROT(3,2) = 0.D0 | |
34934 | ROT(3,3) = COS(PHI) | |
34935 | ELSEIF (MODE.EQ.3) THEN | |
34936 | ROT(1,1) = 0.D0 | |
34937 | ROT(2,1) = 1.D0 | |
34938 | ROT(3,1) = 0.D0 | |
34939 | ROT(1,2) = COS(PHI) | |
34940 | ROT(2,2) = 0.D0 | |
34941 | ROT(3,2) = -SIN(PHI) | |
34942 | ROT(1,3) = SIN(PHI) | |
34943 | ROT(2,3) = 0.D0 | |
34944 | ROT(3,3) = COS(PHI) | |
34945 | ELSEIF (MODE.EQ.4) THEN | |
34946 | ROT(1,1) = 1.D0 | |
34947 | ROT(2,1) = 0.D0 | |
34948 | ROT(3,1) = 0.D0 | |
34949 | ROT(1,2) = 0.D0 | |
34950 | ROT(2,2) = COS(PHI) | |
34951 | ROT(3,2) = -SIN(PHI) | |
34952 | ROT(1,3) = 0.D0 | |
34953 | ROT(2,3) = SIN(PHI) | |
34954 | ROT(3,3) = COS(PHI) | |
34955 | ELSE | |
34956 | STOP ' TESTROT: mode not supported!' | |
34957 | ENDIF | |
34958 | DO 1 J=1,3 | |
34959 | PO(J) = ROT(J,1)*PI(1)+ROT(J,2)*PI(2)+ROT(J,3)*PI(3) | |
34960 | 1 CONTINUE | |
34961 | ||
34962 | RETURN | |
34963 | END | |
34964 | ||
34965 | *$ CREATE DT_LEPDCYP.FOR | |
34966 | *COPY DT_LEPDCYP | |
34967 | * | |
34968 | *===lepdcyp============================================================* | |
34969 | * | |
34970 | SUBROUTINE DT_LEPDCYP(AMA,AML,POL,ETL,PXL,PYL,PZL, | |
34971 | & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN) | |
34972 | C | |
34973 | C----------------------------------------------------------------- | |
34974 | C | |
34975 | C Author :- G. Battistoni 10-NOV-1995 | |
34976 | C | |
34977 | C================================================================= | |
34978 | C | |
34979 | C Purpose : performs decay of polarized lepton in | |
34980 | C its rest frame: a => b + l + anti-nu | |
34981 | C (Example: mu- => nu-mu + e- + anti-nu-e) | |
34982 | C Polarization is assumed along Z-axis | |
34983 | C WARNING: | |
34984 | C 1) b AND anti-nu ARE ASSUMED TO BE NEUTRINOS | |
34985 | C OF NEGLIGIBLE MASS | |
34986 | C 2) RADIATIVE CORRECTIONS ARE NOT CONSIDERED | |
34987 | C IN THIS VERSION | |
34988 | C | |
34989 | C Method : modifies phase space distribution obtained | |
34990 | C by routine EXPLOD using a rejection against the | |
34991 | C matrix element for unpolarized lepton decay | |
34992 | C | |
34993 | C Inputs : Mass of a : AMA | |
34994 | C Mass of l : AML | |
34995 | C Polar. of a: POL | |
34996 | C (Example: fully polar. mu- decay: AMA=AMMUON, AML=AMELCT, | |
34997 | C POL = -1) | |
34998 | C | |
34999 | C Outputs : kinematic variables in the rest frame of decaying lepton | |
35000 | C ETL,PXL,PYL,PZL 4-moment of l | |
35001 | C ETB,PXB,PYB,PZB 4-moment of b | |
35002 | C ETN,PXN,PYN,PZN 4-moment of anti-nu | |
35003 | C | |
35004 | C============================================================ | |
35005 | C + | |
35006 | C Declarations. | |
35007 | C - | |
35008 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
35009 | SAVE | |
35010 | ||
35011 | PARAMETER ( LINP = 10 , | |
35012 | & LOUT = 6 , | |
35013 | & LDAT = 9 ) | |
35014 | ||
35015 | PARAMETER ( KALGNM = 2 ) | |
35016 | PARAMETER ( ANGLGB = 5.0D-16 ) | |
35017 | PARAMETER ( ANGLSQ = 2.5D-31 ) | |
35018 | PARAMETER ( AXCSSV = 0.2D+16 ) | |
35019 | PARAMETER ( ANDRFL = 1.0D-38 ) | |
35020 | PARAMETER ( AVRFLW = 1.0D+38 ) | |
35021 | PARAMETER ( AINFNT = 1.0D+30 ) | |
35022 | PARAMETER ( AZRZRZ = 1.0D-30 ) | |
35023 | PARAMETER ( EINFNT = +69.07755278982137 D+00 ) | |
35024 | PARAMETER ( EZRZRZ = -69.07755278982137 D+00 ) | |
35025 | PARAMETER ( ONEMNS = 0.999999999999999 D+00 ) | |
35026 | PARAMETER ( ONEPLS = 1.000000000000001 D+00 ) | |
35027 | PARAMETER ( CSNNRM = 2.0D-15 ) | |
35028 | PARAMETER ( DMXTRN = 1.0D+08 ) | |
35029 | PARAMETER ( ZERZER = 0.D+00 ) | |
35030 | PARAMETER ( ONEONE = 1.D+00 ) | |
35031 | PARAMETER ( TWOTWO = 2.D+00 ) | |
35032 | PARAMETER ( THRTHR = 3.D+00 ) | |
35033 | PARAMETER ( FOUFOU = 4.D+00 ) | |
35034 | PARAMETER ( FIVFIV = 5.D+00 ) | |
35035 | PARAMETER ( SIXSIX = 6.D+00 ) | |
35036 | PARAMETER ( SEVSEV = 7.D+00 ) | |
35037 | PARAMETER ( EIGEIG = 8.D+00 ) | |
35038 | PARAMETER ( ANINEN = 9.D+00 ) | |
35039 | PARAMETER ( TENTEN = 10.D+00 ) | |
35040 | PARAMETER ( HLFHLF = 0.5D+00 ) | |
35041 | PARAMETER ( ONETHI = ONEONE / THRTHR ) | |
35042 | PARAMETER ( TWOTHI = TWOTWO / THRTHR ) | |
35043 | PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 ) | |
35044 | PARAMETER ( ENEPER = 2.7182818284590452354 D+00 ) | |
35045 | PARAMETER ( SQRENT = 1.6487212707001281468 D+00 ) | |
35046 | PARAMETER ( CLIGHT = 2.99792458 D+10 ) | |
35047 | PARAMETER ( AVOGAD = 6.0221367 D+23 ) | |
35048 | PARAMETER ( AMELGR = 9.1093897 D-28 ) | |
35049 | PARAMETER ( PLCKBR = 1.05457266 D-27 ) | |
35050 | PARAMETER ( ELCCGS = 4.8032068 D-10 ) | |
35051 | PARAMETER ( ELCMKS = 1.60217733 D-19 ) | |
35052 | PARAMETER ( AMUGRM = 1.6605402 D-24 ) | |
35053 | PARAMETER ( AMMUMU = 0.113428913 D+00 ) | |
35054 | PARAMETER ( ALPFSC = 7.2973530791728595 D-03 ) | |
35055 | PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 ) | |
35056 | PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 ) | |
35057 | PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 ) | |
35058 | PARAMETER ( PLABRC = 0.197327053 D+00 ) | |
35059 | PARAMETER ( AMELCT = 0.51099906 D-03 ) | |
35060 | PARAMETER ( AMUGEV = 0.93149432 D+00 ) | |
35061 | PARAMETER ( AMMUON = 0.105658389 D+00 ) | |
35062 | PARAMETER ( RCLSEL = 2.8179409183694872 D-13 ) | |
35063 | PARAMETER ( GEVMEV = 1.0 D+03 ) | |
35064 | PARAMETER ( EMVGEV = 1.0 D-03 ) | |
35065 | PARAMETER ( ALGVMV = 6.90775527898214 D+00 ) | |
35066 | PARAMETER ( RADDEG = 180.D+00 / PIPIPI ) | |
35067 | PARAMETER ( DEGRAD = PIPIPI / 180.D+00 ) | |
35068 | C + | |
35069 | C variables for EXPLOD | |
35070 | C - | |
35071 | PARAMETER ( KPMX = 10 ) | |
35072 | DIMENSION AMEXPL (KPMX), PXEXPL (KPMX), PYEXPL (KPMX), | |
35073 | & PZEXPL (KPMX), ETEXPL (KPMX) | |
35074 | C + | |
35075 | C test variables | |
35076 | C - | |
35077 | **sr - removed (not needed) | |
35078 | C COMMON /GBATNU/ ELERAT,NTRY | |
35079 | ** | |
35080 | C + | |
35081 | C Initializes test variables | |
35082 | C - | |
35083 | NTRY = 0 | |
35084 | ELERAT = 0.D+00 | |
35085 | C + | |
35086 | C Maximum value for matrix element | |
35087 | C - | |
35088 | ELEMAX = ( AMA**2 + AML**2 )**2 / AMA**2 * ( AMA**2 - AML**2 + | |
35089 | & SQRT( AMA**4 + AML**4 - 3.D+00 * AMA**2 * AML**2 ) ) | |
35090 | C + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + | |
35091 | C Inputs for EXPLOD | |
35092 | C part. no. 1 is l (e- in mu- decay) | |
35093 | C part. no. 2 is b (nu-mu in mu- decay) | |
35094 | C part. no. 3 is anti-nu (anti-nu-e in mu- decay) | |
35095 | C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - | |
35096 | NPEXPL = 3 | |
35097 | ETOTEX = AMA | |
35098 | AMEXPL(1) = AML | |
35099 | AMEXPL(2) = 0.D+00 | |
35100 | AMEXPL(3) = 0.D+00 | |
35101 | C + | |
35102 | C phase space distribution | |
35103 | C - | |
35104 | 100 CONTINUE | |
35105 | NTRY = NTRY + 1 | |
35106 | ||
35107 | CALL EXPLOD ( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL, | |
35108 | & PYEXPL, PZEXPL ) | |
35109 | ||
35110 | C + | |
35111 | C Calculates matrix element: | |
35112 | C 64*GF**2{[P(a)-ama*S(a)]*P(anti-nu)}{P(l)*P(b)} | |
35113 | C Here CTH is the cosine of the angle between anti-nu and Z axis | |
35114 | C - | |
35115 | CTH = PZEXPL(3) / SQRT ( PXEXPL(3)**2 + PYEXPL(3)**2 + | |
35116 | & PZEXPL(3)**2 ) | |
35117 | PROD1 = ETEXPL(3) * AMA * (1.D+00 - POL * CTH) | |
35118 | PROD2 = ETEXPL(1) * ETEXPL(2) - PXEXPL(1)*PXEXPL(2) - | |
35119 | & PYEXPL(1)*PYEXPL(2) - PZEXPL(1)*PZEXPL(2) | |
35120 | ELEMAT = 16.D+00 * PROD1 * PROD2 | |
35121 | IF(ELEMAT.GT.ELEMAX) THEN | |
35122 | WRITE(LOUT,*) 'Problems in LEPDCY',ELEMAX,ELEMAT | |
35123 | STOP | |
35124 | ENDIF | |
35125 | C + | |
35126 | C Here performs the rejection | |
35127 | C - | |
35128 | TEST = DT_RNDM(ETOTEX) * ELEMAX | |
35129 | IF ( TEST .GT. ELEMAT ) GO TO 100 | |
35130 | C + | |
35131 | C final assignment of variables | |
35132 | C - | |
35133 | ELERAT = ELEMAT/ELEMAX | |
35134 | ETL = ETEXPL(1) | |
35135 | PXL = PXEXPL(1) | |
35136 | PYL = PYEXPL(1) | |
35137 | PZL = PZEXPL(1) | |
35138 | ETB = ETEXPL(2) | |
35139 | PXB = PXEXPL(2) | |
35140 | PYB = PYEXPL(2) | |
35141 | PZB = PZEXPL(2) | |
35142 | ETN = ETEXPL(3) | |
35143 | PXN = PXEXPL(3) | |
35144 | PYN = PYEXPL(3) | |
35145 | PZN = PZEXPL(3) | |
35146 | 999 RETURN | |
35147 | END | |
35148 | ||
35149 | *$ CREATE DT_GEN_DELTA.FOR | |
35150 | *COPY DT_GEN_DELTA | |
35151 | C================================================================== | |
35152 | C. Generation of Delta resonance events | |
35153 | C================================================================== | |
35154 | * | |
35155 | *===gen_delta==========================================================* | |
35156 | * | |
35157 | SUBROUTINE DT_GEN_DELTA(ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25) | |
35158 | ||
35159 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
35160 | SAVE | |
35161 | ||
35162 | PARAMETER ( LINP = 10 , | |
35163 | & LOUT = 6 , | |
35164 | & LDAT = 9 ) | |
35165 | ||
35166 | C...Generate a Delta-production neutrino/antineutrino | |
35167 | C. CC-interaction on a nucleon | |
35168 | C | |
35169 | C. INPUT ENU (GeV) = Neutrino Energy | |
35170 | C. LLEP = neutrino type | |
35171 | C. LTARG = nucleon target type 1=p, 2=n. | |
35172 | C. JINT = 1:CC, 2::NC | |
35173 | C. | |
35174 | C. OUTPUT PPL(4) 4-monentum of final lepton | |
35175 | C---------------------------------------------------- | |
35176 | PARAMETER (MAXLND=4000) | |
35177 | COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5) | |
35178 | ||
35179 | **sr - removed (not needed) | |
35180 | C COMMON /CBAD/ LBAD, NBAD | |
35181 | ** | |
35182 | ||
35183 | DIMENSION PI(3),PO(3) | |
35184 | C REAL*4 AMD0, AMD, AMN(2), AML0(6), AML, AML2, AMDMIN | |
35185 | DIMENSION AML0(6),AMN(2) | |
35186 | DATA AMD0 /1.231/, GAMD /0.12/, DELD/0.169/, AMDMIN/1.084/ | |
35187 | DATA AMN /0.93827231, 0.93956563/ | |
35188 | DATA AML0 /2*0.51100E-03,2*0.105659, 2*1.777/ | |
35189 | ||
35190 | c WRITE(6,*)' GEN_DEL',ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25 | |
35191 | LBAD = 0 | |
35192 | C...Final lepton mass | |
35193 | IF (JINT.EQ.1) THEN | |
35194 | AML = AML0(LLEP) | |
35195 | ELSE | |
35196 | AML = 0. | |
35197 | ENDIF | |
35198 | AML2 = AML**2 | |
35199 | ||
35200 | C...Particle labels (LUND) | |
35201 | N = 5 | |
35202 | K(1,1) = 21 | |
35203 | K(2,1) = 21 | |
35204 | K(3,1) = 21 | |
35205 | K(4,1) = 1 | |
35206 | K(3,3) = 1 | |
35207 | K(4,3) = 1 | |
35208 | IF (LTARG .EQ. 1) THEN | |
35209 | K(2,2) = 2212 | |
35210 | ELSE | |
35211 | K(2,2) = 2112 | |
35212 | ENDIF | |
35213 | K0 = (LLEP-1)/2 | |
35214 | K1 = LLEP/2 | |
35215 | KA = 12 + 2*K0 | |
35216 | IS = -1 + 2*LLEP - 4*K1 | |
35217 | LNU = 2 - LLEP + 2*K1 | |
35218 | K(1,2) = IS*KA | |
35219 | K(5,1) = 1 | |
35220 | K(5,3) = 2 | |
35221 | IF (JINT .EQ. 1) THEN ! CC interactions | |
35222 | K(3,2) = IS*24 | |
35223 | K(4,2) = IS*(KA-1) | |
35224 | IF(LNU.EQ.1) THEN | |
35225 | IF (LTARG .EQ. 1) THEN | |
35226 | K(5,2) = 2224 | |
35227 | ELSE | |
35228 | K(5,2) = 2214 | |
35229 | ENDIF | |
35230 | ELSE | |
35231 | IF (LTARG .EQ. 1) THEN | |
35232 | K(5,2) = 2114 | |
35233 | ELSE | |
35234 | K(5,2) = 1114 | |
35235 | ENDIF | |
35236 | ENDIF | |
35237 | ELSE | |
35238 | K(3,2) = 23 ! NC (Z0) interactions | |
35239 | K(4,2) = K(1,2) | |
35240 | **sr 7.5.00: swop Delta's (bug), Delta+ for proton (LTARG=1), | |
35241 | * Delta0 for neutron (LTARG=2) | |
35242 | C IF (LTARG .EQ. 1) THEN | |
35243 | C K(5,2) = 2114 | |
35244 | C ELSE | |
35245 | C K(5,2) = 2214 | |
35246 | C ENDIF | |
35247 | IF (LTARG .EQ. 1) THEN | |
35248 | K(5,2) = 2214 | |
35249 | ELSE | |
35250 | K(5,2) = 2114 | |
35251 | ENDIF | |
35252 | ** | |
35253 | ENDIF | |
35254 | ||
35255 | C...4-momentum initial lepton | |
35256 | P(1,5) = 0. | |
35257 | P(1,4) = ENU | |
35258 | P(1,1) = 0. | |
35259 | P(1,2) = 0. | |
35260 | P(1,3) = ENU | |
35261 | C...4-momentum initial nucleon | |
35262 | P(2,5) = AMN(LTARG) | |
35263 | C P(2,4) = P(2,5) | |
35264 | C P(2,1) = 0. | |
35265 | C P(2,2) = 0. | |
35266 | C P(2,3) = 0. | |
35267 | P(2,1) = P21 | |
35268 | P(2,2) = P22 | |
35269 | P(2,3) = P23 | |
35270 | P(2,4) = P24 | |
35271 | P(2,5) = P25 | |
35272 | N=2 | |
35273 | beta1=-p(2,1)/p(2,4) | |
35274 | beta2=-p(2,2)/p(2,4) | |
35275 | beta3=-p(2,3)/p(2,4) | |
35276 | N=2 | |
35277 | ||
35278 | CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3) | |
35279 | ||
35280 | C print*,' nucl. rest fram ( fermi incl.) prima della rotazione' | |
35281 | ||
35282 | phi11=atan(p(1,2)/p(1,3)) | |
35283 | pi(1)=p(1,1) | |
35284 | pi(2)=p(1,2) | |
35285 | pi(3)=p(1,3) | |
35286 | ||
35287 | CALL DT_TESTROT(PI,Po,PHI11,1) | |
35288 | DO ll=1,3 | |
35289 | IF(abs(po(ll)).LT.1.D-07) po(ll)=0. | |
35290 | END DO | |
35291 | p(1,1)=po(1) | |
35292 | p(1,2)=po(2) | |
35293 | p(1,3)=po(3) | |
35294 | phi12=atan(p(1,1)/p(1,3)) | |
35295 | ||
35296 | pi(1)=p(1,1) | |
35297 | pi(2)=p(1,2) | |
35298 | pi(3)=p(1,3) | |
35299 | CALL DT_TESTROT(Pi,Po,PHI12,2) | |
35300 | DO ll=1,3 | |
35301 | IF(abs(po(ll)).LT.1.D-07) po(ll)=0. | |
35302 | END DO | |
35303 | p(1,1)=po(1) | |
35304 | p(1,2)=po(2) | |
35305 | p(1,3)=po(3) | |
35306 | ||
35307 | ENUU=P(1,4) | |
35308 | ||
35309 | C...Generate the Mass of the Delta | |
35310 | NTRY = 0 | |
35311 | 100 R = PYR(0) | |
35312 | AMD=AMD0+0.5*GAMD*TAN((2.*R-1.)*ATAN(2.*DELD/GAMD)) | |
35313 | NTRY = NTRY + 1 | |
35314 | IF (NTRY .GT. 1000) THEN | |
35315 | LBAD = 1 | |
35316 | WRITE (LOUT,1001) NBAD, ENUU,AMD,AMDMIN,AMD0,GAMD,ET | |
35317 | RETURN | |
35318 | ENDIF | |
35319 | IF (AMD .LT. AMDMIN) GOTO 100 | |
35320 | ET = ((AMD+AML)**2 - AMN(LTARG)**2)/(2.*AMN(LTARG)) | |
35321 | IF (ENUU .LT. ET) GOTO 100 | |
35322 | ||
35323 | C...Kinematical limits in Q**2 | |
35324 | S = AMN(LTARG)**2 + 2.*AMN(LTARG)*ENUU | |
35325 | SQS = SQRT(S) | |
35326 | PSTAR = (S - AMN(LTARG)**2)/(2.*SQS) | |
35327 | ELF = (S - AMD**2 + AML2)/(2.*SQS) | |
35328 | PLF = SQRT(ELF**2 - AML2) | |
35329 | Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF) | |
35330 | Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF) | |
35331 | IF (Q2MIN .LT. 0.) Q2MIN = 0. | |
35332 | ||
35333 | DSIGMAX = DT_DSIGMA_DELTA(LNU,-Q2MIN, S, AML, AMD) | |
35334 | 200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0) | |
35335 | DSIG = DT_DSIGMA_DELTA(LNU,-Q2, S, AML, AMD) | |
35336 | IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200 | |
35337 | ||
35338 | C...Generate the kinematics of the final particles | |
35339 | EISTAR = (S + AMN(LTARG)**2)/(2.*SQS) | |
35340 | GAM = EISTAR/AMN(LTARG) | |
35341 | BET = PSTAR/EISTAR | |
35342 | CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF) | |
35343 | EL = GAM*(ELF + BET*PLF*CTSTAR) | |
35344 | PLZ = GAM*(PLF*CTSTAR + BET*ELF) | |
35345 | PL = SQRT(EL**2 - AML2) | |
35346 | PLT = SQRT(MAX(1.D-06,(PL*PL - PLZ*PLZ))) | |
35347 | PHI = 6.28319*PYR(0) | |
35348 | P(4,1) = PLT*COS(PHI) | |
35349 | P(4,2) = PLT*SIN(PHI) | |
35350 | P(4,3) = PLZ | |
35351 | P(4,4) = EL | |
35352 | P(4,5) = AML | |
35353 | ||
35354 | C...4-momentum of Delta | |
35355 | P(5,1) = -P(4,1) | |
35356 | P(5,2) = -P(4,2) | |
35357 | P(5,3) = ENUU-P(4,3) | |
35358 | P(5,4) = ENUU+AMN(LTARG)-P(4,4) | |
35359 | P(5,5) = AMD | |
35360 | ||
35361 | C...4-momentum of intermediate boson | |
35362 | P(3,5) = -Q2 | |
35363 | P(3,4) = P(1,4)-P(4,4) | |
35364 | P(3,1) = P(1,1)-P(4,1) | |
35365 | P(3,2) = P(1,2)-P(4,2) | |
35366 | P(3,3) = P(1,3)-P(4,3) | |
35367 | N=5 | |
35368 | ||
35369 | DO kw=1,5 | |
35370 | pi(1)=p(kw,1) | |
35371 | pi(2)=p(kw,2) | |
35372 | pi(3)=p(kw,3) | |
35373 | CALL DT_TESTROT(Pi,Po,PHI12,3) | |
35374 | DO ll=1,3 | |
35375 | IF(abs(po(ll)).LT.1.D-07) po(ll)=0. | |
35376 | END DO | |
35377 | p(kw,1)=po(1) | |
35378 | p(kw,2)=po(2) | |
35379 | p(kw,3)=po(3) | |
35380 | END DO | |
35381 | ||
35382 | c******************************************** | |
35383 | ||
35384 | DO kw=1,5 | |
35385 | pi(1)=p(kw,1) | |
35386 | pi(2)=p(kw,2) | |
35387 | pi(3)=p(kw,3) | |
35388 | CALL DT_TESTROT(Pi,Po,PHI11,4) | |
35389 | DO ll=1,3 | |
35390 | IF(abs(po(ll)).LT.1.D-07) po(ll)=0. | |
35391 | END DO | |
35392 | p(kw,1)=po(1) | |
35393 | p(kw,2)=po(2) | |
35394 | p(kw,3)=po(3) | |
35395 | END DO | |
35396 | c******************************************** | |
35397 | C transform back into Lab. | |
35398 | ||
35399 | CALL PYROBO(0,0,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3) | |
35400 | ||
35401 | C WRITE(6,*)' Lab fram ( fermi incl.) ' | |
35402 | N=5 | |
35403 | CALL PYEXEC | |
35404 | ||
35405 | RETURN | |
35406 | 1001 FORMAT(2X, 'DT_GEN_DELTA : event rejected ', I5, 6G10.3) | |
35407 | END | |
35408 | ||
35409 | *$ CREATE DT_DSIGMA_DELTA.FOR | |
35410 | *COPY DT_DSIGMA_DELTA | |
35411 | * | |
35412 | *===dsigma_delta=======================================================* | |
35413 | * | |
35414 | DOUBLE PRECISION FUNCTION DT_DSIGMA_DELTA (LNU, QQ, S, AML, MD) | |
35415 | ||
35416 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
35417 | SAVE | |
35418 | ||
35419 | C...Reaction nu + N -> lepton + Delta | |
35420 | C. returns the cross section | |
35421 | C. dsigma/dt | |
35422 | C. INPUT LNU = 1, 2 (neutrino-antineutrino) | |
35423 | C. QQ = t (always negative) GeV**2 | |
35424 | C. S = (c.m energy)**2 GeV**2 | |
35425 | C. OUTPUT = 10**-38 cm+2/GeV**2 | |
35426 | C----------------------------------------------------- | |
35427 | REAL*8 MN, MN2, MN4, MD,MD2, MD4 | |
35428 | DATA MN /0.938/ | |
35429 | DATA PI /3.1415926/ | |
35430 | ||
35431 | GF = (1.1664 * 1.97) | |
35432 | GF2 = GF*GF | |
35433 | MN2 = MN*MN | |
35434 | MN4 = MN2*MN2 | |
35435 | MD2 = MD*MD | |
35436 | MD4 = MD2*MD2 | |
35437 | AML2 = AML*AML | |
35438 | AML4 = AML2*AML2 | |
35439 | VQ = (MN2 - MD2 - QQ)/2. | |
35440 | VPI = (MN2 + MD2 - QQ)/2. | |
35441 | VK = (S + QQ - MN2 - AML2)/2. | |
35442 | PIK = (S - MN2)/2. | |
35443 | QK = (AML2 - QQ)/2. | |
35444 | PIQ = (QQ + MN2 - MD2)/2. | |
35445 | Q = SQRT(-QQ) | |
35446 | C3V = 2.07*SQRT(EXP(-6.3*Q)*(1.+9*Q)) | |
35447 | C3 = SQRT(3.)*C3V/MN | |
35448 | C4 = -C3/MD ! attenzione al segno | |
35449 | C5A = 1.18/(1.-QQ/0.4225)**2 | |
35450 | C32 = C3**2 | |
35451 | C42 = C4**2 | |
35452 | C5A2 = C5A**2 | |
35453 | ||
35454 | IF (LNU .EQ. 1) THEN | |
35455 | ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ* | |
35456 | . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42- | |
35457 | . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ* | |
35458 | . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32 | |
35459 | ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK | |
35460 | . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2* | |
35461 | . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD* | |
35462 | . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ* | |
35463 | . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ | |
35464 | . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ- | |
35465 | . 4.*MN*C3*C5A*MD2*VK*QQ+4.*MN*C3*C5A*MD2*VQ*QK-2.*MD* | |
35466 | . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD | |
35467 | . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.* | |
35468 | . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.* | |
35469 | . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK-MD* | |
35470 | . C3*C5A*MD2*PIK*QQ+MD*C3*C5A*MD2*QK*PIQ-3.*MD*C3*C5A | |
35471 | . *VK*VPI*QQ+MD*C3*C5A*VK*VQ*PIQ+3.*MD*C3*C5A*VPI*VQ* | |
35472 | . QK-MD*C3*C5A*VQ**2*PIK+C4*C5A*MD2*VK*VPI*QQ+C4*C5A* | |
35473 | . MD2*VK*VQ*PIQ-C4*C5A*MD2*VPI*VQ*QK-C4*C5A*MD2*VQ**2 | |
35474 | . *PIK-C4*C5A*MD4*PIK*QQ+C4*C5A*MD4*QK*PIQ-2.*MD2*VK | |
35475 | . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK* | |
35476 | . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK | |
35477 | . *C42-2.*MD2*VPI*QK**2*C32+ANS3 | |
35478 | ELSE | |
35479 | ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ* | |
35480 | . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42- | |
35481 | . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ* | |
35482 | . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32 | |
35483 | ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK | |
35484 | . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2* | |
35485 | . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD* | |
35486 | . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ* | |
35487 | . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ | |
35488 | . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ+ | |
35489 | . 4.*MN*C3*C5A*MD2*VK*QQ-4.*MN*C3*C5A*MD2*VQ*QK-2.*MD* | |
35490 | . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD | |
35491 | . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.* | |
35492 | . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.* | |
35493 | . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK+MD* | |
35494 | . C3*C5A*MD2*PIK*QQ-MD*C3*C5A*MD2*QK*PIQ+3.*MD*C3*C5A | |
35495 | . *VK*VPI*QQ-MD*C3*C5A*VK*VQ*PIQ-3.*MD*C3*C5A*VPI*VQ* | |
35496 | . QK+MD*C3*C5A*VQ**2*PIK-C4*C5A*MD2*VK*VPI*QQ-C4*C5A* | |
35497 | . MD2*VK*VQ*PIQ+C4*C5A*MD2*VPI*VQ*QK+C4*C5A*MD2*VQ**2 | |
35498 | . *PIK+C4*C5A*MD4*PIK*QQ-C4*C5A*MD4*QK*PIQ-2.*MD2*VK | |
35499 | . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK* | |
35500 | . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK | |
35501 | . *C42-2.*MD2*VPI*QK**2*C32+ANS3 | |
35502 | ENDIF | |
35503 | ANS1=32.*ANS2 | |
35504 | ANS=ANS1/(3.*MD2) | |
35505 | P1CM = (S-MN2)/(2.*SQRT(S)) | |
35506 | DT_DSIGMA_DELTA = GF2/2. * ANS/(64.*PI*S*P1CM**2) | |
35507 | ||
35508 | RETURN | |
35509 | END | |
35510 | ||
35511 | *$ CREATE DT_QGAUS.FOR | |
35512 | *COPY DT_QGAUS | |
35513 | * | |
35514 | *===qgaus==============================================================* | |
35515 | * | |
35516 | SUBROUTINE DT_QGAUS(A,B,SS,ENU,LTYP) | |
35517 | ||
35518 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
35519 | SAVE | |
35520 | ||
35521 | DIMENSION X(5),W(5) | |
35522 | DATA X/.1488743389D0,.4333953941D0, | |
35523 | & .6794095682D0,.8650633666D0,.9739065285D0 | |
35524 | */ | |
35525 | DATA W/.2955242247D0,.2692667193D0, | |
35526 | & .2190863625D0,.1494513491D0,.0666713443D0 | |
35527 | */ | |
35528 | XM=0.5D0*(B+A) | |
35529 | XR=0.5D0*(B-A) | |
35530 | SS=0 | |
35531 | DO 11 J=1,5 | |
35532 | DX=XR*X(J) | |
35533 | SS=SS+W(J)*(DT_DSQEL_Q2(LTYP,ENU,XM+DX)+ | |
35534 | & DT_DSQEL_Q2(LTYP,ENU,XM-DX)) | |
35535 | 11 CONTINUE | |
35536 | SS=XR*SS | |
35537 | ||
35538 | RETURN | |
35539 | END | |
35540 | *$ CREATE DT_DIQBRK.FOR | |
35541 | *COPY DT_DIQBRK | |
35542 | * | |
35543 | *===diqbrk=============================================================* | |
35544 | * | |
35545 | SUBROUTINE DT_DIQBRK | |
35546 | ||
35547 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
35548 | SAVE | |
35549 | ||
35550 | * event history | |
35551 | ||
35552 | PARAMETER (NMXHKK=200000) | |
35553 | ||
35554 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
35555 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
35556 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
35557 | ||
35558 | * extended event history | |
35559 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
35560 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
35561 | & IHIST(2,NMXHKK) | |
35562 | ||
35563 | * event flag | |
35564 | COMMON /DTEVNO/ NEVENT,ICASCA | |
35565 | ||
35566 | C IF(DT_RNDM(VV).LE.0.5D0)THEN | |
35567 | C CALL GSQBS1(NHKK) | |
35568 | C CALL GSQBS2(NHKK) | |
35569 | C CALL USQBS1(NHKK) | |
35570 | C CALL USQBS2(NHKK) | |
35571 | C CALL GSABS1(NHKK) | |
35572 | C CALL GSABS2(NHKK) | |
35573 | C CALL USABS1(NHKK) | |
35574 | C CALL USABS2(NHKK) | |
35575 | C ELSE | |
35576 | C CALL GSQBS2(NHKK) | |
35577 | C CALL GSQBS1(NHKK) | |
35578 | C CALL USQBS2(NHKK) | |
35579 | C CALL USQBS1(NHKK) | |
35580 | C CALL GSABS2(NHKK) | |
35581 | C CALL GSABS1(NHKK) | |
35582 | C CALL USABS2(NHKK) | |
35583 | C CALL USABS1(NHKK) | |
35584 | C ENDIF | |
35585 | ||
35586 | IF(DT_RNDM(VV).LE.0.5D0) THEN | |
35587 | CALL DT_DBREAK(1) | |
35588 | CALL DT_DBREAK(2) | |
35589 | CALL DT_DBREAK(3) | |
35590 | CALL DT_DBREAK(4) | |
35591 | CALL DT_DBREAK(5) | |
35592 | CALL DT_DBREAK(6) | |
35593 | CALL DT_DBREAK(7) | |
35594 | CALL DT_DBREAK(8) | |
35595 | ELSE | |
35596 | CALL DT_DBREAK(2) | |
35597 | CALL DT_DBREAK(1) | |
35598 | CALL DT_DBREAK(4) | |
35599 | CALL DT_DBREAK(3) | |
35600 | CALL DT_DBREAK(6) | |
35601 | CALL DT_DBREAK(5) | |
35602 | CALL DT_DBREAK(8) | |
35603 | CALL DT_DBREAK(7) | |
35604 | ENDIF | |
35605 | ||
35606 | RETURN | |
35607 | END | |
35608 | ||
35609 | *$ CREATE MUSQBS2.FOR | |
35610 | *COPY MUSQBS2 | |
35611 | C | |
35612 | C | |
35613 | C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ | |
35614 | SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, | |
35615 | * IP1,IP21,IP22,IPP1,IPP2,IPIP,ISQ,IGCOUN) | |
35616 | C | |
35617 | C USQBS-2 diagram (split target diquark) | |
35618 | C | |
35619 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
35620 | SAVE | |
35621 | ||
35622 | PARAMETER ( LINP = 10 , | |
35623 | & LOUT = 6 , | |
35624 | & LDAT = 9 ) | |
35625 | ||
35626 | * event history | |
35627 | ||
35628 | PARAMETER (NMXHKK=200000) | |
35629 | ||
35630 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
35631 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
35632 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
35633 | ||
35634 | * extended event history | |
35635 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
35636 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
35637 | & IHIST(2,NMXHKK) | |
35638 | ||
35639 | * Lorentz-parameters of the current interaction | |
35640 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
35641 | & UMO,PPCM,EPROJ,PPROJ | |
35642 | ||
35643 | * diquark-breaking mechanism | |
35644 | COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3 | |
35645 | ||
35646 | C | |
35647 | PARAMETER (NTMHKK= 300) | |
35648 | COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT | |
35649 | +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT | |
35650 | +(4,NTMHKK) | |
35651 | *KEEP,XSEADI. | |
35652 | COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA, | |
35653 | +SSMIMQ,VVMTHR | |
35654 | *KEEP,DPRIN. | |
35655 | COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR | |
35656 | COMMON /EVFLAG/ NUMEV | |
35657 | C | |
35658 | C USQBS-2 diagram (split target diquark) | |
35659 | C | |
35660 | C | |
35661 | C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T) | |
35662 | C Input chain 2(NC2) sea-antiquark(NC2P)-sea-quark(NC2T) | |
35663 | C | |
35664 | C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T | |
35665 | C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T | |
35666 | C | |
35667 | C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2) | |
35668 | C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5) | |
35669 | C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8) | |
35670 | C | |
35671 | C | |
35672 | C Put new chains into COMMON /HKKTMP/ | |
35673 | C | |
35674 | IIGLU1=NC1T-NC1P-1 | |
35675 | IIGLU2=NC2T-NC2P-1 | |
35676 | IGCOUN=0 | |
35677 | C WRITE(LOUT,*)'MUSQBS2: IIGLU1,IIGLU2 ',IIGLU1,IIGLU2 | |
35678 | CVQ=1.D0 | |
35679 | IREJ=0 | |
35680 | IF(IPIP.EQ.2)THEN | |
35681 | C IF(NUMEV.EQ.-324)THEN | |
35682 | C WRITE(LOUT,*)' MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,', | |
35683 | C * 'IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN)', | |
35684 | C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, | |
35685 | C * IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN | |
35686 | ENDIF | |
35687 | C | |
35688 | C | |
35689 | C | |
35690 | C determine x-values of NC1T diquark | |
35691 | XDIQT=PHKK(4,NC1T)*2.D0/UMO | |
35692 | XVQP=PHKK(4,NC1P)*2.D0/UMO | |
35693 | C | |
35694 | C determine x-values of sea quark pair | |
35695 | C | |
35696 | IPCO=1 | |
35697 | ICOU=0 | |
35698 | 2234 CONTINUE | |
35699 | ICOU=ICOU+1 | |
35700 | IF(ICOU.GE.500)THEN | |
35701 | IREJ=1 | |
35702 | IF(ISQ.EQ.3)IREJ=3 | |
35703 | IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 2234 ICOU. GT.500' | |
35704 | IPCO=0 | |
35705 | RETURN | |
35706 | ENDIF | |
35707 | IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS2 call XSEAPA: UMO,XDIQT,XVQP ', | |
35708 | * UMO, XDIQT,XVQP | |
35709 | XSQ=0.D0 | |
35710 | XSAQ=0.D0 | |
35711 | **NEW | |
35712 | C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ) | |
35713 | IF (IPIP.EQ.1) THEN | |
35714 | XQMAX = XDIQT/2.0D0 | |
35715 | XAQMAX = 2.D0*XVQP/3.0D0 | |
35716 | ELSE | |
35717 | XQMAX = 2.D0*XVQP/3.0D0 | |
35718 | XAQMAX = XDIQT/2.0D0 | |
35719 | ENDIF | |
35720 | CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ) | |
35721 | ISAQ = 6+ISQ | |
35722 | C write(*,*) 'MUSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP | |
35723 | ** | |
35724 | IF(IPCO.GE.3) | |
35725 | & WRITE(LOUT,*)'MUSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ | |
35726 | IF(IREJ.GE.1)THEN | |
35727 | IF(IPCO.GE.3) | |
35728 | & WRITE(LOUT,*)'MUSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ | |
35729 | IPCO=0 | |
35730 | RETURN | |
35731 | ENDIF | |
35732 | IF(IPIP.EQ.1)THEN | |
35733 | IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234 | |
35734 | ELSEIF(IPIP.EQ.2)THEN | |
35735 | IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234 | |
35736 | ENDIF | |
35737 | IF(IPCO.GE.3)THEN | |
35738 | WRITE(LOUT,'(A,4E12.4)')' MUSQBS2 XDIQT,XVQP,XSQ,XSAQ ', | |
35739 | & XDIQT,XVQP,XSQ,XSAQ | |
35740 | ENDIF | |
35741 | C | |
35742 | C subtract xsq,xsaq from NC1T diquark and NC1P quark | |
35743 | C | |
35744 | C XSQ=0.D0 | |
35745 | IF(IPIP.EQ.1)THEN | |
35746 | XDIQT=XDIQT-XSQ | |
35747 | XVQP =XVQP -XSAQ | |
35748 | ELSEIF(IPIP.EQ.2)THEN | |
35749 | XDIQT=XDIQT-XSAQ | |
35750 | XVQP =XVQP -XSQ | |
35751 | ENDIF | |
35752 | IF(IPCO.GE.3) | |
35753 | & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP | |
35754 | C | |
35755 | C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T | |
35756 | C | |
35757 | XVTHRO=CVQ/UMO | |
35758 | IVTHR=0 | |
35759 | 3466 CONTINUE | |
35760 | IF(IVTHR.EQ.10)THEN | |
35761 | IREJ=1 | |
35762 | IF(ISQ.EQ.3)IREJ=3 | |
35763 | IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 3466 reject IVTHR 10' | |
35764 | IPCO=0 | |
35765 | RETURN | |
35766 | ENDIF | |
35767 | IVTHR=IVTHR+1 | |
35768 | XVTHR=XVTHRO/(201-IVTHR) | |
35769 | UNOPRV=UNON | |
35770 | 380 CONTINUE | |
35771 | IF(XVTHR.GT.0.66D0*XDIQT)THEN | |
35772 | IREJ=1 | |
35773 | IF(ISQ.EQ.3)IREJ=3 | |
35774 | IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 380 XVTHR large', | |
35775 | * XVTHR | |
35776 | IPCO=0 | |
35777 | RETURN | |
35778 | ENDIF | |
35779 | IF(DT_RNDM(V).LT.0.5D0)THEN | |
35780 | XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT) | |
35781 | XVTQII=XDIQT-XVTQI | |
35782 | ELSE | |
35783 | XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT) | |
35784 | XVTQI=XDIQT-XVTQII | |
35785 | ENDIF | |
35786 | IF(IPCO.GE.3)THEN | |
35787 | WRITE(LOUT,'(A,2E12.4)')' MUSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII | |
35788 | ENDIF | |
35789 | C | |
35790 | C Prepare 4 momenta of new chains and chain ends | |
35791 | C | |
35792 | C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT | |
35793 | C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT | |
35794 | C +(4,NTMHKK) | |
35795 | C | |
35796 | C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2) | |
35797 | C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5) | |
35798 | C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8) | |
35799 | C | |
35800 | C SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, | |
35801 | C * IP1,IP21,IP22,IPP1,IPP2) | |
35802 | C | |
35803 | IF(IPIP.EQ.1)THEN | |
35804 | XSQ1=XSQ | |
35805 | XSAQ1=XSAQ | |
35806 | ISQ1=ISQ | |
35807 | ISAQ1=ISAQ | |
35808 | ELSEIF(IPIP.EQ.2)THEN | |
35809 | XSQ1=XSAQ | |
35810 | XSAQ1=XSQ | |
35811 | ISQ1=ISAQ | |
35812 | ISAQ1=ISQ | |
35813 | ENDIF | |
35814 | IDHKT(1) =IPP1 | |
35815 | ISTHKT(1) =951 | |
35816 | JMOHKT(1,1)=NC2P | |
35817 | JMOHKT(2,1)=0 | |
35818 | JDAHKT(1,1)=3+IIGLU1 | |
35819 | JDAHKT(2,1)=0 | |
35820 | C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2) | |
35821 | PHKT(1,1) =PHKK(1,NC2P) | |
35822 | PHKT(2,1) =PHKK(2,NC2P) | |
35823 | PHKT(3,1) =PHKK(3,NC2P) | |
35824 | PHKT(4,1) =PHKK(4,NC2P) | |
35825 | C PHKT(5,1) =PHKK(5,NC2P) | |
35826 | XMIST =(PHKT(4,1)**2- | |
35827 | * PHKT(3,1)**2-PHKT(2,1)**2- | |
35828 | *PHKT(1,1)**2) | |
35829 | IF(XMIST.GT.0.D0)THEN | |
35830 | PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2- | |
35831 | *PHKT(1,1)**2) | |
35832 | ELSE | |
35833 | C WRITE(LOUT,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST | |
35834 | PHKT(5,1)=0.D0 | |
35835 | ENDIF | |
35836 | VHKT(1,1) =VHKK(1,NC2P) | |
35837 | VHKT(2,1) =VHKK(2,NC2P) | |
35838 | VHKT(3,1) =VHKK(3,NC2P) | |
35839 | VHKT(4,1) =VHKK(4,NC2P) | |
35840 | WHKT(1,1) =WHKK(1,NC2P) | |
35841 | WHKT(2,1) =WHKK(2,NC2P) | |
35842 | WHKT(3,1) =WHKK(3,NC2P) | |
35843 | WHKT(4,1) =WHKK(4,NC2P) | |
35844 | C Add here IIGLU1 gluons to this chaina | |
35845 | PG1=0.D0 | |
35846 | PG2=0.D0 | |
35847 | PG3=0.D0 | |
35848 | PG4=0.D0 | |
35849 | IF(IIGLU1.GE.1)THEN | |
35850 | JJG=NC1P | |
35851 | DO 61 IIG=2,2+IIGLU1-1 | |
35852 | KKG=JJG+IIG-1 | |
35853 | IDHKT(IIG) =IDHKK(KKG) | |
35854 | ISTHKT(IIG) =921 | |
35855 | JMOHKT(1,IIG)=KKG | |
35856 | JMOHKT(2,IIG)=0 | |
35857 | JDAHKT(1,IIG)=3+IIGLU1 | |
35858 | JDAHKT(2,IIG)=0 | |
35859 | PHKT(1,IIG)=PHKK(1,KKG) | |
35860 | PG1=PG1+ PHKT(1,IIG) | |
35861 | PHKT(2,IIG)=PHKK(2,KKG) | |
35862 | PG2=PG2+ PHKT(2,IIG) | |
35863 | PHKT(3,IIG)=PHKK(3,KKG) | |
35864 | PG3=PG3+ PHKT(3,IIG) | |
35865 | PHKT(4,IIG)=PHKK(4,KKG) | |
35866 | PG4=PG4+ PHKT(4,IIG) | |
35867 | PHKT(5,IIG)=PHKK(5,KKG) | |
35868 | VHKT(1,IIG) =VHKK(1,KKG) | |
35869 | VHKT(2,IIG) =VHKK(2,KKG) | |
35870 | VHKT(3,IIG) =VHKK(3,KKG) | |
35871 | VHKT(4,IIG) =VHKK(4,KKG) | |
35872 | WHKT(1,IIG) =WHKK(1,KKG) | |
35873 | WHKT(2,IIG) =WHKK(2,KKG) | |
35874 | WHKT(3,IIG) =WHKK(3,KKG) | |
35875 | WHKT(4,IIG) =WHKK(4,KKG) | |
35876 | 61 CONTINUE | |
35877 | ENDIF | |
35878 | IDHKT(2+IIGLU1) =IP21 | |
35879 | ISTHKT(2+IIGLU1) =952 | |
35880 | JMOHKT(1,2+IIGLU1)=NC1T | |
35881 | JMOHKT(2,2+IIGLU1)=0 | |
35882 | JDAHKT(1,2+IIGLU1)=3+IIGLU1 | |
35883 | JDAHKT(2,2+IIGLU1)=0 | |
35884 | PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1) | |
35885 | PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1) | |
35886 | PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1) | |
35887 | PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1) | |
35888 | C PHKT(5,2) =PHKK(5,NC1T) | |
35889 | XMIST =(PHKT(4,2+IIGLU1)**2- | |
35890 | * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2- | |
35891 | *PHKT(1,2+IIGLU1)**2) | |
35892 | IF(XMIST.GT.0.D0)THEN | |
35893 | PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2- | |
35894 | * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2- | |
35895 | *PHKT(1,2+IIGLU1)**2) | |
35896 | ELSE | |
35897 | C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST | |
35898 | PHKT(5,5+IIGLU1)=0.D0 | |
35899 | ENDIF | |
35900 | VHKT(1,2+IIGLU1) =VHKK(1,NC1T) | |
35901 | VHKT(2,2+IIGLU1) =VHKK(2,NC1T) | |
35902 | VHKT(3,2+IIGLU1) =VHKK(3,NC1T) | |
35903 | VHKT(4,2+IIGLU1) =VHKK(4,NC1T) | |
35904 | WHKT(1,2+IIGLU1) =WHKK(1,NC1T) | |
35905 | WHKT(2,2+IIGLU1) =WHKK(2,NC1T) | |
35906 | WHKT(3,2+IIGLU1) =WHKK(3,NC1T) | |
35907 | WHKT(4,2+IIGLU1) =WHKK(4,NC1T) | |
35908 | IDHKT(3+IIGLU1) =88888 | |
35909 | ISTHKT(3+IIGLU1) =95 | |
35910 | JMOHKT(1,3+IIGLU1)=1 | |
35911 | JMOHKT(2,3+IIGLU1)=2+IIGLU1 | |
35912 | JDAHKT(1,3+IIGLU1)=0 | |
35913 | JDAHKT(2,3+IIGLU1)=0 | |
35914 | PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1 | |
35915 | PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2 | |
35916 | PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3 | |
35917 | PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4 | |
35918 | XMIST | |
35919 | * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2 | |
35920 | * -PHKT(3,3+IIGLU1)**2) | |
35921 | IF(XMIST.GT.0.D0)THEN | |
35922 | PHKT(5,3+IIGLU1) | |
35923 | * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2 | |
35924 | * -PHKT(3,3+IIGLU1)**2) | |
35925 | ELSE | |
35926 | C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST | |
35927 | PHKT(5,5+IIGLU1)=0.D0 | |
35928 | ENDIF | |
35929 | IF(IPIP.GE.2)THEN | |
35930 | C IF(NUMEV.EQ.-324)THEN | |
35931 | C WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1), | |
35932 | C * JDAHKT(1,1), | |
35933 | C *JDAHKT(2,1),(PHKT(III,1),III=1,5) | |
35934 | DO 71 IIG=2,2+IIGLU1-1 | |
35935 | C WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG), | |
35936 | C & JMOHKT(1,IIG),JMOHKT(2,IIG), | |
35937 | C * JDAHKT(1,IIG), | |
35938 | C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) | |
35939 | 71 CONTINUE | |
35940 | C WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1), | |
35941 | C * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1), | |
35942 | C *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5) | |
35943 | C WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1), | |
35944 | C * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1), | |
35945 | C *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5) | |
35946 | ENDIF | |
35947 | CHAMAL=CHAM1 | |
35948 | IF(IPIP.EQ.1)THEN | |
35949 | IF(IPP1.LE.-3.OR.IP21.GE.3)CHAMAL=CHAM3 | |
35950 | ELSEIF(IPIP.EQ.2)THEN | |
35951 | IF(IPP1.GE.3.OR.IP21.LE.-3)CHAMAL=CHAM3 | |
35952 | ENDIF | |
35953 | IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN | |
35954 | C IREJ=1 | |
35955 | IPCO=0 | |
35956 | C RETURN | |
35957 | C WRITE(LOUT,*)' MUSQBS1 jump back from chain 3' | |
35958 | GO TO 3466 | |
35959 | ENDIF | |
35960 | VHKT(1,3+IIGLU1) =VHKK(1,NC1) | |
35961 | VHKT(2,3+IIGLU1) =VHKK(2,NC1) | |
35962 | VHKT(3,3+IIGLU1) =VHKK(3,NC1) | |
35963 | VHKT(4,3+IIGLU1) =VHKK(4,NC1) | |
35964 | WHKT(1,3+IIGLU1) =WHKK(1,NC1) | |
35965 | WHKT(2,3+IIGLU1) =WHKK(2,NC1) | |
35966 | WHKT(3,3+IIGLU1) =WHKK(3,NC1) | |
35967 | WHKT(4,3+IIGLU1) =WHKK(4,NC1) | |
35968 | IF(IPIP.EQ.1)THEN | |
35969 | IDHKT(4+IIGLU1) =-(ISAQ1-6) | |
35970 | ELSEIF(IPIP.EQ.2)THEN | |
35971 | IDHKT(4+IIGLU1) =ISAQ1 | |
35972 | ENDIF | |
35973 | ISTHKT(4+IIGLU1) =951 | |
35974 | JMOHKT(1,4+IIGLU1)=NC1P | |
35975 | JMOHKT(2,4+IIGLU1)=0 | |
35976 | JDAHKT(1,4+IIGLU1)=6+IIGLU1 | |
35977 | JDAHKT(2,4+IIGLU1)=0 | |
35978 | C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5) | |
35979 | PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1) | |
35980 | PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1) | |
35981 | PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1) | |
35982 | PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1) | |
35983 | C PHKT(5,4+IIGLU1) =PHKK(5,NC1P) | |
35984 | XMIST =(PHKT(4,4+IIGLU1)**2- | |
35985 | * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2- | |
35986 | *PHKT(1,4+IIGLU1)**2) | |
35987 | IF(XMIST.GT.0.D0)THEN | |
35988 | PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2- | |
35989 | * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2- | |
35990 | *PHKT(1,4+IIGLU1)**2) | |
35991 | ELSE | |
35992 | C WRITE(LOUT,*)'MUSQBS2 parton 4 mass square LT.0 ',XMIST | |
35993 | PHKT(5,4+IIGLU1)=0.D0 | |
35994 | ENDIF | |
35995 | VHKT(1,4+IIGLU1) =VHKK(1,NC1P) | |
35996 | VHKT(2,4+IIGLU1) =VHKK(2,NC1P) | |
35997 | VHKT(3,4+IIGLU1) =VHKK(3,NC1P) | |
35998 | VHKT(4,4+IIGLU1) =VHKK(4,NC1P) | |
35999 | WHKT(1,4+IIGLU1) =WHKK(1,NC1P) | |
36000 | WHKT(2,4+IIGLU1) =WHKK(2,NC1P) | |
36001 | WHKT(3,4+IIGLU1) =WHKK(3,NC1P) | |
36002 | WHKT(4,4+IIGLU1) =WHKK(4,NC1P) | |
36003 | IDHKT(5+IIGLU1) =IP22 | |
36004 | ISTHKT(5+IIGLU1) =952 | |
36005 | JMOHKT(1,5+IIGLU1)=NC1T | |
36006 | JMOHKT(2,5+IIGLU1)=0 | |
36007 | JDAHKT(1,5+IIGLU1)=6+IIGLU1 | |
36008 | JDAHKT(2,5+IIGLU1)=0 | |
36009 | PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1) | |
36010 | PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1) | |
36011 | PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1) | |
36012 | PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1) | |
36013 | C PHKT(5,5+IIGLU1) =PHKK(5,NC1T) | |
36014 | XMIST =(PHKT(4,5+IIGLU1)**2- | |
36015 | * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2- | |
36016 | *PHKT(1,5+IIGLU1)**2) | |
36017 | IF(XMIST.GT.0.D0)THEN | |
36018 | PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2- | |
36019 | * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2- | |
36020 | *PHKT(1,5+IIGLU1)**2) | |
36021 | ELSE | |
36022 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST | |
36023 | PHKT(5,5+IIGLU1)=0.D0 | |
36024 | ENDIF | |
36025 | VHKT(1,5+IIGLU1) =VHKK(1,NC1T) | |
36026 | VHKT(2,5+IIGLU1) =VHKK(2,NC1T) | |
36027 | VHKT(3,5+IIGLU1) =VHKK(3,NC1T) | |
36028 | VHKT(4,5+IIGLU1) =VHKK(4,NC1T) | |
36029 | WHKT(1,5+IIGLU1) =WHKK(1,NC1T) | |
36030 | WHKT(2,5+IIGLU1) =WHKK(2,NC1T) | |
36031 | WHKT(3,5+IIGLU1) =WHKK(3,NC1T) | |
36032 | WHKT(4,5+IIGLU1) =WHKK(4,NC1T) | |
36033 | IDHKT(6+IIGLU1) =88888 | |
36034 | ISTHKT(6+IIGLU1) =95 | |
36035 | JMOHKT(1,6+IIGLU1)=4+IIGLU1 | |
36036 | JMOHKT(2,6+IIGLU1)=5+IIGLU1 | |
36037 | JDAHKT(1,6+IIGLU1)=0 | |
36038 | JDAHKT(2,6+IIGLU1)=0 | |
36039 | PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1) | |
36040 | PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1) | |
36041 | PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1) | |
36042 | PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1) | |
36043 | XMIST | |
36044 | * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2 | |
36045 | * -PHKT(3,6+IIGLU1)**2) | |
36046 | IF(XMIST.GT.0.D0)THEN | |
36047 | PHKT(5,6+IIGLU1) | |
36048 | * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2 | |
36049 | * -PHKT(3,6+IIGLU1)**2) | |
36050 | ELSE | |
36051 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST | |
36052 | PHKT(5,5+IIGLU1)=0.D0 | |
36053 | ENDIF | |
36054 | C IF(IPIP.GE.2)THEN | |
36055 | C IF(NUMEV.EQ.-324)THEN | |
36056 | C WRITE(6,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1), | |
36057 | C * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1), | |
36058 | C *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5) | |
36059 | C WRITE(6,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1), | |
36060 | C * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1), | |
36061 | C *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5) | |
36062 | C WRITE(6,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1), | |
36063 | C * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1), | |
36064 | C *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5) | |
36065 | C ENDIF | |
36066 | CHAMAL=CHAM1 | |
36067 | IF(IPIP.EQ.1)THEN | |
36068 | IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3 | |
36069 | ELSEIF(IPIP.EQ.2)THEN | |
36070 | IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3 | |
36071 | ENDIF | |
36072 | IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN | |
36073 | C IREJ=1 | |
36074 | IPCO=0 | |
36075 | C RETURN | |
36076 | C WRITE(6,*)' MUSQBS1 jump back from chain 6', | |
36077 | C * CHAMAL,PHKT(5,6+IIGLU1) | |
36078 | GO TO 3466 | |
36079 | ENDIF | |
36080 | VHKT(1,6+IIGLU1) =VHKK(1,NC1) | |
36081 | VHKT(2,6+IIGLU1) =VHKK(2,NC1) | |
36082 | VHKT(3,6+IIGLU1) =VHKK(3,NC1) | |
36083 | VHKT(4,6+IIGLU1) =VHKK(4,NC1) | |
36084 | WHKT(1,6+IIGLU1) =WHKK(1,NC1) | |
36085 | WHKT(2,6+IIGLU1) =WHKK(2,NC1) | |
36086 | WHKT(3,6+IIGLU1) =WHKK(3,NC1) | |
36087 | WHKT(4,6+IIGLU1) =WHKK(4,NC1) | |
36088 | C IDHKT(7) =1000*IPP1+100*ISQ+1 | |
36089 | IDHKT(7+IIGLU1) =IP1 | |
36090 | ISTHKT(7+IIGLU1) =951 | |
36091 | JMOHKT(1,7+IIGLU1)=NC1P | |
36092 | JMOHKT(2,7+IIGLU1)=0 | |
36093 | **NEW | |
36094 | C JDAHKT(1,7+IIGLU1)=9+IIGLU1 | |
36095 | JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2 | |
36096 | ** | |
36097 | JDAHKT(2,7+IIGLU1)=0 | |
36098 | PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1) | |
36099 | PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1) | |
36100 | PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1) | |
36101 | PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1) | |
36102 | C PHKT(5,7+IIGLU1) =PHKK(5,NC1P) | |
36103 | XMIST =(PHKT(4,7+IIGLU1)**2- | |
36104 | * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2- | |
36105 | *PHKT(1,7+IIGLU1)**2) | |
36106 | IF(XMIST.GT.0.D0)THEN | |
36107 | PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2- | |
36108 | * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2- | |
36109 | *PHKT(1,7+IIGLU1)**2) | |
36110 | ELSE | |
36111 | C WRITE(6,*)'MUSQBS2 parton 7 mass square LT.0 ',XMIST | |
36112 | PHKT(5,7+IIGLU1)=0.D0 | |
36113 | ENDIF | |
36114 | VHKT(1,7+IIGLU1) =VHKK(1,NC1P) | |
36115 | VHKT(2,7+IIGLU1) =VHKK(2,NC1P) | |
36116 | VHKT(3,7+IIGLU1) =VHKK(3,NC1P) | |
36117 | VHKT(4,7+IIGLU1) =VHKK(4,NC1P) | |
36118 | WHKT(1,7+IIGLU1) =WHKK(1,NC1P) | |
36119 | WHKT(2,7+IIGLU1) =WHKK(2,NC1P) | |
36120 | WHKT(3,7+IIGLU1) =WHKK(3,NC1P) | |
36121 | WHKT(4,7+IIGLU1) =WHKK(4,NC2P) | |
36122 | C Insert here the IIGLU2 gluons | |
36123 | PG1=0.D0 | |
36124 | PG2=0.D0 | |
36125 | PG3=0.D0 | |
36126 | PG4=0.D0 | |
36127 | IF(IIGLU2.GE.1)THEN | |
36128 | JJG=NC2P | |
36129 | DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 | |
36130 | KKG=JJG+IIG-7-IIGLU1 | |
36131 | IDHKT(IIG) =IDHKK(KKG) | |
36132 | ISTHKT(IIG) =921 | |
36133 | JMOHKT(1,IIG)=KKG | |
36134 | JMOHKT(2,IIG)=0 | |
36135 | JDAHKT(1,IIG)=9+IIGLU1+IIGLU2 | |
36136 | JDAHKT(2,IIG)=0 | |
36137 | PHKT(1,IIG)=PHKK(1,KKG) | |
36138 | PG1=PG1+ PHKT(1,IIG) | |
36139 | PHKT(2,IIG)=PHKK(2,KKG) | |
36140 | PG2=PG2+ PHKT(2,IIG) | |
36141 | PHKT(3,IIG)=PHKK(3,KKG) | |
36142 | PG3=PG3+ PHKT(3,IIG) | |
36143 | PHKT(4,IIG)=PHKK(4,KKG) | |
36144 | PG4=PG4+ PHKT(4,IIG) | |
36145 | PHKT(5,IIG)=PHKK(5,KKG) | |
36146 | VHKT(1,IIG) =VHKK(1,KKG) | |
36147 | VHKT(2,IIG) =VHKK(2,KKG) | |
36148 | VHKT(3,IIG) =VHKK(3,KKG) | |
36149 | VHKT(4,IIG) =VHKK(4,KKG) | |
36150 | WHKT(1,IIG) =WHKK(1,KKG) | |
36151 | WHKT(2,IIG) =WHKK(2,KKG) | |
36152 | WHKT(3,IIG) =WHKK(3,KKG) | |
36153 | WHKT(4,IIG) =WHKK(4,KKG) | |
36154 | 81 CONTINUE | |
36155 | ENDIF | |
36156 | IF(IPIP.EQ.1)THEN | |
36157 | IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3 | |
36158 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103 | |
36159 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103 | |
36160 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203 | |
36161 | ELSEIF(IPIP.EQ.2)THEN | |
36162 | IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3 | |
36163 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103 | |
36164 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103 | |
36165 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203 | |
36166 | ENDIF | |
36167 | ISTHKT(8+IIGLU1+IIGLU2) =952 | |
36168 | JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T | |
36169 | JMOHKT(2,8+IIGLU1+IIGLU2)=0 | |
36170 | JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2 | |
36171 | JDAHKT(2,8+IIGLU1+IIGLU2)=0 | |
36172 | PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC2T)+ | |
36173 | * PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1) | |
36174 | PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC2T)+ | |
36175 | * PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1) | |
36176 | PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC2T)+ | |
36177 | * PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1) | |
36178 | PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC2T)+ | |
36179 | * PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1) | |
36180 | C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)', | |
36181 | C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7) | |
36182 | IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN | |
36183 | C IREJ=1 | |
36184 | C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)' | |
36185 | C * ,PHKT(4,8+IIGLU1+IIGLU2), PHKK(4,NC2T),NC2T | |
36186 | IPCO=0 | |
36187 | C RETURN | |
36188 | GO TO 3466 | |
36189 | ENDIF | |
36190 | C PHKT(5,8) =PHKK(5,NC2T) | |
36191 | XMIST =(PHKT(4,8+IIGLU1+IIGLU2)**2- | |
36192 | * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2- | |
36193 | *PHKT(1,8+IIGLU1+IIGLU2)**2) | |
36194 | IF(XMIST.GT.0.D0)THEN | |
36195 | PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2- | |
36196 | * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2- | |
36197 | *PHKT(1,8+IIGLU1+IIGLU2)**2) | |
36198 | ELSE | |
36199 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST | |
36200 | PHKT(5,5+IIGLU1)=0.D0 | |
36201 | ENDIF | |
36202 | VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T) | |
36203 | VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T) | |
36204 | VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T) | |
36205 | VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T) | |
36206 | WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T) | |
36207 | WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T) | |
36208 | WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T) | |
36209 | WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T) | |
36210 | IDHKT(9+IIGLU1+IIGLU2) =88888 | |
36211 | ISTHKT(9+IIGLU1+IIGLU2) =95 | |
36212 | JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1 | |
36213 | JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2 | |
36214 | JDAHKT(1,9+IIGLU1+IIGLU2)=0 | |
36215 | JDAHKT(2,9+IIGLU1+IIGLU2)=0 | |
36216 | **NEW | |
36217 | C PHKT(1,9+IIGLU1+IIGLU2) | |
36218 | C * =PHKT(1,7+IIGLU1+IIGLU2)+PHKT(1,8+IIGLU1+IIGLU2)+PG1 | |
36219 | C PHKT(2,9+IIGLU1+IIGLU2) | |
36220 | C * =PHKT(2,7+IIGLU1+IIGLU2)+PHKT(2,8+IIGLU1+IIGLU2)+PG2 | |
36221 | C PHKT(3,9+IIGLU1+IIGLU2) | |
36222 | C * =PHKT(3,7+IIGLU1+IIGLU2)+PHKT(3,8+IIGLU1+IIGLU2)+PG3 | |
36223 | C PHKT(4,9+IIGLU1+IIGLU2) | |
36224 | C * =PHKT(4,7+IIGLU1+IIGLU2)+PHKT(4,8+IIGLU1+IIGLU2)+PG4 | |
36225 | PHKT(1,9+IIGLU1+IIGLU2) | |
36226 | * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1 | |
36227 | PHKT(2,9+IIGLU1+IIGLU2) | |
36228 | * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2 | |
36229 | PHKT(3,9+IIGLU1+IIGLU2) | |
36230 | * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3 | |
36231 | PHKT(4,9+IIGLU1+IIGLU2) | |
36232 | * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4 | |
36233 | ** | |
36234 | XMIST | |
36235 | * =(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2 | |
36236 | * -PHKT(2,9+IIGLU1+IIGLU2)**2 | |
36237 | * -PHKT(3,9+IIGLU1+IIGLU2)**2) | |
36238 | IF(XMIST.GT.0.D0)THEN | |
36239 | PHKT(5,9+IIGLU1+IIGLU2) | |
36240 | * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2 | |
36241 | * -PHKT(2,9+IIGLU1+IIGLU2)**2 | |
36242 | * -PHKT(3,9+IIGLU1+IIGLU2)**2) | |
36243 | ELSE | |
36244 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST | |
36245 | PHKT(5,5+IIGLU1)=0.D0 | |
36246 | ENDIF | |
36247 | IF(IPIP.GE.2)THEN | |
36248 | C IF(NUMEV.EQ.-324)THEN | |
36249 | C WRITE(6,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1), | |
36250 | C * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1), | |
36251 | C *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5) | |
36252 | C DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 | |
36253 | C WRITE(6,*)IIG,ISTHKT(IIG),IDHKT(IIG),JMOHKT(1,IIG),JMOHKT(2,IIG), | |
36254 | C * JDAHKT(1,IIG), | |
36255 | C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) | |
36256 | C 91 CONTINUE | |
36257 | C WRITE(6,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2), | |
36258 | C * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2), | |
36259 | C *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2), | |
36260 | C *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5) | |
36261 | C WRITE(6,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2), | |
36262 | C * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2), | |
36263 | C *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2), | |
36264 | C *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5) | |
36265 | ENDIF | |
36266 | CHAMAL=CHAB1 | |
36267 | IF(IPIP.EQ.1)THEN | |
36268 | IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3 | |
36269 | ELSEIF(IPIP.EQ.2)THEN | |
36270 | IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3 | |
36271 | ENDIF | |
36272 | IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN | |
36273 | C IREJ=1 | |
36274 | IPCO=0 | |
36275 | C RETURN | |
36276 | C WRITE(6,*)' MUSQBS1 jump back from chain 9', | |
36277 | C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2) | |
36278 | GO TO 3466 | |
36279 | ENDIF | |
36280 | VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1) | |
36281 | VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1) | |
36282 | VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1) | |
36283 | VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1) | |
36284 | WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1) | |
36285 | WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1) | |
36286 | WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1) | |
36287 | WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1) | |
36288 | C | |
36289 | IPCO=0 | |
36290 | IGCOUN=9+IIGLU1+IIGLU2 | |
36291 | RETURN | |
36292 | END | |
36293 | ||
36294 | *$ CREATE MGSQBS2.FOR | |
36295 | *COPY MGSQBS2 | |
36296 | C | |
36297 | C | |
36298 | C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ | |
36299 | SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, | |
36300 | * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,ISQ,IGCOUN) | |
36301 | C | |
36302 | C GSQBS-2 diagram (split target diquark) | |
36303 | C | |
36304 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
36305 | SAVE | |
36306 | ||
36307 | PARAMETER ( LINP = 10 , | |
36308 | & LOUT = 6 , | |
36309 | & LDAT = 9 ) | |
36310 | ||
36311 | * event history | |
36312 | ||
36313 | PARAMETER (NMXHKK=200000) | |
36314 | ||
36315 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
36316 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
36317 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
36318 | ||
36319 | * extended event history | |
36320 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
36321 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
36322 | & IHIST(2,NMXHKK) | |
36323 | ||
36324 | * Lorentz-parameters of the current interaction | |
36325 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
36326 | & UMO,PPCM,EPROJ,PPROJ | |
36327 | ||
36328 | * diquark-breaking mechanism | |
36329 | COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3 | |
36330 | ||
36331 | C | |
36332 | PARAMETER (NTMHKK= 300) | |
36333 | COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT | |
36334 | +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT | |
36335 | +(4,NTMHKK) | |
36336 | ||
36337 | *KEEP,XSEADI. | |
36338 | COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA, | |
36339 | +SSMIMQ,VVMTHR | |
36340 | *KEEP,DPRIN. | |
36341 | COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR | |
36342 | C | |
36343 | C GSQBS-2 diagram (split target diquark) | |
36344 | C | |
36345 | C | |
36346 | C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T) | |
36347 | C Input chain 2(NC2) valence-diquark(NC2P)-sea-quark(NC2T) | |
36348 | C | |
36349 | C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T | |
36350 | C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T | |
36351 | C | |
36352 | C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2) | |
36353 | C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5) | |
36354 | C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8) | |
36355 | C | |
36356 | C | |
36357 | C | |
36358 | C Put new chains into COMMON /HKKTMP/ | |
36359 | C | |
36360 | IIGLU1=NC1T-NC1P-1 | |
36361 | IIGLU2=NC2T-NC2P-1 | |
36362 | IGCOUN=0 | |
36363 | C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2 | |
36364 | CVQ=1.D0 | |
36365 | IREJ=0 | |
36366 | C IF(IPIP.EQ.2)THEN | |
36367 | C WRITE(6,*)' MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,', | |
36368 | C * 'IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN)', | |
36369 | C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, | |
36370 | C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN | |
36371 | C ENDIF | |
36372 | C | |
36373 | C | |
36374 | C | |
36375 | C determine x-values of NC1T diquark | |
36376 | XDIQT=PHKK(4,NC1T)*2.D0/UMO | |
36377 | XVQP=PHKK(4,NC1P)*2.D0/UMO | |
36378 | C | |
36379 | C determine x-values of sea quark pair | |
36380 | C | |
36381 | IPCO=1 | |
36382 | ICOU=0 | |
36383 | 2234 CONTINUE | |
36384 | ICOU=ICOU+1 | |
36385 | IF(ICOU.GE.500)THEN | |
36386 | IREJ=1 | |
36387 | IF(ISQ.EQ.3)IREJ=3 | |
36388 | IF(IPCO.GE.3) | |
36389 | & WRITE(LOUT,*)' MGSQBS2 Rejection 2234 ICOU. GT.500' | |
36390 | IPCO=0 | |
36391 | RETURN | |
36392 | ENDIF | |
36393 | IF(IPCO.GE.3) | |
36394 | & WRITE(LOUT,*)'MGSQBS2 call XSEAPA: UMO,XDIQT,XVQP ', | |
36395 | * UMO, XDIQT,XVQP | |
36396 | XSQ=0.D0 | |
36397 | XSAQ=0.D0 | |
36398 | **NEW | |
36399 | C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ) | |
36400 | IF (IPIP.EQ.1) THEN | |
36401 | XQMAX = XDIQT/2.0D0 | |
36402 | XAQMAX = 2.D0*XVQP/3.0D0 | |
36403 | ELSE | |
36404 | XQMAX = 2.D0*XVQP/3.0D0 | |
36405 | XAQMAX = XDIQT/2.0D0 | |
36406 | ENDIF | |
36407 | CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ) | |
36408 | ISAQ = 6+ISQ | |
36409 | C write(*,*) 'MGSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP | |
36410 | ** | |
36411 | IF(IPCO.GE.3) | |
36412 | & WRITE(LOUT,*)'MGSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ | |
36413 | IF(IREJ.GE.1)THEN | |
36414 | IF(IPCO.GE.3) | |
36415 | & WRITE(LOUT,*)'MGSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ | |
36416 | IPCO=0 | |
36417 | RETURN | |
36418 | ENDIF | |
36419 | IF(IPIP.EQ.1)THEN | |
36420 | IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234 | |
36421 | ELSEIF(IPIP.EQ.2)THEN | |
36422 | IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234 | |
36423 | ENDIF | |
36424 | IF(IPCO.GE.3)THEN | |
36425 | WRITE(LOUT,'(A,4E12.4)')' MGSQBS2 XDIQT,XVQP,XSQ,XSAQ ', | |
36426 | & XDIQT,XVQP,XSQ,XSAQ | |
36427 | ENDIF | |
36428 | C | |
36429 | C subtract xsq,xsaq from NC1T diquark and NC1P quark | |
36430 | C | |
36431 | C XSQ=0.D0 | |
36432 | IF(IPIP.EQ.1)THEN | |
36433 | XDIQT=XDIQT-XSQ | |
36434 | XVQP =XVQP -XSAQ | |
36435 | ELSEIF(IPIP.EQ.2)THEN | |
36436 | XDIQT=XDIQT-XSAQ | |
36437 | XVQP =XVQP -XSQ | |
36438 | ENDIF | |
36439 | IF(IPCO.GE.3) | |
36440 | & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP | |
36441 | C | |
36442 | C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T | |
36443 | C | |
36444 | XVTHRO=CVQ/UMO | |
36445 | IVTHR=0 | |
36446 | 3466 CONTINUE | |
36447 | IF(IVTHR.EQ.10)THEN | |
36448 | IREJ=1 | |
36449 | IF(ISQ.EQ.3)IREJ=3 | |
36450 | IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 3466 reject IVTHR 10' | |
36451 | IPCO=0 | |
36452 | RETURN | |
36453 | ENDIF | |
36454 | IVTHR=IVTHR+1 | |
36455 | XVTHR=XVTHRO/(201-IVTHR) | |
36456 | UNOPRV=UNON | |
36457 | 380 CONTINUE | |
36458 | IF(XVTHR.GT.0.66D0*XDIQT)THEN | |
36459 | IREJ=1 | |
36460 | IF(ISQ.EQ.3)IREJ=3 | |
36461 | IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 Rejection 380 XVTHR large', | |
36462 | * XVTHR | |
36463 | IPCO=0 | |
36464 | RETURN | |
36465 | ENDIF | |
36466 | IF(DT_RNDM(V).LT.0.5D0)THEN | |
36467 | XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT) | |
36468 | XVTQII=XDIQT-XVTQI | |
36469 | ELSE | |
36470 | XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT) | |
36471 | XVTQI=XDIQT-XVTQII | |
36472 | ENDIF | |
36473 | IF(IPCO.GE.3)THEN | |
36474 | WRITE(LOUT,'(A,2E12.4)')' MGSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII | |
36475 | ENDIF | |
36476 | C | |
36477 | C Prepare 4 momenta of new chains and chain ends | |
36478 | C | |
36479 | C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT | |
36480 | C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT | |
36481 | C +(4,NTMHKK) | |
36482 | C | |
36483 | C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2) | |
36484 | C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5) | |
36485 | C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8) | |
36486 | C | |
36487 | C SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, | |
36488 | C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IGCOUN) | |
36489 | C | |
36490 | IF(IPIP.EQ.1)THEN | |
36491 | XSQ1=XSQ | |
36492 | XSAQ1=XSAQ | |
36493 | ISQ1=ISQ | |
36494 | ISAQ1=ISAQ | |
36495 | ELSEIF(IPIP.EQ.2)THEN | |
36496 | XSQ1=XSAQ | |
36497 | XSAQ1=XSQ | |
36498 | ISQ1=ISAQ | |
36499 | ISAQ1=ISQ | |
36500 | ENDIF | |
36501 | KK11=IP21 | |
36502 | C IDHKT(1) =1000*IPP11+100*IPP12+1 | |
36503 | KK21=IPP11 | |
36504 | KK22=IPP12 | |
36505 | XGIVE=0.D0 | |
36506 | IF(IPIP.EQ.1)THEN | |
36507 | IDHKT(4+IIGLU1) =-(ISAQ1-6) | |
36508 | ELSEIF(IPIP.EQ.2)THEN | |
36509 | IDHKT(4+IIGLU1) =ISAQ1 | |
36510 | ENDIF | |
36511 | ISTHKT(4+IIGLU1) =961 | |
36512 | JMOHKT(1,4+IIGLU1)=NC1P | |
36513 | JMOHKT(2,4+IIGLU1)=0 | |
36514 | JDAHKT(1,4+IIGLU1)=6+IIGLU1 | |
36515 | JDAHKT(2,4+IIGLU1)=0 | |
36516 | C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5) | |
36517 | PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1) | |
36518 | PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1) | |
36519 | PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1) | |
36520 | PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1) | |
36521 | C PHKT(5,4+IIGLU1) =PHKK(5,NC1P) | |
36522 | XXMIST=(PHKT(4,4+IIGLU1)**2- | |
36523 | * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2- | |
36524 | *PHKT(1,4+IIGLU1)**2) | |
36525 | IF(XXMIST.GT.0.D0)THEN | |
36526 | PHKT(5,4+IIGLU1) =SQRT(XXMIST) | |
36527 | ELSE | |
36528 | WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST | |
36529 | XXMIST=ABS(XXMIST) | |
36530 | PHKT(5,4+IIGLU1) =SQRT(XXMIST) | |
36531 | ENDIF | |
36532 | VHKT(1,4+IIGLU1) =VHKK(1,NC1P) | |
36533 | VHKT(2,4+IIGLU1) =VHKK(2,NC1P) | |
36534 | VHKT(3,4+IIGLU1) =VHKK(3,NC1P) | |
36535 | VHKT(4,4+IIGLU1) =VHKK(4,NC1P) | |
36536 | WHKT(1,4+IIGLU1) =WHKK(1,NC1P) | |
36537 | WHKT(2,4+IIGLU1) =WHKK(2,NC1P) | |
36538 | WHKT(3,4+IIGLU1) =WHKK(3,NC1P) | |
36539 | WHKT(4,4+IIGLU1) =WHKK(4,NC1P) | |
36540 | IDHKT(5+IIGLU1) =IP22 | |
36541 | ISTHKT(5+IIGLU1) =962 | |
36542 | JMOHKT(1,5+IIGLU1)=NC1T | |
36543 | JMOHKT(2,5+IIGLU1)=0 | |
36544 | JDAHKT(1,5+IIGLU1)=6+IIGLU1 | |
36545 | JDAHKT(2,5+IIGLU1)=0 | |
36546 | PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1) | |
36547 | PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1) | |
36548 | PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1) | |
36549 | PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1) | |
36550 | C PHKT(5,5+IIGLU1) =PHKK(5,NC1T) | |
36551 | XXMIST=(PHKT(4,5+IIGLU1)**2- | |
36552 | * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2- | |
36553 | *PHKT(1,5+IIGLU1)**2) | |
36554 | IF(XXMIST.GT.0.D0)THEN | |
36555 | PHKT(5,5+IIGLU1) =SQRT(XXMIST) | |
36556 | ELSE | |
36557 | WRITE(LOUT,*)' MGSQBS2 XXMIST', XXMIST | |
36558 | XXMIST=ABS(XXMIST) | |
36559 | PHKT(5,5+IIGLU1) =SQRT(XXMIST) | |
36560 | ENDIF | |
36561 | VHKT(1,5+IIGLU1) =VHKK(1,NC1T) | |
36562 | VHKT(2,5+IIGLU1) =VHKK(2,NC1T) | |
36563 | VHKT(3,5+IIGLU1) =VHKK(3,NC1T) | |
36564 | VHKT(4,5+IIGLU1) =VHKK(4,NC1T) | |
36565 | WHKT(1,5+IIGLU1) =WHKK(1,NC1T) | |
36566 | WHKT(2,5+IIGLU1) =WHKK(2,NC1T) | |
36567 | WHKT(3,5+IIGLU1) =WHKK(3,NC1T) | |
36568 | WHKT(4,5+IIGLU1) =WHKK(4,NC1T) | |
36569 | IDHKT(6+IIGLU1) =88888 | |
36570 | ISTHKT(6+IIGLU1) =96 | |
36571 | JMOHKT(1,6+IIGLU1)=4+IIGLU1 | |
36572 | JMOHKT(2,6+IIGLU1)=5+IIGLU1 | |
36573 | JDAHKT(1,6+IIGLU1)=0 | |
36574 | JDAHKT(2,6+IIGLU1)=0 | |
36575 | PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1) | |
36576 | PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1) | |
36577 | PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1) | |
36578 | PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1) | |
36579 | PHKT(5,6+IIGLU1) | |
36580 | * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2 | |
36581 | * -PHKT(3,6+IIGLU1)**2) | |
36582 | CHAMAL=CHAM1 | |
36583 | IF(IPIP.EQ.1)THEN | |
36584 | IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3 | |
36585 | ELSEIF(IPIP.EQ.2)THEN | |
36586 | IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3 | |
36587 | ENDIF | |
36588 | C--------------------------------------------------- | |
36589 | IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN | |
36590 | IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN | |
36591 | C we drop chain 6 and give the energy to chain 3 | |
36592 | IDHKT(6+IIGLU1)=22888 | |
36593 | XGIVE=1.D0 | |
36594 | C WRITE(6,*)' drop chain 6 xgive=1' | |
36595 | GO TO 7788 | |
36596 | ELSEIF(IDHKT(4+IIGLU1).EQ.-IP21)THEN | |
36597 | C we drop chain 6 and give the energy to chain 3 | |
36598 | C and change KK11 to IDHKT(5) | |
36599 | IDHKT(6+IIGLU1)=22888 | |
36600 | XGIVE=1.D0 | |
36601 | C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(5)' | |
36602 | KK11=IDHKT(5+IIGLU1) | |
36603 | GO TO 7788 | |
36604 | ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP11)THEN | |
36605 | C we drop chain 6 and give the energy to chain 3 | |
36606 | C and change KK21 to IDHKT(5+IIGLU1) | |
36607 | C IDHKT(1) =1000*IPP11+100*IPP12+1 | |
36608 | IDHKT(6+IIGLU1)=22888 | |
36609 | XGIVE=1.D0 | |
36610 | C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(5+IIGLU1)' | |
36611 | KK21=IDHKT(5+IIGLU1) | |
36612 | GO TO 7788 | |
36613 | ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP12)THEN | |
36614 | C we drop chain 6 and give the energy to chain 3 | |
36615 | C and change KK22 to IDHKT(5) | |
36616 | C IDHKT(1) =1000*IPP11+100*IPP12+1 | |
36617 | IDHKT(6+IIGLU1)=22888 | |
36618 | XGIVE=1.D0 | |
36619 | C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(5+IIGLU1)' | |
36620 | KK22=IDHKT(5+IIGLU1) | |
36621 | GO TO 7788 | |
36622 | ENDIF | |
36623 | C IREJ=1 | |
36624 | IPCO=0 | |
36625 | C RETURN | |
36626 | GO TO 3466 | |
36627 | ENDIF | |
36628 | 7788 CONTINUE | |
36629 | C--------------------------------------------------- | |
36630 | IF(IPIP.GE.3)THEN | |
36631 | WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1), | |
36632 | * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1), | |
36633 | *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5) | |
36634 | WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1), | |
36635 | * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1), | |
36636 | *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5) | |
36637 | WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1), | |
36638 | * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1), | |
36639 | *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5) | |
36640 | ENDIF | |
36641 | VHKT(1,6+IIGLU1) =VHKK(1,NC1) | |
36642 | VHKT(2,6+IIGLU1) =VHKK(2,NC1) | |
36643 | VHKT(3,6+IIGLU1) =VHKK(3,NC1) | |
36644 | VHKT(4,6+IIGLU1) =VHKK(4,NC1) | |
36645 | WHKT(1,6+IIGLU1) =WHKK(1,NC1) | |
36646 | WHKT(2,6+IIGLU1) =WHKK(2,NC1) | |
36647 | WHKT(3,6+IIGLU1) =WHKK(3,NC1) | |
36648 | WHKT(4,6+IIGLU1) =WHKK(4,NC1) | |
36649 | C IDHKT(1) =1000*IPP11+100*IPP12+1 | |
36650 | IF(IPIP.EQ.1)THEN | |
36651 | IDHKT(1) =1000*KK21+100*KK22+3 | |
36652 | IF(IDHKT(1).EQ.1203)IDHKT(1)=2103 | |
36653 | IF(IDHKT(1).EQ.1303)IDHKT(1)=3103 | |
36654 | IF(IDHKT(1).EQ.2303)IDHKT(1)=3203 | |
36655 | ELSEIF(IPIP.EQ.2)THEN | |
36656 | IDHKT(1) =1000*KK21+100*KK22-3 | |
36657 | IF(IDHKT(1).EQ.-1203)IDHKT(1)=-2103 | |
36658 | IF(IDHKT(1).EQ.-1303)IDHKT(1)=-3103 | |
36659 | IF(IDHKT(1).EQ.-2303)IDHKT(1)=-3203 | |
36660 | ENDIF | |
36661 | ISTHKT(1) =961 | |
36662 | JMOHKT(1,1)=NC2P | |
36663 | JMOHKT(2,1)=0 | |
36664 | JDAHKT(1,1)=3+IIGLU1 | |
36665 | JDAHKT(2,1)=0 | |
36666 | C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2) | |
36667 | PHKT(1,1) =PHKK(1,NC2P) | |
36668 | *+XGIVE*PHKT(1,4+IIGLU1) | |
36669 | PHKT(2,1) =PHKK(2,NC2P) | |
36670 | *+XGIVE*PHKT(2,4+IIGLU1) | |
36671 | PHKT(3,1) =PHKK(3,NC2P) | |
36672 | *+XGIVE*PHKT(3,4+IIGLU1) | |
36673 | PHKT(4,1) =PHKK(4,NC2P) | |
36674 | *+XGIVE*PHKT(4,4+IIGLU1) | |
36675 | C PHKT(5,1) =PHKK(5,NC2P) | |
36676 | XXMIST=PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2- | |
36677 | *PHKT(1,1)**2 | |
36678 | IF(XXMIST.GT.0.D0)THEN | |
36679 | PHKT(5,1) =SQRT(XXMIST) | |
36680 | ELSE | |
36681 | WRITE(LOUT,*)'MGSQBS2',XXMIST | |
36682 | XXMIST=ABS(XXMIST) | |
36683 | PHKT(5,1) =SQRT(XXMIST) | |
36684 | ENDIF | |
36685 | VHKT(1,1) =VHKK(1,NC2P) | |
36686 | VHKT(2,1) =VHKK(2,NC2P) | |
36687 | VHKT(3,1) =VHKK(3,NC2P) | |
36688 | VHKT(4,1) =VHKK(4,NC2P) | |
36689 | WHKT(1,1) =WHKK(1,NC2P) | |
36690 | WHKT(2,1) =WHKK(2,NC2P) | |
36691 | WHKT(3,1) =WHKK(3,NC2P) | |
36692 | WHKT(4,1) =WHKK(4,NC2P) | |
36693 | C Add here IIGLU1 gluons to this chaina | |
36694 | PG1=0.D0 | |
36695 | PG2=0.D0 | |
36696 | PG3=0.D0 | |
36697 | PG4=0.D0 | |
36698 | IF(IIGLU1.GE.1)THEN | |
36699 | JJG=NC1P | |
36700 | DO 61 IIG=2,2+IIGLU1-1 | |
36701 | KKG=JJG+IIG-1 | |
36702 | IDHKT(IIG) =IDHKK(KKG) | |
36703 | ISTHKT(IIG) =921 | |
36704 | JMOHKT(1,IIG)=KKG | |
36705 | JMOHKT(2,IIG)=0 | |
36706 | JDAHKT(1,IIG)=3+IIGLU1 | |
36707 | JDAHKT(2,IIG)=0 | |
36708 | PHKT(1,IIG)=PHKK(1,KKG) | |
36709 | PG1=PG1+ PHKT(1,IIG) | |
36710 | PHKT(2,IIG)=PHKK(2,KKG) | |
36711 | PG2=PG2+ PHKT(2,IIG) | |
36712 | PHKT(3,IIG)=PHKK(3,KKG) | |
36713 | PG3=PG3+ PHKT(3,IIG) | |
36714 | PHKT(4,IIG)=PHKK(4,KKG) | |
36715 | PG4=PG4+ PHKT(4,IIG) | |
36716 | PHKT(5,IIG)=PHKK(5,KKG) | |
36717 | VHKT(1,IIG) =VHKK(1,KKG) | |
36718 | VHKT(2,IIG) =VHKK(2,KKG) | |
36719 | VHKT(3,IIG) =VHKK(3,KKG) | |
36720 | VHKT(4,IIG) =VHKK(4,KKG) | |
36721 | WHKT(1,IIG) =WHKK(1,KKG) | |
36722 | WHKT(2,IIG) =WHKK(2,KKG) | |
36723 | WHKT(3,IIG) =WHKK(3,KKG) | |
36724 | WHKT(4,IIG) =WHKK(4,KKG) | |
36725 | 61 CONTINUE | |
36726 | ENDIF | |
36727 | C IDHKT(2) =IP21 | |
36728 | IDHKT(2+IIGLU1) =KK11 | |
36729 | ISTHKT(2+IIGLU1) =962 | |
36730 | JMOHKT(1,2+IIGLU1)=NC1T | |
36731 | JMOHKT(2,2+IIGLU1)=0 | |
36732 | JDAHKT(1,2+IIGLU1)=3+IIGLU1 | |
36733 | JDAHKT(2,2+IIGLU1)=0 | |
36734 | PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1) | |
36735 | C * +0.5D0*PHKK(1,NC2T) | |
36736 | *+XGIVE*PHKT(1,5+IIGLU1) | |
36737 | PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1) | |
36738 | C *+0.5D0*PHKK(2,NC2T) | |
36739 | *+XGIVE*PHKT(2,5+IIGLU1) | |
36740 | PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1) | |
36741 | C *+0.5D0*PHKK(3,NC2T) | |
36742 | *+XGIVE*PHKT(3,5+IIGLU1) | |
36743 | PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1) | |
36744 | C *+0.5D0*PHKK(4,NC2T) | |
36745 | *+XGIVE*PHKT(4,5+IIGLU1) | |
36746 | C PHKT(5,2) =PHKK(5,NC1T) | |
36747 | XXMIST=(PHKT(4,2+IIGLU1)**2- | |
36748 | * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2- | |
36749 | *PHKT(1,2+IIGLU1)**2) | |
36750 | IF(XXMIST.GT.0.D0)THEN | |
36751 | PHKT(5,2+IIGLU1) =SQRT(XXMIST) | |
36752 | ELSE | |
36753 | WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST | |
36754 | XXMIST=ABS(XXMIST) | |
36755 | PHKT(5,2+IIGLU1) =SQRT(XXMIST) | |
36756 | ENDIF | |
36757 | VHKT(1,2+IIGLU1) =VHKK(1,NC1T) | |
36758 | VHKT(2,2+IIGLU1) =VHKK(2,NC1T) | |
36759 | VHKT(3,2+IIGLU1) =VHKK(3,NC1T) | |
36760 | VHKT(4,2+IIGLU1) =VHKK(4,NC1T) | |
36761 | WHKT(1,2+IIGLU1) =WHKK(1,NC1T) | |
36762 | WHKT(2,2+IIGLU1) =WHKK(2,NC1T) | |
36763 | WHKT(3,2+IIGLU1) =WHKK(3,NC1T) | |
36764 | WHKT(4,2+IIGLU1) =WHKK(4,NC1T) | |
36765 | IDHKT(3+IIGLU1) =88888 | |
36766 | ISTHKT(3+IIGLU1) =96 | |
36767 | JMOHKT(1,3+IIGLU1)=1 | |
36768 | JMOHKT(2,3+IIGLU1)=2+IIGLU1 | |
36769 | JDAHKT(1,3+IIGLU1)=0 | |
36770 | JDAHKT(2,3+IIGLU1)=0 | |
36771 | PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1 | |
36772 | PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2 | |
36773 | PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3 | |
36774 | PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4 | |
36775 | PHKT(5,3+IIGLU1) | |
36776 | * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2 | |
36777 | * -PHKT(3,3+IIGLU1)**2) | |
36778 | IF(IPIP.EQ.3)THEN | |
36779 | WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1), | |
36780 | * JDAHKT(1,1), | |
36781 | *JDAHKT(2,1),(PHKT(III,1),III=1,5) | |
36782 | DO 71 IIG=2,2+IIGLU1-1 | |
36783 | WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG), | |
36784 | & JMOHKT(1,IIG),JMOHKT(2,IIG), | |
36785 | * JDAHKT(1,IIG), | |
36786 | *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) | |
36787 | 71 CONTINUE | |
36788 | WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1), | |
36789 | * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1), | |
36790 | *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5) | |
36791 | WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1), | |
36792 | * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1), | |
36793 | *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5) | |
36794 | ENDIF | |
36795 | CHAMAL=CHAB1 | |
36796 | IF(IPIP.EQ.1)THEN | |
36797 | IF(IPP11.GE.3.OR.IPP12.GE.3.OR.IP21.GE.3)CHAMAL=CHAB3 | |
36798 | ELSEIF(IPIP.EQ.2)THEN | |
36799 | IF(IPP11.LE.-3.OR.IPP12.LE.-3.OR.IP21.LE.-3)CHAMAL=CHAB3 | |
36800 | ENDIF | |
36801 | IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN | |
36802 | C IREJ=1 | |
36803 | IPCO=0 | |
36804 | C RETURN | |
36805 | GO TO 3466 | |
36806 | ENDIF | |
36807 | VHKT(1,3+IIGLU1) =VHKK(1,NC1) | |
36808 | VHKT(2,3+IIGLU1) =VHKK(2,NC1) | |
36809 | VHKT(3,3+IIGLU1) =VHKK(3,NC1) | |
36810 | VHKT(4,3+IIGLU1) =VHKK(4,NC1) | |
36811 | WHKT(1,3+IIGLU1) =WHKK(1,NC1) | |
36812 | WHKT(2,3+IIGLU1) =WHKK(2,NC1) | |
36813 | WHKT(3,3+IIGLU1) =WHKK(3,NC1) | |
36814 | WHKT(4,3+IIGLU1) =WHKK(4,NC1) | |
36815 | C IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+1 | |
36816 | IDHKT(7+IIGLU1) =IP1 | |
36817 | ISTHKT(7+IIGLU1) =961 | |
36818 | JMOHKT(1,7+IIGLU1)=NC1P | |
36819 | JMOHKT(2,7+IIGLU1)=0 | |
36820 | JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2 | |
36821 | JDAHKT(2,7+IIGLU1)=0 | |
36822 | PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1) | |
36823 | PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1) | |
36824 | PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1) | |
36825 | PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1) | |
36826 | C PHKT(5,7+IIGLU1) =PHKK(5,NC1P) | |
36827 | XXMIST=(PHKT(4,7+IIGLU1)**2- | |
36828 | * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2- | |
36829 | *PHKT(1,7+IIGLU1)**2) | |
36830 | IF(XXMIST.GT.0.D0)THEN | |
36831 | PHKT(5,7+IIGLU1) =SQRT(XXMIST) | |
36832 | ELSE | |
36833 | WRITE(LOUT,*)' MGSQBS2, XXMIST',XXMIST | |
36834 | XXMIST=ABS(XXMIST) | |
36835 | PHKT(5,7+IIGLU1) =SQRT(XXMIST) | |
36836 | ENDIF | |
36837 | VHKT(1,7+IIGLU1) =VHKK(1,NC1P) | |
36838 | VHKT(2,7+IIGLU1) =VHKK(2,NC1P) | |
36839 | VHKT(3,7+IIGLU1) =VHKK(3,NC1P) | |
36840 | VHKT(4,7+IIGLU1) =VHKK(4,NC1P) | |
36841 | WHKT(1,7+IIGLU1) =WHKK(1,NC1P) | |
36842 | WHKT(2,7+IIGLU1) =WHKK(2,NC1P) | |
36843 | WHKT(3,7+IIGLU1) =WHKK(3,NC1P) | |
36844 | WHKT(4,7+IIGLU1) =WHKK(4,NC2P) | |
36845 | C IDHKT(7) =1000*IPP1+100*ISQ+1 | |
36846 | C Insert here the IIGLU2 gluons | |
36847 | PG1=0.D0 | |
36848 | PG2=0.D0 | |
36849 | PG3=0.D0 | |
36850 | PG4=0.D0 | |
36851 | IF(IIGLU2.GE.1)THEN | |
36852 | JJG=NC2P | |
36853 | DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 | |
36854 | KKG=JJG+IIG-7-IIGLU1 | |
36855 | IDHKT(IIG) =IDHKK(KKG) | |
36856 | ISTHKT(IIG) =921 | |
36857 | JMOHKT(1,IIG)=KKG | |
36858 | JMOHKT(2,IIG)=0 | |
36859 | JDAHKT(1,IIG)=9+IIGLU1+IIGLU2 | |
36860 | JDAHKT(2,IIG)=0 | |
36861 | PHKT(1,IIG)=PHKK(1,KKG) | |
36862 | PG1=PG1+ PHKT(1,IIG) | |
36863 | PHKT(2,IIG)=PHKK(2,KKG) | |
36864 | PG2=PG2+ PHKT(2,IIG) | |
36865 | PHKT(3,IIG)=PHKK(3,KKG) | |
36866 | PG3=PG3+ PHKT(3,IIG) | |
36867 | PHKT(4,IIG)=PHKK(4,KKG) | |
36868 | PG4=PG4+ PHKT(4,IIG) | |
36869 | PHKT(5,IIG)=PHKK(5,KKG) | |
36870 | VHKT(1,IIG) =VHKK(1,KKG) | |
36871 | VHKT(2,IIG) =VHKK(2,KKG) | |
36872 | VHKT(3,IIG) =VHKK(3,KKG) | |
36873 | VHKT(4,IIG) =VHKK(4,KKG) | |
36874 | WHKT(1,IIG) =WHKK(1,KKG) | |
36875 | WHKT(2,IIG) =WHKK(2,KKG) | |
36876 | WHKT(3,IIG) =WHKK(3,KKG) | |
36877 | WHKT(4,IIG) =WHKK(4,KKG) | |
36878 | 81 CONTINUE | |
36879 | ENDIF | |
36880 | IF(IPIP.EQ.1)THEN | |
36881 | IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3 | |
36882 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103 | |
36883 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103 | |
36884 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203 | |
36885 | ELSEIF(IPIP.EQ.2)THEN | |
36886 | **NEW | |
36887 | C IDHKT(8) =1000*IPP2+100*(-ISQ1+6)-3 | |
36888 | IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3 | |
36889 | ** | |
36890 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103 | |
36891 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103 | |
36892 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203 | |
36893 | ENDIF | |
36894 | ISTHKT(8+IIGLU1+IIGLU2) =962 | |
36895 | JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T | |
36896 | JMOHKT(2,8+IIGLU1+IIGLU2)=0 | |
36897 | JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2 | |
36898 | JDAHKT(2,8+IIGLU1+IIGLU2)=0 | |
36899 | C PHKT(1,8) =0.5D0*PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ/(XDIQT+XSQ) | |
36900 | C PHKT(2,8) =0.5D0*PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ/(XDIQT+XSQ) | |
36901 | C PHKT(3,8) =0.5D0*PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ/(XDIQT+XSQ) | |
36902 | C PHKT(4,8) =0.5D0*PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ/(XDIQT+XSQ) | |
36903 | PHKT(1,8+IIGLU1+IIGLU2) = | |
36904 | * PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1) | |
36905 | PHKT(2,8+IIGLU1+IIGLU2) = | |
36906 | * PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1) | |
36907 | PHKT(3,8+IIGLU1+IIGLU2) = | |
36908 | * PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1) | |
36909 | PHKT(4,8+IIGLU1+IIGLU2) = | |
36910 | * PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1) | |
36911 | C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)', | |
36912 | C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7) | |
36913 | IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN | |
36914 | C IREJ=1 | |
36915 | C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)' | |
36916 | IPCO=0 | |
36917 | C RETURN | |
36918 | GO TO 3466 | |
36919 | ENDIF | |
36920 | C PHKT(5,8) =PHKK(5,NC2T) | |
36921 | PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2- | |
36922 | * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2- | |
36923 | *PHKT(1,8+IIGLU1+IIGLU2)**2) | |
36924 | VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T) | |
36925 | VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T) | |
36926 | VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T) | |
36927 | VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T) | |
36928 | WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T) | |
36929 | WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T) | |
36930 | WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T) | |
36931 | WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T) | |
36932 | IDHKT(9+IIGLU1+IIGLU2) =88888 | |
36933 | ISTHKT(9+IIGLU1+IIGLU2) =96 | |
36934 | JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1 | |
36935 | JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2 | |
36936 | JDAHKT(1,9+IIGLU1+IIGLU2)=0 | |
36937 | JDAHKT(2,9+IIGLU1+IIGLU2)=0 | |
36938 | PHKT(1,9+IIGLU1+IIGLU2) | |
36939 | * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1 | |
36940 | PHKT(2,9+IIGLU1+IIGLU2) | |
36941 | * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2 | |
36942 | PHKT(3,9+IIGLU1+IIGLU2) | |
36943 | * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3 | |
36944 | PHKT(4,9+IIGLU1+IIGLU2) | |
36945 | * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4 | |
36946 | PHKT(5,9+IIGLU1+IIGLU2) | |
36947 | * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2- | |
36948 | * PHKT(2,9+IIGLU1+IIGLU2)**2 | |
36949 | * -PHKT(3,9+IIGLU1+IIGLU2)**2) | |
36950 | IF(IPIP.GE.3)THEN | |
36951 | WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1), | |
36952 | * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1), | |
36953 | *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5) | |
36954 | DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 | |
36955 | WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG), | |
36956 | & JMOHKT(1,IIG),JMOHKT(2,IIG), | |
36957 | * JDAHKT(1,IIG), | |
36958 | *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) | |
36959 | 91 CONTINUE | |
36960 | WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2), | |
36961 | * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2), | |
36962 | *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2), | |
36963 | *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5) | |
36964 | WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2), | |
36965 | * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2), | |
36966 | *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2), | |
36967 | *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5) | |
36968 | ENDIF | |
36969 | CHAMAL=CHAB1 | |
36970 | IF(IPIP.EQ.1)THEN | |
36971 | IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3 | |
36972 | ELSEIF(IPIP.EQ.2)THEN | |
36973 | IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3 | |
36974 | ENDIF | |
36975 | IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN | |
36976 | C IREJ=1 | |
36977 | IPCO=0 | |
36978 | C RETURN | |
36979 | GO TO 3466 | |
36980 | ENDIF | |
36981 | VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1) | |
36982 | VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1) | |
36983 | VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1) | |
36984 | VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1) | |
36985 | WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1) | |
36986 | WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1) | |
36987 | WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1) | |
36988 | WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1) | |
36989 | C | |
36990 | IPCO=0 | |
36991 | IGCOUN=9+IIGLU1+IIGLU2 | |
36992 | RETURN | |
36993 | END | |
36994 | ||
36995 | *$ CREATE MUSQBS1.FOR | |
36996 | *COPY MUSQBS1 | |
36997 | C | |
36998 | C | |
36999 | C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ | |
37000 | SUBROUTINE MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, | |
37001 | * IP11,IP12,IP2,IPP1,IPP2,IPIP,ISQ,IGCOUN) | |
37002 | C | |
37003 | C USQBS-1 diagram (split projectile diquark) | |
37004 | C | |
37005 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
37006 | SAVE | |
37007 | ||
37008 | PARAMETER ( LINP = 10 , | |
37009 | & LOUT = 6 , | |
37010 | & LDAT = 9 ) | |
37011 | ||
37012 | * event history | |
37013 | ||
37014 | PARAMETER (NMXHKK=200000) | |
37015 | ||
37016 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
37017 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
37018 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
37019 | ||
37020 | * extended event history | |
37021 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
37022 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
37023 | & IHIST(2,NMXHKK) | |
37024 | ||
37025 | * Lorentz-parameters of the current interaction | |
37026 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
37027 | & UMO,PPCM,EPROJ,PPROJ | |
37028 | ||
37029 | * diquark-breaking mechanism | |
37030 | COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3 | |
37031 | ||
37032 | C | |
37033 | PARAMETER (NTMHKK= 300) | |
37034 | COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT | |
37035 | +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT | |
37036 | +(4,NTMHKK) | |
37037 | *KEEP,XSEADI. | |
37038 | COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA, | |
37039 | +SSMIMQ,VVMTHR | |
37040 | *KEEP,DPRIN. | |
37041 | COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR | |
37042 | COMMON /EVFLAG/ NUMEV | |
37043 | C | |
37044 | C USQBS-1 diagram (split projectile diquark) | |
37045 | C | |
37046 | C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T) | |
37047 | C Input chain 2(NC2) sea-quark(NC2P)-sea-antiquark(NC2T) | |
37048 | C | |
37049 | C Create quark(qsP)-antiquark(aqsT) pair, energy from NC1P and NC1T | |
37050 | C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P | |
37051 | C | |
37052 | C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2) | |
37053 | C 6 valence quark(vq2P 4)-sea-quark(aqsT 5) | |
37054 | C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8) | |
37055 | C | |
37056 | C Put new chains into COMMON /HKKTMP/ | |
37057 | C | |
37058 | IIGLU1=NC1T-NC1P-1 | |
37059 | IIGLU2=NC2T-NC2P-1 | |
37060 | IGCOUN=0 | |
37061 | C WRITE(6,*)'MUSQBS1: IIGLU1,IIGLU2,IPIP ',IIGLU1,IIGLU2,IPIP | |
37062 | CVQ=1.D0 | |
37063 | IREJ=0 | |
37064 | IF(IPIP.EQ.3)THEN | |
37065 | C IF(NUMEV.EQ.-324)THEN | |
37066 | WRITE(LOUT,*)' MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,', | |
37067 | * ' IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN)', | |
37068 | *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, | |
37069 | * IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN | |
37070 | ENDIF | |
37071 | C | |
37072 | C | |
37073 | C | |
37074 | C determine x-values of NC1P diquark | |
37075 | XDIQP=PHKK(4,NC1P)*2.D0/UMO | |
37076 | XVQT=PHKK(4,NC1T)*2.D0/UMO | |
37077 | C | |
37078 | C determine x-values of sea quark pair | |
37079 | C | |
37080 | IPCO=1 | |
37081 | ICOU=0 | |
37082 | 2234 CONTINUE | |
37083 | ICOU=ICOU+1 | |
37084 | IF(ICOU.GE.500)THEN | |
37085 | IREJ=1 | |
37086 | IF(ISQ.EQ.3)IREJ=3 | |
37087 | IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 2234 ICOU. GT.100' | |
37088 | IPCO=0 | |
37089 | RETURN | |
37090 | ENDIF | |
37091 | IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 call XSEAPA: UMO,XDIQP,XVQT ', | |
37092 | * UMO, XDIQP,XVQT | |
37093 | XSQ=0.D0 | |
37094 | XSAQ=0.D0 | |
37095 | **NEW | |
37096 | C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ) | |
37097 | IF (IPIP.EQ.1) THEN | |
37098 | XQMAX = XDIQP/2.0D0 | |
37099 | XAQMAX = 2.D0*XVQT/3.0D0 | |
37100 | ELSE | |
37101 | XQMAX = 2.D0*XVQT/3.0D0 | |
37102 | XAQMAX = XDIQP/2.0D0 | |
37103 | ENDIF | |
37104 | CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ) | |
37105 | ISAQ = 6+ISQ | |
37106 | C write(*,*) 'MUSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT | |
37107 | ** | |
37108 | IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ | |
37109 | IF(IREJ.GE.1)THEN | |
37110 | IF(IPCO.GE.3) | |
37111 | & WRITE(LOUT,*)'MUSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ | |
37112 | IPCO=0 | |
37113 | RETURN | |
37114 | ENDIF | |
37115 | IF(IPIP.EQ.1)THEN | |
37116 | IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234 | |
37117 | ELSEIF(IPIP.EQ.2)THEN | |
37118 | IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234 | |
37119 | ENDIF | |
37120 | IF(IPCO.GE.3)THEN | |
37121 | WRITE(LOUT,'(A,4E12.4)')' MUSQBS1 XDIQP,XVQT,XSQ,XSAQ ', | |
37122 | & XDIQP,XVQT,XSQ,XSAQ | |
37123 | ENDIF | |
37124 | C | |
37125 | C subtract xsq,xsaq from NC1P diquark and NC1T quark | |
37126 | C | |
37127 | C XSQ=0.D0 | |
37128 | IF(IPIP.EQ.1)THEN | |
37129 | XDIQP=XDIQP-XSQ | |
37130 | XVQT =XVQT -XSAQ | |
37131 | ELSEIF(IPIP.EQ.2)THEN | |
37132 | XDIQP=XDIQP-XSAQ | |
37133 | XVQT =XVQT -XSQ | |
37134 | ENDIF | |
37135 | IF(IPCO.GE.3) | |
37136 | & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT | |
37137 | C | |
37138 | C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P | |
37139 | C | |
37140 | XVTHRO=CVQ/UMO | |
37141 | IVTHR=0 | |
37142 | 3466 CONTINUE | |
37143 | IF(IVTHR.EQ.10)THEN | |
37144 | IREJ=1 | |
37145 | IF(ISQ.EQ.3)IREJ=3 | |
37146 | IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 3466 reject IVTHR 10' | |
37147 | IPCO=0 | |
37148 | RETURN | |
37149 | ENDIF | |
37150 | IVTHR=IVTHR+1 | |
37151 | XVTHR=XVTHRO/(201-IVTHR) | |
37152 | UNOPRV=UNON | |
37153 | 380 CONTINUE | |
37154 | IF(XVTHR.GT.0.66D0*XDIQP)THEN | |
37155 | IREJ=1 | |
37156 | IF(ISQ.EQ.3)IREJ=3 | |
37157 | IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 380 XVTHR large', | |
37158 | * XVTHR | |
37159 | IPCO=0 | |
37160 | RETURN | |
37161 | ENDIF | |
37162 | IF(DT_RNDM(V).LT.0.5D0)THEN | |
37163 | XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP) | |
37164 | XVPQII=XDIQP-XVPQI | |
37165 | ELSE | |
37166 | XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP) | |
37167 | XVPQI=XDIQP-XVPQII | |
37168 | ENDIF | |
37169 | IF(IPCO.GE.3)THEN | |
37170 | WRITE(LOUT,'(A,2E12.4)')' MUSQBS1:XVPQI,XVPQII ',XVPQI,XVPQII | |
37171 | ENDIF | |
37172 | C | |
37173 | C Prepare 4 momenta of new chains and chain ends | |
37174 | C | |
37175 | C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT | |
37176 | C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT | |
37177 | C +(4,NTMHKK) | |
37178 | C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2) | |
37179 | C 6 valence quark(vq2P 4)-sea-quark(aqsT 5) | |
37180 | C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8) | |
37181 | IF(IPIP.EQ.1)THEN | |
37182 | XSQ1=XSQ | |
37183 | XSAQ1=XSAQ | |
37184 | ISQ1=ISQ | |
37185 | ISAQ1=ISAQ | |
37186 | ELSEIF(IPIP.EQ.2)THEN | |
37187 | XSQ1=XSAQ | |
37188 | XSAQ1=XSQ | |
37189 | ISQ1=ISAQ | |
37190 | ISAQ1=ISQ | |
37191 | ENDIF | |
37192 | IDHKT(1) =IP11 | |
37193 | ISTHKT(1) =931 | |
37194 | JMOHKT(1,1)=NC1P | |
37195 | JMOHKT(2,1)=0 | |
37196 | JDAHKT(1,1)=3+IIGLU1 | |
37197 | JDAHKT(2,1)=0 | |
37198 | C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2) | |
37199 | PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1) | |
37200 | PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1) | |
37201 | PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1) | |
37202 | PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1) | |
37203 | C PHKT(5,1) =PHKK(5,NC1P) | |
37204 | XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2- | |
37205 | *PHKT(1,1)**2) | |
37206 | IF(XMIST.GE.0.D0)THEN | |
37207 | PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2- | |
37208 | *PHKT(1,1)**2) | |
37209 | ELSE | |
37210 | C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST | |
37211 | PHKT(5,1)=0.D0 | |
37212 | ENDIF | |
37213 | VHKT(1,1) =VHKK(1,NC1P) | |
37214 | VHKT(2,1) =VHKK(2,NC1P) | |
37215 | VHKT(3,1) =VHKK(3,NC1P) | |
37216 | VHKT(4,1) =VHKK(4,NC1P) | |
37217 | WHKT(1,1) =WHKK(1,NC1P) | |
37218 | WHKT(2,1) =WHKK(2,NC1P) | |
37219 | WHKT(3,1) =WHKK(3,NC1P) | |
37220 | WHKT(4,1) =WHKK(4,NC1P) | |
37221 | C Add here IIGLU1 gluons to this chaina | |
37222 | PG1=0.D0 | |
37223 | PG2=0.D0 | |
37224 | PG3=0.D0 | |
37225 | PG4=0.D0 | |
37226 | IF(IIGLU1.GE.1)THEN | |
37227 | JJG=NC1P | |
37228 | DO 61 IIG=2,2+IIGLU1-1 | |
37229 | KKG=JJG+IIG-1 | |
37230 | IDHKT(IIG) =IDHKK(KKG) | |
37231 | ISTHKT(IIG) =921 | |
37232 | JMOHKT(1,IIG)=KKG | |
37233 | JMOHKT(2,IIG)=0 | |
37234 | JDAHKT(1,IIG)=3+IIGLU1 | |
37235 | JDAHKT(2,IIG)=0 | |
37236 | PHKT(1,IIG)=PHKK(1,KKG) | |
37237 | PG1=PG1+ PHKT(1,IIG) | |
37238 | PHKT(2,IIG)=PHKK(2,KKG) | |
37239 | PG2=PG2+ PHKT(2,IIG) | |
37240 | PHKT(3,IIG)=PHKK(3,KKG) | |
37241 | PG3=PG3+ PHKT(3,IIG) | |
37242 | PHKT(4,IIG)=PHKK(4,KKG) | |
37243 | PG4=PG4+ PHKT(4,IIG) | |
37244 | PHKT(5,IIG)=PHKK(5,KKG) | |
37245 | VHKT(1,IIG) =VHKK(1,KKG) | |
37246 | VHKT(2,IIG) =VHKK(2,KKG) | |
37247 | VHKT(3,IIG) =VHKK(3,KKG) | |
37248 | VHKT(4,IIG) =VHKK(4,KKG) | |
37249 | WHKT(1,IIG) =WHKK(1,KKG) | |
37250 | WHKT(2,IIG) =WHKK(2,KKG) | |
37251 | WHKT(3,IIG) =WHKK(3,KKG) | |
37252 | WHKT(4,IIG) =WHKK(4,KKG) | |
37253 | 61 CONTINUE | |
37254 | ENDIF | |
37255 | IDHKT(2+IIGLU1) =IPP2 | |
37256 | ISTHKT(2+IIGLU1) =932 | |
37257 | JMOHKT(1,2+IIGLU1)=NC2T | |
37258 | JMOHKT(2,2+IIGLU1)=0 | |
37259 | JDAHKT(1,2+IIGLU1)=3+IIGLU1 | |
37260 | JDAHKT(2,2+IIGLU1)=0 | |
37261 | PHKT(1,2+IIGLU1) =PHKK(1,NC2T) | |
37262 | PHKT(2,2+IIGLU1) =PHKK(2,NC2T) | |
37263 | PHKT(3,2+IIGLU1) =PHKK(3,NC2T) | |
37264 | PHKT(4,2+IIGLU1) =PHKK(4,NC2T) | |
37265 | C PHKT(5,2+IIGLU1) =PHKK(5,NC2T) | |
37266 | XMIST=(PHKT(4,2+IIGLU1)**2- | |
37267 | * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2- | |
37268 | *PHKT(1,2+IIGLU1)**2) | |
37269 | IF(XMIST.GT.0.D0)THEN | |
37270 | PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2- | |
37271 | * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2- | |
37272 | *PHKT(1,2+IIGLU1)**2) | |
37273 | ELSE | |
37274 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST | |
37275 | PHKT(5,2+IIGLU1)=0.D0 | |
37276 | ENDIF | |
37277 | VHKT(1,2+IIGLU1) =VHKK(1,NC2T) | |
37278 | VHKT(2,2+IIGLU1) =VHKK(2,NC2T) | |
37279 | VHKT(3,2+IIGLU1) =VHKK(3,NC2T) | |
37280 | VHKT(4,2+IIGLU1) =VHKK(4,NC2T) | |
37281 | WHKT(1,2+IIGLU1) =WHKK(1,NC2T) | |
37282 | WHKT(2,2+IIGLU1) =WHKK(2,NC2T) | |
37283 | WHKT(3,2+IIGLU1) =WHKK(3,NC2T) | |
37284 | WHKT(4,2+IIGLU1) =WHKK(4,NC2T) | |
37285 | IDHKT(3+IIGLU1) =88888 | |
37286 | ISTHKT(3+IIGLU1) =94 | |
37287 | JMOHKT(1,3+IIGLU1)=1 | |
37288 | JMOHKT(2,3+IIGLU1)=2+IIGLU1 | |
37289 | JDAHKT(1,3+IIGLU1)=0 | |
37290 | JDAHKT(2,3+IIGLU1)=0 | |
37291 | PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1 | |
37292 | PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2 | |
37293 | PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3 | |
37294 | PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4 | |
37295 | XMIST | |
37296 | * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2 | |
37297 | * -PHKT(3,3+IIGLU1)**2) | |
37298 | IF(XMIST.GE.0.D0)THEN | |
37299 | PHKT(5,3+IIGLU1) | |
37300 | * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2 | |
37301 | * -PHKT(3,3+IIGLU1)**2) | |
37302 | ELSE | |
37303 | C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST | |
37304 | PHKT(5,1)=0.D0 | |
37305 | ENDIF | |
37306 | IF(IPIP.GE.3)THEN | |
37307 | C IF(NUMEV.EQ.-324)THEN | |
37308 | WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1), | |
37309 | * JMOHKT(2,1),JDAHKT(1,1), | |
37310 | *JDAHKT(2,1),(PHKT(III,1),III=1,5) | |
37311 | DO 71 IIG=2,2+IIGLU1-1 | |
37312 | WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG), | |
37313 | & JMOHKT(1,IIG),JMOHKT(2,IIG), | |
37314 | * JDAHKT(1,IIG), | |
37315 | *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) | |
37316 | 71 CONTINUE | |
37317 | WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1), | |
37318 | * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1), | |
37319 | *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5) | |
37320 | WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1), | |
37321 | * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1), | |
37322 | *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5) | |
37323 | ENDIF | |
37324 | CHAMAL=CHAM1 | |
37325 | IF(IPIP.EQ.1)THEN | |
37326 | IF(IP11.GE.3.OR.IPP2.GE.3)CHAMAL=CHAM3 | |
37327 | ELSEIF(IPIP.EQ.2)THEN | |
37328 | IF(IP11.LE.-3.OR.IPP2.LE.-3)CHAMAL=CHAM3 | |
37329 | ENDIF | |
37330 | IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN | |
37331 | C IREJ=1 | |
37332 | IPCO=0 | |
37333 | C RETURN | |
37334 | C WRITE(6,*)' MUSQBS1 jump back from chain 3' | |
37335 | GO TO 3466 | |
37336 | ENDIF | |
37337 | VHKT(1,3+IIGLU1) =VHKK(1,NC1) | |
37338 | VHKT(2,3+IIGLU1) =VHKK(2,NC1) | |
37339 | VHKT(3,3+IIGLU1) =VHKK(3,NC1) | |
37340 | VHKT(4,3+IIGLU1) =VHKK(4,NC1) | |
37341 | WHKT(1,3+IIGLU1) =WHKK(1,NC1) | |
37342 | WHKT(2,3+IIGLU1) =WHKK(2,NC1) | |
37343 | WHKT(3,3+IIGLU1) =WHKK(3,NC1) | |
37344 | WHKT(4,3+IIGLU1) =WHKK(4,NC1) | |
37345 | IDHKT(4+IIGLU1) =IP12 | |
37346 | ISTHKT(4+IIGLU1) =931 | |
37347 | JMOHKT(1,4+IIGLU1)=NC1P | |
37348 | JMOHKT(2,4+IIGLU1)=0 | |
37349 | JDAHKT(1,4+IIGLU1)=6+IIGLU1 | |
37350 | JDAHKT(2,4+IIGLU1)=0 | |
37351 | C create chain 6 valence quark(vq2P 4)-sea-quark(aqsT 5) | |
37352 | PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1) | |
37353 | PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1) | |
37354 | PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1) | |
37355 | PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1) | |
37356 | C PHKT(5,4+IIGLU1) =PHKK(5,NC1P) | |
37357 | XMIST =(PHKT(4,4+IIGLU1)**2- | |
37358 | * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2- | |
37359 | *PHKT(1,4+IIGLU1)**2) | |
37360 | IF(XMIST.GT.0.D0)THEN | |
37361 | PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2- | |
37362 | * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2- | |
37363 | *PHKT(1,4+IIGLU1)**2) | |
37364 | ELSE | |
37365 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST | |
37366 | PHKT(5,4+IIGLU1)=0.D0 | |
37367 | ENDIF | |
37368 | VHKT(1,4+IIGLU1) =VHKK(1,NC1P) | |
37369 | VHKT(2,4+IIGLU1) =VHKK(2,NC1P) | |
37370 | VHKT(3,4+IIGLU1) =VHKK(3,NC1P) | |
37371 | VHKT(4,4+IIGLU1) =VHKK(4,NC1P) | |
37372 | WHKT(1,4+IIGLU1) =WHKK(1,NC1P) | |
37373 | WHKT(2,4+IIGLU1) =WHKK(2,NC1P) | |
37374 | WHKT(3,4+IIGLU1) =WHKK(3,NC1P) | |
37375 | WHKT(4,4+IIGLU1) =WHKK(4,NC1P) | |
37376 | IF(IPIP.EQ.1)THEN | |
37377 | IDHKT(5+IIGLU1) =-(ISAQ1-6) | |
37378 | ELSEIF(IPIP.EQ.2)THEN | |
37379 | IDHKT(5+IIGLU1) =ISAQ1 | |
37380 | ENDIF | |
37381 | ISTHKT(5+IIGLU1) =932 | |
37382 | JMOHKT(1,5+IIGLU1)=NC1T | |
37383 | JMOHKT(2,5+IIGLU1)=0 | |
37384 | JDAHKT(1,5+IIGLU1)=6+IIGLU1 | |
37385 | JDAHKT(2,5+IIGLU1)=0 | |
37386 | PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1) | |
37387 | PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1) | |
37388 | PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1) | |
37389 | PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1) | |
37390 | C IF( PHKT(4,5).EQ.0.D0)THEN | |
37391 | C IREJ=1 | |
37392 | CIPCO=0 | |
37393 | CRETURN | |
37394 | C ENDIF | |
37395 | C PHKT(5,5) =PHKK(5,NC1T) | |
37396 | XMIST=(PHKT(4,5+IIGLU1)**2- | |
37397 | * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2- | |
37398 | *PHKT(1,5+IIGLU1)**2) | |
37399 | IF(XMIST.GT.0.D0)THEN | |
37400 | PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2- | |
37401 | * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2- | |
37402 | *PHKT(1,5+IIGLU1)**2) | |
37403 | ELSE | |
37404 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST | |
37405 | PHKT(5,5+IIGLU1)=0.D0 | |
37406 | ENDIF | |
37407 | VHKT(1,5+IIGLU1) =VHKK(1,NC1T) | |
37408 | VHKT(2,5+IIGLU1) =VHKK(2,NC1T) | |
37409 | VHKT(3,5+IIGLU1) =VHKK(3,NC1T) | |
37410 | VHKT(4,5+IIGLU1) =VHKK(4,NC1T) | |
37411 | WHKT(1,5+IIGLU1) =WHKK(1,NC1T) | |
37412 | WHKT(2,5+IIGLU1) =WHKK(2,NC1T) | |
37413 | WHKT(3,5+IIGLU1) =WHKK(3,NC1T) | |
37414 | WHKT(4,5+IIGLU1) =WHKK(4,NC1T) | |
37415 | IDHKT(6+IIGLU1) =88888 | |
37416 | ISTHKT(6+IIGLU1) =94 | |
37417 | JMOHKT(1,6+IIGLU1)=4+IIGLU1 | |
37418 | JMOHKT(2,6+IIGLU1)=5+IIGLU1 | |
37419 | JDAHKT(1,6+IIGLU1)=0 | |
37420 | JDAHKT(2,6+IIGLU1)=0 | |
37421 | PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1) | |
37422 | PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1) | |
37423 | PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1) | |
37424 | PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1) | |
37425 | XMIST | |
37426 | * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2 | |
37427 | * -PHKT(3,6+IIGLU1)**2) | |
37428 | IF(XMIST.GE.0.D0)THEN | |
37429 | PHKT(5,6+IIGLU1) | |
37430 | * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2 | |
37431 | * -PHKT(3,6+IIGLU1)**2) | |
37432 | ELSE | |
37433 | C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST | |
37434 | PHKT(5,1)=0.D0 | |
37435 | ENDIF | |
37436 | C IF(IPIP.EQ.3)THEN | |
37437 | CHAMAL=CHAM1 | |
37438 | IF(IPIP.EQ.1)THEN | |
37439 | IF(IP12.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3 | |
37440 | ELSEIF(IPIP.EQ.2)THEN | |
37441 | IF(IP12.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3 | |
37442 | ENDIF | |
37443 | IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN | |
37444 | C IREJ=1 | |
37445 | IPCO=0 | |
37446 | C RETURN | |
37447 | C WRITE(6,*)' MGSQBS1 jump back from chain 6', | |
37448 | C & CHAMAL,PHKT(5,6+IIGLU1) | |
37449 | GO TO 3466 | |
37450 | ENDIF | |
37451 | IF(IPIP.GE.3)THEN | |
37452 | C IF(NUMEV.EQ.-324)THEN | |
37453 | WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1), | |
37454 | * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1), | |
37455 | *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5) | |
37456 | WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1), | |
37457 | * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1), | |
37458 | *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5) | |
37459 | WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1), | |
37460 | * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1), | |
37461 | *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5) | |
37462 | ENDIF | |
37463 | VHKT(1,6+IIGLU1) =VHKK(1,NC1) | |
37464 | VHKT(2,6+IIGLU1) =VHKK(2,NC1) | |
37465 | VHKT(3,6+IIGLU1) =VHKK(3,NC1) | |
37466 | VHKT(4,6+IIGLU1) =VHKK(4,NC1) | |
37467 | WHKT(1,6+IIGLU1) =WHKK(1,NC1) | |
37468 | WHKT(2,6+IIGLU1) =WHKK(2,NC1) | |
37469 | WHKT(3,6+IIGLU1) =WHKK(3,NC1) | |
37470 | WHKT(4,6+IIGLU1) =WHKK(4,NC1) | |
37471 | IF(IPIP.EQ.1)THEN | |
37472 | IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+3 | |
37473 | IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103 | |
37474 | IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103 | |
37475 | IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203 | |
37476 | ELSEIF(IPIP.EQ.2)THEN | |
37477 | IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3 | |
37478 | IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103 | |
37479 | IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103 | |
37480 | IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203 | |
37481 | C WRITE(6,*)'IDHKT(7+IIGLU1),IPP1,ISQ1',IDHKT(7+IIGLU1),IPP1,ISQ1 | |
37482 | ENDIF | |
37483 | ISTHKT(7+IIGLU1) =931 | |
37484 | JMOHKT(1,7+IIGLU1)=NC2P | |
37485 | JMOHKT(2,7+IIGLU1)=0 | |
37486 | JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2 | |
37487 | JDAHKT(2,7+IIGLU1)=0 | |
37488 | C create chain 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8) | |
37489 | PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1) | |
37490 | PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1) | |
37491 | PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1) | |
37492 | PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1) | |
37493 | C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)', | |
37494 | C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7) | |
37495 | IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN | |
37496 | C IREJ=1 | |
37497 | C WRITE(6,*)'reject PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P)' | |
37498 | IPCO=0 | |
37499 | C RETURN | |
37500 | GO TO 3466 | |
37501 | ENDIF | |
37502 | C PHKT(5,7) =PHKK(5,NC2P) | |
37503 | PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2- | |
37504 | * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2- | |
37505 | *PHKT(1,7+IIGLU1)**2) | |
37506 | VHKT(1,7+IIGLU1) =VHKK(1,NC2P) | |
37507 | VHKT(2,7+IIGLU1) =VHKK(2,NC2P) | |
37508 | VHKT(3,7+IIGLU1) =VHKK(3,NC2P) | |
37509 | VHKT(4,7+IIGLU1) =VHKK(4,NC2P) | |
37510 | WHKT(1,7+IIGLU1) =WHKK(1,NC2P) | |
37511 | WHKT(2,7+IIGLU1) =WHKK(2,NC2P) | |
37512 | WHKT(3,7+IIGLU1) =WHKK(3,NC2P) | |
37513 | WHKT(4,7+IIGLU1) =WHKK(4,NC2P) | |
37514 | C Insert here the IIGLU2 gluons | |
37515 | PG1=0.D0 | |
37516 | PG2=0.D0 | |
37517 | PG3=0.D0 | |
37518 | PG4=0.D0 | |
37519 | IF(IIGLU2.GE.1)THEN | |
37520 | JJG=NC2P | |
37521 | DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 | |
37522 | KKG=JJG+IIG-7-IIGLU1 | |
37523 | IDHKT(IIG) =IDHKK(KKG) | |
37524 | ISTHKT(IIG) =921 | |
37525 | JMOHKT(1,IIG)=KKG | |
37526 | JMOHKT(2,IIG)=0 | |
37527 | JDAHKT(1,IIG)=9+IIGLU1+IIGLU2 | |
37528 | JDAHKT(2,IIG)=0 | |
37529 | PHKT(1,IIG)=PHKK(1,KKG) | |
37530 | PG1=PG1+ PHKT(1,IIG) | |
37531 | PHKT(2,IIG)=PHKK(2,KKG) | |
37532 | PG2=PG2+ PHKT(2,IIG) | |
37533 | PHKT(3,IIG)=PHKK(3,KKG) | |
37534 | PG3=PG3+ PHKT(3,IIG) | |
37535 | PHKT(4,IIG)=PHKK(4,KKG) | |
37536 | PG4=PG4+ PHKT(4,IIG) | |
37537 | PHKT(5,IIG)=PHKK(5,KKG) | |
37538 | VHKT(1,IIG) =VHKK(1,KKG) | |
37539 | VHKT(2,IIG) =VHKK(2,KKG) | |
37540 | VHKT(3,IIG) =VHKK(3,KKG) | |
37541 | VHKT(4,IIG) =VHKK(4,KKG) | |
37542 | WHKT(1,IIG) =WHKK(1,KKG) | |
37543 | WHKT(2,IIG) =WHKK(2,KKG) | |
37544 | WHKT(3,IIG) =WHKK(3,KKG) | |
37545 | WHKT(4,IIG) =WHKK(4,KKG) | |
37546 | 81 CONTINUE | |
37547 | ENDIF | |
37548 | IDHKT(8+IIGLU1+IIGLU2) =IP2 | |
37549 | ISTHKT(8+IIGLU1+IIGLU2) =932 | |
37550 | JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T | |
37551 | JMOHKT(2,8+IIGLU1+IIGLU2)=0 | |
37552 | JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2 | |
37553 | JDAHKT(2,8+IIGLU1+IIGLU2)=0 | |
37554 | PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT) | |
37555 | PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT) | |
37556 | PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT) | |
37557 | PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT) | |
37558 | C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T) | |
37559 | XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2- | |
37560 | * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2- | |
37561 | *PHKT(1,8+IIGLU1+IIGLU2)**2) | |
37562 | IF(XMIST.GT.0.D0)THEN | |
37563 | PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2- | |
37564 | * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2- | |
37565 | *PHKT(1,8+IIGLU1+IIGLU2)**2) | |
37566 | ELSE | |
37567 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST | |
37568 | PHKT(5,8+IIGLU1+IIGLU2)=0.D0 | |
37569 | ENDIF | |
37570 | VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T) | |
37571 | VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T) | |
37572 | VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T) | |
37573 | VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T) | |
37574 | WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T) | |
37575 | WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T) | |
37576 | WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T) | |
37577 | WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T) | |
37578 | IDHKT(9+IIGLU1+IIGLU2) =88888 | |
37579 | ISTHKT(9+IIGLU1+IIGLU2) =94 | |
37580 | JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1 | |
37581 | JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2 | |
37582 | JDAHKT(1,9+IIGLU1+IIGLU2)=0 | |
37583 | JDAHKT(2,9+IIGLU1+IIGLU2)=0 | |
37584 | PHKT(1,9+IIGLU1+IIGLU2) | |
37585 | * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1 | |
37586 | PHKT(2,9+IIGLU1+IIGLU2) | |
37587 | * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2 | |
37588 | PHKT(3,9+IIGLU1+IIGLU2) | |
37589 | * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3 | |
37590 | PHKT(4,9+IIGLU1+IIGLU2) | |
37591 | * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4 | |
37592 | XMIST | |
37593 | *=(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2 | |
37594 | * -PHKT(2,9+IIGLU1+IIGLU2)**2 | |
37595 | * -PHKT(3,9+IIGLU1+IIGLU2)**2) | |
37596 | IF(XMIST.GE.0.D0)THEN | |
37597 | PHKT(5,9+IIGLU1+IIGLU2) | |
37598 | *=SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2 | |
37599 | * -PHKT(2,9+IIGLU1+IIGLU2)**2 | |
37600 | * -PHKT(3,9+IIGLU1+IIGLU2)**2) | |
37601 | ELSE | |
37602 | C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST | |
37603 | PHKT(5,1)=0.D0 | |
37604 | ENDIF | |
37605 | IF(IPIP.GE.3)THEN | |
37606 | C IF(NUMEV.EQ.-324)THEN | |
37607 | WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1), | |
37608 | * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1), | |
37609 | *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5) | |
37610 | DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 | |
37611 | WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG), | |
37612 | & JMOHKT(1,IIG),JMOHKT(2,IIG), | |
37613 | * JDAHKT(1,IIG), | |
37614 | *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) | |
37615 | 91 CONTINUE | |
37616 | WRITE(LOUT,*)8+IIGLU1+IIGLU2, | |
37617 | * ISTHKT(8+IIGLU1+IIGLU2),IDHKT(8+IIGLU1+IIGLU2), | |
37618 | * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2), | |
37619 | *JDAHKT(1,8+IIGLU1+IIGLU2), | |
37620 | *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5) | |
37621 | WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2), | |
37622 | * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2), | |
37623 | *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2), | |
37624 | *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5) | |
37625 | ENDIF | |
37626 | CHAMAL=CHAB1 | |
37627 | IF(IPIP.EQ.1)THEN | |
37628 | IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3 | |
37629 | ELSEIF(IPIP.EQ.2)THEN | |
37630 | IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3 | |
37631 | ENDIF | |
37632 | IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN | |
37633 | C IREJ=1 | |
37634 | IPCO=0 | |
37635 | C RETURN | |
37636 | C WRITE(6,*)' MGSQBS1 jump back from chain 9', | |
37637 | C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2) | |
37638 | GO TO 3466 | |
37639 | ENDIF | |
37640 | VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1) | |
37641 | VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1) | |
37642 | VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1) | |
37643 | VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1) | |
37644 | WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1) | |
37645 | WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1) | |
37646 | WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1) | |
37647 | WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1) | |
37648 | C | |
37649 | IPCO=0 | |
37650 | IGCOUN=9+IIGLU1+IIGLU2 | |
37651 | RETURN | |
37652 | END | |
37653 | ||
37654 | *$ CREATE MGSQBS1.FOR | |
37655 | *COPY MGSQBS1 | |
37656 | C | |
37657 | C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ | |
37658 | SUBROUTINE MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, | |
37659 | * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,ISQ,IGCOUN) | |
37660 | C | |
37661 | C GSQBS-1 diagram (split projectile diquark) | |
37662 | C | |
37663 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
37664 | SAVE | |
37665 | ||
37666 | PARAMETER ( LINP = 10 , | |
37667 | & LOUT = 6 , | |
37668 | & LDAT = 9 ) | |
37669 | ||
37670 | * event history | |
37671 | ||
37672 | PARAMETER (NMXHKK=200000) | |
37673 | ||
37674 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
37675 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
37676 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
37677 | ||
37678 | * extended event history | |
37679 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
37680 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
37681 | & IHIST(2,NMXHKK) | |
37682 | ||
37683 | * Lorentz-parameters of the current interaction | |
37684 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
37685 | & UMO,PPCM,EPROJ,PPROJ | |
37686 | ||
37687 | * diquark-breaking mechanism | |
37688 | COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3 | |
37689 | ||
37690 | C | |
37691 | PARAMETER (NTMHKK= 300) | |
37692 | COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT | |
37693 | +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT | |
37694 | +(4,NTMHKK) | |
37695 | *KEEP,XSEADI. | |
37696 | COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA, | |
37697 | +SSMIMQ,VVMTHR | |
37698 | *KEEP,DPRIN. | |
37699 | COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR | |
37700 | C | |
37701 | C GSQBS-1 diagram (split projectile diquark) | |
37702 | C | |
37703 | C | |
37704 | C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T) | |
37705 | C Input chain 2(NC2) sea-quark(NC2P)-valence-diquark(NC2T) | |
37706 | C | |
37707 | C Create quark(qs)-antiquark(aqs) pair energy from NC1P and NC1T | |
37708 | C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P | |
37709 | C | |
37710 | C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2) | |
37711 | C 6 valence quark(vq2P 4)-sea-quark(aqsP 5) | |
37712 | C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8) | |
37713 | C | |
37714 | C Put new chains into COMMON /HKKTMP/ | |
37715 | C | |
37716 | IIGLU1=NC1T-NC1P-1 | |
37717 | IIGLU2=NC2T-NC2P-1 | |
37718 | IGCOUN=0 | |
37719 | C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2 | |
37720 | CVQ=1.D0 | |
37721 | NNNC1=IDHKK(NC1)/1000 | |
37722 | MMMC1=IDHKK(NC1)-NNNC1*1000 | |
37723 | KKKC1=ISTHKK(NC1) | |
37724 | NNNC2=IDHKK(NC2)/1000 | |
37725 | MMMC2=IDHKK(NC2)-NNNC2*1000 | |
37726 | KKKC2=ISTHKK(NC2) | |
37727 | IREJ=0 | |
37728 | IF(IPIP.EQ.3)THEN | |
37729 | WRITE(LOUT,*)' MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,', | |
37730 | * ' IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN)', | |
37731 | *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, | |
37732 | * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN | |
37733 | ENDIF | |
37734 | C | |
37735 | C | |
37736 | C | |
37737 | C determine x-values of NC1P diquark | |
37738 | XDIQP=PHKK(4,NC1P)*2.D0/UMO | |
37739 | XVQT=PHKK(4,NC1T)*2.D0/UMO | |
37740 | C | |
37741 | C determine x-values of sea quark pair | |
37742 | C | |
37743 | IPCO=1 | |
37744 | ICOU=0 | |
37745 | 2234 CONTINUE | |
37746 | ICOU=ICOU+1 | |
37747 | IF(ICOU.GE.500)THEN | |
37748 | IREJ=1 | |
37749 | IF(ISQ.EQ.3)IREJ=3 | |
37750 | IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 Rejection 2234 ICOU. GT.100' | |
37751 | IPCO=0 | |
37752 | RETURN | |
37753 | ENDIF | |
37754 | IF(IPCO.GE.3)WRITE(LOUT,*)'MGSQBS1 call XSEAPA: UMO,XDIQP,XVQT ', | |
37755 | * UMO, XDIQP,XVQT | |
37756 | XSQ=0.D0 | |
37757 | XSAQ=0.D0 | |
37758 | **NEW | |
37759 | C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ) | |
37760 | IF (IPIP.EQ.1) THEN | |
37761 | XQMAX = XDIQP/2.0D0 | |
37762 | XAQMAX = 2.D0*XVQT/3.0D0 | |
37763 | ELSE | |
37764 | XQMAX = 2.D0*XVQT/3.0D0 | |
37765 | XAQMAX = XDIQP/2.0D0 | |
37766 | ENDIF | |
37767 | CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ) | |
37768 | ISAQ = 6+ISQ | |
37769 | C write(*,*) 'MGSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT | |
37770 | ** | |
37771 | IF(IPCO.GE.3) | |
37772 | & WRITE(LOUT,*)'MGSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ | |
37773 | IF(IREJ.GE.1)THEN | |
37774 | IF(IPCO.GE.3) | |
37775 | & WRITE(LOUT,*)'MGSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ | |
37776 | IPCO=0 | |
37777 | RETURN | |
37778 | ENDIF | |
37779 | IF(IPIP.EQ.1)THEN | |
37780 | IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234 | |
37781 | ELSEIF(IPIP.EQ.2)THEN | |
37782 | IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234 | |
37783 | ENDIF | |
37784 | IF(IPCO.GE.3)THEN | |
37785 | WRITE(LOUT,'(A,4E12.4)')' MGSQBS1 XDIQP,XVQT,XSQ,XSAQ ', | |
37786 | & XDIQP,XVQT,XSQ,XSAQ | |
37787 | ENDIF | |
37788 | C | |
37789 | C subtract xsq,xsaq from NC1P diquark and NC1T quark | |
37790 | C | |
37791 | C XSQ=0.D0 | |
37792 | IF(IPIP.EQ.1)THEN | |
37793 | XDIQP=XDIQP-XSQ | |
37794 | **NEW | |
37795 | C IF (XDIQP.LT.0.0D0) WRITE(*,*) ' mgsqbs1: XDIQP<0!!',XDIQP | |
37796 | ** | |
37797 | XVQT =XVQT -XSAQ | |
37798 | ELSEIF(IPIP.EQ.2)THEN | |
37799 | XDIQP=XDIQP-XSAQ | |
37800 | XVQT =XVQT -XSQ | |
37801 | ENDIF | |
37802 | IF(IPCO.GE.3) | |
37803 | & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT | |
37804 | C | |
37805 | C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P | |
37806 | C | |
37807 | XVTHRO=CVQ/UMO | |
37808 | IVTHR=0 | |
37809 | 3466 CONTINUE | |
37810 | IF(IVTHR.EQ.10)THEN | |
37811 | IREJ=1 | |
37812 | IF(ISQ.EQ.3)IREJ=3 | |
37813 | IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 3466 reject IVTHR 10' | |
37814 | IPCO=0 | |
37815 | RETURN | |
37816 | ENDIF | |
37817 | IVTHR=IVTHR+1 | |
37818 | XVTHR=XVTHRO/(201-IVTHR) | |
37819 | UNOPRV=UNON | |
37820 | 380 CONTINUE | |
37821 | IF(XVTHR.GT.0.66D0*XDIQP)THEN | |
37822 | IREJ=1 | |
37823 | IF(ISQ.EQ.3)IREJ=3 | |
37824 | IF(IPCO.GE.3) | |
37825 | & WRITE(LOUT,*)' MGSQBS1 Rejection 380 XVTHR large', | |
37826 | * XVTHR | |
37827 | IPCO=0 | |
37828 | RETURN | |
37829 | ENDIF | |
37830 | IF(DT_RNDM(V).LT.0.5D0)THEN | |
37831 | XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP) | |
37832 | XVPQII=XDIQP-XVPQI | |
37833 | ELSE | |
37834 | XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP) | |
37835 | XVPQI=XDIQP-XVPQII | |
37836 | ENDIF | |
37837 | IF(IPCO.GE.3)THEN | |
37838 | WRITE(LOUT,'(A,4E12.4)')' MGSQBS1:XVTHR,XDIQP,XVPQI,XVPQII ', | |
37839 | & XVTHR,XDIQP,XVPQI,XVPQII | |
37840 | ENDIF | |
37841 | C | |
37842 | C Prepare 4 momenta of new chains and chain ends | |
37843 | C | |
37844 | C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT | |
37845 | C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT | |
37846 | C +(4,NTMHKK) | |
37847 | C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2) | |
37848 | C 6 valence quark(vq2P 4)-sea-quark(aqsP 5) | |
37849 | C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8) | |
37850 | IF(IPIP.EQ.1)THEN | |
37851 | XSQ1=XSQ | |
37852 | XSAQ1=XSAQ | |
37853 | ISQ1=ISQ | |
37854 | ISAQ1=ISAQ | |
37855 | ELSEIF(IPIP.EQ.2)THEN | |
37856 | XSQ1=XSAQ | |
37857 | XSAQ1=XSQ | |
37858 | ISQ1=ISAQ | |
37859 | ISAQ1=ISQ | |
37860 | ENDIF | |
37861 | KK11=IP11 | |
37862 | C IDHKT(2) =1000*IPP21+100*IPP22+1 | |
37863 | KK21= IPP21 | |
37864 | KK22= IPP22 | |
37865 | XGIVE=0.D0 | |
37866 | IDHKT(4+IIGLU1) =IP12 | |
37867 | ISTHKT(4+IIGLU1) =921 | |
37868 | JMOHKT(1,4+IIGLU1)=NC1P | |
37869 | JMOHKT(2,4+IIGLU1)=0 | |
37870 | JDAHKT(1,4+IIGLU1)=6+IIGLU1 | |
37871 | JDAHKT(2,4+IIGLU1)=0 | |
37872 | **NEW | |
37873 | IF ((XDIQP.LT.0.0D0).OR.(XVPQII.LT.0.0D0).OR. | |
37874 | & (XSQ1.LT.0.0D0)) WRITE(LOUT,*) ' mgsqbs1: ',XDIQP,XVPQII,XSQ1 | |
37875 | ** | |
37876 | PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1) | |
37877 | PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1) | |
37878 | PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1) | |
37879 | PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1) | |
37880 | C PHKT(5,4+IIGLU1) =PHKK(5,NC1P) | |
37881 | XXMIST=(PHKT(4,4+IIGLU1)**2- | |
37882 | * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2- | |
37883 | * PHKT(1,4+IIGLU1)**2) | |
37884 | IF(XXMIST.GT.0.D0)THEN | |
37885 | PHKT(5,4+IIGLU1) =SQRT(XXMIST) | |
37886 | ELSE | |
37887 | WRITE(LOUT,*)'MGSQBS1 XXMIST',XXMIST | |
37888 | XXMIST=ABS(XXMIST) | |
37889 | PHKT(5,4+IIGLU1) =SQRT(XXMIST) | |
37890 | ENDIF | |
37891 | VHKT(1,4+IIGLU1) =VHKK(1,NC1P) | |
37892 | VHKT(2,4+IIGLU1) =VHKK(2,NC1P) | |
37893 | VHKT(3,4+IIGLU1) =VHKK(3,NC1P) | |
37894 | VHKT(4,4+IIGLU1) =VHKK(4,NC1P) | |
37895 | WHKT(1,4+IIGLU1) =WHKK(1,NC1P) | |
37896 | WHKT(2,4+IIGLU1) =WHKK(2,NC1P) | |
37897 | WHKT(3,4+IIGLU1) =WHKK(3,NC1P) | |
37898 | WHKT(4,4+IIGLU1) =WHKK(4,NC1P) | |
37899 | IF(IPIP.EQ.1)THEN | |
37900 | IDHKT(5+IIGLU1) =-(ISAQ1-6) | |
37901 | ELSEIF(IPIP.EQ.2)THEN | |
37902 | IDHKT(5+IIGLU1) =ISAQ1 | |
37903 | ENDIF | |
37904 | ISTHKT(5+IIGLU1) =922 | |
37905 | JMOHKT(1,5+IIGLU1)=NC1T | |
37906 | JMOHKT(2,5+IIGLU1)=0 | |
37907 | JDAHKT(1,5+IIGLU1)=6+IIGLU1 | |
37908 | JDAHKT(2,5+IIGLU1)=0 | |
37909 | **NEW | |
37910 | IF ((XSAQ1.LT.0.0D0).OR.(XVQT .LT.0.0D0)) | |
37911 | & WRITE(LOUT,*) ' mgsqbs2: ',XSAQ1,XVQT | |
37912 | ** | |
37913 | PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1) | |
37914 | PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1) | |
37915 | PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1) | |
37916 | PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1) | |
37917 | C PHKT(5,5+IIGLU1) =PHKK(5,NC1T) | |
37918 | XMIST=(PHKT(4,5+IIGLU1)**2- | |
37919 | * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2- | |
37920 | *PHKT(1,5+IIGLU1)**2) | |
37921 | IF(XMIST.GT.0.D0)THEN | |
37922 | PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2- | |
37923 | * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2- | |
37924 | *PHKT(1,5+IIGLU1)**2) | |
37925 | ELSE | |
37926 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST | |
37927 | PHKT(5,5+IIGLU1)=0.D0 | |
37928 | ENDIF | |
37929 | VHKT(1,5+IIGLU1) =VHKK(1,NC1T) | |
37930 | VHKT(2,5+IIGLU1) =VHKK(2,NC1T) | |
37931 | VHKT(3,5+IIGLU1) =VHKK(3,NC1T) | |
37932 | VHKT(4,5+IIGLU1) =VHKK(4,NC1T) | |
37933 | WHKT(1,5+IIGLU1) =WHKK(1,NC1T) | |
37934 | WHKT(2,5+IIGLU1) =WHKK(2,NC1T) | |
37935 | WHKT(3,5+IIGLU1) =WHKK(3,NC1T) | |
37936 | WHKT(4,5+IIGLU1) =WHKK(4,NC1T) | |
37937 | IDHKT(6+IIGLU1) =88888 | |
37938 | C IDHKT(6) =1000*NNNC1+MMMC1 | |
37939 | ISTHKT(6+IIGLU1) =93 | |
37940 | C ISTHKT(6) =KKKC1 | |
37941 | JMOHKT(1,6+IIGLU1)=4+IIGLU1 | |
37942 | JMOHKT(2,6+IIGLU1)=5+IIGLU1 | |
37943 | JDAHKT(1,6+IIGLU1)=0 | |
37944 | JDAHKT(2,6+IIGLU1)=0 | |
37945 | PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1) | |
37946 | PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1) | |
37947 | PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1) | |
37948 | PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1) | |
37949 | PHKT(5,6+IIGLU1) | |
37950 | * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2 | |
37951 | * -PHKT(3,6+IIGLU1)**2) | |
37952 | CHAMAL=CHAM1 | |
37953 | IF(IPIP.EQ.1)THEN | |
37954 | IF(IP12.GE.3.OR.ISAQ.GE.9)CHAMAL=CHAM3 | |
37955 | ELSEIF(IPIP.EQ.2)THEN | |
37956 | IF(IP12.LE.-3.OR.ISAQ.GE.3)CHAMAL=CHAM3 | |
37957 | ENDIF | |
37958 | IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN | |
37959 | IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN | |
37960 | C we drop chain 6 and give the energy to chain 3 | |
37961 | IDHKT(6+IIGLU1)=33888 | |
37962 | XGIVE=1.D0 | |
37963 | C WRITE(6,*)' drop chain 6 xgive=1' | |
37964 | GO TO 7788 | |
37965 | ELSEIF(IDHKT(5+IIGLU1).EQ.-IP11)THEN | |
37966 | C we drop chain 6 and give the energy to chain 3 | |
37967 | C and change KK11 to IDHKT(4) | |
37968 | IDHKT(6+IIGLU1)=33888 | |
37969 | XGIVE=1.D0 | |
37970 | C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(4+IIGLU1)' | |
37971 | KK11=IDHKT(4+IIGLU1) | |
37972 | GO TO 7788 | |
37973 | ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP21)THEN | |
37974 | C we drop chain 6 and give the energy to chain 3 | |
37975 | C and change KK21 to IDHKT(4) | |
37976 | C IDHKT(2) =1000*IPP21+100*IPP22+1 | |
37977 | IDHKT(6+IIGLU1)=33888 | |
37978 | XGIVE=1.D0 | |
37979 | C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(4+IIGLU1)' | |
37980 | KK21=IDHKT(4+IIGLU1) | |
37981 | GO TO 7788 | |
37982 | ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP22)THEN | |
37983 | C we drop chain 6 and give the energy to chain 3 | |
37984 | C and change KK22 to IDHKT(4) | |
37985 | C IDHKT(2) =1000*IPP21+100*IPP22+1 | |
37986 | IDHKT(6+IIGLU1)=33888 | |
37987 | XGIVE=1.D0 | |
37988 | C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(4+IIGLU1)' | |
37989 | KK22=IDHKT(4+IIGLU1) | |
37990 | GO TO 7788 | |
37991 | ENDIF | |
37992 | C IREJ=1 | |
37993 | IPCO=0 | |
37994 | C RETURN | |
37995 | C WRITE(6,*)' MGSQBS1 jump back from chain 6' | |
37996 | GO TO 3466 | |
37997 | ENDIF | |
37998 | 7788 CONTINUE | |
37999 | IF(IPIP.GE.3)THEN | |
38000 | WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1), | |
38001 | * JMOHKT(1,4+IIGLU1), | |
38002 | * JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1), | |
38003 | *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5) | |
38004 | WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1), | |
38005 | * JMOHKT(1,5+IIGLU1), | |
38006 | * JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1), | |
38007 | *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5) | |
38008 | WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1), | |
38009 | * JMOHKT(1,6+IIGLU1), | |
38010 | * JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1), | |
38011 | *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5) | |
38012 | ENDIF | |
38013 | VHKT(1,6+IIGLU1) =VHKK(1,NC1) | |
38014 | VHKT(2,6+IIGLU1) =VHKK(2,NC1) | |
38015 | VHKT(3,6+IIGLU1) =VHKK(3,NC1) | |
38016 | VHKT(4,6+IIGLU1) =VHKK(4,NC1) | |
38017 | WHKT(1,6+IIGLU1) =WHKK(1,NC1) | |
38018 | WHKT(2,6+IIGLU1) =WHKK(2,NC1) | |
38019 | WHKT(3,6+IIGLU1) =WHKK(3,NC1) | |
38020 | WHKT(4,6+IIGLU1) =WHKK(4,NC1) | |
38021 | C IDHKT(1) =IP11 | |
38022 | IDHKT(1) =KK11 | |
38023 | ISTHKT(1) =921 | |
38024 | JMOHKT(1,1)=NC1P | |
38025 | JMOHKT(2,1)=0 | |
38026 | JDAHKT(1,1)=3+IIGLU1 | |
38027 | JDAHKT(2,1)=0 | |
38028 | PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1) | |
38029 | C * +0.5D0*PHKK(1,NC2P) | |
38030 | *+XGIVE*PHKT(1,4+IIGLU1) | |
38031 | PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1) | |
38032 | C * +0.5D0*PHKK(2,NC2P) | |
38033 | *+XGIVE*PHKT(2,4+IIGLU1) | |
38034 | PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1) | |
38035 | C * +0.5D0*PHKK(3,NC2P) | |
38036 | *+XGIVE*PHKT(3,4+IIGLU1) | |
38037 | PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1) | |
38038 | C * +0.5D0*PHKK(4,NC2P) | |
38039 | *+XGIVE*PHKT(4,4+IIGLU1) | |
38040 | C PHKT(5,1) =PHKK(5,NC1P) | |
38041 | XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2- | |
38042 | *PHKT(1,1)**2) | |
38043 | IF(XMIST.GE.0.D0)THEN | |
38044 | PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2- | |
38045 | *PHKT(1,1)**2) | |
38046 | ELSE | |
38047 | C WRITE(6,*)'MGSQBS1 parton 1 mass square LT.0 ',XMIST | |
38048 | PHKT(5,1)=0.D0 | |
38049 | ENDIF | |
38050 | VHKT(1,1) =VHKK(1,NC1P) | |
38051 | VHKT(2,1) =VHKK(2,NC1P) | |
38052 | VHKT(3,1) =VHKK(3,NC1P) | |
38053 | VHKT(4,1) =VHKK(4,NC1P) | |
38054 | WHKT(1,1) =WHKK(1,NC1P) | |
38055 | WHKT(2,1) =WHKK(2,NC1P) | |
38056 | WHKT(3,1) =WHKK(3,NC1P) | |
38057 | WHKT(4,1) =WHKK(4,NC1P) | |
38058 | C Add here IIGLU1 gluons to this chaina | |
38059 | PG1=0.D0 | |
38060 | PG2=0.D0 | |
38061 | PG3=0.D0 | |
38062 | PG4=0.D0 | |
38063 | IF(IIGLU1.GE.1)THEN | |
38064 | JJG=NC1P | |
38065 | DO 61 IIG=2,2+IIGLU1-1 | |
38066 | KKG=JJG+IIG-1 | |
38067 | IDHKT(IIG) =IDHKK(KKG) | |
38068 | ISTHKT(IIG) =921 | |
38069 | JMOHKT(1,IIG)=KKG | |
38070 | JMOHKT(2,IIG)=0 | |
38071 | JDAHKT(1,IIG)=3+IIGLU1 | |
38072 | JDAHKT(2,IIG)=0 | |
38073 | PHKT(1,IIG)=PHKK(1,KKG) | |
38074 | PG1=PG1+ PHKT(1,IIG) | |
38075 | PHKT(2,IIG)=PHKK(2,KKG) | |
38076 | PG2=PG2+ PHKT(2,IIG) | |
38077 | PHKT(3,IIG)=PHKK(3,KKG) | |
38078 | PG3=PG3+ PHKT(3,IIG) | |
38079 | PHKT(4,IIG)=PHKK(4,KKG) | |
38080 | PG4=PG4+ PHKT(4,IIG) | |
38081 | PHKT(5,IIG)=PHKK(5,KKG) | |
38082 | VHKT(1,IIG) =VHKK(1,KKG) | |
38083 | VHKT(2,IIG) =VHKK(2,KKG) | |
38084 | VHKT(3,IIG) =VHKK(3,KKG) | |
38085 | VHKT(4,IIG) =VHKK(4,KKG) | |
38086 | WHKT(1,IIG) =WHKK(1,KKG) | |
38087 | WHKT(2,IIG) =WHKK(2,KKG) | |
38088 | WHKT(3,IIG) =WHKK(3,KKG) | |
38089 | WHKT(4,IIG) =WHKK(4,KKG) | |
38090 | 61 CONTINUE | |
38091 | ENDIF | |
38092 | C IDHKT(2) =1000*IPP21+100*IPP22+1 | |
38093 | IF(IPIP.EQ.1)THEN | |
38094 | IDHKT(2+IIGLU1) =1000*KK21+100*KK22+3 | |
38095 | IF(IDHKT(2+IIGLU1).EQ.1203)IDHKT(2+IIGLU1)=2103 | |
38096 | IF(IDHKT(2+IIGLU1).EQ.1303)IDHKT(2+IIGLU1)=3103 | |
38097 | IF(IDHKT(2+IIGLU1).EQ.2303)IDHKT(2+IIGLU1)=3203 | |
38098 | ELSEIF(IPIP.EQ.2)THEN | |
38099 | IDHKT(2+IIGLU1) =1000*KK21+100*KK22-3 | |
38100 | IF(IDHKT(2+IIGLU1).EQ.-1203)IDHKT(2+IIGLU1)=-2103 | |
38101 | IF(IDHKT(2+IIGLU1).EQ.-1303)IDHKT(2+IIGLU1)=-3103 | |
38102 | IF(IDHKT(2+IIGLU1).EQ.-2303)IDHKT(2+IIGLU1)=-3203 | |
38103 | ENDIF | |
38104 | ISTHKT(2+IIGLU1) =922 | |
38105 | JMOHKT(1,2+IIGLU1)=NC2T | |
38106 | JMOHKT(2,2+IIGLU1)=0 | |
38107 | JDAHKT(1,2+IIGLU1)=3+IIGLU1 | |
38108 | JDAHKT(2,2+IIGLU1)=0 | |
38109 | PHKT(1,2+IIGLU1) =PHKK(1,NC2T) | |
38110 | *+XGIVE*PHKT(1,5+IIGLU1) | |
38111 | PHKT(2,2+IIGLU1) =PHKK(2,NC2T) | |
38112 | *+XGIVE*PHKT(2,5+IIGLU1) | |
38113 | PHKT(3,2+IIGLU1) =PHKK(3,NC2T) | |
38114 | *+XGIVE*PHKT(3,5+IIGLU1) | |
38115 | PHKT(4,2+IIGLU1) =PHKK(4,NC2T) | |
38116 | *+XGIVE*PHKT(4,5+IIGLU1) | |
38117 | C PHKT(5,2) =PHKK(5,NC2T) | |
38118 | XMIST=(PHKT(4,2+IIGLU1)**2- | |
38119 | * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2- | |
38120 | *PHKT(1,2+IIGLU1)**2) | |
38121 | IF(XMIST.GT.0.D0)THEN | |
38122 | PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2- | |
38123 | * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2- | |
38124 | *PHKT(1,2+IIGLU1)**2) | |
38125 | ELSE | |
38126 | C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST | |
38127 | PHKT(5,2+IIGLU1)=0.D0 | |
38128 | ENDIF | |
38129 | VHKT(1,2+IIGLU1) =VHKK(1,NC2T) | |
38130 | VHKT(2,2+IIGLU1) =VHKK(2,NC2T) | |
38131 | VHKT(3,2+IIGLU1) =VHKK(3,NC2T) | |
38132 | VHKT(4,2+IIGLU1) =VHKK(4,NC2T) | |
38133 | WHKT(1,2+IIGLU1) =WHKK(1,NC2T) | |
38134 | WHKT(2,2+IIGLU1) =WHKK(2,NC2T) | |
38135 | WHKT(3,2+IIGLU1) =WHKK(3,NC2T) | |
38136 | WHKT(4,2+IIGLU1) =WHKK(4,NC2T) | |
38137 | IDHKT(3+IIGLU1) =88888 | |
38138 | C IDHKT(3) =1000*NNNC1+MMMC1+10 | |
38139 | ISTHKT(3+IIGLU1) =93 | |
38140 | C ISTHKT(3) =KKKC1 | |
38141 | JMOHKT(1,3+IIGLU1)=1 | |
38142 | JMOHKT(2,3+IIGLU1)=2+IIGLU1 | |
38143 | JDAHKT(1,3+IIGLU1)=0 | |
38144 | JDAHKT(2,3+IIGLU1)=0 | |
38145 | PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1 | |
38146 | PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2 | |
38147 | PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3 | |
38148 | PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4 | |
38149 | PHKT(5,3+IIGLU1) | |
38150 | * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2 | |
38151 | * -PHKT(3,3+IIGLU1)**2) | |
38152 | IF(IPIP.GE.3)THEN | |
38153 | WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1), | |
38154 | * JDAHKT(1,1), | |
38155 | *JDAHKT(2,1),(PHKT(III,1),III=1,5) | |
38156 | DO 71 IIG=2,2+IIGLU1-1 | |
38157 | WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG), | |
38158 | & JMOHKT(1,IIG),JMOHKT(2,IIG), | |
38159 | * JDAHKT(1,IIG), | |
38160 | *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) | |
38161 | 71 CONTINUE | |
38162 | WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1), | |
38163 | & IDHKT(2),JMOHKT(1,2+IIGLU1), | |
38164 | * JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1), | |
38165 | *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5) | |
38166 | WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1), | |
38167 | * JMOHKT(1,3+IIGLU1), | |
38168 | * JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1), | |
38169 | *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5) | |
38170 | ENDIF | |
38171 | CHAMAL=CHAB1 | |
38172 | **NEW | |
38173 | C IF(IPIP.EQ.1)THEN | |
38174 | C IF(IPP21.GE.3.OR.IPP22.GE.3.OR.IP11.GE.3)CHAMAL=CHAB3 | |
38175 | C ELSEIF(IPIP.EQ.2)THEN | |
38176 | C IF(IPP21.LE.-3.OR.IPP22.LE.-3.OR.IP11.LE.-3)CHAMAL=CHAB3 | |
38177 | C ENDIF | |
38178 | IF(IPIP.EQ.1)THEN | |
38179 | IF(KK21.GE.3.OR.KK22.GE.3.OR.KK11.GE.3)CHAMAL=CHAB3 | |
38180 | ELSEIF(IPIP.EQ.2)THEN | |
38181 | IF(KK21.LE.-3.OR.KK22.LE.-3.OR.KK11.LE.-3)CHAMAL=CHAB3 | |
38182 | ENDIF | |
38183 | ** | |
38184 | IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN | |
38185 | C IREJ=1 | |
38186 | IPCO=0 | |
38187 | C RETURN | |
38188 | C WRITE(6,*)' MGSQBS1 jump back from chain 3' | |
38189 | GO TO 3466 | |
38190 | ENDIF | |
38191 | VHKT(1,3+IIGLU1) =VHKK(1,NC1) | |
38192 | VHKT(2,3+IIGLU1) =VHKK(2,NC1) | |
38193 | VHKT(3,3+IIGLU1) =VHKK(3,NC1) | |
38194 | VHKT(4,3+IIGLU1) =VHKK(4,NC1) | |
38195 | WHKT(1,3+IIGLU1) =WHKK(1,NC1) | |
38196 | WHKT(2,3+IIGLU1) =WHKK(2,NC1) | |
38197 | WHKT(3,3+IIGLU1) =WHKK(3,NC1) | |
38198 | WHKT(4,3+IIGLU1) =WHKK(4,NC1) | |
38199 | IF(IPIP.EQ.1)THEN | |
38200 | IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ1+3 | |
38201 | IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103 | |
38202 | IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103 | |
38203 | IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203 | |
38204 | ELSEIF(IPIP.EQ.2)THEN | |
38205 | IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3 | |
38206 | IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103 | |
38207 | IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103 | |
38208 | IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203 | |
38209 | C WRITE(6,*)'IDHKT(7),IPP1,ISQ1',IDHKT(7),IPP1,ISQ1 | |
38210 | ENDIF | |
38211 | ISTHKT(7+IIGLU1) =921 | |
38212 | JMOHKT(1,7+IIGLU1)=NC2P | |
38213 | JMOHKT(2,7+IIGLU1)=0 | |
38214 | JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2 | |
38215 | JDAHKT(2,7+IIGLU1)=0 | |
38216 | C PHKT(1,7) =0.5D0*PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ/(XDIQP+XSQ) | |
38217 | C PHKT(2,7) =0.5D0*PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ/(XDIQP+XSQ) | |
38218 | C PHKT(3,7) =0.5D0*PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ/(XDIQP+XSQ) | |
38219 | C PHKT(4,7+IIGLU1) =0.5D0*PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ/(XDIQP+XSQ) | |
38220 | **NEW | |
38221 | IF ((XSQ1 .LT.0.0D0).OR.(XDIQP .LT.0.0D0)) | |
38222 | & WRITE(LOUT,*) ' mgsqbs3: ',XSQ1,XDIQP | |
38223 | ** | |
38224 | PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1) | |
38225 | PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1) | |
38226 | PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1) | |
38227 | PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1) | |
38228 | C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)', | |
38229 | C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7) | |
38230 | IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN | |
38231 | C IREJ=1 | |
38232 | C WRITE(6,*)'reject PHKT(4,7).GE. PHKK(4,NC1P)' | |
38233 | IPCO=0 | |
38234 | C RETURN | |
38235 | GO TO 3466 | |
38236 | ENDIF | |
38237 | C PHKT(5,7) =PHKK(5,NC2P) | |
38238 | PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2- | |
38239 | * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2- | |
38240 | *PHKT(1,7+IIGLU1)**2) | |
38241 | VHKT(1,7+IIGLU1) =VHKK(1,NC2P) | |
38242 | VHKT(2,7+IIGLU1) =VHKK(2,NC2P) | |
38243 | VHKT(3,7+IIGLU1) =VHKK(3,NC2P) | |
38244 | VHKT(4,7+IIGLU1) =VHKK(4,NC2P) | |
38245 | WHKT(1,7+IIGLU1) =WHKK(1,NC2P) | |
38246 | WHKT(2,7+IIGLU1) =WHKK(2,NC2P) | |
38247 | WHKT(3,7+IIGLU1) =WHKK(3,NC2P) | |
38248 | WHKT(4,7+IIGLU1) =WHKK(4,NC2P) | |
38249 | C Insert here the IIGLU2 gluons | |
38250 | PG1=0.D0 | |
38251 | PG2=0.D0 | |
38252 | PG3=0.D0 | |
38253 | PG4=0.D0 | |
38254 | IF(IIGLU2.GE.1)THEN | |
38255 | JJG=NC2P | |
38256 | DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 | |
38257 | KKG=JJG+IIG-7-IIGLU1 | |
38258 | IDHKT(IIG) =IDHKK(KKG) | |
38259 | ISTHKT(IIG) =921 | |
38260 | JMOHKT(1,IIG)=KKG | |
38261 | JMOHKT(2,IIG)=0 | |
38262 | JDAHKT(1,IIG)=9+IIGLU1+IIGLU2 | |
38263 | JDAHKT(2,IIG)=0 | |
38264 | PHKT(1,IIG)=PHKK(1,KKG) | |
38265 | PG1=PG1+ PHKT(1,IIG) | |
38266 | PHKT(2,IIG)=PHKK(2,KKG) | |
38267 | PG2=PG2+ PHKT(2,IIG) | |
38268 | PHKT(3,IIG)=PHKK(3,KKG) | |
38269 | PG3=PG3+ PHKT(3,IIG) | |
38270 | PHKT(4,IIG)=PHKK(4,KKG) | |
38271 | PG4=PG4+ PHKT(4,IIG) | |
38272 | PHKT(5,IIG)=PHKK(5,KKG) | |
38273 | VHKT(1,IIG) =VHKK(1,KKG) | |
38274 | VHKT(2,IIG) =VHKK(2,KKG) | |
38275 | VHKT(3,IIG) =VHKK(3,KKG) | |
38276 | VHKT(4,IIG) =VHKK(4,KKG) | |
38277 | WHKT(1,IIG) =WHKK(1,KKG) | |
38278 | WHKT(2,IIG) =WHKK(2,KKG) | |
38279 | WHKT(3,IIG) =WHKK(3,KKG) | |
38280 | WHKT(4,IIG) =WHKK(4,KKG) | |
38281 | 81 CONTINUE | |
38282 | ENDIF | |
38283 | IDHKT(8+IIGLU1+IIGLU2) =IP2 | |
38284 | ISTHKT(8+IIGLU1+IIGLU2) =922 | |
38285 | JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T | |
38286 | JMOHKT(2,8+IIGLU1+IIGLU2)=0 | |
38287 | JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2 | |
38288 | JDAHKT(2,8+IIGLU1+IIGLU2)=0 | |
38289 | **NEW | |
38290 | IF ((XVQT.LT.0.0D0).OR.(XSAQ1 .LT.0.0D0)) | |
38291 | & WRITE(LOUT,*) ' mgsqbs4: ',XVQT,XSAQ1 | |
38292 | ** | |
38293 | PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT) | |
38294 | PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT) | |
38295 | PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT) | |
38296 | PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT) | |
38297 | C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T) | |
38298 | XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2- | |
38299 | * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2- | |
38300 | *PHKT(1,8+IIGLU1+IIGLU2)**2) | |
38301 | IF(XMIST.GT.0.D0)THEN | |
38302 | PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2- | |
38303 | * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2- | |
38304 | *PHKT(1,8+IIGLU1+IIGLU2)**2) | |
38305 | ELSE | |
38306 | C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST | |
38307 | PHKT(5,8+IIGLU1+IIGLU2)=0.D0 | |
38308 | ENDIF | |
38309 | VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T) | |
38310 | VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T) | |
38311 | VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T) | |
38312 | VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T) | |
38313 | WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T) | |
38314 | WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T) | |
38315 | WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T) | |
38316 | WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T) | |
38317 | IDHKT(9+IIGLU1+IIGLU2) =88888 | |
38318 | C IDHKT(9) =1000*NNNC2+MMMC2+10 | |
38319 | ISTHKT(9+IIGLU1+IIGLU2) =93 | |
38320 | C ISTHKT(9) =KKKC2 | |
38321 | JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1 | |
38322 | JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2 | |
38323 | JDAHKT(1,9+IIGLU1+IIGLU2)=0 | |
38324 | JDAHKT(2,9+IIGLU1+IIGLU2)=0 | |
38325 | PHKT(1,9+IIGLU1+IIGLU2) =PHKT(1,7+IIGLU1) | |
38326 | * +PHKT(1,8+IIGLU1+IIGLU2)+PG1 | |
38327 | PHKT(2,9+IIGLU1+IIGLU2) =PHKT(2,7+IIGLU1) | |
38328 | * +PHKT(2,8+IIGLU1+IIGLU2)+PG2 | |
38329 | PHKT(3,9+IIGLU1+IIGLU2) =PHKT(3,7+IIGLU1) | |
38330 | * +PHKT(3,8+IIGLU1+IIGLU2)+PG3 | |
38331 | PHKT(4,9+IIGLU1+IIGLU2) =PHKT(4,7+IIGLU1) | |
38332 | * +PHKT(4,8+IIGLU1+IIGLU2)+PG4 | |
38333 | PHKT(5,9+IIGLU1+IIGLU2) | |
38334 | * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2- | |
38335 | * PHKT(2,9+IIGLU1+IIGLU2)**2 | |
38336 | * -PHKT(3,9+IIGLU1+IIGLU2)**2) | |
38337 | IF(IPIP.GE.3)THEN | |
38338 | WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1), | |
38339 | * JMOHKT(1,7+IIGLU1), | |
38340 | * JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1), | |
38341 | *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5) | |
38342 | DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 | |
38343 | WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG), | |
38344 | & JMOHKT(1,IIG),JMOHKT(2,IIG), | |
38345 | * JDAHKT(1,IIG), | |
38346 | *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) | |
38347 | 91 CONTINUE | |
38348 | WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2), | |
38349 | * IDHKT(8+IIGLU1+IIGLU2), | |
38350 | * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2), | |
38351 | * JDAHKT(1,8+IIGLU1+IIGLU2), | |
38352 | *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5) | |
38353 | WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2), | |
38354 | * IDHKT(9+IIGLU1+IIGLU2), | |
38355 | * JMOHKT(1,9+IIGLU1+IIGLU2),JMOHKT(2,9+IIGLU1+IIGLU2), | |
38356 | * JDAHKT(1,9+IIGLU1+IIGLU2), | |
38357 | *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5) | |
38358 | ENDIF | |
38359 | CHAMAL=CHAB1 | |
38360 | IF(IPIP.EQ.1)THEN | |
38361 | IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3 | |
38362 | ELSEIF(IPIP.EQ.2)THEN | |
38363 | IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3 | |
38364 | ENDIF | |
38365 | IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN | |
38366 | C IREJ=1 | |
38367 | IPCO=0 | |
38368 | C RETURN | |
38369 | C WRITE(6,*)' MGSQBS1 jump back from chain 9', | |
38370 | C & 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2) | |
38371 | GO TO 3466 | |
38372 | ENDIF | |
38373 | VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1) | |
38374 | VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1) | |
38375 | VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1) | |
38376 | VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1) | |
38377 | WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1) | |
38378 | WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1) | |
38379 | WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1) | |
38380 | WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1) | |
38381 | C | |
38382 | IGCOUN=9+IIGLU1+IIGLU2 | |
38383 | IPCO=0 | |
38384 | RETURN | |
38385 | END | |
38386 | ||
38387 | *$ CREATE HKKHKT.FOR | |
38388 | *COPY HKKHKT | |
38389 | C | |
38390 | C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ | |
38391 | C | |
38392 | SUBROUTINE HKKHKT(I,J) | |
38393 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
38394 | SAVE | |
38395 | ||
38396 | * event history | |
38397 | ||
38398 | PARAMETER (NMXHKK=200000) | |
38399 | ||
38400 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
38401 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
38402 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
38403 | ||
38404 | * extended event history | |
38405 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
38406 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
38407 | & IHIST(2,NMXHKK) | |
38408 | ||
38409 | PARAMETER (NTMHKK= 300) | |
38410 | COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT | |
38411 | +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT | |
38412 | +(4,NTMHKK) | |
38413 | C | |
38414 | ISTHKK(I) =ISTHKT(J) | |
38415 | IDHKK(I) =IDHKT(J) | |
38416 | C IF(J.EQ.3.OR.J.EQ.6.OR.J.EQ.9)THEN | |
38417 | IF(IDHKK(I).EQ.88888)THEN | |
38418 | C JMOHKK(1,I)=I-2 | |
38419 | C JMOHKK(2,I)=I-1 | |
38420 | JMOHKK(1,I)=I-(J-JMOHKT(1,J)) | |
38421 | JMOHKK(2,I)=I-(J-JMOHKT(2,J)) | |
38422 | ELSE | |
38423 | JMOHKK(1,I)=JMOHKT(1,J) | |
38424 | JMOHKK(2,I)=JMOHKT(2,J) | |
38425 | ENDIF | |
38426 | JDAHKK(1,I)=JDAHKT(1,J) | |
38427 | JDAHKK(2,I)=JDAHKT(2,J) | |
38428 | C IF(J.EQ.1.OR.J.EQ.4.OR.J.EQ.7)THEN | |
38429 | C JDAHKK(1,I)=I+2 | |
38430 | C ELSEIF(J.EQ.2.OR.J.EQ.5.OR.J.EQ.8)THEN | |
38431 | C JDAHKK(1,I)=I+1 | |
38432 | C ENDIF | |
38433 | IF(JDAHKT(1,J).GT.0)THEN | |
38434 | JDAHKK(1,I)=I+(JDAHKT(1,J)-J) | |
38435 | ENDIF | |
38436 | PHKK(1,I) =PHKT(1,J) | |
38437 | PHKK(2,I) =PHKT(2,J) | |
38438 | PHKK(3,I) =PHKT(3,J) | |
38439 | PHKK(4,I) =PHKT(4,J) | |
38440 | PHKK(5,I) =PHKT(5,J) | |
38441 | VHKK(1,I) =VHKT(1,J) | |
38442 | VHKK(2,I) =VHKT(2,J) | |
38443 | VHKK(3,I) =VHKT(3,J) | |
38444 | VHKK(4,I) =VHKT(4,J) | |
38445 | WHKK(1,I) =WHKT(1,J) | |
38446 | WHKK(2,I) =WHKT(2,J) | |
38447 | WHKK(3,I) =WHKT(3,J) | |
38448 | WHKK(4,I) =WHKT(4,J) | |
38449 | RETURN | |
38450 | END | |
38451 | ||
38452 | *$ CREATE DT_DBREAK.FOR | |
38453 | *COPY DT_DBREAK | |
38454 | * | |
38455 | *===dbreak=============================================================* | |
38456 | * | |
38457 | SUBROUTINE DT_DBREAK(MODE) | |
38458 | ||
38459 | ************************************************************************ | |
38460 | * This is the steering subroutine for the different diquark breaking * | |
38461 | * mechanisms. * | |
38462 | * * | |
38463 | * MODE = 1 breaking of projectile diquark in qq-q chain using * | |
38464 | * a sea quark (q-qq chain) of the same projectile * | |
38465 | * = 2 breaking of target diquark in q-qq chain using * | |
38466 | * a sea quark (qq-q chain) of the same target * | |
38467 | * = 3 breaking of projectile diquark in qq-q chain using * | |
38468 | * a sea quark (q-aq chain) of the same projectile * | |
38469 | * = 4 breaking of target diquark in q-qq chain using * | |
38470 | * a sea quark (aq-q chain) of the same target * | |
38471 | * = 5 breaking of projectile anti-diquark in aqaq-aq chain using * | |
38472 | * a sea anti-quark (aq-aqaq chain) of the same projectile * | |
38473 | * = 6 breaking of target anti-diquark in aq-aqaq chain using * | |
38474 | * a sea anti-quark (aqaq-aq chain) of the same target * | |
38475 | * = 7 breaking of projectile anti-diquark in aqaq-aq chain using * | |
38476 | * a sea anti-quark (aq-q chain) of the same projectile * | |
38477 | * = 8 breaking of target anti-diquark in aq-aqaq chain using * | |
38478 | * a sea anti-quark (q-aq chain) of the same target * | |
38479 | * * | |
38480 | * Original version by J. Ranft. * | |
38481 | * This version dated 17.5.00 is written by S. Roesler. * | |
38482 | ************************************************************************ | |
38483 | ||
38484 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
38485 | SAVE | |
38486 | ||
38487 | PARAMETER ( LINP = 10 , | |
38488 | & LOUT = 6 , | |
38489 | & LDAT = 9 ) | |
38490 | ||
38491 | * event history | |
38492 | ||
38493 | PARAMETER (NMXHKK=200000) | |
38494 | ||
38495 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
38496 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
38497 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
38498 | ||
38499 | * extended event history | |
38500 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
38501 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
38502 | & IHIST(2,NMXHKK) | |
38503 | ||
38504 | * flags for input different options | |
38505 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
38506 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
38507 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
38508 | ||
38509 | * pointer to chains in hkkevt common (used by qq-breaking mechanisms) | |
38510 | PARAMETER (MAXCHN=10000) | |
38511 | COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN | |
38512 | ||
38513 | * diquark-breaking mechanism | |
38514 | COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3 | |
38515 | ||
38516 | * flags for particle decays | |
38517 | COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20), | |
38518 | & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20), | |
38519 | & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0 | |
38520 | ||
38521 | * | |
38522 | * chain identifiers | |
38523 | * ( 1 = q-aq, 2 = aq-q, 3 = q-qq, 4 = qq-q, | |
38524 | * 5 = aq-adq, 6 = adq-aq, 7 = dq-adq, 8 = adq-dq ) | |
38525 | DIMENSION IDCHN1(8),IDCHN2(8) | |
38526 | DATA IDCHN1 / 4, 3, 4, 3, 6, 5, 6, 5/ | |
38527 | DATA IDCHN2 / 3, 4, 1, 2, 5, 6, 2, 1/ | |
38528 | * | |
38529 | * parton identifiers | |
38530 | * ( +-21/22 = valence, +-31/32 = Glauber-sea, +-41/42 = Pomeron (diff), | |
38531 | * +-51/52 = unitarity-sea, +-61/62 = gluons ) | |
38532 | DIMENSION ISP1P(8,3),ISP1T(8,3),ISP2P(8,3),ISP2T(8,3) | |
38533 | DATA ISP1P / 21, 21, 21, 21, 21, 21, 21, 21, | |
38534 | & 31, 31, 31, 31, 31, 31, 31, 31, | |
38535 | & 41, 41, 41, 41, 51, 51, 51, 51/ | |
38536 | DATA ISP1T / 22, 22, 22, 22, 22, 22, 22, 22, | |
38537 | & 32, 32, 32, 32, 32, 32, 32, 32, | |
38538 | & 42, 42, 42, 42, 52, 52, 52, 52/ | |
38539 | DATA ISP2P / 31, 21, 31, 31, 21, 21, 21, 21, | |
38540 | & 51, 31, 41, 41, 31, 31, 31, 31, | |
38541 | & 0, 41, 51, 51, 51, 51, 51, 51/ | |
38542 | DATA ISP2T / 22, 32, 32, 32, 22, 22, 22, 22, | |
38543 | & 32, 52, 42, 42, 32, 32, 32, 32, | |
38544 | & 42, 0, 52, 52, 52, 52, 52, 52/ | |
38545 | ||
38546 | IF (NCHAIN.LE.0) RETURN | |
38547 | DO 1 I=1,NCHAIN | |
38548 | IDX1 = IDXCHN(1,I) | |
38549 | IS1P = ABS(ISTHKK(JMOHKK(1,IDX1))) | |
38550 | IS1T = ABS(ISTHKK(JMOHKK(2,IDX1))) | |
38551 | IF ( (IDXCHN(2,I).EQ.IDCHN1(MODE)) | |
38552 | & .AND. | |
38553 | & ((IS1P.EQ.ISP1P(MODE,1)).OR.(IS1P.EQ.ISP1P(MODE,2)).OR. | |
38554 | & (IS1P.EQ.ISP1P(MODE,3))) | |
38555 | & .AND. | |
38556 | & ((IS1T.EQ.ISP1T(MODE,1)).OR.(IS1T.EQ.ISP1T(MODE,2)).OR. | |
38557 | & (IS1T.EQ.ISP1T(MODE,3))) | |
38558 | & ) THEN | |
38559 | DO 2 J=1,NCHAIN | |
38560 | IDX2 = IDXCHN(1,J) | |
38561 | IS2P = ABS(ISTHKK(JMOHKK(1,IDX2))) | |
38562 | IS2T = ABS(ISTHKK(JMOHKK(2,IDX2))) | |
38563 | IF ( (IDXCHN(2,J).EQ.IDCHN2(MODE)) | |
38564 | & .AND. | |
38565 | & ((IS2P.EQ.ISP2P(MODE,1)).OR.(IS2P.EQ.ISP2P(MODE,2)) | |
38566 | & .OR.(IS2P.EQ.ISP2P(MODE,3))) | |
38567 | & .AND. | |
38568 | & ((IS2T.EQ.ISP2T(MODE,1)).OR.(IS2T.EQ.ISP2T(MODE,2)) | |
38569 | & .OR.(IS2T.EQ.ISP2T(MODE,3))) | |
38570 | & ) THEN | |
38571 | * find mother nucleons of the diquark to be splitted and of the | |
38572 | * sea-quark and reject this combination if it is not the same | |
38573 | IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR. | |
38574 | & (MODE.EQ.5).OR.(MODE.EQ.7)) THEN | |
38575 | IANCES = 1 | |
38576 | ELSE | |
38577 | IANCES = 2 | |
38578 | ENDIF | |
38579 | IDXMO1 = JMOHKK(IANCES,IDX1) | |
38580 | 4 CONTINUE | |
38581 | IF ((JMOHKK(1,IDXMO1).NE.0).AND. | |
38582 | & (JMOHKK(2,IDXMO1).NE.0)) THEN | |
38583 | IANC = IANCES | |
38584 | ELSE | |
38585 | IANC = 1 | |
38586 | ENDIF | |
38587 | IF (JMOHKK(IANC,IDXMO1).NE.0) THEN | |
38588 | IDXMO1 = JMOHKK(IANC,IDXMO1) | |
38589 | GOTO 4 | |
38590 | ENDIF | |
38591 | IDXMO2 = JMOHKK(IANCES,IDX2) | |
38592 | 5 CONTINUE | |
38593 | IF ((JMOHKK(1,IDXMO2).NE.0).AND. | |
38594 | & (JMOHKK(2,IDXMO2).NE.0)) THEN | |
38595 | IANC = IANCES | |
38596 | ELSE | |
38597 | IANC = 1 | |
38598 | ENDIF | |
38599 | IF (JMOHKK(IANC,IDXMO2).NE.0) THEN | |
38600 | IDXMO2 = JMOHKK(IANC,IDXMO2) | |
38601 | GOTO 5 | |
38602 | ENDIF | |
38603 | IF (IDXMO1.NE.IDXMO2) GOTO 2 | |
38604 | * quark content of projectile parton | |
38605 | IP1 = IDHKK(JMOHKK(1,IDX1)) | |
38606 | IP11 = IP1/1000 | |
38607 | IP12 = (IP1-1000*IP11)/100 | |
38608 | IP2 = IDHKK(JMOHKK(2,IDX1)) | |
38609 | IP21 = IP2/1000 | |
38610 | IP22 = (IP2-1000*IP21)/100 | |
38611 | * quark content of target parton | |
38612 | IT1 = IDHKK(JMOHKK(1,IDX2)) | |
38613 | IT11 = IT1/1000 | |
38614 | IT12 = (IT1-1000*IT11)/100 | |
38615 | IT2 = IDHKK(JMOHKK(2,IDX2)) | |
38616 | IT21 = IT2/1000 | |
38617 | IT22 = (IT2-1000*IT21)/100 | |
38618 | * split diquark and form new chains | |
38619 | IF (MODE.EQ.1) THEN | |
38620 | IF (IT1.EQ.4) GOTO 2 | |
38621 | CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), | |
38622 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, | |
38623 | & IP11,IP12,IP2,IT1,IT21,IT22,1,IPQ,IGCOUN) | |
38624 | ELSEIF (MODE.EQ.2) THEN | |
38625 | IF (IT2.EQ.4) GOTO 2 | |
38626 | CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), | |
38627 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, | |
38628 | & IP1,IP21,IP22,IT11,IT12,IT2,1,IPQ,IGCOUN) | |
38629 | ELSEIF (MODE.EQ.3) THEN | |
38630 | IF (IT1.EQ.4) GOTO 2 | |
38631 | CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), | |
38632 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, | |
38633 | & IP11,IP12,IP2,IT1,IT2,1,IPQ,IGCOUN) | |
38634 | ELSEIF (MODE.EQ.4) THEN | |
38635 | IF (IT2.EQ.4) GOTO 2 | |
38636 | CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), | |
38637 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, | |
38638 | & IP1,IP21,IP22,IT1,IT2,1,IPQ,IGCOUN) | |
38639 | ELSEIF (MODE.EQ.5) THEN | |
38640 | CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), | |
38641 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, | |
38642 | & IP11,IP12,IP2,IT1,IT21,IT22,2,IPQ,IGCOUN) | |
38643 | ELSEIF (MODE.EQ.6) THEN | |
38644 | CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), | |
38645 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, | |
38646 | & IP1,IP21,IP22,IT11,IT12,IT2,2,IPQ,IGCOUN) | |
38647 | ELSEIF (MODE.EQ.7) THEN | |
38648 | CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), | |
38649 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, | |
38650 | & IP11,IP12,IP2,IT1,IT2,2,IPQ,IGCOUN) | |
38651 | ELSEIF (MODE.EQ.8) THEN | |
38652 | CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), | |
38653 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, | |
38654 | & IP1,IP21,IP22,IT1,IT2,2,IPQ,IGCOUN) | |
38655 | ENDIF | |
38656 | IF (IREJ.GE.1) THEN | |
38657 | if ((ipq.lt.0).or.(ipq.ge.4)) | |
38658 | & write(LOUT,*) 'ipq !!!',ipq,mode | |
38659 | DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0 | |
38660 | * accept or reject new chains corresponding to PDBSEA | |
38661 | ELSE | |
38662 | IF ((IPQ.EQ.1).OR.(IPQ.EQ.2)) THEN | |
38663 | ACC = DBRKA(1,MODE)+DBRKA(2,MODE) | |
38664 | REJ = DBRKR(1,MODE)+DBRKR(2,MODE) | |
38665 | ELSEIF (IPQ.EQ.3) THEN | |
38666 | ACC = DBRKA(3,MODE) | |
38667 | REJ = DBRKR(3,MODE) | |
38668 | ELSE | |
38669 | WRITE(LOUT,*) ' inconsistent IPQ ! ',IPQ | |
38670 | STOP | |
38671 | ENDIF | |
38672 | IF (ACC/(ACC+REJ).LE.PDBSEA(IPQ)) THEN | |
38673 | DBRKA(IPQ,MODE) = DBRKA(IPQ,MODE)+1.0D0 | |
38674 | IACC = 1 | |
38675 | ELSE | |
38676 | DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0 | |
38677 | IACC = 0 | |
38678 | ENDIF | |
38679 | * new chains have been accepted and are now copied into HKKEVT | |
38680 | IF (IACC.EQ.1) THEN | |
38681 | IF (LEMCCK) THEN | |
38682 | CALL DT_EVTEMC(PHKK(1,IDX1),PHKK(2,IDX1), | |
38683 | & PHKK(3,IDX1),PHKK(4,IDX1), | |
38684 | & 1,IDUM1,IDUM2) | |
38685 | CALL DT_EVTEMC(PHKK(1,IDX2),PHKK(2,IDX2), | |
38686 | & PHKK(3,IDX2),PHKK(4,IDX2), | |
38687 | & 2,IDUM1,IDUM2) | |
38688 | ENDIF | |
38689 | IDHKK(IDX1) = 99888 | |
38690 | IDHKK(IDX2) = 99888 | |
38691 | IDXCHN(2,I) = -1 | |
38692 | IDXCHN(2,J) = -1 | |
38693 | DO 3 K=1,IGCOUN | |
38694 | NHKK = NHKK+1 | |
38695 | CALL HKKHKT(NHKK,K) | |
38696 | IF ((LEMCCK).AND.(IDHKK(NHKK).EQ.88888))THEN | |
38697 | PX = -PHKK(1,NHKK) | |
38698 | PY = -PHKK(2,NHKK) | |
38699 | PZ = -PHKK(3,NHKK) | |
38700 | PE = -PHKK(4,NHKK) | |
38701 | CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2) | |
38702 | ENDIF | |
38703 | 3 CONTINUE | |
38704 | IF (LEMCCK) THEN | |
38705 | CHKLEV = 0.1D0 | |
38706 | CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,9000, | |
38707 | & IREJ) | |
38708 | IF (IREJ.NE.0) CALL DT_EVTOUT(4) | |
38709 | ENDIF | |
38710 | GOTO 1 | |
38711 | ENDIF | |
38712 | ENDIF | |
38713 | ENDIF | |
38714 | 2 CONTINUE | |
38715 | ENDIF | |
38716 | 1 CONTINUE | |
38717 | RETURN | |
38718 | END | |
38719 | ||
38720 | *$ CREATE DT_CQPAIR.FOR | |
38721 | *COPY DT_CQPAIR | |
38722 | * | |
38723 | *===cqpair=============================================================* | |
38724 | * | |
38725 | SUBROUTINE DT_CQPAIR(XQMAX,XAQMAX,XQ,XAQ,IFLV,IREJ) | |
38726 | ||
38727 | ************************************************************************ | |
38728 | * This subroutine Creates a Quark-antiquark PAIR from the sea. * | |
38729 | * * | |
38730 | * XQMAX maxium energy fraction of quark (input) * | |
38731 | * XAQMAX maxium energy fraction of antiquark (input) * | |
38732 | * XQ energy fraction of quark (output) * | |
38733 | * XAQ energy fraction of antiquark (output) * | |
38734 | * IFLV quark flavour (- antiquark flavor) (output) * | |
38735 | * * | |
38736 | * This version dated 14.5.00 is written by S. Roesler. * | |
38737 | ************************************************************************ | |
38738 | ||
38739 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
38740 | SAVE | |
38741 | ||
38742 | PARAMETER ( LINP = 10 , | |
38743 | & LOUT = 6 , | |
38744 | & LDAT = 9 ) | |
38745 | ||
38746 | * Lorentz-parameters of the current interaction | |
38747 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
38748 | & UMO,PPCM,EPROJ,PPROJ | |
38749 | ||
38750 | * | |
38751 | IREJ = 0 | |
38752 | XQ = 0.0D0 | |
38753 | XAQ = 0.0D0 | |
38754 | * | |
38755 | * sample quark flavour | |
38756 | * | |
38757 | * set seasq here (the one from DTCHAI should be used in the future) | |
38758 | SEASQ = 0.5D0 | |
38759 | IFLV = INT(1.0D0+DT_RNDM(XQMAX)*(2.0D0+SEASQ)) | |
38760 | * | |
38761 | * sample energy fractions of sea pair | |
38762 | * we first sample the energy fraction of a gluon and then split the gluon | |
38763 | * | |
38764 | * maximum energy fraction of the gluon forced via input | |
38765 | XGMAXI = XQMAX+XAQMAX | |
38766 | * minimum energy fraction of the gluon | |
38767 | XTHR1 = 4.0D0 /UMO**2 | |
38768 | XTHR2 = 0.54D0/UMO**1.5D0 | |
38769 | XGMIN = MAX(XTHR1,XTHR2) | |
38770 | * maximum energy fraction of the gluon | |
38771 | XGMAX = 0.3D0 | |
38772 | XGMAX = MIN(XGMAXI,XGMAX) | |
38773 | IF (XGMIN.GE.XGMAX) THEN | |
38774 | IREJ = 1 | |
38775 | RETURN | |
38776 | ENDIF | |
38777 | * | |
38778 | * sample energy fraction of the gluon | |
38779 | NLOOP = 0 | |
38780 | 1 CONTINUE | |
38781 | NLOOP = NLOOP+1 | |
38782 | IF (NLOOP.GE.50) THEN | |
38783 | IREJ = 1 | |
38784 | RETURN | |
38785 | ENDIF | |
38786 | XGLUON = DT_SAMSQX(XGMIN,XGMAX) | |
38787 | EGLUON = XGLUON*UMO/2.0D0 | |
38788 | * | |
38789 | * split gluon into q-aq pair (we follow PHOJET's subroutine PHO_GLU2QU) | |
38790 | ZMIN = MIN(0.1D0,0.5D0/EGLUON) | |
38791 | ZMAX = 1.0D0-ZMIN | |
38792 | RZ = DT_RNDM(ZMAX) | |
38793 | XHLP = ((1.0D0-RZ)*ZMIN**3+RZ*ZMAX**3)**0.33333 | |
38794 | RQ = DT_RNDM(ZMAX) | |
38795 | IF (RQ.LT.0.5D0) THEN | |
38796 | XQ = XGLUON*XHLP | |
38797 | XAQ = XGLUON-XQ | |
38798 | ELSE | |
38799 | XAQ = XGLUON*XHLP | |
38800 | XQ = XGLUON-XAQ | |
38801 | ENDIF | |
38802 | IF ((XQ.GT.XQMAX).OR.(XAQ.GT.XAQMAX)) GOTO 1 | |
38803 | ||
38804 | RETURN | |
38805 | END |