]>
Commit | Line | Data |
---|---|---|
9aaba0d6 | 1 | *$ CREATE DT_INIT.FOR |
2 | *COPY DT_INIT | |
3 | * | |
4 | * +-------------------------------------------------------------+ | |
5 | * | | | |
6 | * | | | |
7 | * | DPMJET 3.0 | | |
8 | * | | | |
9 | * | | | |
10 | * | S. Roesler+), R. Engel#), J. Ranft*) | | |
11 | * | | | |
12 | * | +) CERN, SC-RP | | |
13 | * | CH-1211 Geneva 23, Switzerland | | |
14 | * | Email: Stefan.Roesler@cern.ch | | |
15 | * | | | |
16 | * | #) Institut fuer Kernphysik | | |
17 | * | Forschungszentrum Karlsruhe | | |
18 | * | D-76021 Karlsruhe, Germany | | |
19 | * | | | |
20 | * | *) University of Siegen, Dept. of Physics | | |
21 | * | D-57068 Siegen, Germany | | |
22 | * | | | |
23 | * | | | |
24 | * | http://home.cern.ch/sroesler/dpmjet3.html | | |
25 | * | | | |
26 | * | | | |
27 | * | Monte Carlo models used for event generation: | | |
28 | * | PHOJET 1.12, JETSET 7.4 and LEPTO 6.5.1 | | |
29 | * | | | |
30 | * +-------------------------------------------------------------+ | |
31 | * | |
32 | * | |
33 | *===init===============================================================* | |
34 | * | |
35 | SUBROUTINE DT_INIT(NCASES,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR, | |
36 | & IDP,IGLAU) | |
37 | ||
38 | ************************************************************************ | |
39 | * Initialization of event generation * | |
40 | * This version dated 7.4.98 is written by S. Roesler. * | |
41 | * * | |
42 | * Last change 27.12.2006 by S. Roesler. * | |
43 | ************************************************************************ | |
44 | ||
45 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
46 | SAVE | |
47 | ||
48 | PARAMETER ( LINP = 10 , | |
49 | & LOUT = 6 , | |
50 | & LDAT = 9 ) | |
51 | PARAMETER (ZERO=0.0D0,ONE=1.0D0) | |
52 | ||
53 | * particle properties (BAMJET index convention) | |
54 | CHARACTER*8 ANAME | |
55 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
56 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
57 | * names of hadrons used in input-cards | |
58 | CHARACTER*8 BTYPE | |
59 | COMMON /DTPAIN/ BTYPE(30) | |
60 | * (original name: PAREVT) | |
61 | LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX, | |
62 | & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF | |
63 | PARAMETER ( NALLWP = 39 ) | |
64 | COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, | |
65 | & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY, | |
66 | & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV, | |
67 | & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF | |
68 | * (original name: INPFLG) | |
69 | COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK | |
70 | * (original name: FRBKCM) | |
71 | PARAMETER ( MXFFBK = 6 ) | |
72 | PARAMETER ( MXZFBK = 9 ) | |
73 | PARAMETER ( MXNFBK = 10 ) | |
74 | PARAMETER ( MXAFBK = 16 ) | |
75 | PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 ) | |
76 | PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 ) | |
77 | PARAMETER ( NXAFBK = MXAFBK + 1 ) | |
78 | PARAMETER ( MXPSST = 300 ) | |
79 | PARAMETER ( MXPSFB = 41000 ) | |
80 | LOGICAL LFRMBK, LNCMSS | |
81 | COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST), | |
82 | & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB), | |
83 | & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK, | |
84 | & IFRBKN (MXPSST), IFRBKZ (MXPSST), | |
85 | & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST), | |
86 | & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK), | |
87 | & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK), | |
88 | & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF, | |
89 | & IFBFRB, NBUFBK, LFRMBK, LNCMSS | |
90 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
91 | * emulsion treatment | |
92 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
93 | & NCOMPO,IEMUL | |
94 | * Glauber formalism: parameters | |
95 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), | |
96 | & BMAX(NCOMPX),BSTEP(NCOMPX), | |
97 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), | |
98 | & NSITEB,NSTATB | |
99 | * Glauber formalism: cross sections | |
100 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
101 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
102 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
103 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
104 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
105 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
106 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
107 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
108 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
109 | & BSLOPE,NEBINI,NQBINI | |
110 | * interface HADRIN-DPM | |
111 | COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA | |
112 | * central particle production, impact parameter biasing | |
113 | COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR | |
114 | * parameter for intranuclear cascade | |
115 | LOGICAL LPAULI | |
116 | COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI | |
117 | * various options for treatment of partons (DTUNUC 1.x) | |
118 | * (chain recombination, Cronin,..) | |
119 | LOGICAL LCO2CR,LINTPT | |
120 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, | |
121 | & LCO2CR,LINTPT | |
122 | * threshold values for x-sampling (DTUNUC 1.x) | |
123 | COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA, | |
124 | & SSMIMQ,VVMTHR | |
125 | * flags for input different options | |
126 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
127 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
128 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
129 | * nuclear potential | |
130 | LOGICAL LFERMI | |
131 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, | |
132 | & EBINDP(2),EBINDN(2),EPOT(2,210), | |
133 | & ETACOU(2),ICOUL,LFERMI | |
134 | * n-n cross section fluctuations | |
135 | PARAMETER (NBINS = 1000) | |
136 | COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT | |
137 | * flags for particle decays | |
138 | COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20), | |
139 | & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20), | |
140 | & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0 | |
141 | * diquark-breaking mechanism | |
142 | COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3 | |
143 | * nucleon-nucleon event-generator | |
144 | CHARACTER*8 CMODEL | |
145 | LOGICAL LPHOIN | |
146 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
147 | * properties of interacting particles | |
148 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
149 | * properties of photon/lepton projectiles | |
150 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC | |
151 | * flags for diffractive interactions (DTUNUC 1.x) | |
152 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF | |
153 | * parameters for hA-diffraction | |
154 | COMMON /DTDIHA/ DIBETA,DIALPH | |
155 | * Lorentz-parameters of the current interaction | |
156 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
157 | & UMO,PPCM,EPROJ,PPROJ | |
158 | * kinematical cuts for lepton-nucleus interactions | |
159 | COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX, | |
160 | & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI | |
161 | * VDM parameter for photon-nucleus interactions | |
162 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
163 | * Glauber formalism: flags and parameters for statistics | |
164 | LOGICAL LPROD | |
165 | CHARACTER*8 CGLB | |
166 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD | |
167 | * cuts for variable energy runs | |
168 | COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI | |
169 | * flags for activated histograms | |
170 | COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL | |
171 | COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) | |
172 | COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5) | |
173 | * LEPTO | |
174 | **LUND single / double precision | |
175 | REAL CUT,PARL,TMPX,TMPY,TMPW2,TMPQ2,TMPU | |
176 | COMMON /LEPTOU/ CUT(14),LST(40),PARL(30), | |
177 | & TMPX,TMPY,TMPW2,TMPQ2,TMPU | |
178 | * LEPTO | |
179 | REAL RPPN | |
180 | COMMON /LEPTOI/ RPPN,LEPIN,INTER | |
181 | * steering flags for qel neutrino scattering modules | |
182 | COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC | |
183 | * event flag | |
184 | COMMON /DTEVNO/ NEVENT,ICASCA | |
185 | ||
186 | INTEGER PYCOMP | |
187 | ||
188 | C DIMENSION XPARA(5) | |
189 | DIMENSION XDUMB(40),IPRANG(5) | |
190 | ||
191 | PARAMETER (MXCARD=58) | |
192 | CHARACTER*78 CLINE,CTITLE | |
193 | CHARACTER*60 CWHAT | |
194 | CHARACTER*8 BLANK,SDUM | |
195 | CHARACTER*10 CODE,CODEWD | |
196 | CHARACTER*72 HEADER | |
197 | LOGICAL LSTART,LEINP,LXSTAB | |
198 | DIMENSION WHAT(6),CODE(MXCARD) | |
199 | DATA CODE/ | |
200 | & 'TITLE ','PROJPAR ','TARPAR ','ENERGY ', | |
201 | & 'MOMENTUM ','CMENERGY ','EMULSION ','FERMI ', | |
202 | & 'TAUFOR ','PAULI ','COULOMB ','HADRIN ', | |
203 | & 'EVAP ','EMCCHECK ','MODEL ','PHOINPUT ', | |
204 | & 'GLAUBERI ','FLUCTUAT ','CENTRAL ','RECOMBIN ', | |
205 | & 'COMBIJET ','XCUTS ','INTPT ','CRONINPT ', | |
206 | & 'SEADISTR ','SEASU3 ','DIQUARKS ','RESONANC ', | |
207 | & 'DIFFRACT ','SINGLECH ','NOFRAGME ','HADRONIZE ', | |
208 | & 'POPCORN ','PARDECAY ','BEAM ','LUND-MSTU ', | |
209 | & 'LUND-MSTJ ','LUND-MDCY ','LUND-PARJ ','LUND-PARU ', | |
210 | & 'OUTLEVEL ','FRAME ','L-TAG ','L-ETAG ', | |
211 | & 'ECMS-CUT ','VDM-PAR1 ','HISTOGRAM ','XS-TABLE ', | |
212 | & 'GLAUB-PAR ','GLAUB-INI ','VDM-PAR2 ','XS-QELPRO ', | |
213 | & 'RNDMINIT ','LEPTO-CUT ','LEPTO-LST ','LEPTO-PARL', | |
214 | & 'START ','STOP '/ | |
215 | DATA BLANK /' '/ | |
216 | ||
217 | DATA LSTART,LXSTAB,IFIRST /.TRUE.,.FALSE.,1/ | |
218 | DATA CMEOLD /0.0D0/ | |
219 | ||
220 | *--------------------------------------------------------------------- | |
221 | * at the first call of INIT: initialize event generation | |
222 | EPNSAV = EPN | |
223 | IF (LSTART) THEN | |
224 | CALL DT_TITLE | |
225 | * initialization and test of the random number generator | |
226 | IF (ITRSPT.NE.1) THEN | |
227 | CALL DT_RNDMST(22,54,76,92) | |
228 | CALL DT_RNDMTE(1) | |
229 | ENDIF | |
230 | * initialization of BAMJET, DECAY and HADRIN | |
231 | CALL DT_DDATAR | |
232 | CALL DT_DHADDE | |
233 | CALL DT_DCHANT | |
234 | CALL DT_DCHANH | |
235 | * set default values for input variables | |
236 | CALL DT_DEFAUL(EPN,PPN) | |
237 | IGLAU = 0 | |
238 | IXSQEL = 0 | |
239 | * flag for collision energy input | |
240 | LEINP = .FALSE. | |
241 | LSTART = .FALSE. | |
242 | ENDIF | |
243 | ||
244 | *--------------------------------------------------------------------- | |
245 | 10 CONTINUE | |
246 | ||
247 | * bypass reading input cards (e.g. for use with Fluka) | |
248 | * in this case Epn is expected to carry the beam momentum | |
249 | IF (NCASES.EQ.-1) THEN | |
250 | IP = NPMASS | |
251 | IPZ = NPCHAR | |
252 | PPN = EPNSAV | |
253 | EPN = ZERO | |
254 | CMENER = ZERO | |
255 | LEINP = .TRUE. | |
256 | MKCRON = 0 | |
257 | WHAT(1) = 1 | |
258 | WHAT(2) = 0 | |
259 | CODEWD = 'START ' | |
260 | GOTO 900 | |
261 | ENDIF | |
262 | ||
263 | * read control card from input-unit LINP | |
264 | READ(LINP,'(A78)',END=9999) CLINE | |
265 | IF (CLINE(1:1).EQ.'*') THEN | |
266 | * comment-line | |
267 | WRITE(LOUT,'(A78)') CLINE | |
268 | GOTO 10 | |
269 | ENDIF | |
270 | C READ(CLINE,1000,END=9999) CODEWD,(WHAT(I),I=1,6),SDUM | |
271 | C1000 FORMAT(A10,6E10.0,A8) | |
272 | DO 1008 I=1,6 | |
273 | WHAT(I) = ZERO | |
274 | 1008 CONTINUE | |
275 | READ(CLINE,1006,END=9999) CODEWD,CWHAT,SDUM | |
276 | 1006 FORMAT(A10,A60,A8) | |
277 | READ(CWHAT,*,END=1007) (WHAT(I),I=1,6) | |
278 | 1007 CONTINUE | |
279 | WRITE(LOUT,1001) CODEWD,(WHAT(I),I=1,6),SDUM | |
280 | 1001 FORMAT(A10,6G10.3,A8) | |
281 | ||
282 | 900 CONTINUE | |
283 | ||
284 | * check for valid control card and get card index | |
285 | ICW = 0 | |
286 | DO 11 I=1,MXCARD | |
287 | IF (CODEWD.EQ.CODE(I)) ICW = I | |
288 | 11 CONTINUE | |
289 | IF (ICW.EQ.0) THEN | |
290 | WRITE(LOUT,1002) CODEWD | |
291 | 1002 FORMAT(/,1X,'---> ',A10,': invalid control-card !',/) | |
292 | GOTO 10 | |
293 | ENDIF | |
294 | ||
295 | GOTO( | |
296 | *------------------------------------------------------------ | |
297 | * TITLE , PROJPAR , TARPAR , ENERGY , MOMENTUM, | |
298 | & 100 , 110 , 120 , 130 , 140 , | |
299 | * | |
300 | *------------------------------------------------------------ | |
301 | * CMENERGY, EMULSION, FERMI , TAUFOR , PAULI , | |
302 | & 150 , 160 , 170 , 180 , 190 , | |
303 | * | |
304 | *------------------------------------------------------------ | |
305 | * COULOMB , HADRIN , EVAP , EMCCHECK, MODEL , | |
306 | & 200 , 210 , 220 , 230 , 240 , | |
307 | * | |
308 | *------------------------------------------------------------ | |
309 | * PHOINPUT, GLAUBERI, FLUCTUAT, CENTRAL , RECOMBIN, | |
310 | & 250 , 260 , 270 , 280 , 290 , | |
311 | * | |
312 | *------------------------------------------------------------ | |
313 | * COMBIJET, XCUTS , INTPT , CRONINPT, SEADISTR, | |
314 | & 300 , 310 , 320 , 330 , 340 , | |
315 | * | |
316 | *------------------------------------------------------------ | |
317 | * SEASU3 , DIQUARKS, RESONANC, DIFFRACT, SINGLECH, | |
318 | & 350 , 360 , 370 , 380 , 390 , | |
319 | * | |
320 | *------------------------------------------------------------ | |
321 | * NOFRAGME, HADRONIZE, POPCORN , PARDECAY, BEAM , | |
322 | & 400 , 410 , 420 , 430 , 440 , | |
323 | * | |
324 | *------------------------------------------------------------ | |
325 | * LUND-MSTU, LUND-MSTJ, LUND-MDCY, LUND-PARJ, LUND-PARU, | |
326 | & 450 , 451 , 452 , 460 , 470 , | |
327 | * | |
328 | *------------------------------------------------------------ | |
329 | * OUTLEVEL, FRAME , L-TAG , L-ETAG , ECMS-CUT, | |
330 | & 480 , 490 , 500 , 510 , 520 , | |
331 | * | |
332 | *------------------------------------------------------------ | |
333 | * VDM-PAR1, HISTOGRAM, XS-TABLE , GLAUB-PAR, GLAUB-INI, | |
334 | & 530 , 540 , 550 , 560 , 565 , | |
335 | * | |
336 | *------------------------------------------------------------ | |
337 | * , , VDM-PAR2, XS-QELPRO, RNDMINIT , | |
338 | & 570 , 580 , 590 , | |
339 | * | |
340 | *------------------------------------------------------------ | |
341 | * LEPTO-CUT, LEPTO-LST,LEPTO-PARL, START , STOP ) | |
342 | & 600 , 610 , 620 , 630 , 640 ) , ICW | |
343 | * | |
344 | *------------------------------------------------------------ | |
345 | ||
346 | GOTO 10 | |
347 | ||
348 | ********************************************************************* | |
349 | * * | |
350 | * control card: codewd = TITLE * | |
351 | * * | |
352 | * what (1..6), sdum no meaning * | |
353 | * * | |
354 | * Note: The control-card following this must consist of * | |
355 | * a string of characters usually giving the title of * | |
356 | * the run. * | |
357 | * * | |
358 | ********************************************************************* | |
359 | ||
360 | 100 CONTINUE | |
361 | READ(LINP,'(A78)') CTITLE | |
362 | WRITE(LOUT,'(//,5X,A78,//)') CTITLE | |
363 | GOTO 10 | |
364 | ||
365 | ********************************************************************* | |
366 | * * | |
367 | * control card: codewd = PROJPAR * | |
368 | * * | |
369 | * what (1) = mass number of projectile nucleus default: 1 * | |
370 | * what (2) = charge of projectile nucleus default: 1 * | |
371 | * what (3..6) no meaning * | |
372 | * sdum projectile particle code word * | |
373 | * * | |
374 | * Note: If sdum is defined what (1..2) have no meaning. * | |
375 | * * | |
376 | ********************************************************************* | |
377 | ||
378 | 110 CONTINUE | |
379 | IF (SDUM.EQ.BLANK) THEN | |
380 | IP = INT(WHAT(1)) | |
381 | IPZ = INT(WHAT(2)) | |
382 | IJPROJ = 1 | |
383 | IBPROJ = 1 | |
384 | ELSE | |
385 | IJPROJ = 0 | |
386 | DO 111 II=1,30 | |
387 | IF (SDUM.EQ.BTYPE(II)) THEN | |
388 | IP = 1 | |
389 | IPZ = 1 | |
390 | IF (II.EQ.26) THEN | |
391 | IJPROJ = 135 | |
392 | ELSEIF (II.EQ.27) THEN | |
393 | IJPROJ = 136 | |
394 | ELSEIF (II.EQ.28) THEN | |
395 | IJPROJ = 133 | |
396 | ELSEIF (II.EQ.29) THEN | |
397 | IJPROJ = 134 | |
398 | ELSE | |
399 | IJPROJ = II | |
400 | ENDIF | |
401 | IBPROJ = IIBAR(IJPROJ) | |
402 | * photon | |
403 | IF ((IJPROJ.EQ.7).AND.(WHAT(1).GT.ZERO)) VIRT = WHAT(1) | |
404 | * lepton | |
405 | IF (((IJPROJ.EQ. 3).OR.(IJPROJ.EQ. 4).OR. | |
406 | & (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11)).AND. | |
407 | & (WHAT(1).GT.ZERO)) Q2HI = WHAT(1) | |
408 | ENDIF | |
409 | 111 CONTINUE | |
410 | IF (IJPROJ.EQ.0) THEN | |
411 | WRITE(LOUT,1110) | |
412 | 1110 FORMAT(/,1X,'invalid PROJPAR card !',/) | |
413 | GOTO 9999 | |
414 | ENDIF | |
415 | ENDIF | |
416 | GOTO 10 | |
417 | ||
418 | ********************************************************************* | |
419 | * * | |
420 | * control card: codewd = TARPAR * | |
421 | * * | |
422 | * what (1) = mass number of target nucleus default: 1 * | |
423 | * what (2) = charge of target nucleus default: 1 * | |
424 | * what (3..6) no meaning * | |
425 | * sdum target particle code word * | |
426 | * * | |
427 | * Note: If sdum is defined what (1..2) have no meaning. * | |
428 | * * | |
429 | ********************************************************************* | |
430 | ||
431 | 120 CONTINUE | |
432 | IF (SDUM.EQ.BLANK) THEN | |
433 | IT = INT(WHAT(1)) | |
434 | ITZ = INT(WHAT(2)) | |
435 | IJTARG = 1 | |
436 | IBTARG = 1 | |
437 | ELSE | |
438 | IJTARG = 0 | |
439 | DO 121 II=1,30 | |
440 | IF (SDUM.EQ.BTYPE(II)) THEN | |
441 | IT = 1 | |
442 | ITZ = 1 | |
443 | IJTARG = II | |
444 | IBTARG = IIBAR(IJTARG) | |
445 | ENDIF | |
446 | 121 CONTINUE | |
447 | IF (IJTARG.EQ.0) THEN | |
448 | WRITE(LOUT,1120) | |
449 | 1120 FORMAT(/,1X,'invalid TARPAR card !',/) | |
450 | GOTO 9999 | |
451 | ENDIF | |
452 | ENDIF | |
453 | GOTO 10 | |
454 | ||
455 | ********************************************************************* | |
456 | * * | |
457 | * control card: codewd = ENERGY * | |
458 | * * | |
459 | * what (1) = energy (GeV) of projectile in Lab. * | |
460 | * if what(1) < 0: |what(1)| = kinetic energy * | |
461 | * default: 200 GeV * | |
462 | * if |what(2)| > 0: min. energy for variable * | |
463 | * energy runs * | |
464 | * what (2) = max. energy for variable energy runs * | |
465 | * if what(2) < 0: |what(2)| = kinetic energy * | |
466 | * * | |
467 | ********************************************************************* | |
468 | ||
469 | 130 CONTINUE | |
470 | EPN = WHAT(1) | |
471 | PPN = ZERO | |
472 | CMENER = ZERO | |
473 | IF ((ABS(WHAT(2)).GT.ZERO).AND. | |
474 | & (ABS(WHAT(2)).GT.ABS(WHAT(1)))) THEN | |
475 | VARELO = WHAT(1) | |
476 | VAREHI = WHAT(2) | |
477 | EPN = VAREHI | |
478 | ENDIF | |
479 | LEINP = .TRUE. | |
480 | GOTO 10 | |
481 | ||
482 | ********************************************************************* | |
483 | * * | |
484 | * control card: codewd = MOMENTUM * | |
485 | * * | |
486 | * what (1) = momentum (GeV/c) of projectile in Lab. * | |
487 | * default: 200 GeV/c * | |
488 | * what (2..6), sdum no meaning * | |
489 | * * | |
490 | ********************************************************************* | |
491 | ||
492 | 140 CONTINUE | |
493 | EPN = ZERO | |
494 | PPN = WHAT(1) | |
495 | CMENER = ZERO | |
496 | LEINP = .TRUE. | |
497 | GOTO 10 | |
498 | ||
499 | ********************************************************************* | |
500 | * * | |
501 | * control card: codewd = CMENERGY * | |
502 | * * | |
503 | * what (1) = energy in nucleon-nucleon cms. * | |
504 | * default: none * | |
505 | * what (2..6), sdum no meaning * | |
506 | * * | |
507 | ********************************************************************* | |
508 | ||
509 | 150 CONTINUE | |
510 | EPN = ZERO | |
511 | PPN = ZERO | |
512 | CMENER = WHAT(1) | |
513 | LEINP = .TRUE. | |
514 | GOTO 10 | |
515 | ||
516 | ********************************************************************* | |
517 | * * | |
518 | * control card: codewd = EMULSION * | |
519 | * * | |
520 | * definition of nuclear emulsions * | |
521 | * * | |
522 | * what(1) mass number of emulsion component * | |
523 | * what(2) charge of emulsion component * | |
524 | * what(3) fraction of events in which a scattering on a * | |
525 | * nucleus of this properties is performed * | |
526 | * what(4,5,6) as what(1,2,3) but for another component * | |
527 | * default: no emulsion * | |
528 | * sdum no meaning * | |
529 | * * | |
530 | * Note: If this input-card is once used with valid parameters * | |
531 | * TARPAR is obsolete. * | |
532 | * Not the absolute values of the fractions are important * | |
533 | * but only the ratios of fractions of different comp. * | |
534 | * This control card can be repeatedly used to define * | |
535 | * emulsions consisting of up to 10 elements. * | |
536 | * * | |
537 | ********************************************************************* | |
538 | ||
539 | 160 CONTINUE | |
540 | IF ((WHAT(1).GT.ZERO).AND.(WHAT(2).GT.ZERO) | |
541 | & .AND.(ABS(WHAT(3)).GT.ZERO)) THEN | |
542 | NCOMPO = NCOMPO+1 | |
543 | IF (NCOMPO.GT.NCOMPX) THEN | |
544 | WRITE(LOUT,1600) | |
545 | STOP | |
546 | ENDIF | |
547 | IEMUMA(NCOMPO) = INT(WHAT(1)) | |
548 | IEMUCH(NCOMPO) = INT(WHAT(2)) | |
549 | EMUFRA(NCOMPO) = WHAT(3) | |
550 | IEMUL = 1 | |
551 | C CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO)) | |
552 | ENDIF | |
553 | IF ((WHAT(4).GT.ZERO).AND.(WHAT(5).GT.ZERO) | |
554 | & .AND.(ABS(WHAT(6)).GT.ZERO)) THEN | |
555 | NCOMPO = NCOMPO+1 | |
556 | IF (NCOMPO.GT.NCOMPX) THEN | |
557 | WRITE(LOUT,1001) | |
558 | STOP | |
559 | ENDIF | |
560 | IEMUMA(NCOMPO) = INT(WHAT(4)) | |
561 | IEMUCH(NCOMPO) = INT(WHAT(5)) | |
562 | EMUFRA(NCOMPO) = WHAT(6) | |
563 | C CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO)) | |
564 | ENDIF | |
565 | 1600 FORMAT(1X,'too many emulsion components - program stopped') | |
566 | GOTO 10 | |
567 | ||
568 | ********************************************************************* | |
569 | * * | |
570 | * control card: codewd = FERMI * | |
571 | * * | |
572 | * what (1) = -1 Fermi-motion of nucleons not treated * | |
573 | * default: 1 * | |
574 | * what (2) = scale factor for Fermi-momentum * | |
575 | * default: 0.75 * | |
576 | * what (3..6), sdum no meaning * | |
577 | * * | |
578 | ********************************************************************* | |
579 | ||
580 | 170 CONTINUE | |
581 | IF (WHAT(1).EQ.-1.0D0) THEN | |
582 | LFERMI = .FALSE. | |
583 | ELSE | |
584 | LFERMI = .TRUE. | |
585 | ENDIF | |
586 | XMOD = WHAT(2) | |
587 | IF (XMOD.GE.ZERO) FERMOD = XMOD | |
588 | GOTO 10 | |
589 | ||
590 | ********************************************************************* | |
591 | * * | |
592 | * control card: codewd = TAUFOR * | |
593 | * * | |
594 | * formation time supressed intranuclear cascade * | |
595 | * * | |
596 | * what (1) formation time (in fm/c) * | |
597 | * note: what(1)=10. corresponds roughly to an * | |
598 | * average formation time of 1 fm/c * | |
599 | * default: 5. fm/c * | |
600 | * what (2) number of generations followed * | |
601 | * default: 25 * | |
602 | * what (3) = 1. p_t-dependent formation zone * | |
603 | * = 2. constant formation zone * | |
604 | * default: 1 * | |
605 | * what (4) modus of selection of nucleus where the * | |
606 | * cascade if followed first * | |
607 | * = 1. proj./target-nucleus with probab. 1/2 * | |
608 | * = 2. nucleus with highest mass * | |
609 | * = 3. proj. nucleus if particle is moving in pos. z * | |
610 | * targ. nucleus if particle is moving in neg. z * | |
611 | * default: 1 * | |
612 | * what (5..6), sdum no meaning * | |
613 | * * | |
614 | ********************************************************************* | |
615 | ||
616 | 180 CONTINUE | |
617 | TAUFOR = WHAT(1) | |
618 | KTAUGE = INT(WHAT(2)) | |
619 | INCMOD = 1 | |
620 | IF ((WHAT(3).GE.1.0D0).AND.(WHAT(3).LE.2.0D0)) | |
621 | & ITAUVE = INT(WHAT(3)) | |
622 | IF ((WHAT(4).GE.1.0D0).AND.(WHAT(4).LE.3.0D0)) | |
623 | & INCMOD = INT(WHAT(4)) | |
624 | GOTO 10 | |
625 | ||
626 | ********************************************************************* | |
627 | * * | |
628 | * control card: codewd = PAULI * | |
629 | * * | |
630 | * what (1) = -1 Pauli's principle for secondary * | |
631 | * interactions not treated * | |
632 | * default: 1 * | |
633 | * what (2..6), sdum no meaning * | |
634 | * * | |
635 | ********************************************************************* | |
636 | ||
637 | 190 CONTINUE | |
638 | IF (WHAT(1).EQ.-1.0D0) THEN | |
639 | LPAULI = .FALSE. | |
640 | ELSE | |
641 | LPAULI = .TRUE. | |
642 | ENDIF | |
643 | GOTO 10 | |
644 | ||
645 | ********************************************************************* | |
646 | * * | |
647 | * control card: codewd = COULOMB * | |
648 | * * | |
649 | * what (1) = -1. Coulomb-energy treatment switched off * | |
650 | * default: 1 * | |
651 | * what (2..6), sdum no meaning * | |
652 | * * | |
653 | ********************************************************************* | |
654 | ||
655 | 200 CONTINUE | |
656 | ICOUL = 1 | |
657 | IF (WHAT(1).EQ.-1.0D0) THEN | |
658 | ICOUL = 0 | |
659 | ELSE | |
660 | ICOUL = 1 | |
661 | ENDIF | |
662 | GOTO 10 | |
663 | ||
664 | ********************************************************************* | |
665 | * * | |
666 | * control card: codewd = HADRIN * | |
667 | * * | |
668 | * HADRIN module * | |
669 | * * | |
670 | * what (1) = 0. elastic/inelastic interactions with probab. * | |
671 | * as defined by cross-sections * | |
672 | * = 1. inelastic interactions forced * | |
673 | * = 2. elastic interactions forced * | |
674 | * default: 1 * | |
675 | * what (2) upper threshold in total energy (GeV) below * | |
676 | * which interactions are sampled by HADRIN * | |
677 | * default: 5. GeV * | |
678 | * what (3..6), sdum no meaning * | |
679 | * * | |
680 | ********************************************************************* | |
681 | ||
682 | 210 CONTINUE | |
683 | IWHAT = INT(WHAT(1)) | |
684 | IF ((IWHAT.GE.0).AND.(IWHAT.LE.2)) INTHAD = IWHAT | |
685 | IF ((WHAT(2).GT.ZERO).AND.(WHAT(2).LT.15.0D0)) EHADTH = WHAT(2) | |
686 | GOTO 10 | |
687 | ||
688 | ********************************************************************* | |
689 | * * | |
690 | * control card: codewd = EVAP * | |
691 | * * | |
692 | * evaporation module * | |
693 | * * | |
694 | * what (1) =< -1 ==> evaporation is switched off * | |
695 | * >= 1 ==> evaporation is performed * | |
696 | * * | |
697 | * what (1) = i1 + i2*10 + i3*100 + i4*10000 * | |
698 | * (i1, i2, i3, i4 >= 0 ) * | |
699 | * * | |
700 | * i1 is the flag for selecting the T=0 level density option used * | |
701 | * = 1: standard EVAP level densities with Cook pairing * | |
702 | * energies * | |
703 | * = 2: Z,N-dependent Gilbert & Cameron level densities * | |
704 | * (default) * | |
705 | * = 3: Julich A-dependent level densities * | |
706 | * = 4: Z,N-dependent Brancazio & Cameron level densities * | |
707 | * * | |
708 | * i2 >= 1: high energy fission activated * | |
709 | * (default high energy fission activated) * | |
710 | * * | |
711 | * i3 = 0: No energy dependence for level densities * | |
712 | * = 1: Standard Ignyatuk (1975, 1st) energy dependence * | |
713 | * for level densities (default) * | |
714 | * = 2: Standard Ignyatuk (1975, 1st) energy dependence * | |
715 | * for level densities with NOT used set of parameters * | |
716 | * = 3: Standard Ignyatuk (1975, 1st) energy dependence * | |
717 | * for level densities with NOT used set of parameters * | |
718 | * = 4: Second Ignyatuk (1975, 2nd) energy dependence * | |
719 | * for level densities * | |
720 | * = 5: Second Ignyatuk (1975, 2nd) energy dependence * | |
721 | * for level densities with fit 1 Iljinov & Mebel set of * | |
722 | * parameters * | |
723 | * = 6: Second Ignyatuk (1975, 2nd) energy dependence * | |
724 | * for level densities with fit 2 Iljinov & Mebel set of * | |
725 | * parameters * | |
726 | * = 7: Second Ignyatuk (1975, 2nd) energy dependence * | |
727 | * for level densities with fit 3 Iljinov & Mebel set of * | |
728 | * parameters * | |
729 | * = 8: Second Ignyatuk (1975, 2nd) energy dependence * | |
730 | * for level densities with fit 4 Iljinov & Mebel set of * | |
731 | * parameters * | |
732 | * * | |
733 | * i4 >= 1: Original Gilbert and Cameron pairing energies used * | |
734 | * (default Cook's modified pairing energies) * | |
735 | * * | |
736 | * what (2) = ig + 10 * if (ig and if must have the same sign) * | |
737 | * * | |
738 | * ig =< -1 ==> deexcitation gammas are not produced * | |
739 | * (if the evaporation step is not performed * | |
740 | * they are never produced) * | |
741 | * if =< -1 ==> Fermi Break Up is not invoked * | |
742 | * (if the evaporation step is not performed * | |
743 | * it is never invoked) * | |
744 | * The default is: deexcitation gamma produced and Fermi break up * | |
745 | * activated for the new preequilibrium, not * | |
746 | * activated otherwise. * | |
747 | * what (3..6), sdum no meaning * | |
748 | * * | |
749 | ********************************************************************* | |
750 | ||
751 | 220 CONTINUE | |
752 | WRITE(LOUT,1009) | |
753 | 1009 FORMAT(1X,/,'Warning! Evaporation request rejected since', | |
754 | & ' evaporation modules not available with this version.') | |
755 | LEVPRT = .FALSE. | |
756 | LDEEXG = .FALSE. | |
757 | LHEAVY = .FALSE. | |
758 | LFRMBK = .FALSE. | |
759 | IFISS = 0 | |
760 | IEVFSS = 0 | |
761 | ||
762 | GOTO 10 | |
763 | ||
764 | ********************************************************************* | |
765 | * * | |
766 | * control card: codewd = EMCCHECK * | |
767 | * * | |
768 | * extended energy-momentum / quantum-number conservation check * | |
769 | * * | |
770 | * what (1) = -1 extended check not performed * | |
771 | * default: 1. * | |
772 | * what (2..6), sdum no meaning * | |
773 | * * | |
774 | ********************************************************************* | |
775 | ||
776 | 230 CONTINUE | |
777 | IF (WHAT(1).EQ.-1) THEN | |
778 | LEMCCK = .FALSE. | |
779 | ELSE | |
780 | LEMCCK = .TRUE. | |
781 | ENDIF | |
782 | GOTO 10 | |
783 | ||
784 | ********************************************************************* | |
785 | * * | |
786 | * control card: codewd = MODEL * | |
787 | * * | |
788 | * Model to be used to treat nucleon-nucleon interactions * | |
789 | * * | |
790 | * sdum = DTUNUC two-chain model * | |
791 | * = PHOJET multiple chains including minijets * | |
792 | * = LEPTO DIS * | |
793 | * = QNEUTRIN quasi-elastic neutrino scattering * | |
794 | * default: PHOJET * | |
795 | * * | |
796 | * if sdum = LEPTO: * | |
797 | * what (1) (variable INTER) * | |
798 | * = 1 gamma exchange * | |
799 | * = 2 W+- exchange * | |
800 | * = 3 Z0 exchange * | |
801 | * = 4 gamma/Z0 exchange * | |
802 | * * | |
803 | * if sdum = QNEUTRIN: * | |
804 | * what (1) = 0 elastic scattering on nucleon and * | |
805 | * tau does not decay (default) * | |
806 | * = 1 decay of tau into mu.. * | |
807 | * = 2 decay of tau into e.. * | |
808 | * = 10 CC events on p and n * | |
809 | * = 11 NC events on p and n * | |
810 | * * | |
811 | * what (2..6) no meaning * | |
812 | * * | |
813 | ********************************************************************* | |
814 | ||
815 | 240 CONTINUE | |
816 | IF (SDUM.EQ.CMODEL(1)) THEN | |
817 | MCGENE = 1 | |
818 | ELSEIF (SDUM.EQ.CMODEL(2)) THEN | |
819 | MCGENE = 2 | |
820 | ELSEIF (SDUM.EQ.CMODEL(3)) THEN | |
821 | MCGENE = 3 | |
822 | IF ((WHAT(1).GE.1.0D0).AND.(WHAT(1).LE.4.0D0)) | |
823 | & INTER = INT(WHAT(1)) | |
824 | ELSEIF (SDUM.EQ.CMODEL(4)) THEN | |
825 | MCGENE = 4 | |
826 | IWHAT = INT(WHAT(1)) | |
827 | IF ((IWHAT.EQ.1 ).OR.(IWHAT.EQ.2 ).OR. | |
828 | & (IWHAT.EQ.10).OR.(IWHAT.EQ.11)) | |
829 | & NEUDEC = IWHAT | |
830 | ELSE | |
831 | STOP ' Unknown model !' | |
832 | ENDIF | |
833 | GOTO 10 | |
834 | ||
835 | ********************************************************************* | |
836 | * * | |
837 | * control card: codewd = PHOINPUT * | |
838 | * * | |
839 | * Start of input-section for PHOJET-specific input-cards * | |
840 | * Note: This section will not be finished before giving * | |
841 | * ENDINPUT-card * | |
842 | * what (1..6), sdum no meaning * | |
843 | * * | |
844 | ********************************************************************* | |
845 | ||
846 | 250 CONTINUE | |
847 | IF (LPHOIN) THEN | |
848 | CALL PHO_INIT(LINP,LOUT,IREJ1) | |
849 | IF (IREJ1.NE.0) THEN | |
850 | WRITE(LOUT,'(1X,A)')'INIT: reading PHOJET-input failed' | |
851 | STOP | |
852 | ENDIF | |
853 | LPHOIN = .FALSE. | |
854 | ENDIF | |
855 | GOTO 10 | |
856 | ||
857 | ********************************************************************* | |
858 | * * | |
859 | * control card: codewd = GLAUBERI * | |
860 | * * | |
861 | * Pre-initialization of impact parameter selection * | |
862 | * * | |
863 | * what (1..6), sdum no meaning * | |
864 | * * | |
865 | ********************************************************************* | |
866 | ||
867 | 260 CONTINUE | |
868 | IF (IFIRST.NE.99) THEN | |
869 | CALL DT_RNDMST(12,34,56,78) | |
870 | CALL DT_RNDMTE(1) | |
871 | OPEN(40,FILE='outdata0/shm.out',STATUS='UNKNOWN') | |
872 | C OPEN(11,FILE='outdata0/shm.dbg',STATUS='UNKNOWN') | |
873 | IFIRST = 99 | |
874 | ENDIF | |
875 | ||
876 | IPPN = 8 | |
877 | PLOW = 10.0D0 | |
878 | C IPPN = 1 | |
879 | C PLOW = 100.0D0 | |
880 | PHI = 1.0D5 | |
881 | APLOW = LOG10(PLOW) | |
882 | APHI = LOG10(PHI) | |
883 | ADP = (APHI-APLOW)/DBLE(IPPN) | |
884 | ||
885 | IPLOW = 1 | |
886 | IDIP = 1 | |
887 | IIP = 5 | |
888 | C IPLOW = 1 | |
889 | C IDIP = 1 | |
890 | C IIP = 1 | |
891 | IPRANG(1) = 1 | |
892 | IPRANG(2) = 2 | |
893 | IPRANG(3) = 5 | |
894 | IPRANG(4) = 10 | |
895 | IPRANG(5) = 20 | |
896 | ||
897 | ITLOW = 30 | |
898 | IDIT = 3 | |
899 | IIT = 60 | |
900 | C IDIT = 10 | |
901 | C IIT = 21 | |
902 | ||
903 | DO 473 NCIT=1,IIT | |
904 | IT = ITLOW+(NCIT-1)*IDIT | |
905 | C IPHI = IT | |
906 | C IDIP = 10 | |
907 | C IIP = (IPHI-IPLOW)/IDIP | |
908 | C IF (IIP.EQ.0) IIP = 1 | |
909 | C IF (IT.EQ.IPLOW) IIP = 0 | |
910 | ||
911 | DO 472 NCIP=1,IIP | |
912 | IP = IPRANG(NCIP) | |
913 | CC IF (NCIP.LE.IIP) THEN | |
914 | C IP = IPLOW+(NCIP-1)*IDIP | |
915 | CC ELSE | |
916 | CC IP = IT | |
917 | CC ENDIF | |
918 | IF (IP.GT.IT) GOTO 472 | |
919 | ||
920 | DO 471 NCP=1,IPPN+1 | |
921 | APPN = APLOW+DBLE(NCP-1)*ADP | |
922 | PPN = 10**APPN | |
923 | ||
924 | OPEN(12,FILE='outdata0/shm.sta',STATUS='UNKNOWN') | |
925 | WRITE(12,'(1X,2I5,E15.3)') IP,IT,PPN | |
926 | CLOSE(12) | |
927 | ||
928 | XLIM1 = 0.0D0 | |
929 | XLIM2 = 50.0D0 | |
930 | XLIM3 = ZERO | |
931 | IBIN = 50 | |
932 | CALL DT_NEWHGR(XDUM,XDUM,XDUM,XDUMB,-1,IHDUM) | |
933 | CALL DT_NEWHGR(XLIM1,XLIM2,XLIM3,XDUMB,IBIN,IHSHMA) | |
934 | ||
935 | NEVFIT = 5 | |
936 | C IF ((IP.GT.10).OR.(IT.GT.10)) THEN | |
937 | C NEVFIT = 5 | |
938 | C ELSE | |
939 | C NEVFIT = 10 | |
940 | C ENDIF | |
941 | SIGAV = 0.0D0 | |
942 | ||
943 | DO 478 I=1,NEVFIT | |
944 | CALL DT_SHMAKI(IP,IDUM1,IT,IDUM1,IJPROJ,PPN,99) | |
945 | SIGAV = SIGAV+XSPRO(1,1,1) | |
946 | DO 479 J=1,50 | |
947 | XC = DBLE(J) | |
948 | CALL DT_FILHGR(XC,BSITE(1,1,1,J),IHSHMA,I) | |
949 | 479 CONTINUE | |
950 | 478 CONTINUE | |
951 | ||
952 | CALL DT_EVTHIS(IDUM) | |
953 | HEADER = ' BSITE' | |
954 | C CALL OUTGEN(IHSHMA,0,0,0,0,0,HEADER,0,NEVFIT,ONE,0,1,-1) | |
955 | ||
956 | C CALL GENFIT(XPARA) | |
957 | C WRITE(40,'(2I4,E11.3,F6.0,5E11.3)') | |
958 | C & IP,IT,PPN,SIGAV/DBLE(NEVFIT),XPARA | |
959 | ||
960 | 471 CONTINUE | |
961 | ||
962 | 472 CONTINUE | |
963 | ||
964 | 473 CONTINUE | |
965 | ||
966 | STOP | |
967 | ||
968 | ********************************************************************* | |
969 | * * | |
970 | * control card: codewd = FLUCTUAT * | |
971 | * * | |
972 | * Treatment of cross section fluctuations * | |
973 | * * | |
974 | * what (1) = 1 treat cross section fluctuations * | |
975 | * default: 0. * | |
976 | * what (1..6), sdum no meaning * | |
977 | * * | |
978 | ********************************************************************* | |
979 | ||
980 | 270 CONTINUE | |
981 | IFLUCT = 0 | |
982 | IF (WHAT(1).EQ.ONE) THEN | |
983 | IFLUCT = 1 | |
984 | CALL DT_FLUINI | |
985 | ENDIF | |
986 | GOTO 10 | |
987 | ||
988 | ********************************************************************* | |
989 | * * | |
990 | * control card: codewd = CENTRAL * | |
991 | * * | |
992 | * what (1) = 1. central production forced default: 0 * | |
993 | * if what (1) < 0 and > -100 * | |
994 | * what (2) = min. impact parameter default: 0 * | |
995 | * what (3) = max. impact parameter default: b_max * | |
996 | * if what (1) < -99 * | |
997 | * what (2) = fraction of cross section default: 1 * | |
998 | * if what (1) = -1 : evaporation/fzc suppressed * | |
999 | * if what (1) < -1 : evaporation/fzc allowed * | |
1000 | * * | |
1001 | * what (4..6), sdum no meaning * | |
1002 | * * | |
1003 | ********************************************************************* | |
1004 | ||
1005 | 280 CONTINUE | |
1006 | ICENTR = INT(WHAT(1)) | |
1007 | IF (ICENTR.LT.0) THEN | |
1008 | IF (ICENTR.GT.-100) THEN | |
1009 | BIMIN = WHAT(2) | |
1010 | BIMAX = WHAT(3) | |
1011 | ELSE | |
1012 | XSFRAC = WHAT(2) | |
1013 | ENDIF | |
1014 | ENDIF | |
1015 | GOTO 10 | |
1016 | ||
1017 | ********************************************************************* | |
1018 | * * | |
1019 | * control card: codewd = RECOMBIN * | |
1020 | * * | |
1021 | * Chain recombination * | |
1022 | * (recombine S-S and V-V chains to V-S chains) * | |
1023 | * * | |
1024 | * what (1) = -1. recombination switched off default: 1 * | |
1025 | * what (2..6), sdum no meaning * | |
1026 | * * | |
1027 | ********************************************************************* | |
1028 | ||
1029 | 290 CONTINUE | |
1030 | IRECOM = 1 | |
1031 | IF (WHAT(1).EQ.-1.0D0) IRECOM = 0 | |
1032 | GOTO 10 | |
1033 | ||
1034 | ********************************************************************* | |
1035 | * * | |
1036 | * control card: codewd = COMBIJET * | |
1037 | * * | |
1038 | * chain fusion (2 q-aq --> qq-aqaq) * | |
1039 | * * | |
1040 | * what (1) = 1 fusion treated * | |
1041 | * default: 0. * | |
1042 | * what (2) minimum number of uncombined chains from * | |
1043 | * single projectile or target nucleons * | |
1044 | * default: 0. * | |
1045 | * what (3..6), sdum no meaning * | |
1046 | * * | |
1047 | ********************************************************************* | |
1048 | ||
1049 | 300 CONTINUE | |
1050 | LCO2CR = .FALSE. | |
1051 | IF (INT(WHAT(1)).EQ.1) LCO2CR = .TRUE. | |
1052 | IF (WHAT(2).GE.ZERO) CUTOF = WHAT(2) | |
1053 | GOTO 10 | |
1054 | ||
1055 | ********************************************************************* | |
1056 | * * | |
1057 | * control card: codewd = XCUTS * | |
1058 | * * | |
1059 | * thresholds for x-sampling * | |
1060 | * * | |
1061 | * what (1) defines lower threshold for val.-q x-value (CVQ) * | |
1062 | * default: 1. * | |
1063 | * what (2) defines lower threshold for val.-qq x-value (CDQ) * | |
1064 | * default: 2. * | |
1065 | * what (3) defines lower threshold for sea-q x-value (CSEA) * | |
1066 | * default: 0.2 * | |
1067 | * what (4) sea-q x-values in S-S chains (SSMIMA) * | |
1068 | * default: 0.14 * | |
1069 | * what (5) not used * | |
1070 | * default: 2. * | |
1071 | * what (6), sdum no meaning * | |
1072 | * * | |
1073 | * Note: Lower thresholds (what(1..3)) are def. as x_thr=CXXX/ECM * | |
1074 | * * | |
1075 | ********************************************************************* | |
1076 | ||
1077 | 310 CONTINUE | |
1078 | IF (WHAT(1).GE.0.5D0) CVQ = WHAT(1) | |
1079 | IF (WHAT(2).GE.ONE) CDQ = WHAT(2) | |
1080 | IF (WHAT(3).GE.0.1D0) CSEA = WHAT(3) | |
1081 | IF (WHAT(4).GE.ZERO) THEN | |
1082 | SSMIMA = WHAT(4) | |
1083 | SSMIMQ = SSMIMA**2 | |
1084 | ENDIF | |
1085 | IF (WHAT(5).GT.2.0D0) VVMTHR = WHAT(5) | |
1086 | GOTO 10 | |
1087 | ||
1088 | ********************************************************************* | |
1089 | * * | |
1090 | * control card: codewd = INTPT * | |
1091 | * * | |
1092 | * what (1) = -1 intrinsic transverse momenta of partons * | |
1093 | * not treated default: 1 * | |
1094 | * what (2..6), sdum no meaning * | |
1095 | * * | |
1096 | ********************************************************************* | |
1097 | ||
1098 | 320 CONTINUE | |
1099 | IF (WHAT(1).EQ.-1.0D0) THEN | |
1100 | LINTPT = .FALSE. | |
1101 | ELSE | |
1102 | LINTPT = .TRUE. | |
1103 | ENDIF | |
1104 | GOTO 10 | |
1105 | ||
1106 | ********************************************************************* | |
1107 | * * | |
1108 | * control card: codewd = CRONINPT * | |
1109 | * * | |
1110 | * Cronin effect (multiple scattering of partons at chain ends) * | |
1111 | * * | |
1112 | * what (1) = -1 Cronin effect not treated default: 1 * | |
1113 | * what (2) = 0 scattering parameter default: 0.64 * | |
1114 | * what (3..6), sdum no meaning * | |
1115 | * * | |
1116 | ********************************************************************* | |
1117 | ||
1118 | 330 CONTINUE | |
1119 | IF (WHAT(1).EQ.-1.0D0) THEN | |
1120 | MKCRON = 0 | |
1121 | ELSE | |
1122 | MKCRON = 1 | |
1123 | ENDIF | |
1124 | CRONCO = WHAT(2) | |
1125 | GOTO 10 | |
1126 | ||
1127 | ********************************************************************* | |
1128 | * * | |
1129 | * control card: codewd = SEADISTR * | |
1130 | * * | |
1131 | * what (1) (XSEACO) sea(x) prop. 1/x**what (1) default: 1. * | |
1132 | * what (2) (UNON) default: 2. * | |
1133 | * what (3) (UNOM) default: 1.5 * | |
1134 | * what (4) (UNOSEA) default: 5. * | |
1135 | * qdis(x) prop. (1-x)**what (1) etc. * | |
1136 | * what (5..6), sdum no meaning * | |
1137 | * * | |
1138 | ********************************************************************* | |
1139 | ||
1140 | 340 CONTINUE | |
1141 | XSEACO = WHAT(1) | |
1142 | XSEACU = 1.05D0-XSEACO | |
1143 | UNON = WHAT(2) | |
1144 | IF (UNON.LT.0.1D0) UNON = 2.0D0 | |
1145 | UNOM = WHAT(3) | |
1146 | IF (UNOM.LT.0.1D0) UNOM = 1.5D0 | |
1147 | UNOSEA = WHAT(4) | |
1148 | IF (UNOSEA.LT.0.1D0) UNOSEA = 5.0D0 | |
1149 | GOTO 10 | |
1150 | ||
1151 | ********************************************************************* | |
1152 | * * | |
1153 | * control card: codewd = SEASU3 * | |
1154 | * * | |
1155 | * Treatment of strange-quarks at chain ends * | |
1156 | * * | |
1157 | * what (1) (SEASQ) strange-quark supression factor * | |
1158 | * iflav = 1.+rndm*(2.+SEASQ) * | |
1159 | * default: 1. * | |
1160 | * what (2..6), sdum no meaning * | |
1161 | * * | |
1162 | ********************************************************************* | |
1163 | ||
1164 | 350 CONTINUE | |
1165 | SEASQ = WHAT(1) | |
1166 | GOTO 10 | |
1167 | ||
1168 | ********************************************************************* | |
1169 | * * | |
1170 | * control card: codewd = DIQUARKS * | |
1171 | * * | |
1172 | * what (1) = -1. sea-diquark/antidiquark-pairs not treated * | |
1173 | * default: 1. * | |
1174 | * what (2..6), sdum no meaning * | |
1175 | * * | |
1176 | ********************************************************************* | |
1177 | ||
1178 | 360 CONTINUE | |
1179 | IF (WHAT(1).EQ.-1.0D0) THEN | |
1180 | LSEADI = .FALSE. | |
1181 | ELSE | |
1182 | LSEADI = .TRUE. | |
1183 | ENDIF | |
1184 | GOTO 10 | |
1185 | ||
1186 | ********************************************************************* | |
1187 | * * | |
1188 | * control card: codewd = RESONANC * | |
1189 | * * | |
1190 | * treatment of low mass chains * | |
1191 | * * | |
1192 | * what (1) = -1 low chain masses are not corrected for resonance * | |
1193 | * masses (obsolete for BAMJET-fragmentation) * | |
1194 | * default: 1. * | |
1195 | * what (2) = -1 massless partons default: 1. (massive) * | |
1196 | * default: 1. (massive) * | |
1197 | * what (3) = -1 chain-system containing chain of too small * | |
1198 | * mass is rejected (note: this does not fully * | |
1199 | * apply to S-S chains) default: 0. * | |
1200 | * what (4..6), sdum no meaning * | |
1201 | * * | |
1202 | ********************************************************************* | |
1203 | ||
1204 | 370 CONTINUE | |
1205 | IRESCO = 1 | |
1206 | IMSHL = 1 | |
1207 | IRESRJ = 0 | |
1208 | IF (WHAT(1).EQ.-ONE) IRESCO = 0 | |
1209 | IF (WHAT(2).EQ.-ONE) IMSHL = 0 | |
1210 | IF (WHAT(3).EQ.-ONE) IRESRJ = 1 | |
1211 | GOTO 10 | |
1212 | ||
1213 | ********************************************************************* | |
1214 | * * | |
1215 | * control card: codewd = DIFFRACT * | |
1216 | * * | |
1217 | * Treatment of diffractive events * | |
1218 | * * | |
1219 | * what (1) = (ISINGD) 0 no single diffraction * | |
1220 | * 1 single diffraction included * | |
1221 | * +-2 single diffractive events only * | |
1222 | * +-3 projectile single diffraction only * | |
1223 | * +-4 target single diffraction only * | |
1224 | * -5 double pomeron exchange only * | |
1225 | * (neg. sign applies to PHOJET events) * | |
1226 | * default: 0. * | |
1227 | * * | |
1228 | * what (2) = (IDOUBD) 0 no double diffraction * | |
1229 | * 1 double diffraction included * | |
1230 | * 2 double diffractive events only * | |
1231 | * default: 0. * | |
1232 | * what (3) = 1 projectile diffraction treated (2-channel form.) * | |
1233 | * default: 0. * | |
1234 | * what (4) = alpha-parameter in projectile diffraction * | |
1235 | * default: 0. * | |
1236 | * what (5..6), sdum no meaning * | |
1237 | * * | |
1238 | ********************************************************************* | |
1239 | ||
1240 | 380 CONTINUE | |
1241 | IF (ABS(WHAT(1)).GT.ZERO) ISINGD = INT(WHAT(1)) | |
1242 | IF (ABS(WHAT(2)).GT.ZERO) IDOUBD = INT(WHAT(2)) | |
1243 | IF ((ISINGD.GT.1).AND.(IDOUBD.GT.1)) THEN | |
1244 | WRITE(LOUT,1380) | |
1245 | 1380 FORMAT(1X,'INIT: inconsistent DIFFRACT - input !',/, | |
1246 | & 11X,'IDOUBD is reset to zero') | |
1247 | IDOUBD = 0 | |
1248 | ENDIF | |
1249 | IF (WHAT(3).GT.ZERO) DIBETA = WHAT(3) | |
1250 | IF (WHAT(4).GT.ZERO) DIALPH = WHAT(4) | |
1251 | GOTO 10 | |
1252 | ||
1253 | ********************************************************************* | |
1254 | * * | |
1255 | * control card: codewd = SINGLECH * | |
1256 | * * | |
1257 | * what (1) = 1. Regge contribution (one chain) included * | |
1258 | * default: 0. * | |
1259 | * what (2..6), sdum no meaning * | |
1260 | * * | |
1261 | ********************************************************************* | |
1262 | ||
1263 | 390 CONTINUE | |
1264 | ISICHA = 0 | |
1265 | IF (WHAT(1).EQ.ONE) ISICHA = 1 | |
1266 | GOTO 10 | |
1267 | ||
1268 | ********************************************************************* | |
1269 | * * | |
1270 | * control card: codewd = NOFRAGME * | |
1271 | * * | |
1272 | * biased chain hadronization * | |
1273 | * * | |
1274 | * what (1..6) = -1 no of hadronizsation of S-S chains * | |
1275 | * = -2 no of hadronizsation of D-S chains * | |
1276 | * = -3 no of hadronizsation of S-D chains * | |
1277 | * = -4 no of hadronizsation of S-V chains * | |
1278 | * = -5 no of hadronizsation of D-V chains * | |
1279 | * = -6 no of hadronizsation of V-S chains * | |
1280 | * = -7 no of hadronizsation of V-D chains * | |
1281 | * = -8 no of hadronizsation of V-V chains * | |
1282 | * = -9 no of hadronizsation of comb. chains * | |
1283 | * default: complete hadronization * | |
1284 | * sdum no meaning * | |
1285 | * * | |
1286 | ********************************************************************* | |
1287 | ||
1288 | 400 CONTINUE | |
1289 | DO 401 I=1,6 | |
1290 | ICHAIN = INT(WHAT(I)) | |
1291 | IF ((ICHAIN.LE.-1).AND.(ICHAIN.GE.-9)) | |
1292 | & LHADRO(ABS(ICHAIN)) = .FALSE. | |
1293 | 401 CONTINUE | |
1294 | GOTO 10 | |
1295 | ||
1296 | ********************************************************************* | |
1297 | * * | |
1298 | * control card: codewd = HADRONIZE * | |
1299 | * * | |
1300 | * hadronization model and parameter switch * | |
1301 | * * | |
1302 | * what (1) = 1 hadronization via BAMJET * | |
1303 | * = 2 hadronization via JETSET * | |
1304 | * default: 2 * | |
1305 | * what (2) = 1..3 parameter set to be used * | |
1306 | * JETSET: 3 sets available * | |
1307 | * ( = 3 default JETSET-parameters) * | |
1308 | * BAMJET: 1 set available * | |
1309 | * default: 1 * | |
1310 | * what (3..6), sdum no meaning * | |
1311 | * * | |
1312 | ********************************************************************* | |
1313 | ||
1314 | 410 CONTINUE | |
1315 | IWHAT1 = INT(WHAT(1)) | |
1316 | IWHAT2 = INT(WHAT(2)) | |
1317 | IF ((IWHAT1.EQ.1).OR.(IWHAT1.EQ.2)) IFRAG(1) = IWHAT1 | |
1318 | IF ((IWHAT1.EQ.2).AND.(IWHAT2.GE.1).AND.(IWHAT2.LE.3)) | |
1319 | & IFRAG(2) = IWHAT2 | |
1320 | GOTO 10 | |
1321 | ||
1322 | ********************************************************************* | |
1323 | * * | |
1324 | * control card: codewd = POPCORN * | |
1325 | * * | |
1326 | * "Popcorn-effect" in fragmentation and diquark breaking diagrams * | |
1327 | * * | |
1328 | * what (1) = (PDB) frac. of diquark fragmenting directly into * | |
1329 | * baryons (PYTHIA/JETSET fragmentation) * | |
1330 | * (JETSET: = 0. Popcorn mechanism switched off) * | |
1331 | * default: 0.5 * | |
1332 | * what (2) = probability for accepting a diquark breaking * | |
1333 | * diagram involving the generation of a u/d quark- * | |
1334 | * antiquark pair default: 0.0 * | |
1335 | * what (3) = same a what (2), here for s quark-antiquark pair * | |
1336 | * default: 0.0 * | |
1337 | * what (4..6), sdum no meaning * | |
1338 | * * | |
1339 | ********************************************************************* | |
1340 | ||
1341 | 420 CONTINUE | |
1342 | IF (WHAT(1).GE.0.0D0) PDB = WHAT(1) | |
1343 | IF (WHAT(2).GE.0.0D0) THEN | |
1344 | PDBSEA(1) = WHAT(2) | |
1345 | PDBSEA(2) = WHAT(2) | |
1346 | ENDIF | |
1347 | IF (WHAT(3).GE.0.0D0) PDBSEA(3) = WHAT(3) | |
1348 | DO 421 I=1,8 | |
1349 | DBRKA(1,I) = DBRKR(1,I)*PDBSEA(1)/(1.D0-PDBSEA(1)) | |
1350 | DBRKA(2,I) = DBRKR(2,I)*PDBSEA(2)/(1.D0-PDBSEA(2)) | |
1351 | DBRKA(3,I) = DBRKR(3,I)*PDBSEA(3)/(1.D0-PDBSEA(3)) | |
1352 | 421 CONTINUE | |
1353 | GOTO 10 | |
1354 | ||
1355 | ********************************************************************* | |
1356 | * * | |
1357 | * control card: codewd = PARDECAY * | |
1358 | * * | |
1359 | * what (1) = 1. Sigma0/Asigma0 are decaying within JETSET * | |
1360 | * = 2. pion^0 decay after intranucl. cascade * | |
1361 | * default: no decay * | |
1362 | * what (2..6), sdum no meaning * | |
1363 | * * | |
1364 | ********************************************************************* | |
1365 | ||
1366 | 430 CONTINUE | |
1367 | IF (WHAT(1).EQ.ONE) ISIG0 = 1 | |
1368 | IF (WHAT(1).EQ.2.0D0) IPI0 = 1 | |
1369 | GOTO 10 | |
1370 | ||
1371 | ********************************************************************* | |
1372 | * * | |
1373 | * control card: codewd = BEAM * | |
1374 | * * | |
1375 | * definition of beam parameters * | |
1376 | * * | |
1377 | * what (1/2) > 0 : energy of beam 1/2 (GeV) * | |
1378 | * < 0 : abs(what(1/2)) energy per charge of * | |
1379 | * beam 1/2 (GeV) * | |
1380 | * (beam 1 is directed into positive z-direction) * | |
1381 | * what (3) beam crossing angle, defined as 2x angle between * | |
1382 | * one beam and the z-axis (micro rad) * | |
1383 | * what (4) angle with x-axis defining the collision plane * | |
1384 | * what (5..6), sdum no meaning * | |
1385 | * * | |
1386 | * Note: this card requires previously defined projectile and * | |
1387 | * target identities (PROJPAR, TARPAR) * | |
1388 | * * | |
1389 | ********************************************************************* | |
1390 | ||
1391 | 440 CONTINUE | |
1392 | CALL DT_BEAMPR(WHAT,PPN,1) | |
1393 | EPN = ZERO | |
1394 | CMENER = ZERO | |
1395 | LEINP = .TRUE. | |
1396 | GOTO 10 | |
1397 | ||
1398 | ********************************************************************* | |
1399 | * * | |
1400 | * control card: codewd = LUND-MSTU * | |
1401 | * * | |
1402 | * set parameter MSTU in JETSET-common /LUDAT1/ * | |
1403 | * * | |
1404 | * what (1) = index according to LUND-common block * | |
1405 | * what (2) = new value of MSTU( int(what(1)) ) * | |
1406 | * what (3), what(4) and what (5), what(6) further * | |
1407 | * parameter in the same way as what (1) and * | |
1408 | * what (2) * | |
1409 | * default: default-Lund or corresponding to * | |
1410 | * the set given in HADRONIZE * | |
1411 | * * | |
1412 | ********************************************************************* | |
1413 | ||
1414 | 450 CONTINUE | |
1415 | IF (WHAT(1).GT.ZERO) THEN | |
1416 | NMSTU = NMSTU+1 | |
1417 | IMSTU(NMSTU) = INT(WHAT(1)) | |
1418 | MSTUX(NMSTU) = INT(WHAT(2)) | |
1419 | ENDIF | |
1420 | IF (WHAT(3).GT.ZERO) THEN | |
1421 | NMSTU = NMSTU+1 | |
1422 | IMSTU(NMSTU) = INT(WHAT(3)) | |
1423 | MSTUX(NMSTU) = INT(WHAT(4)) | |
1424 | ENDIF | |
1425 | IF (WHAT(5).GT.ZERO) THEN | |
1426 | NMSTU = NMSTU+1 | |
1427 | IMSTU(NMSTU) = INT(WHAT(5)) | |
1428 | MSTUX(NMSTU) = INT(WHAT(6)) | |
1429 | ENDIF | |
1430 | GOTO 10 | |
1431 | ||
1432 | ********************************************************************* | |
1433 | * * | |
1434 | * control card: codewd = LUND-MSTJ * | |
1435 | * * | |
1436 | * set parameter MSTJ in JETSET-common /LUDAT1/ * | |
1437 | * * | |
1438 | * what (1) = index according to LUND-common block * | |
1439 | * what (2) = new value of MSTJ( int(what(1)) ) * | |
1440 | * what (3), what(4) and what (5), what(6) further * | |
1441 | * parameter in the same way as what (1) and * | |
1442 | * what (2) * | |
1443 | * default: default-Lund or corresponding to * | |
1444 | * the set given in HADRONIZE * | |
1445 | * * | |
1446 | ********************************************************************* | |
1447 | ||
1448 | 451 CONTINUE | |
1449 | IF (WHAT(1).GT.ZERO) THEN | |
1450 | NMSTJ = NMSTJ+1 | |
1451 | IMSTJ(NMSTJ) = INT(WHAT(1)) | |
1452 | MSTJX(NMSTJ) = INT(WHAT(2)) | |
1453 | ENDIF | |
1454 | IF (WHAT(3).GT.ZERO) THEN | |
1455 | NMSTJ = NMSTJ+1 | |
1456 | IMSTJ(NMSTJ) = INT(WHAT(3)) | |
1457 | MSTJX(NMSTJ) = INT(WHAT(4)) | |
1458 | ENDIF | |
1459 | IF (WHAT(5).GT.ZERO) THEN | |
1460 | NMSTJ = NMSTJ+1 | |
1461 | IMSTJ(NMSTJ) = INT(WHAT(5)) | |
1462 | MSTJX(NMSTJ) = INT(WHAT(6)) | |
1463 | ENDIF | |
1464 | GOTO 10 | |
1465 | ||
1466 | ********************************************************************* | |
1467 | * * | |
1468 | * control card: codewd = LUND-MDCY * | |
1469 | * * | |
1470 | * set parameter MDCY(I,1) for particle decays in JETSET-common * | |
1471 | * /LUDAT3/ * | |
1472 | * * | |
1473 | * what (1-6) = PDG particle index of particle which should * | |
1474 | * not decay * | |
1475 | * default: default-Lund or forced in * | |
1476 | * DT_INITJS * | |
1477 | * * | |
1478 | ********************************************************************* | |
1479 | ||
1480 | 452 CONTINUE | |
1481 | DO 4521 I=1,6 | |
1482 | IF (WHAT(I).NE.ZERO) THEN | |
1483 | KC = PYCOMP(INT(WHAT(I))) | |
1484 | MDCY(KC,1) = 0 | |
1485 | ENDIF | |
1486 | 4521 CONTINUE | |
1487 | GOTO 10 | |
1488 | ||
1489 | ********************************************************************* | |
1490 | * * | |
1491 | * control card: codewd = LUND-PARJ * | |
1492 | * * | |
1493 | * set parameter PARJ in JETSET-common /LUDAT1/ * | |
1494 | * * | |
1495 | * what (1) = index according to LUND-common block * | |
1496 | * what (2) = new value of PARJ( int(what(1)) ) * | |
1497 | * what (3), what(4) and what (5), what(6) further * | |
1498 | * parameter in the same way as what (1) and * | |
1499 | * what (2) * | |
1500 | * default: default-Lund or corresponding to * | |
1501 | * the set given in HADRONIZE * | |
1502 | * * | |
1503 | ********************************************************************* | |
1504 | ||
1505 | 460 CONTINUE | |
1506 | IF (WHAT(1).NE.ZERO) THEN | |
1507 | NPARJ = NPARJ+1 | |
1508 | IPARJ(NPARJ) = INT(WHAT(1)) | |
1509 | PARJX(NPARJ) = WHAT(2) | |
1510 | ENDIF | |
1511 | IF (WHAT(3).NE.ZERO) THEN | |
1512 | NPARJ = NPARJ+1 | |
1513 | IPARJ(NPARJ) = INT(WHAT(3)) | |
1514 | PARJX(NPARJ) = WHAT(4) | |
1515 | ENDIF | |
1516 | IF (WHAT(5).NE.ZERO) THEN | |
1517 | NPARJ = NPARJ+1 | |
1518 | IPARJ(NPARJ) = INT(WHAT(5)) | |
1519 | PARJX(NPARJ) = WHAT(6) | |
1520 | ENDIF | |
1521 | GOTO 10 | |
1522 | ||
1523 | ********************************************************************* | |
1524 | * * | |
1525 | * control card: codewd = LUND-PARU * | |
1526 | * * | |
1527 | * set parameter PARJ in JETSET-common /LUDAT1/ * | |
1528 | * * | |
1529 | * what (1) = index according to LUND-common block * | |
1530 | * what (2) = new value of PARU( int(what(1)) ) * | |
1531 | * what (3), what(4) and what (5), what(6) further * | |
1532 | * parameter in the same way as what (1) and * | |
1533 | * what (2) * | |
1534 | * default: default-Lund or corresponding to * | |
1535 | * the set given in HADRONIZE * | |
1536 | * * | |
1537 | ********************************************************************* | |
1538 | ||
1539 | 470 CONTINUE | |
1540 | IF (WHAT(1).GT.ZERO) THEN | |
1541 | NPARU = NPARU+1 | |
1542 | IPARU(NPARU) = INT(WHAT(1)) | |
1543 | PARUX(NPARU) = WHAT(2) | |
1544 | ENDIF | |
1545 | IF (WHAT(3).GT.ZERO) THEN | |
1546 | NPARU = NPARU+1 | |
1547 | IPARU(NPARU) = INT(WHAT(3)) | |
1548 | PARUX(NPARU) = WHAT(4) | |
1549 | ENDIF | |
1550 | IF (WHAT(5).GT.ZERO) THEN | |
1551 | NPARU = NPARU+1 | |
1552 | IPARU(NPARU) = INT(WHAT(5)) | |
1553 | PARUX(NPARU) = WHAT(6) | |
1554 | ENDIF | |
1555 | GOTO 10 | |
1556 | ||
1557 | ********************************************************************* | |
1558 | * * | |
1559 | * control card: codewd = OUTLEVEL * | |
1560 | * * | |
1561 | * output control switches * | |
1562 | * * | |
1563 | * what (1) = internal rejection informations default: 0 * | |
1564 | * what (2) = energy-momentum conservation check output * | |
1565 | * default: 0 * | |
1566 | * what (3) = internal warning messages default: 0 * | |
1567 | * what (4..6), sdum not yet used * | |
1568 | * * | |
1569 | ********************************************************************* | |
1570 | ||
1571 | 480 CONTINUE | |
1572 | DO 481 K=1,6 | |
1573 | IOULEV(K) = INT(WHAT(K)) | |
1574 | 481 CONTINUE | |
1575 | GOTO 10 | |
1576 | ||
1577 | ********************************************************************* | |
1578 | * * | |
1579 | * control card: codewd = FRAME * | |
1580 | * * | |
1581 | * frame in which final state is given in DTEVT1 * | |
1582 | * * | |
1583 | * what (1) = 1 target rest frame (laboratory) * | |
1584 | * = 2 nucleon-nucleon cms * | |
1585 | * default: 1 * | |
1586 | * * | |
1587 | ********************************************************************* | |
1588 | ||
1589 | 490 CONTINUE | |
1590 | KFRAME = INT(WHAT(1)) | |
1591 | IF ((KFRAME.GE.1).AND.(KFRAME.LE.2)) IFRAME = KFRAME | |
1592 | GOTO 10 | |
1593 | ||
1594 | ********************************************************************* | |
1595 | * * | |
1596 | * control card: codewd = L-TAG * | |
1597 | * * | |
1598 | * lepton tagger: * | |
1599 | * definition of kinematical cuts for radiated photon and * | |
1600 | * outgoing lepton detection in lepton-nucleus interactions * | |
1601 | * * | |
1602 | * what (1) = y_min * | |
1603 | * what (2) = y_max * | |
1604 | * what (3) = Q^2_min * | |
1605 | * what (4) = Q^2_max * | |
1606 | * what (5) = theta_min (Lab) * | |
1607 | * what (6) = theta_max (Lab) * | |
1608 | * default: no cuts * | |
1609 | * sdum no meaning * | |
1610 | * * | |
1611 | ********************************************************************* | |
1612 | ||
1613 | 500 CONTINUE | |
1614 | YMIN = WHAT(1) | |
1615 | YMAX = WHAT(2) | |
1616 | Q2MIN = WHAT(3) | |
1617 | Q2MAX = WHAT(4) | |
1618 | THMIN = WHAT(5) | |
1619 | THMAX = WHAT(6) | |
1620 | GOTO 10 | |
1621 | ||
1622 | ********************************************************************* | |
1623 | * * | |
1624 | * control card: codewd = L-ETAG * | |
1625 | * * | |
1626 | * lepton tagger: * | |
1627 | * what (1) = min. outgoing lepton energy (in Lab) * | |
1628 | * what (2) = min. photon energy (in Lab) * | |
1629 | * what (3) = max. photon energy (in Lab) * | |
1630 | * default: no cuts * | |
1631 | * what (2..6), sdum no meaning * | |
1632 | * * | |
1633 | ********************************************************************* | |
1634 | ||
1635 | 510 CONTINUE | |
1636 | ELMIN = MAX(WHAT(1),ZERO) | |
1637 | EGMIN = MAX(WHAT(2),ZERO) | |
1638 | EGMAX = MAX(WHAT(3),ZERO) | |
1639 | GOTO 10 | |
1640 | ||
1641 | ********************************************************************* | |
1642 | * * | |
1643 | * control card: codewd = ECMS-CUT * | |
1644 | * * | |
1645 | * what (1) = min. c.m. energy to be sampled * | |
1646 | * what (2) = max. c.m. energy to be sampled * | |
1647 | * what (3) = min x_Bj to be sampled * | |
1648 | * default: no cuts * | |
1649 | * what (3..6), sdum no meaning * | |
1650 | * * | |
1651 | ********************************************************************* | |
1652 | ||
1653 | 520 CONTINUE | |
1654 | ECMIN = WHAT(1) | |
1655 | ECMAX = WHAT(2) | |
1656 | IF (ECMIN.GT.ECMAX) ECMIN = ECMAX | |
1657 | XBJMIN = MAX(WHAT(3),ZERO) | |
1658 | GOTO 10 | |
1659 | ||
1660 | ********************************************************************* | |
1661 | * * | |
1662 | * control card: codewd = VDM-PAR1 * | |
1663 | * * | |
1664 | * parameters in gamma-nucleus cross section calculation * | |
1665 | * * | |
1666 | * what (1) = Lambda^2 default: 2. * | |
1667 | * what (2) lower limit in M^2 integration * | |
1668 | * = 1 (3m_pi)^2 * | |
1669 | * = 2 (m_rho0)^2 * | |
1670 | * = 3 (m_phi)^2 default: 1 * | |
1671 | * what (3) upper limit in M^2 integration * | |
1672 | * = 1 s/2 * | |
1673 | * = 2 s/4 * | |
1674 | * = 3 s default: 3 * | |
1675 | * what (4) CKMT F_2 structure function * | |
1676 | * = 2212 proton * | |
1677 | * = 100 deuteron default: 2212 * | |
1678 | * what (5) calculation of gamma-nucleon xsections * | |
1679 | * = 1 according to CKMT-parametrization of F_2 * | |
1680 | * = 2 integrating SIGVP over M^2 * | |
1681 | * = 3 using SIGGA * | |
1682 | * = 4 PHOJET cross sections default: 4 * | |
1683 | * * | |
1684 | * what (6), sdum no meaning * | |
1685 | * * | |
1686 | ********************************************************************* | |
1687 | ||
1688 | 530 CONTINUE | |
1689 | IF (WHAT(1).GE.ZERO) RL2 = WHAT(1) | |
1690 | IF ((WHAT(2).GE.1).AND.(WHAT(2).LE.3)) INTRGE(1) = INT(WHAT(2)) | |
1691 | IF ((WHAT(3).GE.1).AND.(WHAT(3).LE.3)) INTRGE(2) = INT(WHAT(3)) | |
1692 | IF ((WHAT(4).EQ.2212).OR.(WHAT(4).EQ.100)) IDPDF = INT(WHAT(4)) | |
1693 | IF ((WHAT(5).GE.1).AND.(WHAT(5).LE.4)) MODEGA = INT(WHAT(5)) | |
1694 | GOTO 10 | |
1695 | ||
1696 | ********************************************************************* | |
1697 | * * | |
1698 | * control card: codewd = HISTOGRAM * | |
1699 | * * | |
1700 | * activate different classes of histograms * | |
1701 | * * | |
1702 | * default: no histograms * | |
1703 | * * | |
1704 | ********************************************************************* | |
1705 | ||
1706 | 540 CONTINUE | |
1707 | DO 541 J=1,6 | |
1708 | IF ((WHAT(J).GE.100).AND.(WHAT(J).LE.150)) THEN | |
1709 | IHISPP(INT(WHAT(J))-100) = 1 | |
1710 | ELSEIF ((ABS(WHAT(J)).GE.200).AND.(ABS(WHAT(J)).LE.250)) THEN | |
1711 | IHISXS(INT(ABS(WHAT(J)))-200) = 1 | |
1712 | IF (WHAT(J).LT.ZERO) IXSTBL = 1 | |
1713 | ENDIF | |
1714 | 541 CONTINUE | |
1715 | GOTO 10 | |
1716 | ||
1717 | ********************************************************************* | |
1718 | * * | |
1719 | * control card: codewd = XS-TABLE * | |
1720 | * * | |
1721 | * output of cross section table for requested interaction * | |
1722 | * - particle production deactivated ! - * | |
1723 | * * | |
1724 | * what (1) lower energy limit for tabulation * | |
1725 | * > 0 Lab. frame * | |
1726 | * < 0 nucleon-nucleon cms * | |
1727 | * what (2) upper energy limit for tabulation * | |
1728 | * > 0 Lab. frame * | |
1729 | * < 0 nucleon-nucleon cms * | |
1730 | * what (3) > 0 # of equidistant lin. bins in E * | |
1731 | * < 0 # of equidistant log. bins in E * | |
1732 | * what (4) lower limit of particle virtuality (photons) * | |
1733 | * what (5) upper limit of particle virtuality (photons) * | |
1734 | * what (6) > 0 # of equidistant lin. bins in Q^2 * | |
1735 | * < 0 # of equidistant log. bins in Q^2 * | |
1736 | * * | |
1737 | ********************************************************************* | |
1738 | ||
1739 | 550 CONTINUE | |
1740 | IF (WHAT(1).EQ.99999.0D0) THEN | |
1741 | IRATIO = INT(WHAT(2)) | |
1742 | GOTO 10 | |
1743 | ENDIF | |
1744 | CMENER = ABS(WHAT(2)) | |
1745 | IF (.NOT.LXSTAB) THEN | |
1746 | CALL DT_BERTTP | |
1747 | CALL DT_INCINI | |
1748 | ENDIF | |
1749 | IF ((.NOT.LXSTAB).OR.(CMENER.NE.CMEOLD)) THEN | |
1750 | CMEOLD = CMENER | |
1751 | IF (WHAT(2).GT.ZERO) | |
1752 | & CMENER = SQRT(2.0D0*AAM(1)**2+2.0D0*WHAT(2)*AAM(1)) | |
1753 | EPN = ZERO | |
1754 | PPN = ZERO | |
1755 | C WRITE(LOUT,*) 'CMENER = ',CMENER | |
1756 | CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,CMENER,1) | |
1757 | CALL DT_PHOINI | |
1758 | ENDIF | |
1759 | CALL DT_XSTABL(WHAT,IXSQEL,IRATIO) | |
1760 | IXSQEL = 0 | |
1761 | LXSTAB = .TRUE. | |
1762 | GOTO 10 | |
1763 | ||
1764 | ********************************************************************* | |
1765 | * * | |
1766 | * control card: codewd = GLAUB-PAR * | |
1767 | * * | |
1768 | * parameters in Glauber-formalism * | |
1769 | * * | |
1770 | * what (1) # of nucleon configurations sampled in integration * | |
1771 | * over nuclear desity default: 1000 * | |
1772 | * what (2) # of bins for integration over impact-parameter and * | |
1773 | * for profile-function calculation default: 49 * | |
1774 | * what (3) = 1 calculation of tot., el. and qel. cross sections * | |
1775 | * default: 0 * | |
1776 | * what (4) = 1 read pre-calculated impact-parameter distrib. * | |
1777 | * from "sdum".glb * | |
1778 | * =-1 dump pre-calculated impact-parameter distrib. * | |
1779 | * into "sdum".glb * | |
1780 | * = 100 read pre-calculated impact-parameter distrib. * | |
1781 | * for variable projectile/target/energy runs * | |
1782 | * from "sdum".glb * | |
1783 | * default: 0 * | |
1784 | * what (5..6) no meaning * | |
1785 | * sdum if |what (4)| = 1 name of in/output-file (sdum.glb) * | |
1786 | * * | |
1787 | ********************************************************************* | |
1788 | ||
1789 | 560 CONTINUE | |
1790 | IF (WHAT(1).GT.ZERO) JSTATB = INT(WHAT(1)) | |
1791 | IF (WHAT(2).GT.ZERO) JBINSB = INT(WHAT(2)) | |
1792 | IF (WHAT(3).EQ.ONE) LPROD = .FALSE. | |
1793 | IF ((ABS(WHAT(4)).EQ.ONE).OR.(WHAT(4).EQ.100)) THEN | |
1794 | IOGLB = INT(WHAT(4)) | |
1795 | CGLB = SDUM | |
1796 | ENDIF | |
1797 | GOTO 10 | |
1798 | ||
1799 | ********************************************************************* | |
1800 | * * | |
1801 | * control card: codewd = GLAUB-INI * | |
1802 | * * | |
1803 | * pre-initialization of profile function * | |
1804 | * * | |
1805 | * what (1) lower energy limit for initialization * | |
1806 | * > 0 Lab. frame * | |
1807 | * < 0 nucleon-nucleon cms * | |
1808 | * what (2) upper energy limit for initialization * | |
1809 | * > 0 Lab. frame * | |
1810 | * < 0 nucleon-nucleon cms * | |
1811 | * what (3) > 0 # of equidistant lin. bins in E * | |
1812 | * < 0 # of equidistant log. bins in E * | |
1813 | * what (4) maximum projectile mass number for which the * | |
1814 | * Glauber data are initialized for each * | |
1815 | * projectile mass number * | |
1816 | * (if <= mass given with the PROJPAR-card) * | |
1817 | * default: 18 * | |
1818 | * what (5) steps in mass number starting from what (4) * | |
1819 | * up to mass number defined with PROJPAR-card * | |
1820 | * for which Glauber data are initialized * | |
1821 | * default: 5 * | |
1822 | * what (6) no meaning * | |
1823 | * sdum no meaning * | |
1824 | * * | |
1825 | ********************************************************************* | |
1826 | ||
1827 | 565 CONTINUE | |
1828 | IOGLB = -100 | |
1829 | CALL DT_GLBINI(WHAT) | |
1830 | GOTO 10 | |
1831 | ||
1832 | ********************************************************************* | |
1833 | * * | |
1834 | * control card: codewd = VDM-PAR2 * | |
1835 | * * | |
1836 | * parameters in gamma-nucleus cross section calculation * | |
1837 | * * | |
1838 | * what (1) = 0 no suppression of shadowing by direct photon * | |
1839 | * processes * | |
1840 | * = 1 suppression .. default: 1 * | |
1841 | * what (2) = 0 no suppression of shadowing by anomalous * | |
1842 | * component if photon-F_2 * | |
1843 | * = 1 suppression .. default: 1 * | |
1844 | * what (3) = 0 no suppression of shadowing by coherence * | |
1845 | * length of the photon * | |
1846 | * = 1 suppression .. default: 1 * | |
1847 | * what (4) = 1 longitudinal polarized photons are taken into * | |
1848 | * account * | |
1849 | * eps*R*Q^2/M^2 = what(4)*Q^2/M^2 default: 0 * | |
1850 | * what (5..6), sdum no meaning * | |
1851 | * * | |
1852 | ********************************************************************* | |
1853 | ||
1854 | 570 CONTINUE | |
1855 | IF ((WHAT(1).EQ.ZERO).OR.(WHAT(1).EQ.ONE)) ISHAD(1) = INT(WHAT(1)) | |
1856 | IF ((WHAT(2).EQ.ZERO).OR.(WHAT(2).EQ.ONE)) ISHAD(2) = INT(WHAT(2)) | |
1857 | IF ((WHAT(3).EQ.ZERO).OR.(WHAT(3).EQ.ONE)) ISHAD(3) = INT(WHAT(3)) | |
1858 | EPSPOL = WHAT(4) | |
1859 | GOTO 10 | |
1860 | ||
1861 | ********************************************************************* | |
1862 | * * | |
1863 | * control card: XS-QELPRO * | |
1864 | * * | |
1865 | * what (1..6), sdum no meaning * | |
1866 | * * | |
1867 | ********************************************************************* | |
1868 | ||
1869 | 580 CONTINUE | |
1870 | IXSQEL = ABS(WHAT(1)) | |
1871 | GOTO 10 | |
1872 | ||
1873 | ********************************************************************* | |
1874 | * * | |
1875 | * control card: RNDMINIT * | |
1876 | * * | |
1877 | * initialization of random number generator * | |
1878 | * * | |
1879 | * what (1..4) values for initialization (= 1..168) * | |
1880 | * what (5..6), sdum no meaning * | |
1881 | * * | |
1882 | ********************************************************************* | |
1883 | ||
1884 | 590 CONTINUE | |
1885 | IF ((WHAT(1).LT.1.0D0).OR.(WHAT(1).GT.168.0D0)) THEN | |
1886 | NA1 = 22 | |
1887 | ELSE | |
1888 | NA1 = WHAT(1) | |
1889 | ENDIF | |
1890 | IF ((WHAT(2).LT.1.0D0).OR.(WHAT(2).GT.168.0D0)) THEN | |
1891 | NA2 = 54 | |
1892 | ELSE | |
1893 | NA2 = WHAT(2) | |
1894 | ENDIF | |
1895 | IF ((WHAT(3).LT.1.0D0).OR.(WHAT(3).GT.168.0D0)) THEN | |
1896 | NA3 = 76 | |
1897 | ELSE | |
1898 | NA3 = WHAT(3) | |
1899 | ENDIF | |
1900 | IF ((WHAT(4).LT.1.0D0).OR.(WHAT(4).GT.168.0D0)) THEN | |
1901 | NA4 = 92 | |
1902 | ELSE | |
1903 | NA4 = WHAT(4) | |
1904 | ENDIF | |
1905 | CALL DT_RNDMST(NA1,NA2,NA3,NA4) | |
1906 | GOTO 10 | |
1907 | ||
1908 | ********************************************************************* | |
1909 | * * | |
1910 | * control card: codewd = LEPTO-CUT * | |
1911 | * * | |
1912 | * set parameter CUT in LEPTO-common /LEPTOU/ * | |
1913 | * * | |
1914 | * what (1) = index in CUT-array * | |
1915 | * what (2) = new value of CUT( int(what(1)) ) * | |
1916 | * what (3), what(4) and what (5), what(6) further * | |
1917 | * parameter in the same way as what (1) and * | |
1918 | * what (2) * | |
1919 | * default: default-LEPTO parameters * | |
1920 | * * | |
1921 | ********************************************************************* | |
1922 | ||
1923 | 600 CONTINUE | |
1924 | IF (WHAT(1).GT.ZERO) CUT(INT(WHAT(1))) = WHAT(2) | |
1925 | IF (WHAT(3).GT.ZERO) CUT(INT(WHAT(3))) = WHAT(4) | |
1926 | IF (WHAT(5).GT.ZERO) CUT(INT(WHAT(5))) = WHAT(6) | |
1927 | GOTO 10 | |
1928 | ||
1929 | ********************************************************************* | |
1930 | * * | |
1931 | * control card: codewd = LEPTO-LST * | |
1932 | * * | |
1933 | * set parameter LST in LEPTO-common /LEPTOU/ * | |
1934 | * * | |
1935 | * what (1) = index in LST-array * | |
1936 | * what (2) = new value of LST( int(what(1)) ) * | |
1937 | * what (3), what(4) and what (5), what(6) further * | |
1938 | * parameter in the same way as what (1) and * | |
1939 | * what (2) * | |
1940 | * default: default-LEPTO parameters * | |
1941 | * * | |
1942 | ********************************************************************* | |
1943 | ||
1944 | 610 CONTINUE | |
1945 | IF (WHAT(1).GT.ZERO) LST(INT(WHAT(1))) = INT(WHAT(2)) | |
1946 | IF (WHAT(3).GT.ZERO) LST(INT(WHAT(3))) = INT(WHAT(4)) | |
1947 | IF (WHAT(5).GT.ZERO) LST(INT(WHAT(5))) = INT(WHAT(6)) | |
1948 | GOTO 10 | |
1949 | ||
1950 | ********************************************************************* | |
1951 | * * | |
1952 | * control card: codewd = LEPTO-PARL * | |
1953 | * * | |
1954 | * set parameter PARL in LEPTO-common /LEPTOU/ * | |
1955 | * * | |
1956 | * what (1) = index in PARL-array * | |
1957 | * what (2) = new value of PARL( int(what(1)) ) * | |
1958 | * what (3), what(4) and what (5), what(6) further * | |
1959 | * parameter in the same way as what (1) and * | |
1960 | * what (2) * | |
1961 | * default: default-LEPTO parameters * | |
1962 | * * | |
1963 | ********************************************************************* | |
1964 | ||
1965 | 620 CONTINUE | |
1966 | IF (WHAT(1).GT.ZERO) PARL(INT(WHAT(1))) = WHAT(2) | |
1967 | IF (WHAT(3).GT.ZERO) PARL(INT(WHAT(3))) = WHAT(4) | |
1968 | IF (WHAT(5).GT.ZERO) PARL(INT(WHAT(5))) = WHAT(6) | |
1969 | GOTO 10 | |
1970 | ||
1971 | ********************************************************************* | |
1972 | * * | |
1973 | * control card: codewd = START * | |
1974 | * * | |
1975 | * what (1) = number of events default: 100. * | |
1976 | * what (2) = 0 Glauber initialization follows * | |
1977 | * = 1 Glauber initialization supressed, fitted * | |
1978 | * results are used instead * | |
1979 | * (this does not apply if emulsion-treatment * | |
1980 | * is requested) * | |
1981 | * = 2 Glauber initialization is written to * | |
1982 | * output-file shmakov.out * | |
1983 | * = 3 Glauber initialization is read from input-file * | |
1984 | * shmakov.out default: 0 * | |
1985 | * what (3..6) no meaning * | |
1986 | * what (3..6) no meaning * | |
1987 | * * | |
1988 | ********************************************************************* | |
1989 | ||
1990 | 630 CONTINUE | |
1991 | ||
1992 | * check for cross-section table output only | |
1993 | IF (LXSTAB) STOP | |
1994 | ||
1995 | NCASES = INT(WHAT(1)) | |
1996 | IF (NCASES.LE.0) NCASES = 100 | |
1997 | IGLAU = INT(WHAT(2)) | |
1998 | IF ((IGLAU.NE.1).AND.(IGLAU.NE.2).AND.(IGLAU.NE.3)) | |
1999 | & IGLAU = 0 | |
2000 | ||
2001 | NPMASS = IP | |
2002 | NPCHAR = IPZ | |
2003 | NTMASS = IT | |
2004 | NTCHAR = ITZ | |
2005 | IDP = IJPROJ | |
2006 | IDT = IJTARG | |
2007 | IF (IDP.LE.0) IDP = 1 | |
2008 | * muon neutrinos: temporary (missing index) | |
2009 | * (new patch in projpar: therefore the following this is probably not | |
2010 | * necessary anymore..) | |
2011 | C IF (IDP.EQ.26) IDP = 5 | |
2012 | C IF (IDP.EQ.27) IDP = 6 | |
2013 | ||
2014 | * redefine collision energy | |
2015 | IF (LEINP) THEN | |
2016 | IF (ABS(VAREHI).GT.ZERO) THEN | |
2017 | PDUM = ZERO | |
2018 | IF (VARELO.LT.EHADLO) VARELO = EHADLO | |
2019 | CALL DT_LTINI(IDP,IDT,VARELO,PDUM,VARCLO,1) | |
2020 | PDUM = ZERO | |
2021 | CALL DT_LTINI(IDP,IDT,VAREHI,PDUM,VARCHI,1) | |
2022 | ENDIF | |
2023 | CALL DT_LTINI(IDP,IDT,EPN,PPN,CMENER,1) | |
2024 | ELSE | |
2025 | WRITE(LOUT,1003) | |
2026 | 1003 FORMAT(1X,'INIT: collision energy not defined!',/, | |
2027 | & 1X,' -program stopped- ') | |
2028 | STOP | |
2029 | ENDIF | |
2030 | ||
2031 | * switch off evaporation (even if requested) if central coll. requ. | |
2032 | IF ((ICENTR.EQ.-1).OR.(ICENTR.GT.0).OR.(XSFRAC.LT.0.5D0)) THEN | |
2033 | IF (LEVPRT) THEN | |
2034 | WRITE(LOUT,1004) | |
2035 | 1004 FORMAT(1X,/,'Warning! Evaporation request rejected since', | |
2036 | & ' central collisions forced.') | |
2037 | LEVPRT = .FALSE. | |
2038 | LDEEXG = .FALSE. | |
2039 | LHEAVY = .FALSE. | |
2040 | ENDIF | |
2041 | ENDIF | |
2042 | ||
2043 | * initialization of evaporation-module | |
2044 | ||
2045 | WRITE(LOUT,1010) | |
2046 | 1010 FORMAT(1X,/,'Warning! No evaporation performed since', | |
2047 | & ' evaporation modules not available with this version.') | |
2048 | LEVPRT = .FALSE. | |
2049 | LDEEXG = .FALSE. | |
2050 | LHEAVY = .FALSE. | |
2051 | LFRMBK = .FALSE. | |
2052 | IFISS = 0 | |
2053 | IEVFSS = 0 | |
2054 | CALL DT_BERTTP | |
2055 | CALL DT_INCINI | |
2056 | ||
2057 | * save the default JETSET-parameter | |
2058 | CALL DT_JSPARA(0) | |
2059 | ||
2060 | * force use of phojet for g-A | |
2061 | IF ((IDP.EQ.7).AND.(MCGENE.NE.3)) MCGENE = 2 | |
2062 | * initialization of nucleon-nucleon event generator | |
2063 | IF (MCGENE.EQ.2) CALL DT_PHOINI | |
2064 | * initialization of LEPTO event generator | |
2065 | IF (MCGENE.EQ.3) THEN | |
2066 | ||
2067 | STOP ' This version does not contain LEPTO !' | |
2068 | ||
2069 | ENDIF | |
2070 | ||
2071 | * initialization of quasi-elastic neutrino scattering | |
2072 | IF (MCGENE.EQ.4) THEN | |
2073 | IF (IJPROJ.EQ.5) THEN | |
2074 | NEUTYP = 1 | |
2075 | ELSEIF (IJPROJ.EQ.6) THEN | |
2076 | NEUTYP = 2 | |
2077 | ELSEIF (IJPROJ.EQ.135) THEN | |
2078 | NEUTYP = 3 | |
2079 | ELSEIF (IJPROJ.EQ.136) THEN | |
2080 | NEUTYP = 4 | |
2081 | ELSEIF (IJPROJ.EQ.133) THEN | |
2082 | NEUTYP = 5 | |
2083 | ELSEIF (IJPROJ.EQ.134) THEN | |
2084 | NEUTYP = 6 | |
2085 | ENDIF | |
2086 | ENDIF | |
2087 | ||
2088 | * normalize fractions of emulsion components | |
2089 | IF (NCOMPO.GT.0) THEN | |
2090 | SUMFRA = ZERO | |
2091 | DO 491 I=1,NCOMPO | |
2092 | SUMFRA = SUMFRA+EMUFRA(I) | |
2093 | 491 CONTINUE | |
2094 | IF (SUMFRA.GT.ZERO) THEN | |
2095 | DO 492 I=1,NCOMPO | |
2096 | EMUFRA(I) = EMUFRA(I)/SUMFRA | |
2097 | 492 CONTINUE | |
2098 | ENDIF | |
2099 | ENDIF | |
2100 | ||
2101 | * disallow Cronin's multiple scattering for nucleus-nucleus interactions | |
2102 | IF ((IP.GT.1).AND.(MKCRON.GT.0)) THEN | |
2103 | WRITE(LOUT,1005) | |
2104 | 1005 FORMAT(/,1X,'INIT: multiple scattering disallowed',/) | |
2105 | MKCRON = 0 | |
2106 | ENDIF | |
2107 | ||
2108 | * initialization of Glauber-formalism (moved to xAEVT, sr 26.3.96) | |
2109 | C IF (NCOMPO.LE.0) THEN | |
2110 | C CALL DT_SHMAKI(IP,IPZ,IT,ITZ,IDP,PPN,IGLAU) | |
2111 | C ELSE | |
2112 | C DO 493 I=1,NCOMPO | |
2113 | C CALL DT_SHMAKI(IP,IPZ,IEMUMA(I),IEMUCH(I),IDP,PPN,0) | |
2114 | C 493 CONTINUE | |
2115 | C ENDIF | |
2116 | ||
2117 | * pre-tabulation of elastic cross-sections | |
2118 | CALL DT_SIGTBL(JDUM,JDUM,DUM,DUM,-1) | |
2119 | ||
2120 | CALL DT_XTIME | |
2121 | ||
2122 | RETURN | |
2123 | ||
2124 | ********************************************************************* | |
2125 | * * | |
2126 | * control card: codewd = STOP * | |
2127 | * * | |
2128 | * stop of the event generation * | |
2129 | * * | |
2130 | * what (1..6) no meaning * | |
2131 | * * | |
2132 | ********************************************************************* | |
2133 | ||
2134 | 9999 CONTINUE | |
2135 | WRITE(LOUT,9000) | |
2136 | 9000 FORMAT(1X,'---> unexpected end of input !') | |
2137 | ||
2138 | 640 CONTINUE | |
2139 | STOP | |
2140 | ||
2141 | END | |
2142 | ||
2143 | *$ CREATE DT_KKINC.FOR | |
2144 | *COPY DT_KKINC | |
2145 | * | |
2146 | *===kkinc==============================================================* | |
2147 | * | |
2148 | SUBROUTINE DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT, | |
2149 | & IREJ) | |
2150 | ||
2151 | ************************************************************************ | |
2152 | * Treatment of complete nucleus-nucleus or hadron-nucleus scattering * | |
2153 | * This subroutine is an update of the previous version written * | |
2154 | * by J. Ranft/ H.-J. Moehring. * | |
2155 | * This version dated 19.11.95 is written by S. Roesler * | |
2156 | ************************************************************************ | |
2157 | ||
2158 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
2159 | SAVE | |
2160 | PARAMETER ( LINP = 10 , | |
2161 | & LOUT = 6 , | |
2162 | & LDAT = 9 ) | |
2163 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY5=1.0D-5, | |
2164 | & TINY2=1.0D-2,TINY3=1.0D-3) | |
2165 | ||
2166 | LOGICAL LFZC | |
2167 | ||
2168 | * event history | |
2169 | PARAMETER (NMXHKK=200000) | |
2170 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
2171 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
2172 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
2173 | * extended event history | |
2174 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
2175 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
2176 | & IHIST(2,NMXHKK) | |
2177 | * particle properties (BAMJET index convention) | |
2178 | CHARACTER*8 ANAME | |
2179 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
2180 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
2181 | * properties of interacting particles | |
2182 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
2183 | * Lorentz-parameters of the current interaction | |
2184 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
2185 | & UMO,PPCM,EPROJ,PPROJ | |
2186 | * flags for input different options | |
2187 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
2188 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
2189 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
2190 | * flags for particle decays | |
2191 | COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20), | |
2192 | & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20), | |
2193 | & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0 | |
2194 | * cuts for variable energy runs | |
2195 | COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI | |
2196 | * Glauber formalism: flags and parameters for statistics | |
2197 | LOGICAL LPROD | |
2198 | CHARACTER*8 CGLB | |
2199 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD | |
2200 | ||
2201 | DIMENSION WHAT(6) | |
2202 | ||
2203 | IREJ = 0 | |
2204 | ILOOP = 0 | |
2205 | 100 CONTINUE | |
2206 | IF (ILOOP.EQ.4) THEN | |
2207 | WRITE(LOUT,1000) NEVHKK | |
2208 | 1000 FORMAT(1X,'KKINC: event ',I8,' rejected!') | |
2209 | GOTO 9999 | |
2210 | ENDIF | |
2211 | ILOOP = ILOOP+1 | |
2212 | ||
2213 | * variable energy-runs, recalculate parameters for LT's | |
2214 | IF ((ABS(VAREHI).GT.ZERO).OR.(IOGLB.EQ.100)) THEN | |
2215 | PDUM = ZERO | |
2216 | CDUM = ZERO | |
2217 | CALL DT_LTINI(IDP,1,EPN,PDUM,CDUM,1) | |
2218 | ENDIF | |
2219 | IF (EPN.GT.EPROJ) THEN | |
2220 | WRITE(LOUT,'(A,E9.3,2A,E9.3,A)') | |
2221 | & ' Requested energy (',EPN,'GeV) exceeds', | |
2222 | & ' initialization energy (',EPROJ,'GeV) !' | |
2223 | STOP | |
2224 | ENDIF | |
2225 | ||
2226 | * re-initialize /DTPRTA/ | |
2227 | IP = NPMASS | |
2228 | IPZ = NPCHAR | |
2229 | IT = NTMASS | |
2230 | ITZ = NTCHAR | |
2231 | IJPROJ = IDP | |
2232 | IBPROJ = IIBAR(IJPROJ) | |
2233 | ||
2234 | * calculate nuclear potentials (common /DTNPOT/) | |
2235 | CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0) | |
2236 | ||
2237 | * initialize treatment for residual nuclei | |
2238 | CALL DT_RESNCL(EPN,NLOOP,1) | |
2239 | ||
2240 | * sample hadron/nucleus-nucleus interaction | |
2241 | CALL DT_KKEVNT(KKMAT,IREJ1) | |
2242 | IF (IREJ1.GT.0) THEN | |
2243 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKINC' | |
2244 | GOTO 9999 | |
2245 | ENDIF | |
2246 | ||
2247 | IF ((NPMASS.GT.1).OR.(NTMASS.GT.1)) THEN | |
2248 | ||
2249 | * intranuclear cascade of final state particles for KTAUGE generations | |
2250 | * of secondaries | |
2251 | CALL DT_FOZOCA(LFZC,IREJ1) | |
2252 | IF (IREJ1.GT.0) THEN | |
2253 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKINC' | |
2254 | GOTO 9999 | |
2255 | ENDIF | |
2256 | ||
2257 | * baryons unable to escape the nuclear potential are treated as | |
2258 | * excited nucleons (ISTHKK=15,16) | |
2259 | CALL DT_SCN4BA | |
2260 | ||
2261 | * decay of resonances produced in intranuclear cascade processes | |
2262 | **sr 15-11-95 should be obsolete | |
2263 | C IF (LFZC) CALL DT_DECAY1 | |
2264 | ||
2265 | 101 CONTINUE | |
2266 | * treatment of residual nuclei | |
2267 | CALL DT_RESNCL(EPN,NLOOP,2) | |
2268 | ||
2269 | * evaporation / fission / fragmentation | |
2270 | * (if intranuclear cascade was sampled only) | |
2271 | IF (LFZC) THEN | |
2272 | CALL DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ1) | |
2273 | IF (IREJ1.GT.1) GOTO 101 | |
2274 | IF (IREJ1.EQ.1) GOTO 100 | |
2275 | ENDIF | |
2276 | ||
2277 | ENDIF | |
2278 | ||
2279 | * rejection of unphysical configurations | |
2280 | CALL DT_REJUCO(1,IREJ1) | |
2281 | IF (IREJ1.GT.0) THEN | |
2282 | IF (IOULEV(1).GT.0) | |
2283 | & WRITE(LOUT,*) 'rejected 3 in KKINC: too large x' | |
2284 | GOTO 100 | |
2285 | ENDIF | |
2286 | ||
2287 | * transform finale state into Lab. | |
2288 | IFLAG = 2 | |
2289 | CALL DT_BEAMPR(WHAT,DUM,IFLAG) | |
2290 | IF ((IFRAME.EQ.1).AND.(IFLAG.EQ.-1)) CALL DT_LT2LAB | |
2291 | ||
2292 | IF (IPI0.EQ.1) CALL DT_DECPI0 | |
2293 | ||
2294 | C IF (NEVHKK.EQ.5) CALL DT_EVTOUT(4) | |
2295 | ||
2296 | RETURN | |
2297 | 9999 CONTINUE | |
2298 | IREJ = 1 | |
2299 | RETURN | |
2300 | END | |
2301 | ||
2302 | *$ CREATE DT_DEFAUL.FOR | |
2303 | *COPY DT_DEFAUL | |
2304 | * | |
2305 | *===defaul=============================================================* | |
2306 | * | |
2307 | SUBROUTINE DT_DEFAUL(EPN,PPN) | |
2308 | ||
2309 | ************************************************************************ | |
2310 | * Variables are set to default values. * | |
2311 | * This version dated 8.5.95 is written by S. Roesler. * | |
2312 | ************************************************************************ | |
2313 | ||
2314 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
2315 | SAVE | |
2316 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10) | |
2317 | PARAMETER (TWOPI = 6.283185307179586454D+00) | |
2318 | ||
2319 | * particle properties (BAMJET index convention) | |
2320 | CHARACTER*8 ANAME | |
2321 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
2322 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
2323 | * nuclear potential | |
2324 | LOGICAL LFERMI | |
2325 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, | |
2326 | & EBINDP(2),EBINDN(2),EPOT(2,210), | |
2327 | & ETACOU(2),ICOUL,LFERMI | |
2328 | * interface HADRIN-DPM | |
2329 | COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA | |
2330 | * central particle production, impact parameter biasing | |
2331 | COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR | |
2332 | * properties of interacting particles | |
2333 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
2334 | * properties of photon/lepton projectiles | |
2335 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC | |
2336 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
2337 | * emulsion treatment | |
2338 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
2339 | & NCOMPO,IEMUL | |
2340 | * parameter for intranuclear cascade | |
2341 | LOGICAL LPAULI | |
2342 | COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI | |
2343 | * various options for treatment of partons (DTUNUC 1.x) | |
2344 | * (chain recombination, Cronin,..) | |
2345 | LOGICAL LCO2CR,LINTPT | |
2346 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, | |
2347 | & LCO2CR,LINTPT | |
2348 | * threshold values for x-sampling (DTUNUC 1.x) | |
2349 | COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA, | |
2350 | & SSMIMQ,VVMTHR | |
2351 | * flags for input different options | |
2352 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
2353 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
2354 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
2355 | * n-n cross section fluctuations | |
2356 | PARAMETER (NBINS = 1000) | |
2357 | COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT | |
2358 | * flags for particle decays | |
2359 | COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20), | |
2360 | & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20), | |
2361 | & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0 | |
2362 | * diquark-breaking mechanism | |
2363 | COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3 | |
2364 | * nucleon-nucleon event-generator | |
2365 | CHARACTER*8 CMODEL | |
2366 | LOGICAL LPHOIN | |
2367 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
2368 | * flags for diffractive interactions (DTUNUC 1.x) | |
2369 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF | |
2370 | * VDM parameter for photon-nucleus interactions | |
2371 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
2372 | * Glauber formalism: flags and parameters for statistics | |
2373 | LOGICAL LPROD | |
2374 | CHARACTER*8 CGLB | |
2375 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD | |
2376 | * kinematical cuts for lepton-nucleus interactions | |
2377 | COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX, | |
2378 | & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI | |
2379 | * flags for activated histograms | |
2380 | COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL | |
2381 | * cuts for variable energy runs | |
2382 | COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI | |
2383 | * parameters for hA-diffraction | |
2384 | COMMON /DTDIHA/ DIBETA,DIALPH | |
2385 | * LEPTO | |
2386 | REAL RPPN | |
2387 | COMMON /LEPTOI/ RPPN,LEPIN,INTER | |
2388 | * steering flags for qel neutrino scattering modules | |
2389 | COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC | |
2390 | * event flag | |
2391 | COMMON /DTEVNO/ NEVENT,ICASCA | |
2392 | ||
2393 | DATA POTMES /0.002D0/ | |
2394 | ||
2395 | * common /DTNPOT/ | |
2396 | DO 10 I=1,2 | |
2397 | PFERMP(I) = ZERO | |
2398 | PFERMN(I) = ZERO | |
2399 | EBINDP(I) = ZERO | |
2400 | EBINDN(I) = ZERO | |
2401 | DO 11 J=1,210 | |
2402 | EPOT(I,J) = ZERO | |
2403 | 11 CONTINUE | |
2404 | * nucleus independent meson potential | |
2405 | EPOT(I,13) = POTMES | |
2406 | EPOT(I,14) = POTMES | |
2407 | EPOT(I,15) = POTMES | |
2408 | EPOT(I,16) = POTMES | |
2409 | EPOT(I,23) = POTMES | |
2410 | EPOT(I,24) = POTMES | |
2411 | EPOT(I,25) = POTMES | |
2412 | 10 CONTINUE | |
2413 | FERMOD = 0.55D0 | |
2414 | ETACOU(1) = ZERO | |
2415 | ETACOU(2) = ZERO | |
2416 | ICOUL = 1 | |
2417 | LFERMI = .TRUE. | |
2418 | ||
2419 | * common /HNTHRE/ | |
2420 | EHADTH = -99.0D0 | |
2421 | EHADLO = 4.06D0 | |
2422 | EHADHI = 6.0D0 | |
2423 | INTHAD = 1 | |
2424 | IDXTA = 2 | |
2425 | ||
2426 | * common /DTIMPA/ | |
2427 | ICENTR = 0 | |
2428 | BIMIN = ZERO | |
2429 | BIMAX = 1.0D10 | |
2430 | XSFRAC = 1.0D0 | |
2431 | ||
2432 | * common /DTPRTA/ | |
2433 | IP = 1 | |
2434 | IPZ = 1 | |
2435 | IT = 1 | |
2436 | ITZ = 1 | |
2437 | IJPROJ = 1 | |
2438 | IBPROJ = 1 | |
2439 | IJTARG = 1 | |
2440 | IBTARG = 1 | |
2441 | * common /DTGPRO/ | |
2442 | VIRT = ZERO | |
2443 | DO 14 I=1,4 | |
2444 | PGAMM(I) = ZERO | |
2445 | PLEPT0(I) = ZERO | |
2446 | PLEPT1(I) = ZERO | |
2447 | PNUCL(I) = ZERO | |
2448 | 14 CONTINUE | |
2449 | IDIREC = 0 | |
2450 | ||
2451 | * common /DTFOTI/ | |
2452 | **sr 7.4.98: changed after corrected B-sampling | |
2453 | C TAUFOR = 4.4D0 | |
2454 | TAUFOR = 3.5D0 | |
2455 | KTAUGE = 25 | |
2456 | ITAUVE = 1 | |
2457 | INCMOD = 1 | |
2458 | LPAULI = .TRUE. | |
2459 | ||
2460 | * common /DTCHAI/ | |
2461 | SEASQ = ONE | |
2462 | MKCRON = 1 | |
2463 | CRONCO = 0.64D0 | |
2464 | ISICHA = 0 | |
2465 | CUTOF = 100.0D0 | |
2466 | LCO2CR = .FALSE. | |
2467 | IRECOM = 1 | |
2468 | LINTPT = .TRUE. | |
2469 | ||
2470 | * common /DTXCUT/ | |
2471 | * definition of soft quark distributions | |
2472 | XSEACU = 0.05D0 | |
2473 | UNON = 2.0D0 | |
2474 | UNOM = 1.5D0 | |
2475 | UNOSEA = 5.0D0 | |
2476 | * cutoff parameters for x-sampling | |
2477 | CVQ = 1.0D0 | |
2478 | CDQ = 2.0D0 | |
2479 | C CSEA = 0.3D0 | |
2480 | CSEA = 0.1D0 | |
2481 | SSMIMA = 1.2D0 | |
2482 | SSMIMQ = SSMIMA**2 | |
2483 | VVMTHR = 2.0D0 | |
2484 | ||
2485 | * common /DTXSFL/ | |
2486 | IFLUCT = 0 | |
2487 | ||
2488 | * common /DTFRPA/ | |
2489 | PDB = 0.15D0 | |
2490 | PDBSEA(1) = 0.0D0 | |
2491 | PDBSEA(2) = 0.0D0 | |
2492 | PDBSEA(3) = 0.0D0 | |
2493 | ISIG0 = 0 | |
2494 | IPI0 = 0 | |
2495 | NMSTU = 0 | |
2496 | NPARU = 0 | |
2497 | NMSTJ = 0 | |
2498 | NPARJ = 0 | |
2499 | ||
2500 | * common /DTDIQB/ | |
2501 | DO 15 I=1,8 | |
2502 | DBRKR(1,I) = 5.0D0 | |
2503 | DBRKR(2,I) = 5.0D0 | |
2504 | DBRKR(3,I) = 10.0D0 | |
2505 | DBRKA(1,I) = ZERO | |
2506 | DBRKA(2,I) = ZERO | |
2507 | DBRKA(3,I) = ZERO | |
2508 | 15 CONTINUE | |
2509 | CHAM1 = 0.2D0 | |
2510 | CHAM3 = 0.5D0 | |
2511 | CHAB1 = 0.7D0 | |
2512 | CHAB3 = 1.0D0 | |
2513 | ||
2514 | * common /DTFLG3/ | |
2515 | ISINGD = 0 | |
2516 | IDOUBD = 0 | |
2517 | IFLAGD = 0 | |
2518 | IDIFF = 0 | |
2519 | ||
2520 | * common /DTMODL/ | |
2521 | MCGENE = 2 | |
2522 | CMODEL(1) = 'DTUNUC ' | |
2523 | CMODEL(2) = 'PHOJET ' | |
2524 | CMODEL(3) = 'LEPTO ' | |
2525 | CMODEL(4) = 'QNEUTRIN' | |
2526 | LPHOIN = .TRUE. | |
2527 | ELOJET = 5.0D0 | |
2528 | ||
2529 | * common /DTLCUT/ | |
2530 | ECMIN = 3.5D0 | |
2531 | ECMAX = 1.0D10 | |
2532 | XBJMIN = ZERO | |
2533 | ELMIN = ZERO | |
2534 | EGMIN = ZERO | |
2535 | EGMAX = 1.0D10 | |
2536 | YMIN = TINY10 | |
2537 | YMAX = 0.999D0 | |
2538 | Q2MIN = TINY10 | |
2539 | Q2MAX = 10.0D0 | |
2540 | THMIN = ZERO | |
2541 | THMAX = TWOPI | |
2542 | Q2LI = ZERO | |
2543 | Q2HI = 1.0D10 | |
2544 | ECMLI = ZERO | |
2545 | ECMHI = 1.0D10 | |
2546 | ||
2547 | * common /DTVDMP/ | |
2548 | RL2 = 2.0D0 | |
2549 | INTRGE(1) = 1 | |
2550 | INTRGE(2) = 3 | |
2551 | IDPDF = 2212 | |
2552 | MODEGA = 4 | |
2553 | ISHAD(1) = 1 | |
2554 | ISHAD(2) = 1 | |
2555 | ISHAD(3) = 1 | |
2556 | EPSPOL = ZERO | |
2557 | ||
2558 | * common /DTGLGP/ | |
2559 | JSTATB = 1000 | |
2560 | JBINSB = 49 | |
2561 | CGLB = ' ' | |
2562 | IF (ITRSPT.EQ.1) THEN | |
2563 | IOGLB = 100 | |
2564 | ELSE | |
2565 | IOGLB = 0 | |
2566 | ENDIF | |
2567 | LPROD = .TRUE. | |
2568 | ||
2569 | * common /DTHIS3/ | |
2570 | DO 16 I=1,50 | |
2571 | IHISPP(I) = 0 | |
2572 | IHISXS(I) = 0 | |
2573 | 16 CONTINUE | |
2574 | IXSTBL = 0 | |
2575 | ||
2576 | * common /DTVARE/ | |
2577 | VARELO = ZERO | |
2578 | VAREHI = ZERO | |
2579 | VARCLO = ZERO | |
2580 | VARCHI = ZERO | |
2581 | ||
2582 | * common /DTDIHA/ | |
2583 | DIBETA = -1.0D0 | |
2584 | DIALPH = ZERO | |
2585 | ||
2586 | * common /LEPTOI/ | |
2587 | RPPN = 0.0 | |
2588 | LEPIN = 0 | |
2589 | INTER = 0 | |
2590 | ||
2591 | * common /QNEUTO/ | |
2592 | NEUTYP = 1 | |
2593 | NEUDEC = 0 | |
2594 | ||
2595 | * common /DTEVNO/ | |
2596 | NEVENT = 1 | |
2597 | IF (ITRSPT.EQ.1) THEN | |
2598 | ICASCA = 1 | |
2599 | ELSE | |
2600 | ICASCA = 0 | |
2601 | ENDIF | |
2602 | ||
2603 | * default Lab.-energy | |
2604 | EPN = 200.0D0 | |
2605 | PPN = SQRT((EPN-AAM(IJPROJ))*(EPN+AAM(IJPROJ))) | |
2606 | ||
2607 | RETURN | |
2608 | END | |
2609 | ||
2610 | *$ CREATE DT_AAEVT.FOR | |
2611 | *COPY DT_AAEVT | |
2612 | * | |
2613 | *===aaevt==============================================================* | |
2614 | * | |
2615 | SUBROUTINE DT_AAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR, | |
2616 | & IDP,IGLAU) | |
2617 | ||
2618 | ************************************************************************ | |
2619 | * This version dated 22.03.96 is written by S. Roesler. * | |
2620 | ************************************************************************ | |
2621 | ||
2622 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
2623 | SAVE | |
2624 | PARAMETER ( LINP = 10 , | |
2625 | & LOUT = 6 , | |
2626 | & LDAT = 9 ) | |
2627 | ||
2628 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
2629 | * emulsion treatment | |
2630 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
2631 | & NCOMPO,IEMUL | |
2632 | * event flag | |
2633 | COMMON /DTEVNO/ NEVENT,ICASCA | |
2634 | ||
2635 | CHARACTER*8 DATE,HHMMSS | |
2636 | DIMENSION IDMNYR(3) | |
2637 | ||
2638 | KKMAT = 1 | |
2639 | NMSG = MAX(NEVTS/100,1) | |
2640 | ||
2641 | * initialization of run-statistics and histograms | |
2642 | CALL DT_STATIS(1) | |
2643 | CALL PHO_PHIST(1000,DUM) | |
2644 | ||
2645 | * initialization of Glauber-formalism | |
2646 | IF (NCOMPO.LE.0) THEN | |
2647 | CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU) | |
2648 | ELSE | |
2649 | DO 1 I=1,NCOMPO | |
2650 | CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0) | |
2651 | 1 CONTINUE | |
2652 | ENDIF | |
2653 | CALL DT_SIGEMU | |
2654 | ||
2655 | CALL IDATE(IDMNYR) | |
2656 | WRITE(DATE,'(I2,''/'',I2,''/'',I2)') | |
2657 | & IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100) | |
2658 | CALL ITIME(IDMNYR) | |
2659 | WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)') | |
2660 | & IDMNYR(1),IDMNYR(2),IDMNYR(3) | |
2661 | WRITE(LOUT,1001) DATE,HHMMSS | |
2662 | 1001 FORMAT(/,' DT_AAEVT: Initialisation finished. ( Date: ',A8, | |
2663 | & ' Time: ',A8,' )') | |
2664 | ||
2665 | * generate NEVTS events | |
2666 | DO 2 IEVT=1,NEVTS | |
2667 | ||
2668 | * print run-status message | |
2669 | IF (MOD(IEVT,NMSG).EQ.0) THEN | |
2670 | CALL IDATE(IDMNYR) | |
2671 | WRITE(DATE,'(I2,''/'',I2,''/'',I2)') | |
2672 | & IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100) | |
2673 | CALL ITIME(IDMNYR) | |
2674 | WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)') | |
2675 | & IDMNYR(1),IDMNYR(2),IDMNYR(3) | |
2676 | WRITE(LOUT,1000) IEVT-1,NEVTS,DATE,HHMMSS | |
2677 | 1000 FORMAT(/,1X,I8,' out of ',I8,' events sampled ( Date: ',A, | |
2678 | & ' Time: ',A,' )',/) | |
2679 | C WRITE(LOUT,1000) IEVT-1 | |
2680 | C1000 FORMAT(1X,I8,' events sampled') | |
2681 | ENDIF | |
2682 | NEVENT = IEVT | |
2683 | * treat nuclear emulsions | |
2684 | IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0) | |
2685 | * composite targets only | |
2686 | KKMAT = -KKMAT | |
2687 | * sample this event | |
2688 | CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,IREJ) | |
2689 | ||
2690 | CALL PHO_PHIST(2000,DUM) | |
2691 | ||
2692 | 2 CONTINUE | |
2693 | ||
2694 | * print run-statistics and histograms to output-unit 6 | |
2695 | CALL PHO_PHIST(3000,DUM) | |
2696 | CALL DT_STATIS(2) | |
2697 | ||
2698 | RETURN | |
2699 | END | |
2700 | ||
2701 | *$ CREATE DT_LAEVT.FOR | |
2702 | *COPY DT_LAEVT | |
2703 | * | |
2704 | *===laevt==============================================================* | |
2705 | * | |
2706 | SUBROUTINE DT_LAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR, | |
2707 | & IDP,IGLAU) | |
2708 | ||
2709 | ************************************************************************ | |
2710 | * Interface to run DPMJET for lepton-nucleus interactions. * | |
2711 | * Kinematics is sampled using the equivalent photon approximation * | |
2712 | * Based on GPHERA-routine by R. Engel. * | |
2713 | * This version dated 23.03.96 is written by S. Roesler. * | |
2714 | ************************************************************************ | |
2715 | ||
2716 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
2717 | SAVE | |
2718 | PARAMETER ( LINP = 10 , | |
2719 | & LOUT = 6 , | |
2720 | & LDAT = 9 ) | |
2721 | PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4, | |
2722 | & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0) | |
2723 | PARAMETER (TWOPI = 6.283185307179586454D+00, | |
2724 | & PI = TWOPI/TWO, | |
2725 | & ALPHEM = ONE/137.0D0) | |
2726 | ||
2727 | C CHARACTER*72 HEADER | |
2728 | ||
2729 | * particle properties (BAMJET index convention) | |
2730 | CHARACTER*8 ANAME | |
2731 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
2732 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
2733 | * event history | |
2734 | PARAMETER (NMXHKK=200000) | |
2735 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
2736 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
2737 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
2738 | * extended event history | |
2739 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
2740 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
2741 | & IHIST(2,NMXHKK) | |
2742 | * kinematical cuts for lepton-nucleus interactions | |
2743 | COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX, | |
2744 | & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI | |
2745 | * properties of interacting particles | |
2746 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
2747 | * properties of photon/lepton projectiles | |
2748 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC | |
2749 | * kinematics at lepton-gamma vertex | |
2750 | COMMON /DTLGVX/ PPL0(4),PPL1(4),PPG(4),PPA(4) | |
2751 | * flags for activated histograms | |
2752 | COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL | |
2753 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
2754 | * emulsion treatment | |
2755 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
2756 | & NCOMPO,IEMUL | |
2757 | * Glauber formalism: cross sections | |
2758 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
2759 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
2760 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
2761 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
2762 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
2763 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
2764 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
2765 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
2766 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
2767 | & BSLOPE,NEBINI,NQBINI | |
2768 | * nucleon-nucleon event-generator | |
2769 | CHARACTER*8 CMODEL | |
2770 | LOGICAL LPHOIN | |
2771 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
2772 | * flags for input different options | |
2773 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
2774 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
2775 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
2776 | * event flag | |
2777 | COMMON /DTEVNO/ NEVENT,ICASCA | |
2778 | ||
2779 | DIMENSION XDUMB(40),BGTA(4) | |
2780 | ||
2781 | * LEPTO | |
2782 | IF (MCGENE.EQ.3) THEN | |
2783 | STOP ' This version does not contain LEPTO !' | |
2784 | ENDIF | |
2785 | ||
2786 | KKMAT = 1 | |
2787 | NMSG = MAX(NEVTS/10,1) | |
2788 | ||
2789 | * mass of incident lepton | |
2790 | AMLPT = AAM(IDP) | |
2791 | AMLPT2 = AMLPT**2 | |
2792 | IDPPDG = IDT_IPDGHA(IDP) | |
2793 | ||
2794 | * consistency of kinematical limits | |
2795 | Q2MIN = MAX(Q2MIN,TINY10) | |
2796 | Q2MAX = MAX(Q2MAX,TINY10) | |
2797 | YMIN = MIN(MAX(YMIN,TINY10),0.999D0) | |
2798 | YMAX = MIN(MAX(YMAX,TINY10),0.999D0) | |
2799 | ||
2800 | * total energy of the lepton-nucleon system | |
2801 | PTOTLN = SQRT( (PLEPT0(1)+PNUCL(1))**2+(PLEPT0(2)+PNUCL(2))**2 | |
2802 | & +(PLEPT0(3)+PNUCL(3))**2 ) | |
2803 | ETOTLN = PLEPT0(4)+PNUCL(4) | |
2804 | ECMLN = SQRT((ETOTLN-PTOTLN)*(ETOTLN+PTOTLN)) | |
2805 | ECMAX = MIN(ECMAX,ECMLN) | |
2806 | WRITE(LOUT,1003) ECMIN,ECMAX,YMIN,YMAX,Q2MIN,Q2MAX,EGMIN, | |
2807 | & THMIN,THMAX,ELMIN | |
2808 | 1003 FORMAT(1X,'LAEVT:',16X,'kinematical cuts',/,22X, | |
2809 | & '------------------',/,9X,'W (min) =', | |
2810 | & F7.1,' GeV (max) =',F7.1,' GeV',/,9X,'y (min) =', | |
2811 | & F7.3,8X,'(max) =',F7.3,/,9X,'Q^2 (min) =',F7.1, | |
2812 | & ' GeV^2 (max) =',F7.1,' GeV^2',/,' (Lab) E_g (min) =' | |
2813 | & ,F7.1,' GeV',/,' (Lab) theta (min) =',F7.4,8X,'(max) =', | |
2814 | & F7.4,' for E_lpt >',F7.1,' GeV',/) | |
2815 | ||
2816 | * Lorentz-parameter for transf. into Lab | |
2817 | BGTA(1) = PNUCL(1)/AAM(1) | |
2818 | BGTA(2) = PNUCL(2)/AAM(1) | |
2819 | BGTA(3) = PNUCL(3)/AAM(1) | |
2820 | BGTA(4) = PNUCL(4)/AAM(1) | |
2821 | * LT of incident lepton into Lab and dump it in DTEVT1 | |
2822 | CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3), | |
2823 | & PLEPT0(1),PLEPT0(2),PLEPT0(3),PLEPT0(4), | |
2824 | & PLTOT,PPL0(1),PPL0(2),PPL0(3),PPL0(4)) | |
2825 | CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3), | |
2826 | & PNUCL(1),PNUCL(2),PNUCL(3),PNUCL(4), | |
2827 | & PLTOT,PPA(1),PPA(2),PPA(3),PPA(4)) | |
2828 | * maximum energy of photon nucleon system | |
2829 | PTOTGN = SQRT((YMAX*PPL0(1)+PPA(1))**2+(YMAX*PPL0(2)+PPA(2))**2 | |
2830 | & +(YMAX*PPL0(3)+PPA(3))**2) | |
2831 | ETOTGN = YMAX*PPL0(4)+PPA(4) | |
2832 | EGNMAX = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN)) | |
2833 | EGNMAX = MIN(EGNMAX,ECMAX) | |
2834 | * minimum energy of photon nucleon system | |
2835 | PTOTGN = SQRT((YMIN*PPL0(1)+PPA(1))**2+(YMIN*PPL0(2)+PPA(2))**2 | |
2836 | & +(YMIN*PPL0(3)+PPA(3))**2) | |
2837 | ETOTGN = YMIN*PPL0(4)+PPA(4) | |
2838 | EGNMIN = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN)) | |
2839 | EGNMIN = MAX(EGNMIN,ECMIN) | |
2840 | ||
2841 | * limits for Glauber-initialization | |
2842 | Q2LI = Q2MIN | |
2843 | Q2HI = MAX(Q2LI,MIN(Q2HI,Q2MAX)) | |
2844 | ECMLI = MAX(EGNMIN,THREE) | |
2845 | ECMHI = EGNMAX | |
2846 | WRITE(LOUT,1004) EGNMIN,EGNMAX,ECMLI,ECMHI,Q2LI,Q2HI | |
2847 | 1004 FORMAT(1X,'resulting limits:',/,9X,'W (min) =',F7.1, | |
2848 | & ' GeV (max) =',F7.1,' GeV',/,/,' limits for ', | |
2849 | & 'Glauber-initialization:',/,9X,'W (min) =',F7.1, | |
2850 | & ' GeV (max) =',F7.1,' GeV',/,9X,'Q^2 (min) =',F7.1, | |
2851 | & ' GeV^2 (max) =',F7.1,' GeV^2',/) | |
2852 | * initialization of Glauber-formalism | |
2853 | IF (NCOMPO.LE.0) THEN | |
2854 | CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU) | |
2855 | ELSE | |
2856 | DO 9 I=1,NCOMPO | |
2857 | CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0) | |
2858 | 9 CONTINUE | |
2859 | ENDIF | |
2860 | CALL DT_SIGEMU | |
2861 | ||
2862 | * initialization of run-statistics and histograms | |
2863 | CALL DT_STATIS(1) | |
2864 | CALL PHO_PHIST(1000,DUM) | |
2865 | ||
2866 | * maximum photon-nucleus cross section | |
2867 | I1 = 1 | |
2868 | I2 = 1 | |
2869 | RAT = ONE | |
2870 | IF (EGNMAX.GE.ECMNN(NEBINI)) THEN | |
2871 | I1 = NEBINI | |
2872 | I2 = NEBINI | |
2873 | RAT = ONE | |
2874 | ELSEIF (EGNMAX.GT.ECMNN(1)) THEN | |
2875 | DO 5 I=2,NEBINI | |
2876 | IF (EGNMAX.LT.ECMNN(I)) THEN | |
2877 | I1 = I-1 | |
2878 | I2 = I | |
2879 | RAT = (EGNMAX-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1)) | |
2880 | GOTO 6 | |
2881 | ENDIF | |
2882 | 5 CONTINUE | |
2883 | 6 CONTINUE | |
2884 | ENDIF | |
2885 | SIGMAX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1)) | |
2886 | EGNXX = EGNMAX | |
2887 | I1 = 1 | |
2888 | I2 = 1 | |
2889 | RAT = ONE | |
2890 | IF (EGNMIN.GE.ECMNN(NEBINI)) THEN | |
2891 | I1 = NEBINI | |
2892 | I2 = NEBINI | |
2893 | RAT = ONE | |
2894 | ELSEIF (EGNMIN.GT.ECMNN(1)) THEN | |
2895 | DO 7 I=2,NEBINI | |
2896 | IF (EGNMIN.LT.ECMNN(I)) THEN | |
2897 | I1 = I-1 | |
2898 | I2 = I | |
2899 | RAT = (EGNMIN-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1)) | |
2900 | GOTO 8 | |
2901 | ENDIF | |
2902 | 7 CONTINUE | |
2903 | 8 CONTINUE | |
2904 | ENDIF | |
2905 | SIGXX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1)) | |
2906 | IF (SIGXX.GT.SIGMAX) EGNXX = EGNMIN | |
2907 | SIGMAX = MAX(SIGMAX,SIGXX) | |
2908 | WRITE(LOUT,'(9X,A,F8.3,A)') 'Sigma_tot (max) =',SIGMAX,' mb' | |
2909 | ||
2910 | * plot photon flux table | |
2911 | AYMIN = LOG(YMIN) | |
2912 | AYMAX = LOG(YMAX) | |
2913 | AYRGE = AYMAX-AYMIN | |
2914 | MAXTAB = 50 | |
2915 | ADY = LOG(YMAX/YMIN)/DBLE(MAXTAB-1) | |
2916 | C WRITE(LOUT,'(/,1X,A)') 'LAEVT: photon flux ' | |
2917 | DO 1 I=1,MAXTAB | |
2918 | Y = EXP(AYMIN+ADY*DBLE(I-1)) | |
2919 | Q2LOW = MAX(Q2MIN,AMLPT2*Y**2/(ONE-Y)) | |
2920 | FF1 = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW) | |
2921 | & -TWO*AMLPT2*Y*(ONE/Q2LOW-ONE/Q2MAX)) | |
2922 | FF2 = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW) | |
2923 | & -TWO*(ONE-Y)/Y*(ONE-Q2LOW/Q2MAX)) | |
2924 | C WRITE(LOUT,'(5X,3E15.4)') Y,FF1,FF2 | |
2925 | 1 CONTINUE | |
2926 | ||
2927 | * maximum residual weight for flux sampling (dy/y) | |
2928 | YY = YMIN | |
2929 | Q2LOW = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY)) | |
2930 | WGHMAX = (ONE+(ONE-YY)**2)*LOG(Q2MAX/Q2LOW) | |
2931 | & -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY | |
2932 | ||
2933 | CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY0) | |
2934 | CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY1) | |
2935 | CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY2) | |
2936 | CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ0) | |
2937 | CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ1) | |
2938 | CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ2) | |
2939 | CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE0) | |
2940 | CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE1) | |
2941 | CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE2) | |
2942 | CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU0) | |
2943 | CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU1) | |
2944 | CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU2) | |
2945 | XBLOW = 0.001D0 | |
2946 | CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX0) | |
2947 | CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX1) | |
2948 | CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX2) | |
2949 | ||
2950 | ITRY = 0 | |
2951 | ITRW = 0 | |
2952 | NC0 = 0 | |
2953 | NC1 = 0 | |
2954 | ||
2955 | * generate events | |
2956 | DO 2 IEVT=1,NEVTS | |
2957 | IF (MOD(IEVT,NMSG).EQ.0) THEN | |
2958 | C OPEN(LDAT,FILE='/scrtch3/hr/sroesler/statusd5.out', | |
2959 | C & STATUS='UNKNOWN') | |
2960 | WRITE(LOUT,'(1X,I8,A)') IEVT-1,' events sampled' | |
2961 | C CLOSE(LDAT) | |
2962 | ENDIF | |
2963 | NEVENT = IEVT | |
2964 | ||
2965 | 100 CONTINUE | |
2966 | ITRY = ITRY+1 | |
2967 | ||
2968 | * sample y | |
2969 | 101 CONTINUE | |
2970 | ITRW = ITRW+1 | |
2971 | YY = EXP(AYRGE*DT_RNDM(RAT)+AYMIN) | |
2972 | Q2LOW = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY)) | |
2973 | Q2LOG = LOG(Q2MAX/Q2LOW) | |
2974 | WGH = (ONE+(ONE-YY)**2)*Q2LOG | |
2975 | & -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY | |
2976 | IF (WGHMAX.LT.WGH) WRITE(LOUT,1000) YY,WGHMAX,WGH | |
2977 | 1000 FORMAT(1X,'LAEVT: weight error!',3E12.5) | |
2978 | IF (DT_RNDM(YY)*WGHMAX.GT.WGH) GOTO 101 | |
2979 | ||
2980 | * sample Q2 | |
2981 | YEFF = ONE+(ONE-YY)**2 | |
2982 | 102 CONTINUE | |
2983 | Q2 = Q2LOW*EXP(Q2LOG*DT_RNDM(YY)) | |
2984 | WGH = (YEFF-TWO*(ONE-YY)*Q2LOW/Q2)/YEFF | |
2985 | IF (WGH.LT.DT_RNDM(Q2)) GOTO 102 | |
2986 | ||
2987 | c NC0 = NC0+1 | |
2988 | c CALL DT_FILHGR(YY,ONE,IHFLY0,NC0) | |
2989 | c CALL DT_FILHGR(Q2,ONE,IHFLQ0,NC0) | |
2990 | ||
2991 | * kinematics at lepton-photon vertex | |
2992 | * scattered electron | |
2993 | YQ2 = SQRT((ONE-YY)*Q2) | |
2994 | Q2E = Q2/(4.0D0*PLEPT0(4)) | |
2995 | E1Y = (ONE-YY)*PLEPT0(4) | |
2996 | CALL DT_DSFECF(SIF,COF) | |
2997 | PLEPT1(1) = YQ2*COF | |
2998 | PLEPT1(2) = YQ2*SIF | |
2999 | PLEPT1(3) = E1Y-Q2E | |
3000 | PLEPT1(4) = E1Y+Q2E | |
3001 | C THETA = ACOS( (E1Y-Q2E)/(E1Y+Q2E) ) | |
3002 | * radiated photon | |
3003 | PGAMM(1) = -PLEPT1(1) | |
3004 | PGAMM(2) = -PLEPT1(2) | |
3005 | PGAMM(3) = PLEPT0(3)-PLEPT1(3) | |
3006 | PGAMM(4) = PLEPT0(4)-PLEPT1(4) | |
3007 | * E_cm cut | |
3008 | PTOTGN = SQRT( (PGAMM(1)+PNUCL(1))**2+(PGAMM(2)+PNUCL(2))**2 | |
3009 | & +(PGAMM(3)+PNUCL(3))**2 ) | |
3010 | ETOTGN = PGAMM(4)+PNUCL(4) | |
3011 | ECMGN = (ETOTGN-PTOTGN)*(ETOTGN+PTOTGN) | |
3012 | IF (ECMGN.LT.0.1D0) GOTO 101 | |
3013 | ECMGN = SQRT(ECMGN) | |
3014 | IF ((ECMGN.LT.ECMIN).OR.(ECMGN.GT.ECMAX)) GOTO 101 | |
3015 | ||
3016 | * Lorentz-transformation into nucleon-rest system | |
3017 | CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3), | |
3018 | & PGAMM(1),PGAMM(2),PGAMM(3),PGAMM(4), | |
3019 | & PGTOT,PPG(1),PPG(2),PPG(3),PPG(4)) | |
3020 | CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3), | |
3021 | & PLEPT1(1),PLEPT1(2),PLEPT1(3),PLEPT1(4), | |
3022 | & PLTOT,PPL1(1),PPL1(2),PPL1(3),PPL1(4)) | |
3023 | * temporary checks.. | |
3024 | Q2TMP = ABS(PPG(4)**2-PGTOT**2) | |
3025 | IF (ABS(Q2-Q2TMP).GT.0.01D0) WRITE(LOUT,1001) Q2,Q2TMP | |
3026 | 1001 FORMAT(1X,'LAEVT: inconsistent kinematics (Q2,Q2TMP) ', | |
3027 | & 2F10.4) | |
3028 | ECMTMP = SQRT((PPG(4)+AAM(1)-PGTOT)*(PPG(4)+AAM(1)+PGTOT)) | |
3029 | IF (ABS(ECMGN-ECMTMP).GT.TINY10) WRITE(LOUT,1002) ECMGN,ECMTMP | |
3030 | 1002 FORMAT(1X,'LAEVT: inconsistent kinematics (ECMGN,ECMTMP) ', | |
3031 | & 2F10.2) | |
3032 | YYTMP = PPG(4)/PPL0(4) | |
3033 | IF (ABS(YY-YYTMP).GT.0.01D0) WRITE(LOUT,1005) YY,YYTMP | |
3034 | 1005 FORMAT(1X,'LAEVT: inconsistent kinematics (YY,YYTMP) ', | |
3035 | & 2F10.4) | |
3036 | ||
3037 | * lepton tagger (Lab) | |
3038 | THETA = ACOS( PPL1(3)/PLTOT ) | |
3039 | IF (PPL1(4).GT.ELMIN) THEN | |
3040 | IF ((THETA.LT.THMIN).OR.(THETA.GT.THMAX)) GOTO 101 | |
3041 | ENDIF | |
3042 | * photon energy-cut (Lab) | |
3043 | IF (PPG(4).LT.EGMIN) GOTO 101 | |
3044 | IF (PPG(4).GT.EGMAX) GOTO 101 | |
3045 | * x_Bj cut | |
3046 | XBJ = ABS(Q2/(1.876D0*PPG(4))) | |
3047 | IF (XBJ.LT.XBJMIN) GOTO 101 | |
3048 | ||
3049 | NC0 = NC0+1 | |
3050 | CALL DT_FILHGR( Q2,ONE,IHFLQ0,NC0) | |
3051 | CALL DT_FILHGR( YY,ONE,IHFLY0,NC0) | |
3052 | CALL DT_FILHGR( XBJ,ONE,IHFLX0,NC0) | |
3053 | CALL DT_FILHGR(PPG(4),ONE,IHFLU0,NC0) | |
3054 | CALL DT_FILHGR( ECMGN,ONE,IHFLE0,NC0) | |
3055 | ||
3056 | * rotation angles against z-axis | |
3057 | COD = PPG(3)/PGTOT | |
3058 | C SID = SQRT((ONE-COD)*(ONE+COD)) | |
3059 | PPT = SQRT(PPG(1)**2+PPG(2)**2) | |
3060 | SID = PPT/PGTOT | |
3061 | COF = ONE | |
3062 | SIF = ZERO | |
3063 | IF (PGTOT*SID.GT.TINY10) THEN | |
3064 | COF = PPG(1)/(SID*PGTOT) | |
3065 | SIF = PPG(2)/(SID*PGTOT) | |
3066 | ANORF = SQRT(COF*COF+SIF*SIF) | |
3067 | COF = COF/ANORF | |
3068 | SIF = SIF/ANORF | |
3069 | ENDIF | |
3070 | ||
3071 | IF (IXSTBL.EQ.0) THEN | |
3072 | * change to photon projectile | |
3073 | IJPROJ = 7 | |
3074 | * set virtuality | |
3075 | VIRT = Q2 | |
3076 | * re-initialize LTs with new kinematics | |
3077 | * !!PGAMM ist set in cms (ECMGN) along z | |
3078 | EPN = ZERO | |
3079 | PPN = ZERO | |
3080 | CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,ECMGN,0) | |
3081 | * force Lab-system | |
3082 | IFRAME = 1 | |
3083 | * get emulsion component if requested | |
3084 | IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0) | |
3085 | * convolute with cross section | |
3086 | CALL DT_SIGGAT(Q2LOW,EGNXX,STOTX,KKMAT) | |
3087 | CALL DT_SIGGAT(Q2,ECMGN,STOT,KKMAT) | |
3088 | IF (STOTX.LT.STOT) WRITE(LOUT,'(1X,A,/,6E12.3)') | |
3089 | & 'LAEVT: warning STOTX<STOT ! ',Q2LOW,EGNMAX,STOTX, | |
3090 | & Q2,ECMGN,STOT | |
3091 | IF (DT_RNDM(Q2)*STOTX.GT.STOT) GOTO 100 | |
3092 | NC1 = NC1+1 | |
3093 | CALL DT_FILHGR( Q2,ONE,IHFLQ1,NC1) | |
3094 | CALL DT_FILHGR( YY,ONE,IHFLY1,NC1) | |
3095 | CALL DT_FILHGR( XBJ,ONE,IHFLX1,NC1) | |
3096 | CALL DT_FILHGR(PPG(4),ONE,IHFLU1,NC1) | |
3097 | CALL DT_FILHGR( ECMGN,ONE,IHFLE1,NC1) | |
3098 | * composite targets only | |
3099 | KKMAT = -KKMAT | |
3100 | * sample this event | |
3101 | CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IJPROJ,EPN,KKMAT, | |
3102 | & IREJ) | |
3103 | * rotate momenta of final state particles back in photon-nucleon syst. | |
3104 | DO 4 I=NPOINT(4),NHKK | |
3105 | IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR. | |
3106 | & (ISTHKK(I).EQ.1001)) THEN | |
3107 | PX = PHKK(1,I) | |
3108 | PY = PHKK(2,I) | |
3109 | PZ = PHKK(3,I) | |
3110 | CALL DT_MYTRAN(1,PX,PY,PZ,COD,SID,COF,SIF, | |
3111 | & PHKK(1,I),PHKK(2,I),PHKK(3,I)) | |
3112 | ENDIF | |
3113 | 4 CONTINUE | |
3114 | ENDIF | |
3115 | ||
3116 | CALL DT_FILHGR( Q2,ONE,IHFLQ2,NC1) | |
3117 | CALL DT_FILHGR( YY,ONE,IHFLY2,NC1) | |
3118 | CALL DT_FILHGR( XBJ,ONE,IHFLX2,NC1) | |
3119 | CALL DT_FILHGR(PPG(4),ONE,IHFLU2,NC1) | |
3120 | CALL DT_FILHGR( ECMGN,ONE,IHFLE2,NC1) | |
3121 | ||
3122 | * dump this event to histograms | |
3123 | CALL PHO_PHIST(2000,DUM) | |
3124 | ||
3125 | 2 CONTINUE | |
3126 | ||
3127 | WGY = ALPHEM/TWOPI*WGHMAX*DBLE(ITRY)/DBLE(ITRW) | |
3128 | WGY = WGY*LOG(YMAX/YMIN) | |
3129 | WEIGHT = WGY*SIGMAX*DBLE(NEVTS)/DBLE(ITRY) | |
3130 | ||
3131 | C HEADER = ' LAEVT: Q^2 distribution 0' | |
3132 | C CALL DT_OUTHGR(IHFLQ0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3133 | C HEADER = ' LAEVT: Q^2 distribution 1' | |
3134 | C CALL DT_OUTHGR(IHFLQ1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3135 | C HEADER = ' LAEVT: Q^2 distribution 2' | |
3136 | C CALL DT_OUTHGR(IHFLQ2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3137 | C HEADER = ' LAEVT: y distribution 0' | |
3138 | C CALL DT_OUTHGR(IHFLY0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3139 | C HEADER = ' LAEVT: y distribution 1' | |
3140 | C CALL DT_OUTHGR(IHFLY1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3141 | C HEADER = ' LAEVT: y distribution 2' | |
3142 | C CALL DT_OUTHGR(IHFLY2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3143 | C HEADER = ' LAEVT: x distribution 0' | |
3144 | C CALL DT_OUTHGR(IHFLX0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3145 | C HEADER = ' LAEVT: x distribution 1' | |
3146 | C CALL DT_OUTHGR(IHFLX1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3147 | C HEADER = ' LAEVT: x distribution 2' | |
3148 | C CALL DT_OUTHGR(IHFLX2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3149 | C HEADER = ' LAEVT: E_g distribution 0' | |
3150 | C CALL DT_OUTHGR(IHFLU0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3151 | C HEADER = ' LAEVT: E_g distribution 1' | |
3152 | C CALL DT_OUTHGR(IHFLU1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3153 | C HEADER = ' LAEVT: E_g distribution 2' | |
3154 | C CALL DT_OUTHGR(IHFLU2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3155 | C HEADER = ' LAEVT: E_c distribution 0' | |
3156 | C CALL DT_OUTHGR(IHFLE0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3157 | C HEADER = ' LAEVT: E_c distribution 1' | |
3158 | C CALL DT_OUTHGR(IHFLE1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3159 | C HEADER = ' LAEVT: E_c distribution 2' | |
3160 | C CALL DT_OUTHGR(IHFLE2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1) | |
3161 | ||
3162 | * print run-statistics and histograms to output-unit 6 | |
3163 | CALL PHO_PHIST(3000,DUM) | |
3164 | IF (IXSTBL.EQ.0) CALL DT_STATIS(2) | |
3165 | ||
3166 | RETURN | |
3167 | END | |
3168 | ||
3169 | *$ CREATE DT_DTUINI.FOR | |
3170 | *COPY DT_DTUINI | |
3171 | * | |
3172 | *===dtuini=============================================================* | |
3173 | * | |
3174 | SUBROUTINE DT_DTUINI(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR, | |
3175 | & IDP,IEMU) | |
3176 | ||
3177 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
3178 | SAVE | |
3179 | ||
3180 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
3181 | * emulsion treatment | |
3182 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
3183 | & NCOMPO,IEMUL | |
3184 | * Glauber formalism: flags and parameters for statistics | |
3185 | LOGICAL LPROD | |
3186 | CHARACTER*8 CGLB | |
3187 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD | |
3188 | ||
3189 | CALL DT_INIT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,IGLAU) | |
3190 | CALL DT_STATIS(1) | |
3191 | CALL PHO_PHIST(1000,DUM) | |
3192 | IF (NCOMPO.LE.0) THEN | |
3193 | CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU) | |
3194 | ELSE | |
3195 | DO 1 I=1,NCOMPO | |
3196 | CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0) | |
3197 | 1 CONTINUE | |
3198 | ENDIF | |
3199 | IF (IOGLB.NE.100) CALL DT_SIGEMU | |
3200 | IEMU = IEMUL | |
3201 | ||
3202 | RETURN | |
3203 | END | |
3204 | ||
3205 | *$ CREATE DT_DTUOUT.FOR | |
3206 | *COPY DT_DTUOUT | |
3207 | * | |
3208 | *===dtuout=============================================================* | |
3209 | * | |
3210 | SUBROUTINE DT_DTUOUT | |
3211 | ||
3212 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
3213 | SAVE | |
3214 | ||
3215 | CALL PHO_PHIST(3000,DUM) | |
3216 | CALL DT_STATIS(2) | |
3217 | ||
3218 | RETURN | |
3219 | END | |
3220 | ||
3221 | *$ CREATE DT_BEAMPR.FOR | |
3222 | *COPY DT_BEAMPR | |
3223 | * | |
3224 | *===beampr=============================================================* | |
3225 | * | |
3226 | SUBROUTINE DT_BEAMPR(WHAT,PLAB,MODE) | |
3227 | ||
3228 | ************************************************************************ | |
3229 | * Initialization of event generation * | |
3230 | * This version dated 7.4.98 is written by S. Roesler. * | |
3231 | ************************************************************************ | |
3232 | ||
3233 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
3234 | SAVE | |
3235 | ||
3236 | PARAMETER ( LINP = 10 , | |
3237 | & LOUT = 6 , | |
3238 | & LDAT = 9 ) | |
3239 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10) | |
3240 | PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0) | |
3241 | ||
3242 | LOGICAL LBEAM | |
3243 | ||
3244 | * event history | |
3245 | PARAMETER (NMXHKK=200000) | |
3246 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
3247 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
3248 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
3249 | * extended event history | |
3250 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
3251 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
3252 | & IHIST(2,NMXHKK) | |
3253 | * properties of interacting particles | |
3254 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
3255 | * particle properties (BAMJET index convention) | |
3256 | CHARACTER*8 ANAME | |
3257 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
3258 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
3259 | * beam momenta | |
3260 | COMMON /DTBEAM/ P1(4),P2(4) | |
3261 | ||
3262 | C DIMENSION WHAT(6),P1(4),P2(4),P1CMS(4),P2CMS(4) | |
3263 | DIMENSION WHAT(6),P1CMS(4),P2CMS(4) | |
3264 | ||
3265 | DATA LBEAM /.FALSE./ | |
3266 | ||
3267 | GOTO (1,2) MODE | |
3268 | ||
3269 | 1 CONTINUE | |
3270 | ||
3271 | E1 = WHAT(1) | |
3272 | IF (E1.LT.ZERO) E1 = DBLE(IPZ)/DBLE(IP)*ABS(WHAT(1)) | |
3273 | E2 = WHAT(2) | |
3274 | IF (E2.LT.ZERO) E2 = DBLE(ITZ)/DBLE(IT)*ABS(WHAT(2)) | |
3275 | PP1 = SQRT( (E1+AAM(IJPROJ))*(E1-AAM(IJPROJ)) ) | |
3276 | PP2 = SQRT( (E2+AAM(IJTARG))*(E2-AAM(IJTARG)) ) | |
3277 | TH = 1.D-6*WHAT(3)/2.D0 | |
3278 | PH = WHAT(4)*BOG | |
3279 | P1(1) = PP1*SIN(TH)*COS(PH) | |
3280 | P1(2) = PP1*SIN(TH)*SIN(PH) | |
3281 | P1(3) = PP1*COS(TH) | |
3282 | P1(4) = E1 | |
3283 | P2(1) = PP2*SIN(TH)*COS(PH) | |
3284 | P2(2) = PP2*SIN(TH)*SIN(PH) | |
3285 | P2(3) = -PP2*COS(TH) | |
3286 | P2(4) = E2 | |
3287 | ECM = SQRT( (P1(4)+P2(4))**2-(P1(1)+P2(1))**2-(P1(2)+P2(2))**2 | |
3288 | & -(P1(3)+P2(3))**2 ) | |
3289 | ELAB = (ECM**2-AAM(IJPROJ)**2-AAM(IJTARG)**2)/(2.0D0*AAM(IJTARG)) | |
3290 | PLAB = SQRT( (ELAB+AAM(IJPROJ))*(ELAB-AAM(IJPROJ)) ) | |
3291 | BGX = (P1(1)+P2(1))/ECM | |
3292 | BGY = (P1(2)+P2(2))/ECM | |
3293 | BGZ = (P1(3)+P2(3))/ECM | |
3294 | BGE = (P1(4)+P2(4))/ECM | |
3295 | CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P1(1),P1(2),P1(3),P1(4), | |
3296 | & P1TOT,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4)) | |
3297 | CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P2(1),P2(2),P2(3),P2(4), | |
3298 | & P2TOT,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4)) | |
3299 | COD = P1CMS(3)/P1TOT | |
3300 | C SID = SQRT((ONE-COD)*(ONE+COD)) | |
3301 | PPT = SQRT(P1CMS(1)**2+P1CMS(2)**2) | |
3302 | SID = PPT/P1TOT | |
3303 | COF = ONE | |
3304 | SIF = ZERO | |
3305 | IF (P1TOT*SID.GT.TINY10) THEN | |
3306 | COF = P1CMS(1)/(SID*P1TOT) | |
3307 | SIF = P1CMS(2)/(SID*P1TOT) | |
3308 | ANORF = SQRT(COF*COF+SIF*SIF) | |
3309 | COF = COF/ANORF | |
3310 | SIF = SIF/ANORF | |
3311 | ENDIF | |
3312 | **check | |
3313 | C WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4) | |
3314 | C WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4) | |
3315 | C WRITE(LOUT,'(5E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),P1TOT | |
3316 | C WRITE(LOUT,'(5E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),P2TOT | |
3317 | C PAX = ZERO | |
3318 | C PAY = ZERO | |
3319 | C PAZ = P1TOT | |
3320 | C PAE = SQRT(AAM(IJPROJ)**2+PAZ**2) | |
3321 | C PBX = ZERO | |
3322 | C PBY = ZERO | |
3323 | C PBZ = -P2TOT | |
3324 | C PBE = SQRT(AAM(IJTARG)**2+PBZ**2) | |
3325 | C WRITE(LOUT,'(4E15.4)') PAX,PAY,PAZ,PAE | |
3326 | C WRITE(LOUT,'(4E15.4)') PBX,PBY,PBZ,PBE | |
3327 | C CALL DT_MYTRAN(1,PAX,PAY,PAZ,COD,SID,COF,SIF, | |
3328 | C & P1CMS(1),P1CMS(2),P1CMS(3)) | |
3329 | C CALL DT_MYTRAN(1,PBX,PBY,PBZ,COD,SID,COF,SIF, | |
3330 | C & P2CMS(1),P2CMS(2),P2CMS(3)) | |
3331 | C WRITE(LOUT,'(4E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4) | |
3332 | C WRITE(LOUT,'(4E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4) | |
3333 | C CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4), | |
3334 | C & P1TOT,P1(1),P1(2),P1(3),P1(4)) | |
3335 | C CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4), | |
3336 | C & P2TOT,P2(1),P2(2),P2(3),P2(4)) | |
3337 | C WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4) | |
3338 | C WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4) | |
3339 | C STOP | |
3340 | ** | |
3341 | ||
3342 | LBEAM = .TRUE. | |
3343 | ||
3344 | RETURN | |
3345 | ||
3346 | 2 CONTINUE | |
3347 | ||
3348 | IF (LBEAM) THEN | |
3349 | IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN | |
3350 | DO 20 I=NPOINT(4),NHKK | |
3351 | IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR. | |
3352 | & (ISTHKK(I).EQ.1001)) THEN | |
3353 | CALL DT_MYTRAN(1,PHKK(1,I),PHKK(2,I),PHKK(3,I), | |
3354 | & COD,SID,COF,SIF,PXCMS,PYCMS,PZCMS) | |
3355 | PECMS = PHKK(4,I) | |
3356 | CALL DT_DALTRA(BGE,BGX,BGY,BGZ,PXCMS,PYCMS,PZCMS,PECMS, | |
3357 | & PTOT,PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I)) | |
3358 | ENDIF | |
3359 | 20 CONTINUE | |
3360 | ELSE | |
3361 | MODE = -1 | |
3362 | ENDIF | |
3363 | ||
3364 | RETURN | |
3365 | END | |
3366 | ||
3367 | *$ CREATE DT_REJUCO.FOR | |
3368 | *COPY DT_REJUCO | |
3369 | * | |
3370 | *===rejuco=============================================================* | |
3371 | * | |
3372 | SUBROUTINE DT_REJUCO(MODE,IREJ) | |
3373 | ||
3374 | ************************************************************************ | |
3375 | * REJection of Unphysical COnfigurations * | |
3376 | * MODE = 1 rejection of particles with unphysically large energy * | |
3377 | * * | |
3378 | * This version dated 27.12.2006 is written by S. Roesler. * | |
3379 | ************************************************************************ | |
3380 | ||
3381 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
3382 | SAVE | |
3383 | ||
3384 | PARAMETER ( LINP = 10 , | |
3385 | & LOUT = 6 , | |
3386 | & LDAT = 9 ) | |
3387 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10) | |
3388 | PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0) | |
3389 | ||
3390 | * maximum x_cms of final state particle | |
3391 | PARAMETER (XCMSMX = 1.4D0) | |
3392 | ||
3393 | * event history | |
3394 | PARAMETER (NMXHKK=200000) | |
3395 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
3396 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
3397 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
3398 | * extended event history | |
3399 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
3400 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
3401 | & IHIST(2,NMXHKK) | |
3402 | * Lorentz-parameters of the current interaction | |
3403 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
3404 | & UMO,PPCM,EPROJ,PPROJ | |
3405 | ||
3406 | IREJ = 0 | |
3407 | ||
3408 | IF (MODE.EQ.1) THEN | |
3409 | IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN | |
3410 | ECMHLF = UMO/2.0D0 | |
3411 | DO 10 I=NPOINT(4),NHKK | |
3412 | IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDHKK(I).NE.80000)) THEN | |
3413 | XCMS = ABS(PHKK(4,I))/ECMHLF | |
3414 | IF (XCMS.GT.XCMSMX) GOTO 9999 | |
3415 | ENDIF | |
3416 | 10 CONTINUE | |
3417 | ENDIF | |
3418 | ||
3419 | RETURN | |
3420 | 9999 CONTINUE | |
3421 | IREJ = 1 | |
3422 | RETURN | |
3423 | END | |
3424 | ||
3425 | *$ CREATE DT_EVENTB.FOR | |
3426 | *COPY DT_EVENTB | |
3427 | * | |
3428 | *===eventb=============================================================* | |
3429 | * | |
3430 | SUBROUTINE DT_EVENTB(NCSY,IREJ) | |
3431 | ||
3432 | ************************************************************************ | |
3433 | * Treatment of nucleon-nucleon interactions with full two-component * | |
3434 | * Dual Parton Model. * | |
3435 | * NCSY number of nucleon-nucleon interactions * | |
3436 | * IREJ rejection flag * | |
3437 | * This version dated 14.01.2000 is written by S. Roesler * | |
3438 | ************************************************************************ | |
3439 | ||
3440 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
3441 | SAVE | |
3442 | PARAMETER ( LINP = 10 , | |
3443 | & LOUT = 6 , | |
3444 | & LDAT = 9 ) | |
3445 | PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0) | |
3446 | ||
3447 | * event history | |
3448 | PARAMETER (NMXHKK=200000) | |
3449 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
3450 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
3451 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
3452 | * extended event history | |
3453 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
3454 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
3455 | & IHIST(2,NMXHKK) | |
3456 | *! uncomment this line for internal phojet-fragmentation | |
3457 | C #include "dtu_dtevtp.inc" | |
3458 | * particle properties (BAMJET index convention) | |
3459 | CHARACTER*8 ANAME | |
3460 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
3461 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
3462 | * flags for input different options | |
3463 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
3464 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
3465 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
3466 | * rejection counter | |
3467 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
3468 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
3469 | & IREXCI(3),IRDIFF(2),IRINC | |
3470 | * properties of interacting particles | |
3471 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
3472 | * properties of photon/lepton projectiles | |
3473 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC | |
3474 | * various options for treatment of partons (DTUNUC 1.x) | |
3475 | * (chain recombination, Cronin,..) | |
3476 | LOGICAL LCO2CR,LINTPT | |
3477 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, | |
3478 | & LCO2CR,LINTPT | |
3479 | * statistics | |
3480 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
3481 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
3482 | & ICEVTG(8,0:30) | |
3483 | * DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem | |
3484 | COMMON /DTLTSU/ BGX,BGY,BGZ,GAM | |
3485 | * Glauber formalism: collision properties | |
3486 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, | |
3487 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC | |
3488 | * flags for diffractive interactions (DTUNUC 1.x) | |
3489 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF | |
3490 | * statistics: double-Pomeron exchange | |
3491 | COMMON /DTFLG2/ INTFLG,IPOPO | |
3492 | * flags for particle decays | |
3493 | COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20), | |
3494 | & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20), | |
3495 | & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0 | |
3496 | * nucleon-nucleon event-generator | |
3497 | CHARACTER*8 CMODEL | |
3498 | LOGICAL LPHOIN | |
3499 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
3500 | C nucleon-nucleus / nucleus-nucleus interface to DPMJET | |
3501 | INTEGER IDEQP,IDEQB,IHFLD,IHFLS | |
3502 | DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB | |
3503 | COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB, | |
3504 | & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2) | |
3505 | C model switches and parameters | |
3506 | CHARACTER*8 MDLNA | |
3507 | INTEGER ISWMDL,IPAMDL | |
3508 | DOUBLE PRECISION PARMDL | |
3509 | COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400) | |
3510 | C initial state parton radiation (internal part) | |
3511 | INTEGER MXISR3,MXISR4 | |
3512 | PARAMETER ( MXISR3 = 50, MXISR4 = 100 ) | |
3513 | INTEGER IFL1,IFL2,IBRA,IFANO,ISH,NACC | |
3514 | DOUBLE PRECISION Q2SH,PT2SH,XPSH,ZPSH,THSH,SHAT | |
3515 | COMMON /POINT6/ Q2SH(2,MXISR3),PT2SH(2,MXISR3),XPSH(2,MXISR3), | |
3516 | & ZPSH(2,MXISR3),THSH(2,MXISR3),SHAT(MXISR3), | |
3517 | & IFL1(2,MXISR3),IFL2(2,MXISR3), | |
3518 | & IBRA(2,MXISR4),IFANO(2),ISH(2),NACC | |
3519 | C event debugging information | |
3520 | INTEGER NMAXD | |
3521 | PARAMETER (NMAXD=100) | |
3522 | INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO, | |
3523 | & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD | |
3524 | COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG, | |
3525 | & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD | |
3526 | C general process information | |
3527 | INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON | |
3528 | COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4) | |
3529 | ||
3530 | DIMENSION PP(4),PT(4),PTOT(4),PP1(4),PP2(4),PT1(4),PT2(4), | |
3531 | & PPNN(4),PTNN(4),PTOTNN(4),PPSUB(4),PTSUB(4), | |
3532 | & PPTCMS(4),PTTCMS(4),PPTMP(4),PTTMP(4), | |
3533 | & KPRON(15),ISINGL(2000) | |
3534 | ||
3535 | * initial values for max. number of phojet scatterings and dtunuc chains | |
3536 | * to be fragmented with one pyexec call | |
3537 | DATA MXPHFR,MXDTFR /10,100/ | |
3538 | ||
3539 | IREJ = 0 | |
3540 | * pointer to first parton of the first chain in dtevt common | |
3541 | NPOINT(3) = NHKK+1 | |
3542 | * special flag for double-Pomeron statistics | |
3543 | IPOPO = 1 | |
3544 | * counter for low-mass (DTUNUC) interactions | |
3545 | NDTUSC = 0 | |
3546 | * counter for interactions treated by PHOJET | |
3547 | NPHOSC = 0 | |
3548 | ||
3549 | * scan interactions for single nucleon-nucleon interactions | |
3550 | * (this has to be checked here because Cronin modifies parton momenta) | |
3551 | NC = NPOINT(2) | |
3552 | IF (NCSY.GT.2000) STOP ' DT_EVENTB: NCSY > 2000 ! ' | |
3553 | DO 8 I=1,NCSY | |
3554 | ISINGL(I) = 0 | |
3555 | MOP = JMOHKK(1,NC) | |
3556 | MOT = JMOHKK(1,NC+1) | |
3557 | DIFF1 = ABS(PHKK(4,MOP)-PHKK(4, NC)-PHKK(4,NC+2)) | |
3558 | DIFF2 = ABS(PHKK(4,MOT)-PHKK(4,NC+1)-PHKK(4,NC+3)) | |
3559 | IF ((DIFF1.LT.TINY10).AND.(DIFF2.LT.TINY10)) ISINGL(I) = 1 | |
3560 | NC = NC+4 | |
3561 | 8 CONTINUE | |
3562 | ||
3563 | * multiple scattering of chain ends | |
3564 | IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1) | |
3565 | IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2) | |
3566 | ||
3567 | * switch to PHOJET-settings for JETSET parameter | |
3568 | CALL DT_INITJS(1) | |
3569 | ||
3570 | * loop over nucleon-nucleon interaction | |
3571 | NC = NPOINT(2) | |
3572 | DO 2 I=1,NCSY | |
3573 | * | |
3574 | * pick up one nucleon-nucleon interaction from DTEVT1 | |
3575 | * ppnn / ptnn - momenta of the interacting nucleons (cms) | |
3576 | * ptotnn - total momentum of the interacting nucleons (cms) | |
3577 | * pp1,2 / pt1,2 - momenta of the four partons | |
3578 | * pp / pt - total momenta of the proj / targ partons | |
3579 | * ptot - total momentum of the four partons | |
3580 | MOP = JMOHKK(1,NC) | |
3581 | MOT = JMOHKK(1,NC+1) | |
3582 | DO 3 K=1,4 | |
3583 | PPNN(K) = PHKK(K,MOP) | |
3584 | PTNN(K) = PHKK(K,MOT) | |
3585 | PTOTNN(K) = PPNN(K)+PTNN(K) | |
3586 | PP1(K) = PHKK(K,NC) | |
3587 | PT1(K) = PHKK(K,NC+1) | |
3588 | PP2(K) = PHKK(K,NC+2) | |
3589 | PT2(K) = PHKK(K,NC+3) | |
3590 | PP(K) = PP1(K)+PP2(K) | |
3591 | PT(K) = PT1(K)+PT2(K) | |
3592 | PTOT(K) = PP(K)+PT(K) | |
3593 | 3 CONTINUE | |
3594 | * | |
3595 | *----------------------------------------------------------------------- | |
3596 | * this is a complete nucleon-nucleon interaction | |
3597 | * | |
3598 | IF (ISINGL(I).EQ.1) THEN | |
3599 | * | |
3600 | * initialize PHOJET-variables for remnant/valence-partons | |
3601 | IHFLD(1,1) = 0 | |
3602 | IHFLD(1,2) = 0 | |
3603 | IHFLD(2,1) = 0 | |
3604 | IHFLD(2,2) = 0 | |
3605 | IHFLS(1) = 1 | |
3606 | IHFLS(2) = 1 | |
3607 | * save current settings of PHOJET process and min. bias flags | |
3608 | DO 9 K=1,11 | |
3609 | KPRON(K) = IPRON(K,1) | |
3610 | 9 CONTINUE | |
3611 | ISWSAV = ISWMDL(2) | |
3612 | * | |
3613 | * check if forced sampling of diffractive interaction requested | |
3614 | IF (ISINGD.LT.-1) THEN | |
3615 | DO 90 K=1,11 | |
3616 | IPRON(K,1) = 0 | |
3617 | 90 CONTINUE | |
3618 | IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-3)) IPRON(5,1) = 1 | |
3619 | IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-4)) IPRON(6,1) = 1 | |
3620 | IF (ISINGD.EQ.-5) IPRON(4,1) = 1 | |
3621 | ENDIF | |
3622 | * | |
3623 | * for photons: a direct/anomalous interaction is not sampled | |
3624 | * in PHOJET but already in Glauber-formalism. Here we check if such | |
3625 | * an interaction is requested | |
3626 | IF (IJPROJ.EQ.7) THEN | |
3627 | * first switch off direct interactions | |
3628 | IPRON(8,1) = 0 | |
3629 | * this is a direct interactions | |
3630 | IF (IDIREC.EQ.1) THEN | |
3631 | DO 12 K=1,11 | |
3632 | IPRON(K,1) = 0 | |
3633 | 12 CONTINUE | |
3634 | IPRON(8,1) = 1 | |
3635 | * this is an anomalous interactions | |
3636 | * (iswmdl(2) = 0 only hard int. generated ( = 1 min. bias) ) | |
3637 | ELSEIF (IDIREC.EQ.2) THEN | |
3638 | ISWMDL(2) = 0 | |
3639 | ENDIF | |
3640 | ELSE | |
3641 | IF (IDIREC.NE.0) STOP ' DT_EVENTB: IDIREC > 0 ! ' | |
3642 | ENDIF | |
3643 | * | |
3644 | * make sure that total momenta of partons, pp and pt, are on mass | |
3645 | * shell (Cronin may have srewed this up..) | |
3646 | CALL DT_MASHEL(PP,PT,PHKK(5,MOP),PHKK(5,MOT),PPNN,PTNN,IR1) | |
3647 | IF (IR1.NE.0) THEN | |
3648 | IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A)') | |
3649 | & 'EVENTB: mass shell correction rejected' | |
3650 | GOTO 9999 | |
3651 | ENDIF | |
3652 | * | |
3653 | * initialize the incoming particles in PHOJET | |
3654 | IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN | |
3655 | CALL PHO_SETPAR(1,22,0,VIRT) | |
3656 | ELSE | |
3657 | CALL PHO_SETPAR(1,IDHKK(MOP),0,ZERO) | |
3658 | ENDIF | |
3659 | CALL PHO_SETPAR(2,IDHKK(MOT),0,ZERO) | |
3660 | * | |
3661 | * initialize rejection loop counter for anomalous processes | |
3662 | IRJANO = 0 | |
3663 | 800 CONTINUE | |
3664 | IRJANO = IRJANO+1 | |
3665 | * | |
3666 | * temporary fix for ifano problem | |
3667 | IFANO(1) = 0 | |
3668 | IFANO(2) = 0 | |
3669 | * | |
3670 | * generate complete hadron/nucleon/photon-nucleon event with PHOJET | |
3671 | CALL PHO_EVENT(2,PPNN,PTNN,DUM,IREJ1) | |
3672 | * | |
3673 | * for photons: special consistency check for anomalous interactions | |
3674 | IF (IJPROJ.EQ.7) THEN | |
3675 | IF (IRJANO.LT.30) THEN | |
3676 | IF (IFANO(1).NE.0) THEN | |
3677 | * here, an anomalous interaction was generated. Check if it | |
3678 | * was also requested. Otherwise reject this event. | |
3679 | IF (IDIREC.EQ.0) GOTO 800 | |
3680 | ELSE | |
3681 | * here, an anomalous interaction was not generated. Check if it | |
3682 | * was requested in which case we need to reject this event. | |
3683 | IF (IDIREC.EQ.2) GOTO 800 | |
3684 | ENDIF | |
3685 | ELSE | |
3686 | WRITE(LOUT,*) ' DT_EVENTB: Warning! IRJANO > 30 ', | |
3687 | & IRJANO,IDIREC,NEVHKK | |
3688 | ENDIF | |
3689 | ENDIF | |
3690 | * | |
3691 | * copy back original settings of PHOJET process and min. bias flags | |
3692 | DO 10 K=1,11 | |
3693 | IPRON(K,1) = KPRON(K) | |
3694 | 10 CONTINUE | |
3695 | ISWMDL(2) = ISWSAV | |
3696 | * | |
3697 | * check if PHOJET has rejected this event | |
3698 | IF (IREJ1.NE.0) THEN | |
3699 | C IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)') | |
3700 | WRITE(LOUT,'(1X,A,I4)') | |
3701 | & 'EVENTB: chain system rejected',IDIREC | |
3702 | CALL PHO_PREVNT(0) | |
3703 | GOTO 9999 | |
3704 | ENDIF | |
3705 | * | |
3706 | * copy partons and strings from PHOJET common back into DTEVT for | |
3707 | * external fragmentation | |
3708 | MO1 = NC | |
3709 | MO2 = NC+3 | |
3710 | *! uncomment this line for internal phojet-fragmentation | |
3711 | C CALL DT_GETFSP(MO1,MO2,PPNN,PTNN,-1) | |
3712 | NPHOSC = NPHOSC+1 | |
3713 | CALL DT_GETPJE(MO1,MO2,PPNN,PTNN,-1,NPHOSC,IREJ1) | |
3714 | IF (IREJ1.NE.0) THEN | |
3715 | IF (IOULEV(1).GT.0) | |
3716 | & WRITE(LOUT,'(1X,A,I4)') 'EVENTB: chain system rejected 1' | |
3717 | GOTO 9999 | |
3718 | ENDIF | |
3719 | * | |
3720 | * update statistics counter | |
3721 | ICEVTG(IDCH(NC),29) = ICEVTG(IDCH(NC),29)+1 | |
3722 | * | |
3723 | *----------------------------------------------------------------------- | |
3724 | * this interaction involves "remnants" | |
3725 | * | |
3726 | ELSE | |
3727 | * | |
3728 | * total mass of this system | |
3729 | PPTOT = SQRT(PTOT(1)**2+PTOT(2)**2+PTOT(3)**2) | |
3730 | AMTOT2 = (PTOT(4)-PPTOT)*(PTOT(4)+PPTOT) | |
3731 | IF (AMTOT2.LT.ZERO) THEN | |
3732 | AMTOT = ZERO | |
3733 | ELSE | |
3734 | AMTOT = SQRT(AMTOT2) | |
3735 | ENDIF | |
3736 | * | |
3737 | * systems with masses larger than elojet are treated with PHOJET | |
3738 | IF (AMTOT.GT.ELOJET) THEN | |
3739 | * | |
3740 | * initialize PHOJET-variables for remnant/valence-partons | |
3741 | * projectile parton flavors and valence flag | |
3742 | IHFLD(1,1) = IDHKK(NC) | |
3743 | IHFLD(1,2) = IDHKK(NC+2) | |
3744 | IHFLS(1) = 0 | |
3745 | IF ((IDCH(NC).EQ.6).OR.(IDCH(NC).EQ.7) | |
3746 | & .OR.(IDCH(NC).EQ.8)) IHFLS(1) = 1 | |
3747 | * target parton flavors and valence flag | |
3748 | IHFLD(2,1) = IDHKK(NC+1) | |
3749 | IHFLD(2,2) = IDHKK(NC+3) | |
3750 | IHFLS(2) = 0 | |
3751 | IF ((IDCH(NC).EQ.4).OR.(IDCH(NC).EQ.5) | |
3752 | & .OR.(IDCH(NC).EQ.8)) IHFLS(2) = 1 | |
3753 | * flag signalizing PHOJET how to treat the remnant: | |
3754 | * iremn = -1 sea-quark remnant: PHOJET takes flavors from ihfld | |
3755 | * iremn > -1 valence remnant: PHOJET assumes flavors according | |
3756 | * to mother particle | |
3757 | IREMN1 = IHFLS(1)-1 | |
3758 | IREMN2 = IHFLS(2)-1 | |
3759 | * | |
3760 | * initialize the incoming particles in PHOJET | |
3761 | IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN | |
3762 | CALL PHO_SETPAR(1,22,IREMN1,VIRT) | |
3763 | ELSE | |
3764 | CALL PHO_SETPAR(1,IDHKK(MOP),IREMN1,ZERO) | |
3765 | ENDIF | |
3766 | CALL PHO_SETPAR(2,IDHKK(MOT),IREMN2,ZERO) | |
3767 | * | |
3768 | * calculate Lorentz parameter of the nucleon-nucleon cm-system | |
3769 | PPTOTN = SQRT(PTOTNN(1)**2+PTOTNN(2)**2+PTOTNN(3)**2) | |
3770 | AMNN = SQRT( (PTOTNN(4)-PPTOTN)*(PTOTNN(4)+PPTOTN) ) | |
3771 | BGX = PTOTNN(1)/AMNN | |
3772 | BGY = PTOTNN(2)/AMNN | |
3773 | BGZ = PTOTNN(3)/AMNN | |
3774 | GAM = PTOTNN(4)/AMNN | |
3775 | * transform interacting nucleons into nucleon-nucleon cm-system | |
3776 | CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ, | |
3777 | & PPNN(1),PPNN(2),PPNN(3),PPNN(4),PPCMS, | |
3778 | & PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4)) | |
3779 | CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ, | |
3780 | & PTNN(1),PTNN(2),PTNN(3),PTNN(4),PTCMS, | |
3781 | & PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4)) | |
3782 | * transform (total) momenta of the proj and targ partons into | |
3783 | * nucleon-nucleon cm-system | |
3784 | CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ, | |
3785 | & PP(1),PP(2),PP(3),PP(4), | |
3786 | & PPTSUB,PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4)) | |
3787 | CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ, | |
3788 | & PT(1),PT(2),PT(3),PT(4), | |
3789 | & PTTSUB,PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4)) | |
3790 | * energy fractions of the proj and targ partons | |
3791 | XPSUB = MIN(PPSUB(4)/PPTCMS(4),ONE) | |
3792 | XTSUB = MIN(PTSUB(4)/PTTCMS(4),ONE) | |
3793 | *** | |
3794 | * testprint | |
3795 | c PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 + | |
3796 | c & (PPTCMS(2)+PTTCMS(2))**2 + | |
3797 | c & (PPTCMS(3)+PTTCMS(3))**2 ) | |
3798 | c EOLDCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) * | |
3799 | c & (PPTCMS(4)+PTTCMS(4)+PTOTCM) ) | |
3800 | c PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 + | |
3801 | c & (PPSUB(2)+PTSUB(2))**2 + | |
3802 | c & (PPSUB(3)+PTSUB(3))**2 ) | |
3803 | c EOLDSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) * | |
3804 | c & (PPSUB(4)+PTSUB(4)+PTOTSU) ) | |
3805 | *** | |
3806 | * | |
3807 | * save current settings of PHOJET process and min. bias flags | |
3808 | DO 7 K=1,11 | |
3809 | KPRON(K) = IPRON(K,1) | |
3810 | 7 CONTINUE | |
3811 | * disallow direct photon int. (does not make sense here anyway) | |
3812 | IPRON(8,1) = 0 | |
3813 | * disallow double pomeron processes (due to technical problems | |
3814 | * in PHOJET, needs to be solved sometime) | |
3815 | IPRON(4,1) = 0 | |
3816 | * disallow diffraction for sea-diquarks | |
3817 | IF ((IABS(IHFLD(1,1)).GT.1100).AND. | |
3818 | & (IABS(IHFLD(1,2)).GT.1100)) THEN | |
3819 | IPRON(3,1) = 0 | |
3820 | IPRON(6,1) = 0 | |
3821 | ENDIF | |
3822 | IF ((IABS(IHFLD(2,1)).GT.1100).AND. | |
3823 | & (IABS(IHFLD(2,2)).GT.1100)) THEN | |
3824 | IPRON(3,1) = 0 | |
3825 | IPRON(5,1) = 0 | |
3826 | ENDIF | |
3827 | * | |
3828 | * we need massless partons: transform them on mass shell | |
3829 | XMP = ZERO | |
3830 | XMT = ZERO | |
3831 | DO 6 K=1,4 | |
3832 | PPTMP(K) = PPSUB(K) | |
3833 | PTTMP(K) = PTSUB(K) | |
3834 | 6 CONTINUE | |
3835 | CALL DT_MASHEL(PPTMP,PTTMP,XMP,XMT,PPSUB,PTSUB,IREJ1) | |
3836 | PPSUTO = SQRT(PPSUB(1)**2+PPSUB(2)**2+PPSUB(3)**2) | |
3837 | PTSUTO = SQRT(PTSUB(1)**2+PTSUB(2)**2+PTSUB(3)**2) | |
3838 | PSUTOT = SQRT((PPSUB(1)+PTSUB(1))**2+ | |
3839 | & (PPSUB(2)+PTSUB(2))**2+(PPSUB(3)+PTSUB(3))**2) | |
3840 | * total energy of the subsysten after mass transformation | |
3841 | * (should be the same as before..) | |
3842 | SECM = SQRT( (PPSUB(4)+PTSUB(4)-PSUTOT)* | |
3843 | & (PPSUB(4)+PTSUB(4)+PSUTOT) ) | |
3844 | * | |
3845 | * after mass shell transformation the x_sub - relation has to be | |
3846 | * corrected. We therefore create "pseudo-momenta" of mother-nucleons. | |
3847 | * | |
3848 | * The old version was to scale based on the original x_sub and the | |
3849 | * 4-momenta of the subsystem. At very high energy this could lead to | |
3850 | * "pseudo-cm energies" of the parent system considerably exceeding | |
3851 | * the true cm energy. Now we keep the true cm energy and calculate | |
3852 | * new x_sub instead. | |
3853 | C old version PPTCMS(4) = PPSUB(4)/XPSUB | |
3854 | PPTCMS(4) = MAX(PPTCMS(4),PPSUB(4)) | |
3855 | XPSUB = PPSUB(4)/PPTCMS(4) | |
3856 | IF (IJPROJ.EQ.7) THEN | |
3857 | AMP2 = PHKK(5,MOT)**2 | |
3858 | PTOT1 = SQRT(PPTCMS(4)**2-AMP2) | |
3859 | ELSE | |
3860 | *??????? | |
3861 | PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOP)) | |
3862 | & *(PPTCMS(4)+PHKK(5,MOP))) | |
3863 | C PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOT)) | |
3864 | C & *(PPTCMS(4)+PHKK(5,MOT))) | |
3865 | ENDIF | |
3866 | C old version PTTCMS(4) = PTSUB(4)/XTSUB | |
3867 | PTTCMS(4) = MAX(PTTCMS(4),PTSUB(4)) | |
3868 | XTSUB = PTSUB(4)/PTTCMS(4) | |
3869 | PTOT2 = SQRT((PTTCMS(4)-PHKK(5,MOT)) | |
3870 | & *(PTTCMS(4)+PHKK(5,MOT))) | |
3871 | DO 4 K=1,3 | |
3872 | PPTCMS(K) = PTOT1*PPSUB(K)/PPSUTO | |
3873 | PTTCMS(K) = PTOT2*PTSUB(K)/PTSUTO | |
3874 | 4 CONTINUE | |
3875 | *** | |
3876 | * testprint | |
3877 | * | |
3878 | * ppnn / ptnn - momenta of the int. nucleons (cms, negl. Fermi) | |
3879 | * ptotnn - total momentum of the int. nucleons (cms, negl. Fermi) | |
3880 | * pptcms/ pttcms - momenta of the interacting nucleons (cms) | |
3881 | * pp1,2 / pt1,2 - momenta of the four partons | |
3882 | * | |
3883 | * pp / pt - total momenta of the pr/ta partons (cms, negl. Fermi) | |
3884 | * ptot - total momentum of the four partons (cms, negl. Fermi) | |
3885 | * ppsub / ptsub - total momenta of the proj / targ partons (cms) | |
3886 | * | |
3887 | c PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 + | |
3888 | c & (PPTCMS(2)+PTTCMS(2))**2 + | |
3889 | c & (PPTCMS(3)+PTTCMS(3))**2 ) | |
3890 | c ENEWCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) * | |
3891 | c & (PPTCMS(4)+PTTCMS(4)+PTOTCM) ) | |
3892 | c PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 + | |
3893 | c & (PPSUB(2)+PTSUB(2))**2 + | |
3894 | c & (PPSUB(3)+PTSUB(3))**2 ) | |
3895 | c ENEWSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) * | |
3896 | c & (PPSUB(4)+PTSUB(4)+PTOTSU) ) | |
3897 | c IF (ENEWCM/EOLDCM.GT.1.1D0) THEN | |
3898 | c WRITE(*,*) ' EOLDCM, ENEWCM : ',EOLDCM,ENEWCM | |
3899 | c WRITE(*,*) ' EOLDSU, ENEWSU : ',EOLDSU,ENEWSU | |
3900 | c WRITE(*,*) ' XPSUB, XTSUB : ',XPSUB,XTSUB | |
3901 | c ENDIF | |
3902 | c BBGX = (PPTCMS(1)+PTTCMS(1))/ENEWCM | |
3903 | c BBGY = (PPTCMS(2)+PTTCMS(2))/ENEWCM | |
3904 | c BBGZ = (PPTCMS(3)+PTTCMS(3))/ENEWCM | |
3905 | c BGAM = (PPTCMS(4)+PTTCMS(4))/ENEWCM | |
3906 | * transform interacting nucleons into nucleon-nucleon cm-system | |
3907 | c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ, | |
3908 | c & PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4),PPTOT, | |
3909 | c & PPNEW1,PPNEW2,PPNEW3,PPNEW4) | |
3910 | c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ, | |
3911 | c & PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4),PTTOT, | |
3912 | c & PTNEW1,PTNEW2,PTNEW3,PTNEW4) | |
3913 | c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ, | |
3914 | c & PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4),PPTOT, | |
3915 | c & PPSUB1,PPSUB2,PPSUB3,PPSUB4) | |
3916 | c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ, | |
3917 | c & PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4),PTTOT, | |
3918 | c & PTSUB1,PTSUB2,PTSUB3,PTSUB4) | |
3919 | c PTSTCM = SQRT( (PPNEW1+PTNEW1)**2 + | |
3920 | c & (PPNEW2+PTNEW2)**2 + | |
3921 | c & (PPNEW3+PTNEW3)**2 ) | |
3922 | c ETSTCM = SQRT( (PPNEW4+PTNEW4-PTSTCM) * | |
3923 | c & (PPNEW4+PTNEW4+PTSTCM) ) | |
3924 | c PTSTSU = SQRT( (PPSUB1+PTSUB1)**2 + | |
3925 | c & (PPSUB2+PTSUB2)**2 + | |
3926 | c & (PPSUB3+PTSUB3)**2 ) | |
3927 | c ETSTSU = SQRT( (PPSUB4+PTSUB4-PTSTSU) * | |
3928 | c & (PPSUB4+PTSUB4+PTSTSU) ) | |
3929 | C WRITE(*,*) ' mother cmE :' | |
3930 | C WRITE(*,*) ETSTCM,ENEWCM | |
3931 | C WRITE(*,*) ' subsystem cmE :' | |
3932 | C WRITE(*,*) ETSTSU,ENEWSU | |
3933 | C WRITE(*,*) ' projectile mother :' | |
3934 | C WRITE(*,*) PPNEW1,PPNEW2,PPNEW3,PPNEW4 | |
3935 | C WRITE(*,*) ' target mother :' | |
3936 | C WRITE(*,*) PTNEW1,PTNEW2,PTNEW3,PTNEW4 | |
3937 | C WRITE(*,*) ' projectile subsystem:' | |
3938 | C WRITE(*,*) PPSUB1,PPSUB2,PPSUB3,PPSUB4 | |
3939 | C WRITE(*,*) ' target subsystem:' | |
3940 | C WRITE(*,*) PTSUB1,PTSUB2,PTSUB3,PTSUB4 | |
3941 | C WRITE(*,*) ' projectile subsystem should be:' | |
3942 | C WRITE(*,*) ZERO,ZERO,XPSUB*ETSTCM/2.0D0, | |
3943 | C & XPSUB*ETSTCM/2.0D0 | |
3944 | C WRITE(*,*) ' target subsystem should be:' | |
3945 | C WRITE(*,*) ZERO,ZERO,-XTSUB*ETSTCM/2.0D0, | |
3946 | C & XTSUB*ETSTCM/2.0D0 | |
3947 | C WRITE(*,*) ' subsystem cmE should be: ' | |
3948 | C WRITE(*,*) SQRT(XPSUB*XTSUB)*ETSTCM,XPSUB,XTSUB | |
3949 | *** | |
3950 | * | |
3951 | * generate complete remnant - nucleon/remnant event with PHOJET | |
3952 | CALL PHO_EVENT(3,PPTCMS,PTTCMS,DUM,IREJ1) | |
3953 | * | |
3954 | * copy back original settings of PHOJET process flags | |
3955 | DO 11 K=1,11 | |
3956 | IPRON(K,1) = KPRON(K) | |
3957 | 11 CONTINUE | |
3958 | * | |
3959 | * check if PHOJET has rejected this event | |
3960 | IF (IREJ1.NE.0) THEN | |
3961 | IF (IOULEV(1).GT.0) | |
3962 | & WRITE(LOUT,'(1X,A)') 'EVENTB: chain system rejected' | |
3963 | WRITE(LOUT,*) | |
3964 | & 'XPSUB,XTSUB,SECM ',XPSUB,XTSUB,SECM,AMTOT | |
3965 | CALL PHO_PREVNT(0) | |
3966 | GOTO 9999 | |
3967 | ENDIF | |
3968 | * | |
3969 | * copy partons and strings from PHOJET common back into DTEVT for | |
3970 | * external fragmentation | |
3971 | MO1 = NC | |
3972 | MO2 = NC+3 | |
3973 | *! uncomment this line for internal phojet-fragmentation | |
3974 | C CALL DT_GETFSP(MO1,MO2,PP,PT,1) | |
3975 | NPHOSC = NPHOSC+1 | |
3976 | CALL DT_GETPJE(MO1,MO2,PP,PT,1,NPHOSC,IREJ1) | |
3977 | IF (IREJ1.NE.0) THEN | |
3978 | IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)') | |
3979 | & 'EVENTB: chain system rejected 2' | |
3980 | GOTO 9999 | |
3981 | ENDIF | |
3982 | * | |
3983 | * update statistics counter | |
3984 | ICEVTG(IDCH(NC),2) = ICEVTG(IDCH(NC),2)+1 | |
3985 | * | |
3986 | *----------------------------------------------------------------------- | |
3987 | * two-chain approx. for smaller systems | |
3988 | * | |
3989 | ELSE | |
3990 | * | |
3991 | NDTUSC = NDTUSC+1 | |
3992 | * special flag for double-Pomeron statistics | |
3993 | IPOPO = 0 | |
3994 | * | |
3995 | * pick up flavors at the ends of the two chains | |
3996 | IFP1 = IDHKK(NC) | |
3997 | IFT1 = IDHKK(NC+1) | |
3998 | IFP2 = IDHKK(NC+2) | |
3999 | IFT2 = IDHKK(NC+3) | |
4000 | * ..and the indices of the mothers | |
4001 | MOP1 = NC | |
4002 | MOT1 = NC+1 | |
4003 | MOP2 = NC+2 | |
4004 | MOT2 = NC+3 | |
4005 | CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2, | |
4006 | & IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1) | |
4007 | * | |
4008 | * check if this chain system was rejected | |
4009 | IF (IREJ1.GT.0) THEN | |
4010 | IF (IOULEV(1).GT.0) THEN | |
4011 | WRITE(LOUT,*) 'rejected 1 in EVENTB' | |
4012 | WRITE(LOUT,'(1X,4(I6,4E12.3,/),E12.3)') | |
4013 | & IFP1,PP1,IFT1,PT1,IFP2,PP2,IFT2,PT2,AMTOT | |
4014 | ENDIF | |
4015 | IRHHA = IRHHA+1 | |
4016 | GOTO 9999 | |
4017 | ENDIF | |
4018 | * the following lines are for sea-sea chains rejected in GETCSY | |
4019 | IF (IREJ1.EQ.-1) NDTUSC = NDTUSC-1 | |
4020 | ICEVTG(IDCH(NC),1) = ICEVTG(IDCH(NC),1)+1 | |
4021 | ENDIF | |
4022 | * | |
4023 | ENDIF | |
4024 | * | |
4025 | * update statistics counter | |
4026 | ICEVTG(IDCH(NC),0) = ICEVTG(IDCH(NC),0)+1 | |
4027 | * | |
4028 | NC = NC+4 | |
4029 | * | |
4030 | 2 CONTINUE | |
4031 | * | |
4032 | *----------------------------------------------------------------------- | |
4033 | * treatment of low-mass chains (if there are any) | |
4034 | * | |
4035 | IF (NDTUSC.GT.0) THEN | |
4036 | * | |
4037 | * correct chains of very low masses for possible resonances | |
4038 | IF (IRESCO.EQ.1) THEN | |
4039 | CALL DT_EVTRES(IREJ1) | |
4040 | IF (IREJ1.GT.0) THEN | |
4041 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2a in EVENTB' | |
4042 | IRRES(1) = IRRES(1)+1 | |
4043 | GOTO 9999 | |
4044 | ENDIF | |
4045 | ENDIF | |
4046 | * fragmentation of low-mass chains | |
4047 | *! uncomment this line for internal phojet-fragmentation | |
4048 | * (of course it will still be fragmented by DPMJET-routines but it | |
4049 | * has to be done here instead of further below) | |
4050 | C CALL DT_EVTFRA(IREJ1) | |
4051 | C IF (IREJ1.GT.0) THEN | |
4052 | C IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2b in EVENTB' | |
4053 | C IRFRAG = IRFRAG+1 | |
4054 | C GOTO 9999 | |
4055 | C ENDIF | |
4056 | ELSE | |
4057 | *! uncomment this line for internal phojet-fragmentation | |
4058 | C NPOINT(4) = NHKK+1 | |
4059 | IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1 | |
4060 | ENDIF | |
4061 | * | |
4062 | *----------------------------------------------------------------------- | |
4063 | * new di-quark breaking mechanisms | |
4064 | * | |
4065 | MXLEFT = 2 | |
4066 | CALL DT_CHASTA(0) | |
4067 | IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0) | |
4068 | & .OR.(PDBSEA(3).GT.0.0D0)) THEN | |
4069 | CALL DT_DIQBRK | |
4070 | MXLEFT = 4 | |
4071 | ENDIF | |
4072 | * | |
4073 | *----------------------------------------------------------------------- | |
4074 | * hadronize this event | |
4075 | * | |
4076 | * hadronize PHOJET chain systems | |
4077 | NPYMAX = 0 | |
4078 | NPJE = NPHOSC/MXPHFR | |
4079 | IF (MXPHFR.LT.MXLEFT) MXLEFT = 2 | |
4080 | IF (NPJE.GT.1) THEN | |
4081 | NLEFT = NPHOSC-NPJE*MXPHFR | |
4082 | DO 20 JFRG=1,NPJE | |
4083 | NFRG = JFRG*MXPHFR | |
4084 | IF ((JFRG.EQ.NPJE).AND.(NLEFT.LE.MXLEFT)) THEN | |
4085 | CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1) | |
4086 | IF (IREJ1.GT.0) GOTO 22 | |
4087 | NLEFT = 0 | |
4088 | ELSE | |
4089 | CALL DT_EVTFRG(1,NFRG,NPYMEM,IREJ1) | |
4090 | IF (IREJ1.GT.0) GOTO 22 | |
4091 | ENDIF | |
4092 | IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM | |
4093 | 20 CONTINUE | |
4094 | IF (NLEFT.GT.0) THEN | |
4095 | CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1) | |
4096 | IF (IREJ1.GT.0) GOTO 22 | |
4097 | IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM | |
4098 | ENDIF | |
4099 | ELSE | |
4100 | CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1) | |
4101 | IF (IREJ1.GT.0) GOTO 22 | |
4102 | IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM | |
4103 | ENDIF | |
4104 | * | |
4105 | * check max. filling level of jetset common and | |
4106 | * reduce mxphfr if necessary | |
4107 | IF (NPYMAX.GT.3000) THEN | |
4108 | IF (NPYMAX.GT.3500) THEN | |
4109 | MXPHFR = MAX(1,MXPHFR-2) | |
4110 | ELSE | |
4111 | MXPHFR = MAX(1,MXPHFR-1) | |
4112 | ENDIF | |
4113 | C WRITE(LOUT,*) ' EVENTB: Mxphfr reduced to ',MXPHFR | |
4114 | ENDIF | |
4115 | * | |
4116 | * hadronize DTUNUC chain systems | |
4117 | 23 CONTINUE | |
4118 | IBACK = MXDTFR | |
4119 | CALL DT_EVTFRG(2,IBACK,NPYMEM,IREJ2) | |
4120 | IF (IREJ2.GT.0) GOTO 22 | |
4121 | * | |
4122 | * check max. filling level of jetset common and | |
4123 | * reduce mxdtfr if necessary | |
4124 | IF (NPYMEM.GT.3000) THEN | |
4125 | IF (NPYMEM.GT.3500) THEN | |
4126 | MXDTFR = MAX(1,MXDTFR-20) | |
4127 | ELSE | |
4128 | MXDTFR = MAX(1,MXDTFR-10) | |
4129 | ENDIF | |
4130 | C WRITE(LOUT,*) ' EVENTB: Mxdtfr reduced to ',MXDTFR | |
4131 | ENDIF | |
4132 | * | |
4133 | IF (IBACK.EQ.-1) GOTO 23 | |
4134 | * | |
4135 | 22 CONTINUE | |
4136 | C CALL DT_EVTFRG(1,IREJ1) | |
4137 | C CALL DT_EVTFRG(2,IREJ2) | |
4138 | IF ((IREJ1.GT.0).OR.(IREJ2.GT.0)) THEN | |
4139 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTB' | |
4140 | IRFRAG = IRFRAG+1 | |
4141 | GOTO 9999 | |
4142 | ENDIF | |
4143 | * | |
4144 | * get final state particles from /DTEVTP/ | |
4145 | *! uncomment this line for internal phojet-fragmentation | |
4146 | C CALL DT_GETFSP(IDUM,IDUM,PP,PT,2) | |
4147 | ||
4148 | IF (IJPROJ.NE.7) | |
4149 | & CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,88,IREJ3) | |
4150 | C IF (IREJ3.NE.0) GOTO 9999 | |
4151 | ||
4152 | RETURN | |
4153 | ||
4154 | 9999 CONTINUE | |
4155 | IREVT = IREVT+1 | |
4156 | IREJ = 1 | |
4157 | RETURN | |
4158 | END | |
4159 | ||
4160 | *$ CREATE DT_GETPJE.FOR | |
4161 | *COPY DT_GETPJE | |
4162 | * | |
4163 | *===getpje=============================================================* | |
4164 | * | |
4165 | SUBROUTINE DT_GETPJE(MO1,MO2,PP,PT,MODE,IPJE,IREJ) | |
4166 | ||
4167 | ************************************************************************ | |
4168 | * This subroutine copies PHOJET partons and strings from POEVT1 into * | |
4169 | * DTEVT1. * | |
4170 | * MO1,MO2 indices of first and last mother-parton in DTEVT1 * | |
4171 | * PP,PT 4-momenta of projectile/target being handled by * | |
4172 | * PHOJET * | |
4173 | * This version dated 11.12.99 is written by S. Roesler * | |
4174 | ************************************************************************ | |
4175 | ||
4176 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
4177 | SAVE | |
4178 | PARAMETER ( LINP = 10 , | |
4179 | & LOUT = 6 , | |
4180 | & LDAT = 9 ) | |
4181 | PARAMETER (TINY10=1.0D-10,TINY1=1.0D-1, | |
4182 | & ZERO=0.0D0,ONE=1.0D0,OHALF=0.5D0) | |
4183 | ||
4184 | LOGICAL LFLIP | |
4185 | ||
4186 | * event history | |
4187 | PARAMETER (NMXHKK=200000) | |
4188 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
4189 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
4190 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
4191 | * extended event history | |
4192 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
4193 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
4194 | & IHIST(2,NMXHKK) | |
4195 | * Lorentz-parameters of the current interaction | |
4196 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
4197 | & UMO,PPCM,EPROJ,PPROJ | |
4198 | * DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem | |
4199 | COMMON /DTLTSU/ BGX,BGY,BGZ,GAM | |
4200 | * flags for input different options | |
4201 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
4202 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
4203 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
4204 | * statistics: double-Pomeron exchange | |
4205 | COMMON /DTFLG2/ INTFLG,IPOPO | |
4206 | * statistics | |
4207 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
4208 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
4209 | & ICEVTG(8,0:30) | |
4210 | * rejection counter | |
4211 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
4212 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
4213 | & IREXCI(3),IRDIFF(2),IRINC | |
4214 | C standard particle data interface | |
4215 | INTEGER NMXHEP | |
4216 | PARAMETER (NMXHEP=4000) | |
4217 | INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP | |
4218 | DOUBLE PRECISION PHEP,VHEP | |
4219 | COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP), | |
4220 | & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP), | |
4221 | & VHEP(4,NMXHEP) | |
4222 | C extension to standard particle data interface (PHOJET specific) | |
4223 | INTEGER IMPART,IPHIST,ICOLOR | |
4224 | COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP) | |
4225 | C color string configurations including collapsed strings and hadrons | |
4226 | INTEGER MSTR | |
4227 | PARAMETER (MSTR=500) | |
4228 | INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD | |
4229 | COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR), | |
4230 | & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR), | |
4231 | & NNCH(MSTR),IBHAD(MSTR),ISTR | |
4232 | C general process information | |
4233 | INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON | |
4234 | COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4) | |
4235 | C model switches and parameters | |
4236 | CHARACTER*8 MDLNA | |
4237 | INTEGER ISWMDL,IPAMDL | |
4238 | DOUBLE PRECISION PARMDL | |
4239 | COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400) | |
4240 | C event debugging information | |
4241 | INTEGER NMAXD | |
4242 | PARAMETER (NMAXD=100) | |
4243 | INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO, | |
4244 | & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD | |
4245 | COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG, | |
4246 | & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD | |
4247 | ||
4248 | DIMENSION PP(4),PT(4) | |
4249 | DATA MAXLOP /10000/ | |
4250 | ||
4251 | INHKK = NHKK | |
4252 | LFLIP = .TRUE. | |
4253 | 1 CONTINUE | |
4254 | NPVAL = 0 | |
4255 | NTVAL = 0 | |
4256 | IREJ = 0 | |
4257 | ||
4258 | * store initial momenta for energy-momentum conservation check | |
4259 | IF (LEMCCK) THEN | |
4260 | CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM1,IDUM2) | |
4261 | CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM1,IDUM2) | |
4262 | ENDIF | |
4263 | * copy partons and strings from POEVT1 into DTEVT1 | |
4264 | DO 11 I=1,ISTR | |
4265 | C IF ((NCODE(I).EQ.-99).AND.(IPAMDL(17).EQ.0)) THEN | |
4266 | IF (NCODE(I).EQ.-99) THEN | |
4267 | IDXSTG = NPOS(1,I) | |
4268 | IDSTG = IDHEP(IDXSTG) | |
4269 | PX = PHEP(1,IDXSTG) | |
4270 | PY = PHEP(2,IDXSTG) | |
4271 | PZ = PHEP(3,IDXSTG) | |
4272 | PE = PHEP(4,IDXSTG) | |
4273 | IF (MODE.LT.0) THEN | |
4274 | ISTAT = 70000+IPJE | |
4275 | CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PX,PY,PZ,PE, | |
4276 | & 11,IDSTG,0) | |
4277 | IF (LEMCCK) THEN | |
4278 | PX = -PX | |
4279 | PY = -PY | |
4280 | PZ = -PZ | |
4281 | PE = -PE | |
4282 | CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2) | |
4283 | ENDIF | |
4284 | ELSE | |
4285 | CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP, | |
4286 | & PPX,PPY,PPZ,PPE) | |
4287 | ISTAT = 70000+IPJE | |
4288 | CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PPX,PPY,PPZ,PPE, | |
4289 | & 11,IDSTG,0) | |
4290 | IF (LEMCCK) THEN | |
4291 | PX = -PPX | |
4292 | PY = -PPY | |
4293 | PZ = -PPZ | |
4294 | PE = -PPE | |
4295 | CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2) | |
4296 | ENDIF | |
4297 | ENDIF | |
4298 | NOBAM(NHKK) = 0 | |
4299 | IHIST(1,NHKK) = IPHIST(1,IDXSTG) | |
4300 | IHIST(2,NHKK) = 0 | |
4301 | ELSEIF (NCODE(I).GE.0) THEN | |
4302 | * indices of partons and string in POEVT1 | |
4303 | IDX1 = ABS(JMOHEP(1,NPOS(1,I))) | |
4304 | IDX2 = ABS(JMOHEP(2,NPOS(1,I))) | |
4305 | IF ((IDX1.GT.IDX2).OR.(JMOHEP(2,NPOS(1,I)).GT.0)) THEN | |
4306 | WRITE(LOUT,*) ' GETPJE: IDX1.GT.IDX2 ',IDX1,IDX2, | |
4307 | & ' or JMOHEP(2,NPOS(1,I)).GT.0 ',JMOHEP(2,NPOS(1,I)),' ! ' | |
4308 | STOP ' GETPJE 1' | |
4309 | ENDIF | |
4310 | IDXSTG = NPOS(1,I) | |
4311 | * find "mother" string of the string | |
4312 | IDXMS1 = ABS(JMOHEP(1,IDX1)) | |
4313 | IDXMS2 = ABS(JMOHEP(1,IDX2)) | |
4314 | IF (IDXMS1.NE.IDXMS2) THEN | |
4315 | IDXMS1 = IDXSTG | |
4316 | IDXMS2 = IDXSTG | |
4317 | C STOP ' GETPJE: IDXMS1.NE.IDXMS2 !' | |
4318 | ENDIF | |
4319 | * search POEVT1 for the original hadron of the parton | |
4320 | ILOOP = 0 | |
4321 | IPOM1 = 0 | |
4322 | 14 CONTINUE | |
4323 | ILOOP = ILOOP+1 | |
4324 | IF (IDHEP(IDXMS1).EQ.990) IPOM1 = 1 | |
4325 | IDXMS1 = ABS(JMOHEP(1,IDXMS1)) | |
4326 | IF ((IDXMS1.NE.1).AND.(IDXMS1.NE.2).AND. | |
4327 | & (ILOOP.LT.MAXLOP)) GOTO 14 | |
4328 | IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 1 ! ' | |
4329 | IPOM2 = 0 | |
4330 | ILOOP = 0 | |
4331 | 15 CONTINUE | |
4332 | ILOOP = ILOOP+1 | |
4333 | IF (IDHEP(IDXMS2).EQ.990) IPOM2 = 1 | |
4334 | IF ((ILOOP.EQ.1).OR.(IDHEP(IDXMS2).GE.7777)) THEN | |
4335 | IDXMS2 = ABS(JMOHEP(2,IDXMS2)) | |
4336 | ELSE | |
4337 | IDXMS2 = ABS(JMOHEP(1,IDXMS2)) | |
4338 | ENDIF | |
4339 | IF ((IDXMS2.NE.1).AND.(IDXMS2.NE.2).AND. | |
4340 | & (ILOOP.LT.MAXLOP)) GOTO 15 | |
4341 | IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 5 ! ' | |
4342 | * parton 1 | |
4343 | IF (IDXMS1.EQ.1) THEN | |
4344 | ISPTN1 = ISTHKK(MO1) | |
4345 | M1PTN1 = MO1 | |
4346 | M2PTN1 = MO1+2 | |
4347 | ELSE | |
4348 | ISPTN1 = ISTHKK(MO2) | |
4349 | M1PTN1 = MO2-2 | |
4350 | M2PTN1 = MO2 | |
4351 | ENDIF | |
4352 | * parton 2 | |
4353 | IF (IDXMS2.EQ.1) THEN | |
4354 | ISPTN2 = ISTHKK(MO1) | |
4355 | M1PTN2 = MO1 | |
4356 | M2PTN2 = MO1+2 | |
4357 | ELSE | |
4358 | ISPTN2 = ISTHKK(MO2) | |
4359 | M1PTN2 = MO2-2 | |
4360 | M2PTN2 = MO2 | |
4361 | ENDIF | |
4362 | * check for mis-identified mothers and switch mother indices if necessary | |
4363 | IF ((IDXMS1.EQ.IDXMS2).AND.(IPROCE.NE.5).AND.(IPROCE.NE.6) | |
4364 | & .AND.((IDHEP(IDX1).NE.21).OR.(IDHEP(IDX2).NE.21)).AND. | |
4365 | & (LFLIP)) THEN | |
4366 | IF (PHEP(3,IDX1).GT.PHEP(3,IDX2)) THEN | |
4367 | ISPTN1 = ISTHKK(MO1) | |
4368 | M1PTN1 = MO1 | |
4369 | M2PTN1 = MO1+2 | |
4370 | ISPTN2 = ISTHKK(MO2) | |
4371 | M1PTN2 = MO2-2 | |
4372 | M2PTN2 = MO2 | |
4373 | ELSE | |
4374 | ISPTN1 = ISTHKK(MO2) | |
4375 | M1PTN1 = MO2-2 | |
4376 | M2PTN1 = MO2 | |
4377 | ISPTN2 = ISTHKK(MO1) | |
4378 | M1PTN2 = MO1 | |
4379 | M2PTN2 = MO1+2 | |
4380 | ENDIF | |
4381 | ENDIF | |
4382 | * register partons in temporary common | |
4383 | * parton at chain end | |
4384 | PX = PHEP(1,IDX1) | |
4385 | PY = PHEP(2,IDX1) | |
4386 | PZ = PHEP(3,IDX1) | |
4387 | PE = PHEP(4,IDX1) | |
4388 | * flag only partons coming from Pomeron with 41/42 | |
4389 | C IF ((IPOM1.NE.0).OR.(NPOS(4,I).GE.4)) THEN | |
4390 | IF (IPOM1.NE.0) THEN | |
4391 | ISTX = ABS(ISPTN1)/10 | |
4392 | IMO = ABS(ISPTN1)-10*ISTX | |
4393 | ISPTN1 = -(40+IMO) | |
4394 | ELSE | |
4395 | IF ((ICOLOR(2,IDX1).EQ.0).OR.(IDHEP(IDX1).EQ.21)) THEN | |
4396 | ISTX = ABS(ISPTN1)/10 | |
4397 | IMO = ABS(ISPTN1)-10*ISTX | |
4398 | IF ((IDHEP(IDX1).EQ.21).OR. | |
4399 | & (ABS(IPHIST(1,IDX1)).GE.100)) THEN | |
4400 | ISPTN1 = -(60+IMO) | |
4401 | ELSE | |
4402 | ISPTN1 = -(50+IMO) | |
4403 | ENDIF | |
4404 | ENDIF | |
4405 | ENDIF | |
4406 | IF (ISPTN1.EQ.-21) NPVAL = NPVAL+1 | |
4407 | IF (ISPTN1.EQ.-22) NTVAL = NTVAL+1 | |
4408 | IF (MODE.LT.0) THEN | |
4409 | CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PX,PY, | |
4410 | & PZ,PE,0,0,0) | |
4411 | ELSE | |
4412 | CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP, | |
4413 | & PPX,PPY,PPZ,PPE) | |
4414 | CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PPX,PPY, | |
4415 | & PPZ,PPE,0,0,0) | |
4416 | ENDIF | |
4417 | IHIST(1,NHKK) = IPHIST(1,IDX1) | |
4418 | IHIST(2,NHKK) = 0 | |
4419 | DO 19 KK=1,4 | |
4420 | VHKK(KK,NHKK) = VHKK(KK,M2PTN1) | |
4421 | WHKK(KK,NHKK) = WHKK(KK,M1PTN1) | |
4422 | 19 CONTINUE | |
4423 | VHKK(4,NHKK) = VHKK(3,M2PTN1)/BLAB-VHKK(3,M1PTN1)/BGLAB | |
4424 | WHKK(4,NHKK) = -WHKK(3,M1PTN1)/BLAB+WHKK(3,M2PTN1)/BGLAB | |
4425 | M1STRG = NHKK | |
4426 | * gluon kinks | |
4427 | NGLUON = IDX2-IDX1-1 | |
4428 | IF (NGLUON.GT.0) THEN | |
4429 | DO 17 IGLUON=1,NGLUON | |
4430 | IDX = IDX1+IGLUON | |
4431 | IDXMS = ABS(JMOHEP(1,IDX)) | |
4432 | IF ((IDXMS.NE.1).AND.(IDXMS.NE.2)) THEN | |
4433 | ILOOP = 0 | |
4434 | 16 CONTINUE | |
4435 | ILOOP = ILOOP+1 | |
4436 | IDXMS = ABS(JMOHEP(1,IDXMS)) | |
4437 | IF ((IDXMS.NE.1).AND.(IDXMS.NE.2).AND. | |
4438 | & (ILOOP.LT.MAXLOP)) GOTO 16 | |
4439 | IF (ILOOP.EQ.MAXLOP) | |
4440 | & WRITE(LOUT,*) ' GETPJE: MAXLOP in 3 ! ' | |
4441 | ENDIF | |
4442 | IF (IDXMS.EQ.1) THEN | |
4443 | ISPTN = ISTHKK(MO1) | |
4444 | M1PTN = MO1 | |
4445 | M2PTN = MO1+2 | |
4446 | ELSE | |
4447 | ISPTN = ISTHKK(MO2) | |
4448 | M1PTN = MO2-2 | |
4449 | M2PTN = MO2 | |
4450 | ENDIF | |
4451 | PX = PHEP(1,IDX) | |
4452 | PY = PHEP(2,IDX) | |
4453 | PZ = PHEP(3,IDX) | |
4454 | PE = PHEP(4,IDX) | |
4455 | IF ((ICOLOR(2,IDX).EQ.0).OR.(IDHEP(IDX).EQ.21)) THEN | |
4456 | ISTX = ABS(ISPTN)/10 | |
4457 | IMO = ABS(ISPTN)-10*ISTX | |
4458 | IF ((IDHEP(IDX).EQ.21).OR. | |
4459 | & (ABS(IPHIST(1,IDX)).GE.100)) THEN | |
4460 | ISPTN = -(60+IMO) | |
4461 | ELSE | |
4462 | ISPTN = -(50+IMO) | |
4463 | ENDIF | |
4464 | ENDIF | |
4465 | IF (ISPTN.EQ.-21) NPVAL = NPVAL+1 | |
4466 | IF (ISPTN.EQ.-22) NTVAL = NTVAL+1 | |
4467 | IF (MODE.LT.0) THEN | |
4468 | CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN, | |
4469 | & PX,PY,PZ,PE,0,0,0) | |
4470 | ELSE | |
4471 | CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP, | |
4472 | & PPX,PPY,PPZ,PPE) | |
4473 | CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN, | |
4474 | & PPX,PPY,PPZ,PPE,0,0,0) | |
4475 | ENDIF | |
4476 | IHIST(1,NHKK) = IPHIST(1,IDX) | |
4477 | IHIST(2,NHKK) = 0 | |
4478 | DO 20 KK=1,4 | |
4479 | VHKK(KK,NHKK) = VHKK(KK,M2PTN) | |
4480 | WHKK(KK,NHKK) = WHKK(KK,M1PTN) | |
4481 | 20 CONTINUE | |
4482 | VHKK(4,NHKK)= VHKK(3,M2PTN)/BLAB-VHKK(3,M1PTN)/BGLAB | |
4483 | WHKK(4,NHKK)= -WHKK(3,M1PTN)/BLAB+WHKK(3,M2PTN)/BGLAB | |
4484 | 17 CONTINUE | |
4485 | ENDIF | |
4486 | * parton at chain end | |
4487 | PX = PHEP(1,IDX2) | |
4488 | PY = PHEP(2,IDX2) | |
4489 | PZ = PHEP(3,IDX2) | |
4490 | PE = PHEP(4,IDX2) | |
4491 | * flag only partons coming from Pomeron with 41/42 | |
4492 | C IF ((IPOM2.NE.0).OR.(NPOS(4,I).GE.4)) THEN | |
4493 | IF (IPOM2.NE.0) THEN | |
4494 | ISTX = ABS(ISPTN2)/10 | |
4495 | IMO = ABS(ISPTN2)-10*ISTX | |
4496 | ISPTN2 = -(40+IMO) | |
4497 | ELSE | |
4498 | IF ((ICOLOR(2,IDX2).EQ.0).OR.(IDHEP(IDX2).EQ.21)) THEN | |
4499 | ISTX = ABS(ISPTN2)/10 | |
4500 | IMO = ABS(ISPTN2)-10*ISTX | |
4501 | IF ((IDHEP(IDX2).EQ.21).OR. | |
4502 | & (ABS(IPHIST(1,IDX2)).GE.100)) THEN | |
4503 | ISPTN2 = -(60+IMO) | |
4504 | ELSE | |
4505 | ISPTN2 = -(50+IMO) | |
4506 | ENDIF | |
4507 | ENDIF | |
4508 | ENDIF | |
4509 | IF (ISPTN2.EQ.-21) NPVAL = NPVAL+1 | |
4510 | IF (ISPTN2.EQ.-22) NTVAL = NTVAL+1 | |
4511 | IF (MODE.LT.0) THEN | |
4512 | CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2, | |
4513 | & PX,PY,PZ,PE,0,0,0) | |
4514 | ELSE | |
4515 | CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP, | |
4516 | & PPX,PPY,PPZ,PPE) | |
4517 | CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2, | |
4518 | & PPX,PPY,PPZ,PPE,0,0,0) | |
4519 | ENDIF | |
4520 | IHIST(1,NHKK) = IPHIST(1,IDX2) | |
4521 | IHIST(2,NHKK) = 0 | |
4522 | DO 21 KK=1,4 | |
4523 | VHKK(KK,NHKK) = VHKK(KK,M2PTN2) | |
4524 | WHKK(KK,NHKK) = WHKK(KK,M1PTN2) | |
4525 | 21 CONTINUE | |
4526 | VHKK(4,NHKK) = VHKK(3,M2PTN2)/BLAB-VHKK(3,M1PTN2)/BGLAB | |
4527 | WHKK(4,NHKK) = -WHKK(3,M1PTN2)/BLAB+WHKK(3,M2PTN2)/BGLAB | |
4528 | M2STRG = NHKK | |
4529 | * register string | |
4530 | JSTRG = 100*IPROCE+NCODE(I) | |
4531 | PX = PHEP(1,IDXSTG) | |
4532 | PY = PHEP(2,IDXSTG) | |
4533 | PZ = PHEP(3,IDXSTG) | |
4534 | PE = PHEP(4,IDXSTG) | |
4535 | IF (MODE.LT.0) THEN | |
4536 | ISTAT = 70000+IPJE | |
4537 | CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG, | |
4538 | & PX,PY,PZ,PE,0,0,0) | |
4539 | IF (LEMCCK) THEN | |
4540 | PX = -PX | |
4541 | PY = -PY | |
4542 | PZ = -PZ | |
4543 | PE = -PE | |
4544 | CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2) | |
4545 | ENDIF | |
4546 | ELSE | |
4547 | CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP, | |
4548 | & PPX,PPY,PPZ,PPE) | |
4549 | ISTAT = 70000+IPJE | |
4550 | CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG, | |
4551 | & PPX,PPY,PPZ,PPE,0,0,0) | |
4552 | IF (LEMCCK) THEN | |
4553 | PX = -PPX | |
4554 | PY = -PPY | |
4555 | PZ = -PPZ | |
4556 | PE = -PPE | |
4557 | CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2) | |
4558 | ENDIF | |
4559 | ENDIF | |
4560 | NOBAM(NHKK) = 0 | |
4561 | IHIST(1,NHKK) = 0 | |
4562 | IHIST(2,NHKK) = 0 | |
4563 | DO 18 KK=1,4 | |
4564 | VHKK(KK,NHKK) = VHKK(KK,MO2) | |
4565 | WHKK(KK,NHKK) = WHKK(KK,MO1) | |
4566 | 18 CONTINUE | |
4567 | VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB | |
4568 | WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB | |
4569 | ENDIF | |
4570 | 11 CONTINUE | |
4571 | ||
4572 | IF ( ((NPVAL.GT.2).OR.(NTVAL.GT.2)).AND.(LFLIP) ) THEN | |
4573 | NHKK = INHKK | |
4574 | LFLIP = .FALSE. | |
4575 | GOTO 1 | |
4576 | ENDIF | |
4577 | ||
4578 | IF (LEMCCK) THEN | |
4579 | IF (UMO.GT.1.0D5) THEN | |
4580 | CHKLEV = 1.0D0 | |
4581 | ELSE | |
4582 | CHKLEV = TINY1 | |
4583 | ENDIF | |
4584 | CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,1000,IREJ2) | |
4585 | IF (IREJ2.GT.ZERO) CALL PHO_PREVNT(0) | |
4586 | ENDIF | |
4587 | ||
4588 | * internal statistics | |
4589 | * dble-Po statistics. | |
4590 | IF (IPROCE.NE.4) IPOPO = 0 | |
4591 | ||
4592 | INTFLG = IPROCE | |
4593 | IDCHSY = IDCH(MO1) | |
4594 | IF ((IPROCE.GE.1).AND.(IPROCE.LE.8)) THEN | |
4595 | ICEVTG(IDCHSY,IPROCE+2) = ICEVTG(IDCHSY,IPROCE+2)+1 | |
4596 | ELSE | |
4597 | WRITE(LOUT,1000) IPROCE,NEVHKK,MO1 | |
4598 | 1000 FORMAT(1X,'GETFSP: warning! incons. process id. (',I2, | |
4599 | & ') at evt(chain) ',I6,'(',I2,')') | |
4600 | ENDIF | |
4601 | IF (IPROCE.EQ.5) THEN | |
4602 | IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3)) THEN | |
4603 | ICEVTG(IDCHSY,18+IDIFR1) = ICEVTG(IDCHSY,18+IDIFR1)+1 | |
4604 | ELSE | |
4605 | C WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2 | |
4606 | 1001 FORMAT(1X,'GETFSP: warning! incons. diffrac. id. ', | |
4607 | & '(IPROCE,IDIFR1,IDIFR2=',3I3,')') | |
4608 | ENDIF | |
4609 | ELSEIF (IPROCE.EQ.6) THEN | |
4610 | IF ((IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN | |
4611 | ICEVTG(IDCHSY,21+IDIFR2) = ICEVTG(IDCHSY,21+IDIFR2)+1 | |
4612 | ELSE | |
4613 | C WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2 | |
4614 | ENDIF | |
4615 | ELSEIF (IPROCE.EQ.7) THEN | |
4616 | IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3).AND. | |
4617 | & (IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN | |
4618 | IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.1)) | |
4619 | & ICEVTG(IDCHSY,25) = ICEVTG(IDCHSY,25)+1 | |
4620 | IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.2)) | |
4621 | & ICEVTG(IDCHSY,26) = ICEVTG(IDCHSY,26)+1 | |
4622 | IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.2)) | |
4623 | & ICEVTG(IDCHSY,27) = ICEVTG(IDCHSY,27)+1 | |
4624 | IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.1)) | |
4625 | & ICEVTG(IDCHSY,28) = ICEVTG(IDCHSY,28)+1 | |
4626 | ELSE | |
4627 | WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2 | |
4628 | ENDIF | |
4629 | ENDIF | |
4630 | IF ((IDIFR1+IDIFR2.EQ.0).AND.(KHDIR.GE.1).AND.(KHDIR.LE.3)) | |
4631 | & THEN | |
4632 | ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1 | |
4633 | ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1 | |
4634 | ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1 | |
4635 | ENDIF | |
4636 | ICEVTG(IDCHSY,14) = ICEVTG(IDCHSY,14)+KSPOM | |
4637 | ICEVTG(IDCHSY,15) = ICEVTG(IDCHSY,15)+KHPOM | |
4638 | ICEVTG(IDCHSY,16) = ICEVTG(IDCHSY,16)+KSREG | |
4639 | ICEVTG(IDCHSY,17) = ICEVTG(IDCHSY,17)+(KSTRG+KHTRG) | |
4640 | ICEVTG(IDCHSY,18) = ICEVTG(IDCHSY,18)+(KSLOO+KHLOO) | |
4641 | ||
4642 | RETURN | |
4643 | ||
4644 | 9999 CONTINUE | |
4645 | IREJ = 1 | |
4646 | RETURN | |
4647 | END | |
4648 | ||
4649 | *$ CREATE DT_PHOINI.FOR | |
4650 | *COPY DT_PHOINI | |
4651 | * | |
4652 | *===phoini=============================================================* | |
4653 | * | |
4654 | SUBROUTINE DT_PHOINI | |
4655 | ||
4656 | ************************************************************************ | |
4657 | * Initialization PHOJET-event generator for nucleon-nucleon interact. * | |
4658 | * This version dated 16.11.95 is written by S. Roesler * | |
4659 | * * | |
4660 | * Last change 27.12.2006 by S. Roesler. * | |
4661 | ************************************************************************ | |
4662 | ||
4663 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
4664 | SAVE | |
4665 | PARAMETER ( LINP = 10 , | |
4666 | & LOUT = 6 , | |
4667 | & LDAT = 9 ) | |
4668 | PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0) | |
4669 | ||
4670 | * nucleon-nucleon event-generator | |
4671 | CHARACTER*8 CMODEL | |
4672 | LOGICAL LPHOIN | |
4673 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
4674 | * particle properties (BAMJET index convention) | |
4675 | CHARACTER*8 ANAME | |
4676 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
4677 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
4678 | * Lorentz-parameters of the current interaction | |
4679 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
4680 | & UMO,PPCM,EPROJ,PPROJ | |
4681 | * properties of interacting particles | |
4682 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
4683 | * properties of photon/lepton projectiles | |
4684 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC | |
4685 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
4686 | * emulsion treatment | |
4687 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
4688 | & NCOMPO,IEMUL | |
4689 | * VDM parameter for photon-nucleus interactions | |
4690 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
4691 | * nuclear potential | |
4692 | LOGICAL LFERMI | |
4693 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, | |
4694 | & EBINDP(2),EBINDN(2),EPOT(2,210), | |
4695 | & ETACOU(2),ICOUL,LFERMI | |
4696 | * Glauber formalism: flags and parameters for statistics | |
4697 | LOGICAL LPROD | |
4698 | CHARACTER*8 CGLB | |
4699 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD | |
4700 | * | |
4701 | * parameters for cascade calculations: | |
4702 | * maximum mumber of PDF's which can be defined in phojet (limited | |
4703 | * by the dimension of ipdfs in pho_setpdf) | |
4704 | PARAMETER (MAXPDF = 20) | |
4705 | * PDF parametrization and number of set for the first 30 hadrons in | |
4706 | * the bamjet-code list | |
4707 | * negative numbers mean that the PDF is set in phojet, | |
4708 | * zero stands for "not a hadron" | |
4709 | DIMENSION IPARPD(30),ISETPD(30) | |
4710 | * PDF parametrization | |
4711 | DATA IPARPD / | |
4712 | & -5,-5, 0, 0, 0, 0,-5,-5,-5, 0, 0, 5,-5,-5, 5, 5, 5, 5, 5, 5, | |
4713 | & 5, 5,-5, 5, 5, 0, 0, 0, 0, 0/ | |
4714 | * number of set | |
4715 | DATA ISETPD / | |
4716 | & -6,-6, 0, 0, 0, 0,-3,-6,-6, 0, 0, 2,-2,-2, 2, 2, 6, 6, 2, 6, | |
4717 | & 6, 6,-2, 2, 2, 0, 0, 0, 0, 0/ | |
4718 | ||
4719 | **PHOJET105a | |
4720 | C COMMON /GLOCMS/ XECM,XPCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2) | |
4721 | C PARAMETER ( MAXPRO = 16 ) | |
4722 | C PARAMETER ( MAXTAB = 20 ) | |
4723 | C COMMON /HAXSEC/ XSECTA(4,-1:MAXPRO,4,MAXTAB),XSECT(6,-1:MAXPRO), | |
4724 | C & MXSECT(0:4,-1:MAXPRO,4),ECMSH(4,MAXTAB),ISTTAB | |
4725 | C CHARACTER*8 MDLNA | |
4726 | C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100) | |
4727 | C COMMON /PROCES/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15) | |
4728 | **PHOJET110 | |
4729 | C global event kinematics and particle IDs | |
4730 | INTEGER IFPAP,IFPAB | |
4731 | DOUBLE PRECISION ECM,PCM,PMASS,PVIRT | |
4732 | COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2) | |
4733 | C hard cross sections and MC selection weights | |
4734 | INTEGER Max_pro_2 | |
4735 | PARAMETER ( Max_pro_2 = 16 ) | |
4736 | INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried, | |
4737 | & MH_acc_1,MH_acc_2 | |
4738 | DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last | |
4739 | COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2), | |
4740 | & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2), | |
4741 | & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last, | |
4742 | & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4), | |
4743 | & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4) | |
4744 | C model switches and parameters | |
4745 | CHARACTER*8 MDLNA | |
4746 | INTEGER ISWMDL,IPAMDL | |
4747 | DOUBLE PRECISION PARMDL | |
4748 | COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400) | |
4749 | C general process information | |
4750 | INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON | |
4751 | COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4) | |
4752 | ** | |
4753 | DIMENSION PP(4),PT(4) | |
4754 | ||
4755 | LOGICAL LSTART | |
4756 | DATA LSTART /.TRUE./ | |
4757 | ||
4758 | IJP = IJPROJ | |
4759 | IJT = IJTARG | |
4760 | Q2 = VIRT | |
4761 | * lepton-projectiles: initialize real photon instead | |
4762 | IF ((IJP.EQ.3).OR.(IJP.EQ.4).OR.(IJP.EQ.10).OR.(IJP.EQ.11)) THEN | |
4763 | IJP = 7 | |
4764 | Q2 = ZERO | |
4765 | ENDIF | |
4766 | IF (LPHOIN) CALL PHO_INIT(-1,LOUT,IDUM) | |
4767 | * switch Reggeon off | |
4768 | C IPAMDL(3)= 0 | |
4769 | IF (IP.EQ.1) THEN | |
4770 | IFPAP(1) = IDT_IPDGHA(IJP) | |
4771 | IFPAB(1) = IJP | |
4772 | ELSE | |
4773 | IFPAP(1) = 2212 | |
4774 | IFPAB(1) = IDT_ICIHAD(IFPAP(1)) | |
4775 | ENDIF | |
4776 | PMASS(1) = AAM(IFPAB(1))-SQRT(Q2) | |
4777 | PVIRT(1) = PMASS(1)**2 | |
4778 | IF (IT.EQ.1) THEN | |
4779 | IFPAP(2) = IDT_IPDGHA(IJT) | |
4780 | IFPAB(2) = IJT | |
4781 | ELSE | |
4782 | IFPAP(2) = 2212 | |
4783 | IFPAB(2) = IDT_ICIHAD(IFPAP(2)) | |
4784 | ENDIF | |
4785 | PMASS(2) = AAM(IFPAB(2)) | |
4786 | PVIRT(2) = ZERO | |
4787 | DO 1 K=1,4 | |
4788 | PP(K) = ZERO | |
4789 | PT(K) = ZERO | |
4790 | 1 CONTINUE | |
4791 | * get max. possible momenta of incoming particles to be used for PHOJET ini. | |
4792 | PPF = ZERO | |
4793 | PTF = ZERO | |
4794 | SCPF= 1.5D0 | |
4795 | IF (UMO.GE.1.E5) THEN | |
4796 | SCPF= 5.0D0 | |
4797 | ENDIF | |
4798 | IF (NCOMPO.GT.0) THEN | |
4799 | DO 2 I=1,NCOMPO | |
4800 | IF (IT.GT.1) THEN | |
4801 | CALL DT_NCLPOT(IEMUCH(I),IEMUMA(I),ITZ,IT,ZERO,ZERO,0) | |
4802 | ELSE | |
4803 | CALL DT_NCLPOT(IPZ,IP,IEMUCH(I),IEMUMA(I),ZERO,ZERO,0) | |
4804 | ENDIF | |
4805 | PPFTMP = MAX(PFERMP(1),PFERMN(1)) | |
4806 | PTFTMP = MAX(PFERMP(2),PFERMN(2)) | |
4807 | IF (PPFTMP.GT.PPF) PPF = PPFTMP | |
4808 | IF (PTFTMP.GT.PTF) PTF = PTFTMP | |
4809 | 2 CONTINUE | |
4810 | ELSE | |
4811 | CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0) | |
4812 | PPF = MAX(PFERMP(1),PFERMN(1)) | |
4813 | PTF = MAX(PFERMP(2),PFERMN(2)) | |
4814 | ENDIF | |
4815 | PTF = -PTF | |
4816 | PPF = SCPF*PPF | |
4817 | PTF = SCPF*PTF | |
4818 | IF (IJP.EQ.7) THEN | |
4819 | AMP2 = SIGN(PMASS(1)**2,PMASS(1)) | |
4820 | PP(3) = PPCM | |
4821 | PP(4) = SQRT(AMP2+PP(3)**2) | |
4822 | ELSE | |
4823 | EPF = SQRT(PPF**2+PMASS(1)**2) | |
4824 | CALL DT_LTNUC(PPF,EPF,PP(3),PP(4),2) | |
4825 | ENDIF | |
4826 | ETF = SQRT(PTF**2+PMASS(2)**2) | |
4827 | CALL DT_LTNUC(PTF,ETF,PT(3),PT(4),3) | |
4828 | ECMINI = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2- | |
4829 | & (PP(2)+PT(2))**2-(PP(3)+PT(3))**2) | |
4830 | IF (LSTART) THEN | |
4831 | WRITE(LOUT,1001) IP,IPZ,SCPF,PPF,PP | |
4832 | 1001 FORMAT( | |
4833 | & ' DT_PHOINI: PHOJET initialized for projectile A,Z = ', | |
4834 | & I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3) | |
4835 | IF (NCOMPO.GT.0) THEN | |
4836 | WRITE(LOUT,1002) SCPF,PTF,PT | |
4837 | ELSE | |
4838 | WRITE(LOUT,1003) IT,ITZ,SCPF,PTF,PT | |
4839 | ENDIF | |
4840 | 1002 FORMAT( | |
4841 | & ' DT_PHOINI: PHOJET initialized for target emulsion ', | |
4842 | & /,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3) | |
4843 | 1003 FORMAT( | |
4844 | & ' DT_PHOINI: PHOJET initialized for target A,Z = ', | |
4845 | & I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3) | |
4846 | WRITE(LOUT,1004) ECMINI | |
4847 | 1004 FORMAT(' E_cm = ',E10.3) | |
4848 | IF (IJP.EQ.8) WRITE(LOUT,1005) | |
4849 | 1005 FORMAT( | |
4850 | & ' DT_PHOINI: warning! proton parameters used for neutron', | |
4851 | & ' projectile') | |
4852 | LSTART = .FALSE. | |
4853 | ENDIF | |
4854 | * switch off new diffractive cross sections at low energies for nuclei | |
4855 | * (temporary solution) | |
4856 | IF ((ISWMDL(30).NE.0).AND.((IP.GT.1).OR.(IT.GT.1))) THEN | |
4857 | WRITE(LOUT,'(1X,A)') | |
4858 | & ' DT_PHOINI: model-switch 30 for nuclei re-set !' | |
4859 | CALL PHO_SETMDL(30,0,1) | |
4860 | ENDIF | |
4861 | * | |
4862 | C IF (IJP.EQ.7) THEN | |
4863 | C AMP2 = SIGN(PMASS(1)**2,PMASS(1)) | |
4864 | C PP(3) = PPCM | |
4865 | C PP(4) = SQRT(AMP2+PP(3)**2) | |
4866 | C ELSE | |
4867 | C PFERMX = ZERO | |
4868 | C IF (IP.GT.1) PFERMX = 0.5D0 | |
4869 | C EFERMX = SQRT(PFERMX**2+PMASS(1)**2) | |
4870 | C CALL DT_LTNUC(PFERMX,EFERMX,PP(3),PP(4),2) | |
4871 | C ENDIF | |
4872 | C PFERMX = ZERO | |
4873 | C IF ((IT.GT.1).OR.(NCOMPO.GT.0)) PFERMX = -0.5D0 | |
4874 | C EFERMX = SQRT(PFERMX**2+PMASS(2)**2) | |
4875 | C CALL DT_LTNUC(PFERMX,EFERMX,PT(3),PT(4),3) | |
4876 | **sr 26.10.96 | |
4877 | ISAV = IPAMDL(13) | |
4878 | IF ((ISHAD(2).EQ.1).AND. | |
4879 | & ((IJPROJ.EQ. 7).OR.(IJPROJ.EQ.3).OR.(IJPROJ.EQ.4).OR. | |
4880 | & (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11))) IPAMDL(13) = 1 | |
4881 | ** | |
4882 | CALL PHO_EVENT(-1,PP,PT,SIGMAX,IREJ1) | |
4883 | **sr 26.10.96 | |
4884 | IPAMDL(13) = ISAV | |
4885 | ** | |
4886 | * | |
4887 | * patch for cascade calculations: | |
4888 | * define parton distribution functions for other hadrons, i.e. other | |
4889 | * then defined already in phojet | |
4890 | IF (IOGLB.EQ.100) THEN | |
4891 | WRITE(LOUT,1006) | |
4892 | 1006 FORMAT(/,1X,'PHOINI: additional parton distribution functions', | |
4893 | & ' assiged (ID,IPAR,ISET)',/) | |
4894 | NPDF = 0 | |
4895 | DO 3 I=1,30 | |
4896 | IF (IPARPD(I).NE.0) THEN | |
4897 | NPDF = NPDF+1 | |
4898 | IF (NPDF.GT.MAXPDF) STOP ' PHOINI: npdf > maxpdf !' | |
4899 | IF ((IPARPD(I).GT.0).AND.(ISETPD(I).GT.0)) THEN | |
4900 | IDPDG = IDT_IPDGHA(I) | |
4901 | IPAR = IPARPD(I) | |
4902 | ISET = ISETPD(I) | |
4903 | WRITE(LOUT,'(13X,A8,3I6)') ANAME(I),IDPDG,IPAR,ISET | |
4904 | CALL PHO_SETPDF(IDPDG,IDUM,IPAR,ISET,0,0,-1) | |
4905 | ENDIF | |
4906 | ENDIF | |
4907 | 3 CONTINUE | |
4908 | ENDIF | |
4909 | ||
4910 | C CALL PHO_PHIST(-1,SIGMAX) | |
4911 | IF (IREJ1.NE.0) THEN | |
4912 | WRITE(LOUT,1000) | |
4913 | 1000 FORMAT(1X,'PHOINI: PHOJET event-initialization failed!') | |
4914 | STOP | |
4915 | ENDIF | |
4916 | ||
4917 | RETURN | |
4918 | END | |
4919 | ||
4920 | *$ CREATE DT_EVENTD.FOR | |
4921 | *COPY DT_EVENTD | |
4922 | * | |
4923 | *===eventd=============================================================* | |
4924 | * | |
4925 | SUBROUTINE DT_EVENTD(IREJ) | |
4926 | ||
4927 | ************************************************************************ | |
4928 | * Quasi-elastic neutrino nucleus scattering. * | |
4929 | * This version dated 29.04.00 is written by S. Roesler. * | |
4930 | ************************************************************************ | |
4931 | ||
4932 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
4933 | SAVE | |
4934 | PARAMETER ( LINP = 10 , | |
4935 | & LOUT = 6 , | |
4936 | & LDAT = 9 ) | |
4937 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY5=1.0D-5) | |
4938 | PARAMETER (SQTINF=1.0D+15) | |
4939 | ||
4940 | LOGICAL LFIRST | |
4941 | ||
4942 | * event history | |
4943 | PARAMETER (NMXHKK=200000) | |
4944 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
4945 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
4946 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
4947 | * extended event history | |
4948 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
4949 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
4950 | & IHIST(2,NMXHKK) | |
4951 | * flags for input different options | |
4952 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
4953 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
4954 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
4955 | PARAMETER (MAXLND=4000) | |
4956 | COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5) | |
4957 | * properties of interacting particles | |
4958 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
4959 | * Lorentz-parameters of the current interaction | |
4960 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
4961 | & UMO,PPCM,EPROJ,PPROJ | |
4962 | * nuclear potential | |
4963 | LOGICAL LFERMI | |
4964 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, | |
4965 | & EBINDP(2),EBINDN(2),EPOT(2,210), | |
4966 | & ETACOU(2),ICOUL,LFERMI | |
4967 | * steering flags for qel neutrino scattering modules | |
4968 | COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC | |
4969 | COMMON /QNPOL/ POLARX(4),PMODUL | |
4970 | INTEGER PYK | |
4971 | ||
4972 | DATA LFIRST /.TRUE./ | |
4973 | ||
4974 | IREJ = 0 | |
4975 | ||
4976 | IF (LFIRST) THEN | |
4977 | LFIRST = .FALSE. | |
4978 | CALL DT_MASS_INI | |
4979 | ENDIF | |
4980 | ||
4981 | * JETSET parameter | |
4982 | CALL DT_INITJS(0) | |
4983 | ||
4984 | * interacting target nucleon | |
4985 | LTYP = NEUTYP | |
4986 | IF (NEUDEC.LE.9) THEN | |
4987 | IF ((LTYP.EQ.1).OR.(LTYP.EQ.3).OR.(LTYP.EQ.5)) THEN | |
4988 | NUCTYP = 2112 | |
4989 | NUCTOP = 2 | |
4990 | ELSE | |
4991 | NUCTYP = 2212 | |
4992 | NUCTOP = 1 | |
4993 | ENDIF | |
4994 | ELSE | |
4995 | RTYP = DT_RNDM(RTYP) | |
4996 | ZFRAC = DBLE(ITZ)/DBLE(IT) | |
4997 | IF (RTYP.LE.ZFRAC) THEN | |
4998 | NUCTYP = 2212 | |
4999 | NUCTOP = 1 | |
5000 | ELSE | |
5001 | NUCTYP = 2112 | |
5002 | NUCTOP = 2 | |
5003 | ENDIF | |
5004 | ENDIF | |
5005 | ||
5006 | * select first nucleon in list with matching id and reset all other | |
5007 | * nucleons which have been marked as "wounded" by ININUC | |
5008 | IFOUND = 0 | |
5009 | DO 1 I=1,NHKK | |
5010 | IF ((IDHKK(I).EQ.NUCTYP).AND.(IFOUND.EQ.0)) THEN | |
5011 | ISTHKK(I) = 12 | |
5012 | IFOUND = 1 | |
5013 | IDX = I | |
5014 | ELSE | |
5015 | IF (ISTHKK(I).EQ.12) ISTHKK(I) = 14 | |
5016 | ENDIF | |
5017 | 1 CONTINUE | |
5018 | IF (IFOUND.EQ.0) | |
5019 | & STOP ' EVENTD: interacting target nucleon not found! ' | |
5020 | ||
5021 | * correct position of proj. lepton: assume position of target nucleon | |
5022 | DO 3 I=1,4 | |
5023 | VHKK(I,1) = VHKK(I,IDX) | |
5024 | WHKK(I,1) = WHKK(I,IDX) | |
5025 | 3 CONTINUE | |
5026 | ||
5027 | * load initial momenta for conservation check | |
5028 | IF (LEMCCK) THEN | |
5029 | CALL DT_EVTEMC(ZERO,ZERO,PPROJ,EPROJ,1,IDUM,IDUM) | |
5030 | CALL DT_EVTEMC(PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),PHKK(4,IDX), | |
5031 | & 2,IDUM,IDUM) | |
5032 | ENDIF | |
5033 | ||
5034 | * quasi-elastic scattering | |
5035 | IF (NEUDEC.LT.9) THEN | |
5036 | CALL DT_QEL_POL(EPROJ,LTYP,PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX), | |
5037 | & PHKK(4,IDX),PHKK(5,IDX)) | |
5038 | * CC event on p or n | |
5039 | ELSEIF (NEUDEC.EQ.10) THEN | |
5040 | CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,1,PHKK(1,IDX),PHKK(2,IDX), | |
5041 | & PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX)) | |
5042 | * NC event on p or n | |
5043 | ELSEIF (NEUDEC.EQ.11) THEN | |
5044 | CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,2,PHKK(1,IDX),PHKK(2,IDX), | |
5045 | & PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX)) | |
5046 | ENDIF | |
5047 | ||
5048 | * get final state particles from Lund-common and write them into HKKEVT | |
5049 | NPOINT(1) = NHKK+1 | |
5050 | NPOINT(4) = NHKK+1 | |
5051 | NLINES = PYK(0,1) | |
5052 | NHKK0 = NHKK+1 | |
5053 | DO 4 I=4,NLINES | |
5054 | IF (K(I,1).EQ.1) THEN | |
5055 | ID = K(I,2) | |
5056 | PX = P(I,1) | |
5057 | PY = P(I,2) | |
5058 | PZ = P(I,3) | |
5059 | PE = P(I,4) | |
5060 | CALL DT_EVTPUT(1,ID,1,IDX,PX,PY,PZ,PE,0,0,0) | |
5061 | IDBJ = IDT_ICIHAD(ID) | |
5062 | EKIN = PHKK(4,NHKK)-PHKK(5,NHKK) | |
5063 | IF ((IDBJ.EQ.1).OR.(IDBJ.EQ.8)) THEN | |
5064 | IF (EKIN.LE.EPOT(2,IDBJ)) ISTHKK(NHKK) = 16 | |
5065 | ENDIF | |
5066 | VHKK(1,NHKK) = VHKK(1,IDX) | |
5067 | VHKK(2,NHKK) = VHKK(2,IDX) | |
5068 | VHKK(3,NHKK) = VHKK(3,IDX) | |
5069 | VHKK(4,NHKK) = VHKK(4,IDX) | |
5070 | C IF (I.EQ.4) THEN | |
5071 | C WHKK(1,NHKK) = POLARX(1) | |
5072 | C WHKK(2,NHKK) = POLARX(2) | |
5073 | C WHKK(3,NHKK) = POLARX(3) | |
5074 | C WHKK(4,NHKK) = POLARX(4) | |
5075 | C ELSE | |
5076 | WHKK(1,NHKK) = WHKK(1,IDX) | |
5077 | WHKK(2,NHKK) = WHKK(2,IDX) | |
5078 | WHKK(3,NHKK) = WHKK(3,IDX) | |
5079 | WHKK(4,NHKK) = WHKK(4,IDX) | |
5080 | C ENDIF | |
5081 | IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM) | |
5082 | ENDIF | |
5083 | 4 CONTINUE | |
5084 | ||
5085 | IF (LEMCCK) THEN | |
5086 | CHKLEV = TINY5 | |
5087 | CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,778,IREJ1) | |
5088 | IF (IREJ1.NE.0) CALL DT_EVTOUT(4) | |
5089 | ENDIF | |
5090 | ||
5091 | * transform momenta into cms (as required for inc etc.) | |
5092 | DO 5 I=NHKK0,NHKK | |
5093 | IF (ISTHKK(I).EQ.1) THEN | |
5094 | CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,3) | |
5095 | PHKK(3,I) = PZ | |
5096 | PHKK(4,I) = PE | |
5097 | ENDIF | |
5098 | 5 CONTINUE | |
5099 | ||
5100 | RETURN | |
5101 | END | |
5102 | ||
5103 | *$ CREATE DT_KKEVNT.FOR | |
5104 | *COPY DT_KKEVNT | |
5105 | * | |
5106 | *===kkevnt=============================================================* | |
5107 | * | |
5108 | SUBROUTINE DT_KKEVNT(KKMAT,IREJ) | |
5109 | ||
5110 | ************************************************************************ | |
5111 | * Treatment of complete nucleus-nucleus or hadron-nucleus scattering * | |
5112 | * without nuclear effects (one event). * | |
5113 | * This subroutine is an update of the previous version (KKEVT) written * | |
5114 | * by J. Ranft/ H.-J. Moehring. * | |
5115 | * This version dated 20.04.95 is written by S. Roesler * | |
5116 | ************************************************************************ | |
5117 | ||
5118 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
5119 | SAVE | |
5120 | PARAMETER ( LINP = 10 , | |
5121 | & LOUT = 6 , | |
5122 | & LDAT = 9 ) | |
5123 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10) | |
5124 | ||
5125 | PARAMETER ( MAXNCL = 260, | |
5126 | & MAXVQU = MAXNCL, | |
5127 | & MAXSQU = 20*MAXVQU, | |
5128 | & MAXINT = MAXVQU+MAXSQU) | |
5129 | * event history | |
5130 | PARAMETER (NMXHKK=200000) | |
5131 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
5132 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
5133 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
5134 | * extended event history | |
5135 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
5136 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
5137 | & IHIST(2,NMXHKK) | |
5138 | * flags for input different options | |
5139 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
5140 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
5141 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
5142 | * rejection counter | |
5143 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
5144 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
5145 | & IREXCI(3),IRDIFF(2),IRINC | |
5146 | * statistics | |
5147 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
5148 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
5149 | & ICEVTG(8,0:30) | |
5150 | * properties of interacting particles | |
5151 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
5152 | * Lorentz-parameters of the current interaction | |
5153 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
5154 | & UMO,PPCM,EPROJ,PPROJ | |
5155 | * flags for diffractive interactions (DTUNUC 1.x) | |
5156 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF | |
5157 | * interface HADRIN-DPM | |
5158 | COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA | |
5159 | * nucleon-nucleon event-generator | |
5160 | CHARACTER*8 CMODEL | |
5161 | LOGICAL LPHOIN | |
5162 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
5163 | * coordinates of nucleons | |
5164 | COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL) | |
5165 | * interface between Glauber formalism and DPM | |
5166 | COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL), | |
5167 | & INTER1(MAXINT),INTER2(MAXINT) | |
5168 | * Glauber formalism: collision properties | |
5169 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, | |
5170 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC | |
5171 | * central particle production, impact parameter biasing | |
5172 | COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR | |
5173 | **temporary | |
5174 | * statistics: Glauber-formalism | |
5175 | COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB | |
5176 | ** | |
5177 | ||
5178 | DATA NEVOLD,IPOLD,ITOLD,JJPOLD,EPROLD /4*0,0.0D0/ | |
5179 | ||
5180 | IREJ = 0 | |
5181 | ICREQU = ICREQU+1 | |
5182 | NC = 0 | |
5183 | ||
5184 | 1 CONTINUE | |
5185 | ICSAMP = ICSAMP+1 | |
5186 | NC = NC+1 | |
5187 | IF (MOD(NC,10).EQ.0) THEN | |
5188 | WRITE(LOUT,1000) NEVHKK | |
5189 | 1000 FORMAT(1X,'KKEVNT: event ',I8,' rejected!') | |
5190 | GOTO 9999 | |
5191 | ENDIF | |
5192 | ||
5193 | * initialize DTEVT1/DTEVT2 | |
5194 | CALL DT_EVTINI | |
5195 | ||
5196 | * We need the following only in order to sample nucleon coordinates. | |
5197 | * However we don't have parameters (cross sections, slope etc.) | |
5198 | * for neutrinos available. Therefore switch projectile to proton | |
5199 | * in this case. | |
5200 | IF (MCGENE.EQ.4) THEN | |
5201 | JJPROJ = 1 | |
5202 | ELSE | |
5203 | JJPROJ = IJPROJ | |
5204 | ENDIF | |
5205 | ||
5206 | 10 CONTINUE | |
5207 | IF ( (NEVHKK.NE.NEVOLD).OR.(ICENTR.GT.0).OR. | |
5208 | * make sure that Glauber-formalism is called each time the interaction | |
5209 | * configuration changed | |
5210 | & (IP.NE.IPOLD).OR.(IT.NE.ITOLD).OR.(JJPROJ.NE.JJPOLD).OR. | |
5211 | & (ABS(EPROJ-EPROLD).GT.TINY10) ) THEN | |
5212 | * sample number of nucleon-nucleon coll. according to Glauber-form. | |
5213 | CALL DT_GLAUBE(IP,IT,JJPROJ,BIMPAC,NN,NP,NT,JSSH,JTSH,KKMAT) | |
5214 | NWTSAM = NN | |
5215 | NWASAM = NP | |
5216 | NWBSAM = NT | |
5217 | NEVOLD = NEVHKK | |
5218 | IPOLD = IP | |
5219 | ITOLD = IT | |
5220 | JJPOLD = JJPROJ | |
5221 | EPROLD = EPROJ | |
5222 | ENDIF | |
5223 | ||
5224 | * force diffractive particle production in h-K interactions | |
5225 | IF (((ABS(ISINGD).GT.1).OR.(ABS(IDOUBD).GT.1)).AND. | |
5226 | & (IP.EQ.1).AND.(NN.NE.1)) THEN | |
5227 | NEVOLD = 0 | |
5228 | GOTO 10 | |
5229 | ENDIF | |
5230 | ||
5231 | * check number of involved proj. nucl. (NP) if central prod.is requested | |
5232 | IF (ICENTR.GT.0) THEN | |
5233 | CALL DT_CHKCEN(IP,IT,NP,NT,IBACK) | |
5234 | IF (IBACK.GT.0) GOTO 10 | |
5235 | ENDIF | |
5236 | ||
5237 | * get initial nucleon-configuration in projectile and target | |
5238 | * rest-system (including Fermi-momenta if requested) | |
5239 | CALL DT_ININUC(IJPROJ,IP,IPZ,PKOO,JSSH,1) | |
5240 | MODE = 2 | |
5241 | IF (EPROJ.LE.EHADTH) MODE = 3 | |
5242 | CALL DT_ININUC(IJTARG,IT,ITZ,TKOO,JTSH,MODE) | |
5243 | ||
5244 | IF ((MCGENE.NE.3).AND.(MCGENE.NE.4)) THEN | |
5245 | ||
5246 | * activate HADRIN at low energies (implemented for h-N scattering only) | |
5247 | IF (EPROJ.LE.EHADHI) THEN | |
5248 | IF (EHADTH.LT.ZERO) THEN | |
5249 | * smooth transition btwn. DPM and HADRIN | |
5250 | FRAC = (EPROJ-EHADLO)/(EHADHI-EHADLO) | |
5251 | RR = DT_RNDM(FRAC) | |
5252 | IF (RR.GT.FRAC) THEN | |
5253 | IF (IP.EQ.1) THEN | |
5254 | CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1) | |
5255 | IF (IREJ1.GT.0) GOTO 1 | |
5256 | RETURN | |
5257 | ELSE | |
5258 | WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH | |
5259 | ENDIF | |
5260 | ENDIF | |
5261 | ELSE | |
5262 | * fixed threshold for onset of production via HADRIN | |
5263 | IF (EPROJ.LE.EHADTH) THEN | |
5264 | IF (IP.EQ.1) THEN | |
5265 | CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1) | |
5266 | IF (IREJ1.GT.0) GOTO 1 | |
5267 | RETURN | |
5268 | ELSE | |
5269 | WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH | |
5270 | ENDIF | |
5271 | ENDIF | |
5272 | ENDIF | |
5273 | ENDIF | |
5274 | 1001 FORMAT(1X,'KKEVNT: warning! interaction of proj. (m=', | |
5275 | & I3,') with target (m=',I3,')',/,11X, | |
5276 | & 'at E_lab=',F5.1,'GeV (threshold-energy: ',F3.1, | |
5277 | & 'GeV) cannot be handled') | |
5278 | ||
5279 | * sampling of momentum-x fractions & flavors of chain ends | |
5280 | CALL DT_SPLPTN(NN) | |
5281 | ||
5282 | * Lorentz-transformation of wounded nucleons into nucl.-nucl. cms | |
5283 | CALL DT_NUC2CM | |
5284 | ||
5285 | * collect momenta of chain ends and put them into DTEVT1 | |
5286 | CALL DT_GETPTN(IP,NN,NCSY,IREJ1) | |
5287 | IF (IREJ1.NE.0) GOTO 1 | |
5288 | ||
5289 | ENDIF | |
5290 | ||
5291 | * handle chains including fragmentation (two-chain approximation) | |
5292 | IF (MCGENE.EQ.1) THEN | |
5293 | * two-chain approximation | |
5294 | CALL DT_EVENTA(IJPROJ,IP,IT,NCSY,IREJ1) | |
5295 | IF (IREJ1.NE.0) THEN | |
5296 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKEVNT' | |
5297 | GOTO 1 | |
5298 | ENDIF | |
5299 | ELSEIF (MCGENE.EQ.2) THEN | |
5300 | * multiple-Po exchange including minijets | |
5301 | CALL DT_EVENTB(NCSY,IREJ1) | |
5302 | IF (IREJ1.NE.0) THEN | |
5303 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKEVNT' | |
5304 | GOTO 1 | |
5305 | ENDIF | |
5306 | ELSEIF (MCGENE.EQ.3) THEN | |
5307 | STOP ' This version does not contain LEPTO !' | |
5308 | ELSEIF (MCGENE.EQ.4) THEN | |
5309 | * quasi-elastic neutrino scattering | |
5310 | CALL DT_EVENTD(IREJ1) | |
5311 | IF (IREJ1.NE.0) THEN | |
5312 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 4 in KKEVNT' | |
5313 | GOTO 1 | |
5314 | ENDIF | |
5315 | ELSE | |
5316 | WRITE(LOUT,1002) MCGENE | |
5317 | 1002 FORMAT(1X,'KKEVNT: warning! event-generator',I4, | |
5318 | & ' not available - program stopped') | |
5319 | STOP | |
5320 | ENDIF | |
5321 | ||
5322 | RETURN | |
5323 | ||
5324 | 9999 CONTINUE | |
5325 | IREJ = 1 | |
5326 | RETURN | |
5327 | END | |
5328 | ||
5329 | *$ CREATE DT_CHKCEN.FOR | |
5330 | *COPY DT_CHKCEN | |
5331 | * | |
5332 | *===chkcen=============================================================* | |
5333 | * | |
5334 | SUBROUTINE DT_CHKCEN(IP,IT,NP,NT,IBACK) | |
5335 | ||
5336 | ************************************************************************ | |
5337 | * Check of number of involved projectile nucleons if central production* | |
5338 | * is requested. * | |
5339 | * Adopted from a part of the old KKEVT routine which was written by * | |
5340 | * J. Ranft/H.-J.Moehring. * | |
5341 | * This version dated 13.01.95 is written by S. Roesler * | |
5342 | ************************************************************************ | |
5343 | ||
5344 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
5345 | SAVE | |
5346 | PARAMETER ( LINP = 10 , | |
5347 | & LOUT = 6 , | |
5348 | & LDAT = 9 ) | |
5349 | ||
5350 | * statistics | |
5351 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
5352 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
5353 | & ICEVTG(8,0:30) | |
5354 | * central particle production, impact parameter biasing | |
5355 | COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR | |
5356 | ||
5357 | IBACK = 0 | |
5358 | ||
5359 | * old version | |
5360 | IF (ICENTR.EQ.2) THEN | |
5361 | IF (IP.LT.IT) THEN | |
5362 | IF (IP.LE.8) THEN | |
5363 | IF (NP.LT.IP-1) IBACK = 1 | |
5364 | ELSEIF (IP.LE.16) THEN | |
5365 | IF (NP.LT.IP-2) IBACK = 1 | |
5366 | ELSEIF (IP.LE.32) THEN | |
5367 | IF (NP.LT.IP-3) IBACK = 1 | |
5368 | ELSEIF (IP.GE.33) THEN | |
5369 | IF (NP.LT.IP-5) IBACK = 1 | |
5370 | ENDIF | |
5371 | ELSEIF (IP.EQ.IT) THEN | |
5372 | IF (IP.EQ.32) THEN | |
5373 | IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1 | |
5374 | ELSE | |
5375 | IF (NP.LT.IP-IP/8) IBACK = 1 | |
5376 | ENDIF | |
5377 | ELSEIF (ABS(IP-IT).LT.3) THEN | |
5378 | IF (NP.LT.IP-IP/8) IBACK = 1 | |
5379 | ENDIF | |
5380 | ELSE | |
5381 | * new version (DPMJET, 5.6.99) | |
5382 | IF (IP.LT.IT) THEN | |
5383 | IF (IP.LE.8) THEN | |
5384 | IF (NP.LT.IP-1) IBACK = 1 | |
5385 | ELSEIF (IP.LE.16) THEN | |
5386 | IF (NP.LT.IP-2) IBACK = 1 | |
5387 | ELSEIF (IP.LT.32) THEN | |
5388 | IF (NP.LT.IP-3) IBACK = 1 | |
5389 | ELSEIF (IP.GE.32) THEN | |
5390 | IF (IT.LE.150) THEN | |
5391 | * Example: S-Ag | |
5392 | IF (NP.LT.IP-1) IBACK = 1 | |
5393 | ELSE | |
5394 | * Example: S-Au | |
5395 | IF (NP.LT.IP) IBACK = 1 | |
5396 | ENDIF | |
5397 | ENDIF | |
5398 | ELSEIF (IP.EQ.IT) THEN | |
5399 | * Example: S-S | |
5400 | IF (IP.EQ.32) THEN | |
5401 | IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1 | |
5402 | * Example: Pb-Pb | |
5403 | ELSE | |
5404 | IF (NP.LT.IP-IP/4) IBACK = 1 | |
5405 | ENDIF | |
5406 | ELSEIF (ABS(IP-IT).LT.3) THEN | |
5407 | IF (NP.LT.IP-IP/8) IBACK = 1 | |
5408 | ENDIF | |
5409 | ENDIF | |
5410 | ||
5411 | ICCPRO = ICCPRO+1 | |
5412 | ||
5413 | RETURN | |
5414 | END | |
5415 | ||
5416 | *$ CREATE DT_ININUC.FOR | |
5417 | *COPY DT_ININUC | |
5418 | * | |
5419 | *===ininuc=============================================================* | |
5420 | * | |
5421 | SUBROUTINE DT_ININUC(ID,NMASS,NCH,COORD,JS,IMODE) | |
5422 | ||
5423 | ************************************************************************ | |
5424 | * Samples initial configuration of nucleons in nucleus with mass NMASS * | |
5425 | * including Fermi-momenta (if reqested). * | |
5426 | * ID BAMJET-code for hadrons (instead of nuclei) * | |
5427 | * NMASS mass number of nucleus (number of nucleons) * | |
5428 | * NCH charge of nucleus * | |
5429 | * COORD(3,NMASS) coordinates of nucleons inside nucleus in fm * | |
5430 | * JS(NMASS) > 0 nucleon undergoes nucleon-nucleon interact. * | |
5431 | * IMODE = 1 projectile nucleus * | |
5432 | * = 2 target nucleus * | |
5433 | * = 3 target nucleus (E_lab<E_thr for HADRIN) * | |
5434 | * Adopted from a part of the old KKEVT routine which was written by * | |
5435 | * J. Ranft/H.-J.Moehring. * | |
5436 | * This version dated 13.01.95 is written by S. Roesler * | |
5437 | ************************************************************************ | |
5438 | ||
5439 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
5440 | SAVE | |
5441 | PARAMETER ( LINP = 10 , | |
5442 | & LOUT = 6 , | |
5443 | & LDAT = 9 ) | |
5444 | PARAMETER (FM2MM=1.0D-12) | |
5445 | ||
5446 | PARAMETER ( MAXNCL = 260, | |
5447 | & MAXVQU = MAXNCL, | |
5448 | & MAXSQU = 20*MAXVQU, | |
5449 | & MAXINT = MAXVQU+MAXSQU) | |
5450 | * event history | |
5451 | PARAMETER (NMXHKK=200000) | |
5452 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
5453 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
5454 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
5455 | * extended event history | |
5456 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
5457 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
5458 | & IHIST(2,NMXHKK) | |
5459 | * flags for input different options | |
5460 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
5461 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
5462 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
5463 | * auxiliary common for chain system storage (DTUNUC 1.x) | |
5464 | COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL) | |
5465 | * nuclear potential | |
5466 | LOGICAL LFERMI | |
5467 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, | |
5468 | & EBINDP(2),EBINDN(2),EPOT(2,210), | |
5469 | & ETACOU(2),ICOUL,LFERMI | |
5470 | * properties of photon/lepton projectiles | |
5471 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC | |
5472 | * particle properties (BAMJET index convention) | |
5473 | CHARACTER*8 ANAME | |
5474 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
5475 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
5476 | * Glauber formalism: collision properties | |
5477 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, | |
5478 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC | |
5479 | * flavors of partons (DTUNUC 1.x) | |
5480 | COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU), | |
5481 | & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU), | |
5482 | & IPSQ(MAXSQU),IPSQ2(MAXSQU), | |
5483 | & IPSAQ(MAXSQU),IPSAQ2(MAXSQU), | |
5484 | & ITSQ(MAXSQU),ITSQ2(MAXSQU), | |
5485 | & ITSAQ(MAXSQU),ITSAQ2(MAXSQU), | |
5486 | & KKPROJ(MAXVQU),KKTARG(MAXVQU) | |
5487 | * interface HADRIN-DPM | |
5488 | COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA | |
5489 | ||
5490 | DIMENSION PF(4),PFTOT(4),COORD(3,MAXNCL),JS(MAXNCL) | |
5491 | ||
5492 | * number of neutrons | |
5493 | NNEU = NMASS-NCH | |
5494 | * initializations | |
5495 | NP = 0 | |
5496 | NN = 0 | |
5497 | DO 1 K=1,4 | |
5498 | PFTOT(K) = 0.0D0 | |
5499 | 1 CONTINUE | |
5500 | MODE = IMODE | |
5501 | IF (IMODE.GT.2) MODE = 2 | |
5502 | **sr 29.5. new NPOINT(1)-definition | |
5503 | C IF (IMODE.GE.2) NPOINT(1) = NHKK+1 | |
5504 | ** | |
5505 | NHADRI = 0 | |
5506 | NC = NHKK | |
5507 | ||
5508 | * get initial configuration | |
5509 | DO 2 I=1,NMASS | |
5510 | NHKK = NHKK+1 | |
5511 | IF (JS(I).GT.0) THEN | |
5512 | ISTHKK(NHKK) = 10+MODE | |
5513 | IF (IMODE.EQ.3) THEN | |
5514 | * additional treatment if HADRIN-generator is requested | |
5515 | NHADRI = NHADRI+1 | |
5516 | IF (NHADRI.EQ.1) IDXTA = NHKK | |
5517 | IF (NHADRI.GT.1) ISTHKK(NHKK) = 14 | |
5518 | ENDIF | |
5519 | ELSE | |
5520 | ISTHKK(NHKK) = 12+MODE | |
5521 | ENDIF | |
5522 | IF (NMASS.GE.2) THEN | |
5523 | * treatment for nuclei | |
5524 | FRAC = 1.0D0-DBLE(NCH)/DBLE(NMASS) | |
5525 | RR = DT_RNDM(FRAC) | |
5526 | IF ((RR.LT.FRAC).AND.(NN.LT.NNEU)) THEN | |
5527 | IDX = 8 | |
5528 | NN = NN+1 | |
5529 | ELSEIF ((RR.GE.FRAC).AND.(NP.LT.NCH)) THEN | |
5530 | IDX = 1 | |
5531 | NP = NP+1 | |
5532 | ELSEIF (NN.LT.NNEU) THEN | |
5533 | IDX = 8 | |
5534 | NN = NN+1 | |
5535 | ELSEIF (NP.LT.NCH) THEN | |
5536 | IDX = 1 | |
5537 | NP = NP+1 | |
5538 | ENDIF | |
5539 | IDHKK(NHKK) = IDT_IPDGHA(IDX) | |
5540 | IDBAM(NHKK) = IDX | |
5541 | IF (MODE.EQ.1) THEN | |
5542 | IPOSP(I) = NHKK | |
5543 | KKPROJ(I) = IDX | |
5544 | ELSE | |
5545 | IPOST(I) = NHKK | |
5546 | KKTARG(I) = IDX | |
5547 | ENDIF | |
5548 | IF (IDX.EQ.1) THEN | |
5549 | PFER = PFERMP(MODE) | |
5550 | PBIN = SQRT(2.0D0*EBINDP(MODE)*AAM(1)) | |
5551 | ELSE | |
5552 | PFER = PFERMN(MODE) | |
5553 | PBIN = SQRT(2.0D0*EBINDN(MODE)*AAM(8)) | |
5554 | ENDIF | |
5555 | CALL DT_FER4M(PFER,PBIN,PF(1),PF(2),PF(3),PF(4),IDX) | |
5556 | DO 3 K=1,4 | |
5557 | PFTOT(K) = PFTOT(K)+PF(K) | |
5558 | PHKK(K,NHKK) = PF(K) | |
5559 | 3 CONTINUE | |
5560 | PHKK(5,NHKK) = AAM(IDX) | |
5561 | ELSE | |
5562 | * treatment for hadrons | |
5563 | IDHKK(NHKK) = IDT_IPDGHA(ID) | |
5564 | IDBAM(NHKK) = ID | |
5565 | PHKK(4,NHKK) = AAM(ID) | |
5566 | PHKK(5,NHKK) = AAM(ID) | |
5567 | C* VDM assumption | |
5568 | C IF (IDHKK(NHKK).EQ.22) THEN | |
5569 | C PHKK(4,NHKK) = AAM(33) | |
5570 | C PHKK(5,NHKK) = AAM(33) | |
5571 | C ENDIF | |
5572 | IF (MODE.EQ.1) THEN | |
5573 | IPOSP(I) = NHKK | |
5574 | KKPROJ(I) = ID | |
5575 | PHKK(5,NHKK) = PHKK(5,NHKK)-SQRT(VIRT) | |
5576 | ELSE | |
5577 | IPOST(I) = NHKK | |
5578 | KKTARG(I) = ID | |
5579 | ENDIF | |
5580 | ENDIF | |
5581 | DO 4 K=1,3 | |
5582 | VHKK(K,NHKK) = COORD(K,I)*FM2MM | |
5583 | WHKK(K,NHKK) = COORD(K,I)*FM2MM | |
5584 | 4 CONTINUE | |
5585 | IF (MODE.EQ.2) VHKK(1,NHKK) = VHKK(1,NHKK)+BIMPAC*FM2MM | |
5586 | IF (MODE.EQ.2) WHKK(1,NHKK) = WHKK(1,NHKK)+BIMPAC*FM2MM | |
5587 | VHKK(4,NHKK) = 0.0D0 | |
5588 | WHKK(4,NHKK) = 0.0D0 | |
5589 | 2 CONTINUE | |
5590 | ||
5591 | * balance Fermi-momenta | |
5592 | IF (NMASS.GE.2) THEN | |
5593 | DO 5 I=1,NMASS | |
5594 | NC = NC+1 | |
5595 | DO 6 K=1,3 | |
5596 | PHKK(K,NC) = PHKK(K,NC)-PFTOT(K)/DBLE(NMASS) | |
5597 | 6 CONTINUE | |
5598 | PHKK(4,NC) = SQRT(PHKK(5,NC)**2+PHKK(1,NC)**2+ | |
5599 | & PHKK(2,NC)**2+PHKK(3,NC)**2) | |
5600 | 5 CONTINUE | |
5601 | ENDIF | |
5602 | ||
5603 | RETURN | |
5604 | END | |
5605 | ||
5606 | *$ CREATE DT_FER4M.FOR | |
5607 | *COPY DT_FER4M | |
5608 | * | |
5609 | *===fer4m==============================================================* | |
5610 | * | |
5611 | SUBROUTINE DT_FER4M(PFERM,PBIND,PXT,PYT,PZT,ET,KT) | |
5612 | ||
5613 | ************************************************************************ | |
5614 | * Sampling of nucleon Fermi-momenta from distributions at T=0. * | |
5615 | * processed by S. Roesler, 17.10.95 * | |
5616 | ************************************************************************ | |
5617 | ||
5618 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
5619 | SAVE | |
5620 | PARAMETER ( LINP = 10 , | |
5621 | & LOUT = 6 , | |
5622 | & LDAT = 9 ) | |
5623 | ||
5624 | LOGICAL LSTART | |
5625 | ||
5626 | * particle properties (BAMJET index convention) | |
5627 | CHARACTER*8 ANAME | |
5628 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
5629 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
5630 | * nuclear potential | |
5631 | LOGICAL LFERMI | |
5632 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, | |
5633 | & EBINDP(2),EBINDN(2),EPOT(2,210), | |
5634 | & ETACOU(2),ICOUL,LFERMI | |
5635 | ||
5636 | DATA LSTART /.TRUE./ | |
5637 | ||
5638 | ILOOP = 0 | |
5639 | IF (LFERMI) THEN | |
5640 | IF (LSTART) THEN | |
5641 | WRITE(LOUT,1000) | |
5642 | 1000 FORMAT(/,1X,'FER4M: sampling of Fermi-momenta activated') | |
5643 | LSTART = .FALSE. | |
5644 | ENDIF | |
5645 | 1 CONTINUE | |
5646 | CALL DT_DFERMI(PABS) | |
5647 | PABS = PFERM*PABS | |
5648 | C IF (PABS.GE.PBIND) THEN | |
5649 | C ILOOP = ILOOP+1 | |
5650 | C IF (MOD(ILOOP,500).EQ.0) THEN | |
5651 | C WRITE(LOUT,1001) PABS,PBIND,ILOOP | |
5652 | C1001 FORMAT(1X,'FER4M: Fermi-mom. corr. for binding', | |
5653 | C & ' energy ',2E12.3,I6) | |
5654 | C ENDIF | |
5655 | C GOTO 1 | |
5656 | C ENDIF | |
5657 | CALL DT_DPOLI(POLC,POLS) | |
5658 | CALL DT_DSFECF(SFE,CFE) | |
5659 | CXTA = POLS*CFE | |
5660 | CYTA = POLS*SFE | |
5661 | CZTA = POLC | |
5662 | ET = SQRT(PABS*PABS+AAM(KT)**2) | |
5663 | PXT = CXTA*PABS | |
5664 | PYT = CYTA*PABS | |
5665 | PZT = CZTA*PABS | |
5666 | ELSE | |
5667 | ET = AAM(KT) | |
5668 | PXT = 0.0D0 | |
5669 | PYT = 0.0D0 | |
5670 | PZT = 0.0D0 | |
5671 | ENDIF | |
5672 | ||
5673 | RETURN | |
5674 | END | |
5675 | ||
5676 | *$ CREATE DT_NUC2CM.FOR | |
5677 | *COPY DT_NUC2CM | |
5678 | * | |
5679 | *===nuc2cm=============================================================* | |
5680 | * | |
5681 | SUBROUTINE DT_NUC2CM | |
5682 | ||
5683 | ************************************************************************ | |
5684 | * Lorentz-transformation of all wounded nucleons from Lab. to nucl.- * | |
5685 | * nucl. cms. (This subroutine replaces NUCMOM.) * | |
5686 | * This version dated 15.01.95 is written by S. Roesler * | |
5687 | ************************************************************************ | |
5688 | ||
5689 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
5690 | SAVE | |
5691 | PARAMETER ( LINP = 10 , | |
5692 | & LOUT = 6 , | |
5693 | & LDAT = 9 ) | |
5694 | PARAMETER (ZERO=0.0D0,TINY3=1.0D-3) | |
5695 | ||
5696 | * event history | |
5697 | PARAMETER (NMXHKK=200000) | |
5698 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
5699 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
5700 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
5701 | * extended event history | |
5702 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
5703 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
5704 | & IHIST(2,NMXHKK) | |
5705 | * statistics | |
5706 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
5707 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
5708 | & ICEVTG(8,0:30) | |
5709 | * properties of photon/lepton projectiles | |
5710 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC | |
5711 | * particle properties (BAMJET index convention) | |
5712 | CHARACTER*8 ANAME | |
5713 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
5714 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
5715 | * Glauber formalism: collision properties | |
5716 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, | |
5717 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC | |
5718 | **temporary | |
5719 | * statistics: Glauber-formalism | |
5720 | COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB | |
5721 | ** | |
5722 | ||
5723 | ICWP = 0 | |
5724 | ICWT = 0 | |
5725 | NWTACC = 0 | |
5726 | NWAACC = 0 | |
5727 | NWBACC = 0 | |
5728 | ||
5729 | NPOINT(1) = NHKK+1 | |
5730 | NEND = NHKK | |
5731 | DO 1 I=1,NEND | |
5732 | IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.12)) THEN | |
5733 | IF (ISTHKK(I).EQ.11) NWAACC = NWAACC+1 | |
5734 | IF (ISTHKK(I).EQ.12) NWBACC = NWBACC+1 | |
5735 | MODE = ISTHKK(I)-9 | |
5736 | C IF (IDHKK(I).EQ.22) THEN | |
5737 | C* VDM assumption | |
5738 | C PEIN = AAM(33) | |
5739 | C IDB = 33 | |
5740 | C ELSE | |
5741 | C PEIN = PHKK(4,I) | |
5742 | C IDB = IDBAM(I) | |
5743 | C ENDIF | |
5744 | C CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PEIN, | |
5745 | C & PX,PY,PZ,PE,IDB,MODE) | |
5746 | IF (PHKK(5,I).GT.ZERO) THEN | |
5747 | CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I), | |
5748 | & PX,PY,PZ,PE,IDBAM(I),MODE) | |
5749 | ELSE | |
5750 | PX = PGAMM(1) | |
5751 | PY = PGAMM(2) | |
5752 | PZ = PGAMM(3) | |
5753 | PE = PGAMM(4) | |
5754 | ENDIF | |
5755 | IST = ISTHKK(I)-2 | |
5756 | ID = IDHKK(I) | |
5757 | C* VDM assumption | |
5758 | C IF (ID.EQ.22) ID = 113 | |
5759 | CALL DT_EVTPUT(IST,ID,I,0,PX,PY,PZ,PE,0,0,0) | |
5760 | IF (ISTHKK(I).EQ.11) ICWP = ICWP+1 | |
5761 | IF (ISTHKK(I).EQ.12) ICWT = ICWT+1 | |
5762 | ENDIF | |
5763 | 1 CONTINUE | |
5764 | ||
5765 | NWTACC = MAX(NWAACC,NWBACC) | |
5766 | ICDPR = ICDPR+ICWP | |
5767 | ICDTA = ICDTA+ICWT | |
5768 | **temporary | |
5769 | IF ((ICWP.EQ.0).OR.(ICWT.EQ.0)) THEN | |
5770 | CALL DT_EVTOUT(4) | |
5771 | STOP | |
5772 | ENDIF | |
5773 | ||
5774 | RETURN | |
5775 | END | |
5776 | ||
5777 | *$ CREATE DT_SPLPTN.FOR | |
5778 | *COPY DT_SPLPTN | |
5779 | * | |
5780 | *===splptn=============================================================* | |
5781 | * | |
5782 | SUBROUTINE DT_SPLPTN(NN) | |
5783 | ||
5784 | ************************************************************************ | |
5785 | * SamPLing of ParToN momenta and flavors. * | |
5786 | * This version dated 15.01.95 is written by S. Roesler * | |
5787 | ************************************************************************ | |
5788 | ||
5789 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
5790 | SAVE | |
5791 | PARAMETER ( LINP = 10 , | |
5792 | & LOUT = 6 , | |
5793 | & LDAT = 9 ) | |
5794 | ||
5795 | * Lorentz-parameters of the current interaction | |
5796 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
5797 | & UMO,PPCM,EPROJ,PPROJ | |
5798 | ||
5799 | * sample flavors of sea-quarks | |
5800 | CALL DT_SPLFLA(NN,1) | |
5801 | ||
5802 | * sample x-values of partons at chain ends | |
5803 | ECM = UMO | |
5804 | CALL DT_XKSAMP(NN,ECM) | |
5805 | ||
5806 | * samle flavors | |
5807 | CALL DT_SPLFLA(NN,2) | |
5808 | ||
5809 | RETURN | |
5810 | END | |
5811 | ||
5812 | *$ CREATE DT_SPLFLA.FOR | |
5813 | *COPY DT_SPLFLA | |
5814 | * | |
5815 | *===splfla=============================================================* | |
5816 | * | |
5817 | SUBROUTINE DT_SPLFLA(NN,MODE) | |
5818 | ||
5819 | ************************************************************************ | |
5820 | * SamPLing of FLAvors of partons at chain ends. * | |
5821 | * This subroutine replaces FLKSAA/FLKSAM. * | |
5822 | * NN number of nucleon-nucleon interactions * | |
5823 | * MODE = 1 sea-flavors * | |
5824 | * = 2 valence-flavors * | |
5825 | * Based on the original version written by J. Ranft/H.-J. Moehring. * | |
5826 | * This version dated 16.01.95 is written by S. Roesler * | |
5827 | ************************************************************************ | |
5828 | ||
5829 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
5830 | SAVE | |
5831 | PARAMETER ( LINP = 10 , | |
5832 | & LOUT = 6 , | |
5833 | & LDAT = 9 ) | |
5834 | ||
5835 | PARAMETER ( MAXNCL = 260, | |
5836 | & MAXVQU = MAXNCL, | |
5837 | & MAXSQU = 20*MAXVQU, | |
5838 | & MAXINT = MAXVQU+MAXSQU) | |
5839 | * flavors of partons (DTUNUC 1.x) | |
5840 | COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU), | |
5841 | & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU), | |
5842 | & IPSQ(MAXSQU),IPSQ2(MAXSQU), | |
5843 | & IPSAQ(MAXSQU),IPSAQ2(MAXSQU), | |
5844 | & ITSQ(MAXSQU),ITSQ2(MAXSQU), | |
5845 | & ITSAQ(MAXSQU),ITSAQ2(MAXSQU), | |
5846 | & KKPROJ(MAXVQU),KKTARG(MAXVQU) | |
5847 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) | |
5848 | COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD, | |
5849 | & IXPV,IXPS,IXTV,IXTS, | |
5850 | & INTVV1(MAXVQU),INTVV2(MAXVQU), | |
5851 | & INTSV1(MAXVQU),INTSV2(MAXVQU), | |
5852 | & INTVS1(MAXVQU),INTVS2(MAXVQU), | |
5853 | & INTSS1(MAXSQU),INTSS2(MAXSQU), | |
5854 | & INTDV1(MAXVQU),INTDV2(MAXVQU), | |
5855 | & INTVD1(MAXVQU),INTVD2(MAXVQU), | |
5856 | & INTDS1(MAXSQU),INTDS2(MAXSQU), | |
5857 | & INTSD1(MAXSQU),INTSD2(MAXSQU) | |
5858 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) | |
5859 | COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU), | |
5860 | & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU) | |
5861 | * particle properties (BAMJET index convention) | |
5862 | CHARACTER*8 ANAME | |
5863 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
5864 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
5865 | * various options for treatment of partons (DTUNUC 1.x) | |
5866 | * (chain recombination, Cronin,..) | |
5867 | LOGICAL LCO2CR,LINTPT | |
5868 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, | |
5869 | & LCO2CR,LINTPT | |
5870 | ||
5871 | IF (MODE.EQ.1) THEN | |
5872 | * sea-flavors | |
5873 | DO 1 I=1,NN | |
5874 | IPSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ)) | |
5875 | IPSAQ(I) = -IPSQ(I) | |
5876 | 1 CONTINUE | |
5877 | DO 2 I=1,NN | |
5878 | ITSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ)) | |
5879 | ITSAQ(I)= -ITSQ(I) | |
5880 | 2 CONTINUE | |
5881 | ELSEIF (MODE.EQ.2) THEN | |
5882 | * valence flavors | |
5883 | DO 3 I=1,IXPV | |
5884 | CALL DT_FLAHAD(KKPROJ(IFROVP(I)),IPVQ(I),IPPV1(I),IPPV2(I)) | |
5885 | 3 CONTINUE | |
5886 | DO 4 I=1,IXTV | |
5887 | CALL DT_FLAHAD(KKTARG(IFROVT(I)),ITVQ(I),ITTV1(I),ITTV2(I)) | |
5888 | 4 CONTINUE | |
5889 | ENDIF | |
5890 | ||
5891 | RETURN | |
5892 | END | |
5893 | ||
5894 | *$ CREATE DT_GETPTN.FOR | |
5895 | *COPY DT_GETPTN | |
5896 | * | |
5897 | *===getptn=============================================================* | |
5898 | * | |
5899 | SUBROUTINE DT_GETPTN(IP,NN,NCSY,IREJ) | |
5900 | ||
5901 | ************************************************************************ | |
5902 | * This subroutine collects partons at chain ends from temporary * | |
5903 | * commons and puts them into DTEVT1. * | |
5904 | * This version dated 15.01.95 is written by S. Roesler * | |
5905 | ************************************************************************ | |
5906 | ||
5907 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
5908 | SAVE | |
5909 | PARAMETER ( LINP = 10 , | |
5910 | & LOUT = 6 , | |
5911 | & LDAT = 9 ) | |
5912 | PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0) | |
5913 | ||
5914 | LOGICAL LCHK | |
5915 | ||
5916 | PARAMETER ( MAXNCL = 260, | |
5917 | & MAXVQU = MAXNCL, | |
5918 | & MAXSQU = 20*MAXVQU, | |
5919 | & MAXINT = MAXVQU+MAXSQU) | |
5920 | * event history | |
5921 | PARAMETER (NMXHKK=200000) | |
5922 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
5923 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
5924 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
5925 | * extended event history | |
5926 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
5927 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
5928 | & IHIST(2,NMXHKK) | |
5929 | * flags for input different options | |
5930 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
5931 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
5932 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
5933 | * auxiliary common for chain system storage (DTUNUC 1.x) | |
5934 | COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL) | |
5935 | * statistics | |
5936 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
5937 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
5938 | & ICEVTG(8,0:30) | |
5939 | * flags for diffractive interactions (DTUNUC 1.x) | |
5940 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF | |
5941 | * x-values of partons (DTUNUC 1.x) | |
5942 | COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU), | |
5943 | & XTVQ(MAXVQU),XTVD(MAXVQU), | |
5944 | & XPSQ(MAXSQU),XPSAQ(MAXSQU), | |
5945 | & XTSQ(MAXSQU),XTSAQ(MAXSQU) | |
5946 | * flavors of partons (DTUNUC 1.x) | |
5947 | COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU), | |
5948 | & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU), | |
5949 | & IPSQ(MAXSQU),IPSQ2(MAXSQU), | |
5950 | & IPSAQ(MAXSQU),IPSAQ2(MAXSQU), | |
5951 | & ITSQ(MAXSQU),ITSQ2(MAXSQU), | |
5952 | & ITSAQ(MAXSQU),ITSAQ2(MAXSQU), | |
5953 | & KKPROJ(MAXVQU),KKTARG(MAXVQU) | |
5954 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) | |
5955 | COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD, | |
5956 | & IXPV,IXPS,IXTV,IXTS, | |
5957 | & INTVV1(MAXVQU),INTVV2(MAXVQU), | |
5958 | & INTSV1(MAXVQU),INTSV2(MAXVQU), | |
5959 | & INTVS1(MAXVQU),INTVS2(MAXVQU), | |
5960 | & INTSS1(MAXSQU),INTSS2(MAXSQU), | |
5961 | & INTDV1(MAXVQU),INTDV2(MAXVQU), | |
5962 | & INTVD1(MAXVQU),INTVD2(MAXVQU), | |
5963 | & INTDS1(MAXSQU),INTDS2(MAXSQU), | |
5964 | & INTSD1(MAXSQU),INTSD2(MAXSQU) | |
5965 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) | |
5966 | COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU), | |
5967 | & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU) | |
5968 | ||
5969 | DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PP(4),PT(4) | |
5970 | ||
5971 | DATA AMSS,AMVS,AMDS,AMVD,AMVV/0.4D0,2.0D0,2.0D0,2.5D0,2.0D0/ | |
5972 | ||
5973 | IREJ = 0 | |
5974 | NCSY = 0 | |
5975 | NPOINT(2) = NHKK+1 | |
5976 | ||
5977 | * sea-sea chains | |
5978 | DO 10 I=1,NSS | |
5979 | IF (ISKPCH(1,I).EQ.99) GOTO 10 | |
5980 | ICCHAI(1,1) = ICCHAI(1,1)+2 | |
5981 | IDXP = INTSS1(I) | |
5982 | IDXT = INTSS2(I) | |
5983 | MOP = JDAHKK(1,IPOSP(IFROSP(IDXP))) | |
5984 | MOT = JDAHKK(1,IPOST(IFROST(IDXT))) | |
5985 | DO 11 K=1,4 | |
5986 | PP1(K) = XPSQ(IDXP) *PHKK(K,MOP) | |
5987 | PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP) | |
5988 | PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT) | |
5989 | PT2(K) = XTSQ(IDXT) *PHKK(K,MOT) | |
5990 | 11 CONTINUE | |
5991 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 | |
5992 | & +(PP1(3)+PT1(3))**2) | |
5993 | ECH = PP1(4)+PT1(4) | |
5994 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
5995 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 | |
5996 | & +(PP2(3)+PT2(3))**2) | |
5997 | ECH = PP2(4)+PT2(4) | |
5998 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
5999 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN | |
6000 | AM1 = SQRT(AM1) | |
6001 | AM2 = SQRT(AM2) | |
6002 | IF ((AM1.LT.AMSS).OR.(AM2.LT.AMSS)) THEN | |
6003 | C WRITE(LOUT,5000) NEVHKK,I,AM1,AM2 | |
6004 | 5000 FORMAT(1X,'incon. chain mass SS: ',2I5,2E10.3) | |
6005 | ENDIF | |
6006 | ELSE | |
6007 | WRITE(LOUT,5000) NEVHKK,I,AM1,AM2 | |
6008 | ENDIF | |
6009 | IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2) | |
6010 | IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2) | |
6011 | IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2) | |
6012 | IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2) | |
6013 | CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), | |
6014 | & 0,0,1) | |
6015 | CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), | |
6016 | & 0,0,1) | |
6017 | CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), | |
6018 | & 0,0,1) | |
6019 | CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), | |
6020 | & 0,0,1) | |
6021 | NCSY = NCSY+1 | |
6022 | 10 CONTINUE | |
6023 | ||
6024 | * disea-sea chains | |
6025 | DO 20 I=1,NDS | |
6026 | IF (ISKPCH(2,I).EQ.99) GOTO 20 | |
6027 | ICCHAI(1,2) = ICCHAI(1,2)+2 | |
6028 | IDXP = INTDS1(I) | |
6029 | IDXT = INTDS2(I) | |
6030 | MOP = JDAHKK(1,IPOSP(IFROSP(IDXP))) | |
6031 | MOT = JDAHKK(1,IPOST(IFROST(IDXT))) | |
6032 | DO 21 K=1,4 | |
6033 | PP1(K) = XPSQ(IDXP) *PHKK(K,MOP) | |
6034 | PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP) | |
6035 | PT1(K) = XTSQ(IDXT) *PHKK(K,MOT) | |
6036 | PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT) | |
6037 | 21 CONTINUE | |
6038 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 | |
6039 | & +(PP1(3)+PT1(3))**2) | |
6040 | ECH = PP1(4)+PT1(4) | |
6041 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
6042 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 | |
6043 | & +(PP2(3)+PT2(3))**2) | |
6044 | ECH = PP2(4)+PT2(4) | |
6045 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
6046 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN | |
6047 | AM1 = SQRT(AM1) | |
6048 | AM2 = SQRT(AM2) | |
6049 | IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN | |
6050 | C WRITE(LOUT,5001) NEVHKK,I,AM1,AM2 | |
6051 | 5001 FORMAT(1X,'incon. chain mass DS: ',2I5,2E10.3) | |
6052 | ENDIF | |
6053 | ELSE | |
6054 | WRITE(LOUT,5001) NEVHKK,I,AM1,AM2 | |
6055 | ENDIF | |
6056 | IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2) | |
6057 | IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2) | |
6058 | IFT1 = IDT_IB2PDG(ITSQ(IDXT),0,2) | |
6059 | IFT2 = IDT_IB2PDG(ITSAQ(IDXT),0,2) | |
6060 | CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), | |
6061 | & 0,0,2) | |
6062 | CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), | |
6063 | & 0,0,2) | |
6064 | CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), | |
6065 | & 0,0,2) | |
6066 | CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), | |
6067 | & 0,0,2) | |
6068 | NCSY = NCSY+1 | |
6069 | 20 CONTINUE | |
6070 | ||
6071 | * sea-disea chains | |
6072 | DO 30 I=1,NSD | |
6073 | IF (ISKPCH(3,I).EQ.99) GOTO 30 | |
6074 | ICCHAI(1,3) = ICCHAI(1,3)+2 | |
6075 | IDXP = INTSD1(I) | |
6076 | IDXT = INTSD2(I) | |
6077 | MOP = JDAHKK(1,IPOSP(IFROSP(IDXP))) | |
6078 | MOT = JDAHKK(1,IPOST(IFROST(IDXT))) | |
6079 | DO 31 K=1,4 | |
6080 | PP1(K) = XPSQ(IDXP) *PHKK(K,MOP) | |
6081 | PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP) | |
6082 | PT1(K) = XTSQ(IDXT) *PHKK(K,MOT) | |
6083 | PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT) | |
6084 | 31 CONTINUE | |
6085 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 | |
6086 | & +(PP1(3)+PT1(3))**2) | |
6087 | ECH = PP1(4)+PT1(4) | |
6088 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
6089 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 | |
6090 | & +(PP2(3)+PT2(3))**2) | |
6091 | ECH = PP2(4)+PT2(4) | |
6092 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
6093 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN | |
6094 | AM1 = SQRT(AM1) | |
6095 | AM2 = SQRT(AM2) | |
6096 | IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN | |
6097 | C WRITE(LOUT,5002) NEVHKK,I,AM1,AM2 | |
6098 | 5002 FORMAT(1X,'incon. chain mass SD: ',2I5,2E10.3) | |
6099 | ENDIF | |
6100 | ELSE | |
6101 | WRITE(LOUT,5002) NEVHKK,I,AM1,AM2 | |
6102 | ENDIF | |
6103 | IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2) | |
6104 | IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2) | |
6105 | IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2) | |
6106 | IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2) | |
6107 | CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), | |
6108 | & 0,0,3) | |
6109 | CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), | |
6110 | & 0,0,3) | |
6111 | CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), | |
6112 | & 0,0,3) | |
6113 | CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), | |
6114 | & 0,0,3) | |
6115 | NCSY = NCSY+1 | |
6116 | 30 CONTINUE | |
6117 | ||
6118 | * disea-valence chains | |
6119 | DO 50 I=1,NDV | |
6120 | IF (ISKPCH(5,I).EQ.99) GOTO 50 | |
6121 | ICCHAI(1,5) = ICCHAI(1,5)+2 | |
6122 | IDXP = INTDV1(I) | |
6123 | IDXT = INTDV2(I) | |
6124 | MOP = JDAHKK(1,IPOSP(IFROSP(IDXP))) | |
6125 | MOT = JDAHKK(1,IPOST(IFROVT(IDXT))) | |
6126 | DO 51 K=1,4 | |
6127 | PP1(K) = XPSQ(IDXP) *PHKK(K,MOP) | |
6128 | PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP) | |
6129 | PT1(K) = XTVQ(IDXT) *PHKK(K,MOT) | |
6130 | PT2(K) = XTVD(IDXT) *PHKK(K,MOT) | |
6131 | 51 CONTINUE | |
6132 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 | |
6133 | & +(PP1(3)+PT1(3))**2) | |
6134 | ECH = PP1(4)+PT1(4) | |
6135 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
6136 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 | |
6137 | & +(PP2(3)+PT2(3))**2) | |
6138 | ECH = PP2(4)+PT2(4) | |
6139 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
6140 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN | |
6141 | AM1 = SQRT(AM1) | |
6142 | AM2 = SQRT(AM2) | |
6143 | IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN | |
6144 | C WRITE(LOUT,5003) NEVHKK,I,AM1,AM2 | |
6145 | 5003 FORMAT(1X,'incon. chain mass DV: ',2I5,2E10.3) | |
6146 | ENDIF | |
6147 | ELSE | |
6148 | WRITE(LOUT,5003) NEVHKK,I,AM1,AM2 | |
6149 | ENDIF | |
6150 | IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2) | |
6151 | IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2) | |
6152 | IFT1 = IDT_IB2PDG(ITVQ(IDXT),0,2) | |
6153 | IFT2 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2) | |
6154 | CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), | |
6155 | & 0,0,5) | |
6156 | CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), | |
6157 | & 0,0,5) | |
6158 | CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), | |
6159 | & 0,0,5) | |
6160 | CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), | |
6161 | & 0,0,5) | |
6162 | NCSY = NCSY+1 | |
6163 | 50 CONTINUE | |
6164 | ||
6165 | * valence-sea chains | |
6166 | DO 60 I=1,NVS | |
6167 | IF (ISKPCH(6,I).EQ.99) GOTO 60 | |
6168 | ICCHAI(1,6) = ICCHAI(1,6)+2 | |
6169 | IDXP = INTVS1(I) | |
6170 | IDXT = INTVS2(I) | |
6171 | MOP = JDAHKK(1,IPOSP(IFROVP(IDXP))) | |
6172 | MOT = JDAHKK(1,IPOST(IFROST(IDXT))) | |
6173 | DO 61 K=1,4 | |
6174 | PP1(K) = XPVQ(IDXP) *PHKK(K,MOP) | |
6175 | PP2(K) = XPVD(IDXP) *PHKK(K,MOP) | |
6176 | PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT) | |
6177 | PT2(K) = XTSQ(IDXT) *PHKK(K,MOT) | |
6178 | 61 CONTINUE | |
6179 | IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2) | |
6180 | IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2) | |
6181 | IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2) | |
6182 | IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2) | |
6183 | CALL DT_CHKCSY(IFP1,IFT1,LCHK) | |
6184 | IF (LCHK) THEN | |
6185 | CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), | |
6186 | & 0,0,6) | |
6187 | CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), | |
6188 | & 0,0,6) | |
6189 | CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), | |
6190 | & 0,0,6) | |
6191 | CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), | |
6192 | & 0,0,6) | |
6193 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 | |
6194 | & +(PP1(3)+PT1(3))**2) | |
6195 | ECH = PP1(4)+PT1(4) | |
6196 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
6197 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 | |
6198 | & +(PP2(3)+PT2(3))**2) | |
6199 | ECH = PP2(4)+PT2(4) | |
6200 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
6201 | ELSE | |
6202 | CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), | |
6203 | & 0,0,6) | |
6204 | CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), | |
6205 | & 0,0,6) | |
6206 | CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), | |
6207 | & 0,0,6) | |
6208 | CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), | |
6209 | & 0,0,6) | |
6210 | PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2 | |
6211 | & +(PP1(3)+PT2(3))**2) | |
6212 | ECH = PP1(4)+PT2(4) | |
6213 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
6214 | PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2 | |
6215 | & +(PP2(3)+PT1(3))**2) | |
6216 | ECH = PP2(4)+PT1(4) | |
6217 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
6218 | ENDIF | |
6219 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN | |
6220 | AM1 = SQRT(AM1) | |
6221 | AM2 = SQRT(AM2) | |
6222 | IF ((AM1.LT.AMSS).OR.(AM2.LT.AMVS)) THEN | |
6223 | C WRITE(LOUT,5004) NEVHKK,I,AM1,AM2 | |
6224 | 5004 FORMAT(1X,'incon. chain mass VS: ',2I5,2E10.3) | |
6225 | ENDIF | |
6226 | ELSE | |
6227 | WRITE(LOUT,5004) NEVHKK,I,AM1,AM2 | |
6228 | ENDIF | |
6229 | NCSY = NCSY+1 | |
6230 | 60 CONTINUE | |
6231 | ||
6232 | * sea-valence chains | |
6233 | DO 40 I=1,NSV | |
6234 | IF (ISKPCH(4,I).EQ.99) GOTO 40 | |
6235 | ICCHAI(1,4) = ICCHAI(1,4)+2 | |
6236 | IDXP = INTSV1(I) | |
6237 | IDXT = INTSV2(I) | |
6238 | MOP = JDAHKK(1,IPOSP(IFROSP(IDXP))) | |
6239 | MOT = JDAHKK(1,IPOST(IFROVT(IDXT))) | |
6240 | DO 41 K=1,4 | |
6241 | PP1(K) = XPSQ(IDXP) *PHKK(K,MOP) | |
6242 | PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP) | |
6243 | PT1(K) = XTVD(IDXT) *PHKK(K,MOT) | |
6244 | PT2(K) = XTVQ(IDXT) *PHKK(K,MOT) | |
6245 | 41 CONTINUE | |
6246 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 | |
6247 | & +(PP1(3)+PT1(3))**2) | |
6248 | ECH = PP1(4)+PT1(4) | |
6249 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
6250 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 | |
6251 | & +(PP2(3)+PT2(3))**2) | |
6252 | ECH = PP2(4)+PT2(4) | |
6253 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
6254 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN | |
6255 | AM1 = SQRT(AM1) | |
6256 | AM2 = SQRT(AM2) | |
6257 | IF ((AM1.LT.AMVS).OR.(AM2.LT.AMSS)) THEN | |
6258 | C WRITE(LOUT,5005) NEVHKK,I,AM1,AM2 | |
6259 | 5005 FORMAT(1X,'incon. chain mass SV: ',2I5,2E10.3) | |
6260 | ENDIF | |
6261 | ELSE | |
6262 | WRITE(LOUT,5005) NEVHKK,I,AM1,AM2 | |
6263 | ENDIF | |
6264 | IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2) | |
6265 | IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2) | |
6266 | IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2) | |
6267 | IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2) | |
6268 | CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), | |
6269 | & 0,0,4) | |
6270 | CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), | |
6271 | & 0,0,4) | |
6272 | CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), | |
6273 | & 0,0,4) | |
6274 | CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), | |
6275 | & 0,0,4) | |
6276 | NCSY = NCSY+1 | |
6277 | 40 CONTINUE | |
6278 | ||
6279 | * valence-disea chains | |
6280 | DO 70 I=1,NVD | |
6281 | IF (ISKPCH(7,I).EQ.99) GOTO 70 | |
6282 | ICCHAI(1,7) = ICCHAI(1,7)+2 | |
6283 | IDXP = INTVD1(I) | |
6284 | IDXT = INTVD2(I) | |
6285 | MOP = JDAHKK(1,IPOSP(IFROVP(IDXP))) | |
6286 | MOT = JDAHKK(1,IPOST(IFROST(IDXT))) | |
6287 | DO 71 K=1,4 | |
6288 | PP1(K) = XPVQ(IDXP) *PHKK(K,MOP) | |
6289 | PP2(K) = XPVD(IDXP) *PHKK(K,MOP) | |
6290 | PT1(K) = XTSQ(IDXT) *PHKK(K,MOT) | |
6291 | PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT) | |
6292 | 71 CONTINUE | |
6293 | IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2) | |
6294 | IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2) | |
6295 | IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2) | |
6296 | IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2) | |
6297 | CALL DT_CHKCSY(IFP1,IFT1,LCHK) | |
6298 | IF (LCHK) THEN | |
6299 | CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), | |
6300 | & 0,0,7) | |
6301 | CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), | |
6302 | & 0,0,7) | |
6303 | CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), | |
6304 | & 0,0,7) | |
6305 | CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), | |
6306 | & 0,0,7) | |
6307 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 | |
6308 | & +(PP1(3)+PT1(3))**2) | |
6309 | ECH = PP1(4)+PT1(4) | |
6310 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
6311 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 | |
6312 | & +(PP2(3)+PT2(3))**2) | |
6313 | ECH = PP2(4)+PT2(4) | |
6314 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
6315 | ELSE | |
6316 | CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), | |
6317 | & 0,0,7) | |
6318 | CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), | |
6319 | & 0,0,7) | |
6320 | CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), | |
6321 | & 0,0,7) | |
6322 | CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), | |
6323 | & 0,0,7) | |
6324 | PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2 | |
6325 | & +(PP1(3)+PT2(3))**2) | |
6326 | ECH = PP1(4)+PT2(4) | |
6327 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
6328 | PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2 | |
6329 | & +(PP2(3)+PT1(3))**2) | |
6330 | ECH = PP2(4)+PT1(4) | |
6331 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
6332 | ENDIF | |
6333 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN | |
6334 | AM1 = SQRT(AM1) | |
6335 | AM2 = SQRT(AM2) | |
6336 | IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN | |
6337 | C WRITE(LOUT,5006) NEVHKK,I,AM1,AM2 | |
6338 | 5006 FORMAT(1X,'incon. chain mass VD: ',2I5,2E10.3) | |
6339 | ENDIF | |
6340 | ELSE | |
6341 | WRITE(LOUT,5006) NEVHKK,I,AM1,AM2 | |
6342 | ENDIF | |
6343 | NCSY = NCSY+1 | |
6344 | 70 CONTINUE | |
6345 | ||
6346 | * valence-valence chains | |
6347 | DO 80 I=1,NVV | |
6348 | IF (ISKPCH(8,I).EQ.99) GOTO 80 | |
6349 | ICCHAI(1,8) = ICCHAI(1,8)+2 | |
6350 | IDXP = INTVV1(I) | |
6351 | IDXT = INTVV2(I) | |
6352 | MOP = JDAHKK(1,IPOSP(IFROVP(IDXP))) | |
6353 | MOT = JDAHKK(1,IPOST(IFROVT(IDXT))) | |
6354 | DO 81 K=1,4 | |
6355 | PP1(K) = XPVQ(IDXP)*PHKK(K,MOP) | |
6356 | PP2(K) = XPVD(IDXP)*PHKK(K,MOP) | |
6357 | PT1(K) = XTVD(IDXT)*PHKK(K,MOT) | |
6358 | PT2(K) = XTVQ(IDXT)*PHKK(K,MOT) | |
6359 | 81 CONTINUE | |
6360 | IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2) | |
6361 | IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2) | |
6362 | IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2) | |
6363 | IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2) | |
6364 | ||
6365 | * check for diffractive event | |
6366 | IDIFF = 0 | |
6367 | IF (((ISINGD.GT.0).OR.(IDOUBD.GT.0)).AND. | |
6368 | & (IP.EQ.1).AND.(NN.EQ.1)) THEN | |
6369 | DO 800 K=1,4 | |
6370 | PP(K) = PP1(K)+PP2(K) | |
6371 | PT(K) = PT1(K)+PT2(K) | |
6372 | 800 CONTINUE | |
6373 | ISTCK = NHKK | |
6374 | CALL DT_DIFEVT(IFP1,IFP2,PP,MOP, | |
6375 | & IFT1,IFT2,PT,MOT,IDIFF,NCSY,IREJ1) | |
6376 | C IF (IREJ1.NE.0) GOTO 9999 | |
6377 | IF (IREJ1.NE.0) THEN | |
6378 | IDIFF = 0 | |
6379 | NHKK = ISTCK | |
6380 | ENDIF | |
6381 | ELSE | |
6382 | IDIFF = 0 | |
6383 | ENDIF | |
6384 | ||
6385 | IF (IDIFF.EQ.0) THEN | |
6386 | * valence-valence chain system | |
6387 | CALL DT_CHKCSY(IFP1,IFT1,LCHK) | |
6388 | IF (LCHK) THEN | |
6389 | * baryon-baryon | |
6390 | CALL DT_EVTPUT(-21,IFP1,MOP,0, | |
6391 | & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8) | |
6392 | CALL DT_EVTPUT(-22,IFT1,MOT,0, | |
6393 | & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8) | |
6394 | CALL DT_EVTPUT(-21,IFP2,MOP,0, | |
6395 | & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8) | |
6396 | CALL DT_EVTPUT(-22,IFT2,MOT,0, | |
6397 | & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8) | |
6398 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 | |
6399 | & +(PP1(3)+PT1(3))**2) | |
6400 | ECH = PP1(4)+PT1(4) | |
6401 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
6402 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 | |
6403 | & +(PP2(3)+PT2(3))**2) | |
6404 | ECH = PP2(4)+PT2(4) | |
6405 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
6406 | ELSE | |
6407 | * antibaryon-baryon | |
6408 | CALL DT_EVTPUT(-21,IFP1,MOP,0, | |
6409 | & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8) | |
6410 | CALL DT_EVTPUT(-22,IFT2,MOT,0, | |
6411 | & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8) | |
6412 | CALL DT_EVTPUT(-21,IFP2,MOP,0, | |
6413 | & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8) | |
6414 | CALL DT_EVTPUT(-22,IFT1,MOT,0, | |
6415 | & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8) | |
6416 | PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2 | |
6417 | & +(PP1(3)+PT2(3))**2) | |
6418 | ECH = PP1(4)+PT2(4) | |
6419 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
6420 | PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2 | |
6421 | & +(PP2(3)+PT1(3))**2) | |
6422 | ECH = PP2(4)+PT1(4) | |
6423 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
6424 | ENDIF | |
6425 | IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN | |
6426 | AM1 = SQRT(AM1) | |
6427 | AM2 = SQRT(AM2) | |
6428 | IF ((AM1.LT.AMVV).OR.(AM2.LT.AMVV)) THEN | |
6429 | C WRITE(LOUT,5007) NEVHKK,I,AM1,AM2 | |
6430 | 5007 FORMAT(1X,'incon. chain mass VV: ',2I5,2E10.3) | |
6431 | ENDIF | |
6432 | ELSE | |
6433 | WRITE(LOUT,5007) NEVHKK,I,AM1,AM2 | |
6434 | ENDIF | |
6435 | NCSY = NCSY+1 | |
6436 | ENDIF | |
6437 | 80 CONTINUE | |
6438 | IF (ISTHKK(NPOINT(2)).EQ.1) NPOINT(2) = NPOINT(2)+1 | |
6439 | ||
6440 | * energy-momentum & flavor conservation check | |
6441 | IF (ABS(IDIFF).NE.1) THEN | |
6442 | IF (IDIFF.NE.0) THEN | |
6443 | IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-41,1,0, | |
6444 | & 1,3,10,IREJ) | |
6445 | ELSE | |
6446 | IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-31,-32,0, | |
6447 | & 1,3,10,IREJ) | |
6448 | ENDIF | |
6449 | IF (IREJ.NE.0) THEN | |
6450 | CALL DT_EVTOUT(4) | |
6451 | STOP | |
6452 | ENDIF | |
6453 | ENDIF | |
6454 | ||
6455 | RETURN | |
6456 | ||
6457 | 9999 CONTINUE | |
6458 | IREJ = 1 | |
6459 | RETURN | |
6460 | END | |
6461 | ||
6462 | *$ CREATE DT_CHKCSY.FOR | |
6463 | *COPY DT_CHKCSY | |
6464 | * | |
6465 | *===chkcsy=============================================================* | |
6466 | * | |
6467 | SUBROUTINE DT_CHKCSY(ID1,ID2,LCHK) | |
6468 | ||
6469 | ************************************************************************ | |
6470 | * CHeCk Chain SYstem for consistency of partons at chain ends. * | |
6471 | * ID1,ID2 PDG-numbers of partons at chain ends * | |
6472 | * LCHK = .true. consistent chain * | |
6473 | * = .false. inconsistent chain * | |
6474 | * This version dated 18.01.95 is written by S. Roesler * | |
6475 | ************************************************************************ | |
6476 | ||
6477 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
6478 | SAVE | |
6479 | PARAMETER ( LINP = 10 , | |
6480 | & LOUT = 6 , | |
6481 | & LDAT = 9 ) | |
6482 | ||
6483 | LOGICAL LCHK | |
6484 | ||
6485 | LCHK = .TRUE. | |
6486 | ||
6487 | * q-aq chain | |
6488 | IF ((ABS(ID1).LE.6).AND.(ABS(ID2).LE.6)) THEN | |
6489 | IF (ID1*ID2.GT.0) LCHK = .FALSE. | |
6490 | * q-qq, aq-aqaq chain | |
6491 | ELSEIF (((ABS(ID1).LE.6).AND.(ABS(ID2).GT.6)).OR. | |
6492 | & ((ABS(ID1).GT.6).AND.(ABS(ID2).LE.6))) THEN | |
6493 | IF (ID1*ID2.LT.0) LCHK = .FALSE. | |
6494 | * qq-aqaq chain | |
6495 | ELSEIF ((ABS(ID1).GT.6).AND.(ABS(ID2).GT.6)) THEN | |
6496 | IF (ID1*ID2.GT.0) LCHK = .FALSE. | |
6497 | ENDIF | |
6498 | ||
6499 | RETURN | |
6500 | END | |
6501 | ||
6502 | *$ CREATE DT_EVENTA.FOR | |
6503 | *COPY DT_EVENTA | |
6504 | * | |
6505 | *===eventa=============================================================* | |
6506 | * | |
6507 | SUBROUTINE DT_EVENTA(ID,IP,IT,NCSY,IREJ) | |
6508 | ||
6509 | ************************************************************************ | |
6510 | * Treatment of nucleon-nucleon interactions in a two-chain * | |
6511 | * approximation. * | |
6512 | * (input) ID BAMJET-index of projectile hadron (in case of * | |
6513 | * h-K scattering) * | |
6514 | * IP/IT mass number of projectile/target nucleus * | |
6515 | * NCSY number of two chain systems * | |
6516 | * IREJ rejection flag * | |
6517 | * This version dated 15.01.95 is written by S. Roesler * | |
6518 | ************************************************************************ | |
6519 | ||
6520 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
6521 | SAVE | |
6522 | PARAMETER ( LINP = 10 , | |
6523 | & LOUT = 6 , | |
6524 | & LDAT = 9 ) | |
6525 | PARAMETER (TINY10=1.0D-10) | |
6526 | ||
6527 | * event history | |
6528 | PARAMETER (NMXHKK=200000) | |
6529 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
6530 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
6531 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
6532 | * extended event history | |
6533 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
6534 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
6535 | & IHIST(2,NMXHKK) | |
6536 | * rejection counter | |
6537 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
6538 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
6539 | & IREXCI(3),IRDIFF(2),IRINC | |
6540 | * flags for diffractive interactions (DTUNUC 1.x) | |
6541 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF | |
6542 | * particle properties (BAMJET index convention) | |
6543 | CHARACTER*8 ANAME | |
6544 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
6545 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
6546 | * flags for input different options | |
6547 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
6548 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
6549 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
6550 | * various options for treatment of partons (DTUNUC 1.x) | |
6551 | * (chain recombination, Cronin,..) | |
6552 | LOGICAL LCO2CR,LINTPT | |
6553 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, | |
6554 | & LCO2CR,LINTPT | |
6555 | ||
6556 | DIMENSION PP1(4),PP2(4),PT1(4),PT2(4) | |
6557 | ||
6558 | IREJ = 0 | |
6559 | NPOINT(3) = NHKK+1 | |
6560 | ||
6561 | * skip following treatment for low-mass diffraction | |
6562 | IF (ABS(IFLAGD).EQ.1) THEN | |
6563 | NPOINT(3) = NPOINT(2) | |
6564 | GOTO 5 | |
6565 | ENDIF | |
6566 | ||
6567 | * multiple scattering of chain ends | |
6568 | IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1) | |
6569 | IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2) | |
6570 | ||
6571 | NC = NPOINT(2) | |
6572 | * get a two-chain system from DTEVT1 | |
6573 | DO 3 I=1,NCSY | |
6574 | IFP1 = IDHKK(NC) | |
6575 | IFT1 = IDHKK(NC+1) | |
6576 | IFP2 = IDHKK(NC+2) | |
6577 | IFT2 = IDHKK(NC+3) | |
6578 | DO 4 K=1,4 | |
6579 | PP1(K) = PHKK(K,NC) | |
6580 | PT1(K) = PHKK(K,NC+1) | |
6581 | PP2(K) = PHKK(K,NC+2) | |
6582 | PT2(K) = PHKK(K,NC+3) | |
6583 | 4 CONTINUE | |
6584 | MOP1 = NC | |
6585 | MOT1 = NC+1 | |
6586 | MOP2 = NC+2 | |
6587 | MOT2 = NC+3 | |
6588 | CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2, | |
6589 | & IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1) | |
6590 | IF (IREJ1.GT.0) THEN | |
6591 | IRHHA = IRHHA+1 | |
6592 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTA' | |
6593 | GOTO 9999 | |
6594 | ENDIF | |
6595 | NC = NC+4 | |
6596 | 3 CONTINUE | |
6597 | ||
6598 | * meson/antibaryon projectile: | |
6599 | * sample single-chain valence-valence systems (Reggeon contrib.) | |
6600 | IF ((IP.EQ.1).AND.(ISICHA.EQ.1)) THEN | |
6601 | IF (IIBAR(ID).LE.0) CALL DT_VV2SCH | |
6602 | ENDIF | |
6603 | ||
6604 | IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN | |
6605 | * check DTEVT1 for remaining resonance mass corrections | |
6606 | CALL DT_EVTRES(IREJ1) | |
6607 | IF (IREJ1.GT.0) THEN | |
6608 | IRRES(1) = IRRES(1)+1 | |
6609 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in EVENTA' | |
6610 | GOTO 9999 | |
6611 | ENDIF | |
6612 | ENDIF | |
6613 | ||
6614 | * assign p_t to two-"chain" systems consisting of two resonances only | |
6615 | * since only entries for chains will be affected, this is obsolete | |
6616 | * in case of JETSET-fragmetation | |
6617 | CALL DT_RESPT | |
6618 | ||
6619 | * combine q-aq chains to color ropes (qq-aqaq) (chain fusion) | |
6620 | IF (LCO2CR) CALL DT_COM2CR | |
6621 | ||
6622 | 5 CONTINUE | |
6623 | ||
6624 | * fragmentation of the complete event | |
6625 | **uncomment for internal phojet-fragmentation | |
6626 | C CALL DT_EVTFRA(IREJ1) | |
6627 | CALL DT_EVTFRG(2,IDUM,NPYMEM,IREJ1) | |
6628 | IF (IREJ1.GT.0) THEN | |
6629 | IRFRAG = IRFRAG+1 | |
6630 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 3 in EVENTA' | |
6631 | GOTO 9999 | |
6632 | ENDIF | |
6633 | ||
6634 | * decay of possible resonances (should be obsolete) | |
6635 | CALL DT_DECAY1 | |
6636 | ||
6637 | RETURN | |
6638 | ||
6639 | 9999 CONTINUE | |
6640 | IREVT = IREVT+1 | |
6641 | IREJ = 1 | |
6642 | RETURN | |
6643 | END | |
6644 | ||
6645 | *$ CREATE DT_GETCSY.FOR | |
6646 | *COPY DT_GETCSY | |
6647 | * | |
6648 | *===getcsy=============================================================* | |
6649 | * | |
6650 | SUBROUTINE DT_GETCSY(IFPR1,PP1,MOP1,IFPR2,PP2,MOP2, | |
6651 | & IFTA1,PT1,MOT1,IFTA2,PT2,MOT2,IREJ) | |
6652 | ||
6653 | ************************************************************************ | |
6654 | * This version dated 15.01.95 is written by S. Roesler * | |
6655 | ************************************************************************ | |
6656 | ||
6657 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
6658 | SAVE | |
6659 | PARAMETER ( LINP = 10 , | |
6660 | & LOUT = 6 , | |
6661 | & LDAT = 9 ) | |
6662 | PARAMETER (TINY10=1.0D-10) | |
6663 | ||
6664 | * event history | |
6665 | PARAMETER (NMXHKK=200000) | |
6666 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
6667 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
6668 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
6669 | * extended event history | |
6670 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
6671 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
6672 | & IHIST(2,NMXHKK) | |
6673 | * rejection counter | |
6674 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
6675 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
6676 | & IREXCI(3),IRDIFF(2),IRINC | |
6677 | * flags for input different options | |
6678 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
6679 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
6680 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
6681 | * flags for diffractive interactions (DTUNUC 1.x) | |
6682 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF | |
6683 | ||
6684 | DIMENSION PP1(4),PP2(4),PT1(4),PT2(4), | |
6685 | & IFP1(2),IFP2(2),IFT1(2),IFT2(2),PCH1(4),PCH2(4) | |
6686 | ||
6687 | IREJ = 0 | |
6688 | ||
6689 | * get quark content of partons | |
6690 | DO 1 I=1,2 | |
6691 | IFP1(I) = 0 | |
6692 | IFP2(I) = 0 | |
6693 | IFT1(I) = 0 | |
6694 | IFT2(I) = 0 | |
6695 | 1 CONTINUE | |
6696 | IFP1(1) = IDT_IPDG2B(IFPR1,1,2) | |
6697 | IF (ABS(IFPR1).GE.1000) IFP1(2) = IDT_IPDG2B(IFPR1,2,2) | |
6698 | IFP2(1) = IDT_IPDG2B(IFPR2,1,2) | |
6699 | IF (ABS(IFPR2).GE.1000) IFP2(2) = IDT_IPDG2B(IFPR2,2,2) | |
6700 | IFT1(1) = IDT_IPDG2B(IFTA1,1,2) | |
6701 | IF (ABS(IFTA1).GE.1000) IFT1(2) = IDT_IPDG2B(IFTA1,2,2) | |
6702 | IFT2(1) = IDT_IPDG2B(IFTA2,1,2) | |
6703 | IF (ABS(IFTA2).GE.1000) IFT2(2) = IDT_IPDG2B(IFTA2,2,2) | |
6704 | ||
6705 | * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq, 3 - qq-aqaq) | |
6706 | IDCH1 = 2 | |
6707 | IF ((IFP1(2).EQ.0).AND.(IFT1(2).EQ.0)) IDCH1 = 1 | |
6708 | IF ((IFP1(2).NE.0).AND.(IFT1(2).NE.0)) IDCH1 = 3 | |
6709 | IDCH2 = 2 | |
6710 | IF ((IFP2(2).EQ.0).AND.(IFT2(2).EQ.0)) IDCH2 = 1 | |
6711 | IF ((IFP2(2).NE.0).AND.(IFT2(2).NE.0)) IDCH2 = 3 | |
6712 | ||
6713 | * store initial configuration for energy-momentum cons. check | |
6714 | IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IDUM) | |
6715 | ||
6716 | * sample intrinsic p_t at chain-ends | |
6717 | CALL DT_GETSPT(PP1,IFPR1,IFP1,PP2,IFPR2,IFP2, | |
6718 | & PT1,IFTA1,IFT1,PT2,IFTA2,IFT2, | |
6719 | & AMCH1,IDCH1,AMCH2,IDCH2,IDCH(MOP1),IREJ1) | |
6720 | IF (IREJ1.NE.0) THEN | |
6721 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in GETCSY' | |
6722 | IRPT = IRPT+1 | |
6723 | GOTO 9999 | |
6724 | ENDIF | |
6725 | ||
6726 | C IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN | |
6727 | C IF ((IDCH1.EQ.3).OR.((IDCH1.GT.1).AND.(IDCH2.EQ.1))) THEN | |
6728 | C* check second chain for resonance | |
6729 | C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2, | |
6730 | C & AMCH2,AMCH2N,IDCH2,IREJ1) | |
6731 | C IF (IREJ1.NE.0) GOTO 9999 | |
6732 | C IF (IDR2.NE.0) THEN | |
6733 | C CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1, | |
6734 | C & AMCH2,AMCH2N,AMCH1,IREJ1) | |
6735 | C IF (IREJ1.NE.0) GOTO 9999 | |
6736 | C ENDIF | |
6737 | C* check first chain for resonance | |
6738 | C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1, | |
6739 | C & AMCH1,AMCH1N,IDCH1,IREJ1) | |
6740 | C IF (IREJ1.NE.0) GOTO 9999 | |
6741 | C IF (IDR1.NE.0) IDR1 = 100*IDR1 | |
6742 | C ELSE | |
6743 | C* check first chain for resonance | |
6744 | C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1, | |
6745 | C & AMCH1,AMCH1N,IDCH1,IREJ1) | |
6746 | C IF (IREJ1.NE.0) GOTO 9999 | |
6747 | C IF (IDR1.NE.0) THEN | |
6748 | C CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2, | |
6749 | C & AMCH1,AMCH1N,AMCH2,IREJ1) | |
6750 | C IF (IREJ1.NE.0) GOTO 9999 | |
6751 | C ENDIF | |
6752 | C* check second chain for resonance | |
6753 | C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2, | |
6754 | C & AMCH2,AMCH2N,IDCH2,IREJ1) | |
6755 | C IF (IREJ1.NE.0) GOTO 9999 | |
6756 | C IF (IDR2.NE.0) IDR2 = 100*IDR2 | |
6757 | C ENDIF | |
6758 | C ENDIF | |
6759 | ||
6760 | IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN | |
6761 | * check chains for resonances | |
6762 | CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1, | |
6763 | & AMCH1,AMCH1N,IDCH1,IREJ1) | |
6764 | IF (IREJ1.NE.0) GOTO 9999 | |
6765 | CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2, | |
6766 | & AMCH2,AMCH2N,IDCH2,IREJ1) | |
6767 | IF (IREJ1.NE.0) GOTO 9999 | |
6768 | * change kinematics corresponding to resonance-masses | |
6769 | IF ( (IDR1.NE.0).AND.(IDR2.EQ.0) ) THEN | |
6770 | CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2, | |
6771 | & AMCH1,AMCH1N,AMCH2,IREJ1) | |
6772 | IF (IREJ1.GT.0) GOTO 9999 | |
6773 | IF (IREJ1.EQ.-1) IDR1 = 100*IDR1 | |
6774 | CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2, | |
6775 | & AMCH2,AMCH2N,IDCH2,IREJ1) | |
6776 | IF (IREJ1.NE.0) GOTO 9999 | |
6777 | IF (IDR2.NE.0) IDR2 = 100*IDR2 | |
6778 | ELSEIF ( (IDR1.EQ.0).AND.(IDR2.NE.0) ) THEN | |
6779 | CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1, | |
6780 | & AMCH2,AMCH2N,AMCH1,IREJ1) | |
6781 | IF (IREJ1.GT.0) GOTO 9999 | |
6782 | IF (IREJ1.EQ.-1) IDR2 = 100*IDR2 | |
6783 | CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1, | |
6784 | & AMCH1,AMCH1N,IDCH1,IREJ1) | |
6785 | IF (IREJ1.NE.0) GOTO 9999 | |
6786 | IF (IDR1.NE.0) IDR1 = 100*IDR1 | |
6787 | ELSEIF ( (IDR1.NE.0).AND.(IDR2.NE.0) ) THEN | |
6788 | AMDIF1 = ABS(AMCH1-AMCH1N) | |
6789 | AMDIF2 = ABS(AMCH2-AMCH2N) | |
6790 | IF (AMDIF2.LT.AMDIF1) THEN | |
6791 | CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1, | |
6792 | & AMCH2,AMCH2N,AMCH1,IREJ1) | |
6793 | IF (IREJ1.GT.0) GOTO 9999 | |
6794 | IF (IREJ1.EQ.-1) IDR2 = 100*IDR2 | |
6795 | CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2), | |
6796 | & IDR1,IDXR1,AMCH1,AMCH1N,IDCH1,IREJ1) | |
6797 | IF (IREJ1.NE.0) GOTO 9999 | |
6798 | IF (IDR1.NE.0) IDR1 = 100*IDR1 | |
6799 | ELSE | |
6800 | CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2, | |
6801 | & AMCH1,AMCH1N,AMCH2,IREJ1) | |
6802 | IF (IREJ1.GT.0) GOTO 9999 | |
6803 | IF (IREJ1.EQ.-1) IDR1 = 100*IDR1 | |
6804 | CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2), | |
6805 | & IDR2,IDXR2,AMCH2,AMCH2N,IDCH2,IREJ1) | |
6806 | IF (IREJ1.NE.0) GOTO 9999 | |
6807 | IF (IDR2.NE.0) IDR2 = 100*IDR2 | |
6808 | ENDIF | |
6809 | ENDIF | |
6810 | ENDIF | |
6811 | ||
6812 | * store final configuration for energy-momentum cons. check | |
6813 | IF (LEMCCK) THEN | |
6814 | CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IDUM) | |
6815 | CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1) | |
6816 | IF (IREJ1.NE.0) GOTO 9999 | |
6817 | ENDIF | |
6818 | ||
6819 | * put partons and chains into DTEVT1 | |
6820 | DO 10 I=1,4 | |
6821 | PCH1(I) = PP1(I)+PT1(I) | |
6822 | PCH2(I) = PP2(I)+PT2(I) | |
6823 | 10 CONTINUE | |
6824 | CALL DT_EVTPUT(-ISTHKK(MOP1),IFPR1,MOP1,0,PP1(1),PP1(2), | |
6825 | & PP1(3),PP1(4),0,0,0) | |
6826 | CALL DT_EVTPUT(-ISTHKK(MOT1),IFTA1,MOT1,0,PT1(1),PT1(2), | |
6827 | & PT1(3),PT1(4),0,0,0) | |
6828 | KCH = 100+IDCH(MOP1)*10+1 | |
6829 | CALL DT_EVTPUT(KCH,88888,-2,-1, | |
6830 | & PCH1(1),PCH1(2),PCH1(3),PCH1(4),IDR1,IDXR1,IDCH(MOP1)) | |
6831 | CALL DT_EVTPUT(-ISTHKK(MOP2),IFPR2,MOP2,0,PP2(1),PP2(2), | |
6832 | & PP2(3),PP2(4),0,0,0) | |
6833 | CALL DT_EVTPUT(-ISTHKK(MOT2),IFTA2,MOT2,0,PT2(1),PT2(2), | |
6834 | & PT2(3),PT2(4),0,0,0) | |
6835 | KCH = KCH+1 | |
6836 | CALL DT_EVTPUT(KCH,88888,-2,-1, | |
6837 | & PCH2(1),PCH2(2),PCH2(3),PCH2(4),IDR2,IDXR2,IDCH(MOP2)) | |
6838 | ||
6839 | RETURN | |
6840 | ||
6841 | 9999 CONTINUE | |
6842 | IF ((IDCH(MOP1).LE.3).AND.(IDCH(MOP2).LE.3)) THEN | |
6843 | * "cancel" sea-sea chains | |
6844 | CALL DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ1) | |
6845 | IF (IREJ1.NE.0) GOTO 9998 | |
6846 | **sr 16.5. flag for EVENTB | |
6847 | IREJ = -1 | |
6848 | RETURN | |
6849 | ENDIF | |
6850 | 9998 CONTINUE | |
6851 | IREJ = 1 | |
6852 | RETURN | |
6853 | END | |
6854 | ||
6855 | *$ CREATE DT_CHKINE.FOR | |
6856 | *COPY DT_CHKINE | |
6857 | * | |
6858 | *===chkine=============================================================* | |
6859 | * | |
6860 | SUBROUTINE DT_CHKINE(PP1I,IFP1,PP2I,IFP2,PT1I,IFT1,PT2I,IFT2, | |
6861 | & AMCH1,AMCH1N,AMCH2,IREJ) | |
6862 | ||
6863 | ************************************************************************ | |
6864 | * This subroutine replaces CORMOM. * | |
6865 | * This version dated 05.01.95 is written by S. Roesler * | |
6866 | ************************************************************************ | |
6867 | ||
6868 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
6869 | SAVE | |
6870 | PARAMETER ( LINP = 10 , | |
6871 | & LOUT = 6 , | |
6872 | & LDAT = 9 ) | |
6873 | PARAMETER (TINY10=1.0D-10) | |
6874 | ||
6875 | * flags for input different options | |
6876 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
6877 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
6878 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
6879 | * rejection counter | |
6880 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
6881 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
6882 | & IREXCI(3),IRDIFF(2),IRINC | |
6883 | ||
6884 | DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),P1(4),P2(4), | |
6885 | & PP1I(4),PP2I(4),PT1I(4),PT2I(4) | |
6886 | ||
6887 | IREJ = 0 | |
6888 | JMSHL = IMSHL | |
6889 | ||
6890 | SCALE = AMCH1N/MAX(AMCH1,TINY10) | |
6891 | DO 10 I=1,4 | |
6892 | PP1(I) = PP1I(I) | |
6893 | PP2(I) = PP2I(I) | |
6894 | PT1(I) = PT1I(I) | |
6895 | PT2(I) = PT2I(I) | |
6896 | PP2(I) = PP2(I)+(1.0D0-SCALE)*PP1(I) | |
6897 | PT2(I) = PT2(I)+(1.0D0-SCALE)*PT1(I) | |
6898 | PP1(I) = SCALE*PP1(I) | |
6899 | PT1(I) = SCALE*PT1(I) | |
6900 | 10 CONTINUE | |
6901 | IF ((PP1(4).LT.0.0D0).OR.(PP2(4).LT.0.0D0).OR. | |
6902 | & (PT1(4).LT.0.0D0).OR.(PT2(4).LT.0.0D0)) GOTO 9997 | |
6903 | ||
6904 | ECH = PP2(4)+PT2(4) | |
6905 | PCH = SQRT( (PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2+ | |
6906 | & (PP2(3)+PT2(3))**2 ) | |
6907 | AMCH22 = (ECH-PCH)*(ECH+PCH) | |
6908 | IF (AMCH22.LT.0.0D0) THEN | |
6909 | IF (IOULEV(1).GT.0) | |
6910 | & WRITE(LOUT,'(1X,A)') 'CHKINE: inconsistent treatment!' | |
6911 | GOTO 9997 | |
6912 | ENDIF | |
6913 | ||
6914 | AMCH1 = AMCH1N | |
6915 | AMCH2 = SQRT(AMCH22) | |
6916 | ||
6917 | * put partons again on mass shell | |
6918 | 13 CONTINUE | |
6919 | XM1 = 0.0D0 | |
6920 | XM2 = 0.0D0 | |
6921 | IF (JMSHL.EQ.1) THEN | |
6922 | XM1 = PYMASS(IFP1) | |
6923 | XM2 = PYMASS(IFT1) | |
6924 | ENDIF | |
6925 | CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1) | |
6926 | IF (IREJ1.NE.0) THEN | |
6927 | IF (JMSHL.EQ.0) GOTO 9998 | |
6928 | JMSHL = 0 | |
6929 | GOTO 13 | |
6930 | ENDIF | |
6931 | JMSHL = IMSHL | |
6932 | DO 11 I=1,4 | |
6933 | PP1(I) = P1(I) | |
6934 | PT1(I) = P2(I) | |
6935 | 11 CONTINUE | |
6936 | 14 CONTINUE | |
6937 | XM1 = 0.0D0 | |
6938 | XM2 = 0.0D0 | |
6939 | IF (JMSHL.EQ.1) THEN | |
6940 | XM1 = PYMASS(IFP2) | |
6941 | XM2 = PYMASS(IFT2) | |
6942 | ENDIF | |
6943 | CALL DT_MASHEL(PP2,PT2,XM1,XM2,P1,P2,IREJ1) | |
6944 | IF (IREJ1.NE.0) THEN | |
6945 | IF (JMSHL.EQ.0) GOTO 9998 | |
6946 | JMSHL = 0 | |
6947 | GOTO 14 | |
6948 | ENDIF | |
6949 | DO 12 I=1,4 | |
6950 | PP2(I) = P1(I) | |
6951 | PT2(I) = P2(I) | |
6952 | 12 CONTINUE | |
6953 | DO 15 I=1,4 | |
6954 | PP1I(I) = PP1(I) | |
6955 | PP2I(I) = PP2(I) | |
6956 | PT1I(I) = PT1(I) | |
6957 | PT2I(I) = PT2(I) | |
6958 | 15 CONTINUE | |
6959 | RETURN | |
6960 | ||
6961 | 9997 IRCHKI(1) = IRCHKI(1)+1 | |
6962 | **sr | |
6963 | C GOTO 9999 | |
6964 | IREJ = -1 | |
6965 | RETURN | |
6966 | ** | |
6967 | 9998 IRCHKI(2) = IRCHKI(2)+1 | |
6968 | ||
6969 | 9999 CONTINUE | |
6970 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in CHKINE' | |
6971 | IREJ = 1 | |
6972 | RETURN | |
6973 | END | |
6974 | ||
6975 | *$ CREATE DT_CH2RES.FOR | |
6976 | *COPY DT_CH2RES | |
6977 | * | |
6978 | *===ch2res=============================================================* | |
6979 | * | |
6980 | SUBROUTINE DT_CH2RES(IF1,IF2,IF3,IF4,IDR,IDXR, | |
6981 | & AM,AMN,IMODE,IREJ) | |
6982 | ||
6983 | ************************************************************************ | |
6984 | * Check chains for resonance production. * | |
6985 | * This subroutine replaces COMCMA/COBCMA/COMCM2 * | |
6986 | * input: * | |
6987 | * IF1,2,3,4 input flavors (q,aq in any order) * | |
6988 | * AM chain mass * | |
6989 | * MODE = 1 check q-aq chain for meson-resonance * | |
6990 | * = 2 check q-qq, aq-aqaq chain for baryon-resonance * | |
6991 | * = 3 check qq-aqaq chain for lower mass cut * | |
6992 | * output: * | |
6993 | * IDR = 0 no resonances found * | |
6994 | * = -1 pseudoscalar meson/octet baryon * | |
6995 | * = 1 vector-meson/decuplet baryon * | |
6996 | * IDXR BAMJET-index of corresponding resonance * | |
6997 | * AMN mass of corresponding resonance * | |
6998 | * * | |
6999 | * IREJ rejection flag * | |
7000 | * This version dated 06.01.95 is written by S. Roesler * | |
7001 | ************************************************************************ | |
7002 | ||
7003 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
7004 | SAVE | |
7005 | PARAMETER ( LINP = 10 , | |
7006 | & LOUT = 6 , | |
7007 | & LDAT = 9 ) | |
7008 | ||
7009 | * particle properties (BAMJET index convention) | |
7010 | CHARACTER*8 ANAME | |
7011 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
7012 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
7013 | * quark-content to particle index conversion (DTUNUC 1.x) | |
7014 | COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21), | |
7015 | & IA08(6,21),IA10(6,21) | |
7016 | * rejection counter | |
7017 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
7018 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
7019 | & IREXCI(3),IRDIFF(2),IRINC | |
7020 | * flags for input different options | |
7021 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
7022 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
7023 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
7024 | ||
7025 | DIMENSION IF(4),JF(4) | |
7026 | ||
7027 | **sr 4.7. test | |
7028 | C DATA AMLOM,AMLOB /0.08D0,0.2D0/ | |
7029 | DATA AMLOM,AMLOB /0.1D0,0.7D0/ | |
7030 | ** | |
7031 | C DATA AMLOM,AMLOB /0.001D0,0.001D0/ | |
7032 | ||
7033 | MODE = ABS(IMODE) | |
7034 | ||
7035 | IF ((MODE.LT.1).OR.(MODE.GT.3)) THEN | |
7036 | WRITE(LOUT,1000) MODE | |
7037 | 1000 FORMAT(1X,'CH2RES: MODE ',I4,' not supported!',/, | |
7038 | & 1X,' program stopped') | |
7039 | STOP | |
7040 | ENDIF | |
7041 | ||
7042 | AMX = AM | |
7043 | IREJ = 0 | |
7044 | IDR = 0 | |
7045 | IDXR = 0 | |
7046 | AMN = AMX | |
7047 | IF ((AM.LE.0.0D0).AND.(MODE.EQ.1)) AMX = AMLOM | |
7048 | IF ((AM.LE.0.0D0).AND.(MODE.EQ.2)) AMX = AMLOB | |
7049 | ||
7050 | IF(1) = IF1 | |
7051 | IF(2) = IF2 | |
7052 | IF(3) = IF3 | |
7053 | IF(4) = IF4 | |
7054 | NF = 0 | |
7055 | DO 100 I=1,4 | |
7056 | IF (IF(I).NE.0) THEN | |
7057 | NF = NF+1 | |
7058 | JF(NF) = IF(I) | |
7059 | ENDIF | |
7060 | 100 CONTINUE | |
7061 | IF (NF.LE.MODE) THEN | |
7062 | WRITE(LOUT,1001) MODE,IF | |
7063 | 1001 FORMAT(1X,'CH2RES: inconsistent input flavors in MODE ', | |
7064 | & I4,' IF1 = ',I4,' IF2 = ',I4,' IF3 = ',I4,' IF4 = ',I4) | |
7065 | GOTO 9999 | |
7066 | ENDIF | |
7067 | ||
7068 | GOTO (1,2,3) MODE | |
7069 | ||
7070 | * check for meson resonance | |
7071 | 1 CONTINUE | |
7072 | IFQ = JF(1) | |
7073 | IFAQ = ABS(JF(2)) | |
7074 | IF (JF(2).GT.0) THEN | |
7075 | IFQ = JF(2) | |
7076 | IFAQ = ABS(JF(1)) | |
7077 | ENDIF | |
7078 | IFPS = IMPS(IFAQ,IFQ) | |
7079 | IFV = IMVE(IFAQ,IFQ) | |
7080 | AMPS = AAM(IFPS) | |
7081 | AMV = AAM(IFV) | |
7082 | AMHI = AMV+0.3D0 | |
7083 | IF (AMX.LT.AMV) THEN | |
7084 | IF (AMX.LT.AMPS) THEN | |
7085 | IF (IMODE.GT.0) THEN | |
7086 | IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOM)) GOTO 9999 | |
7087 | ELSE | |
7088 | IF (AMX.LT.0.8D0*AMPS) GOTO 9999 | |
7089 | ENDIF | |
7090 | LOMRES = LOMRES+1 | |
7091 | ENDIF | |
7092 | * replace chain by pseudoscalar meson | |
7093 | IDR = -1 | |
7094 | IDXR = IFPS | |
7095 | AMN = AMPS | |
7096 | ELSEIF (AMX.LT.AMHI) THEN | |
7097 | * replace chain by vector-meson | |
7098 | IDR = 1 | |
7099 | IDXR = IFV | |
7100 | AMN = AMV | |
7101 | ENDIF | |
7102 | RETURN | |
7103 | ||
7104 | * check for baryon resonance | |
7105 | 2 CONTINUE | |
7106 | CALL DT_DBKLAS(JF(1),JF(2),JF(3),JB8,JB10) | |
7107 | AM8 = AAM(JB8) | |
7108 | AM10 = AAM(JB10) | |
7109 | AMHI = AM10+0.3D0 | |
7110 | IF (AMX.LT.AM10) THEN | |
7111 | IF (AMX.LT.AM8) THEN | |
7112 | IF (IMODE.GT.0) THEN | |
7113 | IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOB)) GOTO 9999 | |
7114 | ELSE | |
7115 | IF (AMX.LT.0.8D0*AM8) GOTO 9999 | |
7116 | ENDIF | |
7117 | LOBRES = LOBRES+1 | |
7118 | ENDIF | |
7119 | * replace chain by oktet baryon | |
7120 | IDR = -1 | |
7121 | IDXR = JB8 | |
7122 | AMN = AM8 | |
7123 | ELSEIF (AMX.LT.AMHI) THEN | |
7124 | IDR = 1 | |
7125 | IDXR = JB10 | |
7126 | AMN = AM10 | |
7127 | ENDIF | |
7128 | RETURN | |
7129 | ||
7130 | * check qq-aqaq for lower mass cut | |
7131 | 3 CONTINUE | |
7132 | * empirical definition of AMHI to allow for (b-antib)-pair prod. | |
7133 | AMHI = 2.5D0 | |
7134 | IF (AMX.LT.AMHI) GOTO 9999 | |
7135 | RETURN | |
7136 | ||
7137 | 9999 CONTINUE | |
7138 | IF ((IOULEV(1).GT.0).AND.(IMODE.GT.0)) | |
7139 | & WRITE(LOUT,*) 'rejected 1 in CH2RES',IMODE | |
7140 | IREJ = 1 | |
7141 | IRRES(2) = IRRES(2)+1 | |
7142 | RETURN | |
7143 | END | |
7144 | ||
7145 | *$ CREATE DT_RJSEAC.FOR | |
7146 | *COPY DT_RJSEAC | |
7147 | * | |
7148 | *===rjseac=============================================================* | |
7149 | * | |
7150 | SUBROUTINE DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ) | |
7151 | ||
7152 | ************************************************************************ | |
7153 | * ReJection of SEA-sea Chains. * | |
7154 | * MOP1/2 entries of projectile sea-partons in DTEVT1 * | |
7155 | * MOT1/2 entries of projectile sea-partons in DTEVT1 * | |
7156 | * This version dated 16.01.95 is written by S. Roesler * | |
7157 | ************************************************************************ | |
7158 | ||
7159 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
7160 | SAVE | |
7161 | PARAMETER ( LINP = 10 , | |
7162 | & LOUT = 6 , | |
7163 | & LDAT = 9 ) | |
7164 | PARAMETER (TINY10=1.0D-10,ZERO=0.0D0) | |
7165 | ||
7166 | * event history | |
7167 | PARAMETER (NMXHKK=200000) | |
7168 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
7169 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
7170 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
7171 | * extended event history | |
7172 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
7173 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
7174 | & IHIST(2,NMXHKK) | |
7175 | * statistics | |
7176 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
7177 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
7178 | & ICEVTG(8,0:30) | |
7179 | ||
7180 | DIMENSION IDXSEA(2,2),IDXNUC(2),ISTVAL(2) | |
7181 | ||
7182 | IREJ = 0 | |
7183 | ||
7184 | * projectile sea q-aq-pair | |
7185 | * indices of sea-pair | |
7186 | IDXSEA(1,1) = MOP1 | |
7187 | IDXSEA(1,2) = MOP2 | |
7188 | * index of mother-nucleon | |
7189 | IDXNUC(1) = JMOHKK(1,MOP1) | |
7190 | * status of valence quarks to be corrected | |
7191 | ISTVAL(1) = -21 | |
7192 | ||
7193 | * target sea q-aq-pair | |
7194 | * indices of sea-pair | |
7195 | IDXSEA(2,1) = MOT1 | |
7196 | IDXSEA(2,2) = MOT2 | |
7197 | * index of mother-nucleon | |
7198 | IDXNUC(2) = JMOHKK(1,MOT1) | |
7199 | * status of valence quarks to be corrected | |
7200 | ISTVAL(2) = -22 | |
7201 | ||
7202 | DO 1 N=1,2 | |
7203 | IDONE = 0 | |
7204 | DO 2 I=NPOINT(2),NHKK | |
7205 | IF ((ISTHKK(I).EQ.ISTVAL(N)).AND. | |
7206 | & (JMOHKK(1,I).EQ.IDXNUC(N))) THEN | |
7207 | * valence parton found | |
7208 | * inrease 4-momentum by sea 4-momentum | |
7209 | DO 3 K=1,4 | |
7210 | PHKK(K,I) = PHKK(K,I)+PHKK(K,IDXSEA(N,1))+ | |
7211 | & PHKK(K,IDXSEA(N,2)) | |
7212 | 3 CONTINUE | |
7213 | PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2- | |
7214 | & PHKK(2,I)**2-PHKK(3,I)**2)) | |
7215 | * "cancel" sea-pair | |
7216 | DO 4 J=1,2 | |
7217 | ISTHKK(IDXSEA(N,J)) = 100 | |
7218 | IDHKK(IDXSEA(N,J)) = 0 | |
7219 | JMOHKK(1,IDXSEA(N,J)) = 0 | |
7220 | JMOHKK(2,IDXSEA(N,J)) = 0 | |
7221 | JDAHKK(1,IDXSEA(N,J)) = 0 | |
7222 | JDAHKK(2,IDXSEA(N,J)) = 0 | |
7223 | DO 5 K=1,4 | |
7224 | PHKK(K,IDXSEA(N,J)) = ZERO | |
7225 | VHKK(K,IDXSEA(N,J)) = ZERO | |
7226 | WHKK(K,IDXSEA(N,J)) = ZERO | |
7227 | 5 CONTINUE | |
7228 | PHKK(5,IDXSEA(N,J)) = ZERO | |
7229 | 4 CONTINUE | |
7230 | IDONE = 1 | |
7231 | ENDIF | |
7232 | 2 CONTINUE | |
7233 | IF (IDONE.NE.1) THEN | |
7234 | WRITE(LOUT,1000) NEVHKK,MOP1,MOP2,MOT1,MOT2 | |
7235 | 1000 FORMAT(1X,'RJSEAC: event ',I8,': inconsistent event', | |
7236 | & '-record!',/,1X,' sea-quark pairs ', | |
7237 | & 2I5,4X,2I5,' could not be canceled!') | |
7238 | GOTO 9999 | |
7239 | ENDIF | |
7240 | 1 CONTINUE | |
7241 | ICRJSS = ICRJSS+1 | |
7242 | RETURN | |
7243 | ||
7244 | 9999 CONTINUE | |
7245 | IREJ = 1 | |
7246 | RETURN | |
7247 | END | |
7248 | ||
7249 | *$ CREATE DT_VV2SCH.FOR | |
7250 | *COPY DT_VV2SCH | |
7251 | * | |
7252 | *===vv2sch=============================================================* | |
7253 | * | |
7254 | SUBROUTINE DT_VV2SCH | |
7255 | ||
7256 | ************************************************************************ | |
7257 | * Change Valence-Valence chain systems to Single CHain systems for * | |
7258 | * hadron-nucleus collisions with meson or antibaryon projectile. * | |
7259 | * (Reggeon contribution) * | |
7260 | * The single chain system is approximately treated as one chain and a * | |
7261 | * meson at rest. * | |
7262 | * This version dated 18.01.95 is written by S. Roesler * | |
7263 | ************************************************************************ | |
7264 | ||
7265 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
7266 | SAVE | |
7267 | PARAMETER ( LINP = 10 , | |
7268 | & LOUT = 6 , | |
7269 | & LDAT = 9 ) | |
7270 | PARAMETER (ZERO=0.0D0,TINY7=1.0D-7,TINY3=1.0D-3) | |
7271 | ||
7272 | LOGICAL LSTART | |
7273 | ||
7274 | * event history | |
7275 | PARAMETER (NMXHKK=200000) | |
7276 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
7277 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
7278 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
7279 | * extended event history | |
7280 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
7281 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
7282 | & IHIST(2,NMXHKK) | |
7283 | * flags for input different options | |
7284 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
7285 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
7286 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
7287 | * statistics | |
7288 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
7289 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
7290 | & ICEVTG(8,0:30) | |
7291 | ||
7292 | DIMENSION IF(4,2),MO(4),PP1(4),PP2(4),PT1(4),PT2(4),PCH1(4), | |
7293 | & PCH2(4) | |
7294 | ||
7295 | DATA LSTART /.TRUE./ | |
7296 | ||
7297 | IFSC = 0 | |
7298 | IF (LSTART) THEN | |
7299 | WRITE(LOUT,1000) | |
7300 | 1000 FORMAT(/,1X,'VV2SCH: Reggeon contribution to valance-', | |
7301 | & 'valence chains treated') | |
7302 | LSTART = .FALSE. | |
7303 | ENDIF | |
7304 | ||
7305 | NSTOP = NHKK | |
7306 | ||
7307 | * get index of first chain | |
7308 | DO 1 I=NPOINT(3),NHKK | |
7309 | IF (IDHKK(I).EQ.88888) THEN | |
7310 | NC = I | |
7311 | GOTO 2 | |
7312 | ENDIF | |
7313 | 1 CONTINUE | |
7314 | ||
7315 | 2 CONTINUE | |
7316 | IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888) | |
7317 | & .AND.(NC.LT.NSTOP)) THEN | |
7318 | * get valence-valence chains | |
7319 | IF ((IDCH(NC).EQ.8).AND.(IDCH(NC+3).EQ.8)) THEN | |
7320 | * get "mother"-hadron indices | |
7321 | MO1 = JMOHKK(1,JMOHKK(1,JMOHKK(1,NC))) | |
7322 | MO2 = JMOHKK(1,JMOHKK(1,JMOHKK(2,NC))) | |
7323 | KPROJ = IDT_ICIHAD(IDHKK(MO1)) | |
7324 | KTARG = IDT_ICIHAD(IDHKK(MO2)) | |
7325 | * Lab momentum of projectile hadron | |
7326 | CALL DT_LTNUC(PHKK(3,MO1),PHKK(4,MO1),PPZ,PPE,-3) | |
7327 | PTOT = SQRT(PHKK(1,MO1)**2+PHKK(2,MO1)**2+ | |
7328 | & PHKK(3,MO1)**2) | |
7329 | ||
7330 | SICHAP = DT_PHNSCH(KPROJ,KTARG,PTOT) | |
7331 | IF (DT_RNDM(PTOT).LE.SICHAP) THEN | |
7332 | ICVV2S = ICVV2S+1 | |
7333 | * single chain requested | |
7334 | * get flavors of chain-end partons | |
7335 | MO(1) = JMOHKK(1,NC) | |
7336 | MO(2) = JMOHKK(2,NC) | |
7337 | MO(3) = JMOHKK(1,NC+3) | |
7338 | MO(4) = JMOHKK(2,NC+3) | |
7339 | DO 3 I=1,4 | |
7340 | IF(I,1) = IDT_IPDG2B(IDHKK(MO(I)),1,2) | |
7341 | IF(I,2) = 0 | |
7342 | IF (ABS(IDHKK(MO(I))).GE.1000) | |
7343 | & IF(I,2) = IDT_IPDG2B(IDHKK(MO(I)),2,2) | |
7344 | 3 CONTINUE | |
7345 | * which one is the q-aq chain? | |
7346 | * N1,N1+1 - DTEVT1-entries for q-aq system | |
7347 | * N2,N2+1 - DTEVT1-entries for the other chain | |
7348 | IF ((IF(1,2).EQ.0).AND.(IF(2,2).EQ.0)) THEN | |
7349 | K1 = 1 | |
7350 | K2 = 3 | |
7351 | N1 = NC-2 | |
7352 | N2 = NC+1 | |
7353 | ELSEIF ((IF(3,2).EQ.0).AND.(IF(4,2).EQ.0)) THEN | |
7354 | K1 = 3 | |
7355 | K2 = 1 | |
7356 | N1 = NC+1 | |
7357 | N2 = NC-2 | |
7358 | ELSE | |
7359 | GOTO 10 | |
7360 | ENDIF | |
7361 | DO 4 K=1,4 | |
7362 | PP1(K) = PHKK(K,N1) | |
7363 | PT1(K) = PHKK(K,N1+1) | |
7364 | PP2(K) = PHKK(K,N2) | |
7365 | PT2(K) = PHKK(K,N2+1) | |
7366 | 4 CONTINUE | |
7367 | AMCH1 = PHKK(5,N1+2) | |
7368 | AMCH2 = PHKK(5,N2+2) | |
7369 | * get meson-identity corresponding to flavors of q-aq chain | |
7370 | ITMP = IRESRJ | |
7371 | IRESRJ = 0 | |
7372 | CALL DT_CH2RES(IF(K1,1),IF(K1+1,1),0,0,IDR1,IDXR1, | |
7373 | & ZERO,AMCH1N,1,IDUM) | |
7374 | IRESRJ = ITMP | |
7375 | * change kinematics of chains | |
7376 | CALL DT_CHKINE(PP1,IDHKK(N1), PP2,IDHKK(N2), | |
7377 | & PT1,IDHKK(N1+1),PT2,IDHKK(N2+1), | |
7378 | & AMCH1,AMCH1N,AMCH2,IREJ1) | |
7379 | IF (IREJ1.NE.0) GOTO 10 | |
7380 | * check second chain for resonance | |
7381 | IDCHAI = 2 | |
7382 | IF ((IF(K2,2).NE.0).AND.(IF(K2+1,2).NE.0)) IDCHAI = 3 | |
7383 | CALL DT_CH2RES(IF(K2,1),IF(K2,2),IF(K2+1,1),IF(K2+1,2), | |
7384 | & IDR2,IDXR2,AMCH2,AMCH2N,IDCHAI,IREJ1) | |
7385 | IF (IREJ1.NE.0) GOTO 10 | |
7386 | IF (IDR2.NE.0) IDR2 = 100*IDR2 | |
7387 | * add partons and chains to DTEVT1 | |
7388 | DO 5 K=1,4 | |
7389 | PCH1(K) = PP1(K)+PT1(K) | |
7390 | PCH2(K) = PP2(K)+PT2(K) | |
7391 | 5 CONTINUE | |
7392 | CALL DT_EVTPUT(ISTHKK(N1),IDHKK(N1),N1,0,PP1(1),PP1(2), | |
7393 | & PP1(3),PP1(4),0,0,0) | |
7394 | CALL DT_EVTPUT(ISTHKK(N1+1),IDHKK(N1+1),N1+1,0,PT1(1), | |
7395 | & PT1(2),PT1(3),PT1(4),0,0,0) | |
7396 | KCH = ISTHKK(N1+2)+100 | |
7397 | CALL DT_EVTPUT(KCH,88888,-2,-1,PCH1(1),PCH1(2),PCH1(3), | |
7398 | & PCH1(4),IDR1,IDXR1,IDCH(N1+2)) | |
7399 | IDHKK(N1+2) = 22222 | |
7400 | CALL DT_EVTPUT(ISTHKK(N2),IDHKK(N2),N2,0,PP2(1),PP2(2), | |
7401 | & PP2(3),PP2(4),0,0,0) | |
7402 | CALL DT_EVTPUT(ISTHKK(N2+1),IDHKK(N2+1),N2+1,0,PT2(1), | |
7403 | & PT2(2),PT2(3),PT2(4),0,0,0) | |
7404 | KCH = ISTHKK(N2+2)+100 | |
7405 | CALL DT_EVTPUT(KCH,88888,-2,-1,PCH2(1),PCH2(2),PCH2(3), | |
7406 | & PCH2(4),IDR2,IDXR2,IDCH(N2+2)) | |
7407 | IDHKK(N2+2) = 22222 | |
7408 | ENDIF | |
7409 | ENDIF | |
7410 | ELSE | |
7411 | GOTO 11 | |
7412 | ENDIF | |
7413 | 10 CONTINUE | |
7414 | NC = NC+6 | |
7415 | GOTO 2 | |
7416 | ||
7417 | 11 CONTINUE | |
7418 | ||
7419 | RETURN | |
7420 | END | |
7421 | ||
7422 | *$ CREATE DT_PHNSCH.FOR | |
7423 | *COPY DT_PHNSCH | |
7424 | * | |
7425 | *=== phnsch ===========================================================* | |
7426 | * | |
7427 | DOUBLE PRECISION FUNCTION DT_PHNSCH( KP, KTARG, PLAB ) | |
7428 | ||
7429 | *----------------------------------------------------------------------* | |
7430 | * * | |
7431 | * Probability for Hadron Nucleon Single CHain interactions: * | |
7432 | * * | |
7433 | * Created on 30 december 1993 by Alfredo Ferrari & Paola Sala * | |
7434 | * Infn - Milan * | |
7435 | * * | |
7436 | * Last change on 04-jan-94 by Alfredo Ferrari * | |
7437 | * * | |
7438 | * modified by J.R.for use in DTUNUC 6.1.94 * | |
7439 | * * | |
7440 | * Input variables: * | |
7441 | * Kp = hadron projectile index (Part numbering * | |
7442 | * scheme) * | |
7443 | * Ktarg = target nucleon index (1=proton, 8=neutron) * | |
7444 | * Plab = projectile laboratory momentum (GeV/c) * | |
7445 | * Output variable: * | |
7446 | * Phnsch = probability per single chain (particle * | |
7447 | * exchange) interactions * | |
7448 | * * | |
7449 | *----------------------------------------------------------------------* | |
7450 | ||
7451 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
7452 | SAVE | |
7453 | ||
7454 | PARAMETER ( LUNOUT = 6 ) | |
7455 | PARAMETER ( LUNERR = 6 ) | |
7456 | PARAMETER ( ONEPLS = 1.000000000000001 D+00 ) | |
7457 | PARAMETER ( ZERZER = 0.D+00 ) | |
7458 | PARAMETER ( ONEONE = 1.D+00 ) | |
7459 | PARAMETER ( TWOTWO = 2.D+00 ) | |
7460 | PARAMETER ( FIVFIV = 5.D+00 ) | |
7461 | PARAMETER ( HLFHLF = 0.5D+00 ) | |
7462 | ||
7463 | PARAMETER ( NALLWP = 39 ) | |
7464 | PARAMETER ( IDMAXP = 210 ) | |
7465 | ||
7466 | DIMENSION ICHRGE(39),AM(39) | |
7467 | ||
7468 | * particle properties (BAMJET index convention) | |
7469 | CHARACTER*8 ANAME | |
7470 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
7471 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
7472 | ||
7473 | DIMENSION KPTOIP(210) | |
7474 | * auxiliary common for reggeon exchange (DTUNUC 1.x) | |
7475 | COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6), | |
7476 | & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6), | |
7477 | & IQTCHR(-6:6),MQUARK(3,39) | |
7478 | ||
7479 | DIMENSION SGTCOE (5,33), IHLP (NALLWP) | |
7480 | DIMENSION SGTCO1(5,10),SGTCO2(5,8),SGTCO3(5,15) | |
454792a9 | 7481 | CPH SAVE SGTCOE, IHLP |
7482 | CPH SAVE IQFSC1, IQFSC2, IQBSC1, IQBSC2 | |
9aaba0d6 | 7483 | EQUIVALENCE (SGTCO1(1,1),SGTCOE(1,1)) |
7484 | EQUIVALENCE (SGTCO2(1,1),SGTCOE(1,11)) | |
7485 | EQUIVALENCE (SGTCO3(1,1),SGTCOE(1,19)) | |
7486 | ||
7487 | * Conversion from part to paprop numbering | |
7488 | DATA KPTOIP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, | |
7489 | & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 66*0, | |
7490 | & 34, 36, 31, 32, 33, 35, 37, 5*0, 38, 5*0, 39, 19*0, 27, 28, 74*0/ | |
7491 | ||
7492 | * 1=baryon, 2=pion, 3=kaon, 4=antibaryon: | |
7493 | DATA IHLP/1,4,5*0,1,4,2*0,3,2*2,2*3,1,4,3,3*1,2, | |
7494 | & 2*3, 2, 4*0, 3*4, 1, 4, 1, 4, 1, 4 / | |
7495 | C DATA ( ( SGTCOE (J,I), J=1,5 ), I=1,10 ) / | |
7496 | DATA SGTCO1 / | |
7497 | * 1st reaction: gamma p total | |
7498 | &0.147 D+00, ZERZER , ZERZER , 0.0022D+00, -0.0170D+00, | |
7499 | * 2nd reaction: gamma d total | |
7500 | &0.300 D+00, ZERZER , ZERZER , 0.0095D+00, -0.057 D+00, | |
7501 | * 3rd reaction: pi+ p total | |
7502 | &16.4 D+00, 19.3D+00, -0.42D+00, 0.19 D+00, ZERZER , | |
7503 | * 4th reaction: pi- p total | |
7504 | &33.0 D+00, 14.0D+00, -1.36D+00, 0.456 D+00, -4.03 D+00, | |
7505 | * 5th reaction: pi+/- d total | |
7506 | &56.8 D+00, 42.2D+00, -1.45D+00, 0.65 D+00, -5.39 D+00, | |
7507 | * 6th reaction: K+ p total | |
7508 | &18.1 D+00, ZERZER , ZERZER , 0.26 D+00, -1.0 D+00, | |
7509 | * 7th reaction: K+ n total | |
7510 | &18.7 D+00, ZERZER , ZERZER , 0.21 D+00, -0.89 D+00, | |
7511 | * 8th reaction: K+ d total | |
7512 | &34.2 D+00, 7.9 D+00, -2.1 D+00, 0.346 D+00, -0.99 D+00, | |
7513 | * 9th reaction: K- p total | |
7514 | &32.1 D+00, ZERZER , ZERZER , 0.66 D+00, -5.6 D+00, | |
7515 | * 10th reaction: K- n total | |
7516 | &25.2 D+00, ZERZER , ZERZER , 0.38 D+00, -2.9 D+00/ | |
7517 | C DATA ( ( SGTCOE (J,I), J=1,5 ), I=11,18 ) / | |
7518 | DATA SGTCO2 / | |
7519 | * 11th reaction: K- d total | |
7520 | &57.6 D+00, ZERZER , ZERZER , 1.17 D+00, -9.5 D+00, | |
7521 | * 12th reaction: p p total | |
7522 | &48.0 D+00, ZERZER , ZERZER , 0.522 D+00, -4.51 D+00, | |
7523 | * 13th reaction: p n total | |
7524 | &47.30 D+00, ZERZER , ZERZER , 0.513 D+00, -4.27 D+00, | |
7525 | * 14th reaction: p d total | |
7526 | &91.3 D+00, ZERZER , ZERZER , 1.05 D+00, -8.8 D+00, | |
7527 | * 15th reaction: pbar p total | |
7528 | &38.4 D+00, 77.6D+00, -0.64D+00, 0.26 D+00, -1.2 D+00, | |
7529 | * 16th reaction: pbar n total | |
7530 | &ZERZER ,133.6D+00, -0.70D+00, -1.22 D+00, 13.7 D+00, | |
7531 | * 17th reaction: pbar d total | |
7532 | &112. D+00, 125.D+00, -1.08D+00, 1.14 D+00, -12.4 D+00, | |
7533 | * 18th reaction: Lamda p total | |
7534 | &30.4 D+00, ZERZER , ZERZER , ZERZER , 1.6 D+00/ | |
7535 | C DATA ( ( SGTCOE (J,I), J=1,5 ), I=19,33 ) / | |
7536 | DATA SGTCO3 / | |
7537 | * 19th reaction: pi+ p elastic | |
7538 | &ZERZER , 11.4D+00, -0.4 D+00, 0.079 D+00, ZERZER , | |
7539 | * 20th reaction: pi- p elastic | |
7540 | &1.76 D+00, 11.2D+00, -0.64D+00, 0.043 D+00, ZERZER , | |
7541 | * 21st reaction: K+ p elastic | |
7542 | &5.0 D+00, 8.1 D+00, -1.8 D+00, 0.16 D+00, -1.3 D+00, | |
7543 | * 22nd reaction: K- p elastic | |
7544 | &7.3 D+00, ZERZER , ZERZER , 0.29 D+00, -2.40 D+00, | |
7545 | * 23rd reaction: p p elastic | |
7546 | &11.9 D+00, 26.9D+00, -1.21D+00, 0.169 D+00, -1.85 D+00, | |
7547 | * 24th reaction: p d elastic | |
7548 | &16.1 D+00, ZERZER , ZERZER , 0.32 D+00, -3.4 D+00, | |
7549 | * 25th reaction: pbar p elastic | |
7550 | &10.2 D+00, 52.7D+00, -1.16D+00, 0.125 D+00, -1.28 D+00, | |
7551 | * 26th reaction: pbar p elastic bis | |
7552 | &10.6 D+00, 53.1D+00, -1.19D+00, 0.136 D+00, -1.41 D+00, | |
7553 | * 27th reaction: pbar n elastic | |
7554 | &36.5 D+00, ZERZER , ZERZER , ZERZER , -11.9 D+00, | |
7555 | * 28th reaction: Lamda p elastic | |
7556 | &12.3 D+00, ZERZER , ZERZER , ZERZER , -2.4 D+00, | |
7557 | * 29th reaction: K- p ela bis | |
7558 | &7.24 D+00, 46.0D+00, -4.71D+00, 0.279 D+00, -2.35 D+00, | |
7559 | * 30th reaction: pi- p cx | |
7560 | &ZERZER ,0.912D+00, -1.22D+00, ZERZER , ZERZER , | |
7561 | * 31st reaction: K- p cx | |
7562 | &ZERZER , 3.39D+00, -1.75D+00, ZERZER , ZERZER , | |
7563 | * 32nd reaction: K+ n cx | |
7564 | &ZERZER , 7.18D+00, -2.01D+00, ZERZER , ZERZER , | |
7565 | * 33rd reaction: pbar p cx | |
7566 | &ZERZER , 18.8D+00, -2.01D+00, ZERZER , ZERZER / | |
7567 | * | |
7568 | * +-------------------------------------------------------------------* | |
7569 | ICHRGE(KTARG)=IICH(KTARG) | |
7570 | AM (KTARG)=AAM (KTARG) | |
7571 | * | Check for pi0 (d-dbar) | |
7572 | IF ( KP .NE. 26 ) THEN | |
7573 | IP = KPTOIP (KP) | |
7574 | IF(IP.EQ.0)IP=1 | |
7575 | ICHRGE(IP)=IICH(KP) | |
7576 | AM (IP)=AAM (KP) | |
7577 | * | | |
7578 | * +-------------------------------------------------------------------* | |
7579 | * | | |
7580 | ELSE | |
7581 | IP = 23 | |
7582 | ICHRGE(IP)=0 | |
7583 | END IF | |
7584 | * | | |
7585 | * +-------------------------------------------------------------------* | |
7586 | * +-------------------------------------------------------------------* | |
7587 | * | No such interactions for baryon-baryon | |
7588 | IF ( IIBAR (KP) .GT. 0 ) THEN | |
7589 | DT_PHNSCH = ZERZER | |
7590 | RETURN | |
7591 | * | | |
7592 | * +-------------------------------------------------------------------* | |
7593 | * | No "annihilation" diagram possible for K+ p/n | |
7594 | ELSE IF ( IP .EQ. 15 ) THEN | |
7595 | DT_PHNSCH = ZERZER | |
7596 | RETURN | |
7597 | * | | |
7598 | * +-------------------------------------------------------------------* | |
7599 | * | No "annihilation" diagram possible for K0 p/n | |
7600 | ELSE IF ( IP .EQ. 24 ) THEN | |
7601 | DT_PHNSCH = ZERZER | |
7602 | RETURN | |
7603 | * | | |
7604 | * +-------------------------------------------------------------------* | |
7605 | * | No "annihilation" diagram possible for Omebar p/n | |
7606 | ELSE IF ( IP .GE. 38 ) THEN | |
7607 | DT_PHNSCH = ZERZER | |
7608 | RETURN | |
7609 | END IF | |
7610 | * | | |
7611 | * +-------------------------------------------------------------------* | |
7612 | * +-------------------------------------------------------------------* | |
7613 | * | If the momentum is larger than 50 GeV/c, compute the single | |
7614 | * | chain probability at 50 GeV/c and extrapolate to the present | |
7615 | * | momentum according to 1/sqrt(s) | |
7616 | * | sigma = sigma_sch (50) * sqrt (s(50)/s) + sigma_dch | |
7617 | * | P_sch (50) = sigma_sch (50) / ( sigma_dch + sigma_sch (50) ) | |
7618 | * | sigma_dch / sigma_sch (50) = 1 / P_sch (50) - 1 | |
7619 | * | sigma_dch / sigma_sch = 1 / P_sch - 1 = ( 1 / P_sch (50) - 1 ) | |
7620 | * | x sqrt(s/s(50)) | |
7621 | * | P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ] | |
7622 | IF ( PLAB .GT. 50.D+00 ) THEN | |
7623 | PLA = 50.D+00 | |
7624 | AMPSQ = AM (IP)**2 | |
7625 | AMTSQ = AM (KTARG)**2 | |
7626 | EPROJ = SQRT ( PLAB**2 + AMPSQ ) | |
7627 | UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ | |
7628 | EPROJ = SQRT ( PLA**2 + AMPSQ ) | |
7629 | UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ | |
7630 | UMORAT = SQRT ( UMOSQ / UMO50 ) | |
7631 | * | | |
7632 | * +-------------------------------------------------------------------* | |
7633 | * | P < 3 GeV/c | |
7634 | ELSE IF ( PLAB .LT. 3.D+00 ) THEN | |
7635 | PLA = 3.D+00 | |
7636 | AMPSQ = AM (IP)**2 | |
7637 | AMTSQ = AM (KTARG)**2 | |
7638 | EPROJ = SQRT ( PLAB**2 + AMPSQ ) | |
7639 | UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ | |
7640 | EPROJ = SQRT ( PLA**2 + AMPSQ ) | |
7641 | UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ | |
7642 | UMORAT = SQRT ( UMOSQ / UMO50 ) | |
7643 | * | | |
7644 | * +-------------------------------------------------------------------* | |
7645 | * | P < 50 GeV/c | |
7646 | ELSE | |
7647 | PLA = PLAB | |
7648 | UMORAT = ONEONE | |
7649 | END IF | |
7650 | * | | |
7651 | * +-------------------------------------------------------------------* | |
7652 | ALGPLA = LOG (PLA) | |
7653 | * +-------------------------------------------------------------------* | |
7654 | * | Pions: | |
7655 | IF ( IHLP (IP) .EQ. 2 ) THEN | |
7656 | ACOF = SGTCOE (1,3) | |
7657 | BCOF = SGTCOE (2,3) | |
7658 | ENNE = SGTCOE (3,3) | |
7659 | CCOF = SGTCOE (4,3) | |
7660 | DCOF = SGTCOE (5,3) | |
7661 | * | Compute the pi+ p total cross section: | |
7662 | SPPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7663 | & + DCOF * ALGPLA | |
7664 | ACOF = SGTCOE (1,19) | |
7665 | BCOF = SGTCOE (2,19) | |
7666 | ENNE = SGTCOE (3,19) | |
7667 | CCOF = SGTCOE (4,19) | |
7668 | DCOF = SGTCOE (5,19) | |
7669 | * | Compute the pi+ p elastic cross section: | |
7670 | SPPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7671 | & + DCOF * ALGPLA | |
7672 | * | Compute the pi+ p inelastic cross section: | |
7673 | SPPPIN = SPPPTT - SPPPEL | |
7674 | ACOF = SGTCOE (1,4) | |
7675 | BCOF = SGTCOE (2,4) | |
7676 | ENNE = SGTCOE (3,4) | |
7677 | CCOF = SGTCOE (4,4) | |
7678 | DCOF = SGTCOE (5,4) | |
7679 | * | Compute the pi- p total cross section: | |
7680 | SPMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7681 | & + DCOF * ALGPLA | |
7682 | ACOF = SGTCOE (1,20) | |
7683 | BCOF = SGTCOE (2,20) | |
7684 | ENNE = SGTCOE (3,20) | |
7685 | CCOF = SGTCOE (4,20) | |
7686 | DCOF = SGTCOE (5,20) | |
7687 | * | Compute the pi- p elastic cross section: | |
7688 | SPMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7689 | & + DCOF * ALGPLA | |
7690 | * | Compute the pi- p inelastic cross section: | |
7691 | SPMPIN = SPMPTT - SPMPEL | |
7692 | SIGDIA = SPMPIN - SPPPIN | |
7693 | * | +----------------------------------------------------------------* | |
7694 | * | | Charged pions: besides isospin consideration it is supposed | |
7695 | * | | that (pi+ n)el is almost equal to (pi- p)el | |
7696 | * | | and (pi+ p)el " " " " (pi- n)el | |
7697 | * | | and all are almost equal among each others | |
7698 | * | | (reasonable above 5 GeV/c) | |
7699 | IF ( ICHRGE (IP) .NE. 0 ) THEN | |
7700 | KHELP = KTARG / 8 | |
7701 | JREAC = 3 + IP - 13 + ICHRGE (IP) * KHELP | |
7702 | ACOF = SGTCOE (1,JREAC) | |
7703 | BCOF = SGTCOE (2,JREAC) | |
7704 | ENNE = SGTCOE (3,JREAC) | |
7705 | CCOF = SGTCOE (4,JREAC) | |
7706 | DCOF = SGTCOE (5,JREAC) | |
7707 | * | | Compute the total cross section: | |
7708 | SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7709 | & + DCOF * ALGPLA | |
7710 | JREAC = 19 + IP - 13 + ICHRGE (IP) * KHELP | |
7711 | ACOF = SGTCOE (1,JREAC) | |
7712 | BCOF = SGTCOE (2,JREAC) | |
7713 | ENNE = SGTCOE (3,JREAC) | |
7714 | CCOF = SGTCOE (4,JREAC) | |
7715 | DCOF = SGTCOE (5,JREAC) | |
7716 | * | | Compute the elastic cross section: | |
7717 | SHNCEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7718 | & + DCOF * ALGPLA | |
7719 | * | | Compute the inelastic cross section: | |
7720 | SHNCIN = SHNCTT - SHNCEL | |
7721 | * | | Number of diagrams: | |
7722 | NDIAGR = 1 + IP - 13 + ICHRGE (IP) * KHELP | |
7723 | * | | Now compute the chain end (anti)quark-(anti)diquark | |
7724 | IQFSC1 = 1 + IP - 13 | |
7725 | IQFSC2 = 0 | |
7726 | IQBSC1 = 1 + KHELP | |
7727 | IQBSC2 = 1 + IP - 13 | |
7728 | * | | | |
7729 | * | +----------------------------------------------------------------* | |
7730 | * | | pi0: besides isospin consideration it is supposed that the | |
7731 | * | | elastic cross section is not very different from | |
7732 | * | | pi+ p and/or pi- p (reasonable above 5 GeV/c) | |
7733 | ELSE | |
7734 | KHELP = KTARG / 8 | |
7735 | K2HLP = ( KP - 23 ) / 3 | |
7736 | * | | Number of diagrams: | |
7737 | * | | For u ubar (k2hlp=0): | |
7738 | * NDIAGR = 2 - KHELP | |
7739 | * | | For d dbar (k2hlp=1): | |
7740 | * NDIAGR = 2 + KHELP - K2HLP | |
7741 | NDIAGR = 2 + KHELP * ( 2 * K2HLP - 1 ) - K2HLP | |
7742 | SHNCIN = HLFHLF * ( SPPPIN + SPMPIN ) | |
7743 | * | | Now compute the chain end (anti)quark-(anti)diquark | |
7744 | IQFSC1 = 1 + K2HLP | |
7745 | IQFSC2 = 0 | |
7746 | IQBSC1 = 1 + KHELP | |
7747 | IQBSC2 = 2 - K2HLP | |
7748 | END IF | |
7749 | * | | | |
7750 | * | +----------------------------------------------------------------* | |
7751 | * | end pi's | |
7752 | * +-------------------------------------------------------------------* | |
7753 | * | Kaons: | |
7754 | ELSE IF ( IHLP (IP) .EQ. 3 ) THEN | |
7755 | ACOF = SGTCOE (1,6) | |
7756 | BCOF = SGTCOE (2,6) | |
7757 | ENNE = SGTCOE (3,6) | |
7758 | CCOF = SGTCOE (4,6) | |
7759 | DCOF = SGTCOE (5,6) | |
7760 | * | Compute the K+ p total cross section: | |
7761 | SKPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7762 | & + DCOF * ALGPLA | |
7763 | ACOF = SGTCOE (1,21) | |
7764 | BCOF = SGTCOE (2,21) | |
7765 | ENNE = SGTCOE (3,21) | |
7766 | CCOF = SGTCOE (4,21) | |
7767 | DCOF = SGTCOE (5,21) | |
7768 | * | Compute the K+ p elastic cross section: | |
7769 | SKPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7770 | & + DCOF * ALGPLA | |
7771 | * | Compute the K+ p inelastic cross section: | |
7772 | SKPPIN = SKPPTT - SKPPEL | |
7773 | ACOF = SGTCOE (1,9) | |
7774 | BCOF = SGTCOE (2,9) | |
7775 | ENNE = SGTCOE (3,9) | |
7776 | CCOF = SGTCOE (4,9) | |
7777 | DCOF = SGTCOE (5,9) | |
7778 | * | Compute the K- p total cross section: | |
7779 | SKMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7780 | & + DCOF * ALGPLA | |
7781 | ACOF = SGTCOE (1,22) | |
7782 | BCOF = SGTCOE (2,22) | |
7783 | ENNE = SGTCOE (3,22) | |
7784 | CCOF = SGTCOE (4,22) | |
7785 | DCOF = SGTCOE (5,22) | |
7786 | * | Compute the K- p elastic cross section: | |
7787 | SKMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7788 | & + DCOF * ALGPLA | |
7789 | * | Compute the K- p inelastic cross section: | |
7790 | SKMPIN = SKMPTT - SKMPEL | |
7791 | SIGDIA = HLFHLF * ( SKMPIN - SKPPIN ) | |
7792 | * | +----------------------------------------------------------------* | |
7793 | * | | Charged Kaons: actually only K- | |
7794 | IF ( ICHRGE (IP) .NE. 0 ) THEN | |
7795 | KHELP = KTARG / 8 | |
7796 | * | | +-------------------------------------------------------------* | |
7797 | * | | | Proton target: | |
7798 | IF ( KHELP .EQ. 0 ) THEN | |
7799 | SHNCIN = SKMPIN | |
7800 | * | | | Number of diagrams: | |
7801 | NDIAGR = 2 | |
7802 | * | | | | |
7803 | * | | +-------------------------------------------------------------* | |
7804 | * | | | Neutron target: besides isospin consideration it is supposed | |
7805 | * | | | that (K- n)el is almost equal to (K- p)el | |
7806 | * | | | (reasonable above 5 GeV/c) | |
7807 | ELSE | |
7808 | ACOF = SGTCOE (1,10) | |
7809 | BCOF = SGTCOE (2,10) | |
7810 | ENNE = SGTCOE (3,10) | |
7811 | CCOF = SGTCOE (4,10) | |
7812 | DCOF = SGTCOE (5,10) | |
7813 | * | | | Compute the total cross section: | |
7814 | SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7815 | & + DCOF * ALGPLA | |
7816 | * | | | Compute the elastic cross section: | |
7817 | SHNCEL = SKMPEL | |
7818 | * | | | Compute the inelastic cross section: | |
7819 | SHNCIN = SHNCTT - SHNCEL | |
7820 | * | | | Number of diagrams: | |
7821 | NDIAGR = 1 | |
7822 | END IF | |
7823 | * | | | | |
7824 | * | | +-------------------------------------------------------------* | |
7825 | * | | Now compute the chain end (anti)quark-(anti)diquark | |
7826 | IQFSC1 = 3 | |
7827 | IQFSC2 = 0 | |
7828 | IQBSC1 = 1 + KHELP | |
7829 | IQBSC2 = 2 | |
7830 | * | | | |
7831 | * | +----------------------------------------------------------------* | |
7832 | * | | K0's: (actually only K0bar) | |
7833 | ELSE | |
7834 | KHELP = KTARG / 8 | |
7835 | * | | +-------------------------------------------------------------* | |
7836 | * | | | Proton target: (K0bar p)in supposed to be given by | |
7837 | * | | | (K- p)in - Sig_diagr | |
7838 | IF ( KHELP .EQ. 0 ) THEN | |
7839 | SHNCIN = SKMPIN - SIGDIA | |
7840 | * | | | Number of diagrams: | |
7841 | NDIAGR = 1 | |
7842 | * | | | | |
7843 | * | | +-------------------------------------------------------------* | |
7844 | * | | | Neutron target: (K0bar n)in supposed to be given by | |
7845 | * | | | (K- n)in + Sig_diagr | |
7846 | * | | | besides isospin consideration it is supposed | |
7847 | * | | | that (K- n)el is almost equal to (K- p)el | |
7848 | * | | | (reasonable above 5 GeV/c) | |
7849 | ELSE | |
7850 | ACOF = SGTCOE (1,10) | |
7851 | BCOF = SGTCOE (2,10) | |
7852 | ENNE = SGTCOE (3,10) | |
7853 | CCOF = SGTCOE (4,10) | |
7854 | DCOF = SGTCOE (5,10) | |
7855 | * | | | Compute the total cross section: | |
7856 | SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7857 | & + DCOF * ALGPLA | |
7858 | * | | | Compute the elastic cross section: | |
7859 | SHNCEL = SKMPEL | |
7860 | * | | | Compute the inelastic cross section: | |
7861 | SHNCIN = SHNCTT - SHNCEL + SIGDIA | |
7862 | * | | | Number of diagrams: | |
7863 | NDIAGR = 2 | |
7864 | END IF | |
7865 | * | | | | |
7866 | * | | +-------------------------------------------------------------* | |
7867 | * | | Now compute the chain end (anti)quark-(anti)diquark | |
7868 | IQFSC1 = 3 | |
7869 | IQFSC2 = 0 | |
7870 | IQBSC1 = 1 | |
7871 | IQBSC2 = 1 + KHELP | |
7872 | END IF | |
7873 | * | | | |
7874 | * | +----------------------------------------------------------------* | |
7875 | * | end Kaon's | |
7876 | * +-------------------------------------------------------------------* | |
7877 | * | Antinucleons: | |
7878 | ELSE IF ( IHLP (IP) .EQ. 4 .AND. IP .LE. 9 ) THEN | |
7879 | * | For momenta between 3 and 5 GeV/c the use of tabulated data | |
7880 | * | should be implemented! | |
7881 | ACOF = SGTCOE (1,15) | |
7882 | BCOF = SGTCOE (2,15) | |
7883 | ENNE = SGTCOE (3,15) | |
7884 | CCOF = SGTCOE (4,15) | |
7885 | DCOF = SGTCOE (5,15) | |
7886 | * | Compute the pbar p total cross section: | |
7887 | SAPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7888 | & + DCOF * ALGPLA | |
7889 | IF ( PLA .LT. FIVFIV ) THEN | |
7890 | JREAC = 26 | |
7891 | ELSE | |
7892 | JREAC = 25 | |
7893 | END IF | |
7894 | ACOF = SGTCOE (1,JREAC) | |
7895 | BCOF = SGTCOE (2,JREAC) | |
7896 | ENNE = SGTCOE (3,JREAC) | |
7897 | CCOF = SGTCOE (4,JREAC) | |
7898 | DCOF = SGTCOE (5,JREAC) | |
7899 | * | Compute the pbar p elastic cross section: | |
7900 | SAPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7901 | & + DCOF * ALGPLA | |
7902 | * | Compute the pbar p inelastic cross section: | |
7903 | SAPPIN = SAPPTT - SAPPEL | |
7904 | ACOF = SGTCOE (1,12) | |
7905 | BCOF = SGTCOE (2,12) | |
7906 | ENNE = SGTCOE (3,12) | |
7907 | CCOF = SGTCOE (4,12) | |
7908 | DCOF = SGTCOE (5,12) | |
7909 | * | Compute the p p total cross section: | |
7910 | SPPTOT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7911 | & + DCOF * ALGPLA | |
7912 | ACOF = SGTCOE (1,23) | |
7913 | BCOF = SGTCOE (2,23) | |
7914 | ENNE = SGTCOE (3,23) | |
7915 | CCOF = SGTCOE (4,23) | |
7916 | DCOF = SGTCOE (5,23) | |
7917 | * | Compute the p p elastic cross section: | |
7918 | SPPELA = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7919 | & + DCOF * ALGPLA | |
7920 | * | Compute the K- p inelastic cross section: | |
7921 | SPPINE = SPPTOT - SPPELA | |
7922 | SIGDIA = ( SAPPIN - SPPINE ) / FIVFIV | |
7923 | KHELP = KTARG / 8 | |
7924 | * | +----------------------------------------------------------------* | |
7925 | * | | Pbar: | |
7926 | IF ( ICHRGE (IP) .NE. 0 ) THEN | |
7927 | NDIAGR = 5 - KHELP | |
7928 | * | | +-------------------------------------------------------------* | |
7929 | * | | | Proton target: | |
7930 | IF ( KHELP .EQ. 0 ) THEN | |
7931 | * | | | Number of diagrams: | |
7932 | SHNCIN = SAPPIN | |
7933 | PUUBAR = 0.8D+00 | |
7934 | * | | | | |
7935 | * | | +-------------------------------------------------------------* | |
7936 | * | | | Neutron target: it is supposed that (ap n)el is almost equal | |
7937 | * | | | to (ap p)el (reasonable above 5 GeV/c) | |
7938 | ELSE | |
7939 | ACOF = SGTCOE (1,16) | |
7940 | BCOF = SGTCOE (2,16) | |
7941 | ENNE = SGTCOE (3,16) | |
7942 | CCOF = SGTCOE (4,16) | |
7943 | DCOF = SGTCOE (5,16) | |
7944 | * | | | Compute the total cross section: | |
7945 | SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2 | |
7946 | & + DCOF * ALGPLA | |
7947 | * | | | Compute the elastic cross section: | |
7948 | SHNCEL = SAPPEL | |
7949 | * | | | Compute the inelastic cross section: | |
7950 | SHNCIN = SHNCTT - SHNCEL | |
7951 | PUUBAR = HLFHLF | |
7952 | END IF | |
7953 | * | | | | |
7954 | * | | +-------------------------------------------------------------* | |
7955 | * | | Now compute the chain end (anti)quark-(anti)diquark | |
7956 | * | | there are different possibilities, make a random choiche: | |
7957 | IQFSC1 = -1 | |
7958 | RNCHEN = DT_RNDM(PUUBAR) | |
7959 | IF ( RNCHEN .LT. PUUBAR ) THEN | |
7960 | IQFSC2 = -2 | |
7961 | ELSE | |
7962 | IQFSC2 = -1 | |
7963 | END IF | |
7964 | IQBSC1 = -IQFSC1 + KHELP | |
7965 | IQBSC2 = -IQFSC2 | |
7966 | * | | | |
7967 | * | +----------------------------------------------------------------* | |
7968 | * | | nbar: | |
7969 | ELSE | |
7970 | NDIAGR = 4 + KHELP | |
7971 | * | | +-------------------------------------------------------------* | |
7972 | * | | | Proton target: (nbar p)in supposed to be given by | |
7973 | * | | | (pbar p)in - Sig_diagr | |
7974 | IF ( KHELP .EQ. 0 ) THEN | |
7975 | SHNCIN = SAPPIN - SIGDIA | |
7976 | PDDBAR = HLFHLF | |
7977 | * | | | | |
7978 | * | | +-------------------------------------------------------------* | |
7979 | * | | | Neutron target: (nbar n)el is supposed to be equal to | |
7980 | * | | | (pbar p)el (reasonable above 5 GeV/c) | |
7981 | ELSE | |
7982 | * | | | Compute the total cross section: | |
7983 | SHNCTT = SAPPTT | |
7984 | * | | | Compute the elastic cross section: | |
7985 | SHNCEL = SAPPEL | |
7986 | * | | | Compute the inelastic cross section: | |
7987 | SHNCIN = SHNCTT - SHNCEL | |
7988 | PDDBAR = 0.8D+00 | |
7989 | END IF | |
7990 | * | | | | |
7991 | * | | +-------------------------------------------------------------* | |
7992 | * | | Now compute the chain end (anti)quark-(anti)diquark | |
7993 | * | | there are different possibilities, make a random choiche: | |
7994 | IQFSC1 = -2 | |
7995 | RNCHEN = DT_RNDM(RNCHEN) | |
7996 | IF ( RNCHEN .LT. PDDBAR ) THEN | |
7997 | IQFSC2 = -1 | |
7998 | ELSE | |
7999 | IQFSC2 = -2 | |
8000 | END IF | |
8001 | IQBSC1 = -IQFSC1 + KHELP - 1 | |
8002 | IQBSC2 = -IQFSC2 | |
8003 | END IF | |
8004 | * | | | |
8005 | * | +----------------------------------------------------------------* | |
8006 | * | | |
8007 | * +-------------------------------------------------------------------* | |
8008 | * | Others: not yet implemented | |
8009 | ELSE | |
8010 | SIGDIA = ZERZER | |
8011 | SHNCIN = ONEONE | |
8012 | NDIAGR = 0 | |
8013 | DT_PHNSCH = ZERZER | |
8014 | RETURN | |
8015 | END IF | |
8016 | * | end others | |
8017 | * +-------------------------------------------------------------------* | |
8018 | DT_PHNSCH = NDIAGR * SIGDIA / SHNCIN | |
8019 | IQECHC = IQECHR (IQFSC1) + IQECHR (IQFSC2) + IQECHR (IQBSC1) | |
8020 | & + IQECHR (IQBSC2) | |
8021 | IQBCHC = IQBCHR (IQFSC1) + IQBCHR (IQFSC2) + IQBCHR (IQBSC1) | |
8022 | & + IQBCHR (IQBSC2) | |
8023 | IQECHC = IQECHC / 3 | |
8024 | IQBCHC = IQBCHC / 3 | |
8025 | IQSCHC = IQSCHR (IQFSC1) + IQSCHR (IQFSC2) + IQSCHR (IQBSC1) | |
8026 | & + IQSCHR (IQBSC2) | |
8027 | IQSPRO = IQSCHR (MQUARK(1,IP)) + IQSCHR (MQUARK(2,IP)) | |
8028 | & + IQSCHR (MQUARK(3,IP)) | |
8029 | * +-------------------------------------------------------------------* | |
8030 | * | Consistency check: | |
8031 | IF ( DT_PHNSCH .LE. ZERZER .OR. DT_PHNSCH .GT. ONEONE ) THEN | |
8032 | WRITE (LUNOUT,*)' *** Phnsch,kp,ktarg,pla', | |
8033 | & DT_PHNSCH,KP,KTARG,PLA,' ****' | |
8034 | WRITE (LUNERR,*)' *** Phnsch,kp,ktarg,pla', | |
8035 | & DT_PHNSCH,KP,KTARG,PLA,' ****' | |
8036 | DT_PHNSCH = MAX ( DT_PHNSCH, ZERZER ) | |
8037 | DT_PHNSCH = MIN ( DT_PHNSCH, ONEONE ) | |
8038 | END IF | |
8039 | * | | |
8040 | * +-------------------------------------------------------------------* | |
8041 | * +-------------------------------------------------------------------* | |
8042 | * | Consistency check: | |
8043 | IF ( IQSPRO .NE. IQSCHC .OR. ICHRGE (IP) + ICHRGE (KTARG) | |
8044 | & .NE. IQECHC .OR. IIBAR (KP) + IIBAR (KTARG) .NE. IQBCHC) THEN | |
8045 | WRITE (LUNOUT,*) | |
8046 | &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg', | |
8047 | & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG | |
8048 | WRITE (LUNERR,*) | |
8049 | &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg', | |
8050 | & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG | |
8051 | END IF | |
8052 | * | | |
8053 | * +-------------------------------------------------------------------* | |
8054 | * P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ] | |
8055 | IF ( UMORAT .GT. ONEPLS ) | |
8056 | & DT_PHNSCH = ONEONE / ( ( ONEONE / DT_PHNSCH | |
8057 | & - ONEONE ) * UMORAT + ONEONE ) | |
8058 | RETURN | |
8059 | * | |
8060 | ENTRY DT_SCHQUA ( JQFSC1, JQFSC2, JQBSC1, JQBSC2 ) | |
8061 | DT_SCHQUA = ONEONE | |
8062 | JQFSC1 = IQFSC1 | |
8063 | JQFSC2 = IQFSC2 | |
8064 | JQBSC1 = IQBSC1 | |
8065 | JQBSC2 = IQBSC2 | |
8066 | *=== End of function Phnsch ===========================================* | |
8067 | RETURN | |
8068 | END | |
8069 | ||
8070 | *$ CREATE DT_RESPT.FOR | |
8071 | *COPY DT_RESPT | |
8072 | * | |
8073 | *===respt==============================================================* | |
8074 | * | |
8075 | SUBROUTINE DT_RESPT | |
8076 | ||
8077 | ************************************************************************ | |
8078 | * Check DTEVT1 for two-resonance systems and sample intrinsic p_t. * | |
8079 | * This version dated 18.01.95 is written by S. Roesler * | |
8080 | ************************************************************************ | |
8081 | ||
8082 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
8083 | SAVE | |
8084 | PARAMETER ( LINP = 10 , | |
8085 | & LOUT = 6 , | |
8086 | & LDAT = 9 ) | |
8087 | PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3) | |
8088 | ||
8089 | * event history | |
8090 | PARAMETER (NMXHKK=200000) | |
8091 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
8092 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
8093 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
8094 | * extended event history | |
8095 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
8096 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
8097 | & IHIST(2,NMXHKK) | |
8098 | ||
8099 | * get index of first chain | |
8100 | DO 1 I=NPOINT(3),NHKK | |
8101 | IF (IDHKK(I).EQ.88888) THEN | |
8102 | NC = I | |
8103 | GOTO 2 | |
8104 | ENDIF | |
8105 | 1 CONTINUE | |
8106 | ||
8107 | 2 CONTINUE | |
8108 | IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)) THEN | |
8109 | C WRITE(LOUT,*)NC,NC+3,IDRES(NC),IDRES(NC+3) | |
8110 | * skip VV-,SS- systems | |
8111 | IF ((IDCH(NC ).NE.1).AND.(IDCH(NC ).NE.8).AND. | |
8112 | & (IDCH(NC+3).NE.1).AND.(IDCH(NC+3).NE.8)) THEN | |
8113 | * check if both "chains" are resonances | |
8114 | IF ((IDRES(NC).NE.0).AND.(IDRES(NC+3).NE.0)) THEN | |
8115 | CALL DT_SAPTRE(NC,NC+3) | |
8116 | ENDIF | |
8117 | ENDIF | |
8118 | ELSE | |
8119 | GOTO 3 | |
8120 | ENDIF | |
8121 | NC = NC+6 | |
8122 | GOTO 2 | |
8123 | ||
8124 | 3 CONTINUE | |
8125 | ||
8126 | RETURN | |
8127 | END | |
8128 | ||
8129 | *$ CREATE DT_EVTRES.FOR | |
8130 | *COPY DT_EVTRES | |
8131 | * | |
8132 | *===evtres=============================================================* | |
8133 | * | |
8134 | SUBROUTINE DT_EVTRES(IREJ) | |
8135 | ||
8136 | ************************************************************************ | |
8137 | * This version dated 14.12.94 is written by S. Roesler * | |
8138 | ************************************************************************ | |
8139 | ||
8140 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
8141 | SAVE | |
8142 | PARAMETER ( LINP = 10 , | |
8143 | & LOUT = 6 , | |
8144 | & LDAT = 9 ) | |
8145 | PARAMETER (TINY5=1.0D-5,TINY10=1.0D-10) | |
8146 | ||
8147 | * event history | |
8148 | PARAMETER (NMXHKK=200000) | |
8149 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
8150 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
8151 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
8152 | * extended event history | |
8153 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
8154 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
8155 | & IHIST(2,NMXHKK) | |
8156 | * flags for input different options | |
8157 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
8158 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
8159 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
8160 | * particle properties (BAMJET index convention) | |
8161 | CHARACTER*8 ANAME | |
8162 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
8163 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
8164 | ||
8165 | DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),IFP(2),IFT(2) | |
8166 | ||
8167 | IREJ = 0 | |
8168 | ||
8169 | DO 1 I=NPOINT(3),NHKK | |
8170 | IF (ABS(IDRES(I)).GE.100) THEN | |
8171 | AMMX = 0.0D0 | |
8172 | DO 2 J=NPOINT(3),NHKK | |
8173 | IF (IDHKK(J).EQ.88888) THEN | |
8174 | IF (PHKK(5,J).GT.AMMX) THEN | |
8175 | AMMX = PHKK(5,J) | |
8176 | IMMX = J | |
8177 | ENDIF | |
8178 | ENDIF | |
8179 | 2 CONTINUE | |
8180 | IF (IDRES(IMMX).NE.0) THEN | |
8181 | IF (IOULEV(3).GT.0) THEN | |
8182 | WRITE(LOUT,'(1X,A)') | |
8183 | & 'EVTRES: no chain for correc. found' | |
8184 | C GOTO 6 | |
8185 | GOTO 9999 | |
8186 | ELSE | |
8187 | GOTO 9999 | |
8188 | ENDIF | |
8189 | ENDIF | |
8190 | IMO11 = JMOHKK(1,I) | |
8191 | IMO12 = JMOHKK(2,I) | |
8192 | IF (PHKK(3,IMO11).LT.0.0D0) THEN | |
8193 | IMO11 = JMOHKK(2,I) | |
8194 | IMO12 = JMOHKK(1,I) | |
8195 | ENDIF | |
8196 | IMO21 = JMOHKK(1,IMMX) | |
8197 | IMO22 = JMOHKK(2,IMMX) | |
8198 | IF (PHKK(3,IMO21).LT.0.0D0) THEN | |
8199 | IMO21 = JMOHKK(2,IMMX) | |
8200 | IMO22 = JMOHKK(1,IMMX) | |
8201 | ENDIF | |
8202 | AMCH1 = PHKK(5,I) | |
8203 | AMCH1N = AAM(IDXRES(I)) | |
8204 | ||
8205 | IFPR1 = IDHKK(IMO11) | |
8206 | IFPR2 = IDHKK(IMO21) | |
8207 | IFTA1 = IDHKK(IMO12) | |
8208 | IFTA2 = IDHKK(IMO22) | |
8209 | DO 4 J=1,4 | |
8210 | PP1(J) = PHKK(J,IMO11) | |
8211 | PP2(J) = PHKK(J,IMO21) | |
8212 | PT1(J) = PHKK(J,IMO12) | |
8213 | PT2(J) = PHKK(J,IMO22) | |
8214 | 4 CONTINUE | |
8215 | * store initial configuration for energy-momentum cons. check | |
8216 | IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IREJ1) | |
8217 | * correct kinematics of second chain | |
8218 | CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2, | |
8219 | & AMCH1,AMCH1N,AMCH2,IREJ1) | |
8220 | IF (IREJ1.NE.0) GOTO 9999 | |
8221 | * check now this chain for resonance mass | |
8222 | IFP(1) = IDT_IPDG2B(IFPR2,1,2) | |
8223 | IFP(2) = 0 | |
8224 | IF (ABS(IFPR2).GE.1000) IFP(2) = IDT_IPDG2B(IFPR2,2,2) | |
8225 | IFT(1) = IDT_IPDG2B(IFTA2,1,2) | |
8226 | IFT(2) = 0 | |
8227 | IF (ABS(IFTA2).GE.1000) IFT(2) = IDT_IPDG2B(IFTA2,2,2) | |
8228 | IDCH2 = 2 | |
8229 | IF ((IFP(2).EQ.0).AND.(IFT(2).EQ.0)) IDCH2 = 1 | |
8230 | IF ((IFP(2).NE.0).AND.(IFT(2).NE.0)) IDCH2 = 3 | |
8231 | CALL DT_CH2RES(IFP(1),IFP(2),IFT(1),IFT(2),IDR2,IDXR2, | |
8232 | & AMCH2,AMCH2N,IDCH2,IREJ1) | |
8233 | IF ((IREJ1.NE.0).OR.(IDR2.NE.0)) THEN | |
8234 | IF (IOULEV(1).GT.0) | |
8235 | & WRITE(LOUT,*) ' correction for resonance not poss.' | |
8236 | **sr test | |
8237 | C GOTO 1 | |
8238 | C GOTO 9999 | |
8239 | ** | |
8240 | ENDIF | |
8241 | * store final configuration for energy-momentum cons. check | |
8242 | IF (LEMCCK) THEN | |
8243 | CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IREJ1) | |
8244 | CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1) | |
8245 | IF (IREJ1.NE.0) GOTO 9999 | |
8246 | ENDIF | |
8247 | DO 5 J=1,4 | |
8248 | PHKK(J,IMO11) = PP1(J) | |
8249 | PHKK(J,IMO21) = PP2(J) | |
8250 | PHKK(J,IMO12) = PT1(J) | |
8251 | PHKK(J,IMO22) = PT2(J) | |
8252 | 5 CONTINUE | |
8253 | * correct entries of chains | |
8254 | DO 3 K=1,4 | |
8255 | PHKK(K,I) = PHKK(K,IMO11)+PHKK(K,IMO12) | |
8256 | PHKK(K,IMMX) = PHKK(K,IMO21)+PHKK(K,IMO22) | |
8257 | 3 CONTINUE | |
8258 | AM1 = PHKK(4,I)**2-PHKK(1,I)**2-PHKK(2,I)**2-PHKK(3,I)**2 | |
8259 | AM2 = PHKK(4,IMMX)**2-PHKK(1,IMMX)**2-PHKK(2,IMMX)**2- | |
8260 | & PHKK(3,IMMX)**2 | |
8261 | * ?? the following should now be obsolete | |
8262 | **sr test | |
8263 | C IF ((AM1.LT.0.0D0).OR.(AM2.LT.1.0D0)) THEN | |
8264 | IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN | |
8265 | ** | |
8266 | WRITE(LOUT,'(1X,A,4G10.3)') | |
8267 | & 'EVTRES: inonsistent mass-corr.',AM1,AM2 | |
8268 | C GOTO 9999 | |
8269 | GOTO 1 | |
8270 | ENDIF | |
8271 | PHKK(5,I) = SQRT(AM1) | |
8272 | PHKK(5,IMMX) = SQRT(AM2) | |
8273 | IDRES(I) = IDRES(I)/100 | |
8274 | IF ((ABS(PHKK(5,I)-AMCH1N).GT.TINY5).OR. | |
8275 | & (ABS(PHKK(5,IMMX)-AMCH2).GT.TINY5)) THEN | |
8276 | WRITE(LOUT,'(1X,A,4G10.3)') | |
8277 | & 'EVTRES: inconsistent chain-masses', | |
8278 | & PHKK(5,I),AMCH1N,PHKK(5,IMMX),AMCH2 | |
8279 | GOTO 9999 | |
8280 | ENDIF | |
8281 | ENDIF | |
8282 | 1 CONTINUE | |
8283 | 6 CONTINUE | |
8284 | RETURN | |
8285 | ||
8286 | 9999 CONTINUE | |
8287 | IREJ = 1 | |
8288 | RETURN | |
8289 | END | |
8290 | ||
8291 | *$ CREATE DT_GETSPT.FOR | |
8292 | *COPY DT_GETSPT | |
8293 | * | |
8294 | *===getspt=============================================================* | |
8295 | * | |
8296 | SUBROUTINE DT_GETSPT(PP1I,IFPR1,IFP1,PP2I,IFPR2,IFP2, | |
8297 | & PT1I,IFTA1,IFT1,PT2I,IFTA2,IFT2, | |
8298 | & AM1,IDCH1,AM2,IDCH2,IDCHAI,IREJ) | |
8299 | ||
8300 | ************************************************************************ | |
8301 | * This version dated 12.12.94 is written by S. Roesler * | |
8302 | ************************************************************************ | |
8303 | ||
8304 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
8305 | SAVE | |
8306 | PARAMETER ( LINP = 10 , | |
8307 | & LOUT = 6 , | |
8308 | & LDAT = 9 ) | |
8309 | PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,ZERO=0.0D0) | |
8310 | ||
8311 | * various options for treatment of partons (DTUNUC 1.x) | |
8312 | * (chain recombination, Cronin,..) | |
8313 | LOGICAL LCO2CR,LINTPT | |
8314 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, | |
8315 | & LCO2CR,LINTPT | |
8316 | * flags for input different options | |
8317 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
8318 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
8319 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
8320 | * flags for diffractive interactions (DTUNUC 1.x) | |
8321 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF | |
8322 | ||
8323 | DIMENSION PP1(4),PP1I(4),PP2(4),PP2I(4),PT1(4),PT1I(4), | |
8324 | & PT2(4),PT2I(4),P1(4),P2(4), | |
8325 | & IFP1(2),IFP2(2),IFT1(2),IFT2(2), | |
8326 | & PTOTI(4),PTOTF(4),DIFF(4) | |
8327 | ||
8328 | IC = 0 | |
8329 | IREJ = 0 | |
8330 | C B33P = 4.0D0 | |
8331 | C B33T = 4.0D0 | |
8332 | C IF ((IDCHAI.EQ.6).OR.(IDCHAI.EQ.7).OR.(IDCHAI.EQ.8)) B33P = 2.0D0 | |
8333 | C IF ((IDCHAI.EQ.4).OR.(IDCHAI.EQ.5).OR.(IDCHAI.EQ.8)) B33T = 2.0D0 | |
8334 | REDU = 1.0D0 | |
8335 | C B33P = 3.5D0 | |
8336 | C B33T = 3.5D0 | |
8337 | B33P = 4.0D0 | |
8338 | B33T = 4.0D0 | |
8339 | IF (IDIFF.NE.0) THEN | |
8340 | B33P = 16.0D0 | |
8341 | B33T = 16.0D0 | |
8342 | ENDIF | |
8343 | ||
8344 | DO 1 I=1,4 | |
8345 | PTOTI(I) = PP1I(I)+PP2I(I)+PT1I(I)+PT2I(I) | |
8346 | PP1(I) = PP1I(I) | |
8347 | PP2(I) = PP2I(I) | |
8348 | PT1(I) = PT1I(I) | |
8349 | PT2(I) = PT2I(I) | |
8350 | 1 CONTINUE | |
8351 | * get initial chain masses | |
8352 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 | |
8353 | & +(PP1(3)+PT1(3))**2) | |
8354 | ECH = PP1(4)+PT1(4) | |
8355 | AM1 = (ECH+PTOCH)*(ECH-PTOCH) | |
8356 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 | |
8357 | & +(PP2(3)+PT2(3))**2) | |
8358 | ECH = PP2(4)+PT2(4) | |
8359 | AM2 = (ECH+PTOCH)*(ECH-PTOCH) | |
8360 | IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN | |
8361 | IF (IOULEV(1).GT.0) | |
8362 | & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 1', | |
8363 | & AM1,AM2 | |
8364 | GOTO 9999 | |
8365 | ENDIF | |
8366 | AM1 = SQRT(AM1) | |
8367 | AM2 = SQRT(AM2) | |
8368 | AM1N = ZERO | |
8369 | AM2N = ZERO | |
8370 | ||
8371 | MODE = 0 | |
8372 | C IF ((AM1.GE.3.0D0).AND.(AM2.GE.3.0D0)) THEN | |
8373 | C MODE = 0 | |
8374 | C ELSE | |
8375 | C MODE = 1 | |
8376 | C IF (AM1.LT.0.6) THEN | |
8377 | C B33P = 10.0D0 | |
8378 | C ELSEIF ((AM1.GE.1.2).AND.(AM1.LT.3.0D0)) THEN | |
8379 | CC B33P = 4.0D0 | |
8380 | C ENDIF | |
8381 | C IF (AM2.LT.0.6) THEN | |
8382 | C B33T = 10.0D0 | |
8383 | C ELSEIF ((AM2.GE.1.2).AND.(AM2.LT.3.0D0)) THEN | |
8384 | CC B33T = 4.0D0 | |
8385 | C ENDIF | |
8386 | C ENDIF | |
8387 | ||
8388 | * check chain masses for very low mass chains | |
8389 | C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM, | |
8390 | C & AM1,DUM,-IDCH1,IREJ1) | |
8391 | C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM, | |
8392 | C & AM2,DUM,-IDCH2,IREJ2) | |
8393 | C IF ((IREJ1.NE.0).OR.(IREJ2.NE.0)) THEN | |
8394 | C B33P = 20.0D0 | |
8395 | C B33T = 20.0D0 | |
8396 | C ENDIF | |
8397 | ||
8398 | JMSHL = IMSHL | |
8399 | ||
8400 | 2 CONTINUE | |
8401 | IC = IC+1 | |
8402 | IF (MOD(IC,15).EQ.0) B33P = 2.0D0*B33P | |
8403 | IF (MOD(IC,15).EQ.0) B33T = 2.0D0*B33T | |
8404 | IF (MOD(IC,18).EQ.0) REDU = 0.0D0 | |
8405 | C IF (MOD(IC,19).EQ.0) JMSHL = 0 | |
8406 | IF (MOD(IC,20).EQ.0) GOTO 7 | |
8407 | C WRITE(LOUT,'(1X,A)') 'GETSPT: rejection ' | |
8408 | C RETURN | |
8409 | C GOTO 9999 | |
8410 | C ENDIF | |
8411 | ||
8412 | * get transverse momentum | |
8413 | IF (LINTPT) THEN | |
8414 | ES = -2.0D0/(B33P**2) | |
8415 | & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10) | |
8416 | HPSP = SQRT(ES*ES+2.0D0*ES*0.94D0) | |
8417 | HPSP = HPSP*REDU | |
8418 | ES = -2.0D0/(B33T**2) | |
8419 | & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10) | |
8420 | HPST = SQRT(ES*ES+2.0D0*ES*0.94D0) | |
8421 | HPST = HPST*REDU | |
8422 | ELSE | |
8423 | HPSP = ZERO | |
8424 | HPST = ZERO | |
8425 | ENDIF | |
8426 | CALL DT_DSFECF(SFE1,CFE1) | |
8427 | CALL DT_DSFECF(SFE2,CFE2) | |
8428 | IF (MODE.EQ.0) THEN | |
8429 | PP1(1) = PP1I(1)+HPSP*CFE1 | |
8430 | PP1(2) = PP1I(2)+HPSP*SFE1 | |
8431 | PP2(1) = PP2I(1)-HPSP*CFE1 | |
8432 | PP2(2) = PP2I(2)-HPSP*SFE1 | |
8433 | PT1(1) = PT1I(1)+HPST*CFE2 | |
8434 | PT1(2) = PT1I(2)+HPST*SFE2 | |
8435 | PT2(1) = PT2I(1)-HPST*CFE2 | |
8436 | PT2(2) = PT2I(2)-HPST*SFE2 | |
8437 | ELSE | |
8438 | PP1(1) = PP1I(1)+HPSP*CFE1 | |
8439 | PP1(2) = PP1I(2)+HPSP*SFE1 | |
8440 | PT1(1) = PT1I(1)-HPSP*CFE1 | |
8441 | PT1(2) = PT1I(2)-HPSP*SFE1 | |
8442 | PP2(1) = PP2I(1)+HPST*CFE2 | |
8443 | PP2(2) = PP2I(2)+HPST*SFE2 | |
8444 | PT2(1) = PT2I(1)-HPST*CFE2 | |
8445 | PT2(2) = PT2I(2)-HPST*SFE2 | |
8446 | ENDIF | |
8447 | ||
8448 | * put partons on mass shell | |
8449 | XMP1 = 0.0D0 | |
8450 | XMT1 = 0.0D0 | |
8451 | IF (JMSHL.EQ.1) THEN | |
8452 | XMP1 = PYMASS(IFPR1) | |
8453 | XMT1 = PYMASS(IFTA1) | |
8454 | ENDIF | |
8455 | CALL DT_MASHEL(PP1,PT1,XMP1,XMT1,P1,P2,IREJ1) | |
8456 | IF (IREJ1.NE.0) GOTO 2 | |
8457 | DO 3 I=1,4 | |
8458 | PTOTF(I) = P1(I)+P2(I) | |
8459 | PP1(I) = P1(I) | |
8460 | PT1(I) = P2(I) | |
8461 | 3 CONTINUE | |
8462 | XMP2 = 0.0D0 | |
8463 | XMT2 = 0.0D0 | |
8464 | IF (JMSHL.EQ.1) THEN | |
8465 | XMP2 = PYMASS(IFPR2) | |
8466 | XMT2 = PYMASS(IFTA2) | |
8467 | ENDIF | |
8468 | CALL DT_MASHEL(PP2,PT2,XMP2,XMT2,P1,P2,IREJ1) | |
8469 | IF (IREJ1.NE.0) GOTO 2 | |
8470 | DO 4 I=1,4 | |
8471 | PTOTF(I) = PTOTF(I)+P1(I)+P2(I) | |
8472 | PP2(I) = P1(I) | |
8473 | PT2(I) = P2(I) | |
8474 | 4 CONTINUE | |
8475 | ||
8476 | * check consistency | |
8477 | DO 5 I=1,4 | |
8478 | DIFF(I) = PTOTI(I)-PTOTF(I) | |
8479 | 5 CONTINUE | |
8480 | IF ((ABS(DIFF(1)).GT.TINY5).OR.(ABS(DIFF(2)).GT.TINY5).OR. | |
8481 | & (ABS(DIFF(3)).GT.TINY5).OR.(ABS(DIFF(4)).GT.TINY5)) THEN | |
8482 | WRITE(LOUT,'(1X,A,4G10.3)') 'GETSPT: inconsistencies ',DIFF | |
8483 | GOTO 9999 | |
8484 | ENDIF | |
8485 | PTOTP1 = SQRT(PP1(1)**2+PP1(2)**2+PP1(3)**2) | |
8486 | AMP1 = SQRT(ABS( (PP1(4)-PTOTP1)*(PP1(4)+PTOTP1) )) | |
8487 | PTOTP2 = SQRT(PP2(1)**2+PP2(2)**2+PP2(3)**2) | |
8488 | AMP2 = SQRT(ABS( (PP2(4)-PTOTP2)*(PP2(4)+PTOTP2) )) | |
8489 | PTOTT1 = SQRT(PT1(1)**2+PT1(2)**2+PT1(3)**2) | |
8490 | AMT1 = SQRT(ABS( (PT1(4)-PTOTT1)*(PT1(4)+PTOTT1) )) | |
8491 | PTOTT2 = SQRT(PT2(1)**2+PT2(2)**2+PT2(3)**2) | |
8492 | AMT2 = SQRT(ABS( (PT2(4)-PTOTT2)*(PT2(4)+PTOTT2) )) | |
8493 | IF ((ABS(AMP1-XMP1).GT.TINY3).OR.(ABS(AMP2-XMP2).GT.TINY3).OR. | |
8494 | & (ABS(AMT1-XMT1).GT.TINY3).OR.(ABS(AMT2-XMT2).GT.TINY3)) | |
8495 | & THEN | |
8496 | WRITE(LOUT,'(1X,A,2(4G10.3,/))') | |
8497 | & 'GETSPT: inconsistent masses', | |
8498 | & AMP1,XMP1,AMP2,XMP2,AMT1,XMT1,AMT2,XMT2 | |
8499 | * sr 22.11.00: commented. It should only have inconsistent masses for | |
8500 | * ultrahigh energies due to rounding problems | |
8501 | C GOTO 9999 | |
8502 | ENDIF | |
8503 | ||
8504 | * get chain masses | |
8505 | PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2 | |
8506 | & +(PP1(3)+PT1(3))**2) | |
8507 | ECH = PP1(4)+PT1(4) | |
8508 | AM1N = (ECH+PTOCH)*(ECH-PTOCH) | |
8509 | PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2 | |
8510 | & +(PP2(3)+PT2(3))**2) | |
8511 | ECH = PP2(4)+PT2(4) | |
8512 | AM2N = (ECH+PTOCH)*(ECH-PTOCH) | |
8513 | IF ((AM1N.LT.0.0D0).OR.(AM2N.LT.0.0D0)) THEN | |
8514 | IF (IOULEV(1).GT.0) | |
8515 | & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 2', | |
8516 | & AM1N,AM2N | |
8517 | GOTO 2 | |
8518 | ENDIF | |
8519 | AM1N = SQRT(AM1N) | |
8520 | AM2N = SQRT(AM2N) | |
8521 | ||
8522 | * check chain masses for very low mass chains | |
8523 | CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM, | |
8524 | & AM1N,DUM,-IDCH1,IREJ1) | |
8525 | IF (IREJ1.NE.0) GOTO 2 | |
8526 | CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM, | |
8527 | & AM2N,DUM,-IDCH2,IREJ2) | |
8528 | IF (IREJ2.NE.0) GOTO 2 | |
8529 | ||
8530 | 7 CONTINUE | |
8531 | IF (AM1N.GT.ZERO) THEN | |
8532 | AM1 = AM1N | |
8533 | AM2 = AM2N | |
8534 | ENDIF | |
8535 | DO 6 I=1,4 | |
8536 | PP1I(I) = PP1(I) | |
8537 | PP2I(I) = PP2(I) | |
8538 | PT1I(I) = PT1(I) | |
8539 | PT2I(I) = PT2(I) | |
8540 | 6 CONTINUE | |
8541 | ||
8542 | RETURN | |
8543 | ||
8544 | 9999 CONTINUE | |
8545 | IREJ = 1 | |
8546 | RETURN | |
8547 | END | |
8548 | ||
8549 | *$ CREATE DT_SAPTRE.FOR | |
8550 | *COPY DT_SAPTRE | |
8551 | * | |
8552 | *===saptre=============================================================* | |
8553 | * | |
8554 | SUBROUTINE DT_SAPTRE(IDX1,IDX2) | |
8555 | ||
8556 | ************************************************************************ | |
8557 | * p-t sampling for two-resonance systems. ("BAMJET-like" method) * | |
8558 | * IDX1,IDX2 indices of resonances ("chains") in DTEVT1 * | |
8559 | * Adopted from the original SAPTRE written by J. Ranft. * | |
8560 | * This version dated 18.01.95 is written by S. Roesler * | |
8561 | ************************************************************************ | |
8562 | ||
8563 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
8564 | SAVE | |
8565 | PARAMETER ( LINP = 10 , | |
8566 | & LOUT = 6 , | |
8567 | & LDAT = 9 ) | |
8568 | PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3) | |
8569 | ||
8570 | * event history | |
8571 | PARAMETER (NMXHKK=200000) | |
8572 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
8573 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
8574 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
8575 | * extended event history | |
8576 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
8577 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
8578 | & IHIST(2,NMXHKK) | |
8579 | * flags for input different options | |
8580 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
8581 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
8582 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
8583 | ||
8584 | DIMENSION PA1(4),PA2(4),P1(4),P2(4) | |
8585 | ||
8586 | DATA B3 /4.0D0/ | |
8587 | ||
8588 | ESMAX1 = PHKK(4,IDX1)-PHKK(5,IDX1) | |
8589 | ESMAX2 = PHKK(4,IDX2)-PHKK(5,IDX2) | |
8590 | ESMAX = MIN(ESMAX1,ESMAX2) | |
8591 | IF (ESMAX.LE.0.05D0) RETURN | |
8592 | ||
8593 | HMA = PHKK(5,IDX1) | |
8594 | DO 1 K=1,4 | |
8595 | PA1(K) = PHKK(K,IDX1) | |
8596 | PA2(K) = PHKK(K,IDX2) | |
8597 | 1 CONTINUE | |
8598 | ||
8599 | IF (LEMCCK) THEN | |
8600 | CALL DT_EVTEMC(PA1(1),PA1(2),PA1(3),PA1(4),1,IDUM,IDUM) | |
8601 | CALL DT_EVTEMC(PA2(1),PA2(2),PA2(3),PA2(4),2,IDUM,IDUM) | |
8602 | ENDIF | |
8603 | ||
8604 | EXEB = 0.0D0 | |
8605 | IF (B3*ESMAX.LE.60.0D0) EXEB = EXP(-B3*ESMAX) | |
8606 | BEXP = HMA*(1.0D0-EXEB)/B3 | |
8607 | AXEXP = (1.0D0-(B3*ESMAX-1.0D0)*EXEB)/B3**2 | |
8608 | WA = AXEXP/(BEXP+AXEXP) | |
8609 | XAB = DT_RNDM(WA) | |
8610 | 10 CONTINUE | |
8611 | * ES is the transverse kinetic energy | |
8612 | IF (XAB.LT.WA)THEN | |
8613 | X = DT_RNDM(WA) | |
8614 | Y = DT_RNDM(WA) | |
8615 | ES = -2.0D0/(B3**2)*LOG(X*Y+TINY7) | |
8616 | ELSE | |
8617 | X = DT_RNDM(Y) | |
8618 | ES = ABS(-LOG(X+TINY7)/B3) | |
8619 | ENDIF | |
8620 | IF (ES.GT.ESMAX) GOTO 10 | |
8621 | ES = ES+HMA | |
8622 | * transverse momentum | |
8623 | HPS = SQRT((ES-HMA)*(ES+HMA)) | |
8624 | ||
8625 | CALL DT_DSFECF(SFE,CFE) | |
8626 | HPX = HPS*CFE | |
8627 | HPY = HPS*SFE | |
8628 | PZ1NSQ = PA1(3)**2-HPS**2-2.0D0*PA1(1)*HPX-2.0D0*PA1(2)*HPY | |
8629 | PZ2NSQ = PA2(3)**2-HPS**2+2.0D0*PA2(1)*HPX+2.0D0*PA2(2)*HPY | |
8630 | IF ((PZ1NSQ.LT.TINY3).OR.(PZ2NSQ.LT.TINY3)) RETURN | |
8631 | ||
8632 | C PA1(3) = SIGN(SQRT(PZ1NSQ),PA1(3)) | |
8633 | C PA2(3) = SIGN(SQRT(PZ2NSQ),PA2(3)) | |
8634 | PA1(1) = PA1(1)+HPX | |
8635 | PA1(2) = PA1(2)+HPY | |
8636 | PA2(1) = PA2(1)-HPX | |
8637 | PA2(2) = PA2(2)-HPY | |
8638 | ||
8639 | * put resonances on mass-shell again | |
8640 | XM1 = PHKK(5,IDX1) | |
8641 | XM2 = PHKK(5,IDX2) | |
8642 | CALL DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ1) | |
8643 | IF (IREJ1.NE.0) RETURN | |
8644 | ||
8645 | IF (LEMCCK) THEN | |
8646 | CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,IDUM,IDUM) | |
8647 | CALL DT_EVTEMC(-P2(1),-P2(2),-P2(3),-P2(4),2,IDUM,IDUM) | |
8648 | CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,12,IREJ1) | |
8649 | IF (IREJ1.NE.0) RETURN | |
8650 | ENDIF | |
8651 | ||
8652 | DO 2 K=1,4 | |
8653 | PHKK(K,IDX1) = P1(K) | |
8654 | PHKK(K,IDX2) = P2(K) | |
8655 | 2 CONTINUE | |
8656 | ||
8657 | RETURN | |
8658 | END | |
8659 | ||
8660 | *$ CREATE DT_CRONIN.FOR | |
8661 | *COPY DT_CRONIN | |
8662 | * | |
8663 | *===cronin=============================================================* | |
8664 | * | |
8665 | SUBROUTINE DT_CRONIN(INCL) | |
8666 | ||
8667 | ************************************************************************ | |
8668 | * Cronin-Effect. Multiple scattering of partons at chain ends. * | |
8669 | * INCL = 1 multiple sc. in projectile * | |
8670 | * = 2 multiple sc. in target * | |
8671 | * This version dated 05.01.96 is written by S. Roesler. * | |
8672 | ************************************************************************ | |
8673 | ||
8674 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
8675 | SAVE | |
8676 | PARAMETER ( LINP = 10 , | |
8677 | & LOUT = 6 , | |
8678 | & LDAT = 9 ) | |
8679 | PARAMETER (ZERO=0.0D0,TINY3=1.0D-3) | |
8680 | ||
8681 | * event history | |
8682 | PARAMETER (NMXHKK=200000) | |
8683 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
8684 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
8685 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
8686 | * extended event history | |
8687 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
8688 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
8689 | & IHIST(2,NMXHKK) | |
8690 | * rejection counter | |
8691 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
8692 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
8693 | & IREXCI(3),IRDIFF(2),IRINC | |
8694 | * Glauber formalism: collision properties | |
8695 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, | |
8696 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC | |
8697 | ||
8698 | DIMENSION R(3),PIN(4),POUT(4),DEV(4) | |
8699 | ||
8700 | DO 1 K=1,4 | |
8701 | DEV(K) = ZERO | |
8702 | 1 CONTINUE | |
8703 | ||
8704 | DO 2 I=NPOINT(2),NHKK | |
8705 | IF (ISTHKK(I).LT.0) THEN | |
8706 | * get z-position of the chain | |
8707 | R(1) = VHKK(1,I)*1.0D12 | |
8708 | IF (INCL.EQ.2) R(1) = VHKK(1,I)*1.0D12-BIMPAC | |
8709 | R(2) = VHKK(2,I)*1.0D12 | |
8710 | IDXNU = JMOHKK(1,I) | |
8711 | IF ( (INCL.EQ.1).AND.(ISTHKK(IDXNU).EQ.10) ) | |
8712 | & IDXNU = JMOHKK(1,I-1) | |
8713 | IF ( (INCL.EQ.2).AND.(ISTHKK(IDXNU).EQ. 9) ) | |
8714 | & IDXNU = JMOHKK(1,I+1) | |
8715 | R(3) = VHKK(3,IDXNU)*1.0D12 | |
8716 | * position of target parton the chain is connected to | |
8717 | DO 3 K=1,4 | |
8718 | PIN(K) = PHKK(K,I) | |
8719 | 3 CONTINUE | |
8720 | * multiple scattering of parton with DTEVT1-index I | |
8721 | CALL DT_CROMSC(PIN,R,POUT,INCL) | |
8722 | **testprint | |
8723 | C IF (NEVHKK.EQ.5) THEN | |
8724 | C AMIN = PIN(4)**2-PIN(1)**2-PIN(2)**2-PIN(3)**2 | |
8725 | C AMOU = POUT(4)**2-POUT(1)**2-POUT(2)**2-POUT(3)**2 | |
8726 | C AMIN = SIGN(SQRT(ABS(AMIN)),AMIN) | |
8727 | C AMOU = SIGN(SQRT(ABS(AMOU)),AMOU) | |
8728 | C WRITE(6,'(A,I4,2E15.5)')'I,AMIN,AMOU: ',I,AMIN,AMOU | |
8729 | C WRITE(6,'(A,4E15.5)')'PIN: ',PIN | |
8730 | C WRITE(6,'(A,4E15.5)')'POUT: ',POUT | |
8731 | C ENDIF | |
8732 | ** | |
8733 | * increase accumulator by energy-momentum difference | |
8734 | DO 4 K=1,4 | |
8735 | DEV(K) = DEV(K)+POUT(K)-PIN(K) | |
8736 | PHKK(K,I) = POUT(K) | |
8737 | 4 CONTINUE | |
8738 | PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2- | |
8739 | & PHKK(2,I)**2-PHKK(3,I)**2)) | |
8740 | ENDIF | |
8741 | 2 CONTINUE | |
8742 | ||
8743 | * dump accumulator to momenta of valence partons | |
8744 | NVAL = 0 | |
8745 | ETOT = 0.0D0 | |
8746 | DO 5 I=NPOINT(2),NHKK | |
8747 | IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN | |
8748 | NVAL = NVAL+1 | |
8749 | ETOT = ETOT+PHKK(4,I) | |
8750 | ENDIF | |
8751 | 5 CONTINUE | |
8752 | C WRITE(LOUT,1000) NVAL,(DEV(K)/DBLE(NVAL),K=1,4) | |
8753 | 1000 FORMAT(1X,'CRONIN : number of val. partons ',I4,/, | |
8754 | & 9X,4E12.4) | |
8755 | DO 6 I=NPOINT(2),NHKK | |
8756 | IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN | |
8757 | E = PHKK(4,I) | |
8758 | DO 7 K=1,4 | |
8759 | C PHKK(K,I) = PHKK(K,I)-DEV(K)/DBLE(NVAL) | |
8760 | PHKK(K,I) = PHKK(K,I)-DEV(K)*E/ETOT | |
8761 | 7 CONTINUE | |
8762 | PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2- | |
8763 | & PHKK(2,I)**2-PHKK(3,I)**2)) | |
8764 | ENDIF | |
8765 | 6 CONTINUE | |
8766 | ||
8767 | RETURN | |
8768 | END | |
8769 | ||
8770 | *$ CREATE DT_CROMSC.FOR | |
8771 | *COPY DT_CROMSC | |
8772 | * | |
8773 | *===cromsc=============================================================* | |
8774 | * | |
8775 | SUBROUTINE DT_CROMSC(PIN,R,POUT,INCL) | |
8776 | ||
8777 | ************************************************************************ | |
8778 | * Cronin-Effect. Multiple scattering of one parton passing through * | |
8779 | * nuclear matter. * | |
8780 | * PIN(4) input 4-momentum of parton * | |
8781 | * POUT(4) 4-momentum of parton after mult. scatt. * | |
8782 | * R(3) spatial position of parton in target nucleus * | |
8783 | * INCL = 1 multiple sc. in projectile * | |
8784 | * = 2 multiple sc. in target * | |
8785 | * This is a revised version of the original version written by J. Ranft* | |
8786 | * This version dated 17.01.95 is written by S. Roesler. * | |
8787 | ************************************************************************ | |
8788 | ||
8789 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
8790 | SAVE | |
8791 | PARAMETER ( LINP = 10 , | |
8792 | & LOUT = 6 , | |
8793 | & LDAT = 9 ) | |
8794 | PARAMETER (ZERO=0.0D0,TINY3=1.0D-3) | |
8795 | ||
8796 | LOGICAL LSTART | |
8797 | ||
8798 | * rejection counter | |
8799 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
8800 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
8801 | & IREXCI(3),IRDIFF(2),IRINC | |
8802 | * Glauber formalism: collision properties | |
8803 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, | |
8804 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC | |
8805 | * various options for treatment of partons (DTUNUC 1.x) | |
8806 | * (chain recombination, Cronin,..) | |
8807 | LOGICAL LCO2CR,LINTPT | |
8808 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, | |
8809 | & LCO2CR,LINTPT | |
8810 | ||
8811 | DIMENSION PIN(4),POUT(4),R(3) | |
8812 | ||
8813 | DATA LSTART /.TRUE./ | |
8814 | ||
8815 | IRCRON(1) = IRCRON(1)+1 | |
8816 | ||
8817 | IF (LSTART) THEN | |
8818 | WRITE(LOUT,1000) CRONCO | |
8819 | 1000 FORMAT(/,1X,'CROMSC: multiple scattering of chain ends', | |
8820 | & ' treated',/,10X,'with parameter CRONCO = ',F5.2) | |
8821 | LSTART = .FALSE. | |
8822 | ENDIF | |
8823 | ||
8824 | NCBACK = 0 | |
8825 | RNCL = RPROJ | |
8826 | IF (INCL.EQ.2) RNCL = RTARG | |
8827 | ||
8828 | * Lorentz-transformation into Lab. | |
8829 | MODE = -(INCL+1) | |
8830 | CALL DT_LTNUC(PIN(3),PIN(4),PZ,PE,MODE) | |
8831 | ||
8832 | PTOT = SQRT(PIN(1)**2+PIN(2)**2+PZ**2) | |
8833 | IF (PTOT.LE.8.0D0) GOTO 9997 | |
8834 | ||
8835 | * direction cosines of parton before mult. scattering | |
8836 | COSX = PIN(1)/PTOT | |
8837 | COSY = PIN(2)/PTOT | |
8838 | COSZ = PZ/PTOT | |
8839 | ||
8840 | RTESQ = R(1)**2+R(2)**2+R(3)**2-RNCL**2 | |
8841 | IF (RTESQ.GE.-TINY3) GOTO 9999 | |
8842 | ||
8843 | * calculate distance (DIST) from R to surface of nucleus (radius RNCL) | |
8844 | * in the direction of particle motion | |
8845 | ||
8846 | A = COSX*R(1)+COSY*R(2)+COSZ*R(3) | |
8847 | TMP = A**2-RTESQ | |
8848 | IF (TMP.LT.ZERO) GOTO 9998 | |
8849 | DIST = -A+SQRT(TMP) | |
8850 | ||
8851 | * multiple scattering angle | |
8852 | THETO = CRONCO*SQRT(DIST)/PTOT | |
8853 | IF (THETO.GT.0.1D0) THETO=0.1D0 | |
8854 | ||
8855 | 1 CONTINUE | |
8856 | * Gaussian sampling of spatial angle | |
8857 | CALL DT_RANNOR(R1,R2) | |
8858 | THETA = ABS(R1*THETO) | |
8859 | IF (THETA.GT.0.3D0) GOTO 9997 | |
8860 | CALL DT_DSFECF(SFE,CFE) | |
8861 | COSTH = COS(THETA) | |
8862 | SINTH = SIN(THETA) | |
8863 | ||
8864 | * new direction cosines | |
8865 | CALL DT_MYTRAN(1,COSX,COSY,COSZ,COSTH,SINTH,SFE,CFE, | |
8866 | & COSXN,COSYN,COSZN) | |
8867 | ||
8868 | POUT(1) = COSXN*PTOT | |
8869 | POUT(2) = COSYN*PTOT | |
8870 | PZ = COSZN*PTOT | |
8871 | * Lorentz-transformation into nucl.-nucl. cms | |
8872 | MODE = INCL+1 | |
8873 | CALL DT_LTNUC(PZ,PE,POUT(3),POUT(4),MODE) | |
8874 | ||
8875 | C IF (ABS(PIN(4)-POUT(4)).GT.0.2D0) THEN | |
8876 | C IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.1D0 ) THEN | |
8877 | IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.05D0 ) THEN | |
8878 | THETO = THETO/2.0D0 | |
8879 | NCBACK = NCBACK+1 | |
8880 | IF (MOD(NCBACK,200).EQ.0) THEN | |
8881 | WRITE(LOUT,1001) THETO,PIN,POUT | |
8882 | 1001 FORMAT(1X,'CROMSC: inconsistent scattering angle ', | |
8883 | & E12.4,/,1X,' PIN :',4E12.4,/, | |
8884 | & 1X,' POUT:',4E12.4) | |
8885 | GOTO 9997 | |
8886 | ENDIF | |
8887 | GOTO 1 | |
8888 | ENDIF | |
8889 | ||
8890 | RETURN | |
8891 | ||
8892 | 9997 IRCRON(2) = IRCRON(2)+1 | |
8893 | GOTO 9999 | |
8894 | 9998 IRCRON(3) = IRCRON(3)+1 | |
8895 | ||
8896 | 9999 CONTINUE | |
8897 | DO 100 K=1,4 | |
8898 | POUT(K) = PIN(K) | |
8899 | 100 CONTINUE | |
8900 | RETURN | |
8901 | END | |
8902 | ||
8903 | *$ CREATE DT_COM2CR.FOR | |
8904 | *COPY DT_COM2CR | |
8905 | * | |
8906 | *===com2sr=============================================================* | |
8907 | * | |
8908 | SUBROUTINE DT_COM2CR | |
8909 | ||
8910 | ************************************************************************ | |
8911 | * COMbine q-aq chains to Color Ropes (qq-aqaq). * | |
8912 | * CUTOF parameter determining minimum number of not * | |
8913 | * combined q-aq chains * | |
8914 | * This subroutine replaces KKEVCC etc. * | |
8915 | * This version dated 11.01.95 is written by S. Roesler. * | |
8916 | ************************************************************************ | |
8917 | ||
8918 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
8919 | SAVE | |
8920 | PARAMETER ( LINP = 10 , | |
8921 | & LOUT = 6 , | |
8922 | & LDAT = 9 ) | |
8923 | ||
8924 | * event history | |
8925 | PARAMETER (NMXHKK=200000) | |
8926 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
8927 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
8928 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
8929 | * extended event history | |
8930 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
8931 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
8932 | & IHIST(2,NMXHKK) | |
8933 | * statistics | |
8934 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
8935 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
8936 | & ICEVTG(8,0:30) | |
8937 | * various options for treatment of partons (DTUNUC 1.x) | |
8938 | * (chain recombination, Cronin,..) | |
8939 | LOGICAL LCO2CR,LINTPT | |
8940 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, | |
8941 | & LCO2CR,LINTPT | |
8942 | ||
8943 | DIMENSION IDXQA(248),IDXAQ(248) | |
8944 | ||
8945 | ICCHAI(1,9) = ICCHAI(1,9)+1 | |
8946 | NQA = 0 | |
8947 | NAQ = 0 | |
8948 | * scan DTEVT1 for q-aq, aq-q chains | |
8949 | DO 10 I=NPOINT(3),NHKK | |
8950 | * skip "chains" which are resonances | |
8951 | IF ((IDHKK(I).EQ.88888).AND.(IDRES(I).EQ.0)) THEN | |
8952 | MO1 = JMOHKK(1,I) | |
8953 | MO2 = JMOHKK(2,I) | |
8954 | IF ((ABS(IDHKK(MO1)).LE.6).AND.(ABS(IDHKK(MO2)).LE.6)) THEN | |
8955 | * q-aq, aq-q chain found, keep index | |
8956 | IF (IDHKK(MO1).GT.0) THEN | |
8957 | NQA = NQA+1 | |
8958 | IDXQA(NQA) = I | |
8959 | ELSE | |
8960 | NAQ = NAQ+1 | |
8961 | IDXAQ(NAQ) = I | |
8962 | ENDIF | |
8963 | ENDIF | |
8964 | ENDIF | |
8965 | 10 CONTINUE | |
8966 | ||
8967 | * minimum number of q-aq chains requested for the same projectile/ | |
8968 | * target | |
8969 | NCHMIN = IDT_NPOISS(CUTOF) | |
8970 | ||
8971 | * combine q-aq chains of the same projectile | |
8972 | CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,1) | |
8973 | * combine q-aq chains of the same target | |
8974 | CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,2) | |
8975 | * combine aq-q chains of the same projectile | |
8976 | CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,1) | |
8977 | * combine aq-q chains of the same target | |
8978 | CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,2) | |
8979 | ||
8980 | RETURN | |
8981 | END | |
8982 | ||
8983 | *$ CREATE DT_SCN4CR.FOR | |
8984 | *COPY DT_SCN4CR | |
8985 | * | |
8986 | *===scn4cr=============================================================* | |
8987 | * | |
8988 | SUBROUTINE DT_SCN4CR(NCH,IDXCH,NCHMIN,MODE) | |
8989 | ||
8990 | ************************************************************************ | |
8991 | * SCan q-aq chains for Color Ropes. * | |
8992 | * This version dated 11.01.95 is written by S. Roesler. * | |
8993 | ************************************************************************ | |
8994 | ||
8995 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
8996 | SAVE | |
8997 | PARAMETER ( LINP = 10 , | |
8998 | & LOUT = 6 , | |
8999 | & LDAT = 9 ) | |
9000 | ||
9001 | * event history | |
9002 | PARAMETER (NMXHKK=200000) | |
9003 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
9004 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
9005 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
9006 | * extended event history | |
9007 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
9008 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
9009 | & IHIST(2,NMXHKK) | |
9010 | ||
9011 | DIMENSION IDXCH(248),IDXJN(248) | |
9012 | ||
9013 | DO 1 I=1,NCH | |
9014 | IF (IDXCH(I).GT.0) THEN | |
9015 | NJOIN = 1 | |
9016 | IDXMO = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(I)))) | |
9017 | IDXJN(NJOIN) = I | |
9018 | IF (I.LT.NCH) THEN | |
9019 | DO 2 J=I+1,NCH | |
9020 | IF (IDXCH(J).GT.0) THEN | |
9021 | IDXMO1 = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(J)))) | |
9022 | IF (IDXMO.EQ.IDXMO1) THEN | |
9023 | NJOIN = NJOIN+1 | |
9024 | IDXJN(NJOIN) = J | |
9025 | ENDIF | |
9026 | ENDIF | |
9027 | 2 CONTINUE | |
9028 | ENDIF | |
9029 | IF (NJOIN.GE.NCHMIN+2) THEN | |
9030 | NJ = INT(DBLE(NJOIN-NCHMIN)/2.0D0) | |
9031 | DO 3 J=1,2*NJ,2 | |
9032 | CALL DT_JOIN(IDXCH(IDXJN(J)),IDXCH(IDXJN(J+1)),IREJ1) | |
9033 | IF (IREJ1.NE.0) GOTO 3 | |
9034 | IDXCH(IDXJN(J)) = 0 | |
9035 | IDXCH(IDXJN(J+1)) = 0 | |
9036 | 3 CONTINUE | |
9037 | ENDIF | |
9038 | ENDIF | |
9039 | 1 CONTINUE | |
9040 | ||
9041 | RETURN | |
9042 | END | |
9043 | ||
9044 | *$ CREATE DT_JOIN.FOR | |
9045 | *COPY DT_JOIN | |
9046 | * | |
9047 | *===join===============================================================* | |
9048 | * | |
9049 | SUBROUTINE DT_JOIN(IDX1,IDX2,IREJ) | |
9050 | ||
9051 | ************************************************************************ | |
9052 | * This subroutine joins two q-aq chains to one qq-aqaq chain. * | |
9053 | * IDX1, IDX2 DTEVT1 indices of chains to be joined * | |
9054 | * This version dated 11.01.95 is written by S. Roesler. * | |
9055 | ************************************************************************ | |
9056 | ||
9057 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
9058 | SAVE | |
9059 | PARAMETER ( LINP = 10 , | |
9060 | & LOUT = 6 , | |
9061 | & LDAT = 9 ) | |
9062 | ||
9063 | * event history | |
9064 | PARAMETER (NMXHKK=200000) | |
9065 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
9066 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
9067 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
9068 | * extended event history | |
9069 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
9070 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
9071 | & IHIST(2,NMXHKK) | |
9072 | * flags for input different options | |
9073 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
9074 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
9075 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
9076 | * statistics | |
9077 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
9078 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
9079 | & ICEVTG(8,0:30) | |
9080 | ||
9081 | DIMENSION MO(2,2),ID(2,2),IDX(2),PCH(4),PP(4),PT(4),P1(4),P2(4) | |
9082 | ||
9083 | IREJ = 0 | |
9084 | ||
9085 | IDX(1) = IDX1 | |
9086 | IDX(2) = IDX2 | |
9087 | DO 1 I=1,2 | |
9088 | DO 2 J=1,2 | |
9089 | MO(I,J) = JMOHKK(J,IDX(I)) | |
9090 | ID(I,J) = IDT_IPDG2B(IDHKK(MO(I,J)),1,2) | |
9091 | 2 CONTINUE | |
9092 | 1 CONTINUE | |
9093 | ||
9094 | * check consistency | |
9095 | IF ((ABS(ID(1,1)).GT.6).OR.(ABS(ID(1,2)).GT.6).OR. | |
9096 | & (ABS(ID(2,1)).GT.6).OR.(ABS(ID(2,2)).GT.6).OR. | |
9097 | & ((ID(1,1)*ID(2,1)).LT.0).OR. | |
9098 | & ((ID(1,2)*ID(2,2)).LT.0)) THEN | |
9099 | WRITE(LOUT,1000) IDX(1),MO(1,1),MO(1,2),IDX(2),MO(2,1), | |
9100 | & MO(2,2) | |
9101 | 1000 FORMAT(1X,'JOIN: incons. chain system! chain ',I4,':', | |
9102 | & 2I5,' chain ',I4,':',2I5) | |
9103 | ENDIF | |
9104 | ||
9105 | * join chains | |
9106 | DO 3 K=1,4 | |
9107 | PP(K) = PHKK(K,MO(1,1))+PHKK(K,MO(2,1)) | |
9108 | PT(K) = PHKK(K,MO(1,2))+PHKK(K,MO(2,2)) | |
9109 | 3 CONTINUE | |
9110 | IF1 = IDT_IB2PDG(ID(1,1),ID(2,1),2) | |
9111 | IF2 = IDT_IB2PDG(ID(1,2),ID(2,2),2) | |
9112 | IST1 = ISTHKK(MO(1,1)) | |
9113 | IST2 = ISTHKK(MO(1,2)) | |
9114 | ||
9115 | * put partons again on mass shell | |
9116 | XM1 = 0.0D0 | |
9117 | XM2 = 0.0D0 | |
9118 | IF (IMSHL.EQ.1) THEN | |
9119 | XM1 = PYMASS(IF1) | |
9120 | XM2 = PYMASS(IF2) | |
9121 | ENDIF | |
9122 | CALL DT_MASHEL(PP,PT,XM1,XM2,P1,P2,IREJ1) | |
9123 | IF (IREJ1.NE.0) GOTO 9999 | |
9124 | DO 4 I=1,4 | |
9125 | PP(I) = P1(I) | |
9126 | PT(I) = P2(I) | |
9127 | 4 CONTINUE | |
9128 | ||
9129 | * store new partons in DTEVT1 | |
9130 | CALL DT_EVTPUT(IST1,IF1,MO(1,1),MO(2,1),PP(1),PP(2),PP(3),PP(4), | |
9131 | & 0,0,0) | |
9132 | CALL DT_EVTPUT(IST2,IF2,MO(1,2),MO(2,2),PT(1),PT(2),PT(3),PT(4), | |
9133 | & 0,0,0) | |
9134 | DO 5 K=1,4 | |
9135 | PCH(K) = PP(K)+PT(K) | |
9136 | 5 CONTINUE | |
9137 | ||
9138 | * check new chain for lower mass limit | |
9139 | IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN | |
9140 | AMCH = SQRT(ABS(PCH(4)**2-PCH(1)**2-PCH(2)**2-PCH(3)**2)) | |
9141 | CALL DT_CH2RES(ID(1,1),ID(2,1),ID(1,2),ID(2,2),IDUM,IDUM, | |
9142 | & AMCH,AMCHN,3,IREJ1) | |
9143 | IF (IREJ1.NE.0) THEN | |
9144 | NHKK = NHKK-2 | |
9145 | GOTO 9999 | |
9146 | ENDIF | |
9147 | ENDIF | |
9148 | ||
9149 | ICCHAI(2,9) = ICCHAI(2,9)+1 | |
9150 | * store new chain in DTEVT1 | |
9151 | KCH = 191 | |
9152 | CALL DT_EVTPUT(KCH,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),0,0,9) | |
9153 | IDHKK(IDX(1)) = 22222 | |
9154 | IDHKK(IDX(2)) = 22222 | |
9155 | * special treatment for space-time coordinates | |
9156 | DO 6 K=1,4 | |
9157 | VHKK(K,NHKK) = (VHKK(K,IDX(1))+VHKK(K,IDX(2)))/2.0D0 | |
9158 | WHKK(K,NHKK) = (WHKK(K,IDX(1))+WHKK(K,IDX(2)))/2.0D0 | |
9159 | 6 CONTINUE | |
9160 | RETURN | |
9161 | ||
9162 | 9999 CONTINUE | |
9163 | IREJ = 1 | |
9164 | RETURN | |
9165 | END | |
9166 | ||
9167 | *$ CREATE DT_XSGLAU.FOR | |
9168 | *COPY DT_XSGLAU | |
9169 | * | |
9170 | *===xsglau=============================================================* | |
9171 | * | |
9172 | SUBROUTINE DT_XSGLAU(NA,NB,JJPROJ,XI,Q2I,ECMI,IE,IQ,NIDX) | |
9173 | ||
9174 | ************************************************************************ | |
9175 | * Total, elastic, quasi-elastic, inelastic cross sections according to * | |
9176 | * Glauber's approach. * | |
9177 | * NA / NB mass numbers of proj./target nuclei * | |
9178 | * JJPROJ bamjet-index of projectile (=1 in case of proj.nucleus) * | |
9179 | * XI,Q2I,ECMI kinematical variables x, Q^2, E_cm * | |
9180 | * IE,IQ indices of energy and virtuality (the latter for gamma * | |
9181 | * projectiles only) * | |
9182 | * NIDX index of projectile/target nucleus * | |
9183 | * This version dated 17.3.98 is written by S. Roesler * | |
9184 | ************************************************************************ | |
9185 | ||
9186 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
9187 | SAVE | |
9188 | PARAMETER ( LINP = 10 , | |
9189 | & LOUT = 6 , | |
9190 | & LDAT = 9 ) | |
9191 | ||
9192 | COMPLEX*16 CZERO,CONE,CTWO | |
9193 | CHARACTER*12 CFILE | |
9194 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0, | |
9195 | & ONETHI=ONE/THREE,TINY25=1.0D-25) | |
9196 | PARAMETER (TWOPI = 6.283185307179586454D+00, | |
9197 | & PI = TWOPI/TWO, | |
9198 | & GEV2MB = 0.38938D0, | |
9199 | & GEV2FM = 0.1972D0, | |
9200 | & ALPHEM = ONE/137.0D0, | |
9201 | * proton mass | |
9202 | & AMP = 0.938D0, | |
9203 | & AMP2 = AMP**2, | |
9204 | * approx. nucleon radius | |
9205 | & RNUCLE = 1.12D0) | |
9206 | ||
9207 | * particle properties (BAMJET index convention) | |
9208 | CHARACTER*8 ANAME | |
9209 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
9210 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
9211 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
9212 | PARAMETER ( MAXNCL = 260, | |
9213 | & MAXVQU = MAXNCL, | |
9214 | & MAXSQU = 20*MAXVQU, | |
9215 | & MAXINT = MAXVQU+MAXSQU) | |
9216 | * Glauber formalism: parameters | |
9217 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), | |
9218 | & BMAX(NCOMPX),BSTEP(NCOMPX), | |
9219 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), | |
9220 | & NSITEB,NSTATB | |
9221 | * Glauber formalism: cross sections | |
9222 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
9223 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
9224 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
9225 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
9226 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
9227 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
9228 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
9229 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
9230 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
9231 | & BSLOPE,NEBINI,NQBINI | |
9232 | * Glauber formalism: flags and parameters for statistics | |
9233 | LOGICAL LPROD | |
9234 | CHARACTER*8 CGLB | |
9235 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD | |
9236 | * nucleon-nucleon event-generator | |
9237 | CHARACTER*8 CMODEL | |
9238 | LOGICAL LPHOIN | |
9239 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
9240 | * VDM parameter for photon-nucleus interactions | |
9241 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
9242 | * parameters for hA-diffraction | |
9243 | COMMON /DTDIHA/ DIBETA,DIALPH | |
9244 | ||
9245 | COMPLEX*16 PP11(MAXNCL),PP12(MAXNCL),PP21(MAXNCL),PP22(MAXNCL), | |
9246 | & OMPP11,OMPP12,OMPP21,OMPP22, | |
9247 | & DIPP11,DIPP12,DIPP21,DIPP22,AVDIPP, | |
9248 | & PPTMP1,PPTMP2 | |
9249 | COMPLEX*16 C,CA,CI | |
9250 | DIMENSION COOP1(3,MAXNCL),COOT1(3,MAXNCL), | |
9251 | & COOP2(3,MAXNCL),COOT2(3,MAXNCL), | |
9252 | & BPROD(KSITEB) | |
9253 | ||
9254 | PARAMETER (NPOINT=16) | |
9255 | DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT) | |
9256 | ||
9257 | LOGICAL LFIRST,LOPEN | |
9258 | DATA LFIRST,LOPEN /.TRUE.,.FALSE./ | |
9259 | ||
9260 | NTARG = ABS(NIDX) | |
9261 | * for quasi-elastic neutrino scattering set projectile to proton | |
9262 | * it should not have an effect since the whole Glauber-formalism is | |
9263 | * not needed for these interactions.. | |
9264 | IF (MCGENE.EQ.4) THEN | |
9265 | IJPROJ = 1 | |
9266 | ELSE | |
9267 | IJPROJ = JJPROJ | |
9268 | ENDIF | |
9269 | ||
9270 | IF ((ABS(IOGLB).EQ.1).AND.(.NOT.LOPEN)) THEN | |
9271 | I = INDEX(CGLB,' ') | |
9272 | IF (I.EQ.0) THEN | |
9273 | CFILE = CGLB//'.glb' | |
9274 | OPEN(LDAT,FILE=CGLB//'.glb',STATUS='UNKNOWN') | |
9275 | ELSEIF (I.GT.1) THEN | |
9276 | CFILE = CGLB(1:I-1)//'.glb' | |
9277 | OPEN(LDAT,FILE=CGLB(1:I-1)//'.glb',STATUS='UNKNOWN') | |
9278 | ELSE | |
9279 | STOP 'XSGLAU 1' | |
9280 | ENDIF | |
9281 | LOPEN = .TRUE. | |
9282 | ENDIF | |
9283 | ||
9284 | CZERO = DCMPLX(ZERO,ZERO) | |
9285 | CONE = DCMPLX(ONE,ZERO) | |
9286 | CTWO = DCMPLX(TWO,ZERO) | |
9287 | NEBINI = IE | |
9288 | NQBINI = IQ | |
9289 | ||
9290 | * re-define kinematics | |
9291 | S = ECMI**2 | |
9292 | Q2 = Q2I | |
9293 | X = XI | |
9294 | * g(Q2=0)-A, h-A, A-A scattering | |
9295 | IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN | |
9296 | Q2 = 0.0001D0 | |
9297 | X = Q2/(S+Q2-AMP2) | |
9298 | * g(Q2>0)-A scattering | |
9299 | ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(S.GT.ZERO)) THEN | |
9300 | X = Q2/(S+Q2-AMP2) | |
9301 | ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN | |
9302 | Q2 = (S-AMP2)*X/(ONE-X) | |
9303 | ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN | |
9304 | S = Q2*(ONE-X)/X+AMP2 | |
9305 | ELSE | |
9306 | WRITE(LOUT,*) 'XSGLAU: inconsistent input ',S,Q2,X | |
9307 | STOP | |
9308 | ENDIF | |
9309 | ECMNN(IE) = SQRT(S) | |
9310 | Q2G(IQ) = Q2 | |
9311 | XNU = (S+Q2-AMP2)/(TWO*AMP) | |
9312 | ||
9313 | * parameters determining statistics in evaluating Glauber-xsection | |
9314 | NSTATB = JSTATB | |
9315 | NSITEB = JBINSB | |
9316 | IF (NSITEB.GT.KSITEB) NSITEB = KSITEB | |
9317 | ||
9318 | * set up interaction geometry (common /DTGLAM/) | |
9319 | * projectile/target radii | |
9320 | RPRNCL = DT_RNCLUS(NA) | |
9321 | RTANCL = DT_RNCLUS(NB) | |
9322 | IF (IJPROJ.EQ.7) THEN | |
9323 | RASH(1) = ZERO | |
9324 | RBSH(NTARG) = RTANCL | |
9325 | BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG)) | |
9326 | ELSE | |
9327 | IF (NIDX.LE.-1) THEN | |
9328 | RASH(1) = RPRNCL | |
9329 | RBSH(NTARG) = RTANCL | |
9330 | BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG)) | |
9331 | ELSE | |
9332 | RASH(NTARG) = RPRNCL | |
9333 | RBSH(1) = RTANCL | |
9334 | BMAX(NTARG) = 2.0D0*(RASH(NTARG)+RBSH(1)) | |
9335 | ENDIF | |
9336 | ENDIF | |
9337 | * maximum impact-parameter | |
9338 | BSTEP(NTARG)= BMAX(NTARG)/DBLE(NSITEB-1) | |
9339 | ||
9340 | * slope, rho ( Re(f(0))/Im(f(0)) ) | |
9341 | IF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN | |
9342 | IF (MCGENE.EQ.2) THEN | |
9343 | ZERO1 = ZERO | |
9344 | CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,SDUM1,SDUM2,SDUM3, | |
9345 | & BSLOPE,0) | |
9346 | ELSE | |
9347 | BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S)) | |
9348 | ENDIF | |
9349 | IF (ECMNN(IE).LE.3.0D0) THEN | |
9350 | ROSH = -0.43D0 | |
9351 | ELSEIF ((ECMNN(IE).GT.3.0D0).AND.(ECMNN(IE).LE.50.D0)) THEN | |
9352 | ROSH = -0.63D0+0.175D0*LOG(ECMNN(IE)) | |
9353 | ELSEIF (ECMNN(IE).GT.50.0D0) THEN | |
9354 | ROSH = 0.1D0 | |
9355 | ENDIF | |
9356 | ELSEIF (IJPROJ.EQ.7) THEN | |
9357 | ROSH = 0.1D0 | |
9358 | ELSE | |
9359 | BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S)) | |
9360 | ROSH = 0.01D0 | |
9361 | ENDIF | |
9362 | ||
9363 | * projectile-nucleon xsection (in fm) | |
9364 | IF (IJPROJ.EQ.7) THEN | |
9365 | SIGSH = DT_SIGVP(X,Q2)/10.0D0 | |
9366 | ELSE | |
9367 | ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP) | |
9368 | PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) ) | |
9369 | C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0 | |
9370 | DUMZER = ZERO | |
9371 | CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL) | |
9372 | SIGSH = SIGSH/10.0D0 | |
9373 | ENDIF | |
9374 | ||
9375 | * parameters for projectile diffraction (hA scattering only) | |
9376 | IF ((MCGENE.EQ.2).AND.(NA.EQ.1).AND.(NB.GT.1).AND.(IJPROJ.NE.7) | |
9377 | & .AND.(DIBETA.GE.ZERO)) THEN | |
9378 | ZERO1 = ZERO | |
9379 | CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,STOT,SDUM2,SDIF1,BDUM,0) | |
9380 | C DIBETA = SDIF1/STOT | |
9381 | DIBETA = 0.2D0 | |
9382 | DIGAMM = SQRT(DIALPH**2+DIBETA**2) | |
9383 | IF (DIBETA.LE.ZERO) THEN | |
9384 | ALPGAM = ONE | |
9385 | ELSE | |
9386 | ALPGAM = DIALPH/DIGAMM | |
9387 | ENDIF | |
9388 | FACDI1 = ONE-ALPGAM | |
9389 | FACDI2 = ONE+ALPGAM | |
9390 | FACDI = SQRT(FACDI1*FACDI2) | |
9391 | WRITE(LOUT,*)'DIBETA,DIALPH,DIGAMM: ',DIBETA,DIALPH,DIGAMM | |
9392 | ELSE | |
9393 | DIBETA = -1.0D0 | |
9394 | DIALPH = ZERO | |
9395 | DIGAMM = ZERO | |
9396 | FACDI1 = ZERO | |
9397 | FACDI2 = 2.0D0 | |
9398 | FACDI = ZERO | |
9399 | ENDIF | |
9400 | ||
9401 | * initializations | |
9402 | DO 10 I=1,NSITEB | |
9403 | BSITE( 0,IQ,NTARG,I) = ZERO | |
9404 | BSITE(IE,IQ,NTARG,I) = ZERO | |
9405 | BPROD(I) = ZERO | |
9406 | 10 CONTINUE | |
9407 | STOT = ZERO | |
9408 | STOT2 = ZERO | |
9409 | SELA = ZERO | |
9410 | SELA2 = ZERO | |
9411 | SQEP = ZERO | |
9412 | SQEP2 = ZERO | |
9413 | SQET = ZERO | |
9414 | SQET2 = ZERO | |
9415 | SQE2 = ZERO | |
9416 | SQE22 = ZERO | |
9417 | SPRO = ZERO | |
9418 | SPRO2 = ZERO | |
9419 | SDEL = ZERO | |
9420 | SDEL2 = ZERO | |
9421 | SDQE = ZERO | |
9422 | SDQE2 = ZERO | |
9423 | FACN = ONE/DBLE(NSTATB) | |
9424 | ||
9425 | IPNT = 0 | |
9426 | RPNT = ZERO | |
9427 | ||
9428 | * initialize Gauss-integration for photon-proj. | |
9429 | JPOINT = 1 | |
9430 | IF (IJPROJ.EQ.7) THEN | |
9431 | IF (INTRGE(1).EQ.1) THEN | |
9432 | AMLO2 = (3.0D0*AAM(13))**2 | |
9433 | ELSEIF (INTRGE(1).EQ.2) THEN | |
9434 | AMLO2 = AAM(33)**2 | |
9435 | ELSE | |
9436 | AMLO2 = AAM(96)**2 | |
9437 | ENDIF | |
9438 | IF (INTRGE(2).EQ.1) THEN | |
9439 | AMHI2 = S/TWO | |
9440 | ELSEIF (INTRGE(2).EQ.2) THEN | |
9441 | AMHI2 = S/4.0D0 | |
9442 | ELSE | |
9443 | AMHI2 = S | |
9444 | ENDIF | |
9445 | AMHI20 = (ECMNN(IE)-AMP)**2 | |
9446 | IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20 | |
9447 | XAMLO = LOG( AMLO2+Q2 ) | |
9448 | XAMHI = LOG( AMHI2+Q2 ) | |
9449 | **PHOJET105a | |
9450 | C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT) | |
9451 | **PHOJET112 | |
9452 | CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT) | |
9453 | ** | |
9454 | JPOINT = NPOINT | |
9455 | * ratio direct/total photon-nucleon xsection | |
9456 | CALL DT_POILIK(NB,NTARG,ECMNN(IE),Q2,IPNT,RPNT,1) | |
9457 | ENDIF | |
9458 | ||
9459 | * read pre-initialized profile-function from file | |
9460 | IF (IOGLB.EQ.1) THEN | |
9461 | READ(LDAT,'(5I10,E15.5)') KJPROJ,IA,IB,ISTATB,ISITEB,DUM | |
9462 | IF ((IA.NE.NA).OR.(IB.NE.NB)) THEN | |
9463 | WRITE(LOUT,1000) CFILE,IA,IB,ISTATB,ISITEB, | |
9464 | & NA,NB,NSTATB,NSITEB | |
9465 | 1000 FORMAT(' XSGLAU: inconsistent input data in file ',A12,/, | |
9466 | & ' (IA,IB,ISTATB,ISITEB) ',4I10,/, | |
9467 | & ' (NA,NB,NSTATB,NSITEB) ',4I10) | |
9468 | STOP | |
9469 | ENDIF | |
9470 | IF (LFIRST) WRITE(LOUT,1001) CFILE | |
9471 | 1001 FORMAT(/,' XSGLAU: impact parameter distribution read from ', | |
9472 | & 'file ',A12,/) | |
9473 | READ(LDAT,'(6E12.5)') XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG), | |
9474 | & XSQEP(IE,IQ,NTARG),XSQET(IE,IQ,NTARG), | |
9475 | & XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG) | |
9476 | READ(LDAT,'(6E12.5)') XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG), | |
9477 | & XEQEP(IE,IQ,NTARG),XEQET(IE,IQ,NTARG), | |
9478 | & XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG) | |
9479 | NLINES = INT(DBLE(NSITEB)/7.0D0) | |
9480 | IF (NLINES.GT.0) THEN | |
9481 | DO 21 I=1,NLINES | |
9482 | ISTART = 7*I-6 | |
9483 | READ(LDAT,'(7E11.4)') | |
9484 | & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6) | |
9485 | 21 CONTINUE | |
9486 | ENDIF | |
9487 | ISTART = 7*NLINES+1 | |
9488 | IF (ISTART.LE.NSITEB) THEN | |
9489 | READ(LDAT,'(7E11.4)') | |
9490 | & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB) | |
9491 | ENDIF | |
9492 | LFIRST = .FALSE. | |
9493 | GOTO 100 | |
9494 | * variable projectile/target/energy runs: | |
9495 | * read pre-initialized profile-functions from file | |
9496 | ELSEIF (IOGLB.EQ.100) THEN | |
9497 | CALL DT_GLBSET(IJPROJ,IINA,IINB,RRELAB,0) | |
9498 | GOTO 100 | |
9499 | ENDIF | |
9500 | ||
9501 | * cross sections averaged over NSTATB nucleon configurations | |
9502 | DO 11 IS=1,NSTATB | |
9503 | C IF ((NA.EQ.207).AND.(NB.EQ.207)) WRITE(LOUT,*) 'conf. ',IS | |
9504 | STOTN = ZERO | |
9505 | SELAN = ZERO | |
9506 | SQEPN = ZERO | |
9507 | SQETN = ZERO | |
9508 | SQE2N = ZERO | |
9509 | SPRON = ZERO | |
9510 | SDELN = ZERO | |
9511 | SDQEN = ZERO | |
9512 | ||
9513 | IF (NIDX.LE.-1) THEN | |
9514 | CALL DT_CONUCL(COOP1,NA,RASH(1),0) | |
9515 | CALL DT_CONUCL(COOT1,NB,RBSH(NTARG),1) | |
9516 | IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN | |
9517 | CALL DT_CONUCL(COOP2,NA,RASH(1),0) | |
9518 | CALL DT_CONUCL(COOT2,NB,RBSH(NTARG),1) | |
9519 | ENDIF | |
9520 | ELSE | |
9521 | CALL DT_CONUCL(COOP1,NA,RASH(NTARG),0) | |
9522 | CALL DT_CONUCL(COOT1,NB,RBSH(1),1) | |
9523 | IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN | |
9524 | CALL DT_CONUCL(COOP2,NA,RASH(NTARG),0) | |
9525 | CALL DT_CONUCL(COOT2,NB,RBSH(1),1) | |
9526 | ENDIF | |
9527 | ENDIF | |
9528 | ||
9529 | * integration over impact parameter B | |
9530 | DO 12 IB=1,NSITEB-1 | |
9531 | STOTB = ZERO | |
9532 | SELAB = ZERO | |
9533 | SQEPB = ZERO | |
9534 | SQETB = ZERO | |
9535 | SQE2B = ZERO | |
9536 | SPROB = ZERO | |
9537 | SDIR = ZERO | |
9538 | SDELB = ZERO | |
9539 | SDQEB = ZERO | |
9540 | B = DBLE(IB)*BSTEP(NTARG) | |
9541 | FACB = 10.0D0*TWOPI*B*BSTEP(NTARG) | |
9542 | ||
9543 | * integration over M_V^2 for photon-proj. | |
9544 | DO 14 IM=1,JPOINT | |
9545 | PP11(1) = CONE | |
9546 | PP12(1) = CONE | |
9547 | PP21(1) = CONE | |
9548 | PP22(1) = CONE | |
9549 | IF (IJPROJ.EQ.7) THEN | |
9550 | DO 13 K=2,NB | |
9551 | PP11(K) = CONE | |
9552 | PP12(K) = CONE | |
9553 | PP21(K) = CONE | |
9554 | PP22(K) = CONE | |
9555 | 13 CONTINUE | |
9556 | ENDIF | |
9557 | SHI = ZERO | |
9558 | FACM = ONE | |
9559 | DCOH = 1.0D10 | |
9560 | ||
9561 | IF (IJPROJ.EQ.7) THEN | |
9562 | AMV2 = EXP(ABSZX(IM))-Q2 | |
9563 | AMV = SQRT(AMV2) | |
9564 | IF (AMV2.LT.16.0D0) THEN | |
9565 | R = TWO | |
9566 | ELSEIF ((AMV2.GE.16.0D0).AND.(AMV2.LT.121.0D0)) THEN | |
9567 | R = 10.0D0/3.0D0 | |
9568 | ELSE | |
9569 | R = 11.0D0/3.0D0 | |
9570 | ENDIF | |
9571 | * define M_V dependent properties of nucleon scattering amplitude | |
9572 | * V_M-nucleon xsection | |
9573 | SIGMVD = RPNT*SIGSH/(AMV2+Q2+RL2)*10.0D0 | |
9574 | SIGMV = (ONE-RPNT)*SIGSH/(AMV2+Q2+RL2) | |
9575 | * slope-parametrisation a la Kaidalov | |
9576 | BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2) | |
9577 | & +0.25D0*LOG(S/(AMV2+Q2))) | |
9578 | * coherence length | |
9579 | IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+Q2)*GEV2FM | |
9580 | * integration weight factor | |
9581 | FACM = ALPHEM/(3.0D0*PI*(ONE-X))* | |
9582 | & R*AMV2/(AMV2+Q2)*(ONE+EPSPOL*Q2/AMV2)*WEIGHT(IM) | |
9583 | ENDIF | |
9584 | GSH = 10.0D0/(TWO*BSLOPE*GEV2MB) | |
9585 | GAM = GSH | |
9586 | IF (IJPROJ.EQ.7) THEN | |
9587 | RCA = GAM*SIGMV/TWOPI | |
9588 | ELSE | |
9589 | RCA = GAM*SIGSH/TWOPI | |
9590 | ENDIF | |
9591 | FCA = -ROSH*RCA | |
9592 | CA = DCMPLX(RCA,FCA) | |
9593 | CI = CONE | |
9594 | ||
9595 | DO 15 INA=1,NA | |
9596 | KK1 = 1 | |
9597 | INT1 = 1 | |
9598 | KK2 = 1 | |
9599 | INT2 = 1 | |
9600 | DO 16 INB=1,NB | |
9601 | * photon-projectile: check for supression by coherence length | |
9602 | IF (IJPROJ.EQ.7) THEN | |
9603 | IF (ABS(COOT1(3,INB)-COOT1(3,KK1)).GT.DCOH)THEN | |
9604 | KK1 = INB | |
9605 | INT1 = INT1+1 | |
9606 | ENDIF | |
9607 | IF (ABS(COOT2(3,INB)-COOT2(3,KK2)).GT.DCOH)THEN | |
9608 | KK2 = INB | |
9609 | INT2 = INT2+1 | |
9610 | ENDIF | |
9611 | ENDIF | |
9612 | ||
9613 | X11 = B+COOT1(1,INB)-COOP1(1,INA) | |
9614 | Y11 = COOT1(2,INB)-COOP1(2,INA) | |
9615 | XY11 = GAM*(X11*X11+Y11*Y11) | |
9616 | IF (XY11.LE.15.0D0) THEN | |
9617 | C = CONE-CA*EXP(-XY11) | |
9618 | AR = DBLE(PP11(INT1)) | |
9619 | AI = DIMAG(PP11(INT1)) | |
9620 | IF (ABS(AR).LT.TINY25) AR = ZERO | |
9621 | IF (ABS(AI).LT.TINY25) AI = ZERO | |
9622 | PP11(INT1) = DCMPLX(AR,AI) | |
9623 | PP11(INT1) = PP11(INT1)*C | |
9624 | AR = DBLE(C) | |
9625 | AI = DIMAG(C) | |
9626 | SHI = SHI+LOG(AR*AR+AI*AI) | |
9627 | ENDIF | |
9628 | IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN | |
9629 | X12 = B+COOT2(1,INB)-COOP1(1,INA) | |
9630 | Y12 = COOT2(2,INB)-COOP1(2,INA) | |
9631 | XY12 = GAM*(X12*X12+Y12*Y12) | |
9632 | IF (XY12.LE.15.0D0) THEN | |
9633 | C = CONE-CA*EXP(-XY12) | |
9634 | AR = DBLE(PP12(INT2)) | |
9635 | AI = DIMAG(PP12(INT2)) | |
9636 | IF (ABS(AR).LT.TINY25) AR = ZERO | |
9637 | IF (ABS(AI).LT.TINY25) AI = ZERO | |
9638 | PP12(INT2) = DCMPLX(AR,AI) | |
9639 | PP12(INT2) = PP12(INT2)*C | |
9640 | ENDIF | |
9641 | X21 = B+COOT1(1,INB)-COOP2(1,INA) | |
9642 | Y21 = COOT1(2,INB)-COOP2(2,INA) | |
9643 | XY21 = GAM*(X21*X21+Y21*Y21) | |
9644 | IF (XY21.LE.15.0D0) THEN | |
9645 | C = CONE-CA*EXP(-XY21) | |
9646 | AR = DBLE(PP21(INT1)) | |
9647 | AI = DIMAG(PP21(INT1)) | |
9648 | IF (ABS(AR).LT.TINY25) AR = ZERO | |
9649 | IF (ABS(AI).LT.TINY25) AI = ZERO | |
9650 | PP21(INT1) = DCMPLX(AR,AI) | |
9651 | PP21(INT1) = PP21(INT1)*C | |
9652 | ENDIF | |
9653 | X22 = B+COOT2(1,INB)-COOP2(1,INA) | |
9654 | Y22 = COOT2(2,INB)-COOP2(2,INA) | |
9655 | XY22 = GAM*(X22*X22+Y22*Y22) | |
9656 | IF (XY22.LE.15.0D0) THEN | |
9657 | C = CONE-CA*EXP(-XY22) | |
9658 | AR = DBLE(PP22(INT2)) | |
9659 | AI = DIMAG(PP22(INT2)) | |
9660 | IF (ABS(AR).LT.TINY25) AR = ZERO | |
9661 | IF (ABS(AI).LT.TINY25) AI = ZERO | |
9662 | PP22(INT2) = DCMPLX(AR,AI) | |
9663 | PP22(INT2) = PP22(INT2)*C | |
9664 | ENDIF | |
9665 | ENDIF | |
9666 | 16 CONTINUE | |
9667 | 15 CONTINUE | |
9668 | ||
9669 | OMPP11 = CZERO | |
9670 | OMPP21 = CZERO | |
9671 | DIPP11 = CZERO | |
9672 | DIPP21 = CZERO | |
9673 | DO 17 K=1,INT1 | |
9674 | IF (PP11(K).EQ.CZERO) THEN | |
9675 | PPTMP1 = CZERO | |
9676 | PPTMP2 = CZERO | |
9677 | ELSE | |
9678 | PPTMP1 = PP11(K)**(ONE-DIALPH-DIGAMM) | |
9679 | PPTMP2 = PP11(K)**(ONE-DIALPH+DIGAMM) | |
9680 | ENDIF | |
9681 | AVDIPP = 0.5D0* | |
9682 | & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) ) | |
9683 | OMPP11 = OMPP11+AVDIPP | |
9684 | C OMPP11 = OMPP11+(CONE-PP11(K)) | |
9685 | AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 ) | |
9686 | DIPP11 = DIPP11+AVDIPP | |
9687 | IF (PP21(K).EQ.CZERO) THEN | |
9688 | PPTMP1 = CZERO | |
9689 | PPTMP2 = CZERO | |
9690 | ELSE | |
9691 | PPTMP1 = PP21(K)**(ONE-DIALPH-DIGAMM) | |
9692 | PPTMP2 = PP21(K)**(ONE-DIALPH+DIGAMM) | |
9693 | ENDIF | |
9694 | AVDIPP = 0.5D0* | |
9695 | & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) ) | |
9696 | OMPP21 = OMPP21+AVDIPP | |
9697 | C OMPP21 = OMPP21+(CONE-PP21(K)) | |
9698 | AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 ) | |
9699 | DIPP21 = DIPP21+AVDIPP | |
9700 | 17 CONTINUE | |
9701 | OMPP12 = CZERO | |
9702 | OMPP22 = CZERO | |
9703 | DIPP12 = CZERO | |
9704 | DIPP22 = CZERO | |
9705 | DO 18 K=1,INT2 | |
9706 | IF (PP12(K).EQ.CZERO) THEN | |
9707 | PPTMP1 = CZERO | |
9708 | PPTMP2 = CZERO | |
9709 | ELSE | |
9710 | PPTMP1 = PP12(K)**(ONE-DIALPH-DIGAMM) | |
9711 | PPTMP2 = PP12(K)**(ONE-DIALPH+DIGAMM) | |
9712 | ENDIF | |
9713 | AVDIPP = 0.5D0* | |
9714 | & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) ) | |
9715 | OMPP12 = OMPP12+AVDIPP | |
9716 | C OMPP12 = OMPP12+(CONE-PP12(K)) | |
9717 | AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 ) | |
9718 | DIPP12 = DIPP12+AVDIPP | |
9719 | IF (PP22(K).EQ.CZERO) THEN | |
9720 | PPTMP1 = CZERO | |
9721 | PPTMP2 = CZERO | |
9722 | ELSE | |
9723 | PPTMP1 = PP22(K)**(ONE-DIALPH-DIGAMM) | |
9724 | PPTMP2 = PP22(K)**(ONE-DIALPH+DIGAMM) | |
9725 | ENDIF | |
9726 | AVDIPP = 0.5D0* | |
9727 | & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) ) | |
9728 | OMPP22 = OMPP22+AVDIPP | |
9729 | C OMPP22 = OMPP22+(CONE-PP22(K)) | |
9730 | AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 ) | |
9731 | DIPP22 = DIPP22+AVDIPP | |
9732 | 18 CONTINUE | |
9733 | ||
9734 | SPROM = ONE-EXP(SHI) | |
9735 | SPROB = SPROB+FACM*SPROM | |
9736 | IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN | |
9737 | STOTM = DBLE(OMPP11+OMPP22) | |
9738 | SELAM = DBLE(OMPP11*DCONJG(OMPP22)) | |
9739 | SQEPM = DBLE(OMPP11*DCONJG(OMPP21))-SELAM | |
9740 | SQETM = DBLE(OMPP11*DCONJG(OMPP12))-SELAM | |
9741 | SQE2M = DBLE(OMPP11*DCONJG(OMPP11))-SELAM-SQEPM-SQETM | |
9742 | SDELM = DBLE(DIPP11*DCONJG(DIPP22)) | |
9743 | SDQEM = DBLE(DIPP11*DCONJG(DIPP21))-SDELM | |
9744 | STOTB = STOTB+FACM*STOTM | |
9745 | SELAB = SELAB+FACM*SELAM | |
9746 | SDELB = SDELB+FACM*SDELM | |
9747 | IF (NB.GT.1) THEN | |
9748 | SQEPB = SQEPB+FACM*SQEPM | |
9749 | SDQEB = SDQEB+FACM*SDQEM | |
9750 | ENDIF | |
9751 | IF (NA.GT.1) SQETB = SQETB+FACM*SQETM | |
9752 | IF ((NA.GT.1).AND.(NB.GT.1)) SQE2B = SQE2B+FACM*SQE2M | |
9753 | IF (IJPROJ.EQ.7) SDIR = SDIR+FACM*SIGMVD | |
9754 | ENDIF | |
9755 | ||
9756 | 14 CONTINUE | |
9757 | ||
9758 | STOTN = STOTN+FACB*STOTB | |
9759 | SELAN = SELAN+FACB*SELAB | |
9760 | SQEPN = SQEPN+FACB*SQEPB | |
9761 | SQETN = SQETN+FACB*SQETB | |
9762 | SQE2N = SQE2N+FACB*SQE2B | |
9763 | SPRON = SPRON+FACB*SPROB | |
9764 | SDELN = SDELN+FACB*SDELB | |
9765 | SDQEN = SDQEN+FACB*SDQEB | |
9766 | ||
9767 | IF (IJPROJ.EQ.7) THEN | |
9768 | BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*(STOTB-SELAB-SQEPB) | |
9769 | ELSE | |
9770 | IF (DIBETA.GT.ZERO) THEN | |
9771 | BPROD(IB+1)= BPROD(IB+1) | |
9772 | & +FACN*FACB*(STOTB-SELAB-SQEPB-SQETB-SQE2B) | |
9773 | ELSE | |
9774 | BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*SPROB | |
9775 | ENDIF | |
9776 | ENDIF | |
9777 | ||
9778 | 12 CONTINUE | |
9779 | ||
9780 | STOT = STOT +FACN*STOTN | |
9781 | STOT2 = STOT2+FACN*STOTN**2 | |
9782 | SELA = SELA +FACN*SELAN | |
9783 | SELA2 = SELA2+FACN*SELAN**2 | |
9784 | SQEP = SQEP +FACN*SQEPN | |
9785 | SQEP2 = SQEP2+FACN*SQEPN**2 | |
9786 | SQET = SQET +FACN*SQETN | |
9787 | SQET2 = SQET2+FACN*SQETN**2 | |
9788 | SQE2 = SQE2 +FACN*SQE2N | |
9789 | SQE22 = SQE22+FACN*SQE2N**2 | |
9790 | SPRO = SPRO +FACN*SPRON | |
9791 | SPRO2 = SPRO2+FACN*SPRON**2 | |
9792 | SDEL = SDEL +FACN*SDELN | |
9793 | SDEL2 = SDEL2+FACN*SDELN**2 | |
9794 | SDQE = SDQE +FACN*SDQEN | |
9795 | SDQE2 = SDQE2+FACN*SDQEN**2 | |
9796 | ||
9797 | 11 CONTINUE | |
9798 | ||
9799 | * final cross sections | |
9800 | * 1) total | |
9801 | XSTOT(IE,IQ,NTARG) = STOT | |
9802 | IF (IJPROJ.EQ.7) | |
9803 | & XSTOT(IE,IQ,NTARG) = XSTOT(IE,IQ,NTARG)+DBLE(NB)*SDIR | |
9804 | * 2) elastic | |
9805 | XSELA(IE,IQ,NTARG) = SELA | |
9806 | * 3) quasi-el.: A+B-->A+X (excluding 2) | |
9807 | XSQEP(IE,IQ,NTARG) = SQEP | |
9808 | * 4) quasi-el.: A+B-->X+B (excluding 2) | |
9809 | XSQET(IE,IQ,NTARG) = SQET | |
9810 | * 5) quasi-el.: A+B-->X (excluding 2-4) | |
9811 | XSQE2(IE,IQ,NTARG) = SQE2 | |
9812 | * 6) production (= STOT-SELA-SQEP-SQET-SQE2!) | |
9813 | IF (SDEL.GT.ZERO) THEN | |
9814 | XSPRO(IE,IQ,NTARG) = STOT-SELA-SQEP-SQET-SQE2 | |
9815 | ELSE | |
9816 | XSPRO(IE,IQ,NTARG) = SPRO | |
9817 | ENDIF | |
9818 | * 7) projectile diffraction (el. scatt. off target) | |
9819 | XSDEL(IE,IQ,NTARG) = SDEL | |
9820 | * 8) projectile diffraction (quasi-el. scatt. off target) | |
9821 | XSDQE(IE,IQ,NTARG) = SDQE | |
9822 | * stat. errors | |
9823 | XETOT(IE,IQ,NTARG) = SQRT(ABS(STOT2-STOT**2)/DBLE(NSTATB-1)) | |
9824 | XEELA(IE,IQ,NTARG) = SQRT(ABS(SELA2-SELA**2)/DBLE(NSTATB-1)) | |
9825 | XEQEP(IE,IQ,NTARG) = SQRT(ABS(SQEP2-SQEP**2)/DBLE(NSTATB-1)) | |
9826 | XEQET(IE,IQ,NTARG) = SQRT(ABS(SQET2-SQET**2)/DBLE(NSTATB-1)) | |
9827 | XEQE2(IE,IQ,NTARG) = SQRT(ABS(SQE22-SQE2**2)/DBLE(NSTATB-1)) | |
9828 | XEPRO(IE,IQ,NTARG) = SQRT(ABS(SPRO2-SPRO**2)/DBLE(NSTATB-1)) | |
9829 | XEDEL(IE,IQ,NTARG) = SQRT(ABS(SDEL2-SDEL**2)/DBLE(NSTATB-1)) | |
9830 | XEDQE(IE,IQ,NTARG) = SQRT(ABS(SDQE2-SDQE**2)/DBLE(NSTATB-1)) | |
9831 | ||
9832 | IF (IJPROJ.EQ.7) THEN | |
9833 | BNORM = XSTOT(IE,IQ,NTARG)-XSELA(IE,IQ,NTARG) | |
9834 | & -XSQEP(IE,IQ,NTARG) | |
9835 | ELSE | |
9836 | BNORM = XSPRO(IE,IQ,NTARG) | |
9837 | ENDIF | |
9838 | DO 19 I=2,NSITEB | |
9839 | BSITE(IE,IQ,NTARG,I) = BPROD(I)/BNORM+BSITE(IE,IQ,NTARG,I-1) | |
9840 | IF ((IE.EQ.1).AND.(IQ.EQ.1)) | |
9841 | & BSITE(0,1,NTARG,I) = BPROD(I)/BNORM+BSITE(0,1,NTARG,I-1) | |
9842 | 19 CONTINUE | |
9843 | ||
9844 | * write profile function data into file | |
9845 | IF ((IOGLB.EQ.-1).OR.(IOGLB.EQ.-100)) THEN | |
9846 | WRITE(LDAT,'(5I10,1P,E15.5)') | |
9847 | & IJPROJ,NA,NB,NSTATB,NSITEB,ECMNN(IE) | |
9848 | WRITE(LDAT,'(1P,6E12.5)') | |
9849 | & XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),XSQEP(IE,IQ,NTARG), | |
9850 | & XSQET(IE,IQ,NTARG),XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG) | |
9851 | WRITE(LDAT,'(1P,6E12.5)') | |
9852 | & XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),XEQEP(IE,IQ,NTARG), | |
9853 | & XEQET(IE,IQ,NTARG),XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG) | |
9854 | NLINES = INT(DBLE(NSITEB)/7.0D0) | |
9855 | IF (NLINES.GT.0) THEN | |
9856 | DO 20 I=1,NLINES | |
9857 | ISTART = 7*I-6 | |
9858 | WRITE(LDAT,'(1P,7E11.4)') | |
9859 | & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6) | |
9860 | 20 CONTINUE | |
9861 | ENDIF | |
9862 | ISTART = 7*NLINES+1 | |
9863 | IF (ISTART.LE.NSITEB) THEN | |
9864 | WRITE(LDAT,'(1P,7E11.4)') | |
9865 | & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB) | |
9866 | ENDIF | |
9867 | ENDIF | |
9868 | ||
9869 | 100 CONTINUE | |
9870 | ||
9871 | C IF (ABS(IOGLB).EQ.1) CLOSE(LDAT) | |
9872 | ||
9873 | RETURN | |
9874 | END | |
9875 | ||
9876 | *$ CREATE DT_GETBXS.FOR | |
9877 | *COPY DT_GETBXS | |
9878 | * | |
9879 | *===getbxs=============================================================* | |
9880 | * | |
9881 | SUBROUTINE DT_GETBXS(XSFRAC,BLO,BHI,NIDX) | |
9882 | ||
9883 | ************************************************************************ | |
9884 | * Biasing in impact parameter space. * | |
9885 | * XSFRAC = 0 : BLO - minimum impact parameter (input) * | |
9886 | * BHI - maximum impact parameter (input) * | |
9887 | * XSFRAC - fraction of cross section corresponding * | |
9888 | * to impact parameter range (BLO,BHI) * | |
9889 | * (output) * | |
9890 | * XSFRAC > 0 : XSFRAC - fraction of cross section (input) * | |
9891 | * BHI - maximum impact parameter giving requested * | |
9892 | * fraction of cross section in impact * | |
9893 | * parameter range (0,BMAX) (output) * | |
9894 | * This version dated 17.03.00 is written by S. Roesler * | |
9895 | ************************************************************************ | |
9896 | ||
9897 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
9898 | SAVE | |
9899 | PARAMETER ( LINP = 10 , | |
9900 | & LOUT = 6 , | |
9901 | & LDAT = 9 ) | |
9902 | ||
9903 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
9904 | * Glauber formalism: parameters | |
9905 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), | |
9906 | & BMAX(NCOMPX),BSTEP(NCOMPX), | |
9907 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), | |
9908 | & NSITEB,NSTATB | |
9909 | ||
9910 | NTARG = ABS(NIDX) | |
9911 | IF (XSFRAC.LE.0.0D0) THEN | |
9912 | ILO = MIN(NSITEB-1,INT(BLO/BSTEP(NTARG))) | |
9913 | IHI = MIN(NSITEB-1,INT(BHI/BSTEP(NTARG))) | |
9914 | IF (ILO.GE.IHI) THEN | |
9915 | XSFRAC = 0.0D0 | |
9916 | RETURN | |
9917 | ENDIF | |
9918 | IF (ILO.EQ.NSITEB-1) THEN | |
9919 | FRCLO = BSITE(0,1,NTARG,NSITEB) | |
9920 | ELSE | |
9921 | FRCLO = BSITE(0,1,NTARG,ILO+1) | |
9922 | & +(BLO-ILO*BSTEP(NTARG))/BSTEP(NTARG) | |
9923 | & *(BSITE(0,1,NTARG,ILO+2)-BSITE(0,1,NTARG,ILO+1)) | |
9924 | ENDIF | |
9925 | IF (IHI.EQ.NSITEB-1) THEN | |
9926 | FRCHI = BSITE(0,1,NTARG,NSITEB) | |
9927 | ELSE | |
9928 | FRCHI = BSITE(0,1,NTARG,IHI+1) | |
9929 | & +(BHI-IHI*BSTEP(NTARG))/BSTEP(NTARG) | |
9930 | & *(BSITE(0,1,NTARG,IHI+2)-BSITE(0,1,NTARG,IHI+1)) | |
9931 | ENDIF | |
9932 | XSFRAC = FRCHI-FRCLO | |
9933 | ELSE | |
9934 | BLO = 0.0D0 | |
9935 | BHI = BMAX(NTARG) | |
9936 | DO 1 I=1,NSITEB-1 | |
9937 | IF (XSFRAC.LT.BSITE(0,1,NTARG,I+1)) THEN | |
9938 | FAC = (XSFRAC -BSITE(0,1,NTARG,I))/ | |
9939 | & (BSITE(0,1,NTARG,I+1)-BSITE(0,1,NTARG,I)) | |
9940 | BHI = DBLE(I-1)*BSTEP(NTARG)+BSTEP(NTARG)*FAC | |
9941 | GOTO 2 | |
9942 | ENDIF | |
9943 | 1 CONTINUE | |
9944 | 2 CONTINUE | |
9945 | ENDIF | |
9946 | ||
9947 | RETURN | |
9948 | END | |
9949 | ||
9950 | *$ CREATE DT_CONUCL.FOR | |
9951 | *COPY DT_CONUCL | |
9952 | * | |
9953 | *===conucl=============================================================* | |
9954 | * | |
9955 | SUBROUTINE DT_CONUCL(X,N,R,MODE) | |
9956 | ||
9957 | ************************************************************************ | |
9958 | * Calculation of coordinates of nucleons within nuclei. * | |
9959 | * X(3,N) spatial coordinates of nucleons (in fm) (output) * | |
9960 | * N / R number of nucleons / radius of nucleus (input) * | |
9961 | * MODE = 0 coordinates not sorted * | |
9962 | * = 1 coordinates sorted with increasing X(3,i) * | |
9963 | * = 2 coordinates sorted with decreasing X(3,i) * | |
9964 | * This version dated 26.10.95 is revised by S. Roesler * | |
9965 | ************************************************************************ | |
9966 | ||
9967 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
9968 | SAVE | |
9969 | PARAMETER ( LINP = 10 , | |
9970 | & LOUT = 6 , | |
9971 | & LDAT = 9 ) | |
9972 | ||
9973 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0, | |
9974 | & ONETHI=ONE/THREE,SQRTWO=1.414213562D0) | |
9975 | ||
9976 | PARAMETER (TWOPI = 6.283185307179586454D+00 ) | |
9977 | ||
9978 | PARAMETER (NSRT=10) | |
9979 | DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT) | |
9980 | DIMENSION X(3,N),XTMP(3,260) | |
9981 | ||
9982 | CALL DT_COORDI(XTMP,IDXSRT,ICSRT,N,R) | |
9983 | ||
9984 | IF ((MODE.NE.0).AND.(N.GT.4)) THEN | |
9985 | K = 0 | |
9986 | DO 1 I=1,NSRT | |
9987 | IF (MODE.EQ.2) THEN | |
9988 | ISRT = NSRT+1-I | |
9989 | ELSE | |
9990 | ISRT = I | |
9991 | ENDIF | |
9992 | K1 = K | |
9993 | DO 2 J=1,ICSRT(ISRT) | |
9994 | K = K+1 | |
9995 | X(1,K) = XTMP(1,IDXSRT(ISRT,J)) | |
9996 | X(2,K) = XTMP(2,IDXSRT(ISRT,J)) | |
9997 | X(3,K) = XTMP(3,IDXSRT(ISRT,J)) | |
9998 | 2 CONTINUE | |
9999 | IF (ICSRT(ISRT).GT.1) THEN | |
10000 | I0 = K1+1 | |
10001 | I1 = K | |
10002 | CALL DT_SORT(X,N,I0,I1,MODE) | |
10003 | ENDIF | |
10004 | 1 CONTINUE | |
10005 | ELSEIF ((MODE.NE.0).AND.(N.GE.2).AND.(N.LE.4)) THEN | |
10006 | DO 3 I=1,N | |
10007 | X(1,I) = XTMP(1,I) | |
10008 | X(2,I) = XTMP(2,I) | |
10009 | X(3,I) = XTMP(3,I) | |
10010 | 3 CONTINUE | |
10011 | CALL DT_SORT(X,N,1,N,MODE) | |
10012 | ELSE | |
10013 | DO 4 I=1,N | |
10014 | X(1,I) = XTMP(1,I) | |
10015 | X(2,I) = XTMP(2,I) | |
10016 | X(3,I) = XTMP(3,I) | |
10017 | 4 CONTINUE | |
10018 | ENDIF | |
10019 | ||
10020 | RETURN | |
10021 | END | |
10022 | ||
10023 | *$ CREATE DT_COORDI.FOR | |
10024 | *COPY DT_COORDI | |
10025 | * | |
10026 | *===coordi=============================================================* | |
10027 | * | |
10028 | SUBROUTINE DT_COORDI(X,IDXSRT,ICSRT,N,R) | |
10029 | ||
10030 | ************************************************************************ | |
10031 | * Calculation of coordinates of nucleons within nuclei. * | |
10032 | * X(3,N) spatial coordinates of nucleons (in fm) (output) * | |
10033 | * N / R number of nucleons / radius of nucleus (input) * | |
10034 | * Based on the original version by Shmakov et al. * | |
10035 | * This version dated 26.10.95 is revised by S. Roesler * | |
10036 | ************************************************************************ | |
10037 | ||
10038 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
10039 | SAVE | |
10040 | PARAMETER ( LINP = 10 , | |
10041 | & LOUT = 6 , | |
10042 | & LDAT = 9 ) | |
10043 | ||
10044 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0, | |
10045 | & ONETHI=ONE/THREE,SQRTWO=1.414213562D0) | |
10046 | ||
10047 | PARAMETER (TWOPI = 6.283185307179586454D+00 ) | |
10048 | ||
10049 | LOGICAL LSTART | |
10050 | ||
10051 | PARAMETER (NSRT=10) | |
10052 | DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT) | |
10053 | DIMENSION X(3,260),WD(4),RD(3) | |
10054 | ||
10055 | DATA PDIF/0.545D0/,R2MIN/0.16D0/ | |
10056 | DATA WD / 0.0D0, 0.178D0, 0.465D0, 1.0D0/ | |
10057 | DATA RD /2.09D0, 0.935D0, 0.697D0/ | |
10058 | ||
10059 | X1SUM = ZERO | |
10060 | X2SUM = ZERO | |
10061 | X3SUM = ZERO | |
10062 | ||
10063 | IF (N.EQ.1) THEN | |
10064 | X(1,1) = ZERO | |
10065 | X(2,1) = ZERO | |
10066 | X(3,1) = ZERO | |
10067 | ELSEIF (N.EQ.2) THEN | |
10068 | EPS = DT_RNDM(RD(1)) | |
10069 | DO 30 I=1,3 | |
10070 | IF ((EPS.GE.WD(I)).AND.(EPS.LE.WD(I+1))) GOTO 40 | |
10071 | 30 CONTINUE | |
10072 | 40 CONTINUE | |
10073 | DO 50 J=1,3 | |
10074 | CALL DT_RANNOR(X1,X2) | |
10075 | X(J,1) = RD(I)*X1 | |
10076 | X(J,2) = -X(J,1) | |
10077 | 50 CONTINUE | |
10078 | ELSEIF ((N.EQ.3).OR.(N.EQ.4)) THEN | |
10079 | SIGMA = R/SQRTWO | |
10080 | LSTART = .TRUE. | |
10081 | CALL DT_RANNOR(X3,X4) | |
10082 | DO 100 I=1,N | |
10083 | CALL DT_RANNOR(X1,X2) | |
10084 | X(1,I) = SIGMA*X1 | |
10085 | X(2,I) = SIGMA*X2 | |
10086 | IF (LSTART) GOTO 80 | |
10087 | X(3,I) = SIGMA*X4 | |
10088 | CALL DT_RANNOR(X3,X4) | |
10089 | GOTO 90 | |
10090 | 80 CONTINUE | |
10091 | X(3,I) = SIGMA*X3 | |
10092 | 90 CONTINUE | |
10093 | LSTART = .NOT.LSTART | |
10094 | X1SUM = X1SUM+X(1,I) | |
10095 | X2SUM = X2SUM+X(2,I) | |
10096 | X3SUM = X3SUM+X(3,I) | |
10097 | 100 CONTINUE | |
10098 | X1SUM = X1SUM/DBLE(N) | |
10099 | X2SUM = X2SUM/DBLE(N) | |
10100 | X3SUM = X3SUM/DBLE(N) | |
10101 | DO 101 I=1,N | |
10102 | X(1,I) = X(1,I)-X1SUM | |
10103 | X(2,I) = X(2,I)-X2SUM | |
10104 | X(3,I) = X(3,I)-X3SUM | |
10105 | 101 CONTINUE | |
10106 | ELSE | |
10107 | ||
10108 | * maximum nuclear radius for coordinate sampling | |
10109 | RMAX = R+4.605D0*PDIF | |
10110 | ||
10111 | * initialize pre-sorting | |
10112 | DO 121 I=1,NSRT | |
10113 | ICSRT(I) = 0 | |
10114 | 121 CONTINUE | |
10115 | DR = TWO*RMAX/DBLE(NSRT) | |
10116 | ||
10117 | * sample coordinates for N nucleons | |
10118 | DO 140 I=1,N | |
10119 | 120 CONTINUE | |
10120 | RAD = RMAX*(DT_RNDM(DR))**ONETHI | |
10121 | F = DT_DENSIT(N,RAD,R) | |
10122 | IF (DT_RNDM(RAD).GT.F) GOTO 120 | |
10123 | * theta, phi uniformly distributed | |
10124 | CT = ONE-TWO*DT_RNDM(F) | |
10125 | ST = SQRT((ONE-CT)*(ONE+CT)) | |
10126 | CALL DT_DSFECF(SFE,CFE) | |
10127 | X(1,I) = RAD*ST*CFE | |
10128 | X(2,I) = RAD*ST*SFE | |
10129 | X(3,I) = RAD*CT | |
10130 | * ensure that distance between two nucleons is greater than R2MIN | |
10131 | IF (I.LT.2) GOTO 122 | |
10132 | I1 = I-1 | |
10133 | DO 130 I2=1,I1 | |
10134 | DIST2 = (X(1,I)-X(1,I2))**2+(X(2,I)-X(2,I2))**2+ | |
10135 | & (X(3,I)-X(3,I2))**2 | |
10136 | IF (DIST2.LE.R2MIN) GOTO 120 | |
10137 | 130 CONTINUE | |
10138 | 122 CONTINUE | |
10139 | * save index according to z-bin | |
10140 | IDXZ = INT( (X(3,I)+RMAX)/DR )+1 | |
10141 | ICSRT(IDXZ) = ICSRT(IDXZ)+1 | |
10142 | IDXSRT(IDXZ,ICSRT(IDXZ)) = I | |
10143 | X1SUM = X1SUM+X(1,I) | |
10144 | X2SUM = X2SUM+X(2,I) | |
10145 | X3SUM = X3SUM+X(3,I) | |
10146 | 140 CONTINUE | |
10147 | X1SUM = X1SUM/DBLE(N) | |
10148 | X2SUM = X2SUM/DBLE(N) | |
10149 | X3SUM = X3SUM/DBLE(N) | |
10150 | DO 141 I=1,N | |
10151 | X(1,I) = X(1,I)-X1SUM | |
10152 | X(2,I) = X(2,I)-X2SUM | |
10153 | X(3,I) = X(3,I)-X3SUM | |
10154 | 141 CONTINUE | |
10155 | ||
10156 | ENDIF | |
10157 | ||
10158 | RETURN | |
10159 | END | |
10160 | ||
10161 | *$ CREATE DT_DENSIT.FOR | |
10162 | *COPY DT_DENSIT | |
10163 | * | |
10164 | *===densit=============================================================* | |
10165 | * | |
10166 | DOUBLE PRECISION FUNCTION DT_DENSIT(NA,R,RA) | |
10167 | ||
10168 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
10169 | SAVE | |
10170 | ||
10171 | PARAMETER ( LINP = 10 , | |
10172 | & LOUT = 6 , | |
10173 | & LDAT = 9 ) | |
10174 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) | |
10175 | PARAMETER (TWOPI = 6.283185307179586476925286766559D+00, | |
10176 | & PI = TWOPI/TWO) | |
10177 | ||
10178 | DIMENSION R0(18),FNORM(18) | |
10179 | DATA R0 / ZERO, ZERO, ZERO, ZERO, 2.12D0, | |
10180 | & 2.56D0, 2.41D0, 2.46D0, 2.52D0, 2.45D0, | |
10181 | & 2.37D0, 2.46D0, 2.44D0, 2.54D0, 2.58D0, | |
10182 | & 2.72D0, 2.66D0, 2.79D0/ | |
10183 | DATA FNORM /.1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01, | |
10184 | & .1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01, | |
10185 | & .1012D+01,.1039D+01,.1075D+01,.1118D+01,.1164D+01, | |
10186 | & .1214D+01,.1265D+01,.1318D+01/ | |
10187 | DATA PDIF /0.545D0/ | |
10188 | ||
10189 | DT_DENSIT = ZERO | |
10190 | * shell model | |
10191 | IF (NA.LE.4) THEN | |
10192 | STOP 'DT_DENSIT-0' | |
10193 | ELSEIF ((NA.GT.4).AND.(NA.LE.18)) THEN | |
10194 | R1 = R0(NA)/SQRT(2.5D0-4.0D0/DBLE(NA)) | |
10195 | DT_DENSIT = (ONE+(DBLE(NA)-4.0D0)/6.0D0*(R/R1)**2) | |
10196 | & *EXP(-(R/R1)**2)/FNORM(NA) | |
10197 | * Woods-Saxon | |
10198 | ELSEIF (NA.GT.18) THEN | |
10199 | DT_DENSIT = ONE/(ONE+EXP((R-RA)/PDIF)) | |
10200 | ENDIF | |
10201 | ||
10202 | RETURN | |
10203 | END | |
10204 | ||
10205 | *$ CREATE DT_RNCLUS.FOR | |
10206 | *COPY DT_RNCLUS | |
10207 | * | |
10208 | *===rnclus=============================================================* | |
10209 | * | |
10210 | DOUBLE PRECISION FUNCTION DT_RNCLUS(N) | |
10211 | ||
10212 | ************************************************************************ | |
10213 | * Nuclear radius for nucleus with mass number N. * | |
10214 | * This version dated 26.9.00 is written by S. Roesler * | |
10215 | ************************************************************************ | |
10216 | ||
10217 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
10218 | SAVE | |
10219 | ||
10220 | PARAMETER (ONE=1.0D0,THREE=3.0D0,ONETHI=ONE/THREE) | |
10221 | ||
10222 | * nucleon radius | |
10223 | PARAMETER (RNUCLE = 1.12D0) | |
10224 | ||
10225 | * nuclear radii for selected nuclei | |
10226 | DIMENSION RADNUC(18) | |
10227 | DATA RADNUC / 8*0.0D0,2.52D0,2.45D0,2.37D0,2.45D0,2.44D0,2.55D0, | |
10228 | & 2.58D0,2.71D0,2.66D0,2.71D0/ | |
10229 | ||
10230 | IF (N.LE.18) THEN | |
10231 | IF (RADNUC(N).GT.0.0D0) THEN | |
10232 | DT_RNCLUS = RADNUC(N) | |
10233 | ELSE | |
10234 | DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI | |
10235 | ENDIF | |
10236 | ELSE | |
10237 | DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI | |
10238 | ENDIF | |
10239 | ||
10240 | RETURN | |
10241 | END | |
10242 | ||
10243 | *$ CREATE DT_DENTST.FOR | |
10244 | *COPY DT_DENTST | |
10245 | * | |
10246 | *===dentst=============================================================* | |
10247 | * | |
10248 | C PROGRAM DT_DENTST | |
10249 | SUBROUTINE DT_DENTST | |
10250 | ||
10251 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
10252 | SAVE | |
10253 | ||
10254 | OPEN(40,FILE='dentst.out',STATUS='UNKNOWN') | |
10255 | OPEN(41,FILE='denmax.out',STATUS='UNKNOWN') | |
10256 | ||
10257 | RMIN = 0.0D0 | |
10258 | RMAX = 8.0D0 | |
10259 | NBINS = 500.0D0 | |
10260 | DR = (RMAX-RMIN)/DBLE(NBINS) | |
10261 | DO 1 IA=5,18 | |
10262 | FMAX = 0.0D0 | |
10263 | DO 2 IR=1,NBINS+1 | |
10264 | R = RMIN+DBLE(IR-1)*DR | |
10265 | F = DT_DENSIT(IA,R,R) | |
10266 | IF (F.GT.FMAX) FMAX = F | |
10267 | WRITE(40,'(1X,I3,2E15.5)') IA,R,F | |
10268 | 2 CONTINUE | |
10269 | WRITE(41,'(1X,I3,E15.5)') IA,FMAX | |
10270 | 1 CONTINUE | |
10271 | ||
10272 | CLOSE(40) | |
10273 | CLOSE(41) | |
10274 | ||
10275 | END | |
10276 | ||
10277 | *$ CREATE DT_SHMAKI.FOR | |
10278 | *COPY DT_SHMAKI | |
10279 | * | |
10280 | *===shmaki=============================================================* | |
10281 | * | |
10282 | SUBROUTINE DT_SHMAKI(NA,NCA,NB,NCB,IJP,PPN,MODE) | |
10283 | ||
10284 | ************************************************************************ | |
10285 | * Initialisation of Glauber formalism. This subroutine has to be * | |
10286 | * called once (in case of target emulsions as often as many different * | |
10287 | * target nuclei are considered) before events are sampled. * | |
10288 | * NA / NCA mass number/charge of projectile nucleus * | |
10289 | * NB / NCB mass number/charge of target nucleus * | |
10290 | * IJP identity of projectile (hadrons/leptons/photons) * | |
10291 | * PPN projectile momentum (for projectile nuclei: * | |
10292 | * momentum per nucleon) in target rest system * | |
10293 | * MODE = 0 Glauber formalism invoked * | |
10294 | * = 1 fitted results are loaded from data-file * | |
10295 | * = 99 NTARG is forced to be 1 * | |
10296 | * (used in connection with GLAUBERI-card only) * | |
10297 | * This version dated 22.03.96 is based on the original SHMAKI-routine * | |
10298 | * and revised by S. Roesler. * | |
10299 | ************************************************************************ | |
10300 | ||
10301 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
10302 | SAVE | |
10303 | PARAMETER ( LINP = 10 , | |
10304 | & LOUT = 6 , | |
10305 | & LDAT = 9 ) | |
10306 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0, | |
10307 | & THREE=3.0D0) | |
10308 | ||
10309 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
10310 | * Glauber formalism: parameters | |
10311 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), | |
10312 | & BMAX(NCOMPX),BSTEP(NCOMPX), | |
10313 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), | |
10314 | & NSITEB,NSTATB | |
10315 | * Lorentz-parameters of the current interaction | |
10316 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
10317 | & UMO,PPCM,EPROJ,PPROJ | |
10318 | * properties of photon/lepton projectiles | |
10319 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC | |
10320 | * kinematical cuts for lepton-nucleus interactions | |
10321 | COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX, | |
10322 | & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI | |
10323 | * Glauber formalism: cross sections | |
10324 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
10325 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
10326 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
10327 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
10328 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
10329 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
10330 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
10331 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
10332 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
10333 | & BSLOPE,NEBINI,NQBINI | |
10334 | * cuts for variable energy runs | |
10335 | COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI | |
10336 | * nucleon-nucleon event-generator | |
10337 | CHARACTER*8 CMODEL | |
10338 | LOGICAL LPHOIN | |
10339 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
10340 | * Glauber formalism: flags and parameters for statistics | |
10341 | LOGICAL LPROD | |
10342 | CHARACTER*8 CGLB | |
10343 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD | |
10344 | ||
10345 | DATA NTARG,ICOUT,IVEOUT /0,0,0/ | |
10346 | ||
10347 | C CALL DT_HISHAD | |
10348 | C STOP | |
10349 | ||
10350 | NTARG = NTARG+1 | |
10351 | IF (MODE.EQ.99) NTARG = 1 | |
10352 | NIDX = -NTARG | |
10353 | IF (MODE.EQ.-1) NIDX = NTARG | |
10354 | ||
10355 | IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) ICOUT = ICOUT+1 | |
10356 | IF (ICOUT.EQ.1) WRITE(LOUT,1000) | |
10357 | 1000 FORMAT(//,1X,'SHMAKI: Glauber formalism (Shmakov et. al) -', | |
10358 | & ' initialization',/,12X,'--------------------------', | |
10359 | & '-------------------------',/) | |
10360 | ||
10361 | IF (MODE.EQ.2) THEN | |
10362 | CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX) | |
10363 | CALL DT_SHFAST(MODE,PPN,IBACK) | |
10364 | STOP ' Glauber pre-initialization done' | |
10365 | ENDIF | |
10366 | IF (MODE.EQ.1) THEN | |
10367 | CALL DT_PROFBI(NA,NB,PPN,NTARG) | |
10368 | ELSE | |
10369 | IBACK = 1 | |
10370 | IF (MODE.EQ.3) CALL DT_SHFAST(MODE,PPN,IBACK) | |
10371 | IF (IBACK.EQ.1) THEN | |
10372 | * lepton-nucleus (variable energy runs) | |
10373 | IF ((IJP.EQ. 3).OR.(IJP.EQ. 4).OR. | |
10374 | & (IJP.EQ.10).OR.(IJP.EQ.11)) THEN | |
10375 | IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) | |
10376 | & WRITE(LOUT,1002) NB,NCB | |
10377 | 1002 FORMAT(1X,'variable energy run: projectile-id: 7', | |
10378 | & ' target A/Z: ',I3,' /',I3,/,/,8X, | |
10379 | & 'E_cm (GeV) Q^2 (GeV^2)', | |
10380 | & ' Sigma_tot (mb) Sigma_in (mb)',/,7X, | |
10381 | & '--------------------------------', | |
10382 | & '------------------------------') | |
10383 | AECMLO = LOG10(MIN(UMO,ECMLI)) | |
10384 | AECMHI = LOG10(MIN(UMO,ECMHI)) | |
10385 | IESTEP = NEB-1 | |
10386 | DAECM = (AECMHI-AECMLO)/DBLE(IESTEP) | |
10387 | IF (AECMLO.EQ.AECMHI) IESTEP = 0 | |
10388 | DO 1 I=1,IESTEP+1 | |
10389 | ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM) | |
10390 | IF (Q2HI.GT.0.1D0) THEN | |
10391 | IF (Q2LI.LT.0.01D0) THEN | |
10392 | CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX) | |
10393 | IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) | |
10394 | & WRITE(LOUT,1003) | |
10395 | & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG) | |
10396 | Q2LI = 0.01D0 | |
10397 | IBIN = 2 | |
10398 | ELSE | |
10399 | IBIN = 1 | |
10400 | ENDIF | |
10401 | IQSTEP = NQB-IBIN | |
10402 | AQ2LO = LOG10(Q2LI) | |
10403 | AQ2HI = LOG10(Q2HI) | |
10404 | DAQ2 = (AQ2HI-AQ2LO)/MAX(DBLE(IQSTEP),ONE) | |
10405 | DO 2 J=IBIN,IQSTEP+IBIN | |
10406 | Q2 = 10.0D0**(AQ2LO+DBLE(J-IBIN)*DAQ2) | |
10407 | CALL DT_XSGLAU(NA,NB,7,ZERO,Q2,ECM,I,J,NIDX) | |
10408 | IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) | |
10409 | & WRITE(LOUT,1003) ECMNN(I), | |
10410 | & Q2G(J),XSTOT(I,J,NTARG),XSPRO(I,J,NTARG) | |
10411 | 2 CONTINUE | |
10412 | ELSE | |
10413 | CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX) | |
10414 | IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) | |
10415 | & WRITE(LOUT,1003) | |
10416 | & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG) | |
10417 | ENDIF | |
10418 | 1003 FORMAT(9X,F6.1,9X,F6.2,8X,F8.3,11X,F8.3) | |
10419 | 1 CONTINUE | |
10420 | IVEOUT = 1 | |
10421 | ELSE | |
10422 | * hadron/photon/nucleus-nucleus | |
10423 | IF ((ABS(VAREHI).GT.ZERO).AND. | |
10424 | & (ABS(VAREHI).GT.ABS(VARELO))) THEN | |
10425 | IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) THEN | |
10426 | WRITE(LOUT,1004) NA,NB,NCB | |
10427 | 1004 FORMAT(1X,'variable energy run: projectile-id:', | |
10428 | & I3,' target A/Z: ',I3,' /',I3,/) | |
10429 | WRITE(LOUT,1005) | |
10430 | 1005 FORMAT(' E_cm (GeV) E_Lab (GeV) sig_tot^pp (mb)' | |
10431 | & ,' Sigma_tot (mb) Sigma_prod (mb)',/, | |
10432 | & ' -------------------------------------', | |
10433 | & '--------------------------------------') | |
10434 | ENDIF | |
10435 | AECMLO = LOG10(VARCLO) | |
10436 | AECMHI = LOG10(VARCHI) | |
10437 | IESTEP = NEB-1 | |
10438 | DAECM = (AECMHI-AECMLO)/DBLE(IESTEP) | |
10439 | IF (AECMLO.EQ.AECMHI) IESTEP = 0 | |
10440 | DO 3 I=1,IESTEP+1 | |
10441 | ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM) | |
10442 | AMP = 0.938D0 | |
10443 | AMT = 0.938D0 | |
10444 | AMP2 = AMP**2 | |
10445 | AMT2 = AMT**2 | |
10446 | ELAB = (ECM**2-AMP2-AMT2)/(TWO*AMT) | |
10447 | PLAB = SQRT((ELAB+AMP)*(ELAB-AMP)) | |
10448 | CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,ECM,I,1,NIDX) | |
10449 | IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) | |
10450 | & WRITE(LOUT,1006) | |
10451 | & ECM,PLAB,SIGSH,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG) | |
10452 | 1006 FORMAT(1X,F9.1,1X,E11.3,1X,F12.2,8X,F10.3,8X,F8.3) | |
10453 | 3 CONTINUE | |
10454 | IVEOUT = 1 | |
10455 | ELSE | |
10456 | CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX) | |
10457 | ENDIF | |
10458 | ENDIF | |
10459 | ENDIF | |
10460 | ENDIF | |
10461 | ||
10462 | IF ((ICOUT.LT.15).AND.(IVEOUT.EQ.0).AND.(MCGENE.NE.4).AND. | |
10463 | & (IOGLB.NE.100)) THEN | |
10464 | WRITE(LOUT,1001) NA,NCA,NB,NCB,ECMNN(1),SIGSH*10.0D0,ROSH, | |
10465 | & BSLOPE,NSITEB,NSTATB,XSPRO(1,1,NTARG) | |
10466 | 1001 FORMAT(38X,'projectile', | |
10467 | & ' target',/,1X,'Mass number / charge', | |
10468 | & 17X,I3,' /',I3,6X,I3,' /',I3,/,/,1X, | |
10469 | & 'Nucleon-nucleon c.m. energy',9X,F10.2,' GeV',/,/,1X, | |
10470 | & 'Parameters of elastic scattering amplitude:',/,5X, | |
10471 | & 'sigma =',F7.2,' mb',6X,'rho = ',F9.4,6X,'slope = ', | |
10472 | & F4.1,' GeV^-2',/,/,1X,'Number of b-steps',4X,I3,8X, | |
10473 | & 'statistics at each b-step',4X,I5,/,/,1X, | |
10474 | & 'Prod. cross section ',5X,F10.4,' mb',/) | |
10475 | ENDIF | |
10476 | ||
10477 | RETURN | |
10478 | END | |
10479 | ||
10480 | *$ CREATE DT_PROFBI.FOR | |
10481 | *COPY DT_PROFBI | |
10482 | * | |
10483 | *===profbi=============================================================* | |
10484 | * | |
10485 | SUBROUTINE DT_PROFBI(NA,NB,PPN,NTARG) | |
10486 | ||
10487 | ************************************************************************ | |
10488 | * Integral over profile function (to be used for impact-parameter * | |
10489 | * sampling during event generation). * | |
10490 | * Fitted results are used. * | |
10491 | * NA / NB mass numbers of proj./target nuclei * | |
10492 | * PPN projectile momentum (for projectile nuclei: * | |
10493 | * momentum per nucleon) in target rest system * | |
10494 | * NTARG index of target material (i.e. kind of nucleus) * | |
10495 | * This version dated 31.05.95 is revised by S. Roesler * | |
10496 | ************************************************************************ | |
10497 | ||
10498 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
10499 | SAVE | |
10500 | PARAMETER ( LINP = 10 , | |
10501 | & LOUT = 6 , | |
10502 | & LDAT = 9 ) | |
454792a9 | 10503 | CPH SAVE |
9aaba0d6 | 10504 | |
10505 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0) | |
10506 | ||
10507 | LOGICAL LSTART | |
10508 | CHARACTER CNAME*80 | |
10509 | ||
10510 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
10511 | * Glauber formalism: parameters | |
10512 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), | |
10513 | & BMAX(NCOMPX),BSTEP(NCOMPX), | |
10514 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), | |
10515 | & NSITEB,NSTATB | |
10516 | * Glauber formalism: cross sections | |
10517 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
10518 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
10519 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
10520 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
10521 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
10522 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
10523 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
10524 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
10525 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
10526 | & BSLOPE,NEBINI,NQBINI | |
10527 | ||
10528 | PARAMETER (NGLMAX=8000) | |
10529 | DIMENSION NGLIT(NGLMAX),NGLIP(NGLMAX),GLAPPN(NGLMAX), | |
10530 | & GLASIG(NGLMAX),GLAFIT(5,NGLMAX) | |
10531 | ||
10532 | DATA LSTART /.TRUE./ | |
10533 | ||
10534 | IF (LSTART) THEN | |
10535 | * read fit-parameters from file | |
10536 | OPEN(47,FILE='inpdata/glpara.dat',STATUS='UNKNOWN') | |
10537 | I = 0 | |
10538 | 1 CONTINUE | |
10539 | READ(47,'(A80)') CNAME | |
10540 | IF (CNAME.EQ.'STOP') GOTO 2 | |
10541 | I = I+1 | |
10542 | READ(CNAME,*) NGLIP(I),NGLIT(I),GLAPPN(I),GLASIG(I), | |
10543 | & GLAFIT(1,I),GLAFIT(2,I),GLAFIT(3,I), | |
10544 | & GLAFIT(4,I),GLAFIT(5,I) | |
10545 | IF (I+1.GT.NGLMAX) THEN | |
10546 | WRITE(LOUT,1000) | |
10547 | 1000 FORMAT(1X,'PROFBI: warning! array size exceeded - ', | |
10548 | & 'program stopped') | |
10549 | STOP | |
10550 | ENDIF | |
10551 | GOTO 1 | |
10552 | 2 CONTINUE | |
10553 | NGLPAR = I | |
10554 | LSTART = .FALSE. | |
10555 | ENDIF | |
10556 | ||
10557 | NNA = NA | |
10558 | NNB = NB | |
10559 | IF (NA.GT.NB) THEN | |
10560 | NNA = NB | |
10561 | NNB = NA | |
10562 | ENDIF | |
10563 | IDXGLA = 0 | |
10564 | DO 3 J=1,NGLPAR | |
10565 | IF ((NNB.LT.NGLIT(J)).OR.(J.EQ.NGLPAR)) THEN | |
10566 | IF (NNB.NE.NGLIT(J-1)) NNB = NGLIT(J-1) | |
10567 | DO 4 K=1,J-1 | |
10568 | IPOINT = J-K | |
10569 | IF (J.EQ.NGLPAR) IPOINT = J+1-K | |
10570 | IF ((NNA.GT.NGLIP(IPOINT)).OR. | |
10571 | & (NNB.NE.NGLIT(IPOINT)).OR.(IPOINT.EQ.1)) THEN | |
10572 | IF (IPOINT.EQ.1) IPOINT = 0 | |
10573 | NATMP = NGLIP(IPOINT+1) | |
10574 | IF (PPN.LT.GLAPPN(IPOINT+1)) THEN | |
10575 | IDXGLA = IPOINT+1 | |
10576 | GOTO 6 | |
10577 | ELSE | |
10578 | J1BEG = IPOINT+1 | |
10579 | J1END = J | |
10580 | C IF (J.EQ.NGLPAR) THEN | |
10581 | C J1BEG = IPOINT | |
10582 | C J1END = J | |
10583 | C ENDIF | |
10584 | DO 5 J1=J1BEG,J1END | |
10585 | IF (NGLIP(J1).EQ.NATMP) THEN | |
10586 | IF (PPN.LT.GLAPPN(J1)) THEN | |
10587 | IDXGLA = J1 | |
10588 | GOTO 6 | |
10589 | ENDIF | |
10590 | ELSE | |
10591 | IDXGLA = J1-1 | |
10592 | GOTO 6 | |
10593 | ENDIF | |
10594 | 5 CONTINUE | |
10595 | IF ((J.EQ.NGLPAR).AND.(PPN.GT.GLAPPN(NGLPAR))) | |
10596 | & IDXGLA = NGLPAR | |
10597 | ENDIF | |
10598 | ENDIF | |
10599 | 4 CONTINUE | |
10600 | ENDIF | |
10601 | 3 CONTINUE | |
10602 | ||
10603 | 6 CONTINUE | |
10604 | IF (IDXGLA.EQ.0) THEN | |
10605 | WRITE(LOUT,1001) NNA,NNB,PPN | |
10606 | 1001 FORMAT(1X,'PROFBI: configuration (NA,NB,PPN = ', | |
10607 | & 2I4,F6.0,') not found ') | |
10608 | STOP | |
10609 | ENDIF | |
10610 | ||
10611 | * no interpolation yet available | |
10612 | XSPRO(1,1,NTARG) = GLASIG(IDXGLA) | |
10613 | ||
10614 | BSITE(1,1,NTARG,1) = ZERO | |
10615 | DO 10 I=2,NSITEB | |
10616 | XX = DBLE(I) | |
10617 | POLY = GLAFIT(1,IDXGLA)+GLAFIT(2,IDXGLA)*XX+ | |
10618 | & GLAFIT(3,IDXGLA)*XX**2+GLAFIT(4,IDXGLA)*XX**3+ | |
10619 | & GLAFIT(5,IDXGLA)*XX**4 | |
10620 | IF (ABS(POLY).GT.35.0D0) POLY = SIGN(35.0D0,POLY) | |
10621 | BSITE(1,1,NTARG,I) = (1.0D0-EXP(-POLY)) | |
10622 | IF (BSITE(1,1,NTARG,I).LT.ZERO) BSITE(1,1,NTARG,I) = ZERO | |
10623 | 10 CONTINUE | |
10624 | ||
10625 | RETURN | |
10626 | END | |
10627 | ||
10628 | *$ CREATE DT_GLAUBE.FOR | |
10629 | *COPY DT_GLAUBE | |
10630 | * | |
10631 | *===glaube=============================================================* | |
10632 | * | |
10633 | SUBROUTINE DT_GLAUBE(NA,NB,IJPROJ,B,INTT,INTA,INTB,JS,JT,NIDX) | |
10634 | ||
10635 | ************************************************************************ | |
10636 | * Calculation of configuartion of interacting nucleons for one event. * | |
10637 | * NB / NB mass numbers of proj./target nuclei (input) * | |
10638 | * B impact parameter (output) * | |
10639 | * INTT total number of wounded nucleons " * | |
10640 | * INTA / INTB number of wounded nucleons in proj. / target " * | |
10641 | * JS / JT(i) number of collisions proj. / target nucleon i is * | |
10642 | * involved (output) * | |
10643 | * NIDX index of projectile/target material (input) * | |
10644 | * = -2 call within FLUKA transport calculation * | |
10645 | * This is an update of the original routine SHMAKO by J.Ranft/HJM * | |
10646 | * This version dated 22.03.96 is revised by S. Roesler * | |
10647 | * * | |
10648 | * Last change 27.12.2006 by S. Roesler. * | |
10649 | ************************************************************************ | |
10650 | ||
10651 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
10652 | SAVE | |
10653 | PARAMETER ( LINP = 10 , | |
10654 | & LOUT = 6 , | |
10655 | & LDAT = 9 ) | |
10656 | PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14, | |
10657 | & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0) | |
10658 | ||
10659 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
10660 | PARAMETER ( MAXNCL = 260, | |
10661 | & MAXVQU = MAXNCL, | |
10662 | & MAXSQU = 20*MAXVQU, | |
10663 | & MAXINT = MAXVQU+MAXSQU) | |
10664 | * Glauber formalism: parameters | |
10665 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), | |
10666 | & BMAX(NCOMPX),BSTEP(NCOMPX), | |
10667 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), | |
10668 | & NSITEB,NSTATB | |
10669 | * Glauber formalism: cross sections | |
10670 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
10671 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
10672 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
10673 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
10674 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
10675 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
10676 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
10677 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
10678 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
10679 | & BSLOPE,NEBINI,NQBINI | |
10680 | * Lorentz-parameters of the current interaction | |
10681 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
10682 | & UMO,PPCM,EPROJ,PPROJ | |
10683 | * properties of photon/lepton projectiles | |
10684 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC | |
10685 | * Glauber formalism: collision properties | |
10686 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, | |
10687 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC | |
10688 | * Glauber formalism: flags and parameters for statistics | |
10689 | LOGICAL LPROD | |
10690 | CHARACTER*8 CGLB | |
10691 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD | |
10692 | ||
10693 | DIMENSION JS(MAXNCL),JT(MAXNCL) | |
10694 | ||
10695 | NTARG = ABS(NIDX) | |
10696 | ||
10697 | * get actual energy from /DTLTRA/ | |
10698 | ECMNOW = UMO | |
10699 | Q2 = VIRT | |
10700 | * | |
10701 | * new patch for pre-initialized variable projectile/target/energy runs, | |
10702 | * bypassed for use within FLUKA (Nidx=-2) | |
10703 | IF (IOGLB.EQ.100) THEN | |
10704 | IF (NIDX.NE.-2) CALL DT_GLBSET(IJPROJ,NA,NB,EPROJ,1) | |
10705 | * | |
10706 | * variable energy run, interpolate profile function | |
10707 | ELSE | |
10708 | I1 = 1 | |
10709 | I2 = 1 | |
10710 | RATE = ONE | |
10711 | IF (NEBINI.GT.1) THEN | |
10712 | IF (ECMNOW.GE.ECMNN(NEBINI)) THEN | |
10713 | I1 = NEBINI | |
10714 | I2 = NEBINI | |
10715 | RATE = ONE | |
10716 | ELSEIF (ECMNOW.GT.ECMNN(1)) THEN | |
10717 | DO 1 I=2,NEBINI | |
10718 | IF (ECMNOW.LT.ECMNN(I)) THEN | |
10719 | I1 = I-1 | |
10720 | I2 = I | |
10721 | RATE = (ECMNOW-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1)) | |
10722 | GOTO 2 | |
10723 | ENDIF | |
10724 | 1 CONTINUE | |
10725 | 2 CONTINUE | |
10726 | ENDIF | |
10727 | ENDIF | |
10728 | J1 = 1 | |
10729 | J2 = 1 | |
10730 | RATQ = ONE | |
10731 | IF (NQBINI.GT.1) THEN | |
10732 | IF (Q2.GE.Q2G(NQBINI)) THEN | |
10733 | J1 = NQBINI | |
10734 | J2 = NQBINI | |
10735 | RATQ = ONE | |
10736 | ELSEIF (Q2.GT.Q2G(1)) THEN | |
10737 | DO 3 I=2,NQBINI | |
10738 | IF (Q2.LT.Q2G(I)) THEN | |
10739 | J1 = I-1 | |
10740 | J2 = I | |
10741 | RATQ = LOG10( Q2/MAX(Q2G(J1),TINY14))/ | |
10742 | & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14)) | |
10743 | C RATQ = (Q2-Q2G(J1))/(Q2G(J2)-Q2G(J1)) | |
10744 | GOTO 4 | |
10745 | ENDIF | |
10746 | 3 CONTINUE | |
10747 | 4 CONTINUE | |
10748 | ENDIF | |
10749 | ENDIF | |
10750 | ||
10751 | DO 5 I=1,KSITEB | |
10752 | BSITE(0,1,NTARG,I) = BSITE(I1,J1,NTARG,I)+ | |
10753 | & RATE*(BSITE(I2,J1,NTARG,I)-BSITE(I1,J1,NTARG,I))+ | |
10754 | & RATQ*(BSITE(I1,J2,NTARG,I)-BSITE(I1,J1,NTARG,I))+ | |
10755 | & RATE*RATQ*(BSITE(I2,J2,NTARG,I)-BSITE(I1,J2,NTARG,I)+ | |
10756 | & BSITE(I1,J1,NTARG,I)-BSITE(I2,J1,NTARG,I)) | |
10757 | 5 CONTINUE | |
10758 | ENDIF | |
10759 | ||
10760 | CALL DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,INTT,INTA,INTB,IDIREC,NIDX) | |
10761 | IF (NIDX.LE.-1) THEN | |
10762 | RPROJ = RASH(1) | |
10763 | RTARG = RBSH(NTARG) | |
10764 | ELSE | |
10765 | RPROJ = RASH(NTARG) | |
10766 | RTARG = RBSH(1) | |
10767 | ENDIF | |
10768 | ||
10769 | RETURN | |
10770 | END | |
10771 | ||
10772 | *$ CREATE DT_DIAGR.FOR | |
10773 | *COPY DT_DIAGR | |
10774 | * | |
10775 | *===diagr==============================================================* | |
10776 | * | |
10777 | SUBROUTINE DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,JNT,INTA,INTB,IDIREC, | |
10778 | & NIDX) | |
10779 | ||
10780 | ************************************************************************ | |
10781 | * Based on the original version by Shmakov et al. * | |
10782 | * This version dated 21.04.95 is revised by S. Roesler * | |
10783 | ************************************************************************ | |
10784 | ||
10785 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
10786 | SAVE | |
10787 | PARAMETER ( LINP = 10 , | |
10788 | & LOUT = 6 , | |
10789 | & LDAT = 9 ) | |
10790 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) | |
10791 | PARAMETER (TWOPI = 6.283185307179586454D+00, | |
10792 | & PI = TWOPI/TWO, | |
10793 | & GEV2MB = 0.38938D0, | |
10794 | & GEV2FM = 0.1972D0, | |
10795 | & ALPHEM = ONE/137.0D0, | |
10796 | * proton mass | |
10797 | & AMP = 0.938D0, | |
10798 | & AMP2 = AMP**2, | |
10799 | * rho0 mass | |
10800 | & AMRHO0 = 0.77D0) | |
10801 | ||
10802 | COMPLEX*16 C,CA,CI | |
10803 | PARAMETER ( MAXNCL = 260, | |
10804 | & MAXVQU = MAXNCL, | |
10805 | & MAXSQU = 20*MAXVQU, | |
10806 | & MAXINT = MAXVQU+MAXSQU) | |
10807 | * particle properties (BAMJET index convention) | |
10808 | CHARACTER*8 ANAME | |
10809 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
10810 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
10811 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
10812 | * emulsion treatment | |
10813 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
10814 | & NCOMPO,IEMUL | |
10815 | * Glauber formalism: parameters | |
10816 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), | |
10817 | & BMAX(NCOMPX),BSTEP(NCOMPX), | |
10818 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), | |
10819 | & NSITEB,NSTATB | |
10820 | * Glauber formalism: cross sections | |
10821 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
10822 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
10823 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
10824 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
10825 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
10826 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
10827 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
10828 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
10829 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
10830 | & BSLOPE,NEBINI,NQBINI | |
10831 | * VDM parameter for photon-nucleus interactions | |
10832 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
10833 | * nucleon-nucleon event-generator | |
10834 | CHARACTER*8 CMODEL | |
10835 | LOGICAL LPHOIN | |
10836 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
10837 | **PHOJET105a | |
10838 | C COMMON /CUTOFF/ PTCUT(4),CUTMU(4),FPS(4),FPH(4),PSOMIN,XSOMIN | |
10839 | **PHOJET112 | |
10840 | C obsolete cut-off information | |
10841 | DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN | |
10842 | COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN | |
10843 | ** | |
10844 | * coordinates of nucleons | |
10845 | COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL) | |
10846 | * interface between Glauber formalism and DPM | |
10847 | COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL), | |
10848 | & INTER1(MAXINT),INTER2(MAXINT) | |
10849 | * statistics: Glauber-formalism | |
10850 | COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB | |
10851 | * n-n cross section fluctuations | |
10852 | PARAMETER (NBINS = 1000) | |
10853 | COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT | |
10854 | ||
10855 | DIMENSION JS(MAXNCL),JT(MAXNCL), | |
10856 | & JS0(MAXNCL),JT0(MAXNCL,MAXNCL), | |
10857 | & JI1(MAXNCL,MAXNCL),JI2(MAXNCL,MAXNCL),JNT0(MAXNCL) | |
10858 | DIMENSION NWA(0:210),NWB(0:210) | |
10859 | ||
10860 | LOGICAL LFIRST | |
10861 | DATA LFIRST /.TRUE./ | |
10862 | ||
10863 | DATA NTARGO,ICNT /0,0/ | |
10864 | ||
10865 | NTARG = ABS(NIDX) | |
10866 | ||
10867 | IF (LFIRST) THEN | |
10868 | LFIRST = .FALSE. | |
10869 | IF (NCOMPO.EQ.0) THEN | |
10870 | NCALL = 0 | |
10871 | NWAMAX = NA | |
10872 | NWBMAX = NB | |
10873 | DO 17 I=0,210 | |
10874 | NWA(I) = 0 | |
10875 | NWB(I) = 0 | |
10876 | 17 CONTINUE | |
10877 | ENDIF | |
10878 | ENDIF | |
10879 | IF (NTARG.EQ.-1) THEN | |
10880 | IF (NCOMPO.EQ.0) THEN | |
10881 | WRITE(LOUT,*) ' DIAGR: distribution of wounded nucleons' | |
10882 | WRITE(LOUT,'(8X,A,3I7)') 'NCALL,NWAMAX,NWBMAX = ', | |
10883 | & NCALL,NWAMAX,NWBMAX | |
10884 | DO 18 I=1,MAX(NWAMAX,NWBMAX) | |
10885 | WRITE(LOUT,'(8X,2I7,E12.4,I7,E12.4)') | |
10886 | & I,NWA(I),DBLE(NWA(I))/DBLE(NCALL), | |
10887 | & NWB(I),DBLE(NWB(I))/DBLE(NCALL) | |
10888 | 18 CONTINUE | |
10889 | ENDIF | |
10890 | RETURN | |
10891 | ENDIF | |
10892 | ||
10893 | DCOH = 1.0D10 | |
10894 | IPNT = 0 | |
10895 | ||
10896 | SQ2 = Q2 | |
10897 | IF (SQ2.LE.ZERO) SQ2 = 0.0001D0 | |
10898 | S = ECMNOW**2 | |
10899 | X = SQ2/(S+SQ2-AMP2) | |
10900 | XNU = (S+SQ2-AMP2)/(TWO*AMP) | |
10901 | * photon projectiles: recalculate photon-nucleon amplitude | |
10902 | IF (IJPROJ.EQ.7) THEN | |
10903 | 15 CONTINUE | |
10904 | * VDM assumption: mass of V-meson | |
10905 | AMV2 = DT_SAM2(SQ2,ECMNOW) | |
10906 | AMV = SQRT(AMV2) | |
10907 | IF (AMV.GT.2.0D0*PTCUT(1)) GOTO 15 | |
10908 | * check for pointlike interaction | |
10909 | CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,1) | |
10910 | **sr 27.10. | |
10911 | C SIGSH = DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0 | |
10912 | SIGSH = (ONE-RPNT)*DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0 | |
10913 | ** | |
10914 | ROSH = 0.1D0 | |
10915 | BSLOPE = 2.0D0*(2.0D0+AMRHO0**2/(AMV2+SQ2) | |
10916 | & +0.25D0*LOG(S/(AMV2+SQ2))) | |
10917 | * coherence length | |
10918 | IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+SQ2)*GEV2FM | |
10919 | ELSEIF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN | |
10920 | IF (MCGENE.EQ.2) THEN | |
10921 | ZERO1 = ZERO | |
10922 | CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SDUM1,SDUM2,SDUM3, | |
10923 | & BSLOPE,0) | |
10924 | ELSE | |
10925 | BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S)) | |
10926 | ENDIF | |
10927 | IF (ECMNOW.LE.3.0D0) THEN | |
10928 | ROSH = -0.43D0 | |
10929 | ELSEIF ((ECMNOW.GT.3.0D0).AND.(ECMNOW.LE.50.D0)) THEN | |
10930 | ROSH = -0.63D0+0.175D0*LOG(ECMNOW) | |
10931 | ELSEIF (ECMNOW.GT.50.0D0) THEN | |
10932 | ROSH = 0.1D0 | |
10933 | ENDIF | |
10934 | ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP) | |
10935 | PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) ) | |
10936 | IF (MCGENE.EQ.2) THEN | |
10937 | ZERO1 = ZERO | |
10938 | CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SIGSH,SDUM2,SDUM3, | |
10939 | & BDUM,0) | |
10940 | SIGSH = SIGSH/10.0D0 | |
10941 | ELSE | |
10942 | C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0 | |
10943 | DUMZER = ZERO | |
10944 | CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL) | |
10945 | SIGSH = SIGSH/10.0D0 | |
10946 | ENDIF | |
10947 | ELSE | |
10948 | BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S)) | |
10949 | ROSH = 0.01D0 | |
10950 | ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP) | |
10951 | PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) ) | |
10952 | C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0 | |
10953 | DUMZER = ZERO | |
10954 | CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL) | |
10955 | SIGSH = SIGSH/10.0D0 | |
10956 | ENDIF | |
10957 | GSH = 10.0D0/(TWO*BSLOPE*GEV2MB) | |
10958 | GAM = GSH | |
10959 | RCA = GAM*SIGSH/TWOPI | |
10960 | FCA = -ROSH*RCA | |
10961 | CA = DCMPLX(RCA,FCA) | |
10962 | CI = DCMPLX(ONE,ZERO) | |
10963 | ||
10964 | 16 CONTINUE | |
10965 | * impact parameter | |
10966 | IF (MCGENE.NE.3) CALL DT_MODB(B,NIDX) | |
10967 | ||
10968 | NTRY = 0 | |
10969 | 3 CONTINUE | |
10970 | NTRY = NTRY+1 | |
10971 | * initializations | |
10972 | JNT = 0 | |
10973 | DO 1 I=1,NA | |
10974 | JS(I) = 0 | |
10975 | 1 CONTINUE | |
10976 | DO 2 I=1,NB | |
10977 | JT(I) = 0 | |
10978 | 2 CONTINUE | |
10979 | IF (IJPROJ.EQ.7) THEN | |
10980 | DO 8 I=1,MAXNCL | |
10981 | JS0(I) = 0 | |
10982 | JNT0(I)= 0 | |
10983 | DO 9 J=1,NB | |
10984 | JT0(I,J) = 0 | |
10985 | 9 CONTINUE | |
10986 | 8 CONTINUE | |
10987 | ENDIF | |
10988 | ||
10989 | * nucleon configuration | |
10990 | C IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,5).EQ.0)) THEN | |
10991 | IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,1).EQ.0)) THEN | |
10992 | C CALL DT_CONUCL(PKOO,NA,RASH,2) | |
10993 | C CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),1) | |
10994 | IF (NIDX.LE.-1) THEN | |
10995 | CALL DT_CONUCL(PKOO,NA,RASH(1),0) | |
10996 | CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),0) | |
10997 | ELSE | |
10998 | CALL DT_CONUCL(PKOO,NA,RASH(NTARG),0) | |
10999 | CALL DT_CONUCL(TKOO,NB,RBSH(1),0) | |
11000 | ENDIF | |
11001 | NTARGO = NTARG | |
11002 | ENDIF | |
11003 | ICNT = ICNT+1 | |
11004 | ||
11005 | * LEPTO: pick out one struck nucleon | |
11006 | IF (MCGENE.EQ.3) THEN | |
11007 | JNT = 1 | |
11008 | JS(1) = 1 | |
11009 | IDX = INT(DT_RNDM(X)*NB)+1 | |
11010 | JT(IDX) = 1 | |
11011 | B = ZERO | |
11012 | GOTO 19 | |
11013 | ENDIF | |
11014 | ||
11015 | DO 4 INA=1,NA | |
11016 | * cross section fluctuations | |
11017 | AFLUC = ONE | |
11018 | IF (IFLUCT.EQ.1) THEN | |
11019 | IFLUK = INT((DT_RNDM(X)+0.001D0)*1000.0D0) | |
11020 | AFLUC = FLUIXX(IFLUK) | |
11021 | ENDIF | |
11022 | KK1 = 1 | |
11023 | KINT = 1 | |
11024 | DO 5 INB=1,NB | |
11025 | * photon-projectile: check for supression by coherence length | |
11026 | IF (IJPROJ.EQ.7) THEN | |
11027 | IF (ABS(TKOO(3,INB)-TKOO(3,KK1)).GT.DCOH) THEN | |
11028 | KK1 = INB | |
11029 | KINT = KINT+1 | |
11030 | ENDIF | |
11031 | ENDIF | |
11032 | QQ1 = B+TKOO(1,INB)-PKOO(1,INA) | |
11033 | QQ2 = TKOO(2,INB)-PKOO(2,INA) | |
11034 | XY = GAM*(QQ1*QQ1+QQ2*QQ2) | |
11035 | IF (XY.LE.15.0D0) THEN | |
11036 | C = CI-CA*AFLUC*EXP(-XY) | |
11037 | AR = DBLE(C) | |
11038 | AI = DIMAG(C) | |
11039 | P = AR*AR+AI*AI | |
11040 | IF (DT_RNDM(XY).GE.P) THEN | |
11041 | JNT = JNT+1 | |
11042 | IF (IJPROJ.EQ.7) THEN | |
11043 | JNT0(KINT) = JNT0(KINT)+1 | |
11044 | IF (JNT0(KINT).GT.MAXNCL) THEN | |
11045 | WRITE(LOUT,1001) MAXNCL | |
11046 | 1001 FORMAT(1X, | |
11047 | & 'DIAGR: no. of requested interactions', | |
11048 | & ' exceeds array dimensions ',I4) | |
11049 | STOP | |
11050 | ENDIF | |
11051 | JS0(KINT) = JS0(KINT)+1 | |
11052 | JT0(KINT,INB) = JT0(KINT,INB)+1 | |
11053 | JI1(KINT,JNT0(KINT)) = INA | |
11054 | JI2(KINT,JNT0(KINT)) = INB | |
11055 | ELSE | |
11056 | IF (JNT.GT.MAXINT) THEN | |
11057 | WRITE(LOUT,1000) JNT, MAXINT | |
11058 | 1000 FORMAT(1X, | |
11059 | & 'DIAGR: no. of requested interactions (' | |
11060 | & ,I4,') exceeds array dimensions (',I4,')') | |
11061 | STOP | |
11062 | ENDIF | |
11063 | JS(INA) = JS(INA)+1 | |
11064 | JT(INB) = JT(INB)+1 | |
11065 | INTER1(JNT) = INA | |
11066 | INTER2(JNT) = INB | |
11067 | ENDIF | |
11068 | ENDIF | |
11069 | ENDIF | |
11070 | 5 CONTINUE | |
11071 | 4 CONTINUE | |
11072 | ||
11073 | IF (JNT.EQ.0) THEN | |
11074 | IF (NTRY.LT.500) THEN | |
11075 | GOTO 3 | |
11076 | ELSE | |
11077 | C WRITE(6,*) ' new impact parameter required (old= ',B,')' | |
11078 | GOTO 16 | |
11079 | ENDIF | |
11080 | ENDIF | |
11081 | ||
11082 | IDIREC = 0 | |
11083 | IF (IJPROJ.EQ.7) THEN | |
11084 | K = INT(ONE+DT_RNDM(X)*DBLE(KINT)) | |
11085 | 10 CONTINUE | |
11086 | IF (JNT0(K).EQ.0) THEN | |
11087 | K = K+1 | |
11088 | IF (K.GT.KINT) K = 1 | |
11089 | GOTO 10 | |
11090 | ENDIF | |
11091 | * supress Glauber-cascade by direct photon processes | |
11092 | CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,2) | |
11093 | IF (IPNT.GT.0) THEN | |
11094 | JNT = 1 | |
11095 | JS(1) = 1 | |
11096 | DO 11 INB=1,NB | |
11097 | JT(INB) = JT0(K,INB) | |
11098 | IF (JT(INB).GT.0) GOTO 12 | |
11099 | 11 CONTINUE | |
11100 | 12 CONTINUE | |
11101 | INTER1(1) = 1 | |
11102 | INTER2(1) = INB | |
11103 | IDIREC = IPNT | |
11104 | ELSE | |
11105 | JNT = JNT0(K) | |
11106 | JS(1) = JS0(K) | |
11107 | DO 13 INB=1,NB | |
11108 | JT(INB) = JT0(K,INB) | |
11109 | 13 CONTINUE | |
11110 | DO 14 I=1,JNT | |
11111 | INTER1(I) = JI1(K,I) | |
11112 | INTER2(I) = JI2(K,I) | |
11113 | 14 CONTINUE | |
11114 | ENDIF | |
11115 | ENDIF | |
11116 | ||
11117 | 19 CONTINUE | |
11118 | INTA = 0 | |
11119 | INTB = 0 | |
11120 | DO 6 I=1,NA | |
11121 | IF (JS(I).NE.0) INTA=INTA+1 | |
11122 | 6 CONTINUE | |
11123 | DO 7 I=1,NB | |
11124 | IF (JT(I).NE.0) INTB=INTB+1 | |
11125 | 7 CONTINUE | |
11126 | ICWPG = INTA | |
11127 | ICWTG = INTB | |
11128 | ICIG = JNT | |
11129 | IPGLB = IPGLB+INTA | |
11130 | ITGLB = ITGLB+INTB | |
11131 | NGLB = NGLB+1 | |
11132 | ||
11133 | IF (NCOMPO.EQ.0) THEN | |
11134 | NCALL = NCALL+1 | |
11135 | NWA(INTA) = NWA(INTA)+1 | |
11136 | NWB(INTB) = NWB(INTB)+1 | |
11137 | ENDIF | |
11138 | ||
11139 | RETURN | |
11140 | END | |
11141 | ||
11142 | *$ CREATE DT_MODB.FOR | |
11143 | *COPY DT_MODB | |
11144 | * | |
11145 | *===modb===============================================================* | |
11146 | * | |
11147 | SUBROUTINE DT_MODB(B,NIDX) | |
11148 | ||
11149 | ************************************************************************ | |
11150 | * Sampling of impact parameter of collision. * | |
11151 | * B impact parameter (output) * | |
11152 | * NIDX index of projectile/target material (input)* | |
11153 | * Based on the original version by Shmakov et al. * | |
11154 | * This version dated 21.04.95 is revised by S. Roesler * | |
11155 | * * | |
11156 | * Last change 27.12.2006 by S. Roesler. * | |
11157 | ************************************************************************ | |
11158 | ||
11159 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
11160 | SAVE | |
11161 | PARAMETER ( LINP = 10 , | |
11162 | & LOUT = 6 , | |
11163 | & LDAT = 9 ) | |
11164 | PARAMETER (ZERO=0.0D0,TINY15=1.0D-15,ONE=1.0D0,TWO=2.0D0) | |
11165 | ||
11166 | LOGICAL LEFT,LFIRST | |
11167 | ||
11168 | * central particle production, impact parameter biasing | |
11169 | COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR | |
11170 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
11171 | * Glauber formalism: parameters | |
11172 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), | |
11173 | & BMAX(NCOMPX),BSTEP(NCOMPX), | |
11174 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), | |
11175 | & NSITEB,NSTATB | |
11176 | * Glauber formalism: cross sections | |
11177 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
11178 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
11179 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
11180 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
11181 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
11182 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
11183 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
11184 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
11185 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
11186 | & BSLOPE,NEBINI,NQBINI | |
11187 | ||
11188 | DATA LFIRST /.TRUE./ | |
11189 | ||
11190 | NTARG = ABS(NIDX) | |
11191 | IF (NIDX.LE.-1) THEN | |
11192 | RA = RASH(1) | |
11193 | RB = RBSH(NTARG) | |
11194 | ELSE | |
11195 | RA = RASH(NTARG) | |
11196 | RB = RBSH(1) | |
11197 | ENDIF | |
11198 | ||
11199 | IF (ICENTR.EQ.2) THEN | |
11200 | IF (RA.EQ.RB) THEN | |
11201 | BB = DT_RNDM(B)*(0.3D0*RA)**2 | |
11202 | B = SQRT(BB) | |
11203 | ELSEIF(RA.LT.RB)THEN | |
11204 | BB = DT_RNDM(B)*1.4D0*(RB-RA)**2 | |
11205 | B = SQRT(BB) | |
11206 | ELSEIF(RA.GT.RB)THEN | |
11207 | BB = DT_RNDM(B)*1.4D0*(RA-RB)**2 | |
11208 | B = SQRT(BB) | |
11209 | ENDIF | |
11210 | ELSE | |
11211 | 9 CONTINUE | |
11212 | Y = DT_RNDM(BB) | |
11213 | I0 = 1 | |
11214 | I2 = NSITEB | |
11215 | 10 CONTINUE | |
11216 | I1 = (I0+I2)/2 | |
11217 | LEFT = ((BSITE(0,1,NTARG,I0)-Y) | |
11218 | & *(BSITE(0,1,NTARG,I1)-Y)).LT.ZERO | |
11219 | IF (LEFT) GOTO 20 | |
11220 | I0 = I1 | |
11221 | GOTO 30 | |
11222 | 20 CONTINUE | |
11223 | I2 = I1 | |
11224 | 30 CONTINUE | |
11225 | IF (I2-I0-2) 40,50,60 | |
11226 | 40 CONTINUE | |
11227 | I1 = I2+1 | |
11228 | IF (I1.GT.NSITEB) I1 = I0-1 | |
11229 | GOTO 70 | |
11230 | 50 CONTINUE | |
11231 | I1 = I0+1 | |
11232 | GOTO 70 | |
11233 | 60 CONTINUE | |
11234 | GOTO 10 | |
11235 | 70 CONTINUE | |
11236 | X0 = DBLE(I0-1)*BSTEP(NTARG) | |
11237 | X1 = DBLE(I1-1)*BSTEP(NTARG) | |
11238 | X2 = DBLE(I2-1)*BSTEP(NTARG) | |
11239 | Y0 = BSITE(0,1,NTARG,I0) | |
11240 | Y1 = BSITE(0,1,NTARG,I1) | |
11241 | Y2 = BSITE(0,1,NTARG,I2) | |
11242 | 80 CONTINUE | |
11243 | B = X0*(Y-Y1)*(Y-Y2)/((Y0-Y1)*(Y0-Y2)+TINY15)+ | |
11244 | & X1*(Y-Y0)*(Y-Y2)/((Y1-Y0)*(Y1-Y2)+TINY15)+ | |
11245 | & X2*(Y-Y0)*(Y-Y1)/((Y2-Y0)*(Y2-Y1)+TINY15) | |
11246 | **sr 5.4.98: shift B by half the bin width to be in agreement with BPROD | |
11247 | B = B+0.5D0*BSTEP(NTARG) | |
11248 | IF (B.LT.ZERO) B = X1 | |
11249 | IF (B.GT.BMAX(NTARG)) B = BMAX(NTARG) | |
11250 | IF (ICENTR.LT.0) THEN | |
11251 | IF (LFIRST) THEN | |
11252 | LFIRST = .FALSE. | |
11253 | IF (ICENTR.LE.-100) THEN | |
11254 | BIMIN = 0.0D0 | |
11255 | ELSE | |
11256 | XSFRAC = 0.0D0 | |
11257 | ENDIF | |
11258 | CALL DT_GETBXS(XSFRAC,BIMIN,BIMAX,NTARG) | |
11259 | WRITE(LOUT,1000) RASH(1),RBSH(NTARG),BMAX(NTARG), | |
11260 | & BIMIN,BIMAX,XSFRAC*100.0D0, | |
11261 | & XSFRAC*XSPRO(1,1,NTARG) | |
11262 | 10000 FORMAT(/,1X,'DT_MODB: Biasing in impact parameter', | |
11263 | & /,15X,'---------------------------'/,/,4X, | |
11264 | & 'average radii of proj / targ :',F10.3,' fm /', | |
11265 | & F7.3,' fm',/,4X,'corresp. b_max (4*(r_p+r_t)) :', | |
11266 | & F10.3,' fm',/,/,21X,'b_lo / b_hi :', | |
11267 | & F10.3,' fm /',F7.3,' fm',/,5X,'percentage of', | |
11268 | & ' cross section :',F10.3,' %',/,5X, | |
11269 | & 'corresponding cross section :',F10.3,' mb',/) | |
11270 | ENDIF | |
11271 | IF (ABS(BIMAX-BIMIN).LT.1.0D-3) THEN | |
11272 | B = BIMIN | |
11273 | ELSE | |
11274 | IF ((B.LT.BIMIN).OR.(B.GT.BIMAX)) GOTO 9 | |
11275 | ENDIF | |
11276 | ENDIF | |
11277 | ENDIF | |
11278 | ||
11279 | RETURN | |
11280 | END | |
11281 | ||
11282 | *$ CREATE DT_SHFAST.FOR | |
11283 | *COPY DT_SHFAST | |
11284 | * | |
11285 | *===shfast=============================================================* | |
11286 | * | |
11287 | SUBROUTINE DT_SHFAST(MODE,PPN,IBACK) | |
11288 | ||
11289 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
11290 | SAVE | |
11291 | PARAMETER ( LINP = 10 , | |
11292 | & LOUT = 6 , | |
11293 | & LDAT = 9 ) | |
11294 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY1=1.0D-1, | |
11295 | & ONE=1.0D0,TWO=2.0D0) | |
11296 | ||
11297 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
11298 | * Glauber formalism: parameters | |
11299 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), | |
11300 | & BMAX(NCOMPX),BSTEP(NCOMPX), | |
11301 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), | |
11302 | & NSITEB,NSTATB | |
11303 | * properties of interacting particles | |
11304 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
11305 | * Glauber formalism: cross sections | |
11306 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
11307 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
11308 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
11309 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
11310 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
11311 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
11312 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
11313 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
11314 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
11315 | & BSLOPE,NEBINI,NQBINI | |
11316 | ||
11317 | IBACK = 0 | |
11318 | ||
11319 | IF (MODE.EQ.2) THEN | |
11320 | OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN') | |
11321 | WRITE(47,1000) IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG,PPN | |
11322 | 1000 FORMAT(1X,8I5,E15.5) | |
11323 | WRITE(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1) | |
11324 | 1001 FORMAT(1X,4E15.5) | |
11325 | WRITE(47,1002) SIGSH,ROSH,GSH | |
11326 | 1002 FORMAT(1X,3E15.5) | |
11327 | DO 10 I=1,100 | |
11328 | WRITE(47,'(1X,E15.5)') BSITE(1,1,1,I) | |
11329 | 10 CONTINUE | |
11330 | WRITE(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE | |
11331 | 1003 FORMAT(1X,2I10,3E15.5) | |
11332 | CLOSE(47) | |
11333 | ELSE | |
11334 | OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN') | |
11335 | READ(47,1000) JT,JTZ,JP,JPZ,JJPROJ,JBPROJ,JJTARG,JBTARG,PP | |
11336 | IF ((JT.EQ.IT).AND.(JTZ.EQ.ITZ).AND.(JP.EQ.IP).AND. | |
11337 | & (JPZ.EQ.IPZ).AND.(JJPROJ.EQ.IJPROJ).AND.(JBPROJ.EQ.IBPROJ) | |
11338 | & .AND.(JJTARG.EQ.IJTARG).AND.(JBTARG.EQ.IBTARG).AND. | |
11339 | & (ABS(PP-PPN).LT.(PPN*0.01D0))) THEN | |
11340 | READ(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1) | |
11341 | READ(47,1002) SIGSH,ROSH,GSH | |
11342 | DO 11 I=1,100 | |
11343 | READ(47,'(1X,E15.5)') BSITE(1,1,1,I) | |
11344 | 11 CONTINUE | |
11345 | READ(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE | |
11346 | ELSE | |
11347 | IBACK = 1 | |
11348 | ENDIF | |
11349 | CLOSE(47) | |
11350 | ENDIF | |
11351 | ||
11352 | RETURN | |
11353 | END | |
11354 | ||
11355 | *$ CREATE DT_POILIK.FOR | |
11356 | *COPY DT_POILIK | |
11357 | * | |
11358 | *===poilik=============================================================* | |
11359 | * | |
11360 | SUBROUTINE DT_POILIK(NB,NTARG,ECM,VIRT,IPNT,RPNT,MODE) | |
11361 | ||
11362 | IMPLICIT DOUBLE PRECISION(A-H,O-Z) | |
11363 | SAVE | |
11364 | ||
11365 | PARAMETER ( LINP = 10 , | |
11366 | & LOUT = 6 , | |
11367 | & LDAT = 9 ) | |
11368 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.0D0) | |
11369 | PARAMETER (NE = 8) | |
11370 | ||
11371 | **PHOJET105a | |
11372 | C CHARACTER*8 MDLNA | |
11373 | C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100) | |
11374 | C PARAMETER (IEETAB=10) | |
11375 | C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX | |
11376 | **PHOJET110 | |
11377 | C model switches and parameters | |
11378 | CHARACTER*8 MDLNA | |
11379 | INTEGER ISWMDL,IPAMDL | |
11380 | DOUBLE PRECISION PARMDL | |
11381 | COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400) | |
11382 | C energy-interpolation table | |
11383 | INTEGER IEETA2 | |
11384 | PARAMETER ( IEETA2 = 20 ) | |
11385 | INTEGER ISIMAX | |
11386 | DOUBLE PRECISION SIGTAB,SIGECM | |
11387 | COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX | |
11388 | ** | |
11389 | * VDM parameter for photon-nucleus interactions | |
11390 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
11391 | **sr 22.7.97 | |
11392 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
11393 | * Glauber formalism: cross sections | |
11394 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
11395 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
11396 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
11397 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
11398 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
11399 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
11400 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
11401 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
11402 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
11403 | & BSLOPE,NEBINI,NQBINI | |
11404 | ** | |
11405 | ||
11406 | DATA ECMOLD,Q2OLD /-1.0D0,-1.0D0/ | |
11407 | ||
11408 | IF ((ECM.EQ.ECMOLD).AND.(VIRT.EQ.Q2OLD)) GOTO 3 | |
11409 | ||
11410 | * load cross sections from interpolation table | |
11411 | IP = 1 | |
11412 | IF(ECM.LE.SIGECM(IP,1)) THEN | |
11413 | I1 = 1 | |
11414 | I2 = 1 | |
11415 | ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN | |
11416 | DO 50 I=2,ISIMAX | |
11417 | IF(ECM.LE.SIGECM(IP,I)) GOTO 200 | |
11418 | 50 CONTINUE | |
11419 | 200 CONTINUE | |
11420 | I1 = I-1 | |
11421 | I2 = I | |
11422 | ELSE | |
11423 | WRITE(LOUT,'(/1X,A,2E12.3)') | |
11424 | & 'POILIK:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX) | |
11425 | I1 = ISIMAX | |
11426 | I2 = ISIMAX | |
11427 | ENDIF | |
11428 | FAC2 = ZERO | |
11429 | IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1)) | |
11430 | & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1)) | |
11431 | FAC1 = ONE-FAC2 | |
11432 | ||
11433 | SIGANO = DT_SANO(ECM) | |
11434 | ||
11435 | * cross section dependence on photon virtuality | |
11436 | FSUP1 = ZERO | |
11437 | DO 150 I=1,3 | |
11438 | FSUP1 = FSUP1+PARMDL(26+I)*(ONE+VIRT/(4.D0*PARMDL(30+I))) | |
11439 | & /(ONE+VIRT/PARMDL(30+I))**2 | |
11440 | 150 CONTINUE | |
11441 | FSUP1 = FSUP1+PARMDL(30)/(ONE+VIRT/PARMDL(34)) | |
11442 | FAC1 = FAC1*FSUP1 | |
11443 | FAC2 = FAC2*FSUP1 | |
11444 | FSUP2 = ONE | |
11445 | ||
11446 | ECMOLD = ECM | |
11447 | Q2OLD = VIRT | |
11448 | ||
11449 | 3 CONTINUE | |
11450 | ||
11451 | C SIGTOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1) | |
11452 | CALL DT_SIGGP(ZERO,VIRT,ECM,ZERO,SIGTOT,DUM1,DUM2) | |
11453 | IF (ISHAD(1).EQ.1) THEN | |
11454 | SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1) | |
11455 | ELSE | |
11456 | SIGDIR = ZERO | |
11457 | ENDIF | |
11458 | SIGANO = FSUP1*FSUP2*SIGANO | |
11459 | SIGTOT = SIGTOT-SIGDIR-SIGANO | |
11460 | SIGDIR = SIGDIR/(FSUP1*FSUP2) | |
11461 | SIGANO = SIGANO/(FSUP1*FSUP2) | |
11462 | SIGTOT = SIGTOT+SIGDIR+SIGANO | |
11463 | ||
11464 | RR = DT_RNDM(SIGTOT) | |
11465 | IF (RR.LT.SIGDIR/SIGTOT) THEN | |
11466 | IPNT = 1 | |
11467 | ELSEIF ((RR.GE.SIGDIR/SIGTOT).AND. | |
11468 | & (RR.LT.(SIGDIR+SIGANO)/SIGTOT)) THEN | |
11469 | IPNT = 2 | |
11470 | ELSE | |
11471 | IPNT = 0 | |
11472 | ENDIF | |
11473 | RPNT = (SIGDIR+SIGANO)/SIGTOT | |
11474 | C WRITE(LOUT,'(I3,2F15.5)') ISHAD(1),FAC1,FAC2 | |
11475 | C WRITE(LOUT,'(I3,2F15.5)') MODE,SIGDIR,SIGANO | |
11476 | C WRITE(LOUT,'(I3,4F15.5)') MODE,SIGDIR+SIGANO,SIGTOT,RPNT,ECM | |
11477 | C WRITE(LOUT,'(1X,6E12.4)') ECM,VIRT,SIGTOT,SIGDIR,SIGANO,RPNT | |
11478 | IF (MODE.EQ.1) RETURN | |
11479 | ||
11480 | **sr 22.7.97 | |
11481 | K1 = 1 | |
11482 | K2 = 1 | |
11483 | RATE = ZERO | |
11484 | IF (ECM.GE.ECMNN(NEBINI)) THEN | |
11485 | K1 = NEBINI | |
11486 | K2 = NEBINI | |
11487 | RATE = ONE | |
11488 | ELSEIF (ECM.GT.ECMNN(1)) THEN | |
11489 | DO 10 I=2,NEBINI | |
11490 | IF (ECM.LT.ECMNN(I)) THEN | |
11491 | K1 = I-1 | |
11492 | K2 = I | |
11493 | RATE = (ECM-ECMNN(K1))/(ECMNN(K2)-ECMNN(K1)) | |
11494 | GOTO 11 | |
11495 | ENDIF | |
11496 | 10 CONTINUE | |
11497 | 11 CONTINUE | |
11498 | ENDIF | |
11499 | J1 = 1 | |
11500 | J2 = 1 | |
11501 | RATQ = ZERO | |
11502 | IF (NQBINI.GT.1) THEN | |
11503 | IF (VIRT.GE.Q2G(NQBINI)) THEN | |
11504 | J1 = NQBINI | |
11505 | J2 = NQBINI | |
11506 | RATQ = ONE | |
11507 | ELSEIF (VIRT.GT.Q2G(1)) THEN | |
11508 | DO 12 I=2,NQBINI | |
11509 | IF (VIRT.LT.Q2G(I)) THEN | |
11510 | J1 = I-1 | |
11511 | J2 = I | |
11512 | RATQ = LOG10( VIRT/MAX(Q2G(J1),TINY14))/ | |
11513 | & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14)) | |
11514 | GOTO 13 | |
11515 | ENDIF | |
11516 | 12 CONTINUE | |
11517 | 13 CONTINUE | |
11518 | ENDIF | |
11519 | ENDIF | |
11520 | SGA = XSPRO(K1,J1,NTARG)+ | |
11521 | & RATE*(XSPRO(K2,J1,NTARG)-XSPRO(K1,J1,NTARG))+ | |
11522 | & RATQ*(XSPRO(K1,J2,NTARG)-XSPRO(K1,J1,NTARG))+ | |
11523 | & RATE*RATQ*(XSPRO(K2,J2,NTARG)-XSPRO(K1,J2,NTARG)+ | |
11524 | & XSPRO(K1,J1,NTARG)-XSPRO(K2,J1,NTARG)) | |
11525 | SDI = DBLE(NB)*SIGDIR | |
11526 | SAN = DBLE(NB)*SIGANO | |
11527 | SPL = SDI+SAN | |
11528 | RR = DT_RNDM(SPL) | |
11529 | IF (RR.LT.SDI/SGA) THEN | |
11530 | IPNT = 1 | |
11531 | ELSEIF ((RR.GE.SDI/SGA).AND. | |
11532 | & (RR.LT.SPL/SGA)) THEN | |
11533 | IPNT = 2 | |
11534 | ELSE | |
11535 | IPNT = 0 | |
11536 | ENDIF | |
11537 | RPNT = SPL/SGA | |
11538 | C WRITE(LOUT,'(I3,4F15.5)') MODE,SPL,SGA,RPNT,ECM | |
11539 | ** | |
11540 | ||
11541 | RETURN | |
11542 | END | |
11543 | ||
11544 | *$ CREATE DT_GLBINI.FOR | |
11545 | *COPY DT_GLBINI | |
11546 | * | |
11547 | *===glbini=============================================================* | |
11548 | * | |
11549 | SUBROUTINE DT_GLBINI(WHAT) | |
11550 | ||
11551 | ************************************************************************ | |
11552 | * Pre-initialization of profile function * | |
11553 | * This version dated 28.11.00 is written by S. Roesler. * | |
11554 | * * | |
11555 | * Last change 27.12.2006 by S. Roesler. * | |
11556 | ************************************************************************ | |
11557 | ||
11558 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
11559 | SAVE | |
11560 | ||
11561 | PARAMETER ( LINP = 10 , | |
11562 | & LOUT = 6 , | |
11563 | & LDAT = 9 ) | |
11564 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.D-14) | |
11565 | ||
11566 | LOGICAL LCMS | |
11567 | ||
11568 | * particle properties (BAMJET index convention) | |
11569 | CHARACTER*8 ANAME | |
11570 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
11571 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
11572 | * properties of interacting particles | |
11573 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
11574 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
11575 | * emulsion treatment | |
11576 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
11577 | & NCOMPO,IEMUL | |
11578 | * Glauber formalism: flags and parameters for statistics | |
11579 | LOGICAL LPROD | |
11580 | CHARACTER*8 CGLB | |
11581 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD | |
11582 | * number of data sets other than protons and nuclei | |
11583 | * at the moment = 2 (pions and kaons) | |
11584 | PARAMETER (MAXOFF=2) | |
11585 | DIMENSION IJPINI(5),IOFFST(25) | |
11586 | DATA IJPINI / 13, 15, 0, 0, 0/ | |
11587 | * Glauber data-set to be used for hadron projectiles | |
11588 | * (0=proton, 1=pion, 2=kaon) | |
11589 | DATA (IOFFST(K),K=1,25) / | |
11590 | & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0, | |
11591 | & 0, 0, 1, 2, 2/ | |
11592 | * Acceptance interval for target nucleus mass | |
11593 | PARAMETER (KBACC = 6) | |
11594 | * flags for input different options | |
11595 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
11596 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
11597 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
11598 | ||
11599 | PARAMETER (MAXMSS = 100) | |
11600 | DIMENSION IASAV(MAXMSS),IBSAV(MAXMSS) | |
11601 | DIMENSION WHAT(6) | |
11602 | ||
11603 | DATA JPEACH,JPSTEP / 18, 5 / | |
11604 | ||
11605 | * temporary patch until fix has been implemented in phojet: | |
11606 | * maximum energy for pion projectile | |
11607 | DATA ECMXPI / 100000.0D0 / | |
11608 | * | |
11609 | *-------------------------------------------------------------------------- | |
11610 | * general initializations | |
11611 | * | |
11612 | * steps in projectile mass number for initialization | |
11613 | IF (WHAT(4).GT.ZERO) JPEACH = INT(WHAT(4)) | |
11614 | IF (WHAT(5).GT.ZERO) JPSTEP = INT(WHAT(5)) | |
11615 | * | |
11616 | * energy range and binning | |
11617 | ELO = ABS(WHAT(1)) | |
11618 | EHI = ABS(WHAT(2)) | |
11619 | IF (ELO.GT.EHI) ELO = EHI | |
11620 | NEBIN = MAX(INT(WHAT(3)),1) | |
11621 | IF (ELO.EQ.EHI) NEBIN = 0 | |
11622 | LCMS = (WHAT(1).LT.ZERO).OR.(WHAT(2).LT.ZERO) | |
11623 | IF (LCMS) THEN | |
11624 | ECMINI = EHI | |
11625 | ELSE | |
11626 | ECMINI = SQRT(AAM(IJPROJ)**2+AAM(IJTARG)**2 | |
11627 | & +2.0D0*AAM(IJTARG)*EHI) | |
11628 | ENDIF | |
11629 | * | |
11630 | * default arguments for Glauber-routine | |
11631 | XI = ZERO | |
11632 | Q2I = ZERO | |
11633 | * | |
11634 | * initialize nuclear parameters, etc. | |
11635 | CALL DT_BERTTP | |
11636 | CALL DT_INCINI | |
11637 | * | |
11638 | * open Glauber-data output file | |
11639 | IDX = INDEX(CGLB,' ') | |
11640 | K = 12 | |
11641 | IF (IDX.GT.1) K = IDX-1 | |
11642 | OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN') | |
11643 | * | |
11644 | *-------------------------------------------------------------------------- | |
11645 | * Glauber-initialization for proton and nuclei projectiles | |
11646 | * | |
11647 | * initialize phojet for proton-proton interactions | |
11648 | ELAB = ZERO | |
11649 | PLAB = ZERO | |
11650 | CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1) | |
11651 | CALL DT_PHOINI | |
11652 | * | |
11653 | * record projectile masses | |
11654 | NASAV = 0 | |
11655 | NPROJ = MIN(IP,JPEACH) | |
11656 | DO 10 KPROJ=1,NPROJ | |
11657 | NASAV = NASAV+1 | |
11658 | IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! ' | |
11659 | IASAV(NASAV) = KPROJ | |
11660 | 10 CONTINUE | |
11661 | IF (IP.GT.JPEACH) THEN | |
11662 | NPROJ = DBLE(IP-JPEACH)/DBLE(JPSTEP) | |
11663 | IF (NPROJ.EQ.0) THEN | |
11664 | NASAV = NASAV+1 | |
11665 | IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! ' | |
11666 | IASAV(NASAV) = IP | |
11667 | ELSE | |
11668 | DO 11 IPROJ=1,NPROJ | |
11669 | KPROJ = JPEACH+IPROJ*JPSTEP | |
11670 | NASAV = NASAV+1 | |
11671 | IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! ' | |
11672 | IASAV(NASAV) = KPROJ | |
11673 | 11 CONTINUE | |
11674 | IF (KPROJ.LT.IP) THEN | |
11675 | NASAV = NASAV+1 | |
11676 | IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! ' | |
11677 | IASAV(NASAV) = IP | |
11678 | ENDIF | |
11679 | ENDIF | |
11680 | ENDIF | |
11681 | * | |
11682 | * record target masses | |
11683 | NBSAV = 0 | |
11684 | NTARG = 1 | |
11685 | IF (NCOMPO.GT.0) NTARG = NCOMPO | |
11686 | DO 12 ITARG=1,NTARG | |
11687 | NBSAV = NBSAV+1 | |
11688 | IF (NBSAV.GT.MAXMSS) STOP ' GLBINI: NBSAV > MAXMSS ! ' | |
11689 | IF (NCOMPO.GT.0) THEN | |
11690 | IBSAV(NBSAV) = IEMUMA(ITARG) | |
11691 | ELSE | |
11692 | IBSAV(NBSAV) = IT | |
11693 | ENDIF | |
11694 | 12 CONTINUE | |
11695 | * | |
11696 | * print masses | |
11697 | WRITE(LDAT,1000) NEBIN,': ',SIGN(ELO,WHAT(1)),SIGN(EHI,WHAT(2)) | |
11698 | 1000 FORMAT(I4,A,1P,2E13.5) | |
11699 | NLINES = DBLE(NASAV)/18.0D0 | |
11700 | IF (NLINES.GT.0) THEN | |
11701 | DO 13 I=1,NLINES | |
11702 | IF (I.EQ.1) THEN | |
11703 | WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=1,18) | |
11704 | ELSE | |
11705 | WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=18*I-17,18*I) | |
11706 | ENDIF | |
11707 | 13 CONTINUE | |
11708 | ENDIF | |
11709 | I0 = 18*NLINES+1 | |
11710 | IF (I0.LE.NASAV) THEN | |
11711 | IF (I0.EQ.1) THEN | |
11712 | WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=I0,NASAV) | |
11713 | ELSE | |
11714 | WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=I0,NASAV) | |
11715 | ENDIF | |
11716 | ENDIF | |
11717 | NLINES = DBLE(NBSAV)/18.0D0 | |
11718 | IF (NLINES.GT.0) THEN | |
11719 | DO 14 I=1,NLINES | |
11720 | IF (I.EQ.1) THEN | |
11721 | WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=1,18) | |
11722 | ELSE | |
11723 | WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=18*I-17,18*I) | |
11724 | ENDIF | |
11725 | 14 CONTINUE | |
11726 | ENDIF | |
11727 | I0 = 18*NLINES+1 | |
11728 | IF (I0.LE.NBSAV) THEN | |
11729 | IF (I0.EQ.1) THEN | |
11730 | WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=I0,NBSAV) | |
11731 | ELSE | |
11732 | WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=I0,NBSAV) | |
11733 | ENDIF | |
11734 | ENDIF | |
11735 | * | |
11736 | * calculate Glauber-data for each energy and mass combination | |
11737 | * | |
11738 | * loop over energy bins | |
11739 | ELO = LOG10(ELO) | |
11740 | EHI = LOG10(EHI) | |
11741 | DEBIN = (EHI-ELO)/MAX(DBLE(NEBIN),ONE) | |
11742 | DO 1 IE=1,NEBIN+1 | |
11743 | E = ELO+DBLE(IE-1)*DEBIN | |
11744 | E = 10**E | |
11745 | IF (LCMS) THEN | |
11746 | E = MAX(2.0D0*AAM(IJPROJ)+0.1D0,E) | |
11747 | ECM = E | |
11748 | ELSE | |
11749 | PLAB = ZERO | |
11750 | ECM = ZERO | |
11751 | E = MAX(AAM(IJPROJ)+0.1D0,E) | |
11752 | CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0) | |
11753 | ENDIF | |
11754 | * | |
11755 | * loop over projectile and target masses | |
11756 | DO 2 ITARG=1,NBSAV | |
11757 | DO 3 IPROJ=1,NASAV | |
11758 | CALL DT_XSGLAU(IASAV(IPROJ),IBSAV(ITARG),IJPROJ, | |
11759 | & XI,Q2I,ECM,1,1,-1) | |
11760 | 3 CONTINUE | |
11761 | 2 CONTINUE | |
11762 | * | |
11763 | 1 CONTINUE | |
11764 | * | |
11765 | *-------------------------------------------------------------------------- | |
11766 | * Glauber-initialization for pion, kaon, ... projectiles | |
11767 | * | |
11768 | DO 6 IJ=1,MAXOFF | |
11769 | * | |
11770 | * initialize phojet for this interaction | |
11771 | ELAB = ZERO | |
11772 | PLAB = ZERO | |
11773 | IJPROJ = IJPINI(IJ) | |
11774 | IP = 1 | |
11775 | IPZ = 1 | |
11776 | * | |
11777 | * temporary patch until fix has been implemented in phojet: | |
11778 | IF (ECMINI.GT.ECMXPI) THEN | |
11779 | CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMXPI,1) | |
11780 | ELSE | |
11781 | CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1) | |
11782 | ENDIF | |
11783 | CALL DT_PHOINI | |
11784 | * | |
11785 | * calculate Glauber-data for each energy and mass combination | |
11786 | * | |
11787 | * loop over energy bins | |
11788 | DO 4 IE=1,NEBIN+1 | |
11789 | E = ELO+DBLE(IE-1)*DEBIN | |
11790 | E = 10**E | |
11791 | IF (LCMS) THEN | |
11792 | E = MAX(2.0D0*AAM(IJPROJ)+TINY14,E) | |
11793 | ECM = E | |
11794 | ELSE | |
11795 | PLAB = ZERO | |
11796 | ECM = ZERO | |
11797 | E = MAX(AAM(IJPROJ)+TINY14,E) | |
11798 | CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0) | |
11799 | ENDIF | |
11800 | * | |
11801 | * loop over projectile and target masses | |
11802 | DO 5 ITARG=1,NBSAV | |
11803 | CALL DT_XSGLAU(1,IBSAV(ITARG),IJPROJ,XI,Q2I,ECM,1,1,-1) | |
11804 | 5 CONTINUE | |
11805 | * | |
11806 | 4 CONTINUE | |
11807 | * | |
11808 | 6 CONTINUE | |
11809 | ||
11810 | *-------------------------------------------------------------------------- | |
11811 | * close output unit(s), etc. | |
11812 | * | |
11813 | CLOSE(LDAT) | |
11814 | ||
11815 | RETURN | |
11816 | END | |
11817 | ||
11818 | *$ CREATE DT_GLBSET.FOR | |
11819 | *COPY DT_GLBSET | |
11820 | * | |
11821 | *===glbset=============================================================* | |
11822 | * | |
11823 | SUBROUTINE DT_GLBSET(IDPROJ,NA,NB,ELAB,MODE) | |
11824 | ************************************************************************ | |
11825 | * Interpolation of pre-initialized profile functions * | |
11826 | * This version dated 28.11.00 is written by S. Roesler. * | |
11827 | ************************************************************************ | |
11828 | ||
11829 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
11830 | SAVE | |
11831 | ||
11832 | PARAMETER ( LINP = 10 , | |
11833 | & LOUT = 6 , | |
11834 | & LDAT = 9 ) | |
11835 | PARAMETER (ZERO=0.0D0,ONE=1.0D0) | |
11836 | ||
11837 | LOGICAL LCMS,LREAD,LFRST1,LFRST2 | |
11838 | ||
11839 | * particle properties (BAMJET index convention) | |
11840 | CHARACTER*8 ANAME | |
11841 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
11842 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
11843 | * Glauber formalism: flags and parameters for statistics | |
11844 | LOGICAL LPROD | |
11845 | CHARACTER*8 CGLB | |
11846 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD | |
11847 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
11848 | * Glauber formalism: parameters | |
11849 | COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX), | |
11850 | & BMAX(NCOMPX),BSTEP(NCOMPX), | |
11851 | & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB), | |
11852 | & NSITEB,NSTATB | |
11853 | * Glauber formalism: cross sections | |
11854 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
11855 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
11856 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
11857 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
11858 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
11859 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
11860 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
11861 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
11862 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
11863 | & BSLOPE,NEBINI,NQBINI | |
11864 | * number of data sets other than protons and nuclei | |
11865 | * at the moment = 2 (pions and kaons) | |
11866 | PARAMETER (MAXOFF=2) | |
11867 | DIMENSION IJPINI(5),IOFFST(25) | |
11868 | DATA IJPINI / 13, 15, 0, 0, 0/ | |
11869 | * Glauber data-set to be used for hadron projectiles | |
11870 | * (0=proton, 1=pion, 2=kaon) | |
11871 | DATA (IOFFST(K),K=1,25) / | |
11872 | & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0, | |
11873 | & 0, 0, 1, 2, 2/ | |
11874 | * Acceptance interval for target nucleus mass | |
11875 | PARAMETER (KBACC = 6) | |
11876 | * emulsion treatment | |
11877 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
11878 | & NCOMPO,IEMUL | |
11879 | ||
11880 | PARAMETER (MAXSET=5000, | |
11881 | & MAXBIN=100) | |
11882 | DIMENSION XSIG(MAXSET,6),XERR(MAXSET,6),BPROFL(MAXSET,KSITEB) | |
11883 | DIMENSION IABIN(MAXBIN),IBBIN(MAXBIN),XS(6),XE(6), | |
11884 | & BPRO0(KSITEB),BPRO1(KSITEB),BPRO(KSITEB), | |
11885 | & IAIDX(10) | |
11886 | ||
11887 | DATA LREAD,LFRST1,LFRST2 /.FALSE.,.TRUE.,.TRUE./ | |
11888 | * | |
11889 | * read data from file | |
11890 | * | |
11891 | IF (MODE.EQ.0) THEN | |
11892 | ||
11893 | IF (LREAD) RETURN | |
11894 | ||
11895 | DO 1 I=1,MAXSET | |
11896 | DO 2 J=1,6 | |
11897 | XSIG(I,J) = ZERO | |
11898 | XERR(I,J) = ZERO | |
11899 | 2 CONTINUE | |
11900 | DO 3 J=1,KSITEB | |
11901 | BPROFL(I,J) = ZERO | |
11902 | 3 CONTINUE | |
11903 | 1 CONTINUE | |
11904 | DO 4 I=1,MAXBIN | |
11905 | IABIN(I) = 0 | |
11906 | IBBIN(I) = 0 | |
11907 | 4 CONTINUE | |
11908 | DO 5 I=1,KSITEB | |
11909 | BPRO0(I) = ZERO | |
11910 | BPRO1(I) = ZERO | |
11911 | BPRO(I) = ZERO | |
11912 | 5 CONTINUE | |
11913 | ||
11914 | IDX = INDEX(CGLB,' ') | |
11915 | K = 12 | |
11916 | IF (IDX.GT.1) K = IDX-1 | |
11917 | OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN') | |
11918 | WRITE(LOUT,1000) CGLB(1:K)//'.glb' | |
11919 | 1000 FORMAT(/,' GLBSET: impact parameter distributions read from ', | |
11920 | & 'file ',A12,/) | |
11921 | * | |
11922 | * read binning information | |
11923 | READ(LDAT,'(I4,2X,2E13.5)') NEBIN,ELO,EHI | |
11924 | * return lower energy threshold to Fluka-interface | |
11925 | ELAB = ELO | |
11926 | LCMS = ELO.LT.ZERO | |
11927 | WRITE(LOUT,'(1X,A)') ' equidistant logarithmic energy binning:' | |
11928 | IF (LCMS) THEN | |
11929 | WRITE(LOUT,1001) '(cms)',ABS(ELO),ABS(EHI),NEBIN | |
11930 | ELSE | |
11931 | WRITE(LOUT,1001) '(lab)',ABS(ELO),ABS(EHI),NEBIN | |
11932 | ENDIF | |
11933 | 1001 FORMAT(2X,A5,' E_lo = ',1P,E9.3,' E_hi = ',1P,E9.3,4X, | |
11934 | & 'No. of bins:',I5,/) | |
11935 | ELO = LOG10(ABS(ELO)) | |
11936 | EHI = LOG10(ABS(EHI)) | |
11937 | DEBIN = (EHI-ELO)/ABS(DBLE(NEBIN)) | |
11938 | WRITE(LOUT,'(/,1X,A)') ' projectiles: (mass number)' | |
11939 | READ(LDAT,'(I4,2X,18I4)') NABIN,(IABIN(J),J=1,18) | |
11940 | IF (NABIN.LT.18) THEN | |
11941 | WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,NABIN) | |
11942 | ELSE | |
11943 | WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,18) | |
11944 | ENDIF | |
11945 | IF (NABIN.GT.MAXBIN) STOP ' GLBSET: NABIN > MAXBIN !' | |
11946 | IF (NABIN.GT.18) THEN | |
11947 | NLINES = DBLE(NABIN-18)/18.0D0 | |
11948 | IF (NLINES.GT.0) THEN | |
11949 | DO 7 I=1,NLINES | |
11950 | I0 = 18*(I+1)-17 | |
11951 | READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,I0+17) | |
11952 | WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,I0+17) | |
11953 | 7 CONTINUE | |
11954 | ENDIF | |
11955 | I0 = 18*(NLINES+1)+1 | |
11956 | IF (I0.LE.NABIN) THEN | |
11957 | READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,NABIN) | |
11958 | WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,NABIN) | |
11959 | ENDIF | |
11960 | ENDIF | |
11961 | WRITE(LOUT,'(/,1X,A)') ' targets: (mass number)' | |
11962 | READ(LDAT,'(I4,2X,18I4)') NBBIN,(IBBIN(J),J=1,18) | |
11963 | IF (NBBIN.LT.18) THEN | |
11964 | WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,NBBIN) | |
11965 | ELSE | |
11966 | WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,18) | |
11967 | ENDIF | |
11968 | IF (NBBIN.GT.MAXBIN) STOP ' GLBSET: NBBIN > MAXBIN !' | |
11969 | IF (NBBIN.GT.18) THEN | |
11970 | NLINES = DBLE(NBBIN-18)/18.0D0 | |
11971 | IF (NLINES.GT.0) THEN | |
11972 | DO 8 I=1,NLINES | |
11973 | I0 = 18*(I+1)-17 | |
11974 | READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17) | |
11975 | WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17) | |
11976 | 8 CONTINUE | |
11977 | ENDIF | |
11978 | I0 = 18*(NLINES+1)+1 | |
11979 | IF (I0.LE.NBBIN) THEN | |
11980 | READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN) | |
11981 | WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN) | |
11982 | ENDIF | |
11983 | ENDIF | |
11984 | * number of data sets to follow in the Glauber data file | |
11985 | * this variable is used for checks of consistency of projectile | |
11986 | * and target mass configurations given in header of Glauber data | |
11987 | * file and the data-sets which follow in this file | |
11988 | NSET0 = (NEBIN+1)*(NABIN+MAXOFF)*NBBIN | |
11989 | * | |
11990 | * read profile function data | |
11991 | NSET = 0 | |
11992 | NAIDX = 0 | |
11993 | IPOLD = 0 | |
11994 | 10 CONTINUE | |
11995 | NSET = NSET+1 | |
11996 | IF (NSET.GT.MAXSET) STOP ' GLBSET: NSET > MAXSET ! ' | |
11997 | READ(LDAT,1002,END=100) IP,IA,IB,ISTATB,ISITEB,ECM | |
11998 | 1002 FORMAT(5I10,E15.5) | |
11999 | IF ((IP.NE.1).AND.(IP.NE.IPOLD)) THEN | |
12000 | NAIDX = NAIDX+1 | |
12001 | IF (NAIDX.GT.10) STOP ' GLBSET: NAIDX > 10 !' | |
12002 | IAIDX(NAIDX) = IP | |
12003 | IPOLD = IP | |
12004 | ENDIF | |
12005 | READ(LDAT,'(6E12.5)') (XSIG(NSET,I),I=1,6) | |
12006 | READ(LDAT,'(6E12.5)') (XERR(NSET,I),I=1,6) | |
12007 | NLINES = INT(DBLE(ISITEB)/7.0D0) | |
12008 | IF (NLINES.GT.0) THEN | |
12009 | DO 11 I=1,NLINES | |
12010 | READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=7*I-6,7*I) | |
12011 | 11 CONTINUE | |
12012 | ENDIF | |
12013 | I0 = 7*NLINES+1 | |
12014 | IF (I0.LE.ISITEB) | |
12015 | & READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=I0,ISITEB) | |
12016 | GOTO 10 | |
12017 | 100 CONTINUE | |
12018 | NSET = NSET-1 | |
12019 | IF (NSET.NE.NSET0) STOP ' GLBSET: NSET.NE.NSET0 !' | |
12020 | WRITE(LOUT,'(/,1X,A)') | |
12021 | & ' projectiles other than protons and nuclei: (particle index)' | |
12022 | IF (NAIDX.GT.0) THEN | |
12023 | WRITE(LOUT,'(6X,18I4)') (IAIDX(J),J=1,NAIDX) | |
12024 | ELSE | |
12025 | WRITE(LOUT,'(6X,A)') 'none' | |
12026 | ENDIF | |
12027 | * | |
12028 | CLOSE(LDAT) | |
12029 | WRITE(LOUT,*) | |
12030 | LREAD = .TRUE. | |
12031 | ||
12032 | IF (NCOMPO.EQ.0) THEN | |
12033 | DO 12 J=1,NBBIN | |
12034 | NCOMPO = NCOMPO+1 | |
12035 | IEMUMA(NCOMPO) = IBBIN(J) | |
12036 | IEMUCH(NCOMPO) = IEMUMA(NCOMPO)/2 | |
12037 | EMUFRA(NCOMPO) = 1.0D0 | |
12038 | 12 CONTINUE | |
12039 | IEMUL = 1 | |
12040 | ENDIF | |
12041 | * | |
12042 | * calculate profile function for certain set of parameters | |
12043 | * | |
12044 | ELSE | |
12045 | ||
12046 | c write(*,*) 'glbset called for ',IDPROJ,NA,NB,ELAB,MODE | |
12047 | * | |
12048 | * check for type of projectile and set index-offset to entry in | |
12049 | * Glauber data array correspondingly | |
12050 | IF (IDPROJ.GT.25) STOP ' GLBSET: IDPROJ > 25 !' | |
12051 | IF (IOFFST(IDPROJ).EQ.-1) THEN | |
12052 | STOP ' GLBSET: no data for this projectile !' | |
12053 | ELSEIF (IOFFST(IDPROJ).GT.0) THEN | |
12054 | IDXOFF = (NEBIN+1)*(NABIN+IOFFST(IDPROJ)-1)*NBBIN | |
12055 | ELSE | |
12056 | IDXOFF = 0 | |
12057 | ENDIF | |
12058 | * | |
12059 | * get energy bin and interpolation factor | |
12060 | IF (LCMS) THEN | |
12061 | E = SQRT(AAM(IDPROJ)**2+AAM(1)**2+2.0D0*AAM(1)*ELAB) | |
12062 | ELSE | |
12063 | E = ELAB | |
12064 | ENDIF | |
12065 | E = LOG10(E) | |
12066 | IF (E.LT.ELO) THEN | |
12067 | IF (LFRST1) THEN | |
12068 | WRITE(LOUT,*) ' GLBSET: Too low energy! (E_lo,E) ',ELO,E | |
12069 | LFRST1 = .FALSE. | |
12070 | ENDIF | |
12071 | E = ELO | |
12072 | ENDIF | |
12073 | IF (E.GT.EHI) THEN | |
12074 | IF (LFRST2) THEN | |
12075 | WRITE(LOUT,*) ' GLBSET: Too high energy! (E_hi,E) ',EHI,E | |
12076 | LFRST2 = .FALSE. | |
12077 | ENDIF | |
12078 | E = EHI | |
12079 | ENDIF | |
12080 | IE0 = (E-ELO)/DEBIN+1 | |
12081 | IE1 = IE0+1 | |
12082 | FACE = (E-(ELO+DBLE(IE0-1)*DEBIN))/DEBIN | |
12083 | * | |
12084 | * get target nucleus index | |
12085 | KB = 0 | |
12086 | NBACC = KBACC | |
12087 | DO 20 I=1,NBBIN | |
12088 | NBDIFF = ABS(NB-IBBIN(I)) | |
12089 | IF (NB.EQ.IBBIN(I)) THEN | |
12090 | KB = I | |
12091 | GOTO 21 | |
12092 | ELSEIF (NBDIFF.LE.NBACC) THEN | |
12093 | KB = I | |
12094 | NBACC = NBDIFF | |
12095 | ENDIF | |
12096 | 20 CONTINUE | |
12097 | IF (KB.NE.0) GOTO 21 | |
12098 | WRITE(LOUT,*) ' GLBSET: data not found for target ',NB | |
12099 | STOP | |
12100 | 21 CONTINUE | |
12101 | * | |
12102 | * get projectile nucleus bin and interpolation factor | |
12103 | KA0 = 0 | |
12104 | KA1 = 0 | |
12105 | FACNA = 0 | |
12106 | IF (IDXOFF.GT.0) THEN | |
12107 | KA0 = 1 | |
12108 | KA1 = 1 | |
12109 | KABIN = 1 | |
12110 | ELSE | |
12111 | IF (NA.GT.IABIN(NABIN)) STOP ' GLBSET: NA > IABIN(NABIN) !' | |
12112 | DO 22 I=1,NABIN | |
12113 | IF (NA.EQ.IABIN(I)) THEN | |
12114 | KA0 = I | |
12115 | KA1 = I | |
12116 | GOTO 23 | |
12117 | ELSEIF (NA.LT.IABIN(I)) THEN | |
12118 | KA0 = I-1 | |
12119 | KA1 = I | |
12120 | GOTO 23 | |
12121 | ENDIF | |
12122 | 22 CONTINUE | |
12123 | WRITE(LOUT,*) ' GLBSET: data not found for projectile ',NA | |
12124 | STOP | |
12125 | 23 CONTINUE | |
12126 | IF (KA0.NE.KA1) | |
12127 | & FACNA = DBLE(NA-IABIN(KA0))/DBLE(IABIN(KA1)-IABIN(KA0)) | |
12128 | KABIN = NABIN | |
12129 | ENDIF | |
12130 | * | |
12131 | * interpolate profile functions for interactions ka0-kb and ka1-kb | |
12132 | * for energy E separately | |
12133 | IDX0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1) | |
12134 | IDX1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1) | |
12135 | IDY0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1) | |
12136 | IDY1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1) | |
12137 | DO 30 I=1,ISITEB | |
12138 | BPRO0(I) = BPROFL(IDX0,I) | |
12139 | & +FACE*(BPROFL(IDX1,I)-BPROFL(IDX0,I)) | |
12140 | BPRO1(I) = BPROFL(IDY0,I) | |
12141 | & +FACE*(BPROFL(IDY1,I)-BPROFL(IDY0,I)) | |
12142 | 30 CONTINUE | |
12143 | RADB = DT_RNCLUS(NB) | |
12144 | BSTP0 = 2.0D0*(DT_RNCLUS(IABIN(KA0))+RADB)/DBLE(ISITEB-1) | |
12145 | BSTP1 = 2.0D0*(DT_RNCLUS(IABIN(KA1))+RADB)/DBLE(ISITEB-1) | |
12146 | * | |
12147 | * interpolate cross sections for energy E and projectile mass | |
12148 | DO 31 I=1,6 | |
12149 | XS0 = XSIG(IDX0,I)+FACE*(XSIG(IDX1,I)-XSIG(IDX0,I)) | |
12150 | XS1 = XSIG(IDY0,I)+FACE*(XSIG(IDY1,I)-XSIG(IDY0,I)) | |
12151 | XS(I) = XS0+FACNA*(XS1-XS0) | |
12152 | XE0 = XERR(IDX0,I)+FACE*(XERR(IDX1,I)-XERR(IDX0,I)) | |
12153 | XE1 = XERR(IDY0,I)+FACE*(XERR(IDY1,I)-XERR(IDY0,I)) | |
12154 | XE(I) = XE0+FACNA*(XE1-XE0) | |
12155 | 31 CONTINUE | |
12156 | * | |
12157 | * interpolate between ka0 and ka1 | |
12158 | RADA = DT_RNCLUS(NA) | |
12159 | BMX = 2.0D0*(RADA+RADB) | |
12160 | BSTP = BMX/DBLE(ISITEB-1) | |
12161 | BPRO(1) = ZERO | |
12162 | DO 32 I=1,ISITEB-1 | |
12163 | B = DBLE(I)*BSTP | |
12164 | * | |
12165 | * calculate values of profile functions at B | |
12166 | IDX0 = B/BSTP0+1 | |
12167 | IF (IDX0.GT.ISITEB) IDX0 = ISITEB | |
12168 | IDX1 = MIN(IDX0+1,ISITEB) | |
12169 | FACB = (B-DBLE(IDX0-1)*BSTP0)/BSTP0 | |
12170 | BPR0 = BPRO0(IDX0)+FACB*(BPRO0(IDX1)-BPRO0(IDX0)) | |
12171 | IDX0 = B/BSTP1+1 | |
12172 | IF (IDX0.GT.ISITEB) IDX0 = ISITEB | |
12173 | IDX1 = MIN(IDX0+1,ISITEB) | |
12174 | FACB = (B-DBLE(IDX0-1)*BSTP1)/BSTP1 | |
12175 | BPR1 = BPRO1(IDX0)+FACB*(BPRO1(IDX1)-BPRO1(IDX0)) | |
12176 | * | |
12177 | BPRO(I+1) = BPR0+FACNA*(BPR1-BPR0) | |
12178 | 32 CONTINUE | |
12179 | * | |
12180 | * fill common dtglam | |
12181 | NSITEB = ISITEB | |
12182 | RASH(1) = RADA | |
12183 | RBSH(1) = RADB | |
12184 | BMAX(1) = BMX | |
12185 | BSTEP(1) = BSTP | |
12186 | DO 33 I=1,KSITEB | |
12187 | BSITE(0,1,1,I) = BPRO(I) | |
12188 | 33 CONTINUE | |
12189 | * | |
12190 | * fill common dtglxs | |
12191 | XSTOT(1,1,1) = XS(1) | |
12192 | XSELA(1,1,1) = XS(2) | |
12193 | XSQEP(1,1,1) = XS(3) | |
12194 | XSQET(1,1,1) = XS(4) | |
12195 | XSQE2(1,1,1) = XS(5) | |
12196 | XSPRO(1,1,1) = XS(6) | |
12197 | XETOT(1,1,1) = XE(1) | |
12198 | XEELA(1,1,1) = XE(2) | |
12199 | XEQEP(1,1,1) = XE(3) | |
12200 | XEQET(1,1,1) = XE(4) | |
12201 | XEQE2(1,1,1) = XE(5) | |
12202 | XEPRO(1,1,1) = XE(6) | |
12203 | ||
12204 | ENDIF | |
12205 | ||
12206 | RETURN | |
12207 | END | |
12208 | ||
12209 | *$ CREATE DT_XKSAMP.FOR | |
12210 | *COPY DT_XKSAMP | |
12211 | * | |
12212 | *===xksamp=============================================================* | |
12213 | * | |
12214 | SUBROUTINE DT_XKSAMP(NN,ECM) | |
12215 | ||
12216 | ************************************************************************ | |
12217 | * Sampling of parton x-values and chain system for one interaction. * | |
12218 | * processed by S. Roesler, 9.8.95 * | |
12219 | ************************************************************************ | |
12220 | ||
12221 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
12222 | SAVE | |
12223 | PARAMETER ( LINP = 10 , | |
12224 | & LOUT = 6 , | |
12225 | & LDAT = 9 ) | |
12226 | PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0) | |
454792a9 | 12227 | CPH SAVE |
9aaba0d6 | 12228 | |
12229 | PARAMETER ( | |
12230 | * lower cuts for (valence-sea/sea-valence) chain masses | |
12231 | * antiquark-quark (u/d-sea quark) (s-sea quark) | |
12232 | & AMIU = 0.5D0, AMIS = 0.8D0, | |
12233 | * quark-diquark (u/d-sea quark) (s-sea quark) | |
12234 | & AMAU = 2.6D0, AMAS = 2.6D0, | |
12235 | * maximum lower valence-x threshold | |
12236 | & XVMAX = 0.98D0, | |
12237 | * fraction of sea-diquarks sampled out of sea-partons | |
12238 | **test | |
12239 | C & FRCDIQ = 0.9D0, | |
12240 | ** | |
12241 | * | |
12242 | & SQMA = 0.7D0, | |
12243 | * | |
12244 | * maximum number of trials to generate x's for the required number | |
12245 | * of sea quark pairs for a given hadron | |
12246 | & NSEATY = 12 | |
12247 | C & NSEATY = 3 | |
12248 | & ) | |
12249 | ||
12250 | LOGICAL ZUOVP,ZUOSP,ZUOVT,ZUOST,INTLO | |
12251 | ||
12252 | PARAMETER ( MAXNCL = 260, | |
12253 | & MAXVQU = MAXNCL, | |
12254 | & MAXSQU = 20*MAXVQU, | |
12255 | & MAXINT = MAXVQU+MAXSQU) | |
12256 | * event history | |
12257 | PARAMETER (NMXHKK=200000) | |
12258 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
12259 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
12260 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
12261 | * particle properties (BAMJET index convention) | |
12262 | CHARACTER*8 ANAME | |
12263 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
12264 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
12265 | * interface between Glauber formalism and DPM | |
12266 | COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL), | |
12267 | & INTER1(MAXINT),INTER2(MAXINT) | |
12268 | * properties of interacting particles | |
12269 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
12270 | * threshold values for x-sampling (DTUNUC 1.x) | |
12271 | COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA, | |
12272 | & SSMIMQ,VVMTHR | |
12273 | * x-values of partons (DTUNUC 1.x) | |
12274 | COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU), | |
12275 | & XTVQ(MAXVQU),XTVD(MAXVQU), | |
12276 | & XPSQ(MAXSQU),XPSAQ(MAXSQU), | |
12277 | & XTSQ(MAXSQU),XTSAQ(MAXSQU) | |
12278 | * flavors of partons (DTUNUC 1.x) | |
12279 | COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU), | |
12280 | & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU), | |
12281 | & IPSQ(MAXSQU),IPSQ2(MAXSQU), | |
12282 | & IPSAQ(MAXSQU),IPSAQ2(MAXSQU), | |
12283 | & ITSQ(MAXSQU),ITSQ2(MAXSQU), | |
12284 | & ITSAQ(MAXSQU),ITSAQ2(MAXSQU), | |
12285 | & KKPROJ(MAXVQU),KKTARG(MAXVQU) | |
12286 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) | |
12287 | COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD, | |
12288 | & IXPV,IXPS,IXTV,IXTS, | |
12289 | & INTVV1(MAXVQU),INTVV2(MAXVQU), | |
12290 | & INTSV1(MAXVQU),INTSV2(MAXVQU), | |
12291 | & INTVS1(MAXVQU),INTVS2(MAXVQU), | |
12292 | & INTSS1(MAXSQU),INTSS2(MAXSQU), | |
12293 | & INTDV1(MAXVQU),INTDV2(MAXVQU), | |
12294 | & INTVD1(MAXVQU),INTVD2(MAXVQU), | |
12295 | & INTDS1(MAXSQU),INTDS2(MAXSQU), | |
12296 | & INTSD1(MAXSQU),INTSD2(MAXSQU) | |
12297 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) | |
12298 | COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU), | |
12299 | & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU) | |
12300 | * auxiliary common for chain system storage (DTUNUC 1.x) | |
12301 | COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL) | |
12302 | * flags for input different options | |
12303 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
12304 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
12305 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
12306 | * various options for treatment of partons (DTUNUC 1.x) | |
12307 | * (chain recombination, Cronin,..) | |
12308 | LOGICAL LCO2CR,LINTPT | |
12309 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, | |
12310 | & LCO2CR,LINTPT | |
12311 | ||
12312 | DIMENSION ZUOVP(MAXVQU),ZUOSP(MAXSQU),ZUOVT(MAXVQU),ZUOST(MAXSQU), | |
12313 | & INTLO(MAXINT) | |
12314 | ||
12315 | * (1) initializations | |
12316 | *----------------------------------------------------------------------- | |
12317 | ||
12318 | **test | |
12319 | IF (ECM.LT.4.5D0) THEN | |
12320 | C FRCDIQ = 0.6D0 | |
12321 | FRCDIQ = 0.4D0 | |
12322 | ELSEIF ((ECM.GE.4.5D0).AND.(ECM.LT.7.5)) THEN | |
12323 | C FRCDIQ = 0.6D0+(ECM-4.5D0)/3.0D0*0.3D0 | |
12324 | FRCDIQ = 0.4D0+(ECM-4.5D0)/3.0D0*0.3D0 | |
12325 | ELSE | |
12326 | C FRCDIQ = 0.9D0 | |
12327 | FRCDIQ = 0.7D0 | |
12328 | ENDIF | |
12329 | ** | |
12330 | DO 30 I=1,MAXSQU | |
12331 | ZUOSP(I) = .FALSE. | |
12332 | ZUOST(I) = .FALSE. | |
12333 | IF (I.LE.MAXVQU) THEN | |
12334 | ZUOVP(I) = .FALSE. | |
12335 | ZUOVT(I) = .FALSE. | |
12336 | ENDIF | |
12337 | 30 CONTINUE | |
12338 | ||
12339 | * lower thresholds for x-selection | |
12340 | * sea-quarks (default: CSEA=0.2) | |
12341 | IF (ECM.LT.10.0D0) THEN | |
12342 | **!!test | |
12343 | XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM | |
12344 | C XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM**2.0D0 | |
12345 | NSEA = NSEATY | |
12346 | C XSTHR = ONE/ECM**2 | |
12347 | ELSE | |
12348 | **sr 30.3.98 | |
12349 | C XSTHR = CSEA/ECM | |
12350 | XSTHR = CSEA/ECM**2 | |
12351 | C XSTHR = ONE/ECM**2 | |
12352 | ** | |
12353 | IF ((IP.GE.150).AND.(IT.GE.150)) | |
12354 | & XSTHR = 2.5D0/(ECM*SQRT(ECM)) | |
12355 | NSEA = NSEATY | |
12356 | ENDIF | |
12357 | * (default: SSMIMA=0.14) used for sea-diquarks (?) | |
12358 | XSSTHR = SSMIMA/ECM | |
12359 | BSQMA = SQMA/ECM | |
12360 | * valence-quarks (default: CVQ=1.0) | |
12361 | XVTHR = CVQ/ECM | |
12362 | * valence-diquarks (default: CDQ=2.0) | |
12363 | XDTHR = CDQ/ECM | |
12364 | ||
12365 | * maximum-x for sea-quarks | |
12366 | XVCUT = XVTHR+XDTHR | |
12367 | IF (XVCUT.GT.XVMAX) THEN | |
12368 | XVCUT = XVMAX | |
12369 | XVTHR = XVCUT/3.0D0 | |
12370 | XDTHR = XVCUT-XVTHR | |
12371 | ENDIF | |
12372 | XXSEAM = ONE-XVCUT | |
12373 | **sr 18.4. test: DPMJET | |
12374 | C XXSEAM=1.0 - XVTHR*(1.D0+0.3D0*DT_RNDM(V1)) | |
12375 | C & - XDTHR*(1.D0+0.3D0*DT_RNDM(V2)) | |
12376 | C & -0.01*(1.D0+1.5D0*DT_RNDM(V3)) | |
12377 | ** | |
12378 | * maximum number of sea-pairs allowed kinematically | |
12379 | C NSMAX = INT(OHALF*XXSEAM/XSTHR) | |
12380 | RNSMAX = OHALF*XXSEAM/XSTHR | |
12381 | IF (RNSMAX.GT.10000.0D0) THEN | |
12382 | NSMAX = 10000 | |
12383 | ELSE | |
12384 | NSMAX = INT(OHALF*XXSEAM/XSTHR) | |
12385 | ENDIF | |
12386 | * check kinematical limit for valence-x thresholds | |
12387 | * (should be obsolete now) | |
12388 | IF (XVCUT.GT.XVMAX) THEN | |
12389 | WRITE(LOUT,1000) XVCUT,ECM | |
12390 | 1000 FORMAT(' XKSAMP: kin. limit for valence-x', | |
12391 | & ' thresholds not allowed (',2E9.3,')') | |
12392 | C XVTHR = XVMAX-XDTHR | |
12393 | C IF (XVTHR.LT.ZERO) STOP | |
12394 | STOP | |
12395 | ENDIF | |
12396 | ||
12397 | * set eta for valence-x sampling (BETREJ) | |
12398 | * (UNON per default, UNOM used for projectile mesons only) | |
12399 | IF ((IJPROJ.NE.0).AND.(IBPROJ.EQ.0)) THEN | |
12400 | UNOPRV = UNOM | |
12401 | ELSE | |
12402 | UNOPRV = UNON | |
12403 | ENDIF | |
12404 | ||
12405 | * (2) select parton x-values of interacting projectile nucleons | |
12406 | *----------------------------------------------------------------------- | |
12407 | ||
12408 | IXPV = 0 | |
12409 | IXPS = 0 | |
12410 | ||
12411 | DO 100 IPP=1,IP | |
12412 | * get interacting projectile nucleon as sampled by Glauber | |
12413 | IF (JSSH(IPP).NE.0) THEN | |
12414 | IXSTMP = IXPS | |
12415 | IXVTMP = IXPV | |
12416 | 99 CONTINUE | |
12417 | IXPS = IXSTMP | |
12418 | IXPV = IXVTMP | |
12419 | * JIPP is the actual number of sea-pairs sampled for this nucleon | |
12420 | JIPP = MIN(JSSH(IPP)-1,NSMAX) | |
12421 | 41 CONTINUE | |
12422 | XXSEA = ZERO | |
12423 | IF (JIPP.GT.0) THEN | |
12424 | XSMAX = XXSEAM-2.0D0*DBLE(JIPP)*XSTHR | |
12425 | *??? | |
12426 | IF (XSTHR.GE.XSMAX) THEN | |
12427 | JIPP = JIPP-1 | |
12428 | GOTO 41 | |
12429 | ENDIF | |
12430 | ||
12431 | *>>>get x-values of sea-quark pairs | |
12432 | NSCOUN = 0 | |
12433 | PLW = 0.5D0 | |
12434 | 40 CONTINUE | |
12435 | * accumulator for sea x-values | |
12436 | XXSEA = ZERO | |
12437 | NSCOUN = NSCOUN+1 | |
12438 | IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0 | |
12439 | IF (NSCOUN.GT.NSEA) THEN | |
12440 | * decrease the number of interactions after NSEA trials | |
12441 | JIPP = JIPP-1 | |
12442 | NSCOUN = 0 | |
12443 | ENDIF | |
12444 | DO 70 ISQ=1,JIPP | |
12445 | * sea-quarks | |
12446 | IF (IPSQ(IXPS+1).LE.2) THEN | |
12447 | **sr 8.4.98 (1/sqrt(x)) | |
12448 | C XPSQI = DT_SAMPEX(XSTHR,XSMAX) | |
12449 | C XPSQI = DT_SAMSQX(XSTHR,XSMAX) | |
12450 | XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW) | |
12451 | ** | |
12452 | ELSE | |
12453 | IF (XSMAX.GT.XSTHR+BSQMA) THEN | |
12454 | XPSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA) | |
12455 | ELSE | |
12456 | **sr 8.4.98 (1/sqrt(x)) | |
12457 | C XPSQI = DT_SAMPEX(XSTHR,XSMAX) | |
12458 | C XPSQI = DT_SAMSQX(XSTHR,XSMAX) | |
12459 | XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW) | |
12460 | ** | |
12461 | ENDIF | |
12462 | ENDIF | |
12463 | * sea-antiquarks | |
12464 | IF (IPSAQ(IXPS+1).GE.-2) THEN | |
12465 | **sr 8.4.98 (1/sqrt(x)) | |
12466 | C XPSAQI = DT_SAMPEX(XSTHR,XSMAX) | |
12467 | C XPSAQI = DT_SAMSQX(XSTHR,XSMAX) | |
12468 | XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW) | |
12469 | ** | |
12470 | ELSE | |
12471 | IF (XSMAX.GT.XSTHR+BSQMA) THEN | |
12472 | XPSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA) | |
12473 | ELSE | |
12474 | **sr 8.4.98 (1/sqrt(x)) | |
12475 | C XPSAQI = DT_SAMPEX(XSTHR,XSMAX) | |
12476 | C XPSAQI = DT_SAMSQX(XSTHR,XSMAX) | |
12477 | XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW) | |
12478 | ** | |
12479 | ENDIF | |
12480 | ENDIF | |
12481 | XXSEA = XXSEA+XPSQI+XPSAQI | |
12482 | * check for maximum allowed sea x-value | |
12483 | IF (XXSEA.GE.XXSEAM) THEN | |
12484 | IXPS = IXPS-ISQ+1 | |
12485 | GOTO 40 | |
12486 | ENDIF | |
12487 | * accept this sea-quark pair | |
12488 | IXPS = IXPS+1 | |
12489 | XPSQ(IXPS) = XPSQI | |
12490 | XPSAQ(IXPS) = XPSAQI | |
12491 | IFROSP(IXPS) = IPP | |
12492 | ZUOSP(IXPS) = .TRUE. | |
12493 | 70 CONTINUE | |
12494 | ENDIF | |
12495 | ||
12496 | *>>>get x-values of valence partons | |
12497 | * valence quark | |
12498 | IF (XVTHR.GT.0.05D0) THEN | |
12499 | XVHI = ONE-XXSEA-XDTHR | |
12500 | XPVQI = DT_BETREJ(OHALF,UNOPRV,XVTHR,XVHI) | |
12501 | ELSE | |
12502 | 90 CONTINUE | |
12503 | XPVQI = DT_DBETAR(OHALF,UNOPRV) | |
12504 | IF ((XPVQI.LT.XVTHR).OR.(ONE-XPVQI-XXSEA.LT.XDTHR)) | |
12505 | & GOTO 90 | |
12506 | ENDIF | |
12507 | * valence diquark | |
12508 | XPVDI = ONE-XPVQI-XXSEA | |
12509 | * reject according to x**1.5 | |
12510 | XDTMP = XPVDI**1.5D0 | |
12511 | IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 99 | |
12512 | * accept these valence partons | |
12513 | IXPV = IXPV+1 | |
12514 | XPVQ(IXPV) = XPVQI | |
12515 | XPVD(IXPV) = XPVDI | |
12516 | IFROVP(IXPV) = IPP | |
12517 | ITOVP(IPP) = IXPV | |
12518 | ZUOVP(IXPV) = .TRUE. | |
12519 | ||
12520 | ENDIF | |
12521 | 100 CONTINUE | |
12522 | ||
12523 | * (3) select parton x-values of interacting target nucleons | |
12524 | *----------------------------------------------------------------------- | |
12525 | ||
12526 | IXTV = 0 | |
12527 | IXTS = 0 | |
12528 | ||
12529 | DO 170 ITT=1,IT | |
12530 | * get interacting target nucleon as sampled by Glauber | |
12531 | IF (JTSH(ITT).NE.0) THEN | |
12532 | IXSTMP = IXTS | |
12533 | IXVTMP = IXTV | |
12534 | 169 CONTINUE | |
12535 | IXTS = IXSTMP | |
12536 | IXTV = IXVTMP | |
12537 | * JITT is the actual number of sea-pairs sampled for this nucleon | |
12538 | JITT = MIN(JTSH(ITT)-1,NSMAX) | |
12539 | 111 CONTINUE | |
12540 | XXSEA = ZERO | |
12541 | IF (JITT.GT.0) THEN | |
12542 | XSMAX = XXSEAM-2.0D0*DBLE(JITT)*XSTHR | |
12543 | *??? | |
12544 | IF (XSTHR.GE.XSMAX) THEN | |
12545 | JITT = JITT-1 | |
12546 | GOTO 111 | |
12547 | ENDIF | |
12548 | ||
12549 | *>>>get x-values of sea-quark pairs | |
12550 | NSCOUN = 0 | |
12551 | PLW = 0.5D0 | |
12552 | 110 CONTINUE | |
12553 | * accumulator for sea x-values | |
12554 | XXSEA = ZERO | |
12555 | NSCOUN = NSCOUN+1 | |
12556 | IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0 | |
12557 | IF (NSCOUN.GT.NSEA)THEN | |
12558 | * decrease the number of interactions after NSEA trials | |
12559 | JITT = JITT-1 | |
12560 | NSCOUN = 0 | |
12561 | ENDIF | |
12562 | DO 140 ISQ=1,JITT | |
12563 | * sea-quarks | |
12564 | IF (ITSQ(IXTS+1).LE.2) THEN | |
12565 | **sr 8.4.98 (1/sqrt(x)) | |
12566 | C XTSQI = DT_SAMPEX(XSTHR,XSMAX) | |
12567 | C XTSQI = DT_SAMSQX(XSTHR,XSMAX) | |
12568 | XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW) | |
12569 | ** | |
12570 | ELSE | |
12571 | IF (XSMAX.GT.XSTHR+BSQMA) THEN | |
12572 | XTSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA) | |
12573 | ELSE | |
12574 | **sr 8.4.98 (1/sqrt(x)) | |
12575 | C XTSQI = DT_SAMPEX(XSTHR,XSMAX) | |
12576 | C XTSQI = DT_SAMSQX(XSTHR,XSMAX) | |
12577 | XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW) | |
12578 | ** | |
12579 | ENDIF | |
12580 | ENDIF | |
12581 | * sea-antiquarks | |
12582 | IF (ITSAQ(IXTS+1).GE.-2) THEN | |
12583 | **sr 8.4.98 (1/sqrt(x)) | |
12584 | C XTSAQI = DT_SAMPEX(XSTHR,XSMAX) | |
12585 | C XTSAQI = DT_SAMSQX(XSTHR,XSMAX) | |
12586 | XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW) | |
12587 | ** | |
12588 | ELSE | |
12589 | IF (XSMAX.GT.XSTHR+BSQMA) THEN | |
12590 | XTSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA) | |
12591 | ELSE | |
12592 | **sr 8.4.98 (1/sqrt(x)) | |
12593 | C XTSAQI = DT_SAMPEX(XSTHR,XSMAX) | |
12594 | C XTSAQI = DT_SAMSQX(XSTHR,XSMAX) | |
12595 | XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW) | |
12596 | ** | |
12597 | ENDIF | |
12598 | ENDIF | |
12599 | XXSEA = XXSEA+XTSQI+XTSAQI | |
12600 | * check for maximum allowed sea x-value | |
12601 | IF (XXSEA.GE.XXSEAM) THEN | |
12602 | IXTS = IXTS-ISQ+1 | |
12603 | GOTO 110 | |
12604 | ENDIF | |
12605 | * accept this sea-quark pair | |
12606 | IXTS = IXTS+1 | |
12607 | XTSQ(IXTS) = XTSQI | |
12608 | XTSAQ(IXTS) = XTSAQI | |
12609 | IFROST(IXTS) = ITT | |
12610 | ZUOST(IXTS) = .TRUE. | |
12611 | 140 CONTINUE | |
12612 | ENDIF | |
12613 | ||
12614 | *>>>get x-values of valence partons | |
12615 | * valence quark | |
12616 | IF (XVTHR.GT.0.05D0) THEN | |
12617 | XVHI = ONE-XXSEA-XDTHR | |
12618 | XTVQI = DT_BETREJ(OHALF,UNON,XVTHR,XVHI) | |
12619 | ELSE | |
12620 | 160 CONTINUE | |
12621 | XTVQI = DT_DBETAR(OHALF,UNON) | |
12622 | IF ((XTVQI.LT.XVTHR).OR.(ONE-XTVQI-XXSEA.LT.XDTHR)) | |
12623 | & GOTO 160 | |
12624 | ENDIF | |
12625 | * valence diquark | |
12626 | XTVDI = ONE-XTVQI-XXSEA | |
12627 | * reject according to x**1.5 | |
12628 | XDTMP = XTVDI**1.5D0 | |
12629 | IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 169 | |
12630 | * accept these valence partons | |
12631 | IXTV = IXTV+1 | |
12632 | XTVQ(IXTV) = XTVQI | |
12633 | XTVD(IXTV) = XTVDI | |
12634 | IFROVT(IXTV) = ITT | |
12635 | ITOVT(ITT) = IXTV | |
12636 | ZUOVT(IXTV) = .TRUE. | |
12637 | ||
12638 | ENDIF | |
12639 | 170 CONTINUE | |
12640 | ||
12641 | * (4) get valence-valence chains | |
12642 | *----------------------------------------------------------------------- | |
12643 | ||
12644 | NVV = 0 | |
12645 | DO 240 I=1,NN | |
12646 | INTLO(I) = .TRUE. | |
12647 | IPVAL = ITOVP(INTER1(I)) | |
12648 | ITVAL = ITOVT(INTER2(I)) | |
12649 | IF (ZUOVP(IPVAL).AND.ZUOVT(ITVAL)) THEN | |
12650 | INTLO(I) = .FALSE. | |
12651 | ZUOVP(IPVAL) = .FALSE. | |
12652 | ZUOVT(ITVAL) = .FALSE. | |
12653 | NVV = NVV+1 | |
12654 | ISKPCH(8,NVV) = 0 | |
12655 | INTVV1(NVV) = IPVAL | |
12656 | INTVV2(NVV) = ITVAL | |
12657 | ENDIF | |
12658 | 240 CONTINUE | |
12659 | ||
12660 | * (5) get sea-valence chains | |
12661 | *----------------------------------------------------------------------- | |
12662 | ||
12663 | NSV = 0 | |
12664 | NDV = 0 | |
12665 | PLW = 0.5D0 | |
12666 | DO 270 I=1,NN | |
12667 | IF (INTLO(I)) THEN | |
12668 | IPVAL = ITOVP(INTER1(I)) | |
12669 | ITVAL = ITOVT(INTER2(I)) | |
12670 | DO 250 J=1,IXPS | |
12671 | IF (ZUOSP(J).AND.(IFROSP(J).EQ.INTER1(I)).AND. | |
12672 | & ZUOVT(ITVAL)) THEN | |
12673 | ZUOSP(J) = .FALSE. | |
12674 | ZUOVT(ITVAL) = .FALSE. | |
12675 | INTLO(I) = .FALSE. | |
12676 | IF (LSEADI.AND.(DT_RNDM(PLW).GT.FRCDIQ)) THEN | |
12677 | * sample sea-diquark pair | |
12678 | CALL DT_SAMSDQ(ECM,ITVAL,J,2,IREJ1) | |
12679 | IF (IREJ1.EQ.0) GOTO 260 | |
12680 | ENDIF | |
12681 | NSV = NSV+1 | |
12682 | ISKPCH(4,NSV) = 0 | |
12683 | INTSV1(NSV) = J | |
12684 | INTSV2(NSV) = ITVAL | |
12685 | ||
12686 | *>>>correct chain kinematics according to minimum chain masses | |
12687 | * the actual chain masses | |
12688 | AMSVQ1 = XPSQ(J) *XTVD(ITVAL)*ECM**2 | |
12689 | AMSVQ2 = XPSAQ(J)*XTVQ(ITVAL)*ECM**2 | |
12690 | * get lower mass cuts | |
12691 | IF (IPSQ(J).EQ.3) THEN | |
12692 | * q being s-quark | |
12693 | AMCHK1 = AMAS | |
12694 | AMCHK2 = AMIS | |
12695 | ELSE | |
12696 | * q being u/d-quark | |
12697 | AMCHK1 = AMAU | |
12698 | AMCHK2 = AMIU | |
12699 | ENDIF | |
12700 | * q-qq chain | |
12701 | * chain mass above minimum - resampling of sea-q x-value | |
12702 | IF (AMSVQ1.GT.AMCHK1) THEN | |
12703 | XPSQTH = AMCHK1/(XTVD(ITVAL)*ECM**2) | |
12704 | **sr 8.4.98 (1/sqrt(x)) | |
12705 | C XPSQXX = DT_SAMPEX(XPSQTH,XPSQ(J)) | |
12706 | C XPSQXX = DT_SAMSQX(XPSQTH,XPSQ(J)) | |
12707 | XPSQXX = DT_SAMPLW(XPSQTH,XPSQ(J),PLW) | |
12708 | ** | |
12709 | XPVD(IPVAL) = XPVD(IPVAL)+XPSQ(J)-XPSQXX | |
12710 | XPSQ(J) = XPSQXX | |
12711 | * chain mass below minimum - reset sea-q x-value and correct | |
12712 | * diquark-x of the same nucleon | |
12713 | ELSEIF (AMSVQ1.LT.AMCHK1) THEN | |
12714 | XPSQW = AMCHK1/(XTVD(ITVAL)*ECM**2) | |
12715 | DXPSQ = XPSQW-XPSQ(J) | |
12716 | IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN | |
12717 | XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ | |
12718 | XPSQ(J) = XPSQW | |
12719 | ENDIF | |
12720 | ENDIF | |
12721 | * aq-q chain | |
12722 | * chain mass below minimum - reset sea-aq x-value and correct | |
12723 | * diquark-x of the same nucleon | |
12724 | IF (AMSVQ2.LT.AMCHK2) THEN | |
12725 | XPSQW = AMCHK2/(XTVQ(ITVAL)*ECM**2) | |
12726 | DXPSQ = XPSQW-XPSAQ(J) | |
12727 | IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN | |
12728 | XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ | |
12729 | XPSAQ(J) = XPSQW | |
12730 | ENDIF | |
12731 | ENDIF | |
12732 | *>>>end of chain mass correction | |
12733 | ||
12734 | GOTO 260 | |
12735 | ENDIF | |
12736 | 250 CONTINUE | |
12737 | ENDIF | |
12738 | 260 CONTINUE | |
12739 | 270 CONTINUE | |
12740 | ||
12741 | * (6) get valence-sea chains | |
12742 | *----------------------------------------------------------------------- | |
12743 | ||
12744 | NVS = 0 | |
12745 | NVD = 0 | |
12746 | DO 300 I=1,NN | |
12747 | IF (INTLO(I)) THEN | |
12748 | IPVAL = ITOVP(INTER1(I)) | |
12749 | ITVAL = ITOVT(INTER2(I)) | |
12750 | DO 280 J=1,IXTS | |
12751 | IF (ZUOVP(IPVAL).AND.ZUOST(J).AND. | |
12752 | & (IFROST(J).EQ.INTER2(I))) THEN | |
12753 | ZUOST(J) = .FALSE. | |
12754 | ZUOVP(IPVAL) = .FALSE. | |
12755 | INTLO(I) = .FALSE. | |
12756 | IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN | |
12757 | * sample sea-diquark pair | |
12758 | CALL DT_SAMSDQ(ECM,IPVAL,J,1,IREJ1) | |
12759 | IF (IREJ1.EQ.0) GOTO 290 | |
12760 | ENDIF | |
12761 | NVS = NVS + 1 | |
12762 | ISKPCH(6,NVS) = 0 | |
12763 | INTVS1(NVS) = IPVAL | |
12764 | INTVS2(NVS) = J | |
12765 | ||
12766 | *>>>correct chain kinematics according to minimum chain masses | |
12767 | * the actual chain masses | |
12768 | AMVSQ1 = XPVQ(IPVAL)*XTSAQ(J)*ECM**2 | |
12769 | AMVSQ2 = XPVD(IPVAL)*XTSQ(J) *ECM**2 | |
12770 | * get lower mass cuts | |
12771 | IF (ITSQ(J).EQ.3) THEN | |
12772 | * q being s-quark | |
12773 | AMCHK1 = AMIS | |
12774 | AMCHK2 = AMAS | |
12775 | ELSE | |
12776 | * q being u/d-quark | |
12777 | AMCHK1 = AMIU | |
12778 | AMCHK2 = AMAU | |
12779 | ENDIF | |
12780 | * q-aq chain | |
12781 | * chain mass below minimum - reset sea-aq x-value and correct | |
12782 | * diquark-x of the same nucleon | |
12783 | IF (AMVSQ1.LT.AMCHK1) THEN | |
12784 | XTSQW = AMCHK1/(XPVQ(IPVAL)*ECM**2) | |
12785 | DXTSQ = XTSQW-XTSAQ(J) | |
12786 | IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN | |
12787 | XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ | |
12788 | XTSAQ(J) = XTSQW | |
12789 | ENDIF | |
12790 | ENDIF | |
12791 | * qq-q chain | |
12792 | * chain mass above minimum - resampling of sea-q x-value | |
12793 | IF (AMVSQ2.GT.AMCHK2) THEN | |
12794 | XTSQTH = AMCHK2/(XPVD(IPVAL)*ECM**2) | |
12795 | **sr 8.4.98 (1/sqrt(x)) | |
12796 | C XTSQXX = DT_SAMPEX(XTSQTH,XTSQ(J)) | |
12797 | C XTSQXX = DT_SAMSQX(XTSQTH,XTSQ(J)) | |
12798 | XTSQXX = DT_SAMPLW(XTSQTH,XTSQ(J),PLW) | |
12799 | ** | |
12800 | XTVD(ITVAL) = XTVD(ITVAL)+XTSQ(J)-XTSQXX | |
12801 | XTSQ(J) = XTSQXX | |
12802 | * chain mass below minimum - reset sea-q x-value and correct | |
12803 | * diquark-x of the same nucleon | |
12804 | ELSEIF (AMVSQ2.LT.AMCHK2) THEN | |
12805 | XTSQW = AMCHK2/(XPVD(IPVAL)*ECM**2) | |
12806 | DXTSQ = XTSQW-XTSQ(J) | |
12807 | IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN | |
12808 | XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ | |
12809 | XTSQ(J) = XTSQW | |
12810 | ENDIF | |
12811 | ENDIF | |
12812 | *>>>end of chain mass correction | |
12813 | ||
12814 | GOTO 290 | |
12815 | ENDIF | |
12816 | 280 CONTINUE | |
12817 | ENDIF | |
12818 | 290 CONTINUE | |
12819 | 300 CONTINUE | |
12820 | ||
12821 | * (7) get sea-sea chains | |
12822 | *----------------------------------------------------------------------- | |
12823 | ||
12824 | NSS = 0 | |
12825 | NDS = 0 | |
12826 | NSD = 0 | |
12827 | DO 420 I=1,NN | |
12828 | IF (INTLO(I)) THEN | |
12829 | IPVAL = ITOVP(INTER1(I)) | |
12830 | ITVAL = ITOVT(INTER2(I)) | |
12831 | * loop over target partons not yet matched | |
12832 | DO 400 J=1,IXTS | |
12833 | IF (ZUOST(J).AND.(IFROST(J).EQ.INTER2(I))) THEN | |
12834 | * loop over projectile partons not yet matched | |
12835 | DO 390 JJ=1,IXPS | |
12836 | IF (ZUOSP(JJ).AND.(IFROSP(JJ).EQ.INTER1(I))) THEN | |
12837 | ZUOSP(JJ) = .FALSE. | |
12838 | ZUOST(J) = .FALSE. | |
12839 | INTLO(I) = .FALSE. | |
12840 | NSS = NSS+1 | |
12841 | ISKPCH(1,NSS) = 0 | |
12842 | INTSS1(NSS) = JJ | |
12843 | INTSS2(NSS) = J | |
12844 | ||
12845 | *---->chain recombination option | |
12846 | VALFRA = DBLE(NVV/(NVV+IXPS+IXTS)) | |
12847 | IF (IRECOM.EQ.1.AND.(DT_RNDM(BSQMA).GT.VALFRA)) | |
12848 | & THEN | |
12849 | * sea-sea chains may recombine with valence-valence chains | |
12850 | * only if they have the same projectile or target nucleon | |
12851 | DO 4201 IVV=1,NVV | |
12852 | IF (ISKPCH(8,IVV).NE.99) THEN | |
12853 | IXVPR = INTVV1(IVV) | |
12854 | IXVTA = INTVV2(IVV) | |
12855 | IF ((INTER1(I).EQ.IFROVP(IXVPR)).OR. | |
12856 | & (INTER2(I).EQ.IFROVT(IXVTA))) THEN | |
12857 | * recombination possible, drop old v-v and s-s chains | |
12858 | ISKPCH(1,NSS) = 99 | |
12859 | ISKPCH(8,IVV) = 99 | |
12860 | ||
12861 | * (a) assign new s-v chains | |
12862 | * ~~~~~~~~~~~~~~~~~~~~~~~~~ | |
12863 | IF (LSEADI.AND. | |
12864 | & (DT_RNDM(VALFRA).GT.FRCDIQ)) | |
12865 | & THEN | |
12866 | * sample sea-diquark pair | |
12867 | CALL DT_SAMSDQ(ECM,IXVTA,JJ,2, | |
12868 | & IREJ1) | |
12869 | IF (IREJ1.EQ.0) GOTO 4202 | |
12870 | ENDIF | |
12871 | NSV = NSV+1 | |
12872 | ISKPCH(4,NSV) = 0 | |
12873 | INTSV1(NSV) = JJ | |
12874 | INTSV2(NSV) = IXVTA | |
12875 | *>>>>>>>>>>>correct chain kinematics according to minimum chain masses | |
12876 | * the actual chain masses | |
12877 | AMSVQ1 = XPSQ(JJ) *XTVD(IXVTA) | |
12878 | & *ECM**2 | |
12879 | AMSVQ2 = XPSAQ(JJ)*XTVQ(IXVTA) | |
12880 | & *ECM**2 | |
12881 | * get lower mass cuts | |
12882 | IF (IPSQ(JJ).EQ.3) THEN | |
12883 | * q being s-quark | |
12884 | AMCHK1 = AMAS | |
12885 | AMCHK2 = AMIS | |
12886 | ELSE | |
12887 | * q being u/d-quark | |
12888 | AMCHK1 = AMAU | |
12889 | AMCHK2 = AMIU | |
12890 | ENDIF | |
12891 | * q-qq chain | |
12892 | * chain mass above minimum - resampling of sea-q x-value | |
12893 | IF (AMSVQ1.GT.AMCHK1) THEN | |
12894 | XPSQTH = | |
12895 | & AMCHK1/(XTVD(IXVTA)*ECM**2) | |
12896 | **sr 8.4.98 (1/sqrt(x)) | |
12897 | XPSQXX = | |
12898 | & DT_SAMPLW(XPSQTH,XPSQ(JJ),PLW) | |
12899 | C & DT_SAMSQX(XPSQTH,XPSQ(JJ)) | |
12900 | C & DT_SAMPEX(XPSQTH,XPSQ(JJ)) | |
12901 | ** | |
12902 | XPVD(IPVAL) = | |
12903 | & XPVD(IPVAL)+XPSQ(JJ)-XPSQXX | |
12904 | XPSQ(JJ) = XPSQXX | |
12905 | * chain mass below minimum - reset sea-q x-value and correct | |
12906 | * diquark-x of the same nucleon | |
12907 | ELSEIF (AMSVQ1.LT.AMCHK1) THEN | |
12908 | XPSQW = | |
12909 | & AMCHK1/(XTVD(IXVTA)*ECM**2) | |
12910 | DXPSQ = XPSQW-XPSQ(JJ) | |
12911 | IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) | |
12912 | & THEN | |
12913 | XPVD(IPVAL) = | |
12914 | & XPVD(IPVAL)-DXPSQ | |
12915 | XPSQ(JJ) = XPSQW | |
12916 | ENDIF | |
12917 | ENDIF | |
12918 | * aq-q chain | |
12919 | * chain mass below minimum - reset sea-aq x-value and correct | |
12920 | * diquark-x of the same nucleon | |
12921 | IF (AMSVQ2.LT.AMCHK2) THEN | |
12922 | XPSQW = | |
12923 | & AMCHK2/(XTVQ(IXVTA)*ECM**2) | |
12924 | DXPSQ = XPSQW-XPSAQ(JJ) | |
12925 | IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) | |
12926 | & THEN | |
12927 | XPVD(IPVAL) = | |
12928 | & XPVD(IPVAL)-DXPSQ | |
12929 | XPSAQ(JJ) = XPSQW | |
12930 | ENDIF | |
12931 | ENDIF | |
12932 | *>>>>>>>>>>>end of chain mass correction | |
12933 | 4202 CONTINUE | |
12934 | ||
12935 | * (b) assign new v-s chains | |
12936 | * ~~~~~~~~~~~~~~~~~~~~~~~~~ | |
12937 | IF (LSEADI.AND.( | |
12938 | & DT_RNDM(AMSVQ2).GT.FRCDIQ)) | |
12939 | & THEN | |
12940 | * sample sea-diquark pair | |
12941 | CALL DT_SAMSDQ(ECM,IXVPR,J,1, | |
12942 | & IREJ1) | |
12943 | IF (IREJ1.EQ.0) GOTO 4203 | |
12944 | ENDIF | |
12945 | NVS = NVS+1 | |
12946 | ISKPCH(6,NVS) = 0 | |
12947 | INTVS1(NVS) = IXVPR | |
12948 | INTVS2(NVS) = J | |
12949 | *>>>>>>>>>>>correct chain kinematics according to minimum chain masses | |
12950 | * the actual chain masses | |
12951 | AMVSQ1 = XPVQ(IXVPR)*XTSAQ(J)*ECM**2 | |
12952 | AMVSQ2 = XPVD(IXVPR)*XTSQ(J) *ECM**2 | |
12953 | * get lower mass cuts | |
12954 | IF (ITSQ(J).EQ.3) THEN | |
12955 | * q being s-quark | |
12956 | AMCHK1 = AMIS | |
12957 | AMCHK2 = AMAS | |
12958 | ELSE | |
12959 | * q being u/d-quark | |
12960 | AMCHK1 = AMIU | |
12961 | AMCHK2 = AMAU | |
12962 | ENDIF | |
12963 | * q-aq chain | |
12964 | * chain mass below minimum - reset sea-aq x-value and correct | |
12965 | * diquark-x of the same nucleon | |
12966 | IF (AMVSQ1.LT.AMCHK1) THEN | |
12967 | XTSQW = | |
12968 | & AMCHK1/(XPVQ(IXVPR)*ECM**2) | |
12969 | DXTSQ = XTSQW-XTSAQ(J) | |
12970 | IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) | |
12971 | & THEN | |
12972 | XTVD(ITVAL) = | |
12973 | & XTVD(ITVAL)-DXTSQ | |
12974 | XTSAQ(J) = XTSQW | |
12975 | ENDIF | |
12976 | ENDIF | |
12977 | IF (AMVSQ2.GT.AMCHK2) THEN | |
12978 | XTSQTH = | |
12979 | & AMCHK2/(XPVD(IXVPR)*ECM**2) | |
12980 | **sr 8.4.98 (1/sqrt(x)) | |
12981 | XTSQXX = | |
12982 | & DT_SAMPLW(XTSQTH,XTSQ(J),PLW) | |
12983 | C & DT_SAMSQX(XTSQTH,XTSQ(J)) | |
12984 | C & DT_SAMPEX(XTSQTH,XTSQ(J)) | |
12985 | ** | |
12986 | XTVD(ITVAL) = | |
12987 | & XTVD(ITVAL)+XTSQ(J)-XTSQXX | |
12988 | XTSQ(J) = XTSQXX | |
12989 | ELSEIF (AMVSQ2.LT.AMCHK2) THEN | |
12990 | XTSQW = | |
12991 | & AMCHK2/(XPVD(IXVPR)*ECM**2) | |
12992 | DXTSQ = XTSQW-XTSQ(J) | |
12993 | IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) | |
12994 | & THEN | |
12995 | XTVD(ITVAL) = | |
12996 | & XTVD(ITVAL)-DXTSQ | |
12997 | XTSQ(J) = XTSQW | |
12998 | ENDIF | |
12999 | ENDIF | |
13000 | *>>>>>>>>>end of chain mass correction | |
13001 | 4203 CONTINUE | |
13002 | * jump out of s-s chain loop | |
13003 | GOTO 420 | |
13004 | ENDIF | |
13005 | ENDIF | |
13006 | 4201 CONTINUE | |
13007 | ENDIF | |
13008 | *---->end of chain recombination option | |
13009 | ||
13010 | * sample sea-diquark pair (projectile) | |
13011 | IF (LSEADI.AND.(DT_RNDM(BSQMA).GT.FRCDIQ)) THEN | |
13012 | CALL DT_SAMSDQ(ECM,J,JJ,4,IREJ1) | |
13013 | IF (IREJ1.EQ.0) THEN | |
13014 | ISKPCH(1,NSS) = 99 | |
13015 | GOTO 410 | |
13016 | ENDIF | |
13017 | ENDIF | |
13018 | * sample sea-diquark pair (target) | |
13019 | IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN | |
13020 | CALL DT_SAMSDQ(ECM,JJ,J,3,IREJ1) | |
13021 | IF (IREJ1.EQ.0) THEN | |
13022 | ISKPCH(1,NSS) = 99 | |
13023 | GOTO 410 | |
13024 | ENDIF | |
13025 | ENDIF | |
13026 | *>>>>>correct chain kinematics according to minimum chain masses | |
13027 | * the actual chain masses | |
13028 | SSMA1Q = XPSQ(JJ) *XTSAQ(J)*ECM**2 | |
13029 | SSMA2Q = XPSAQ(JJ)*XTSQ(J) *ECM**2 | |
13030 | * check for lower mass cuts | |
13031 | IF ((SSMA1Q.LT.SSMIMQ).OR. | |
13032 | & (SSMA2Q.LT.SSMIMQ)) THEN | |
13033 | IPVAL = ITOVP(INTER1(I)) | |
13034 | ITVAL = ITOVT(INTER2(I)) | |
13035 | IF ((XPVD(IPVAL).GT.XDTHR+3.5D0*XSSTHR).AND. | |
13036 | & (XTVD(ITVAL).GT.XDTHR+3.5D0*XSSTHR))THEN | |
13037 | * maximum allowed x values for sea quarks | |
13038 | XSPMAX = ONE-XPVQ(IPVAL)-XDTHR- | |
13039 | & 1.2D0*XSSTHR | |
13040 | XSTMAX = ONE-XTVQ(ITVAL)-XDTHR- | |
13041 | & 1.2D0*XSSTHR | |
13042 | * resampling of x values not possible - skip sea-sea chains | |
13043 | IF ((XSPMAX.LE.XSSTHR+0.05D0).OR. | |
13044 | & (XSTMAX.LE.XSSTHR+0.05D0)) GOTO 380 | |
13045 | * resampling of x for projectile sea quark pair | |
13046 | ICOUS = 0 | |
13047 | 310 CONTINUE | |
13048 | ICOUS = ICOUS+1 | |
13049 | IF (XSSTHR.GT.0.05D0) THEN | |
13050 | XPSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR, | |
13051 | & XSPMAX) | |
13052 | XPSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR, | |
13053 | & XSPMAX) | |
13054 | ELSE | |
13055 | 320 CONTINUE | |
13056 | XPSQI = DT_DBETAR(XSEACU,UNOSEA) | |
13057 | IF ((XPSQI.LT.XSSTHR).OR. | |
13058 | & (XPSQI.GT.XSPMAX)) GOTO 320 | |
13059 | 330 CONTINUE | |
13060 | XPSAQI = DT_DBETAR(XSEACU,UNOSEA) | |
13061 | IF ((XPSAQI.LT.XSSTHR).OR. | |
13062 | & (XPSAQI.GT.XSPMAX)) GOTO 330 | |
13063 | ENDIF | |
13064 | * final test of remaining x for projectile diquark | |
13065 | XPVDCO = XPVD(IPVAL)-XPSQI-XPSAQI | |
13066 | & +XPSQ(JJ)+XPSAQ(JJ) | |
13067 | IF (XPVDCO.LE.XDTHR) THEN | |
13068 | *!!! | |
13069 | C IF (ICOUS.LT.5) GOTO 310 | |
13070 | IF (ICOUS.LT.0.5D0) GOTO 310 | |
13071 | GOTO 380 | |
13072 | ENDIF | |
13073 | * resampling of x for target sea quark pair | |
13074 | ICOUS = 0 | |
13075 | 350 CONTINUE | |
13076 | ICOUS = ICOUS+1 | |
13077 | IF (XSSTHR.GT.0.05D0) THEN | |
13078 | XTSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR, | |
13079 | & XSTMAX) | |
13080 | XTSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR, | |
13081 | & XSTMAX) | |
13082 | ELSE | |
13083 | 360 CONTINUE | |
13084 | XTSQI = DT_DBETAR(XSEACU,UNOSEA) | |
13085 | IF ((XTSQI.LT.XSSTHR).OR. | |
13086 | & (XTSQI.GT.XSTMAX)) GOTO 360 | |
13087 | 370 CONTINUE | |
13088 | XTSAQI = DT_DBETAR(XSEACU,UNOSEA) | |
13089 | IF ((XTSAQI.LT.XSSTHR).OR. | |
13090 | & (XTSAQI.GT.XSTMAX)) GOTO 370 | |
13091 | ENDIF | |
13092 | * final test of remaining x for target diquark | |
13093 | XTVDCO = XTVD(ITVAL)-XTSQI-XTSAQI | |
13094 | & +XTSQ(J)+XTSAQ(J) | |
13095 | IF (XTVDCO.LT.XDTHR) THEN | |
13096 | IF (ICOUS.LT.5) GOTO 350 | |
13097 | GOTO 380 | |
13098 | ENDIF | |
13099 | XPVD(IPVAL) = XPVDCO | |
13100 | XTVD(ITVAL) = XTVDCO | |
13101 | XPSQ(JJ) = XPSQI | |
13102 | XPSAQ(JJ) = XPSAQI | |
13103 | XTSQ(J) = XTSQI | |
13104 | XTSAQ(J) = XTSAQI | |
13105 | *>>>>>end of chain mass correction | |
13106 | GOTO 410 | |
13107 | ENDIF | |
13108 | * come here to discard s-s interaction | |
13109 | * resampling of x values not allowed or unsuccessful | |
13110 | 380 CONTINUE | |
13111 | INTLO(I) = .FALSE. | |
13112 | ZUOST(J) = .TRUE. | |
13113 | ZUOSP(JJ) = .TRUE. | |
13114 | NSS = NSS-1 | |
13115 | ENDIF | |
13116 | * consider next s-s interaction | |
13117 | GOTO 410 | |
13118 | ENDIF | |
13119 | 390 CONTINUE | |
13120 | ENDIF | |
13121 | 400 CONTINUE | |
13122 | ENDIF | |
13123 | 410 CONTINUE | |
13124 | 420 CONTINUE | |
13125 | ||
13126 | * correct x-values of valence quarks for non-matching sea quarks | |
13127 | DO 430 I=1,IXPS | |
13128 | IF (ZUOSP(I)) THEN | |
13129 | IPVAL = ITOVP(IFROSP(I)) | |
13130 | XPVQ(IPVAL) = XPVQ(IPVAL)+XPSQ(I)+XPSAQ(I) | |
13131 | XPSQ(I) = ZERO | |
13132 | XPSAQ(I) = ZERO | |
13133 | ZUOSP(I) = .FALSE. | |
13134 | ENDIF | |
13135 | 430 CONTINUE | |
13136 | DO 440 I=1,IXTS | |
13137 | IF (ZUOST(I)) THEN | |
13138 | ITVAL = ITOVT(IFROST(I)) | |
13139 | XTVQ(ITVAL) = XTVQ(ITVAL)+XTSQ(I)+XTSAQ(I) | |
13140 | XTSQ(I) = ZERO | |
13141 | XTSAQ(I) = ZERO | |
13142 | ZUOST(I) = .FALSE. | |
13143 | ENDIF | |
13144 | 440 CONTINUE | |
13145 | DO 450 I=1,IXPV | |
13146 | IF (ZUOVP(I)) ISTHKK(IFROVP(I)) = 13 | |
13147 | 450 CONTINUE | |
13148 | DO 460 I=1,IXTV | |
13149 | IF (ZUOVT(I)) ISTHKK(IFROVT(I)+IP) = 14 | |
13150 | 460 CONTINUE | |
13151 | ||
13152 | RETURN | |
13153 | END | |
13154 | ||
13155 | *$ CREATE DT_SAMSDQ.FOR | |
13156 | *COPY DT_SAMSDQ | |
13157 | * | |
13158 | *===samsdq=============================================================* | |
13159 | * | |
13160 | SUBROUTINE DT_SAMSDQ(ECM,IDX1,IDX2,MODE,IREJ) | |
13161 | ||
13162 | ************************************************************************ | |
13163 | * SAMpling of Sea-DiQuarks * | |
13164 | * ECM cm-energy of the nucleon-nucleon system * | |
13165 | * IDX1,2 indices of x-values of the participating * | |
13166 | * partons (IDX2 is always the sea-q-pair to be * | |
13167 | * changed to sea-qq-pair) * | |
13168 | * MODE = 1 valence-q - sea-diq * | |
13169 | * = 2 sea-diq - valence-q * | |
13170 | * = 3 sea-q - sea-diq * | |
13171 | * = 4 sea-diq - sea-q * | |
13172 | * Based on DIQVS, DIQSV, DIQSSD, DIQDSS. * | |
13173 | * This version dated 17.10.95 is written by S. Roesler * | |
13174 | ************************************************************************ | |
13175 | ||
13176 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
13177 | SAVE | |
13178 | ||
13179 | PARAMETER (ZERO=0.0D0) | |
13180 | ||
13181 | * threshold values for x-sampling (DTUNUC 1.x) | |
13182 | COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA, | |
13183 | & SSMIMQ,VVMTHR | |
13184 | * various options for treatment of partons (DTUNUC 1.x) | |
13185 | * (chain recombination, Cronin,..) | |
13186 | LOGICAL LCO2CR,LINTPT | |
13187 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, | |
13188 | & LCO2CR,LINTPT | |
13189 | PARAMETER ( MAXNCL = 260, | |
13190 | & MAXVQU = MAXNCL, | |
13191 | & MAXSQU = 20*MAXVQU, | |
13192 | & MAXINT = MAXVQU+MAXSQU) | |
13193 | * x-values of partons (DTUNUC 1.x) | |
13194 | COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU), | |
13195 | & XTVQ(MAXVQU),XTVD(MAXVQU), | |
13196 | & XPSQ(MAXSQU),XPSAQ(MAXSQU), | |
13197 | & XTSQ(MAXSQU),XTSAQ(MAXSQU) | |
13198 | * flavors of partons (DTUNUC 1.x) | |
13199 | COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU), | |
13200 | & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU), | |
13201 | & IPSQ(MAXSQU),IPSQ2(MAXSQU), | |
13202 | & IPSAQ(MAXSQU),IPSAQ2(MAXSQU), | |
13203 | & ITSQ(MAXSQU),ITSQ2(MAXSQU), | |
13204 | & ITSAQ(MAXSQU),ITSAQ2(MAXSQU), | |
13205 | & KKPROJ(MAXVQU),KKTARG(MAXVQU) | |
13206 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) | |
13207 | COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD, | |
13208 | & IXPV,IXPS,IXTV,IXTS, | |
13209 | & INTVV1(MAXVQU),INTVV2(MAXVQU), | |
13210 | & INTSV1(MAXVQU),INTSV2(MAXVQU), | |
13211 | & INTVS1(MAXVQU),INTVS2(MAXVQU), | |
13212 | & INTSS1(MAXSQU),INTSS2(MAXSQU), | |
13213 | & INTDV1(MAXVQU),INTDV2(MAXVQU), | |
13214 | & INTVD1(MAXVQU),INTVD2(MAXVQU), | |
13215 | & INTDS1(MAXSQU),INTDS2(MAXSQU), | |
13216 | & INTSD1(MAXSQU),INTSD2(MAXSQU) | |
13217 | * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x) | |
13218 | COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU), | |
13219 | & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU) | |
13220 | * auxiliary common for chain system storage (DTUNUC 1.x) | |
13221 | COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL) | |
13222 | ||
13223 | IREJ = 0 | |
13224 | * threshold-x for valence diquarks | |
13225 | XDTHR = CDQ/ECM | |
13226 | ||
13227 | GOTO (1,2,3,4) MODE | |
13228 | ||
13229 | *--------------------------------------------------------------------- | |
13230 | * proj. valence partons - targ. sea partons | |
13231 | * get x-values and flavors for target sea-diquark pair | |
13232 | ||
13233 | 1 CONTINUE | |
13234 | IDXVP = IDX1 | |
13235 | IDXST = IDX2 | |
13236 | ||
13237 | * index of corr. val-diquark-x in target nucleon | |
13238 | IDXVT = ITOVT(IFROST(IDXST)) | |
13239 | * available x above diquark thresholds for valence- and sea-diquarks | |
13240 | XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR | |
13241 | ||
13242 | IF (XXD.GE.ZERO) THEN | |
13243 | * x-values for the three diquarks of the target nucleon | |
13244 | RR1 = DT_RNDM(XXD) | |
13245 | RR2 = DT_RNDM(RR1) | |
13246 | RR3 = DT_RNDM(RR2) | |
13247 | SR123 = RR1+RR2+RR3 | |
13248 | XXTV = XDTHR+RR1*XXD/SR123 | |
13249 | XXTSQ = XDTHR+RR2*XXD/SR123 | |
13250 | XXTSAQ = XDTHR+RR3*XXD/SR123 | |
13251 | ELSE | |
13252 | XXTV = XTVD(IDXVT) | |
13253 | XXTSQ = XTSQ(IDXST) | |
13254 | XXTSAQ = XTSAQ(IDXST) | |
13255 | ENDIF | |
13256 | * flavor of the second quarks in the sea-diquark pair | |
13257 | ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ)) | |
13258 | ITSAQ2(IDXST) = -ITSQ2(IDXST) | |
13259 | * check masses of the new val-q - sea-qq, val-qq - sea-aqaq chains | |
13260 | AM1 = XXTSQ *XPVQ(IDXVP)*ECM**2 | |
13261 | AM2 = XXTSAQ*XPVD(IDXVP)*ECM**2 | |
13262 | IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND. | |
13263 | * ss-asas pair | |
13264 | & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN | |
13265 | IREJ = 1 | |
13266 | RETURN | |
13267 | ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND. | |
13268 | * at least one strange quark | |
13269 | & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN | |
13270 | IREJ = 1 | |
13271 | RETURN | |
13272 | ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN | |
13273 | IREJ = 1 | |
13274 | RETURN | |
13275 | ENDIF | |
13276 | * accept the new sea-diquark | |
13277 | XTVD(IDXVT) = XXTV | |
13278 | XTSQ(IDXST) = XXTSQ | |
13279 | XTSAQ(IDXST) = XXTSAQ | |
13280 | NVD = NVD+1 | |
13281 | INTVD1(NVD) = IDXVP | |
13282 | INTVD2(NVD) = IDXST | |
13283 | ISKPCH(7,NVD) = 0 | |
13284 | RETURN | |
13285 | ||
13286 | *--------------------------------------------------------------------- | |
13287 | * proj. sea partons - targ. valence partons | |
13288 | * get x-values and flavors for projectile sea-diquark pair | |
13289 | ||
13290 | 2 CONTINUE | |
13291 | IDXSP = IDX2 | |
13292 | IDXVT = IDX1 | |
13293 | ||
13294 | * index of corr. val-diquark-x in projectile nucleon | |
13295 | IDXVP = ITOVP(IFROSP(IDXSP)) | |
13296 | * available x above diquark thresholds for valence- and sea-diquarks | |
13297 | XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR | |
13298 | ||
13299 | IF (XXD.GE.ZERO) THEN | |
13300 | * x-values for the three diquarks of the projectile nucleon | |
13301 | RR1 = DT_RNDM(XXD) | |
13302 | RR2 = DT_RNDM(RR1) | |
13303 | RR3 = DT_RNDM(RR2) | |
13304 | SR123 = RR1+RR2+RR3 | |
13305 | XXPV = XDTHR+RR1*XXD/SR123 | |
13306 | XXPSQ = XDTHR+RR2*XXD/SR123 | |
13307 | XXPSAQ = XDTHR+RR3*XXD/SR123 | |
13308 | ELSE | |
13309 | XXPV = XPVD(IDXVP) | |
13310 | XXPSQ = XPSQ(IDXSP) | |
13311 | XXPSAQ = XPSAQ(IDXSP) | |
13312 | ENDIF | |
13313 | * flavor of the second quarks in the sea-diquark pair | |
13314 | IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ)) | |
13315 | IPSAQ2(IDXSP) = -IPSQ2(IDXSP) | |
13316 | * check masses of the new sea-qq - val-q, sea-aqaq - val-qq chains | |
13317 | AM1 = XXPSQ *XTVQ(IDXVT)*ECM**2 | |
13318 | AM2 = XXPSAQ*XTVD(IDXVT)*ECM**2 | |
13319 | IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND. | |
13320 | * ss-asas pair | |
13321 | & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN | |
13322 | IREJ = 1 | |
13323 | RETURN | |
13324 | ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND. | |
13325 | * at least one strange quark | |
13326 | & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN | |
13327 | IREJ = 1 | |
13328 | RETURN | |
13329 | ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN | |
13330 | IREJ = 1 | |
13331 | RETURN | |
13332 | ENDIF | |
13333 | * accept the new sea-diquark | |
13334 | XPVD(IDXVP) = XXPV | |
13335 | XPSQ(IDXSP) = XXPSQ | |
13336 | XPSAQ(IDXSP) = XXPSAQ | |
13337 | NDV = NDV+1 | |
13338 | INTDV1(NDV) = IDXSP | |
13339 | INTDV2(NDV) = IDXVT | |
13340 | ISKPCH(5,NDV) = 0 | |
13341 | RETURN | |
13342 | ||
13343 | *--------------------------------------------------------------------- | |
13344 | * proj. sea partons - targ. sea partons | |
13345 | * get x-values and flavors for target sea-diquark pair | |
13346 | ||
13347 | 3 CONTINUE | |
13348 | IDXSP = IDX1 | |
13349 | IDXST = IDX2 | |
13350 | ||
13351 | * index of corr. val-diquark-x in target nucleon | |
13352 | IDXVT = ITOVT(IFROST(IDXST)) | |
13353 | * available x above diquark thresholds for valence- and sea-diquarks | |
13354 | XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR | |
13355 | ||
13356 | IF (XXD.GE.ZERO) THEN | |
13357 | * x-values for the three diquarks of the target nucleon | |
13358 | RR1 = DT_RNDM(XXD) | |
13359 | RR2 = DT_RNDM(RR1) | |
13360 | RR3 = DT_RNDM(RR2) | |
13361 | SR123 = RR1+RR2+RR3 | |
13362 | XXTV = XDTHR+RR1*XXD/SR123 | |
13363 | XXTSQ = XDTHR+RR2*XXD/SR123 | |
13364 | XXTSAQ = XDTHR+RR3*XXD/SR123 | |
13365 | ELSE | |
13366 | XXTV = XTVD(IDXVT) | |
13367 | XXTSQ = XTSQ(IDXST) | |
13368 | XXTSAQ = XTSAQ(IDXST) | |
13369 | ENDIF | |
13370 | * flavor of the second quarks in the sea-diquark pair | |
13371 | ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ)) | |
13372 | ITSAQ2(IDXST) = -ITSQ2(IDXST) | |
13373 | * check masses of the new sea-q - sea-qq, sea-aq - sea-aqaq chains | |
13374 | AM1 = XXTSQ *XPSQ(IDXSP)*ECM**2 | |
13375 | AM2 = XXTSAQ*XPSAQ(IDXSP)*ECM**2 | |
13376 | IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND. | |
13377 | * ss-asas pair | |
13378 | & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN | |
13379 | IREJ = 1 | |
13380 | RETURN | |
13381 | ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND. | |
13382 | * at least one strange quark | |
13383 | & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN | |
13384 | IREJ = 1 | |
13385 | RETURN | |
13386 | ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN | |
13387 | IREJ = 1 | |
13388 | RETURN | |
13389 | ENDIF | |
13390 | * accept the new sea-diquark | |
13391 | XTVD(IDXVT) = XXTV | |
13392 | XTSQ(IDXST) = XXTSQ | |
13393 | XTSAQ(IDXST) = XXTSAQ | |
13394 | NSD = NSD+1 | |
13395 | INTSD1(NSD) = IDXSP | |
13396 | INTSD2(NSD) = IDXST | |
13397 | ISKPCH(3,NSD) = 0 | |
13398 | RETURN | |
13399 | ||
13400 | *--------------------------------------------------------------------- | |
13401 | * proj. sea partons - targ. sea partons | |
13402 | * get x-values and flavors for projectile sea-diquark pair | |
13403 | ||
13404 | 4 CONTINUE | |
13405 | IDXSP = IDX2 | |
13406 | IDXST = IDX1 | |
13407 | ||
13408 | * index of corr. val-diquark-x in projectile nucleon | |
13409 | IDXVP = ITOVP(IFROSP(IDXSP)) | |
13410 | * available x above diquark thresholds for valence- and sea-diquarks | |
13411 | XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR | |
13412 | ||
13413 | IF (XXD.GE.ZERO) THEN | |
13414 | * x-values for the three diquarks of the projectile nucleon | |
13415 | RR1 = DT_RNDM(XXD) | |
13416 | RR2 = DT_RNDM(RR1) | |
13417 | RR3 = DT_RNDM(RR2) | |
13418 | SR123 = RR1+RR2+RR3 | |
13419 | XXPV = XDTHR+RR1*XXD/SR123 | |
13420 | XXPSQ = XDTHR+RR2*XXD/SR123 | |
13421 | XXPSAQ = XDTHR+RR3*XXD/SR123 | |
13422 | ELSE | |
13423 | XXPV = XPVD(IDXVP) | |
13424 | XXPSQ = XPSQ(IDXSP) | |
13425 | XXPSAQ = XPSAQ(IDXSP) | |
13426 | ENDIF | |
13427 | * flavor of the second quarks in the sea-diquark pair | |
13428 | IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ)) | |
13429 | IPSAQ2(IDXSP) = -IPSQ2(IDXSP) | |
13430 | * check masses of the new sea-qq - sea-q, sea-aqaq - sea-qq chains | |
13431 | AM1 = XXPSQ *XTSQ(IDXST)*ECM**2 | |
13432 | AM2 = XXPSAQ*XTSAQ(IDXST)*ECM**2 | |
13433 | IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND. | |
13434 | * ss-asas pair | |
13435 | & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN | |
13436 | IREJ = 1 | |
13437 | RETURN | |
13438 | ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND. | |
13439 | * at least one strange quark | |
13440 | & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN | |
13441 | IREJ = 1 | |
13442 | RETURN | |
13443 | ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN | |
13444 | IREJ = 1 | |
13445 | RETURN | |
13446 | ENDIF | |
13447 | * accept the new sea-diquark | |
13448 | XPVD(IDXVP) = XXPV | |
13449 | XPSQ(IDXSP) = XXPSQ | |
13450 | XPSAQ(IDXSP) = XXPSAQ | |
13451 | NDS = NDS+1 | |
13452 | INTDS1(NDS) = IDXSP | |
13453 | INTDS2(NDS) = IDXST | |
13454 | ISKPCH(2,NDS) = 0 | |
13455 | RETURN | |
13456 | END | |
13457 | ||
13458 | *$ CREATE DT_DIFEVT.FOR | |
13459 | *COPY DT_DIFEVT | |
13460 | * | |
13461 | *===difevt=============================================================* | |
13462 | * | |
13463 | SUBROUTINE DT_DIFEVT(IFP1,IFP2,PP,MOP, | |
13464 | & IFT1,IFT2,PT,MOT,JDIFF,NCSY,IREJ) | |
13465 | ||
13466 | ************************************************************************ | |
13467 | * Interface to treatment of diffractive interactions. * | |
13468 | * (input) IFP1/2 PDG-indizes of projectile partons * | |
13469 | * (baryon: IFP2 - adiquark) * | |
13470 | * PP(4) projectile 4-momentum * | |
13471 | * IFT1/2 PDG-indizes of target partons * | |
13472 | * (baryon: IFT1 - adiquark) * | |
13473 | * PT(4) target 4-momentum * | |
13474 | * (output) JDIFF = 0 no diffraction * | |
13475 | * = 1/-1 LMSD/LMDD * | |
13476 | * = 2/-2 HMSD/HMDD * | |
13477 | * NCSY counter for two-chain systems * | |
13478 | * dumped to DTEVT1 * | |
13479 | * This version dated 14.02.95 is written by S. Roesler * | |
13480 | ************************************************************************ | |
13481 | ||
13482 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
13483 | SAVE | |
13484 | PARAMETER ( LINP = 10 , | |
13485 | & LOUT = 6 , | |
13486 | & LDAT = 9 ) | |
13487 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5, | |
13488 | & OHALF=0.5D0) | |
13489 | ||
13490 | * event history | |
13491 | PARAMETER (NMXHKK=200000) | |
13492 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
13493 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
13494 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
13495 | * extended event history | |
13496 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
13497 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
13498 | & IHIST(2,NMXHKK) | |
13499 | * flags for diffractive interactions (DTUNUC 1.x) | |
13500 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF | |
13501 | ||
13502 | DIMENSION PP(4),PT(4) | |
13503 | ||
13504 | LOGICAL LFIRST | |
13505 | DATA LFIRST /.TRUE./ | |
13506 | ||
13507 | IREJ = 0 | |
13508 | JDIFF = 0 | |
13509 | IFLAGD = JDIFF | |
13510 | ||
13511 | * cm. energy | |
13512 | XM = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2- | |
13513 | & (PP(2)+PT(2))**2-(PP(3)+PT(3))**2) | |
13514 | * identities of projectile hadron / target nucleon | |
13515 | KPROJ = IDT_ICIHAD(IDHKK(MOP)) | |
13516 | KTARG = IDT_ICIHAD(IDHKK(MOT)) | |
13517 | ||
13518 | * single diffractive xsections | |
13519 | CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM) | |
13520 | * double diffractive xsections | |
13521 | **!! no double diff yet | |
13522 | C CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM,DDTOT,DDHM) | |
13523 | DDTOT = 0.0D0 | |
13524 | DDHM = 0.0D0 | |
13525 | **!! | |
13526 | * total inelastic xsection | |
13527 | C SIGIN = DT_SHNTOT(KPROJ,KTARG,XM,ZERO)-DT_SHNELA(KPROJ,KTARG,XM) | |
13528 | DUMZER = ZERO | |
13529 | CALL DT_XSHN(KPROJ,KTARG,DUMZER,XM,SIGTO,SIGEL) | |
13530 | SIGIN = MAX(SIGTO-SIGEL,ZERO) | |
13531 | ||
13532 | * fraction of diffractive processes | |
13533 | FRADIF = (SDTOT+DDTOT)/SIGIN | |
13534 | ||
13535 | IF (LFIRST) THEN | |
13536 | WRITE(LOUT,1000) XM,SDTOT,SIGIN | |
13537 | 1000 FORMAT(1X,'DIFEVT: single diffraction requested at E_cm = ', | |
13538 | & F5.1,' GeV',/,9X,'sigma_sd = ',F4.1,' mb, sigma_in = ', | |
13539 | & F5.1,' mb',/) | |
13540 | LFIRST = .FALSE. | |
13541 | ENDIF | |
13542 | ||
13543 | IF ((DT_RNDM(DDHM).LE.FRADIF).OR. | |
13544 | & (ISINGD.GT.1).OR.(IDOUBD.GT.1)) THEN | |
13545 | * diffractive interaction requested by x-section or by user | |
13546 | FRASD = SDTOT/(SDTOT+DDTOT) | |
13547 | FRASDH = SDHM/SDTOT | |
13548 | **sr needs to be specified!! | |
13549 | C FRADDH = DDHM/DDTOT | |
13550 | FRADDH = 1.0D0 | |
13551 | ** | |
13552 | IF ((DT_RNDM(FRASD).LE.FRASD).OR.(ISINGD.GT.1)) THEN | |
13553 | * single diffraction | |
13554 | KDIFF = 1 | |
13555 | IF (DT_RNDM(DDTOT).LE.FRASDH) THEN | |
13556 | KP = 2 | |
13557 | KT = 0 | |
13558 | IF (((ISINGD.EQ.4).OR.(DT_RNDM(DDTOT).GE.OHALF)).AND. | |
13559 | & ISINGD.NE.3) THEN | |
13560 | KP = 0 | |
13561 | KT = 2 | |
13562 | ENDIF | |
13563 | ELSE | |
13564 | KP = 1 | |
13565 | KT = 0 | |
13566 | IF (((ISINGD.EQ.4).OR.(DT_RNDM(FRADDH).GE.OHALF)).AND. | |
13567 | & ISINGD.NE.3) THEN | |
13568 | KP = 0 | |
13569 | KT = 1 | |
13570 | ENDIF | |
13571 | ENDIF | |
13572 | ELSE | |
13573 | * double diffraction | |
13574 | KDIFF = -1 | |
13575 | IF (DT_RNDM(FRADDH).LE.FRADDH) THEN | |
13576 | KP = 2 | |
13577 | KT = 2 | |
13578 | ELSE | |
13579 | KP = 1 | |
13580 | KT = 1 | |
13581 | ENDIF | |
13582 | ENDIF | |
13583 | CALL DT_DIFFKI(IFP1,IFP2,PP,MOP,KP, | |
13584 | & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1) | |
13585 | IF (IREJ1.EQ.0) THEN | |
13586 | IFLAGD = 2*KDIFF | |
13587 | IF ((KP.EQ.1).OR.(KT.EQ.1)) IFLAGD = KDIFF | |
13588 | ELSE | |
13589 | GOTO 9999 | |
13590 | ENDIF | |
13591 | ENDIF | |
13592 | JDIFF = IFLAGD | |
13593 | ||
13594 | RETURN | |
13595 | ||
13596 | 9999 CONTINUE | |
13597 | IREJ = 1 | |
13598 | RETURN | |
13599 | END | |
13600 | ||
13601 | *$ CREATE DT_DIFFKI.FOR | |
13602 | *COPY DT_DIFFKI | |
13603 | * | |
13604 | *===difkin=============================================================* | |
13605 | * | |
13606 | SUBROUTINE DT_DIFFKI(IFP1,IFP2,PP,MOP,KP, | |
13607 | & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ) | |
13608 | ||
13609 | ************************************************************************ | |
13610 | * Kinematics of diffractive nucleon-nucleon interaction. * | |
13611 | * IFP1/2 PDG-indizes of projectile partons * | |
13612 | * (baryon: IFP2 - adiquark) * | |
13613 | * PP(4) projectile 4-momentum * | |
13614 | * IFT1/2 PDG-indizes of target partons * | |
13615 | * (baryon: IFT1 - adiquark) * | |
13616 | * PT(4) target 4-momentum * | |
13617 | * KP = 0 projectile quasi-elastically scattered * | |
13618 | * = 1 excited to low-mass diff. state * | |
13619 | * = 2 excited to high-mass diff. state * | |
13620 | * KT = 0 target quasi-elastically scattered * | |
13621 | * = 1 excited to low-mass diff. state * | |
13622 | * = 2 excited to high-mass diff. state * | |
13623 | * This version dated 12.02.95 is written by S. Roesler * | |
13624 | ************************************************************************ | |
13625 | ||
13626 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
13627 | SAVE | |
13628 | PARAMETER ( LINP = 10 , | |
13629 | & LOUT = 6 , | |
13630 | & LDAT = 9 ) | |
13631 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5) | |
13632 | ||
13633 | LOGICAL LSTART | |
13634 | ||
13635 | * particle properties (BAMJET index convention) | |
13636 | CHARACTER*8 ANAME | |
13637 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
13638 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
13639 | * flags for input different options | |
13640 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
13641 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
13642 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
13643 | * rejection counter | |
13644 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
13645 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
13646 | & IREXCI(3),IRDIFF(2),IRINC | |
13647 | * kinematics of diffractive interactions (DTUNUC 1.x) | |
13648 | COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4), | |
13649 | & PPF(4),PTF(4), | |
13650 | & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4), | |
13651 | & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2) | |
13652 | ||
13653 | DIMENSION PITOT(4),BGTOT(4),PP1(4),PT1(4),PPBLOB(4),PTBLOB(4), | |
13654 | & PP(4),PT(4),PPOM1(4),DEV1(4),DEV2(4) | |
13655 | ||
13656 | DATA LSTART /.TRUE./ | |
13657 | ||
13658 | IF (LSTART) THEN | |
13659 | WRITE(LOUT,2000) | |
13660 | 2000 FORMAT(/,1X,'DIFEVT: diffractive interactions treated ') | |
13661 | LSTART = .FALSE. | |
13662 | ENDIF | |
13663 | ||
13664 | IREJ = 0 | |
13665 | ||
13666 | * initialize common /DTDIKI/ | |
13667 | CALL DT_DIFINI | |
13668 | * store momenta of initial incoming particles for emc-check | |
13669 | IF (LEMCCK) THEN | |
13670 | CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM,IDUM) | |
13671 | CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM,IDUM) | |
13672 | ENDIF | |
13673 | ||
13674 | * masses of initial particles | |
13675 | XMP2 = PP(4)**2-PP(1)**2-PP(2)**2-PP(3)**2 | |
13676 | XMT2 = PT(4)**2-PT(1)**2-PT(2)**2-PT(3)**2 | |
13677 | IF ((XMP2.LT.ZERO).OR.(XMT2.LT.ZERO)) GOTO 9999 | |
13678 | XMP = SQRT(XMP2) | |
13679 | XMT = SQRT(XMT2) | |
13680 | * check quark-input (used to adjust coherence cond. for M-selection) | |
13681 | IBP = 0 | |
13682 | IF ((ABS(IFP1).GE.1000).OR.(ABS(IFP2).GE.1000)) IBP = 1 | |
13683 | IBT = 0 | |
13684 | IF ((ABS(IFT1).GE.1000).OR.(ABS(IFT2).GE.1000)) IBT = 1 | |
13685 | ||
13686 | * parameter for Lorentz-transformation into nucleon-nucleon cms | |
13687 | DO 3 K=1,4 | |
13688 | PITOT(K) = PP(K)+PT(K) | |
13689 | 3 CONTINUE | |
13690 | XMTOT2 = PITOT(4)**2-PITOT(1)**2-PITOT(2)**2-PITOT(3)**2 | |
13691 | IF (XMTOT2.LE.ZERO) THEN | |
13692 | WRITE(LOUT,1000) XMTOT2 | |
13693 | 1000 FORMAT(1X,'DIFEVT: negative cm. energy! ', | |
13694 | & 'XMTOT2 = ',E12.3) | |
13695 | GOTO 9999 | |
13696 | ENDIF | |
13697 | XMTOT = SQRT(XMTOT2) | |
13698 | DO 4 K=1,4 | |
13699 | BGTOT(K) = PITOT(K)/XMTOT | |
13700 | 4 CONTINUE | |
13701 | * transformation of nucleons into cms | |
13702 | CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PP(1),PP(2), | |
13703 | & PP(3),PP(4),PPTOT,PP1(1),PP1(2),PP1(3),PP1(4)) | |
13704 | CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PT(1),PT(2), | |
13705 | & PT(3),PT(4),PTTOT,PT1(1),PT1(2),PT1(3),PT1(4)) | |
13706 | * rotation angles | |
13707 | COD = PP1(3)/PPTOT | |
13708 | C SID = SQRT((ONE-COD)*(ONE+COD)) | |
13709 | PPT = SQRT(PP1(1)**2+PP1(2)**2) | |
13710 | SID = PPT/PPTOT | |
13711 | COF = ONE | |
13712 | SIF = ZERO | |
13713 | IF(PPTOT*SID.GT.TINY10) THEN | |
13714 | COF = PP1(1)/(SID*PPTOT) | |
13715 | SIF = PP1(2)/(SID*PPTOT) | |
13716 | ANORF = SQRT(COF*COF+SIF*SIF) | |
13717 | COF = COF/ANORF | |
13718 | SIF = SIF/ANORF | |
13719 | ENDIF | |
13720 | * check consistency | |
13721 | DO 5 K=1,4 | |
13722 | DEV1(K) = ABS(PP1(K)+PT1(K)) | |
13723 | 5 CONTINUE | |
13724 | DEV1(4) = ABS(DEV1(4)-XMTOT) | |
13725 | IF ((DEV1(1).GT.TINY10).OR.(DEV1(2).GT.TINY10).OR. | |
13726 | & (DEV1(3).GT.TINY10).OR.(DEV1(4).GT.TINY10)) THEN | |
13727 | WRITE(LOUT,1001) DEV1 | |
13728 | 1001 FORMAT(1X,'DIFEVT: inconsitent Lorentz-transformation! ', | |
13729 | & /,8X,4E12.3) | |
13730 | GOTO 9999 | |
13731 | ENDIF | |
13732 | ||
13733 | * select x-fractions in high-mass diff. interactions | |
13734 | IF ((KP.EQ.2).OR.(KT.EQ.2)) CALL DT_XVALHM(KP,KT) | |
13735 | ||
13736 | * select diffractive masses | |
13737 | * - projectile | |
13738 | IF (KP.EQ.1) THEN | |
13739 | XMPF = DT_XMLMD(XMTOT) | |
13740 | CALL DT_LM2RES(IFP1,IFP2,XMPF,IDPR,IDXPR,IREJ1) | |
13741 | IF (IREJ1.GT.0) GOTO 9999 | |
13742 | ELSEIF (KP.EQ.2) THEN | |
13743 | XMPF = DT_XMHMD(XMTOT,IBP,1) | |
13744 | ELSE | |
13745 | XMPF = XMP | |
13746 | ENDIF | |
13747 | * - target | |
13748 | IF (KT.EQ.1) THEN | |
13749 | XMTF = DT_XMLMD(XMTOT) | |
13750 | CALL DT_LM2RES(IFT1,IFT2,XMTF,IDTR,IDXTR,IREJ1) | |
13751 | IF (IREJ1.GT.0) GOTO 9999 | |
13752 | ELSEIF (KT.EQ.2) THEN | |
13753 | XMTF = DT_XMHMD(XMTOT,IBT,2) | |
13754 | ELSE | |
13755 | XMTF = XMT | |
13756 | ENDIF | |
13757 | ||
13758 | * kinematical treatment of "two-particle" system (masses - XMPF,XMTF) | |
13759 | XMPF2 = XMPF**2 | |
13760 | XMTF2 = XMTF**2 | |
13761 | PPBLOB(3) = DT_YLAMB(XMTOT2,XMPF2,XMTF2)/(2.D0*XMTOT) | |
13762 | PPBLOB(4) = SQRT(XMPF2+PPBLOB(3)**2) | |
13763 | ||
13764 | * select momentum transfer (all t-values used here are <0) | |
13765 | * minimum absolute value to produce diffractive masses | |
13766 | TMIN = XMP2+XMPF2-2.0D0*(PP1(4)*PPBLOB(4)-PPTOT*PPBLOB(3)) | |
13767 | TT = DT_TDIFF(XMTOT,TMIN,XMPF,KP,XMTF,KT,IREJ1) | |
13768 | IF (IREJ1.GT.0) GOTO 9999 | |
13769 | ||
13770 | * longitudinal momentum of excited/elastically scattered projectile | |
13771 | PPBLOB(3) = (TT-XMP2-XMPF2+2.0D0*PP1(4)*PPBLOB(4))/(2.0D0*PPTOT) | |
13772 | * total transverse momentum due to t-selection | |
13773 | PPBLT2 = PPBLOB(4)**2-PPBLOB(3)**2-XMPF2 | |
13774 | IF (PPBLT2.LT.ZERO) THEN | |
13775 | WRITE(LOUT,1002) PPBLT2,KP,PP1,XMPF,KT,PT1,XMTF,TT | |
13776 | 1002 FORMAT(1X,'DIFEVT: inconsistent transverse momentum! ', | |
13777 | & E12.3,2(/,1X,I2,5E12.3),/,1X,E12.3) | |
13778 | GOTO 9999 | |
13779 | ENDIF | |
13780 | CALL DT_DSFECF(SINPHI,COSPHI) | |
13781 | PPBLT = SQRT(PPBLT2) | |
13782 | PPBLOB(1) = COSPHI*PPBLT | |
13783 | PPBLOB(2) = SINPHI*PPBLT | |
13784 | ||
13785 | * rotate excited/elastically scattered projectile into n-n cms. | |
13786 | CALL DT_MYTRAN(1,PPBLOB(1),PPBLOB(2),PPBLOB(3),COD,SID,COF,SIF, | |
13787 | & XX,YY,ZZ) | |
13788 | PPBLOB(1) = XX | |
13789 | PPBLOB(2) = YY | |
13790 | PPBLOB(3) = ZZ | |
13791 | ||
13792 | * 4-momentum of excited/elastically scattered target and of exchanged | |
13793 | * Pomeron | |
13794 | DO 6 K=1,4 | |
13795 | IF (K.LT.4) PTBLOB(K) = -PPBLOB(K) | |
13796 | PPOM1(K) = PP1(K)-PPBLOB(K) | |
13797 | 6 CONTINUE | |
13798 | PTBLOB(4) = XMTOT-PPBLOB(4) | |
13799 | ||
13800 | * Lorentz-transformation back into system of initial diff. collision | |
13801 | CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3), | |
13802 | & PPBLOB(1),PPBLOB(2),PPBLOB(3),PPBLOB(4), | |
13803 | & PPTOTF,PPF(1),PPF(2),PPF(3),PPF(4)) | |
13804 | CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3), | |
13805 | & PTBLOB(1),PTBLOB(2),PTBLOB(3),PTBLOB(4), | |
13806 | & PTTOTF,PTF(1),PTF(2),PTF(3),PTF(4)) | |
13807 | CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3), | |
13808 | & PPOM1(1),PPOM1(2),PPOM1(3),PPOM1(4), | |
13809 | & PPOMTO,PPOM(1),PPOM(2),PPOM(3),PPOM(4)) | |
13810 | ||
13811 | * store 4-momentum of elastically scattered particle (in single diff. | |
13812 | * events) | |
13813 | IF (KP.EQ.0) THEN | |
13814 | DO 7 K=1,4 | |
13815 | PSC(K) = PPF(K) | |
13816 | 7 CONTINUE | |
13817 | ELSEIF (KT.EQ.0) THEN | |
13818 | DO 8 K=1,4 | |
13819 | PSC(K) = PTF(K) | |
13820 | 8 CONTINUE | |
13821 | ENDIF | |
13822 | ||
13823 | * check consistency of kinematical treatment so far | |
13824 | IF (LEMCCK) THEN | |
13825 | CALL DT_EVTEMC(-PPF(1),-PPF(2),-PPF(3),-PPF(4),2,IDUM,IDUM) | |
13826 | CALL DT_EVTEMC(-PTF(1),-PTF(2),-PTF(3),-PTF(4),2,IDUM,IDUM) | |
13827 | CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,60,IREJ1) | |
13828 | IF (IREJ1.NE.0) GOTO 9999 | |
13829 | ENDIF | |
13830 | DO 9 K=1,4 | |
13831 | DEV1(K) = ABS(PP(K)-PPF(K)-PPOM(K)) | |
13832 | DEV2(K) = ABS(PT(K)-PTF(K)+PPOM(K)) | |
13833 | 9 CONTINUE | |
13834 | IF ((DEV1(1).GT.TINY5).OR.(DEV1(2).GT.TINY5).OR. | |
13835 | & (DEV1(3).GT.TINY5).OR.(DEV1(4).GT.TINY5).OR. | |
13836 | & (DEV2(1).GT.TINY5).OR.(DEV2(2).GT.TINY5).OR. | |
13837 | & (DEV2(3).GT.TINY5).OR.(DEV2(4).GT.TINY5)) THEN | |
13838 | WRITE(LOUT,1003) DEV1,DEV2 | |
13839 | 1003 FORMAT(1X,'DIFEVT: inconsitent kinematical treatment! ', | |
13840 | & 2(/,8X,4E12.3)) | |
13841 | GOTO 9999 | |
13842 | ENDIF | |
13843 | ||
13844 | * kinematical treatment for low-mass diffraction | |
13845 | CALL DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ1) | |
13846 | IF (IREJ1.NE.0) GOTO 9999 | |
13847 | ||
13848 | * dump diffractive chains into DTEVT1 | |
13849 | CALL DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1) | |
13850 | IF (IREJ1.NE.0) GOTO 9999 | |
13851 | ||
13852 | RETURN | |
13853 | ||
13854 | 9999 CONTINUE | |
13855 | IRDIFF(1) = IRDIFF(1)+1 | |
13856 | IREJ = 1 | |
13857 | RETURN | |
13858 | END | |
13859 | ||
13860 | *$ CREATE DT_XMHMD.FOR | |
13861 | *COPY DT_XMHMD | |
13862 | * | |
13863 | *===xmhmd==============================================================* | |
13864 | * | |
13865 | DOUBLE PRECISION FUNCTION DT_XMHMD(ECM,IB,MODE) | |
13866 | ||
13867 | ************************************************************************ | |
13868 | * Diffractive mass in high mass single/double diffractive events. * | |
13869 | * This version dated 11.02.95 is written by S. Roesler * | |
13870 | ************************************************************************ | |
13871 | ||
13872 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
13873 | SAVE | |
13874 | PARAMETER ( LINP = 10 , | |
13875 | & LOUT = 6 , | |
13876 | & LDAT = 9 ) | |
13877 | PARAMETER (OHALF=0.5D0,ONE=1.0D0,ZERO=0.0D0) | |
13878 | ||
13879 | * kinematics of diffractive interactions (DTUNUC 1.x) | |
13880 | COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4), | |
13881 | & PPF(4),PTF(4), | |
13882 | & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4), | |
13883 | & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2) | |
13884 | ||
13885 | C DATA XCOLOW /0.05D0/ | |
13886 | DATA XCOLOW /0.15D0/ | |
13887 | ||
13888 | DT_XMHMD = ZERO | |
13889 | XH = XPH(2) | |
13890 | IF (MODE.EQ.2) XH = XTH(2) | |
13891 | ||
13892 | * minimum Pomeron-x for high-mass diffraction | |
13893 | * (adjusted to get a smooth transition between HM and LM component) | |
13894 | R = DT_RNDM(XH) | |
13895 | XDIMIN = (3.0D0+400.0D0*R**2)/(XH*ECM**2) | |
13896 | IF (ECM.LE.300.0D0) THEN | |
13897 | RR = (1.0D0-EXP(-((ECM/140.0D0)**4))) | |
13898 | XDIMIN = (3.0D0+400.0D0*(R**2)*RR)/(XH*ECM**2) | |
13899 | ENDIF | |
13900 | * maximum Pomeron-x for high-mass diffraction | |
13901 | * (coherence condition, adjusted to fit to experimental data) | |
13902 | IF (IB.NE.0) THEN | |
13903 | * baryon-diffraction | |
13904 | XDIMAX = XCOLOW*(1.0D0+EXP(-((ECM/420.0D0)**2))) | |
13905 | ELSE | |
13906 | * meson-diffraction | |
13907 | XDIMAX = XCOLOW*(1.0D0+4.0D0*EXP(-((ECM/420.0D0)**2))) | |
13908 | ENDIF | |
13909 | * check boundaries | |
13910 | IF (XDIMIN.GE.XDIMAX) THEN | |
13911 | XDIMIN = OHALF*XDIMAX | |
13912 | ENDIF | |
13913 | ||
13914 | KLOOP = 0 | |
13915 | 1 CONTINUE | |
13916 | KLOOP = KLOOP+1 | |
13917 | IF (KLOOP.GT.20) RETURN | |
13918 | * sample Pomeron-x from 1/x-distribution (critical Pomeron) | |
13919 | XDIFF = DT_SAMPEX(XDIMIN,XDIMAX) | |
13920 | * corr. diffr. mass | |
13921 | DT_XMHMD = ECM*SQRT(XDIFF) | |
13922 | IF (DT_XMHMD.LT.2.5D0) GOTO 1 | |
13923 | ||
13924 | RETURN | |
13925 | END | |
13926 | ||
13927 | *$ CREATE DT_XMLMD.FOR | |
13928 | *COPY DT_XMLMD | |
13929 | * | |
13930 | *===xmlmd==============================================================* | |
13931 | * | |
13932 | DOUBLE PRECISION FUNCTION DT_XMLMD(ECM) | |
13933 | ||
13934 | ************************************************************************ | |
13935 | * Diffractive mass in high mass single/double diffractive events. * | |
13936 | * This version dated 11.02.95 is written by S. Roesler * | |
13937 | ************************************************************************ | |
13938 | ||
13939 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
13940 | SAVE | |
13941 | PARAMETER ( LINP = 10 , | |
13942 | & LOUT = 6 , | |
13943 | & LDAT = 9 ) | |
13944 | ||
13945 | * minimum Pomeron-x for low-mass diffraction | |
13946 | C AMO = 1.5D0 | |
13947 | AMO = 2.0D0 | |
13948 | * maximum Pomeron-x for low-mass diffraction | |
13949 | * (adjusted to get a smooth transition between HM and LM component) | |
13950 | R = DT_RNDM(AMO) | |
13951 | SAM = 1.0D0 | |
13952 | IF (ECM.LE.300.0D0) SAM = 1.0D0-EXP(-((ECM/200.0D0)**4)) | |
13953 | R = DT_RNDM(AMO)*SAM | |
13954 | AMAX= (1.0D0-SAM)*SQRT(0.1D0*ECM**2)+SAM*SQRT(400.0D0) | |
13955 | AMU = R*SQRT(100.0D0)+(1.0D0-R)*AMAX | |
13956 | ||
13957 | * selection of diffractive mass | |
13958 | * (adjusted to get a smooth transition between HM and LM component) | |
13959 | R = DT_RNDM(AMU) | |
13960 | IF (ECM.LE.50.0D0) THEN | |
13961 | DT_XMLMD = AMO*(AMU/AMO)**R | |
13962 | ELSE | |
13963 | A = 0.7D0 | |
13964 | IF (ECM.LE.300.0D0) A = 0.7D0*(1.0D0-EXP(-((ECM/100.0D0)**2))) | |
13965 | DT_XMLMD = 1.0D0/((R/(AMU**A)+(1.0D0-R)/(AMO**A))**(1.0D0/A)) | |
13966 | ENDIF | |
13967 | ||
13968 | RETURN | |
13969 | END | |
13970 | ||
13971 | *$ CREATE DT_TDIFF.FOR | |
13972 | *COPY DT_TDIFF | |
13973 | * | |
13974 | *===tdiff==============================================================* | |
13975 | * | |
13976 | DOUBLE PRECISION FUNCTION DT_TDIFF(ECM,TMIN,XM1I,K1,XM2I,K2,IREJ) | |
13977 | ||
13978 | ************************************************************************ | |
13979 | * t-selection for single/double diffractive interactions. * | |
13980 | * ECM cm. energy * | |
13981 | * TMIN minimum momentum transfer to produce diff. masses * | |
13982 | * XM1/XM2 diffractively produced masses * | |
13983 | * (for single diffraction XM2 is obsolete) * | |
13984 | * K1/K2= 0 not excited * | |
13985 | * = 1 low-mass excitation * | |
13986 | * = 2 high-mass excitation * | |
13987 | * This version dated 11.02.95 is written by S. Roesler * | |
13988 | ************************************************************************ | |
13989 | ||
13990 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
13991 | SAVE | |
13992 | PARAMETER ( LINP = 10 , | |
13993 | & LOUT = 6 , | |
13994 | & LDAT = 9 ) | |
13995 | PARAMETER (ZERO=0.0D0) | |
13996 | ||
13997 | PARAMETER ( BTP0 = 3.7D0, | |
13998 | & ALPHAP = 0.24D0 ) | |
13999 | ||
14000 | IREJ = 0 | |
14001 | NCLOOP = 0 | |
14002 | DT_TDIFF = ZERO | |
14003 | ||
14004 | IF (K1.GT.0) THEN | |
14005 | XM1 = XM1I | |
14006 | XM2 = XM2I | |
14007 | ELSE | |
14008 | XM1 = XM2I | |
14009 | ENDIF | |
14010 | XDI = (XM1/ECM)**2 | |
14011 | IF ((K1.EQ.0).OR.(K2.EQ.0)) THEN | |
14012 | * slope for single diffraction | |
14013 | SLOPE = BTP0-2.0D0*ALPHAP*LOG(XDI) | |
14014 | ELSE | |
14015 | * slope for double diffraction | |
14016 | SLOPE = -2.0D0*ALPHAP*LOG(XDI*XM2**2) | |
14017 | ENDIF | |
14018 | ||
14019 | 1 CONTINUE | |
14020 | NCLOOP = NCLOOP+1 | |
14021 | IF (MOD(NCLOOP,1000).EQ.0) GOTO 9999 | |
14022 | Y = DT_RNDM(XDI) | |
14023 | T = -LOG(1.0D0-Y)/SLOPE | |
14024 | IF (ABS(T).LE.ABS(TMIN)) GOTO 1 | |
14025 | DT_TDIFF = -ABS(T) | |
14026 | ||
14027 | RETURN | |
14028 | ||
14029 | 9999 CONTINUE | |
14030 | WRITE(LOUT,1000) ECM,TMIN,XM1I,XM2I,K1,K2 | |
14031 | 1000 FORMAT(1X,'DT_TDIFF: t-selection rejected!',/, | |
14032 | & 1X,'ECM = ',E12.3,' TMIN = ',E12.2,/,1X,'XM1I = ', | |
14033 | & E12.3,' XM2I = ',E12.3,' K1 = ',I2,' K2 = ',I2) | |
14034 | IREJ = 1 | |
14035 | RETURN | |
14036 | END | |
14037 | ||
14038 | *$ CREATE DT_XVALHM.FOR | |
14039 | *COPY DT_XVALHM | |
14040 | * | |
14041 | *===xvalhm=============================================================* | |
14042 | * | |
14043 | SUBROUTINE DT_XVALHM(KP,KT) | |
14044 | ||
14045 | ************************************************************************ | |
14046 | * Sampling of parton x-values in high-mass diffractive interactions. * | |
14047 | * This version dated 12.02.95 is written by S. Roesler * | |
14048 | ************************************************************************ | |
14049 | ||
14050 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
14051 | SAVE | |
14052 | PARAMETER ( LINP = 10 , | |
14053 | & LOUT = 6 , | |
14054 | & LDAT = 9 ) | |
14055 | PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0,TINY2=1.0D-2) | |
14056 | ||
14057 | * kinematics of diffractive interactions (DTUNUC 1.x) | |
14058 | COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4), | |
14059 | & PPF(4),PTF(4), | |
14060 | & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4), | |
14061 | & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2) | |
14062 | * various options for treatment of partons (DTUNUC 1.x) | |
14063 | * (chain recombination, Cronin,..) | |
14064 | LOGICAL LCO2CR,LINTPT | |
14065 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, | |
14066 | & LCO2CR,LINTPT | |
14067 | ||
14068 | DATA UNON,XVQTHR /2.0D0,0.8D0/ | |
14069 | ||
14070 | IF (KP.EQ.2) THEN | |
14071 | * x-fractions of projectile valence partons | |
14072 | 1 CONTINUE | |
14073 | XPH(1) = DT_DBETAR(OHALF,UNON) | |
14074 | IF (XPH(1).GE.XVQTHR) GOTO 1 | |
14075 | XPH(2) = ONE-XPH(1) | |
14076 | * x-fractions of Pomeron q-aq-pair | |
14077 | XPOLO = TINY2 | |
14078 | XPOHI = ONE-TINY2 | |
14079 | XPPO(1) = DT_SAMPEX(XPOLO,XPOHI) | |
14080 | XPPO(2) = ONE-XPPO(1) | |
14081 | * flavors of Pomeron q-aq-pair | |
14082 | IFLAV = INT(ONE+DT_RNDM(UNON)*(2.0D0+SEASQ)) | |
14083 | IFPPO(1) = IFLAV | |
14084 | IFPPO(2) = -IFLAV | |
14085 | IF (DT_RNDM(UNON).GT.OHALF) THEN | |
14086 | IFPPO(1) = -IFLAV | |
14087 | IFPPO(2) = IFLAV | |
14088 | ENDIF | |
14089 | ENDIF | |
14090 | ||
14091 | IF (KT.EQ.2) THEN | |
14092 | * x-fractions of projectile target partons | |
14093 | 2 CONTINUE | |
14094 | XTH(1) = DT_DBETAR(OHALF,UNON) | |
14095 | IF (XTH(1).GE.XVQTHR) GOTO 2 | |
14096 | XTH(2) = ONE-XTH(1) | |
14097 | * x-fractions of Pomeron q-aq-pair | |
14098 | XPOLO = TINY2 | |
14099 | XPOHI = ONE-TINY2 | |
14100 | XTPO(1) = DT_SAMPEX(XPOLO,XPOHI) | |
14101 | XTPO(2) = ONE-XTPO(1) | |
14102 | * flavors of Pomeron q-aq-pair | |
14103 | IFLAV = INT(ONE+DT_RNDM(XPOLO)*(2.0D0+SEASQ)) | |
14104 | IFTPO(1) = IFLAV | |
14105 | IFTPO(2) = -IFLAV | |
14106 | IF (DT_RNDM(XPOLO).GT.OHALF) THEN | |
14107 | IFTPO(1) = -IFLAV | |
14108 | IFTPO(2) = IFLAV | |
14109 | ENDIF | |
14110 | ENDIF | |
14111 | ||
14112 | RETURN | |
14113 | END | |
14114 | ||
14115 | *$ CREATE DT_LM2RES.FOR | |
14116 | *COPY DT_LM2RES | |
14117 | * | |
14118 | *===lm2res=============================================================* | |
14119 | * | |
14120 | SUBROUTINE DT_LM2RES(IF1,IF2,XM,IDR,IDXR,IREJ) | |
14121 | ||
14122 | ************************************************************************ | |
14123 | * Check low-mass diffractive excitation for resonance mass. * | |
14124 | * (input) IF1/2 PDG-indizes of valence partons * | |
14125 | * (in/out) XM diffractive mass requested/corrected * | |
14126 | * (output) IDR/IDXR id./BAMJET-index of resonance * | |
14127 | * This version dated 12.02.95 is written by S. Roesler * | |
14128 | ************************************************************************ | |
14129 | ||
14130 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
14131 | SAVE | |
14132 | PARAMETER ( LINP = 10 , | |
14133 | & LOUT = 6 , | |
14134 | & LDAT = 9 ) | |
14135 | PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0) | |
14136 | ||
14137 | * kinematics of diffractive interactions (DTUNUC 1.x) | |
14138 | COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4), | |
14139 | & PPF(4),PTF(4), | |
14140 | & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4), | |
14141 | & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2) | |
14142 | ||
14143 | IREJ = 0 | |
14144 | IF1B = 0 | |
14145 | IF2B = 0 | |
14146 | XMI = XM | |
14147 | ||
14148 | * BAMJET indices of partons | |
14149 | IF1A = IDT_IPDG2B(IF1,1,2) | |
14150 | IF (ABS(IF1).GE.1000) IF1B = IDT_IPDG2B(IF1,2,2) | |
14151 | IF2A = IDT_IPDG2B(IF2,1,2) | |
14152 | IF (ABS(IF2).GE.1000) IF2B = IDT_IPDG2B(IF2,2,2) | |
14153 | ||
14154 | * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq) | |
14155 | IDCH = 2 | |
14156 | IF ((IF1B.EQ.0).AND.(IF2B.EQ.0)) IDCH = 1 | |
14157 | ||
14158 | * check for resonance mass | |
14159 | CALL DT_CH2RES(IF1A,IF1B,IF2A,IF2B,IDR,IDXR,XMI,XMN,IDCH,IREJ1) | |
14160 | IF (IREJ1.NE.0) GOTO 9999 | |
14161 | ||
14162 | XM = XMN | |
14163 | RETURN | |
14164 | ||
14165 | 9999 CONTINUE | |
14166 | IREJ = 1 | |
14167 | RETURN | |
14168 | END | |
14169 | ||
14170 | *$ CREATE DT_LMKINE.FOR | |
14171 | *COPY DT_LMKINE | |
14172 | * | |
14173 | *===lmkine=============================================================* | |
14174 | * | |
14175 | SUBROUTINE DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ) | |
14176 | ||
14177 | ************************************************************************ | |
14178 | * Kinematical treatment of low-mass excitations. * | |
14179 | * This version dated 12.02.95 is written by S. Roesler * | |
14180 | ************************************************************************ | |
14181 | ||
14182 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
14183 | SAVE | |
14184 | PARAMETER ( LINP = 10 , | |
14185 | & LOUT = 6 , | |
14186 | & LDAT = 9 ) | |
14187 | PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0) | |
14188 | ||
14189 | * flags for input different options | |
14190 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
14191 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
14192 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
14193 | * kinematics of diffractive interactions (DTUNUC 1.x) | |
14194 | COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4), | |
14195 | & PPF(4),PTF(4), | |
14196 | & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4), | |
14197 | & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2) | |
14198 | ||
14199 | DIMENSION P1(4),P2(4) | |
14200 | ||
14201 | IREJ = 0 | |
14202 | ||
14203 | IF (KP.EQ.1) THEN | |
14204 | PABS = SQRT(PPF(1)**2+PPF(2)**2+PPF(3)**2) | |
14205 | POE = PPF(4)/PABS | |
14206 | FAC1 = OHALF*(POE+ONE) | |
14207 | FAC2 = -OHALF*(POE-ONE) | |
14208 | DO 1 K=1,3 | |
14209 | PPLM1(K) = FAC1*PPF(K) | |
14210 | PPLM2(K) = FAC2*PPF(K) | |
14211 | 1 CONTINUE | |
14212 | PPLM1(4) = FAC1*PABS | |
14213 | PPLM2(4) = -FAC2*PABS | |
14214 | IF (IMSHL.EQ.1) THEN | |
14215 | XM1 = PYMASS(IFP1) | |
14216 | XM2 = PYMASS(IFP2) | |
14217 | CALL DT_MASHEL(PPLM1,PPLM2,XM1,XM2,P1,P2,IREJ1) | |
14218 | IF (IREJ1.NE.0) GOTO 9999 | |
14219 | DO 2 K=1,4 | |
14220 | PPLM1(K) = P1(K) | |
14221 | PPLM2(K) = P2(K) | |
14222 | 2 CONTINUE | |
14223 | ENDIF | |
14224 | ENDIF | |
14225 | ||
14226 | IF (KT.EQ.1) THEN | |
14227 | PABS = SQRT(PTF(1)**2+PTF(2)**2+PTF(3)**2) | |
14228 | POE = PTF(4)/PABS | |
14229 | FAC1 = OHALF*(POE+ONE) | |
14230 | FAC2 = -OHALF*(POE-ONE) | |
14231 | DO 3 K=1,3 | |
14232 | PTLM2(K) = FAC1*PTF(K) | |
14233 | PTLM1(K) = FAC2*PTF(K) | |
14234 | 3 CONTINUE | |
14235 | PTLM2(4) = FAC1*PABS | |
14236 | PTLM1(4) = -FAC2*PABS | |
14237 | IF (IMSHL.EQ.1) THEN | |
14238 | XM1 = PYMASS(IFT1) | |
14239 | XM2 = PYMASS(IFT2) | |
14240 | CALL DT_MASHEL(PTLM1,PTLM2,XM1,XM2,P1,P2,IREJ1) | |
14241 | IF (IREJ1.NE.0) GOTO 9999 | |
14242 | DO 4 K=1,4 | |
14243 | PTLM1(K) = P1(K) | |
14244 | PTLM2(K) = P2(K) | |
14245 | 4 CONTINUE | |
14246 | ENDIF | |
14247 | ENDIF | |
14248 | ||
14249 | RETURN | |
14250 | ||
14251 | 9999 CONTINUE | |
14252 | WRITE(LOUT,'(A)') 'LMKINE: kinematical treatment rejected' | |
14253 | IREJ = 1 | |
14254 | RETURN | |
14255 | END | |
14256 | ||
14257 | *$ CREATE DT_DIFINI.FOR | |
14258 | *COPY DT_DIFINI | |
14259 | * | |
14260 | *===difini=============================================================* | |
14261 | * | |
14262 | SUBROUTINE DT_DIFINI | |
14263 | ||
14264 | ************************************************************************ | |
14265 | * Initialization of common /DTDIKI/ * | |
14266 | * This version dated 12.02.95 is written by S. Roesler * | |
14267 | ************************************************************************ | |
14268 | ||
14269 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
14270 | SAVE | |
14271 | PARAMETER ( LINP = 10 , | |
14272 | & LOUT = 6 , | |
14273 | & LDAT = 9 ) | |
14274 | PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0) | |
14275 | ||
14276 | * kinematics of diffractive interactions (DTUNUC 1.x) | |
14277 | COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4), | |
14278 | & PPF(4),PTF(4), | |
14279 | & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4), | |
14280 | & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2) | |
14281 | ||
14282 | DO 1 K=1,4 | |
14283 | PPOM(K) = ZERO | |
14284 | PSC(K) = ZERO | |
14285 | PPF(K) = ZERO | |
14286 | PTF(K) = ZERO | |
14287 | PPLM1(K) = ZERO | |
14288 | PPLM2(K) = ZERO | |
14289 | PTLM1(K) = ZERO | |
14290 | PTLM2(K) = ZERO | |
14291 | 1 CONTINUE | |
14292 | DO 2 K=1,2 | |
14293 | XPH(K) = ZERO | |
14294 | XPPO(K) = ZERO | |
14295 | XTH(K) = ZERO | |
14296 | XTPO(K) = ZERO | |
14297 | IFPPO(K) = 0 | |
14298 | IFTPO(K) = 0 | |
14299 | 2 CONTINUE | |
14300 | IDPR = 0 | |
14301 | IDXPR = 0 | |
14302 | IDTR = 0 | |
14303 | IDXTR = 0 | |
14304 | ||
14305 | RETURN | |
14306 | END | |
14307 | ||
14308 | *$ CREATE DT_DIFPUT.FOR | |
14309 | *COPY DT_DIFPUT | |
14310 | * | |
14311 | *===difput=============================================================* | |
14312 | * | |
14313 | SUBROUTINE DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY, | |
14314 | & IREJ) | |
14315 | ||
14316 | ************************************************************************ | |
14317 | * Dump diffractive chains into DTEVT1 * | |
14318 | * This version dated 12.02.95 is written by S. Roesler * | |
14319 | ************************************************************************ | |
14320 | ||
14321 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
14322 | SAVE | |
14323 | PARAMETER ( LINP = 10 , | |
14324 | & LOUT = 6 , | |
14325 | & LDAT = 9 ) | |
14326 | PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0) | |
14327 | ||
14328 | LOGICAL LCHK | |
14329 | ||
14330 | * kinematics of diffractive interactions (DTUNUC 1.x) | |
14331 | COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4), | |
14332 | & PPF(4),PTF(4), | |
14333 | & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4), | |
14334 | & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2) | |
14335 | * event history | |
14336 | PARAMETER (NMXHKK=200000) | |
14337 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
14338 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
14339 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
14340 | * extended event history | |
14341 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
14342 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
14343 | & IHIST(2,NMXHKK) | |
14344 | * rejection counter | |
14345 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
14346 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
14347 | & IREXCI(3),IRDIFF(2),IRINC | |
14348 | ||
14349 | DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PCH(4),PP(4),PT(4), | |
14350 | & P1(4),P2(4),P3(4),P4(4) | |
14351 | ||
14352 | IREJ = 0 | |
14353 | ||
14354 | IF (KP.EQ.1) THEN | |
14355 | DO 1 K=1,4 | |
14356 | PCH(K) = PPLM1(K)+PPLM2(K) | |
14357 | 1 CONTINUE | |
14358 | ID1 = IFP1 | |
14359 | ID2 = IFP2 | |
14360 | IF (DT_RNDM(PT).GT.OHALF) THEN | |
14361 | ID1 = IFP2 | |
14362 | ID2 = IFP1 | |
14363 | ENDIF | |
14364 | CALL DT_EVTPUT(21,ID1,MOP,0,PPLM1(1),PPLM1(2),PPLM1(3), | |
14365 | & PPLM1(4),0,0,0) | |
14366 | CALL DT_EVTPUT(21,ID2,MOP,0,PPLM2(1),PPLM2(2),PPLM2(3), | |
14367 | & PPLM2(4),0,0,0) | |
14368 | CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4), | |
14369 | & IDPR,IDXPR,8) | |
14370 | ELSEIF (KP.EQ.2) THEN | |
14371 | DO 2 K=1,4 | |
14372 | PP1(K) = XPH(1)*PP(K) | |
14373 | PP2(K) = XPH(2)*PP(K) | |
14374 | PT1(K) = -XPPO(1)*PPOM(K) | |
14375 | PT2(K) = -XPPO(2)*PPOM(K) | |
14376 | 2 CONTINUE | |
14377 | CALL DT_CHKCSY(IFP1,IFPPO(1),LCHK) | |
14378 | XM1 = ZERO | |
14379 | XM2 = ZERO | |
14380 | IF (LCHK) THEN | |
14381 | CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1) | |
14382 | IF (IREJ1.NE.0) GOTO 9999 | |
14383 | CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1) | |
14384 | IF (IREJ1.NE.0) GOTO 9999 | |
14385 | DO 3 K=1,4 | |
14386 | PP1(K) = P1(K) | |
14387 | PT1(K) = P2(K) | |
14388 | PP2(K) = P3(K) | |
14389 | PT2(K) = P4(K) | |
14390 | 3 CONTINUE | |
14391 | CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), | |
14392 | & 0,0,8) | |
14393 | CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3), | |
14394 | & PT1(4),0,0,8) | |
14395 | CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), | |
14396 | & 0,0,8) | |
14397 | CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3), | |
14398 | & PT2(4),0,0,8) | |
14399 | ELSE | |
14400 | CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1) | |
14401 | IF (IREJ1.NE.0) GOTO 9999 | |
14402 | CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1) | |
14403 | IF (IREJ1.NE.0) GOTO 9999 | |
14404 | DO 4 K=1,4 | |
14405 | PP1(K) = P1(K) | |
14406 | PT2(K) = P2(K) | |
14407 | PP2(K) = P3(K) | |
14408 | PT1(K) = P4(K) | |
14409 | 4 CONTINUE | |
14410 | CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4), | |
14411 | & 0,0,8) | |
14412 | CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3), | |
14413 | & PT2(4),0,0,8) | |
14414 | CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4), | |
14415 | & 0,0,8) | |
14416 | CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3), | |
14417 | & PT1(4),0,0,8) | |
14418 | ENDIF | |
14419 | NCSY = NCSY+1 | |
14420 | ELSE | |
14421 | CALL DT_EVTPUT(1,IDHKK(MOP),MOP,0,PSC(1),PSC(2),PSC(3),PSC(4), | |
14422 | & 0,0,0) | |
14423 | ENDIF | |
14424 | ||
14425 | IF (KT.EQ.1) THEN | |
14426 | DO 5 K=1,4 | |
14427 | PCH(K) = PTLM1(K)+PTLM2(K) | |
14428 | 5 CONTINUE | |
14429 | ID1 = IFT1 | |
14430 | ID2 = IFT2 | |
14431 | IF (DT_RNDM(PT).GT.OHALF) THEN | |
14432 | ID1 = IFT2 | |
14433 | ID2 = IFT1 | |
14434 | ENDIF | |
14435 | CALL DT_EVTPUT(22,ID1,MOT,0,PTLM1(1),PTLM1(2),PTLM1(3), | |
14436 | & PTLM1(4),0,0,0) | |
14437 | CALL DT_EVTPUT(22,ID2,MOT,0,PTLM2(1),PTLM2(2),PTLM2(3), | |
14438 | & PTLM2(4),0,0,0) | |
14439 | CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4), | |
14440 | & IDTR,IDXTR,8) | |
14441 | ELSEIF (KT.EQ.2) THEN | |
14442 | DO 6 K=1,4 | |
14443 | PP1(K) = XTPO(1)*PPOM(K) | |
14444 | PP2(K) = XTPO(2)*PPOM(K) | |
14445 | PT1(K) = XTH(2)*PT(K) | |
14446 | PT2(K) = XTH(1)*PT(K) | |
14447 | 6 CONTINUE | |
14448 | CALL DT_CHKCSY(IFTPO(1),IFT1,LCHK) | |
14449 | XM1 = ZERO | |
14450 | XM2 = ZERO | |
14451 | IF (LCHK) THEN | |
14452 | CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1) | |
14453 | IF (IREJ1.NE.0) GOTO 9999 | |
14454 | CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1) | |
14455 | IF (IREJ1.NE.0) GOTO 9999 | |
14456 | DO 7 K=1,4 | |
14457 | PP1(K) = P1(K) | |
14458 | PT1(K) = P2(K) | |
14459 | PP2(K) = P3(K) | |
14460 | PT2(K) = P4(K) | |
14461 | 7 CONTINUE | |
14462 | CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3), | |
14463 | & PP1(4),0,0,8) | |
14464 | CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), | |
14465 | & 0,0,8) | |
14466 | CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3), | |
14467 | & PP2(4),0,0,8) | |
14468 | CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), | |
14469 | & 0,0,8) | |
14470 | ELSE | |
14471 | CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1) | |
14472 | IF (IREJ1.NE.0) GOTO 9999 | |
14473 | CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1) | |
14474 | IF (IREJ1.NE.0) GOTO 9999 | |
14475 | DO 8 K=1,4 | |
14476 | PP1(K) = P1(K) | |
14477 | PT2(K) = P2(K) | |
14478 | PP2(K) = P3(K) | |
14479 | PT1(K) = P4(K) | |
14480 | 8 CONTINUE | |
14481 | CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3), | |
14482 | & PP1(4),0,0,8) | |
14483 | CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4), | |
14484 | & 0,0,8) | |
14485 | CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3), | |
14486 | & PP2(4),0,0,8) | |
14487 | CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4), | |
14488 | & 0,0,8) | |
14489 | ENDIF | |
14490 | NCSY = NCSY+1 | |
14491 | ELSE | |
14492 | CALL DT_EVTPUT(1,IDHKK(MOT),MOT,0,PSC(1),PSC(2),PSC(3),PSC(4), | |
14493 | & 0,0,0) | |
14494 | ENDIF | |
14495 | ||
14496 | RETURN | |
14497 | ||
14498 | 9999 CONTINUE | |
14499 | IRDIFF(2) = IRDIFF(2)+1 | |
14500 | IREJ = 1 | |
14501 | RETURN | |
14502 | END | |
14503 | ||
14504 | *$ CREATE DT_EVTFRG.FOR | |
14505 | *COPY DT_EVTFRG | |
14506 | * | |
14507 | *===evtfrg=============================================================* | |
14508 | * | |
14509 | SUBROUTINE DT_EVTFRG(KMODE,NFRG,NPYMEM,IREJ) | |
14510 | ||
14511 | ************************************************************************ | |
14512 | * Hadronization of chains in DTEVT1. * | |
14513 | * * | |
14514 | * Input: * | |
14515 | * KMODE = 1 hadronization of PHOJET-chains (id=77xxx) * | |
14516 | * = 2 hadronization of DTUNUC-chains (id=88xxx) * | |
14517 | * NFRG if KMODE = 1 : upper index of PHOJET-scatterings to be * | |
14518 | * hadronized with one PYEXEC call * | |
14519 | * if KMODE = 2 : max. number of DTUNUC-chains to be hadronized * | |
14520 | * with one PYEXEC call * | |
14521 | * Output: * | |
14522 | * NPYMEM number of entries in JETSET-common after hadronization * | |
14523 | * IREJ rejection flag * | |
14524 | * * | |
14525 | * This version dated 17.09.00 is written by S. Roesler * | |
14526 | ************************************************************************ | |
14527 | ||
14528 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
14529 | SAVE | |
14530 | PARAMETER ( LINP = 10 , | |
14531 | & LOUT = 6 , | |
14532 | & LDAT = 9 ) | |
14533 | PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1) | |
14534 | PARAMETER (ONE=1.0D0,ZERO=0.0D0) | |
14535 | ||
14536 | LOGICAL LACCEP | |
14537 | ||
14538 | PARAMETER (MXJOIN=200) | |
14539 | ||
14540 | * event history | |
14541 | PARAMETER (NMXHKK=200000) | |
14542 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
14543 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
14544 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
14545 | * extended event history | |
14546 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
14547 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
14548 | & IHIST(2,NMXHKK) | |
14549 | * flags for input different options | |
14550 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
14551 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
14552 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
14553 | * statistics | |
14554 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
14555 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
14556 | & ICEVTG(8,0:30) | |
14557 | * flags for diffractive interactions (DTUNUC 1.x) | |
14558 | COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF | |
14559 | * nucleon-nucleon event-generator | |
14560 | CHARACTER*8 CMODEL | |
14561 | LOGICAL LPHOIN | |
14562 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
14563 | * phojet | |
14564 | C model switches and parameters | |
14565 | CHARACTER*8 MDLNA | |
14566 | INTEGER ISWMDL,IPAMDL | |
14567 | DOUBLE PRECISION PARMDL | |
14568 | COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400) | |
14569 | * jetset | |
14570 | COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) | |
14571 | PARAMETER (MAXLND=4000) | |
14572 | COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5) | |
14573 | INTEGER PYK | |
14574 | DIMENSION IJOIN(MXJOIN),ISJOIN(MXJOIN),IHISMO(8000),IFLG(4000) | |
14575 | ||
14576 | MODE = KMODE | |
14577 | ISTSTG = 7 | |
14578 | IF (MODE.NE.1) ISTSTG = 8 | |
14579 | IREJ = 0 | |
14580 | ||
14581 | IP = 0 | |
14582 | ISH = 0 | |
14583 | INIEMC = 1 | |
14584 | NEND = NHKK | |
14585 | NACCEP = 0 | |
14586 | IFRG = 0 | |
14587 | IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1 | |
14588 | DO 10 I=NPOINT(3),NEND | |
14589 | * sr 14.02.00: seems to be not necessary anymore, commented | |
14590 | C LACCEP = ((NOBAM(I).EQ.0).AND.(MODE.EQ.1)).OR. | |
14591 | C & ((NOBAM(I).NE.0).AND.(MODE.EQ.2)) | |
14592 | LACCEP = .TRUE. | |
14593 | * pick up chains from dtevt1 | |
14594 | IDCHK = IDHKK(I)/10000 | |
14595 | IF ((IDCHK.EQ.ISTSTG).AND.LACCEP) THEN | |
14596 | IF (IDCHK.EQ.7) THEN | |
14597 | IPJE = IDHKK(I)-IDCHK*10000 | |
14598 | IF (IPJE.NE.IFRG) THEN | |
14599 | IFRG = IPJE | |
14600 | IF (IFRG.GT.NFRG) GOTO 16 | |
14601 | ENDIF | |
14602 | ELSE | |
14603 | IPJE = 1 | |
14604 | IFRG = IFRG+1 | |
14605 | IF (IFRG.GT.NFRG) THEN | |
14606 | NFRG = -1 | |
14607 | GOTO 16 | |
14608 | ENDIF | |
14609 | ENDIF | |
14610 | * statistics counter | |
14611 | c IF (IDCH(I).LE.8) | |
14612 | c & ICCHAI(2,IDCH(I)) = ICCHAI(2,IDCH(I))+1 | |
14613 | c IF (IDRES(I).NE.0) ICRES(IDCH(I)) = ICRES(IDCH(I))+1 | |
14614 | * special treatment for small chains already corrected to hadrons | |
14615 | IF (IDRES(I).NE.0) THEN | |
14616 | IF (IDRES(I).EQ.11) THEN | |
14617 | ID = IDXRES(I) | |
14618 | ELSE | |
14619 | ID = IDT_IPDGHA(IDXRES(I)) | |
14620 | ENDIF | |
14621 | IF (LEMCCK) THEN | |
14622 | CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I), | |
14623 | & PHKK(4,I),INIEMC,IDUM,IDUM) | |
14624 | INIEMC = 2 | |
14625 | ENDIF | |
14626 | IP = IP+1 | |
14627 | IF (IP.GT.MSTU(4)) STOP ' NEWFRA 1: IP.GT.MSTU(4) !' | |
14628 | P(IP,1) = PHKK(1,I) | |
14629 | P(IP,2) = PHKK(2,I) | |
14630 | P(IP,3) = PHKK(3,I) | |
14631 | P(IP,4) = PHKK(4,I) | |
14632 | P(IP,5) = PHKK(5,I) | |
14633 | K(IP,1) = 1 | |
14634 | K(IP,2) = ID | |
14635 | K(IP,3) = 0 | |
14636 | K(IP,4) = 0 | |
14637 | K(IP,5) = 0 | |
14638 | IHIST(2,I) = 10000*IPJE+IP | |
14639 | IF (IHIST(1,I).LE.-100) THEN | |
14640 | ISH = ISH+1 | |
14641 | IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !' | |
14642 | ISJOIN(ISH) = I | |
14643 | ENDIF | |
14644 | N = IP | |
14645 | IHISMO(IP) = I | |
14646 | ELSE | |
14647 | IJ = 0 | |
14648 | DO 11 KK=JMOHKK(1,I),JMOHKK(2,I) | |
14649 | IF (LEMCCK) THEN | |
14650 | CALL DT_EVTEMC(PHKK(1,KK),PHKK(2,KK),PHKK(3,KK), | |
14651 | & PHKK(4,KK),INIEMC,IDUM,IDUM) | |
14652 | CALL DT_EVTFLC(IDHKK(KK),1,INIEMC,IDUM,IDUM) | |
14653 | INIEMC = 2 | |
14654 | ENDIF | |
14655 | ID = IDHKK(KK) | |
14656 | IF (ID.EQ.0) ID = 21 | |
14657 | c PTOT = SQRT(PHKK(1,KK)**2+PHKK(2,KK)**2+PHKK(3,KK)**2) | |
14658 | c AM0 = SQRT(ABS((PHKK(4,KK)-PTOT)*(PHKK(4,KK)+PTOT))) | |
14659 | c AMRQ = PYMASS(ID) | |
14660 | c AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ) | |
14661 | c IF ((ABS(AMDIF2).GT.TINY3).AND.(PTOT.GT.ZERO).AND. | |
14662 | c & (ABS(IDIFF).EQ.0)) THEN | |
14663 | cC WRITE(LOUT,*)'here: ',NEVHKK,AM0,AMRQ | |
14664 | c DELTA = -AMDIF2/(2.0D0*(PHKK(4,KK)+PTOT)) | |
14665 | c PHKK(4,KK) = PHKK(4,KK)+DELTA | |
14666 | c PTOT1 = PTOT-DELTA | |
14667 | c PHKK(1,KK) = PHKK(1,KK)*PTOT1/PTOT | |
14668 | c PHKK(2,KK) = PHKK(2,KK)*PTOT1/PTOT | |
14669 | c PHKK(3,KK) = PHKK(3,KK)*PTOT1/PTOT | |
14670 | c PHKK(5,KK) = AMRQ | |
14671 | c ENDIF | |
14672 | IP = IP+1 | |
14673 | IF (IP.GT.MSTU(4)) STOP ' NEWFRA 2: IP.GT.MSTU(4) !' | |
14674 | P(IP,1) = PHKK(1,KK) | |
14675 | P(IP,2) = PHKK(2,KK) | |
14676 | P(IP,3) = PHKK(3,KK) | |
14677 | P(IP,4) = PHKK(4,KK) | |
14678 | P(IP,5) = PHKK(5,KK) | |
14679 | K(IP,1) = 1 | |
14680 | K(IP,2) = ID | |
14681 | K(IP,3) = 0 | |
14682 | K(IP,4) = 0 | |
14683 | K(IP,5) = 0 | |
14684 | IHIST(2,KK) = 10000*IPJE+IP | |
14685 | IF (IHIST(1,KK).LE.-100) THEN | |
14686 | ISH = ISH+1 | |
14687 | IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !' | |
14688 | ISJOIN(ISH) = KK | |
14689 | ENDIF | |
14690 | IJ = IJ+1 | |
14691 | IF (IJ.GT.MXJOIN) STOP 'IJ > MXJOIN !' | |
14692 | IJOIN(IJ) = IP | |
14693 | IHISMO(IP) = I | |
14694 | 11 CONTINUE | |
14695 | N = IP | |
14696 | * join the two-parton system | |
14697 | CALL PYJOIN(IJ,IJOIN) | |
14698 | ENDIF | |
14699 | IDHKK(I) = 99999 | |
14700 | ENDIF | |
14701 | 10 CONTINUE | |
14702 | 16 CONTINUE | |
14703 | N = IP | |
14704 | ||
14705 | IF (IP.GT.0) THEN | |
14706 | ||
14707 | * final state parton shower | |
14708 | DO 136 NPJE=1,IPJE | |
14709 | IF ((MCGENE.EQ.2).AND.(ISH.GE.2)) THEN | |
14710 | IF ((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN | |
14711 | DO 130 K1=1,ISH | |
14712 | IF (ISJOIN(K1).EQ.0) GOTO 130 | |
14713 | I = ISJOIN(K1) | |
14714 | IF ((IPAMDL(102).EQ.1).AND.(IHIST(1,I).NE.-100)) | |
14715 | & GOTO 130 | |
14716 | IH1 = IHIST(2,I)/10000 | |
14717 | IF (IH1.NE.NPJE) GOTO 130 | |
14718 | IH1 = IHIST(2,I)-IH1*10000 | |
14719 | DO 135 K2=K1+1,ISH | |
14720 | IF (ISJOIN(K2).EQ.0) GOTO 135 | |
14721 | II = ISJOIN(K2) | |
14722 | IH2 = IHIST(2,II)/10000 | |
14723 | IF (IH2.NE.NPJE) GOTO 135 | |
14724 | IH2 = IHIST(2,II)-IH2*10000 | |
14725 | IF (IHIST(1,I).EQ.IHIST(1,II)) THEN | |
14726 | PT1 = SQRT(PHKK(1,II)**2+PHKK(2,II)**2) | |
14727 | PT2 = SQRT(PHKK(1, I)**2+PHKK(2, I)**2) | |
14728 | RQLUN = MIN(PT1,PT2) | |
14729 | CALL PYSHOW(IH1,IH2,RQLUN) | |
14730 | ||
14731 | ISJOIN(K1) = 0 | |
14732 | ISJOIN(K2) = 0 | |
14733 | GOTO 130 | |
14734 | ENDIF | |
14735 | 135 CONTINUE | |
14736 | 130 CONTINUE | |
14737 | ENDIF | |
14738 | ENDIF | |
14739 | 136 CONTINUE | |
14740 | ||
14741 | CALL DT_INITJS(MODE) | |
14742 | * hadronization | |
14743 | ||
14744 | CALL PYEXEC | |
14745 | ||
14746 | IF (MSTU(24).NE.0) THEN | |
14747 | WRITE(LOUT,*) ' JETSET-reject at event', | |
14748 | & NEVHKK,MSTU(24),KMODE | |
14749 | C CALL DT_EVTOUT(4) | |
14750 | ||
14751 | C CALL PYLIST(2) | |
14752 | ||
14753 | GOTO 9999 | |
14754 | ENDIF | |
14755 | ||
14756 | * number of entries in LUJETS | |
14757 | ||
14758 | NLINES = PYK(0,1) | |
14759 | ||
14760 | NPYMEM = NLINES | |
14761 | ||
14762 | DO 12 I=1,NLINES | |
14763 | IFLG(I) = 0 | |
14764 | 12 CONTINUE | |
14765 | ||
14766 | DO 13 II=1,NLINES | |
14767 | ||
14768 | IF ((PYK(II,7).EQ.1).AND.(IFLG(II).NE.1)) THEN | |
14769 | ||
14770 | * pick up mother resonance if possible and put it together with | |
14771 | * their decay-products into the common | |
14772 | IDXMOR = K(II,3) | |
14773 | IF ((IDXMOR.GE.1).AND.(IDXMOR.LE.MAXLND)) THEN | |
14774 | KFMOR = K(IDXMOR,2) | |
14775 | ISMOR = K(IDXMOR,1) | |
14776 | ELSE | |
14777 | KFMOR = 91 | |
14778 | ISMOR = 1 | |
14779 | ENDIF | |
14780 | IF ((KFMOR.NE.91).AND.(KFMOR.NE.92).AND. | |
14781 | & (KFMOR.NE.94).AND.(ISMOR.EQ.11)) THEN | |
14782 | ID = K(IDXMOR,2) | |
14783 | MO = IHISMO(PYK(IDXMOR,15)) | |
14784 | PX = PYP(IDXMOR,1) | |
14785 | PY = PYP(IDXMOR,2) | |
14786 | PZ = PYP(IDXMOR,3) | |
14787 | PE = PYP(IDXMOR,4) | |
14788 | CALL DT_EVTPUT(2,ID,MO,0,PX,PY,PZ,PE,0,0,0) | |
14789 | IFLG(IDXMOR) = 1 | |
14790 | MO = NHKK | |
14791 | DO 15 JDAUG=K(IDXMOR,4),K(IDXMOR,5) | |
14792 | IF (PYK(JDAUG,7).EQ.1) THEN | |
14793 | ID = PYK(JDAUG,8) | |
14794 | PX = PYP(JDAUG,1) | |
14795 | PY = PYP(JDAUG,2) | |
14796 | PZ = PYP(JDAUG,3) | |
14797 | PE = PYP(JDAUG,4) | |
14798 | CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0) | |
14799 | IF (LEMCCK) THEN | |
14800 | PX = -PYP(JDAUG,1) | |
14801 | PY = -PYP(JDAUG,2) | |
14802 | PZ = -PYP(JDAUG,3) | |
14803 | PE = -PYP(JDAUG,4) | |
14804 | CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM) | |
14805 | ENDIF | |
14806 | IFLG(JDAUG) = 1 | |
14807 | ENDIF | |
14808 | 15 CONTINUE | |
14809 | ELSE | |
14810 | * there was no mother resonance | |
14811 | MO = IHISMO(PYK(II,15)) | |
14812 | ID = PYK(II,8) | |
14813 | PX = PYP(II,1) | |
14814 | PY = PYP(II,2) | |
14815 | PZ = PYP(II,3) | |
14816 | PE = PYP(II,4) | |
14817 | CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0) | |
14818 | IF (LEMCCK) THEN | |
14819 | PX = -PYP(II,1) | |
14820 | PY = -PYP(II,2) | |
14821 | PZ = -PYP(II,3) | |
14822 | PE = -PYP(II,4) | |
14823 | CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM) | |
14824 | ENDIF | |
14825 | ENDIF | |
14826 | ENDIF | |
14827 | 13 CONTINUE | |
14828 | IF (LEMCCK) THEN | |
14829 | CHKLEV = TINY1 | |
14830 | CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,6,IREJ1) | |
14831 | C IF (IREJ1.NE.0) CALL DT_EVTOUT(4) | |
14832 | ENDIF | |
14833 | ||
14834 | * global energy-momentum & flavor conservation check | |
14835 | **sr 16.5. this check is skipped in case of phojet-treatment | |
14836 | IF (MCGENE.EQ.1) | |
14837 | & CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,12,IREJ3) | |
14838 | ||
14839 | * update statistics-counter for diffraction | |
14840 | c IF (IFLAGD.NE.0) THEN | |
14841 | c ICDIFF(1) = ICDIFF(1)+1 | |
14842 | c IF (IFLAGD.EQ. 1) ICDIFF(2) = ICDIFF(2)+1 | |
14843 | c IF (IFLAGD.EQ. 2) ICDIFF(3) = ICDIFF(3)+1 | |
14844 | c IF (IFLAGD.EQ.-1) ICDIFF(4) = ICDIFF(4)+1 | |
14845 | c IF (IFLAGD.EQ.-2) ICDIFF(5) = ICDIFF(5)+1 | |
14846 | c ENDIF | |
14847 | ||
14848 | ENDIF | |
14849 | ||
14850 | RETURN | |
14851 | ||
14852 | 9999 CONTINUE | |
14853 | IREJ = 1 | |
14854 | RETURN | |
14855 | END | |
14856 | ||
14857 | *$ CREATE DT_DECAYS.FOR | |
14858 | *COPY DT_DECAYS | |
14859 | * | |
14860 | *===decay==============================================================* | |
14861 | * | |
14862 | SUBROUTINE DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ) | |
14863 | ||
14864 | ************************************************************************ | |
14865 | * Resonance-decay. * | |
14866 | * This subroutine replaces DDECAY/DECHKK. * | |
14867 | * PIN(4) 4-momentum of resonance (input) * | |
14868 | * IDXIN BAMJET-index of resonance (input) * | |
14869 | * POUT(20,4) 4-momenta of decay-products (output) * | |
14870 | * IDXOUT(20) BAMJET-indices of decay-products (output) * | |
14871 | * NSEC number of secondaries (output) * | |
14872 | * Adopted from the original version DECHKK. * | |
14873 | * This version dated 09.01.95 is written by S. Roesler * | |
14874 | ************************************************************************ | |
14875 | ||
14876 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
14877 | SAVE | |
14878 | PARAMETER ( LINP = 10 , | |
14879 | & LOUT = 6 , | |
14880 | & LDAT = 9 ) | |
14881 | PARAMETER (TINY17=1.0D-17) | |
14882 | ||
14883 | * HADRIN: decay channel information | |
14884 | PARAMETER (IDMAX9=602) | |
14885 | CHARACTER*8 ZKNAME | |
14886 | COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3) | |
14887 | * particle properties (BAMJET index convention) | |
14888 | CHARACTER*8 ANAME | |
14889 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
14890 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
14891 | * flags for input different options | |
14892 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
14893 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
14894 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
14895 | ||
14896 | DIMENSION PIN(4),PI(20,4),POUT(20,4),IDXOUT(20), | |
14897 | & EF(3),PF(3),PFF(3),IDXSTK(20),IDX(3), | |
14898 | & CODF(3),COFF(3),SIFF(3),DCOS(3),DCOSF(3) | |
14899 | ||
14900 | * ISTAB = 1 strong and weak decays | |
14901 | * = 2 strong decays only | |
14902 | * = 3 strong decays, weak decays for charmed particles and tau | |
14903 | * leptons only | |
14904 | DATA ISTAB /2/ | |
14905 | ||
14906 | IREJ = 0 | |
14907 | NSEC = 0 | |
14908 | * put initial resonance to stack | |
14909 | NSTK = 1 | |
14910 | IDXSTK(NSTK) = IDXIN | |
14911 | DO 5 I=1,4 | |
14912 | PI(NSTK,I) = PIN(I) | |
14913 | 5 CONTINUE | |
14914 | ||
14915 | * store initial configuration for energy-momentum cons. check | |
14916 | IF (LEMCCK) CALL DT_EVTEMC(PI(NSTK,1),PI(NSTK,2),PI(NSTK,3), | |
14917 | & PI(NSTK,4),1,IDUM,IDUM) | |
14918 | ||
14919 | 100 CONTINUE | |
14920 | * get particle from stack | |
14921 | IDXI = IDXSTK(NSTK) | |
14922 | * skip stable particles | |
14923 | IF (ISTAB.EQ.1) THEN | |
14924 | IF ((IDXI.EQ.135).OR. (IDXI.EQ.136)) GOTO 10 | |
14925 | IF ((IDXI.GE. 1).AND.(IDXI.LE. 7)) GOTO 10 | |
14926 | ELSEIF (ISTAB.EQ.2) THEN | |
14927 | IF ((IDXI.GE. 1).AND.(IDXI.LE. 30)) GOTO 10 | |
14928 | IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10 | |
14929 | IF ((IDXI.GE.115).AND.(IDXI.LE.122)) GOTO 10 | |
14930 | IF ((IDXI.GE.131).AND.(IDXI.LE.136)) GOTO 10 | |
14931 | IF ( IDXI.EQ.109) GOTO 10 | |
14932 | IF ((IDXI.GE.137).AND.(IDXI.LE.160)) GOTO 10 | |
14933 | ELSEIF (ISTAB.EQ.3) THEN | |
14934 | IF ((IDXI.GE. 1).AND.(IDXI.LE. 23)) GOTO 10 | |
14935 | IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10 | |
14936 | IF ((IDXI.GE.109).AND.(IDXI.LE.115)) GOTO 10 | |
14937 | IF ((IDXI.GE.133).AND.(IDXI.LE.136)) GOTO 10 | |
14938 | ENDIF | |
14939 | ||
14940 | * calculate direction cosines and Lorentz-parameter of decaying part. | |
14941 | PTOT = SQRT(PI(NSTK,1)**2+PI(NSTK,2)**2+PI(NSTK,3)**2) | |
14942 | PTOT = MAX(PTOT,TINY17) | |
14943 | DO 1 I=1,3 | |
14944 | DCOS(I) = PI(NSTK,I)/PTOT | |
14945 | 1 CONTINUE | |
14946 | GAM = PI(NSTK,4)/AAM(IDXI) | |
14947 | BGAM = PTOT/AAM(IDXI) | |
14948 | ||
14949 | * get decay-channel | |
14950 | KCHAN = K1(IDXI)-1 | |
14951 | 2 CONTINUE | |
14952 | KCHAN = KCHAN+1 | |
14953 | IF ((DT_RNDM(GAM)-TINY17).GT.WT(KCHAN)) GOTO 2 | |
14954 | ||
14955 | * identities of secondaries | |
14956 | IDX(1) = NZK(KCHAN,1) | |
14957 | IDX(2) = NZK(KCHAN,2) | |
14958 | IF (IDX(2).LT.1) GOTO 9999 | |
14959 | IDX(3) = NZK(KCHAN,3) | |
14960 | ||
14961 | * handle decay in rest system of decaying particle | |
14962 | IF (IDX(3).EQ.0) THEN | |
14963 | * two-particle decay | |
14964 | NDEC = 2 | |
14965 | CALL DT_DTWOPD(AAM(IDXI),EF(1),EF(2),PF(1),PF(2), | |
14966 | & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2), | |
14967 | & AAM(IDX(1)),AAM(IDX(2))) | |
14968 | ELSE | |
14969 | * three-particle decay | |
14970 | NDEC = 3 | |
14971 | CALL DT_DTHREP(AAM(IDXI),EF(1),EF(2),EF(3),PF(1),PF(2),PF(3), | |
14972 | & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2), | |
14973 | & CODF(3),COFF(3),SIFF(3), | |
14974 | & AAM(IDX(1)),AAM(IDX(2)),AAM(IDX(3))) | |
14975 | ENDIF | |
14976 | NSTK = NSTK-1 | |
14977 | ||
14978 | * transform decay products back | |
14979 | DO 3 I=1,NDEC | |
14980 | NSTK = NSTK+1 | |
14981 | CALL DT_DTRAFO(GAM,BGAM,DCOS(1),DCOS(2),DCOS(3), | |
14982 | & CODF(I),COFF(I),SIFF(I),PF(I),EF(I), | |
14983 | & PFF(I),DCOSF(1),DCOSF(2),DCOSF(3),PI(NSTK,4)) | |
14984 | * add particle to stack | |
14985 | IDXSTK(NSTK) = IDX(I) | |
14986 | DO 4 J=1,3 | |
14987 | PI(NSTK,J) = DCOSF(J)*PFF(I) | |
14988 | 4 CONTINUE | |
14989 | 3 CONTINUE | |
14990 | GOTO 100 | |
14991 | ||
14992 | 10 CONTINUE | |
14993 | * stable particle, put to output-arrays | |
14994 | NSEC = NSEC+1 | |
14995 | DO 6 I=1,4 | |
14996 | POUT(NSEC,I) = PI(NSTK,I) | |
14997 | 6 CONTINUE | |
14998 | IDXOUT(NSEC) = IDXSTK(NSTK) | |
14999 | * store secondaries for energy-momentum conservation check | |
15000 | IF (LEMCCK) | |
15001 | &CALL DT_EVTEMC(-POUT(NSEC,1),-POUT(NSEC,2),-POUT(NSEC,3), | |
15002 | & -POUT(NSEC,4),2,IDUM,IDUM) | |
15003 | NSTK = NSTK-1 | |
15004 | IF (NSTK.GT.0) GOTO 100 | |
15005 | ||
15006 | * check energy-momentum conservation | |
15007 | IF (LEMCCK) THEN | |
15008 | CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,5,IREJ1) | |
15009 | IF (IREJ1.NE.0) GOTO 9999 | |
15010 | ENDIF | |
15011 | ||
15012 | RETURN | |
15013 | ||
15014 | 9999 CONTINUE | |
15015 | IREJ = 1 | |
15016 | RETURN | |
15017 | END | |
15018 | ||
15019 | *$ CREATE DT_DECAY1.FOR | |
15020 | *COPY DT_DECAY1 | |
15021 | * | |
15022 | *===decay1=============================================================* | |
15023 | * | |
15024 | SUBROUTINE DT_DECAY1 | |
15025 | ||
15026 | ************************************************************************ | |
15027 | * Decay of resonances stored in DTEVT1. * | |
15028 | * This version dated 20.01.95 is written by S. Roesler * | |
15029 | ************************************************************************ | |
15030 | ||
15031 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
15032 | SAVE | |
15033 | PARAMETER ( LINP = 10 , | |
15034 | & LOUT = 6 , | |
15035 | & LDAT = 9 ) | |
15036 | ||
15037 | * event history | |
15038 | PARAMETER (NMXHKK=200000) | |
15039 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
15040 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
15041 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
15042 | * extended event history | |
15043 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
15044 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
15045 | & IHIST(2,NMXHKK) | |
15046 | ||
15047 | DIMENSION PIN(4),POUT(20,4),IDXOUT(20) | |
15048 | ||
15049 | NEND = NHKK | |
15050 | C DO 1 I=NPOINT(5),NEND | |
15051 | DO 1 I=NPOINT(4),NEND | |
15052 | IF (ABS(ISTHKK(I)).EQ.1) THEN | |
15053 | DO 2 K=1,4 | |
15054 | PIN(K) = PHKK(K,I) | |
15055 | 2 CONTINUE | |
15056 | IDXIN = IDBAM(I) | |
15057 | CALL DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ) | |
15058 | IF (NSEC.GT.1) THEN | |
15059 | DO 3 N=1,NSEC | |
15060 | IDHAD = IDT_IPDGHA(IDXOUT(N)) | |
15061 | CALL DT_EVTPUT(1,IDHAD,I,0,POUT(N,1),POUT(N,2), | |
15062 | & POUT(N,3),POUT(N,4),0,0,0) | |
15063 | 3 CONTINUE | |
15064 | ENDIF | |
15065 | ENDIF | |
15066 | 1 CONTINUE | |
15067 | ||
15068 | RETURN | |
15069 | END | |
15070 | ||
15071 | *$ CREATE DT_DECPI0.FOR | |
15072 | *COPY DT_DECPI0 | |
15073 | * | |
15074 | *===decpi0=============================================================* | |
15075 | * | |
15076 | SUBROUTINE DT_DECPI0 | |
15077 | ||
15078 | ************************************************************************ | |
15079 | * Decay of pi0 handled with JETSET. * | |
15080 | * This version dated 18.02.96 is written by S. Roesler * | |
15081 | ************************************************************************ | |
15082 | ||
15083 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
15084 | SAVE | |
15085 | PARAMETER ( LINP = 10 , | |
15086 | & LOUT = 6 , | |
15087 | & LDAT = 9 ) | |
15088 | PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0,ZERO=0.0D0) | |
15089 | ||
15090 | * event history | |
15091 | PARAMETER (NMXHKK=200000) | |
15092 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
15093 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
15094 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
15095 | * extended event history | |
15096 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
15097 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
15098 | & IHIST(2,NMXHKK) | |
15099 | COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5) | |
15100 | COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) | |
15101 | PARAMETER (MAXLND=4000) | |
15102 | COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5) | |
15103 | * flags for input different options | |
15104 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
15105 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
15106 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
15107 | ||
15108 | INTEGER PYCOMP,PYK | |
15109 | ||
15110 | DIMENSION IHISMO(NMXHKK),P1(4) | |
15111 | ||
15112 | TWOPI = 2.0D0*ATAN2(0.0D0,-1.0D0) | |
15113 | ||
15114 | CALL DT_INITJS(2) | |
15115 | * allow pi0 decay | |
15116 | KC = PYCOMP(111) | |
15117 | MDCY(KC,1) = 1 | |
15118 | ||
15119 | NN = 0 | |
15120 | INI = 0 | |
15121 | DO 1 I=1,NHKK | |
15122 | IF ((ISTHKK(I).EQ.1).AND.(IDHKK(I).EQ.111)) THEN | |
15123 | IF (INI.EQ.0) THEN | |
15124 | INI = 1 | |
15125 | ELSE | |
15126 | INI = 2 | |
15127 | ENDIF | |
15128 | IF (LEMCCK) CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I), | |
15129 | & PHKK(4,I),INI,IDUM,IDUM) | |
15130 | PT = SQRT(PHKK(1,I)**2+PHKK(2,I)**2) | |
15131 | PTOT = SQRT(PT**2+PHKK(3,I)**2) | |
15132 | COSTH = PHKK(3,I)/(PTOT+TINY10) | |
15133 | IF (COSTH.GT.ONE) THEN | |
15134 | THETA = ZERO | |
15135 | ELSEIF (COSTH.LT.-ONE) THEN | |
15136 | THETA = TWOPI/2.0D0 | |
15137 | ELSE | |
15138 | THETA = ACOS(COSTH) | |
15139 | ENDIF | |
15140 | PHI = ASIN(PHKK(2,I)/(PT +TINY10)) | |
15141 | IF (PHKK(1,I).LT.0.0D0) | |
15142 | & PHI = SIGN(TWOPI/2.0D0-ABS(PHI),PHI) | |
15143 | ENER = PHKK(4,I) | |
15144 | NN = NN+1 | |
15145 | KTEMP = MSTU(10) | |
15146 | MSTU(10)= 1 | |
15147 | P(NN,5) = PHKK(5,I) | |
15148 | CALL PY1ENT(NN,111,ENER,THETA,PHI) | |
15149 | MSTU(10) = KTEMP | |
15150 | IHISMO(NN)= I | |
15151 | ENDIF | |
15152 | 1 CONTINUE | |
15153 | IF (NN.GT.0) THEN | |
15154 | CALL PYEXEC | |
15155 | NLINES = PYK(0,1) | |
15156 | DO 2 II=1,NLINES | |
15157 | IF (PYK(II,7).EQ.1) THEN | |
15158 | DO 3 KK=1,4 | |
15159 | P1(KK) = PYP(II,KK) | |
15160 | 3 CONTINUE | |
15161 | ID = PYK(II,8) | |
15162 | MO = IHISMO(PYK(II,15)) | |
15163 | CALL DT_EVTPUT(1,ID,MO,0,P1(1),P1(2),P1(3),P1(4),0,0,0) | |
15164 | IF (LEMCCK) | |
15165 | & CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2, | |
15166 | & IDUM,IDUM) | |
15167 | *sr: flag with neg. sign (for HELIOS p/A-W jobs) | |
15168 | ISTHKK(MO) = -2 | |
15169 | ENDIF | |
15170 | 2 CONTINUE | |
15171 | IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,7000,IREJ1) | |
15172 | ENDIF | |
15173 | MDCY(KC,1) = 0 | |
15174 | ||
15175 | RETURN | |
15176 | END | |
15177 | ||
15178 | *$ CREATE DT_DTWOPD.FOR | |
15179 | *COPY DT_DTWOPD | |
15180 | * | |
15181 | *===dtwopd=============================================================* | |
15182 | * | |
15183 | SUBROUTINE DT_DTWOPD(UMO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,COD2, | |
15184 | & COF2,SIF2,AM1,AM2) | |
15185 | ||
15186 | ************************************************************************ | |
15187 | * Two-particle decay. * | |
15188 | * UMO cm-energy of the decaying system (input) * | |
15189 | * AM1/AM2 masses of the decay products (input) * | |
15190 | * ECM1,ECM2/PCM1,PCM2 cm-energies/momenta of the decay prod. (output) * | |
15191 | * COD,COF,SIF direction cosines of the decay prod. (output) * | |
15192 | * Revised by S. Roesler, 20.11.95 * | |
15193 | ************************************************************************ | |
15194 | ||
15195 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
15196 | SAVE | |
15197 | PARAMETER ( LINP = 10 , | |
15198 | & LOUT = 6 , | |
15199 | & LDAT = 9 ) | |
15200 | PARAMETER (TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,ZERO=0.0D0) | |
15201 | ||
15202 | IF (UMO.LT.(AM1+AM2)) THEN | |
15203 | WRITE(LOUT,1000) UMO,AM1,AM2 | |
15204 | 1000 FORMAT(1X,'DTWOPD: inconsistent kinematics - UMO,AM1,AM2 ', | |
15205 | & 3E12.3) | |
15206 | STOP | |
15207 | ENDIF | |
15208 | ||
15209 | ECM1 = ((UMO-AM2)*(UMO+AM2)+AM1*AM1)/(TWO*UMO) | |
15210 | ECM2 = UMO-ECM1 | |
15211 | PCM1 = SQRT((ECM1-AM1)*(ECM1+AM1)) | |
15212 | PCM2 = PCM1 | |
15213 | CALL DT_DSFECF(SIF1,COF1) | |
15214 | COD1 = TWO*DT_RNDM(PCM2)-ONE | |
15215 | COD2 = -COD1 | |
15216 | COF2 = -COF1 | |
15217 | SIF2 = -SIF1 | |
15218 | ||
15219 | RETURN | |
15220 | END | |
15221 | ||
15222 | *$ CREATE DT_DTHREP.FOR | |
15223 | *COPY DT_DTHREP | |
15224 | * | |
15225 | *===dthrep=============================================================* | |
15226 | * | |
15227 | SUBROUTINE DT_DTHREP(UMO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1, | |
15228 | & SIF1,COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3) | |
15229 | ||
15230 | ************************************************************************ | |
15231 | * Three-particle decay. * | |
15232 | * UMO cm-energy of the decaying system (input) * | |
15233 | * AM1/2/3 masses of the decay products (input) * | |
15234 | * ECM1/2/2,PCM1/2/3 cm-energies/momenta of the decay prod. (output) * | |
15235 | * COD,COF,SIF direction cosines of the decay prod. (output) * | |
15236 | * * | |
15237 | * Threpd89: slight revision by A. Ferrari * | |
15238 | * Last change on 11-oct-93 by Alfredo Ferrari, INFN - Milan * | |
15239 | * Revised by S. Roesler, 20.11.95 * | |
15240 | ************************************************************************ | |
15241 | ||
15242 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
15243 | SAVE | |
15244 | PARAMETER ( LINP = 10 , | |
15245 | & LOUT = 6 , | |
15246 | & LDAT = 9 ) | |
15247 | ||
15248 | PARAMETER ( ANGLSQ = 2.5D-31 ) | |
15249 | PARAMETER ( AZRZRZ = 1.0D-30 ) | |
15250 | PARAMETER ( ONEMNS = 0.999999999999999 D+00 ) | |
15251 | PARAMETER ( ONEPLS = 1.000000000000001 D+00 ) | |
15252 | PARAMETER ( ONEONE = 1.D+00 ) | |
15253 | PARAMETER ( TWOTWO = 2.D+00 ) | |
15254 | PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 ) | |
15255 | ||
15256 | COMMON /HNGAMR/ REDU,AMO,AMM(15) | |
15257 | * flags for input different options | |
15258 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
15259 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
15260 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
15261 | ||
15262 | DIMENSION F(5),XX(5) | |
15263 | DATA EPS /AZRZRZ/ | |
15264 | ||
15265 | UMOO=UMO+UMO | |
15266 | C***S1, S2, S3 ARE THE INVARIANT MASSES OF THE PARTICLES 1, 2, 3 | |
15267 | C***J. VON NEUMANN - RANDOM - SELECTION OF S2 | |
15268 | C***CALCULATION OF THE MAXIMUM OF THE S2 - DISTRIBUTION | |
15269 | UUMO=UMO | |
15270 | AAM1=AM1 | |
15271 | AAM2=AM2 | |
15272 | AAM3=AM3 | |
15273 | GU=(AM2+AM3)**2 | |
15274 | GO=(UMO-AM1)**2 | |
15275 | * UFAK=1.0000000000001D0 | |
15276 | * IF (GU.GT.GO) UFAK=0.9999999999999D0 | |
15277 | IF (GU.GT.GO) THEN | |
15278 | UFAK=ONEMNS | |
15279 | ELSE | |
15280 | UFAK=ONEPLS | |
15281 | END IF | |
15282 | OFAK=2.D0-UFAK | |
15283 | GU=GU*UFAK | |
15284 | GO=GO*OFAK | |
15285 | DS2=(GO-GU)/99.D0 | |
15286 | AM11=AM1*AM1 | |
15287 | AM22=AM2*AM2 | |
15288 | AM33=AM3*AM3 | |
15289 | UMO2=UMO*UMO | |
15290 | RHO2=0.D0 | |
15291 | S22=GU | |
15292 | DO 124 I=1,100 | |
15293 | S21=S22 | |
15294 | S22=GU+(I-1.D0)*DS2 | |
15295 | RHO1=RHO2 | |
15296 | RHO2=DT_YLAMB(S22,UMO2,AM11)*DT_YLAMB(S22,AM22,AM33)/ | |
15297 | * (S22+EPS) | |
15298 | IF(RHO2.LT.RHO1) GO TO 125 | |
15299 | 124 CONTINUE | |
15300 | 125 S2SUP=(S22-S21)*.5D0+S21 | |
15301 | SUPRHO=DT_YLAMB(S2SUP,UMO2,AM11)*DT_YLAMB(S2SUP,AM22,AM33)/ | |
15302 | * (S2SUP+EPS) | |
15303 | SUPRHO=SUPRHO*1.05D0 | |
15304 | XO=S21-DS2 | |
15305 | IF (GU.LT.GO.AND.XO.LT.GU) XO=GU | |
15306 | IF (GU.GT.GO.AND.XO.GT.GU) XO=GU | |
15307 | XX(1)=XO | |
15308 | XX(3)=S22 | |
15309 | X1=(XO+S22)*0.5D0 | |
15310 | XX(2)=X1 | |
15311 | F(3)=RHO2 | |
15312 | F(1)=DT_YLAMB(XO,UMO2,AM11)*DT_YLAMB(XO,AM22,AM33)/(XO+EPS) | |
15313 | F(2)=DT_YLAMB(X1,UMO2,AM11)*DT_YLAMB(X1,AM22,AM33)/(X1+EPS) | |
15314 | DO 126 I=1,16 | |
15315 | X4=(XX(1)+XX(2))*0.5D0 | |
15316 | X5=(XX(2)+XX(3))*0.5D0 | |
15317 | F(4)=DT_YLAMB(X4,UMO2,AM11)*DT_YLAMB(X4,AM22,AM33)/ | |
15318 | * (X4+EPS) | |
15319 | F(5)=DT_YLAMB(X5,UMO2,AM11)*DT_YLAMB(X5,AM22,AM33)/ | |
15320 | * (X5+EPS) | |
15321 | XX(4)=X4 | |
15322 | XX(5)=X5 | |
15323 | DO 128 II=1,5 | |
15324 | IA=II | |
15325 | DO 128 III=IA,5 | |
15326 | IF (F (II).GE.F (III)) GO TO 128 | |
15327 | FH=F(II) | |
15328 | F(II)=F(III) | |
15329 | F(III)=FH | |
15330 | FH=XX(II) | |
15331 | XX(II)=XX(III) | |
15332 | XX(III)=FH | |
15333 | 128 CONTINUE | |
15334 | SUPRHO=F(1) | |
15335 | S2SUP=XX(1) | |
15336 | DO 129 II=1,3 | |
15337 | IA=II | |
15338 | DO 129 III=IA,3 | |
15339 | IF (XX(II).GE.XX(III)) GO TO 129 | |
15340 | FH=F(II) | |
15341 | F(II)=F(III) | |
15342 | F(III)=FH | |
15343 | FH=XX(II) | |
15344 | XX(II)=XX(III) | |
15345 | XX(III)=FH | |
15346 | 129 CONTINUE | |
15347 | 126 CONTINUE | |
15348 | AM23=(AM2+AM3)**2 | |
15349 | ITH=0 | |
15350 | REDU=2.D0 | |
15351 | 1 CONTINUE | |
15352 | ITH=ITH+1 | |
15353 | IF (ITH.GT.200) REDU=-9.D0 | |
15354 | IF (ITH.GT.200) GO TO 400 | |
15355 | C=DT_RNDM(REDU) | |
15356 | * S2=AM23+C*((UMO-AM1)**2-AM23) | |
15357 | S2=AM23+C*(UMO-AM1-AM2-AM3)*(UMO-AM1+AM2+AM3) | |
15358 | Y=DT_RNDM(S2) | |
15359 | Y=Y*SUPRHO | |
15360 | RHO=DT_YLAMB(S2,UMO2,AM11)*DT_YLAMB(S2,AM22,AM33)/S2 | |
15361 | IF(Y.GT.RHO) GO TO 1 | |
15362 | C***RANDOM SELECTION OF S3 AND CALCULATION OF S1 | |
15363 | S1=DT_RNDM(S2) | |
15364 | S1=S1*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)/(2.D0*S2)- | |
15365 | &RHO*.5D0 | |
15366 | S3=UMO2+AM11+AM22+AM33-S1-S2 | |
15367 | ECM1=(UMO2+AM11-S2)/UMOO | |
15368 | ECM2=(UMO2+AM22-S3)/UMOO | |
15369 | ECM3=(UMO2+AM33-S1)/UMOO | |
15370 | PCM1=SQRT((ECM1+AM1)*(ECM1-AM1)) | |
15371 | PCM2=SQRT((ECM2+AM2)*(ECM2-AM2)) | |
15372 | PCM3=SQRT((ECM3+AM3)*(ECM3-AM3)) | |
15373 | CALL DT_DSFECF(SFE,CFE) | |
15374 | C***TH IS THE ANGLE BETWEEN PARTICLES 1 AND 2 | |
15375 | C***TH1, TH2 ARE THE ANGLES BETWEEN PARTICLES 1, 2 AND THE DIRECTION OF | |
15376 | PCM12 = PCM1 * PCM2 | |
15377 | IF ( PCM12 .LT. ANGLSQ ) GO TO 200 | |
15378 | COSTH=(ECM1*ECM2+0.5D+00*(AM11+AM22-S1))/PCM12 | |
15379 | GO TO 300 | |
15380 | 200 CONTINUE | |
15381 | UW=DT_RNDM(S1) | |
15382 | COSTH=(UW-0.5D+00)*2.D+00 | |
15383 | 300 CONTINUE | |
15384 | * IF(ABS(COSTH).GT.0.9999999999999999D0) | |
15385 | * &COSTH=SIGN(0.9999999999999999D0,COSTH) | |
15386 | IF(ABS(COSTH).GT.ONEONE) | |
15387 | &COSTH=SIGN(ONEONE,COSTH) | |
15388 | IF (REDU.LT.1.D+00) RETURN | |
15389 | COSTH2=(PCM3*PCM3+PCM2*PCM2-PCM1*PCM1)/(2.D+00*PCM2*PCM3) | |
15390 | * IF(ABS(COSTH2).GT.0.9999999999999999D0) | |
15391 | * &COSTH2=SIGN(0.9999999999999999D0,COSTH2) | |
15392 | IF(ABS(COSTH2).GT.ONEONE) | |
15393 | &COSTH2=SIGN(ONEONE,COSTH2) | |
15394 | SINTH2=SQRT((ONEONE-COSTH2)*(ONEONE+COSTH2)) | |
15395 | SINTH =SQRT((ONEONE-COSTH)*(ONEONE+COSTH)) | |
15396 | SINTH1=COSTH2*SINTH-COSTH*SINTH2 | |
15397 | COSTH1=COSTH*COSTH2+SINTH2*SINTH | |
15398 | C***RANDOM SELECTION OF THE SPHERICAL COORDINATES OF THE DIRECTION OF PA | |
15399 | C***CFE, SFE ARE COS AND SIN OF THE ROTATION ANGLE OF THE SYSTEM 1, 2 AR | |
15400 | C***THE DIRECTION OF PARTICLE 3 | |
15401 | C***CALCULATION OF THE SPHERICAL COORDINATES OF PARTICLES 1, 2 | |
15402 | CX11=-COSTH1 | |
15403 | CY11=SINTH1*CFE | |
15404 | CZ11=SINTH1*SFE | |
15405 | CX22=-COSTH2 | |
15406 | CY22=-SINTH2*CFE | |
15407 | CZ22=-SINTH2*SFE | |
15408 | CALL DT_DSFECF(SIF3,COF3) | |
15409 | COD3=TWOTWO*DT_RNDM(CX11)-ONEONE | |
15410 | SID3=SQRT((1.D+00-COD3)*(1.D+00+COD3)) | |
15411 | 2 FORMAT(5F20.15) | |
15412 | COD1=CX11*COD3+CZ11*SID3 | |
15413 | CHLP=(ONEONE-COD1)*(ONEONE+COD1) | |
15414 | IF(CHLP.LT.1.D-14)WRITE(LOUT,2)COD1,COF3,SID3, | |
15415 | &CX11,CZ11 | |
15416 | SID1=SQRT(CHLP) | |
15417 | COF1=(CX11*SID3*COF3-CY11*SIF3-CZ11*COD3*COF3)/SID1 | |
15418 | SIF1=(CX11*SID3*SIF3+CY11*COF3-CZ11*COD3*SIF3)/SID1 | |
15419 | COD2=CX22*COD3+CZ22*SID3 | |
15420 | SID2=SQRT((ONEONE-COD2)*(ONEONE+COD2)) | |
15421 | COF2=(CX22*SID3*COF3-CY22*SIF3-CZ22*COD3*COF3)/SID2 | |
15422 | SIF2=(CX22*SID3*SIF3+CY22*COF3-CZ22*COD3*SIF3)/SID2 | |
15423 | 400 CONTINUE | |
15424 | * === Energy conservation check: === * | |
15425 | EOCHCK = UMO - ECM1 - ECM2 - ECM3 | |
15426 | * SID1 = SQRT ( ( ONEONE - COD1 ) * ( ONEONE + COD1 ) ) | |
15427 | * SID2 = SQRT ( ( ONEONE - COD2 ) * ( ONEONE + COD2 ) ) | |
15428 | * SID3 = SQRT ( ( ONEONE - COD3 ) * ( ONEONE + COD3 ) ) | |
15429 | PZCHCK = PCM1 * COD1 + PCM2 * COD2 + PCM3 * COD3 | |
15430 | PXCHCK = PCM1 * COF1 * SID1 + PCM2 * COF2 * SID2 | |
15431 | & + PCM3 * COF3 * SID3 | |
15432 | PYCHCK = PCM1 * SIF1 * SID1 + PCM2 * SIF2 * SID2 | |
15433 | & + PCM3 * SIF3 * SID3 | |
15434 | EOCMPR = 1.D-12 * UMO | |
15435 | IF ( ABS (EOCHCK) + ABS (PXCHCK) + ABS (PYCHCK) + ABS (PZCHCK) | |
15436 | & .GT. EOCMPR ) THEN | |
15437 | **sr 5.5.95 output-unit changed | |
15438 | IF (IOULEV(1).GT.0) THEN | |
15439 | WRITE(LOUT,*) | |
15440 | & ' *** Threpd: energy/momentum conservation failure! ***', | |
15441 | & EOCHCK,PXCHCK,PYCHCK,PZCHCK | |
15442 | WRITE(LOUT,*)' *** SID1,SID2,SID3',SID1,SID2,SID3 | |
15443 | ENDIF | |
15444 | ** | |
15445 | END IF | |
15446 | RETURN | |
15447 | END | |
15448 | ||
15449 | *$ CREATE DT_DBKLAS.FOR | |
15450 | *COPY DT_DBKLAS | |
15451 | * | |
15452 | *===dbklas=============================================================* | |
15453 | * | |
15454 | SUBROUTINE DT_DBKLAS(I,J,K,I8,I10) | |
15455 | ||
15456 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
15457 | SAVE | |
15458 | PARAMETER ( LINP = 10 , | |
15459 | & LOUT = 6 , | |
15460 | & LDAT = 9 ) | |
15461 | ||
15462 | * quark-content to particle index conversion (DTUNUC 1.x) | |
15463 | COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21), | |
15464 | & IA08(6,21),IA10(6,21) | |
15465 | ||
15466 | IF (I) 20,20,10 | |
15467 | * baryons | |
15468 | 10 CONTINUE | |
15469 | CALL DT_INDEXD(J,K,IND) | |
15470 | I8 = IB08(I,IND) | |
15471 | I10 = IB10(I,IND) | |
15472 | IF (I8.LE.0) I8 = I10 | |
15473 | RETURN | |
15474 | * antibaryons | |
15475 | 20 CONTINUE | |
15476 | II = IABS(I) | |
15477 | JJ = IABS(J) | |
15478 | KK = IABS(K) | |
15479 | CALL DT_INDEXD(JJ,KK,IND) | |
15480 | I8 = IA08(II,IND) | |
15481 | I10 = IA10(II,IND) | |
15482 | IF (I8.LE.0) I8 = I10 | |
15483 | ||
15484 | RETURN | |
15485 | END | |
15486 | ||
15487 | *$ CREATE DT_INDEXD.FOR | |
15488 | *COPY DT_INDEXD | |
15489 | * | |
15490 | *===indexd=============================================================* | |
15491 | * | |
15492 | SUBROUTINE DT_INDEXD(KA,KB,IND) | |
15493 | ||
15494 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
15495 | SAVE | |
15496 | PARAMETER ( LINP = 10 , | |
15497 | & LOUT = 6 , | |
15498 | & LDAT = 9 ) | |
15499 | ||
15500 | KP = KA*KB | |
15501 | KS = KA+KB | |
15502 | IF (KP.EQ.1) IND=1 | |
15503 | IF (KP.EQ.2) IND=2 | |
15504 | IF (KP.EQ.3) IND=3 | |
15505 | IF ((KP.EQ.4).AND.(KS.EQ.5)) IND=4 | |
15506 | IF (KP.EQ.5) IND=5 | |
15507 | IF ((KP.EQ.6).AND.(KS.EQ.7)) IND=6 | |
15508 | IF ((KP.EQ.4).AND.(KS.EQ.4)) IND=7 | |
15509 | IF ((KP.EQ.6).AND.(KS.EQ.5)) IND=8 | |
15510 | IF (KP.EQ.8) IND=9 | |
15511 | IF (KP.EQ.10) IND=10 | |
15512 | IF ((KP.EQ.12).AND.(KS.EQ.8)) IND=11 | |
15513 | IF (KP.EQ.9) IND=12 | |
15514 | IF ((KP.EQ.12).AND.(KS.EQ.7)) IND=13 | |
15515 | IF (KP.EQ.15) IND=14 | |
15516 | IF (KP.EQ.18) IND=15 | |
15517 | IF (KP.EQ.16) IND=16 | |
15518 | IF (KP.EQ.20) IND=17 | |
15519 | IF (KP.EQ.24) IND=18 | |
15520 | IF (KP.EQ.25) IND=19 | |
15521 | IF (KP.EQ.30) IND=20 | |
15522 | IF (KP.EQ.36) IND=21 | |
15523 | ||
15524 | RETURN | |
15525 | END | |
15526 | ||
15527 | *$ CREATE DT_DCHANT.FOR | |
15528 | *COPY DT_DCHANT | |
15529 | * | |
15530 | *===dchant=============================================================* | |
15531 | * | |
15532 | SUBROUTINE DT_DCHANT | |
15533 | ||
15534 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
15535 | SAVE | |
15536 | PARAMETER ( LINP = 10 , | |
15537 | & LOUT = 6 , | |
15538 | & LDAT = 9 ) | |
15539 | PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0) | |
15540 | ||
15541 | * HADRIN: decay channel information | |
15542 | PARAMETER (IDMAX9=602) | |
15543 | CHARACTER*8 ZKNAME | |
15544 | COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3) | |
15545 | * particle properties (BAMJET index convention) | |
15546 | CHARACTER*8 ANAME | |
15547 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
15548 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
15549 | ||
15550 | DIMENSION HWT(IDMAX9) | |
15551 | ||
15552 | * change of weights wt from absolut values into the sum of wt of a dec. | |
15553 | DO 10 J=1,IDMAX9 | |
15554 | HWT(J) = ZERO | |
15555 | 10 CONTINUE | |
15556 | C DO 999 KKK=1,210 | |
15557 | C WRITE(LOUT,'(A8,F5.2,2E10.3,2I4,2I10)') | |
15558 | C & ANAME(KKK),AAM(KKK),GA(KKK),TAU(KKK),IICH(KKK),IIBAR(KKK), | |
15559 | C & K1(KKK),K2(KKK) | |
15560 | C 999 CONTINUE | |
15561 | C STOP | |
15562 | DO 30 I=1,210 | |
15563 | IK1 = K1(I) | |
15564 | IK2 = K2(I) | |
15565 | HV = ZERO | |
15566 | DO 20 J=IK1,IK2 | |
15567 | HV = HV+WT(J) | |
15568 | HWT(J) = HV | |
15569 | **sr 13.1.95 | |
15570 | IF (HWT(J).GT.1.0001) WRITE(LOUT,1000) HWT(J),J,I,IK1 | |
15571 | 1000 FORMAT(2X,15H ERROR IN HWT =,1F10.5,8H J,I,K1=,3I5) | |
15572 | 20 CONTINUE | |
15573 | 30 CONTINUE | |
15574 | DO 40 J=1,IDMAX9 | |
15575 | WT(J) = HWT(J) | |
15576 | 40 CONTINUE | |
15577 | ||
15578 | RETURN | |
15579 | END | |
15580 | ||
15581 | *$ CREATE DT_DDATAR.FOR | |
15582 | *COPY DT_DDATAR | |
15583 | * | |
15584 | *===ddatar=============================================================* | |
15585 | * | |
15586 | SUBROUTINE DT_DDATAR | |
15587 | ||
15588 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
15589 | SAVE | |
15590 | PARAMETER ( LINP = 10 , | |
15591 | & LOUT = 6 , | |
15592 | & LDAT = 9 ) | |
15593 | PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0) | |
15594 | ||
15595 | * quark-content to particle index conversion (DTUNUC 1.x) | |
15596 | COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21), | |
15597 | & IA08(6,21),IA10(6,21) | |
15598 | ||
15599 | DIMENSION IV(36),IP(36),IB(126),IBB(126),IA(126),IAA(126) | |
15600 | ||
15601 | DATA IV/ 33, 34, 38,123, 0, 0, 32, 33, 39,124, | |
15602 | & 0, 0, 36, 37, 96,127, 0, 0,126,125, | |
15603 | & 128,129,14*0/ | |
15604 | DATA IP/ 23, 14, 16,116, 0, 0, 13, 23, 25,117, | |
15605 | & 0, 0, 15, 24, 31,120, 0, 0,119,118, | |
15606 | & 121,122,14*0/ | |
15607 | DATA IB/ 0, 1, 21,140, 0, 0, 8, 22,137, 0, | |
15608 | & 0, 97,138, 0, 0,146, 0, 0, 0, 0, | |
15609 | & 0, 1, 8, 22,137, 0, 0, 0, 20,142, | |
15610 | & 0, 0, 98,139, 0, 0,147, 0, 0, 0, | |
15611 | & 0, 0, 21, 22, 97,138, 0, 0, 20, 98, | |
15612 | & 139, 0, 0, 0,145, 0, 0,148, 0, 0, | |
15613 | & 0, 0, 0,140,137,138,146, 0, 0,142, | |
15614 | & 139,147, 0, 0,145,148, 50*0/ | |
15615 | DATA IBB/53, 54,104,161, 0, 0, 55,105,162, 0, | |
15616 | & 0,107,164, 0, 0,167, 0, 0, 0, 0, | |
15617 | & 0, 54, 55,105,162, 0, 0, 56,106,163, | |
15618 | & 0, 0,108,165, 0, 0,168, 0, 0, 0, | |
15619 | & 0, 0,104,105,107,164, 0, 0,106,108, | |
15620 | & 165, 0, 0,109,166, 0, 0,169, 0, 0, | |
15621 | & 0, 0, 0,161,162,164,167, 0, 0,163, | |
15622 | & 165,168, 0, 0,166,169, 0, 0,170,47*0/ | |
15623 | DATA IA/ 0, 2, 99,152, 0, 0, 9,100,149, 0, | |
15624 | & 0,102,150, 0, 0,158, 0, 0, 0, 0, | |
15625 | & 0, 2, 9,100,149, 0, 0, 0,101,154, | |
15626 | & 0, 0,103,151, 0, 0,159, 0, 0, 0, | |
15627 | & 0, 0, 99,100,102,150, 0, 0,101,103, | |
15628 | & 151, 0, 0, 0,157, 0, 0,160, 0, 0, | |
15629 | & 0, 0, 0,152,149,150,158, 0, 0,154, | |
15630 | & 151,159, 0, 0,157,160, 50*0/ | |
15631 | DATA IAA/67, 68,110,171, 0, 0, 69,111,172, 0, | |
15632 | & 0,113,174, 0, 0,177, 0, 0, 0, 0, | |
15633 | & 0, 68, 69,111,172, 0, 0, 70,112,173, | |
15634 | & 0, 0,114,175, 0, 0,178, 0, 0, 0, | |
15635 | & 0, 0,110,111,113,174, 0, 0,112,114, | |
15636 | & 175, 0, 0,115,176, 0, 0,179, 0, 0, | |
15637 | & 0, 0, 0,171,172,174,177, 0, 0,173, | |
15638 | & 175,178, 0, 0,176,179, 0, 0,180,47*0/ | |
15639 | ||
15640 | L=0 | |
15641 | DO 2 I=1,6 | |
15642 | DO 1 J=1,6 | |
15643 | L = L+1 | |
15644 | IMPS(I,J) = IP(L) | |
15645 | IMVE(I,J) = IV(L) | |
15646 | 1 CONTINUE | |
15647 | 2 CONTINUE | |
15648 | L=0 | |
15649 | DO 4 I=1,6 | |
15650 | DO 3 J=1,21 | |
15651 | L = L+1 | |
15652 | IB08(I,J) = IB(L) | |
15653 | IB10(I,J) = IBB(L) | |
15654 | IA08(I,J) = IA(L) | |
15655 | IA10(I,J) = IAA(L) | |
15656 | 3 CONTINUE | |
15657 | 4 CONTINUE | |
15658 | C A1 = 0.88D0 | |
15659 | C B1 = 3.0D0 | |
15660 | C B2 = 3.0D0 | |
15661 | C B3 = 8.0D0 | |
15662 | C LT = 0 | |
15663 | C LB = 0 | |
15664 | C BET = 12.0D0 | |
15665 | C AS = 0.25D0 | |
15666 | C B8 = 0.33D0 | |
15667 | C AME = 0.95D0 | |
15668 | C DIQ = 0.375D0 | |
15669 | C ISU = 4 | |
15670 | ||
15671 | RETURN | |
15672 | END | |
15673 | ||
15674 | *$ CREATE DT_INITJS.FOR | |
15675 | *COPY DT_INITJS | |
15676 | * | |
15677 | *===initjs=============================================================* | |
15678 | * | |
15679 | SUBROUTINE DT_INITJS(MODE) | |
15680 | ||
15681 | ************************************************************************ | |
15682 | * Initialize JETSET paramters. * | |
15683 | * MODE = 0 default settings * | |
15684 | * = 1 PHOJET settings * | |
15685 | * = 2 DTUNUC settings * | |
15686 | * This version dated 16.02.96 is written by S. Roesler * | |
15687 | * * | |
15688 | * Last change 27.12.2006 by S. Roesler. * | |
15689 | ************************************************************************ | |
15690 | ||
15691 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
15692 | SAVE | |
15693 | PARAMETER ( LINP = 10 , | |
15694 | & LOUT = 6 , | |
15695 | & LDAT = 9 ) | |
15696 | PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0) | |
15697 | ||
15698 | LOGICAL LFIRST,LFIRDT,LFIRPH | |
15699 | ||
15700 | COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) | |
15701 | COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) | |
15702 | COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5) | |
15703 | * flags for particle decays | |
15704 | COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20), | |
15705 | & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20), | |
15706 | & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0 | |
15707 | * flags for input different options | |
15708 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
15709 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
15710 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
15711 | ||
15712 | INTEGER PYCOMP | |
15713 | ||
15714 | DIMENSION IDXSTA(40) | |
15715 | DATA IDXSTA | |
15716 | * K0s pi0 lam alam sig+ asig+ sig- asig- tet0 atet0 | |
15717 | & / 310, 111, 3122,-3122, 3222,-3222, 3112,-3112, 3322,-3322, | |
15718 | * tet- atet- om- aom- D+ D- D0 aD0 Ds+ aDs+ | |
15719 | & 3312,-3312, 3334,-3334, 411, -411, 421, -421, 431, -431, | |
15720 | * etac lamc+alamc+sigc++ sigc+ sigc0asigc++asigc+asigc0 Ksic+ | |
15721 | & 441, 4122,-4122, 4222, 4212, 4112,-4222,-4212,-4112, 4232, | |
15722 | * Ksic0 aKsic+aKsic0 sig0 asig0 | |
15723 | & 4132,-4232,-4132, 3212,-3212, 5*0/ | |
15724 | ||
15725 | DATA LFIRST,LFIRDT,LFIRPH /.TRUE.,.TRUE.,.TRUE./ | |
15726 | ||
15727 | IF (LFIRST) THEN | |
15728 | * save default settings | |
15729 | PDEF1 = PARJ(1) | |
15730 | PDEF2 = PARJ(2) | |
15731 | PDEF3 = PARJ(3) | |
15732 | PDEF5 = PARJ(5) | |
15733 | PDEF6 = PARJ(6) | |
15734 | PDEF7 = PARJ(7) | |
15735 | PDEF18 = PARJ(18) | |
15736 | PDEF19 = PARJ(19) | |
15737 | PDEF21 = PARJ(21) | |
15738 | PDEF42 = PARJ(42) | |
15739 | MDEF12 = MSTJ(12) | |
15740 | * LUJETS / PYJETS array-dimensions | |
15741 | MSTU(4) = 4000 | |
15742 | * increase maximum number of JETSET-error prints | |
15743 | MSTU(22) = 50000 | |
15744 | * prevent particles decaying | |
15745 | DO 1 I=1,35 | |
15746 | IF (I.LT.34) THEN | |
15747 | KC = PYCOMP(IDXSTA(I)) | |
15748 | IF (KC.GT.0) THEN | |
15749 | IF (I.EQ.2) THEN | |
15750 | * pi0 decay | |
15751 | C MDCY(KC,1) = 1 | |
15752 | MDCY(KC,1) = 0 | |
15753 | **cr mode | |
15754 | C ELSEIF ((I.EQ.4).OR.(I.EQ. 6).OR. | |
15755 | C & (I.EQ.8).OR.(I.EQ.10)) THEN | |
15756 | C ELSEIF (I.EQ.4) THEN | |
15757 | C MDCY(KC,1) = 1 | |
15758 | ** | |
15759 | ELSE | |
15760 | MDCY(KC,1) = 0 | |
15761 | ENDIF | |
15762 | ENDIF | |
15763 | ELSEIF (((I.EQ.34).OR.(I.EQ.35)).AND.(ISIG0.EQ.0)) THEN | |
15764 | KC = PYCOMP(IDXSTA(I)) | |
15765 | IF (KC.GT.0) THEN | |
15766 | MDCY(KC,1) = 0 | |
15767 | ENDIF | |
15768 | ENDIF | |
15769 | 1 CONTINUE | |
15770 | * | |
15771 | * | |
15772 | * popcorn: | |
15773 | IF (PDB.LE.ZERO) THEN | |
15774 | * no popcorn-mechanism | |
15775 | MSTJ(12) = 1 | |
15776 | ELSE | |
15777 | MSTJ(12) = 3 | |
15778 | PARJ(5) = PDB | |
15779 | ENDIF | |
15780 | * set JETSET-parameter requested by input cards | |
15781 | IF (NMSTU.GT.0) THEN | |
15782 | DO 2 I=1,NMSTU | |
15783 | MSTU(IMSTU(I)) = MSTUX(I) | |
15784 | 2 CONTINUE | |
15785 | ENDIF | |
15786 | IF (NMSTJ.GT.0) THEN | |
15787 | DO 3 I=1,NMSTJ | |
15788 | MSTJ(IMSTJ(I)) = MSTJX(I) | |
15789 | 3 CONTINUE | |
15790 | ENDIF | |
15791 | IF (NPARU.GT.0) THEN | |
15792 | DO 4 I=1,NPARU | |
15793 | PARU(IPARU(I)) = PARUX(I) | |
15794 | 4 CONTINUE | |
15795 | ENDIF | |
15796 | LFIRST = .FALSE. | |
15797 | ENDIF | |
15798 | * | |
15799 | * PARJ(1) suppression of qq-aqaq pair prod. compared to | |
15800 | * q-aq pair prod. (default: 0.1) | |
15801 | * PARJ(2) strangeness suppression (default: 0.3) | |
15802 | * PARJ(3) extra suppression of strange diquarks (default: 0.4) | |
15803 | * PARJ(6) extra suppression of sas-pair shared by B and | |
15804 | * aB in BMaB (default: 0.5) | |
15805 | * PARJ(7) extra suppression of strange meson M in BMaB | |
15806 | * configuration (default: 0.5) | |
15807 | * PARJ(18) spin 3/2 baryon suppression (default: 1.0) | |
15808 | * PARJ(21) width sigma in Gaussian p_x, p_y transverse | |
15809 | * momentum distrib. for prim. hadrons (default: 0.35) | |
15810 | * PARJ(42) b-parameter for symmetric Lund-fragmentation | |
15811 | * function (default: 0.9 GeV^-2) | |
15812 | * | |
15813 | * PHOJET settings | |
15814 | IF (MODE.EQ.1) THEN | |
15815 | * JETSET default | |
15816 | C PARJ(1) = PDEF1 | |
15817 | C PARJ(2) = PDEF2 | |
15818 | C PARJ(3) = PDEF3 | |
15819 | C PARJ(6) = PDEF6 | |
15820 | C PARJ(7) = PDEF7 | |
15821 | C PARJ(18) = PDEF18 | |
15822 | C PARJ(21) = PDEF21 | |
15823 | C PARJ(42) = PDEF42 | |
15824 | **sr 18.11.98 parameter tuning | |
15825 | C PARJ(1) = 0.092D0 | |
15826 | C PARJ(2) = 0.25D0 | |
15827 | C PARJ(3) = 0.45D0 | |
15828 | C PARJ(19) = 0.3D0 | |
15829 | C PARJ(21) = 0.45D0 | |
15830 | C PARJ(42) = 1.0D0 | |
15831 | **sr 28.04.99 parameter tuning (May 99 minor modifications) | |
15832 | PARJ(1) = 0.085D0 | |
15833 | PARJ(2) = 0.26D0 | |
15834 | PARJ(3) = 0.8D0 | |
15835 | PARJ(11) = 0.38D0 | |
15836 | PARJ(18) = 0.3D0 | |
15837 | PARJ(19) = 0.4D0 | |
15838 | PARJ(21) = 0.36D0 | |
15839 | PARJ(41) = 0.3D0 | |
15840 | PARJ(42) = 0.86D0 | |
15841 | IF (NPARJ.GT.0) THEN | |
15842 | DO 10 I=1,NPARJ | |
15843 | IF (IPARJ(I).GT.0) PARJ(IPARJ(I)) = PARJX(I) | |
15844 | 10 CONTINUE | |
15845 | ENDIF | |
15846 | IF (LFIRPH) THEN | |
15847 | WRITE(LOUT,'(1X,A)') | |
15848 | & 'DT_INITJS: JETSET-parameter for PHOJET' | |
15849 | CALL DT_JSPARA(0) | |
15850 | LFIRPH = .FALSE. | |
15851 | ENDIF | |
15852 | * DTUNUC settings | |
15853 | ELSEIF (MODE.EQ.2) THEN | |
15854 | IF (IFRAG(2).EQ.1) THEN | |
15855 | **sr parameters before 9.3.96 | |
15856 | C PARJ(2) = 0.27D0 | |
15857 | C PARJ(3) = 0.6D0 | |
15858 | C PARJ(6) = 0.75D0 | |
15859 | C PARJ(7) = 0.75D0 | |
15860 | C PARJ(21) = 0.55D0 | |
15861 | C PARJ(42) = 1.3D0 | |
15862 | **sr 18.11.98 parameter tuning | |
15863 | C PARJ(1) = 0.05D0 | |
15864 | C PARJ(2) = 0.27D0 | |
15865 | C PARJ(3) = 0.4D0 | |
15866 | C PARJ(19) = 0.2D0 | |
15867 | C PARJ(21) = 0.45D0 | |
15868 | C PARJ(42) = 1.0D0 | |
15869 | **sr 28.04.99 parameter tuning | |
15870 | PARJ(1) = 0.11D0 | |
15871 | PARJ(2) = 0.36D0 | |
15872 | PARJ(3) = 0.8D0 | |
15873 | PARJ(19) = 0.2D0 | |
15874 | PARJ(21) = 0.3D0 | |
15875 | PARJ(41) = 0.3D0 | |
15876 | PARJ(42) = 0.58D0 | |
15877 | IF (NPARJ.GT.0) THEN | |
15878 | DO 20 I=1,NPARJ | |
15879 | IF (IPARJ(I).LT.0) THEN | |
15880 | IDX = ABS(IPARJ(I)) | |
15881 | PARJ(IDX) = PARJX(I) | |
15882 | ENDIF | |
15883 | 20 CONTINUE | |
15884 | ENDIF | |
15885 | IF (LFIRDT) THEN | |
15886 | WRITE(LOUT,'(1X,A)') | |
15887 | & 'DT_INITJS: JETSET-parameter for DTUNUC' | |
15888 | CALL DT_JSPARA(0) | |
15889 | LFIRDT = .FALSE. | |
15890 | ENDIF | |
15891 | ELSEIF (IFRAG(2).EQ.2) THEN | |
15892 | PARJ(1) = 0.11D0 | |
15893 | PARJ(2) = 0.27D0 | |
15894 | PARJ(3) = 0.3D0 | |
15895 | PARJ(6) = 0.35D0 | |
15896 | PARJ(7) = 0.45D0 | |
15897 | PARJ(18) = 0.66D0 | |
15898 | C PARJ(21) = 0.55D0 | |
15899 | C PARJ(42) = 1.0D0 | |
15900 | PARJ(21) = 0.60D0 | |
15901 | PARJ(42) = 1.3D0 | |
15902 | ELSE | |
15903 | PARJ(1) = PDEF1 | |
15904 | PARJ(2) = PDEF2 | |
15905 | PARJ(3) = PDEF3 | |
15906 | PARJ(6) = PDEF6 | |
15907 | PARJ(7) = PDEF7 | |
15908 | PARJ(18) = PDEF18 | |
15909 | PARJ(21) = PDEF21 | |
15910 | PARJ(42) = PDEF42 | |
15911 | ENDIF | |
15912 | ELSE | |
15913 | PARJ(1) = PDEF1 | |
15914 | PARJ(2) = PDEF2 | |
15915 | PARJ(3) = PDEF3 | |
15916 | PARJ(5) = PDEF5 | |
15917 | PARJ(6) = PDEF6 | |
15918 | PARJ(7) = PDEF7 | |
15919 | PARJ(18) = PDEF18 | |
15920 | PARJ(19) = PDEF19 | |
15921 | PARJ(21) = PDEF21 | |
15922 | PARJ(42) = PDEF42 | |
15923 | MSTJ(12) = MDEF12 | |
15924 | ENDIF | |
15925 | ||
15926 | RETURN | |
15927 | END | |
15928 | ||
15929 | *$ CREATE DT_JSPARA.FOR | |
15930 | *COPY DT_JSPARA | |
15931 | * | |
15932 | *===jspara=============================================================* | |
15933 | * | |
15934 | SUBROUTINE DT_JSPARA(MODE) | |
15935 | ||
15936 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
15937 | SAVE | |
15938 | PARAMETER ( LINP = 10 , | |
15939 | & LOUT = 6 , | |
15940 | & LDAT = 9 ) | |
15941 | PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1, | |
15942 | & ONE=1.0D0,ZERO=0.0D0) | |
15943 | ||
15944 | LOGICAL LFIRST | |
15945 | ||
15946 | COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) | |
15947 | ||
15948 | DIMENSION ISTU(200),QARU(200),ISTJ(200),QARJ(200) | |
15949 | ||
15950 | DATA LFIRST /.TRUE./ | |
15951 | ||
15952 | * save the default JETSET-parameter on the first call | |
15953 | IF (LFIRST) THEN | |
15954 | DO 1 I=1,200 | |
15955 | ISTU(I) = MSTU(I) | |
15956 | QARU(I) = PARU(I) | |
15957 | ISTJ(I) = MSTJ(I) | |
15958 | QARJ(I) = PARJ(I) | |
15959 | 1 CONTINUE | |
15960 | LFIRST = .FALSE. | |
15961 | ENDIF | |
15962 | ||
15963 | WRITE(LOUT,1000) | |
15964 | 1000 FORMAT(1X,'DT_JSPARA: new value (default value)') | |
15965 | ||
15966 | * compare the default JETSET-parameter with the present values | |
15967 | DO 2 I=1,200 | |
15968 | IF ((MSTU(I).NE.ISTU(I)).AND.(I.NE.31)) THEN | |
15969 | WRITE(LOUT,1002) 'MSTU(',I,MSTU(I),ISTU(I) | |
15970 | C ISTU(I) = MSTU(I) | |
15971 | ENDIF | |
15972 | DIFF = ABS(PARU(I)-QARU(I)) | |
15973 | IF ((DIFF.GE.1.0D-5).AND.(I.NE.21)) THEN | |
15974 | WRITE(LOUT,1001) 'PARU(',I,PARU(I),QARU(I) | |
15975 | C QARU(I) = PARU(I) | |
15976 | ENDIF | |
15977 | IF (MSTJ(I).NE.ISTJ(I)) THEN | |
15978 | WRITE(LOUT,1002) 'MSTJ(',I,MSTJ(I),ISTJ(I) | |
15979 | C ISTJ(I) = MSTJ(I) | |
15980 | ENDIF | |
15981 | DIFF = ABS(PARJ(I)-QARJ(I)) | |
15982 | IF (DIFF.GE.1.0D-5) THEN | |
15983 | WRITE(LOUT,1001) 'PARJ(',I,PARJ(I),QARJ(I) | |
15984 | C QARJ(I) = PARJ(I) | |
15985 | ENDIF | |
15986 | 2 CONTINUE | |
15987 | 1001 FORMAT(12X,A5,I3,'): ',F6.3,' (',F6.3,')') | |
15988 | 1002 FORMAT(12X,A5,I3,'): ',I6,' (',I6,')') | |
15989 | ||
15990 | RETURN | |
15991 | END | |
15992 | ||
15993 | *$ CREATE DT_FOZOCA.FOR | |
15994 | *COPY DT_FOZOCA | |
15995 | * | |
15996 | *===fozoca=============================================================* | |
15997 | * | |
15998 | SUBROUTINE DT_FOZOCA(LFZC,IREJ) | |
15999 | ||
16000 | ************************************************************************ | |
16001 | * This subroutine treats the complete FOrmation ZOne supressed intra- * | |
16002 | * nuclear CAscade. * | |
16003 | * LFZC = .true. cascade has been treated * | |
16004 | * = .false. cascade skipped * | |
16005 | * This is a completely revised version of the original FOZOKL. * | |
16006 | * This version dated 18.11.95 is written by S. Roesler * | |
16007 | ************************************************************************ | |
16008 | ||
16009 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
16010 | SAVE | |
16011 | PARAMETER ( LINP = 10 , | |
16012 | & LOUT = 6 , | |
16013 | & LDAT = 9 ) | |
16014 | PARAMETER (DLARGE=1.0D10,OHALF=0.5D0,ZERO=0.0D0) | |
16015 | PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0) | |
16016 | ||
16017 | LOGICAL LSTART,LCAS,LFZC | |
16018 | ||
16019 | * event history | |
16020 | PARAMETER (NMXHKK=200000) | |
16021 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
16022 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
16023 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
16024 | * extended event history | |
16025 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
16026 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
16027 | & IHIST(2,NMXHKK) | |
16028 | * rejection counter | |
16029 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
16030 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
16031 | & IREXCI(3),IRDIFF(2),IRINC | |
16032 | * properties of interacting particles | |
16033 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
16034 | * Glauber formalism: collision properties | |
16035 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, | |
16036 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC | |
16037 | * flags for input different options | |
16038 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
16039 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
16040 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
16041 | * final state after intranuclear cascade step | |
16042 | COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC | |
16043 | * parameter for intranuclear cascade | |
16044 | LOGICAL LPAULI | |
16045 | COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI | |
16046 | ||
16047 | DIMENSION NCWOUN(2) | |
16048 | ||
16049 | DATA LSTART /.TRUE./ | |
16050 | ||
16051 | LFZC = .TRUE. | |
16052 | IREJ = 0 | |
16053 | ||
16054 | * skip cascade if hadron-hadron interaction or if supressed by user | |
16055 | IF (((IP.EQ.1).AND.(IT.EQ.1)).OR.(KTAUGE.LT.1)) GOTO 9999 | |
16056 | * skip cascade if not all possible chains systems are hadronized | |
16057 | DO 1 I=1,8 | |
16058 | IF (.NOT.LHADRO(I)) GOTO 9999 | |
16059 | 1 CONTINUE | |
16060 | ||
16061 | IF (LSTART) THEN | |
16062 | WRITE(LOUT,1000) KTAUGE,TAUFOR,INCMOD | |
16063 | 1000 FORMAT(/,1X,'FOZOCA: intranuclear cascade treated for a ', | |
16064 | & 'maximum of',I4,' generations',/,10X,'formation time ', | |
16065 | & 'parameter:',F5.1,' fm/c',9X,'modus:',I2) | |
16066 | IF (ITAUVE.EQ.1) WRITE(LOUT,1001) | |
16067 | IF (ITAUVE.EQ.2) WRITE(LOUT,1002) | |
16068 | 1001 FORMAT(10X,'p_t dependent formation zone',/) | |
16069 | 1002 FORMAT(10X,'constant formation zone',/) | |
16070 | LSTART = .FALSE. | |
16071 | ENDIF | |
16072 | ||
16073 | * in order to avoid wasting of cpu-time the DTEVT1-indices of nucleons | |
16074 | * which may interact with final state particles are stored in a seperate | |
16075 | * array - here all proj./target nucleon-indices (just for simplicity) | |
16076 | NOINC = 0 | |
16077 | DO 9 I=1,NPOINT(1)-1 | |
16078 | NOINC = NOINC+1 | |
16079 | IDXINC(NOINC) = I | |
16080 | 9 CONTINUE | |
16081 | ||
16082 | * initialize Pauli-principle treatment (find wounded nucleons) | |
16083 | NWOUND(1) = 0 | |
16084 | NWOUND(2) = 0 | |
16085 | NCWOUN(1) = 0 | |
16086 | NCWOUN(2) = 0 | |
16087 | DO 2 J=1,NPOINT(1) | |
16088 | DO 3 I=1,2 | |
16089 | IF (ISTHKK(J).EQ.10+I) THEN | |
16090 | NWOUND(I) = NWOUND(I)+1 | |
16091 | EWOUND(I,NWOUND(I)) = PHKK(4,J) | |
16092 | IF (IDHKK(J).EQ.2212) NCWOUN(I) = NCWOUN(I)+1 | |
16093 | ENDIF | |
16094 | 3 CONTINUE | |
16095 | 2 CONTINUE | |
16096 | ||
16097 | * modify nuclear potential for wounded nucleons | |
16098 | IPRCL = IP -NWOUND(1) | |
16099 | IPZRCL = IPZ-NCWOUN(1) | |
16100 | ITRCL = IT -NWOUND(2) | |
16101 | ITZRCL = ITZ-NCWOUN(2) | |
16102 | CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1) | |
16103 | ||
16104 | NSTART = NPOINT(4) | |
16105 | NEND = NHKK | |
16106 | ||
16107 | 7 CONTINUE | |
16108 | DO 8 I=NSTART,NEND | |
16109 | ||
16110 | IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDCH(I).LT.KTAUGE)) THEN | |
16111 | * select nucleus the cascade starts first (proj. - 1, target - -1) | |
16112 | NCAS = 1 | |
16113 | * projectile/target with probab. 1/2 | |
16114 | IF ((INCMOD.EQ.1).OR.(IDCH(I).GT.0)) THEN | |
16115 | IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS | |
16116 | * in the nucleus with highest mass | |
16117 | ELSEIF (INCMOD.EQ.2) THEN | |
16118 | IF (IP.GT.IT) THEN | |
16119 | NCAS = -NCAS | |
16120 | ELSEIF (IP.EQ.IT) THEN | |
16121 | IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS | |
16122 | ENDIF | |
16123 | * the nucleus the cascade starts first is requested to be the one | |
16124 | * moving in the direction of the secondary | |
16125 | ELSEIF (INCMOD.EQ.3) THEN | |
16126 | NCAS = INT(SIGN(1.0D0,PHKK(3,I))) | |
16127 | ENDIF | |
16128 | * check that the selected "nucleus" is not a hadron | |
16129 | IF (((NCAS.EQ. 1).AND.(IP.LE.1)).OR. | |
16130 | & ((NCAS.EQ.-1).AND.(IT.LE.1))) NCAS = -NCAS | |
16131 | ||
16132 | * treat intranuclear cascade in the nucleus selected first | |
16133 | LCAS = .FALSE. | |
16134 | CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1) | |
16135 | IF (IREJ1.NE.0) GOTO 9998 | |
16136 | * treat intranuclear cascade in the other nucleus if this isn't a had. | |
16137 | NCAS = -NCAS | |
16138 | IF (((NCAS.EQ. 1).AND.(IP.GT.1)).OR. | |
16139 | & ((NCAS.EQ.-1).AND.(IT.GT.1))) THEN | |
16140 | IF (LCAS) CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1) | |
16141 | IF (IREJ1.NE.0) GOTO 9998 | |
16142 | ENDIF | |
16143 | ||
16144 | ENDIF | |
16145 | ||
16146 | 8 CONTINUE | |
16147 | NSTART = NEND+1 | |
16148 | NEND = NHKK | |
16149 | IF (NSTART.LE.NEND) GOTO 7 | |
16150 | ||
16151 | RETURN | |
16152 | ||
16153 | 9998 CONTINUE | |
16154 | * reject this event | |
16155 | IRINC = IRINC+1 | |
16156 | IREJ = 1 | |
16157 | ||
16158 | 9999 CONTINUE | |
16159 | * intranucl. cascade not treated because of interaction properties or | |
16160 | * it is supressed by user or it was rejected or... | |
16161 | LFZC = .FALSE. | |
16162 | * reset flag characterizing direction of motion in n-n-cms | |
16163 | **sr14-11-95 | |
16164 | C DO 9990 I=NPOINT(5),NHKK | |
16165 | C IF (ISTHKK(I).EQ.-1) ISTHKK(I)=1 | |
16166 | C9990 CONTINUE | |
16167 | ||
16168 | RETURN | |
16169 | END | |
16170 | ||
16171 | *$ CREATE DT_INUCAS.FOR | |
16172 | *COPY DT_INUCAS | |
16173 | * | |
16174 | *===inucas=============================================================* | |
16175 | * | |
16176 | SUBROUTINE DT_INUCAS(IT,IP,IDXCAS,LCAS,NCAS,IREJ) | |
16177 | ||
16178 | ************************************************************************ | |
16179 | * Formation zone supressed IntraNUclear CAScade for one final state * | |
16180 | * particle. * | |
16181 | * IT, IP mass numbers of target, projectile nuclei * | |
16182 | * IDXCAS index of final state particle in DTEVT1 * | |
16183 | * NCAS = 1 intranuclear cascade in projectile * | |
16184 | * = -1 intranuclear cascade in target * | |
16185 | * This version dated 18.11.95 is written by S. Roesler * | |
16186 | ************************************************************************ | |
16187 | ||
16188 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
16189 | SAVE | |
16190 | PARAMETER ( LINP = 10 , | |
16191 | & LOUT = 6 , | |
16192 | & LDAT = 9 ) | |
16193 | ||
16194 | PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10, | |
16195 | & OHALF=0.5D0,ONE=1.0D0) | |
16196 | PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0) | |
16197 | PARAMETER (TWOPI=6.283185307179586454D+00) | |
16198 | PARAMETER (PLOWH=0.01D0,PHIH=9.0D0) | |
16199 | ||
16200 | LOGICAL LABSOR,LCAS | |
16201 | ||
16202 | * event history | |
16203 | PARAMETER (NMXHKK=200000) | |
16204 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
16205 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
16206 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
16207 | * extended event history | |
16208 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
16209 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
16210 | & IHIST(2,NMXHKK) | |
16211 | * final state after inc step | |
16212 | PARAMETER (MAXFSP=10) | |
16213 | COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP | |
16214 | * flags for input different options | |
16215 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
16216 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
16217 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
16218 | * particle properties (BAMJET index convention) | |
16219 | CHARACTER*8 ANAME | |
16220 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
16221 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
16222 | * Glauber formalism: collision properties | |
16223 | COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC, | |
16224 | & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC | |
16225 | * nuclear potential | |
16226 | LOGICAL LFERMI | |
16227 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, | |
16228 | & EBINDP(2),EBINDN(2),EPOT(2,210), | |
16229 | & ETACOU(2),ICOUL,LFERMI | |
16230 | * parameter for intranuclear cascade | |
16231 | LOGICAL LPAULI | |
16232 | COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI | |
16233 | * final state after intranuclear cascade step | |
16234 | COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC | |
16235 | * nucleon-nucleon event-generator | |
16236 | CHARACTER*8 CMODEL | |
16237 | LOGICAL LPHOIN | |
16238 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
16239 | * statistics: residual nuclei | |
16240 | COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2), | |
16241 | & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2), | |
16242 | & NINCST(2,4),NINCEV(2), | |
16243 | & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2), | |
16244 | & NRESPB(2),NRESCH(2),NRESEV(4), | |
16245 | & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240), | |
16246 | & NEVAFI(2,2) | |
16247 | ||
16248 | DIMENSION PCAS(2,5),PTOCAS(2),COSCAS(2,3),VTXCAS(2,4),VTXCA1(2,4), | |
16249 | & PCAS1(5),PNUC(5),BGTA(4), | |
16250 | & BGCAS(2),GACAS(2),BECAS(2), | |
16251 | & RNUC(2),BIMPC(2),VTXDST(3),IDXSPE(2),IDSPE(2),NWTMP(2) | |
16252 | ||
16253 | DATA PDIF /0.545D0/ | |
16254 | ||
16255 | IREJ = 0 | |
16256 | ||
16257 | * update counter | |
16258 | IF (NINCEV(1).NE.NEVHKK) THEN | |
16259 | NINCEV(1) = NEVHKK | |
16260 | NINCEV(2) = NINCEV(2)+1 | |
16261 | ENDIF | |
16262 | ||
16263 | * "BAMJET-index" of this hadron | |
16264 | IDCAS = IDBAM(IDXCAS) | |
16265 | IF (IDT_MCHAD(IDCAS).EQ.-1) RETURN | |
16266 | ||
16267 | * skip gammas, electrons, etc.. | |
16268 | IF (AAM(IDCAS).LT.TINY2) RETURN | |
16269 | ||
16270 | * Lorentz-trsf. into projectile rest system | |
16271 | IF (IP.GT.1) THEN | |
16272 | CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS), | |
16273 | & PHKK(4,IDXCAS),PCAS(1,1),PCAS(1,2),PCAS(1,3), | |
16274 | & PCAS(1,4),IDCAS,-2) | |
16275 | PTOCAS(1) = SQRT(PCAS(1,1)**2+PCAS(1,2)**2+PCAS(1,3)**2) | |
16276 | PCAS(1,5) = (PCAS(1,4)-PTOCAS(1))*(PCAS(1,4)+PTOCAS(1)) | |
16277 | IF (PCAS(1,5).GT.ZERO) THEN | |
16278 | PCAS(1,5) = SQRT(PCAS(1,5)) | |
16279 | ELSE | |
16280 | PCAS(1,5) = AAM(IDCAS) | |
16281 | ENDIF | |
16282 | DO 20 K=1,3 | |
16283 | COSCAS(1,K) = PCAS(1,K)/MAX(PTOCAS(1),TINY10) | |
16284 | 20 CONTINUE | |
16285 | * Lorentz-parameters | |
16286 | * particle rest system --> projectile rest system | |
16287 | BGCAS(1) = PTOCAS(1)/MAX(PCAS(1,5),TINY10) | |
16288 | GACAS(1) = PCAS(1,4)/MAX(PCAS(1,5),TINY10) | |
16289 | BECAS(1) = BGCAS(1)/GACAS(1) | |
16290 | ELSE | |
16291 | DO 21 K=1,5 | |
16292 | PCAS(1,K) = ZERO | |
16293 | IF (K.LE.3) COSCAS(1,K) = ZERO | |
16294 | 21 CONTINUE | |
16295 | PTOCAS(1) = ZERO | |
16296 | BGCAS(1) = ZERO | |
16297 | GACAS(1) = ZERO | |
16298 | BECAS(1) = ZERO | |
16299 | ENDIF | |
16300 | * Lorentz-trsf. into target rest system | |
16301 | IF (IT.GT.1) THEN | |
16302 | * LEPTO: final state particles are already in target rest frame | |
16303 | C IF (MCGENE.EQ.3) THEN | |
16304 | C PCAS(2,1) = PHKK(1,IDXCAS) | |
16305 | C PCAS(2,2) = PHKK(2,IDXCAS) | |
16306 | C PCAS(2,3) = PHKK(3,IDXCAS) | |
16307 | C PCAS(2,4) = PHKK(4,IDXCAS) | |
16308 | C ELSE | |
16309 | CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS), | |
16310 | & PHKK(4,IDXCAS),PCAS(2,1),PCAS(2,2),PCAS(2,3), | |
16311 | & PCAS(2,4),IDCAS,-3) | |
16312 | C ENDIF | |
16313 | PTOCAS(2) = SQRT(PCAS(2,1)**2+PCAS(2,2)**2+PCAS(2,3)**2) | |
16314 | PCAS(2,5) = (PCAS(2,4)-PTOCAS(2))*(PCAS(2,4)+PTOCAS(2)) | |
16315 | IF (PCAS(2,5).GT.ZERO) THEN | |
16316 | PCAS(2,5) = SQRT(PCAS(2,5)) | |
16317 | ELSE | |
16318 | PCAS(2,5) = AAM(IDCAS) | |
16319 | ENDIF | |
16320 | DO 22 K=1,3 | |
16321 | COSCAS(2,K) = PCAS(2,K)/MAX(PTOCAS(2),TINY10) | |
16322 | 22 CONTINUE | |
16323 | * Lorentz-parameters | |
16324 | * particle rest system --> target rest system | |
16325 | BGCAS(2) = PTOCAS(2)/MAX(PCAS(2,5),TINY10) | |
16326 | GACAS(2) = PCAS(2,4)/MAX(PCAS(2,5),TINY10) | |
16327 | BECAS(2) = BGCAS(2)/GACAS(2) | |
16328 | ELSE | |
16329 | DO 23 K=1,5 | |
16330 | PCAS(2,K) = ZERO | |
16331 | IF (K.LE.3) COSCAS(2,K) = ZERO | |
16332 | 23 CONTINUE | |
16333 | PTOCAS(2) = ZERO | |
16334 | BGCAS(2) = ZERO | |
16335 | GACAS(2) = ZERO | |
16336 | BECAS(2) = ZERO | |
16337 | ENDIF | |
16338 | ||
16339 | * radii of nuclei (mm) modified by the wall-depth of the Woods-Saxon- | |
16340 | * potential (see CONUCL) | |
16341 | RNUC(1) = (RPROJ+4.605D0*PDIF)*FM2MM | |
16342 | RNUC(2) = (RTARG+4.605D0*PDIF)*FM2MM | |
16343 | * impact parameter (the projectile moving along z) | |
16344 | BIMPC(1) = ZERO | |
16345 | BIMPC(2) = BIMPAC*FM2MM | |
16346 | ||
16347 | * get position of initial hadron in projectile/target rest-syst. | |
16348 | DO 3 K=1,4 | |
16349 | VTXCAS(1,K) = WHKK(K,IDXCAS) | |
16350 | VTXCAS(2,K) = VHKK(K,IDXCAS) | |
16351 | 3 CONTINUE | |
16352 | ||
16353 | ICAS = 1 | |
16354 | I2 = 2 | |
16355 | IF (NCAS.EQ.-1) THEN | |
16356 | ICAS = 2 | |
16357 | I2 = 1 | |
16358 | ENDIF | |
16359 | ||
16360 | IF (PTOCAS(ICAS).LT.TINY10) THEN | |
16361 | WRITE(LOUT,1000) PTOCAS | |
16362 | 1000 FORMAT(1X,'INUCAS: warning! zero momentum of initial', | |
16363 | & ' hadron ',/,20X,2E12.4) | |
16364 | GOTO 9999 | |
16365 | ENDIF | |
16366 | ||
16367 | * reset spectator flags | |
16368 | NSPE = 0 | |
16369 | IDXSPE(1) = 0 | |
16370 | IDXSPE(2) = 0 | |
16371 | IDSPE(1) = 0 | |
16372 | IDSPE(2) = 0 | |
16373 | ||
16374 | * formation length (in fm) | |
16375 | C IF (LCAS) THEN | |
16376 | C DEL0 = ZERO | |
16377 | C ELSE | |
16378 | DEL0 = TAUFOR*BGCAS(ICAS) | |
16379 | IF (ITAUVE.EQ.1) THEN | |
16380 | AMT = PCAS(ICAS,1)**2+PCAS(ICAS,2)**2+PCAS(ICAS,5)**2 | |
16381 | DEL0 = DEL0*PCAS(ICAS,5)**2/AMT | |
16382 | ENDIF | |
16383 | C ENDIF | |
16384 | * sample from exp(-del/del0) | |
16385 | DEL1 = -DEL0*LOG(MAX(DT_RNDM(DEL0),TINY10)) | |
16386 | * save formation time | |
16387 | TAUSA1 = DEL1/BGCAS(ICAS) | |
16388 | REL1 = TAUSA1*BGCAS(I2) | |
16389 | ||
16390 | DEL = DEL1 | |
16391 | TAUSAM = DEL/BGCAS(ICAS) | |
16392 | REL = TAUSAM*BGCAS(I2) | |
16393 | ||
16394 | * special treatment for negative particles unable to escape | |
16395 | * nuclear potential (implemented for ap, pi-, K- only) | |
16396 | LABSOR = .FALSE. | |
16397 | IF ((IICH(IDCAS).EQ.-1).AND.(IDCAS.LT.20)) THEN | |
16398 | * threshold energy = nuclear potential + Coulomb potential | |
16399 | * (nuclear potential for hadron-nucleus interactions only) | |
16400 | ETHR = AAM(IDCAS)+EPOT(ICAS,IDCAS)+ETACOU(ICAS) | |
16401 | IF (PCAS(ICAS,4).LT.ETHR) THEN | |
16402 | DO 4 K=1,5 | |
16403 | PCAS1(K) = PCAS(ICAS,K) | |
16404 | 4 CONTINUE | |
16405 | * "absorb" negative particle in nucleus | |
16406 | CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,0,IREJ1) | |
16407 | IF (IREJ1.NE.0) GOTO 9999 | |
16408 | IF (NSPE.GE.1) LABSOR = .TRUE. | |
16409 | ENDIF | |
16410 | ENDIF | |
16411 | ||
16412 | * if the initial particle has not been absorbed proceed with | |
16413 | * "normal" cascade | |
16414 | IF (.NOT.LABSOR) THEN | |
16415 | ||
16416 | * calculate coordinates of hadron at the end of the formation zone | |
16417 | * transport-time and -step in the rest system where this step is | |
16418 | * treated | |
16419 | DSTEP = DEL*FM2MM | |
16420 | DTIME = DSTEP/BECAS(ICAS) | |
16421 | RSTEP = REL*FM2MM | |
16422 | IF ((IP.GT.1).AND.(IT.GT.1)) THEN | |
16423 | RTIME = RSTEP/BECAS(I2) | |
16424 | ELSE | |
16425 | RTIME = ZERO | |
16426 | ENDIF | |
16427 | * save step whithout considering the overlapping region | |
16428 | DSTEP1 = DEL1*FM2MM | |
16429 | DTIME1 = DSTEP1/BECAS(ICAS) | |
16430 | RSTEP1 = REL1*FM2MM | |
16431 | IF ((IP.GT.1).AND.(IT.GT.1)) THEN | |
16432 | RTIME1 = RSTEP1/BECAS(I2) | |
16433 | ELSE | |
16434 | RTIME1 = ZERO | |
16435 | ENDIF | |
16436 | * transport to the end of the formation zone in this system | |
16437 | DO 5 K=1,3 | |
16438 | VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+DSTEP1*COSCAS(ICAS,K) | |
16439 | VTXCA1(I2,K) = VTXCAS(I2,K) +RSTEP1*COSCAS(I2,K) | |
16440 | VTXCAS(ICAS,K) = VTXCAS(ICAS,K)+DSTEP*COSCAS(ICAS,K) | |
16441 | VTXCAS(I2,K) = VTXCAS(I2,K) +RSTEP*COSCAS(I2,K) | |
16442 | 5 CONTINUE | |
16443 | VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME1 | |
16444 | VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME1 | |
16445 | VTXCAS(ICAS,4) = VTXCAS(ICAS,4)+DTIME | |
16446 | VTXCAS(I2,4) = VTXCAS(I2,4) +RTIME | |
16447 | ||
16448 | IF ((IP.GT.1).AND.(IT.GT.1)) THEN | |
16449 | XCAS = VTXCAS(ICAS,1) | |
16450 | YCAS = VTXCAS(ICAS,2) | |
16451 | XNCLTA = BIMPAC*FM2MM | |
16452 | RNCLPR = (RPROJ+RNUCLE)*FM2MM | |
16453 | RNCLTA = (RTARG+RNUCLE)*FM2MM | |
16454 | C RNCLPR = (RPROJ+1.605D0*PDIF)*FM2MM | |
16455 | C RNCLTA = (RTARG+1.605D0*PDIF)*FM2MM | |
16456 | C RNCLPR = (RPROJ)*FM2MM | |
16457 | C RNCLTA = (RTARG)*FM2MM | |
16458 | RCASPR = SQRT( XCAS**2 +YCAS**2) | |
16459 | RCASTA = SQRT((XCAS-XNCLTA)**2+YCAS**2) | |
16460 | IF ((RCASPR.LT.RNCLPR).AND.(RCASTA.LT.RNCLTA)) THEN | |
16461 | IF (IDCH(IDXCAS).EQ.0) NOBAM(IDXCAS) = 3 | |
16462 | ENDIF | |
16463 | ENDIF | |
16464 | ||
16465 | * check if particle is already outside of the corresp. nucleus | |
16466 | RDIST = SQRT((VTXCAS(ICAS,1)-BIMPC(ICAS))**2+ | |
16467 | & VTXCAS(ICAS,2)**2+VTXCAS(ICAS,3)**2) | |
16468 | IF (RDIST.GE.RNUC(ICAS)) THEN | |
16469 | * here: IDCH is the generation of the final state part. starting | |
16470 | * with zero for hadronization products | |
16471 | * flag particles of generation 0 being outside the nuclei after | |
16472 | * formation time (to be used for excitation energy calculation) | |
16473 | IF ((IDCH(IDXCAS).EQ.0).AND.(NOBAM(IDXCAS).LT.3)) | |
16474 | & NOBAM(IDXCAS) = NOBAM(IDXCAS)+ICAS | |
16475 | GOTO 9997 | |
16476 | ENDIF | |
16477 | DIST = DLARGE | |
16478 | DISTP = DLARGE | |
16479 | DISTN = DLARGE | |
16480 | IDXP = 0 | |
16481 | IDXN = 0 | |
16482 | ||
16483 | * already here: skip particles being outside HADRIN "energy-window" | |
16484 | * to avoid wasting of time | |
16485 | NINCHR(ICAS,1) = NINCHR(ICAS,1)+1 | |
16486 | IF ((PTOCAS(ICAS).LE.PLOWH).OR.(PTOCAS(ICAS).GE.PHIH)) THEN | |
16487 | NINCHR(ICAS,2) = NINCHR(ICAS,2)+1 | |
16488 | C WRITE(LOUT,1002) IDXCAS,IDCAS,ICAS,PTOCAS(ICAS),NEVHKK | |
16489 | C1002 FORMAT(1X,'INUCAS: warning! momentum of particle with ', | |
16490 | C & 'index ',I5,' (id: ',I3,') ',I3,/,11X,'p_tot = ', | |
16491 | C & E12.4,', above or below HADRIN-thresholds',I6) | |
16492 | NSPE = 0 | |
16493 | GOTO 9997 | |
16494 | ENDIF | |
16495 | ||
16496 | DO 7 IDXHKK=1,NOINC | |
16497 | I = IDXINC(IDXHKK) | |
16498 | * scan DTEVT1 for unwounded or excited nucleons | |
16499 | IF ((ISTHKK(I).EQ.12+ICAS).OR.(ISTHKK(I).EQ.14+ICAS)) THEN | |
16500 | DO 8 K=1,3 | |
16501 | IF (ICAS.EQ.1) THEN | |
16502 | VTXDST(K) = WHKK(K,I)-VTXCAS(1,K) | |
16503 | ELSEIF (ICAS.EQ.2) THEN | |
16504 | VTXDST(K) = VHKK(K,I)-VTXCAS(2,K) | |
16505 | ENDIF | |
16506 | 8 CONTINUE | |
16507 | POSNUC = VTXDST(1)*COSCAS(ICAS,1)+ | |
16508 | & VTXDST(2)*COSCAS(ICAS,2)+ | |
16509 | & VTXDST(3)*COSCAS(ICAS,3) | |
16510 | * check if nucleon is situated in forward direction | |
16511 | IF (POSNUC.GT.ZERO) THEN | |
16512 | * distance between hadron and this nucleon | |
16513 | DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+ | |
16514 | & VTXDST(3)**2) | |
16515 | * impact parameter | |
16516 | BIMNU2 = DISTNU**2-POSNUC**2 | |
16517 | IF (BIMNU2.LT.ZERO) THEN | |
16518 | WRITE(LOUT,1001) DISTNU,POSNUC,BIMNU2 | |
16519 | 1001 FORMAT(1X,'INUCAS: warning! inconsistent impact', | |
16520 | & ' parameter ',/,20X,3E12.4) | |
16521 | GOTO 7 | |
16522 | ENDIF | |
16523 | BIMNU = SQRT(BIMNU2) | |
16524 | * maximum impact parameter to have interaction | |
16525 | IDNUC = IDT_ICIHAD(IDHKK(I)) | |
16526 | IDNUC1 = IDT_MCHAD(IDNUC) | |
16527 | IDCAS1 = IDT_MCHAD(IDCAS) | |
16528 | DO 19 K=1,5 | |
16529 | PCAS1(K) = PCAS(ICAS,K) | |
16530 | PNUC(K) = PHKK(K,I) | |
16531 | 19 CONTINUE | |
16532 | * Lorentz-parameter for trafo into rest-system of target | |
16533 | DO 18 K=1,4 | |
16534 | BGTA(K) = PNUC(K)/MAX(PNUC(5),TINY10) | |
16535 | 18 CONTINUE | |
16536 | * transformation of projectile into rest-system of target | |
16537 | CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3), | |
16538 | & PCAS1(1),PCAS1(2),PCAS1(3),PCAS1(4), | |
16539 | & PPTOT,PX,PY,PZ,PE) | |
16540 | ** | |
16541 | C CALL DT_SIHNIN(IDCAS1,IDNUC1,PPTOT,SIGIN) | |
16542 | C CALL DT_SIHNEL(IDCAS1,IDNUC1,PPTOT,SIGEL) | |
16543 | DUMZER = ZERO | |
16544 | CALL DT_XSHN(IDCAS1,IDNUC1,PPTOT,DUMZER,SIGTOT,SIGEL) | |
16545 | CALL DT_SIHNAB(IDCAS1,IDNUC1,PPTOT,SIGAB) | |
16546 | IF (((IDCAS1.EQ.13).OR.(IDCAS1.EQ.14)).AND. | |
16547 | & (PPTOT.LT.0.15D0)) SIGEL = SIGEL/2.0D0 | |
16548 | SIGIN = SIGTOT-SIGEL-SIGAB | |
16549 | C SIGTOT = SIGIN+SIGEL+SIGAB | |
16550 | ** | |
16551 | BIMMAX = SQRT(SIGTOT/(5.0D0*TWOPI))*FM2MM | |
16552 | * check if interaction is possible | |
16553 | IF (BIMNU.LE.BIMMAX) THEN | |
16554 | * get nucleon with smallest distance and kind of interaction | |
16555 | * (elastic/inelastic) | |
16556 | IF (DISTNU.LT.DIST) THEN | |
16557 | DIST = DISTNU | |
16558 | BINT = BIMNU | |
16559 | IF (IDNUC.NE.IDSPE(1)) THEN | |
16560 | IDSPE(2) = IDSPE(1) | |
16561 | IDXSPE(2) = IDXSPE(1) | |
16562 | IDSPE(1) = IDNUC | |
16563 | ENDIF | |
16564 | IDXSPE(1) = I | |
16565 | NSPE = 1 | |
16566 | **sr | |
16567 | SELA = SIGEL | |
16568 | SABS = SIGAB | |
16569 | STOT = SIGTOT | |
16570 | C IF ((IDCAS.EQ.2).OR.(IDCAS.EQ.9)) THEN | |
16571 | C SELA = SIGEL | |
16572 | C STOT = SIGIN+SIGEL | |
16573 | C ELSE | |
16574 | C SELA = SIGEL+0.75D0*SIGIN | |
16575 | C STOT = 0.25D0*SIGIN+SELA | |
16576 | C ENDIF | |
16577 | ** | |
16578 | ENDIF | |
16579 | ENDIf | |
16580 | ENDIF | |
16581 | DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+ | |
16582 | & VTXDST(3)**2) | |
16583 | IDNUC = IDT_ICIHAD(IDHKK(I)) | |
16584 | IF (IDNUC.EQ.1) THEN | |
16585 | IF (DISTNU.LT.DISTP) THEN | |
16586 | DISTP = DISTNU | |
16587 | IDXP = I | |
16588 | POSP = POSNUC | |
16589 | ENDIF | |
16590 | ELSEIF (IDNUC.EQ.8) THEN | |
16591 | IF (DISTNU.LT.DISTN) THEN | |
16592 | DISTN = DISTNU | |
16593 | IDXN = I | |
16594 | POSN = POSNUC | |
16595 | ENDIF | |
16596 | ENDIF | |
16597 | ENDIF | |
16598 | 7 CONTINUE | |
16599 | ||
16600 | * there is no nucleon for a secondary interaction | |
16601 | IF (NSPE.EQ.0) GOTO 9997 | |
16602 | ||
16603 | C IF ((IDCAS.EQ.13).AND.((PCAS(ICAS,4)-PCAS(ICAS,5)).LT.0.1D0)) | |
16604 | C & WRITE(LOUT,*) STOT,SELA,SABS,IDXSPE | |
16605 | IF (IDXSPE(2).EQ.0) THEN | |
16606 | IF ((IDSPE(1).EQ.1).AND.(IDXN.GT.0)) THEN | |
16607 | C DO 80 K=1,3 | |
16608 | C IF (ICAS.EQ.1) THEN | |
16609 | C VTXDST(K) = WHKK(K,IDXN)-WHKK(K,IDXSPE(1)) | |
16610 | C ELSEIF (ICAS.EQ.2) THEN | |
16611 | C VTXDST(K) = VHKK(K,IDXN)-VHKK(K,IDXSPE(1)) | |
16612 | C ENDIF | |
16613 | C 80 CONTINUE | |
16614 | C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+ | |
16615 | C & VTXDST(3)**2) | |
16616 | C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSN.GT.ZERO)) THEN | |
16617 | IDXSPE(2) = IDXN | |
16618 | IDSPE(2) = 8 | |
16619 | C ELSE | |
16620 | C STOT = STOT-SABS | |
16621 | C SABS = ZERO | |
16622 | C ENDIF | |
16623 | ELSEIF ((IDSPE(1).EQ.8).AND.(IDXP.GT.0)) THEN | |
16624 | C DO 81 K=1,3 | |
16625 | C IF (ICAS.EQ.1) THEN | |
16626 | C VTXDST(K) = WHKK(K,IDXP)-WHKK(K,IDXSPE(1)) | |
16627 | C ELSEIF (ICAS.EQ.2) THEN | |
16628 | C VTXDST(K) = VHKK(K,IDXP)-VHKK(K,IDXSPE(1)) | |
16629 | C ENDIF | |
16630 | C 81 CONTINUE | |
16631 | C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+ | |
16632 | C & VTXDST(3)**2) | |
16633 | C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSP.GT.ZERO)) THEN | |
16634 | IDXSPE(2) = IDXP | |
16635 | IDSPE(2) = 1 | |
16636 | C ELSE | |
16637 | C STOT = STOT-SABS | |
16638 | C SABS = ZERO | |
16639 | C ENDIF | |
16640 | ELSE | |
16641 | STOT = STOT-SABS | |
16642 | SABS = ZERO | |
16643 | ENDIF | |
16644 | ENDIF | |
16645 | RR = DT_RNDM(DIST) | |
16646 | IF (RR.LT.SELA/STOT) THEN | |
16647 | IPROC = 2 | |
16648 | ELSEIF ((RR.GE.SELA/STOT).AND.(RR.LT.(SELA+SABS)/STOT)) THEN | |
16649 | IPROC = 3 | |
16650 | ELSE | |
16651 | IPROC = 1 | |
16652 | ENDIF | |
16653 | ||
16654 | DO 9 K=1,5 | |
16655 | PCAS1(K) = PCAS(ICAS,K) | |
16656 | PNUC(K) = PHKK(K,IDXSPE(1)) | |
16657 | 9 CONTINUE | |
16658 | IF (IPROC.EQ.3) THEN | |
16659 | * 2-nucleon absorption of pion | |
16660 | NSPE = 2 | |
16661 | CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,1,IREJ1) | |
16662 | IF (IREJ1.NE.0) GOTO 9999 | |
16663 | IF (NSPE.GE.1) LABSOR = .TRUE. | |
16664 | ELSE | |
16665 | * sample secondary interaction | |
16666 | IDNUC = IDBAM(IDXSPE(1)) | |
16667 | CALL DT_HADRIN(IDCAS,PCAS1,IDNUC,PNUC,IPROC,IREJ1) | |
16668 | IF (IREJ1.EQ.1) GOTO 9999 | |
16669 | IF (IREJ1.GT.1) GOTO 9998 | |
16670 | ENDIF | |
16671 | ENDIF | |
16672 | ||
16673 | * update arrays to include Pauli-principle | |
16674 | DO 10 I=1,NSPE | |
16675 | IF (NWOUND(ICAS).LE.299) THEN | |
16676 | NWOUND(ICAS) = NWOUND(ICAS)+1 | |
16677 | EWOUND(ICAS,NWOUND(ICAS)) = PHKK(4,IDXSPE(I)) | |
16678 | ENDIF | |
16679 | 10 CONTINUE | |
16680 | ||
16681 | * dump initial hadron for energy-momentum conservation check | |
16682 | IF (LEMCCK) | |
16683 | & CALL DT_EVTEMC(PCAS(ICAS,1),PCAS(ICAS,2),PCAS(ICAS,3), | |
16684 | & PCAS(ICAS,4),1,IDUM,IDUM) | |
16685 | ||
16686 | * dump final state particles into DTEVT1 | |
16687 | ||
16688 | * check if Pauli-principle is fulfilled | |
16689 | NPAULI = 0 | |
16690 | NWTMP(1) = NWOUND(1) | |
16691 | NWTMP(2) = NWOUND(2) | |
16692 | DO 111 I=1,NFSP | |
16693 | NPAULI = 0 | |
16694 | J1 = 2 | |
16695 | IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR. | |
16696 | & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1 | |
16697 | DO 117 J=1,J1 | |
16698 | IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 117 | |
16699 | IF (J.EQ.1) THEN | |
16700 | IDX = ICAS | |
16701 | PE = PFSP(4,I) | |
16702 | ELSE | |
16703 | IDX = I2 | |
16704 | MODE = 1 | |
16705 | IF (IDX.EQ.1) MODE = -1 | |
16706 | CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,MODE) | |
16707 | ENDIF | |
16708 | * first check if cascade step is forbidden due to Pauli-principle | |
16709 | * (in case of absorpion this step is forced) | |
16710 | IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR. | |
16711 | & (IDFSP(I).EQ.8))) THEN | |
16712 | * get nuclear potential barrier | |
16713 | POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I)) | |
16714 | IF (IDFSP(I).EQ.1) THEN | |
16715 | POTLOW = POT-EBINDP(IDX) | |
16716 | ELSE | |
16717 | POTLOW = POT-EBINDN(IDX) | |
16718 | ENDIF | |
16719 | * final state particle not able to escape nucleus | |
16720 | IF (PE.LE.POTLOW) THEN | |
16721 | * check if there are wounded nucleons | |
16722 | IF ((NWOUND(IDX).GE.1).AND.(PE.GE. | |
16723 | & EWOUND(IDX,NWOUND(IDX)))) THEN | |
16724 | NPAULI = NPAULI+1 | |
16725 | NWOUND(IDX) = NWOUND(IDX)-1 | |
16726 | ELSE | |
16727 | * interaction prohibited by Pauli-principle | |
16728 | NWOUND(1) = NWTMP(1) | |
16729 | NWOUND(2) = NWTMP(2) | |
16730 | GOTO 9997 | |
16731 | ENDIF | |
16732 | ENDIF | |
16733 | ENDIF | |
16734 | 117 CONTINUE | |
16735 | 111 CONTINUE | |
16736 | ||
16737 | NPAULI = 0 | |
16738 | NWOUND(1) = NWTMP(1) | |
16739 | NWOUND(2) = NWTMP(2) | |
16740 | ||
16741 | DO 11 I=1,NFSP | |
16742 | ||
16743 | IST = ISTHKK(IDXCAS) | |
16744 | ||
16745 | NPAULI = 0 | |
16746 | J1 = 2 | |
16747 | IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR. | |
16748 | & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1 | |
16749 | DO 17 J=1,J1 | |
16750 | IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 17 | |
16751 | IDX = ICAS | |
16752 | PE = PFSP(4,I) | |
16753 | IF (J.EQ.2) THEN | |
16754 | IDX = I2 | |
16755 | CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,NCAS) | |
16756 | ENDIF | |
16757 | * first check if cascade step is forbidden due to Pauli-principle | |
16758 | * (in case of absorpion this step is forced) | |
16759 | IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR. | |
16760 | & (IDFSP(I).EQ.8))) THEN | |
16761 | * get nuclear potential barrier | |
16762 | POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I)) | |
16763 | IF (IDFSP(I).EQ.1) THEN | |
16764 | POTLOW = POT-EBINDP(IDX) | |
16765 | ELSE | |
16766 | POTLOW = POT-EBINDN(IDX) | |
16767 | ENDIF | |
16768 | * final state particle not able to escape nucleus | |
16769 | IF (PE.LE.POTLOW) THEN | |
16770 | * check if there are wounded nucleons | |
16771 | IF ((NWOUND(IDX).GE.1).AND.(PE.GE. | |
16772 | & EWOUND(IDX,NWOUND(IDX)))) THEN | |
16773 | NWOUND(IDX) = NWOUND(IDX)-1 | |
16774 | NPAULI = NPAULI+1 | |
16775 | IST = 14+IDX | |
16776 | ELSE | |
16777 | * interaction prohibited by Pauli-principle | |
16778 | NWOUND(1) = NWTMP(1) | |
16779 | NWOUND(2) = NWTMP(2) | |
16780 | GOTO 9997 | |
16781 | ENDIF | |
16782 | **sr | |
16783 | c ELSEIF (PE.LE.POT) THEN | |
16784 | cC ELSEIF ((PE.LE.POT).AND.(NWOUND(IDX).GE.1)) THEN | |
16785 | cC NWOUND(IDX) = NWOUND(IDX)-1 | |
16786 | c** | |
16787 | c NPAULI = NPAULI+1 | |
16788 | c IST = 14+IDX | |
16789 | ENDIF | |
16790 | ENDIF | |
16791 | 17 CONTINUE | |
16792 | ||
16793 | * dump final state particles for energy-momentum conservation check | |
16794 | IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),-PFSP(3,I), | |
16795 | & -PFSP(4,I),2,IDUM,IDUM) | |
16796 | ||
16797 | PX = PFSP(1,I) | |
16798 | PY = PFSP(2,I) | |
16799 | PZ = PFSP(3,I) | |
16800 | PE = PFSP(4,I) | |
16801 | IF (ABS(IST).EQ.1) THEN | |
16802 | * transform particles back into n-n cms | |
16803 | * LEPTO: leave final state particles in target rest frame | |
16804 | C IF (MCGENE.EQ.3) THEN | |
16805 | C PFSP(1,I) = PX | |
16806 | C PFSP(2,I) = PY | |
16807 | C PFSP(3,I) = PZ | |
16808 | C PFSP(4,I) = PE | |
16809 | C ELSE | |
16810 | IMODE = ICAS+1 | |
16811 | CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I), | |
16812 | & PFSP(4,I),IDFSP(I),IMODE) | |
16813 | C ENDIF | |
16814 | ELSEIF ((ICAS.EQ.2).AND.(IST.EQ.15)) THEN | |
16815 | * target cascade but fsp got stuck in proj. --> transform it into | |
16816 | * proj. rest system | |
16817 | CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I), | |
16818 | & PFSP(4,I),IDFSP(I),-1) | |
16819 | ELSEIF ((ICAS.EQ.1).AND.(IST.EQ.16)) THEN | |
16820 | * proj. cascade but fsp got stuck in target --> transform it into | |
16821 | * target rest system | |
16822 | CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I), | |
16823 | & PFSP(4,I),IDFSP(I),1) | |
16824 | ENDIF | |
16825 | ||
16826 | * dump final state particles into DTEVT1 | |
16827 | IGEN = IDCH(IDXCAS)+1 | |
16828 | ID = IDT_IPDGHA(IDFSP(I)) | |
16829 | IXR = 0 | |
16830 | IF (LABSOR) IXR = 99 | |
16831 | CALL DT_EVTPUT(IST,ID,IDXCAS,IDXSPE(1),PFSP(1,I), | |
16832 | & PFSP(2,I),PFSP(3,I),PFSP(4,I),0,IXR,IGEN) | |
16833 | ||
16834 | * update the counter for particles which got stuck inside the nucleus | |
16835 | IF ((IST.EQ.15).OR.(IST.EQ.16)) THEN | |
16836 | NOINC = NOINC+1 | |
16837 | IDXINC(NOINC) = NHKK | |
16838 | ENDIF | |
16839 | IF (LABSOR) THEN | |
16840 | * in case of absorption the spatial treatment is an approximate | |
16841 | * solution anyway (the positions of the nucleons which "absorb" the | |
16842 | * cascade particle are not taken into consideration) therefore the | |
16843 | * particles are produced at the position of the cascade particle | |
16844 | DO 12 K=1,4 | |
16845 | WHKK(K,NHKK) = WHKK(K,IDXCAS) | |
16846 | VHKK(K,NHKK) = VHKK(K,IDXCAS) | |
16847 | 12 CONTINUE | |
16848 | ELSE | |
16849 | * DDISTL - distance the cascade particle moves to the intera. point | |
16850 | * (the position where impact-parameter = distance to the interacting | |
16851 | * nucleon), DIST - distance to the interacting nucleon at the time of | |
16852 | * formation of the cascade particle, BINT - impact-parameter of this | |
16853 | * cascade-interaction | |
16854 | DDISTL = SQRT(DIST**2-BINT**2) | |
16855 | DTIME = DDISTL/BECAS(ICAS) | |
16856 | DTIMEL = DDISTL/BGCAS(ICAS) | |
16857 | RDISTL = DTIMEL*BGCAS(I2) | |
16858 | IF ((IP.GT.1).AND.(IT.GT.1)) THEN | |
16859 | RTIME = RDISTL/BECAS(I2) | |
16860 | ELSE | |
16861 | RTIME = ZERO | |
16862 | ENDIF | |
16863 | * RDISTL, RTIME are this step and time in the rest system of the other | |
16864 | * nucleus | |
16865 | DO 13 K=1,3 | |
16866 | VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+COSCAS(ICAS,K)*DDISTL | |
16867 | VTXCA1(I2,K) = VTXCAS(I2,K) +COSCAS(I2,K) *RDISTL | |
16868 | 13 CONTINUE | |
16869 | VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME | |
16870 | VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME | |
16871 | * position of particle production is half the impact-parameter to | |
16872 | * the interacting nucleon | |
16873 | DO 14 K=1,3 | |
16874 | WHKK(K,NHKK) = OHALF*(VTXCA1(1,K)+WHKK(K,IDXSPE(1))) | |
16875 | VHKK(K,NHKK) = OHALF*(VTXCA1(2,K)+VHKK(K,IDXSPE(1))) | |
16876 | 14 CONTINUE | |
16877 | * time of production of secondary = time of interaction | |
16878 | WHKK(4,NHKK) = VTXCA1(1,4) | |
16879 | VHKK(4,NHKK) = VTXCA1(2,4) | |
16880 | ENDIF | |
16881 | ||
16882 | 11 CONTINUE | |
16883 | ||
16884 | * modify status and position of cascade particle (the latter for | |
16885 | * statistics reasons only) | |
16886 | ISTHKK(IDXCAS) = 2 | |
16887 | IF (LABSOR) ISTHKK(IDXCAS) = 19 | |
16888 | IF (.NOT.LABSOR) THEN | |
16889 | DO 15 K=1,4 | |
16890 | WHKK(K,IDXCAS) = VTXCA1(1,K) | |
16891 | VHKK(K,IDXCAS) = VTXCA1(2,K) | |
16892 | 15 CONTINUE | |
16893 | ENDIF | |
16894 | ||
16895 | DO 16 I=1,NSPE | |
16896 | IS = IDXSPE(I) | |
16897 | * dump interacting nucleons for energy-momentum conservation check | |
16898 | IF (LEMCCK) | |
16899 | & CALL DT_EVTEMC(PHKK(1,IS),PHKK(2,IS),PHKK(3,IS),PHKK(4,IS), | |
16900 | & 2,IDUM,IDUM) | |
16901 | * modify entry for interacting nucleons | |
16902 | IF (ISTHKK(IS).EQ.12+ICAS) ISTHKK(IS)=16+ICAS | |
16903 | IF (ISTHKK(IS).EQ.14+ICAS) ISTHKK(IS)=2 | |
16904 | IF (I.GE.2) THEN | |
16905 | JDAHKK(1,IS) = JDAHKK(1,IDXSPE(1)) | |
16906 | JDAHKK(2,IS) = JDAHKK(2,IDXSPE(1)) | |
16907 | ENDIF | |
16908 | 16 CONTINUE | |
16909 | ||
16910 | * check energy-momentum conservation | |
16911 | IF (LEMCCK) THEN | |
16912 | CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,500,IREJ1) | |
16913 | IF (IREJ1.NE.0) GOTO 9999 | |
16914 | ENDIF | |
16915 | ||
16916 | * update counter | |
16917 | IF (LABSOR) THEN | |
16918 | NINCCO(ICAS,1) = NINCCO(ICAS,1)+1 | |
16919 | ELSE | |
16920 | IF (IPROC.EQ.1) NINCCO(ICAS,2) = NINCCO(ICAS,2)+1 | |
16921 | IF (IPROC.EQ.2) NINCCO(ICAS,3) = NINCCO(ICAS,3)+1 | |
16922 | ENDIF | |
16923 | ||
16924 | RETURN | |
16925 | ||
16926 | 9997 CONTINUE | |
16927 | 9998 CONTINUE | |
16928 | * transport-step but no cascade step due to configuration (i.e. there | |
16929 | * is no nucleon for interaction etc.) | |
16930 | IF (LCAS) THEN | |
16931 | DO 100 K=1,4 | |
16932 | C WHKK(K,IDXCAS) = VTXCAS(1,K) | |
16933 | C VHKK(K,IDXCAS) = VTXCAS(2,K) | |
16934 | WHKK(K,IDXCAS) = VTXCA1(1,K) | |
16935 | VHKK(K,IDXCAS) = VTXCA1(2,K) | |
16936 | 100 CONTINUE | |
16937 | ENDIF | |
16938 | ||
16939 | C9998 CONTINUE | |
16940 | * no cascade-step because of configuration | |
16941 | * (i.e. hadron outside nucleus etc.) | |
16942 | LCAS = .TRUE. | |
16943 | RETURN | |
16944 | ||
16945 | 9999 CONTINUE | |
16946 | * rejection | |
16947 | IREJ = 1 | |
16948 | RETURN | |
16949 | END | |
16950 | ||
16951 | *$ CREATE DT_ABSORP.FOR | |
16952 | *COPY DT_ABSORP | |
16953 | * | |
16954 | *===absorp=============================================================* | |
16955 | * | |
16956 | SUBROUTINE DT_ABSORP(IDCAS,PCAS,NCAS,NSPE,IDSPE,IDXSPE,MODE,IREJ) | |
16957 | ||
16958 | ************************************************************************ | |
16959 | * Two-nucleon absorption of antiprotons, pi-, and K-. * | |
16960 | * Antiproton absorption is handled by HADRIN. * | |
16961 | * The following channels for meson-absorption are considered: * | |
16962 | * pi- + p + p ---> n + p * | |
16963 | * pi- + p + n ---> n + n * | |
16964 | * K- + p + p ---> sigma+ + n / Lam + p / sigma0 + p * | |
16965 | * K- + p + n ---> sigma- + n / Lam + n / sigma0 + n * | |
16966 | * K- + p + p ---> sigma- + n * | |
16967 | * IDCAS, PCAS identity, momentum of particle to be absorbed * | |
16968 | * NCAS = 1 intranuclear cascade in projectile * | |
16969 | * = -1 intranuclear cascade in target * | |
16970 | * NSPE number of spectator nucleons involved * | |
16971 | * IDXSPE(2) DTEVT1-indices of spectator nucleons involved * | |
16972 | * Revised version of the original STOPIK written by HJM and J. Ranft. * | |
16973 | * This version dated 24.02.95 is written by S. Roesler * | |
16974 | ************************************************************************ | |
16975 | ||
16976 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
16977 | SAVE | |
16978 | PARAMETER ( LINP = 10 , | |
16979 | & LOUT = 6 , | |
16980 | & LDAT = 9 ) | |
16981 | PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,ONE=1.0D0, | |
16982 | & ONETHI=0.3333D0,TWOTHI=0.6666D0) | |
16983 | ||
16984 | * event history | |
16985 | PARAMETER (NMXHKK=200000) | |
16986 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
16987 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
16988 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
16989 | * extended event history | |
16990 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
16991 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
16992 | & IHIST(2,NMXHKK) | |
16993 | * flags for input different options | |
16994 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
16995 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
16996 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
16997 | * final state after inc step | |
16998 | PARAMETER (MAXFSP=10) | |
16999 | COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP | |
17000 | * particle properties (BAMJET index convention) | |
17001 | CHARACTER*8 ANAME | |
17002 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
17003 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
17004 | ||
17005 | DIMENSION PCAS(5),IDXSPE(2),IDSPE(2),PSPE(2,5),PSPE1(5), | |
17006 | & PTOT3P(4),BG3P(4), | |
17007 | & ECMF(2),PCMF(2),CODF(2),COFF(2),SIFF(2) | |
17008 | ||
17009 | IREJ = 0 | |
17010 | NFSP = 0 | |
17011 | ||
17012 | * skip particles others than ap, pi-, K- for mode=0 | |
17013 | IF ((MODE.EQ.0).AND. | |
17014 | & (IDCAS.NE.2).AND.(IDCAS.NE.14).AND.(IDCAS.NE.16)) RETURN | |
17015 | * skip particles others than pions for mode=1 | |
17016 | * (2-nucleon absorption in intranuclear cascade) | |
17017 | IF ((MODE.EQ.1).AND. | |
17018 | & (IDCAS.NE.13).AND.(IDCAS.NE.14).AND.(IDCAS.NE.23)) RETURN | |
17019 | ||
17020 | NUCAS = NCAS | |
17021 | IF (NUCAS.EQ.-1) NUCAS = 2 | |
17022 | ||
17023 | IF (MODE.EQ.0) THEN | |
17024 | * scan spectator nucleons for nucleons being able to "absorb" | |
17025 | NSPE = 0 | |
17026 | IDXSPE(1) = 0 | |
17027 | IDXSPE(2) = 0 | |
17028 | DO 1 I=1,NHKK | |
17029 | IF ((ISTHKK(I).EQ.12+NUCAS).OR.(ISTHKK(I).EQ.14+NUCAS)) THEN | |
17030 | NSPE = NSPE+1 | |
17031 | IDXSPE(NSPE) = I | |
17032 | IDSPE(NSPE) = IDBAM(I) | |
17033 | IF ((NSPE.EQ.1).AND.(IDCAS.EQ.2)) GOTO 2 | |
17034 | IF (NSPE.EQ.2) THEN | |
17035 | IF ((IDCAS.EQ.14).AND.(IDSPE(1).EQ.8).AND. | |
17036 | & (IDSPE(2).EQ.8)) THEN | |
17037 | * there is no pi-+n+n channel | |
17038 | NSPE = 1 | |
17039 | GOTO 1 | |
17040 | ELSE | |
17041 | GOTO 2 | |
17042 | ENDIF | |
17043 | ENDIF | |
17044 | ENDIF | |
17045 | 1 CONTINUE | |
17046 | ||
17047 | 2 CONTINUE | |
17048 | ENDIF | |
17049 | * transform excited projectile nucleons (status=15) into proj. rest s. | |
17050 | DO 3 I=1,NSPE | |
17051 | DO 4 K=1,5 | |
17052 | PSPE(I,K) = PHKK(K,IDXSPE(I)) | |
17053 | 4 CONTINUE | |
17054 | 3 CONTINUE | |
17055 | ||
17056 | * antiproton absorption | |
17057 | IF ((IDCAS.EQ.2).AND.(NSPE.GE.1)) THEN | |
17058 | DO 5 K=1,5 | |
17059 | PSPE1(K) = PSPE(1,K) | |
17060 | 5 CONTINUE | |
17061 | CALL DT_HADRIN(IDCAS,PCAS,IDSPE(1),PSPE1,1,IREJ1) | |
17062 | IF (IREJ1.NE.0) GOTO 9999 | |
17063 | ||
17064 | * meson absorption | |
17065 | ELSEIF (((IDCAS.EQ.13).OR.(IDCAS.EQ.14).OR.(IDCAS.EQ.23) | |
17066 | & .OR.(IDCAS.EQ.16)).AND.(NSPE.GE.2)) THEN | |
17067 | IF (IDCAS.EQ.14) THEN | |
17068 | * pi- absorption | |
17069 | IDFSP(1) = 8 | |
17070 | IDFSP(2) = 8 | |
17071 | IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) IDFSP(2) = 1 | |
17072 | ELSEIF (IDCAS.EQ.13) THEN | |
17073 | * pi+ absorption | |
17074 | IDFSP(1) = 1 | |
17075 | IDFSP(2) = 1 | |
17076 | IF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) IDFSP(2) = 8 | |
17077 | ELSEIF (IDCAS.EQ.23) THEN | |
17078 | * pi0 absorption | |
17079 | IDFSP(1) = IDSPE(1) | |
17080 | IDFSP(2) = IDSPE(2) | |
17081 | ELSEIF (IDCAS.EQ.16) THEN | |
17082 | * K- absorption | |
17083 | R = DT_RNDM(PCAS) | |
17084 | IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) THEN | |
17085 | IF (R.LT.ONETHI) THEN | |
17086 | IDFSP(1) = 21 | |
17087 | IDFSP(2) = 8 | |
17088 | ELSEIF (R.LT.TWOTHI) THEN | |
17089 | IDFSP(1) = 17 | |
17090 | IDFSP(2) = 1 | |
17091 | ELSE | |
17092 | IDFSP(1) = 22 | |
17093 | IDFSP(2) = 1 | |
17094 | ENDIF | |
17095 | ELSEIF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) THEN | |
17096 | IDFSP(1) = 20 | |
17097 | IDFSP(2) = 8 | |
17098 | ELSE | |
17099 | IF (R.LT.ONETHI) THEN | |
17100 | IDFSP(1) = 20 | |
17101 | IDFSP(2) = 1 | |
17102 | ELSEIF (R.LT.TWOTHI) THEN | |
17103 | IDFSP(1) = 17 | |
17104 | IDFSP(2) = 8 | |
17105 | ELSE | |
17106 | IDFSP(1) = 22 | |
17107 | IDFSP(2) = 8 | |
17108 | ENDIF | |
17109 | ENDIF | |
17110 | ENDIF | |
17111 | * dump initial particles for energy-momentum cons. check | |
17112 | IF (LEMCCK) THEN | |
17113 | CALL DT_EVTEMC(PCAS(1),PCAS(2),PCAS(3),PCAS(4),1,IDUM,IDUM) | |
17114 | CALL DT_EVTEMC(PSPE(1,1),PSPE(1,2),PSPE(1,3),PSPE(1,4),2, | |
17115 | & IDUM,IDUM) | |
17116 | CALL DT_EVTEMC(PSPE(2,1),PSPE(2,2),PSPE(2,3),PSPE(2,4),2, | |
17117 | & IDUM,IDUM) | |
17118 | ENDIF | |
17119 | * get Lorentz-parameter of 3 particle initial state | |
17120 | DO 6 K=1,4 | |
17121 | PTOT3P(K) = PCAS(K)+PSPE(1,K)+PSPE(2,K) | |
17122 | 6 CONTINUE | |
17123 | P3P = SQRT(PTOT3P(1)**2+PTOT3P(2)**2+PTOT3P(3)**2) | |
17124 | AM3P = SQRT( (PTOT3P(4)-P3P)*(PTOT3P(4)+P3P) ) | |
17125 | DO 7 K=1,4 | |
17126 | BG3P(K) = PTOT3P(K)/MAX(AM3P,TINY10) | |
17127 | 7 CONTINUE | |
17128 | * 2-particle decay of the 3-particle compound system | |
17129 | CALL DT_DTWOPD(AM3P,ECMF(1),ECMF(2),PCMF(1),PCMF(2), | |
17130 | & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2), | |
17131 | & AAM(IDFSP(1)),AAM(IDFSP(2))) | |
17132 | DO 8 I=1,2 | |
17133 | SDF = SQRT((ONE-CODF(I))*(ONE+CODF(I))) | |
17134 | PX = PCMF(I)*COFF(I)*SDF | |
17135 | PY = PCMF(I)*SIFF(I)*SDF | |
17136 | PZ = PCMF(I)*CODF(I) | |
17137 | CALL DT_DALTRA(BG3P(4),BG3P(1),BG3P(2),BG3P(3),PX,PY,PZ, | |
17138 | & ECMF(I),PTOFSP,PFSP(1,I),PFSP(2,I),PFSP(3,I), | |
17139 | & PFSP(4,I)) | |
17140 | PFSP(5,I) = SQRT( (PFSP(4,I)-PTOFSP)*(PFSP(4,I)+PTOFSP) ) | |
17141 | * check consistency of kinematics | |
17142 | IF (ABS(AAM(IDFSP(I))-PFSP(5,I)).GT.TINY5) THEN | |
17143 | WRITE(LOUT,1001) IDFSP(I),AAM(IDFSP(I)),PFSP(5,I) | |
17144 | 1001 FORMAT(1X,'ABSORP: warning! inconsistent', | |
17145 | & ' tree-particle kinematics',/,20X,'id: ',I3, | |
17146 | & ' AAM = ',E10.4,' MFSP = ',E10.4) | |
17147 | ENDIF | |
17148 | * dump final state particles for energy-momentum cons. check | |
17149 | IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I), | |
17150 | & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM) | |
17151 | 8 CONTINUE | |
17152 | NFSP = 2 | |
17153 | IF (LEMCCK) THEN | |
17154 | CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,100,IREJ1) | |
17155 | IF (IREJ1.NE.0) THEN | |
17156 | WRITE(LOUT,*)'ABSORB: EMC ',AAM(IDFSP(1)),AAM(IDFSP(2)), | |
17157 | & AM3P | |
17158 | GOTO 9999 | |
17159 | ENDIF | |
17160 | ENDIF | |
17161 | ELSE | |
17162 | IF (IOULEV(3).GT.0) WRITE(LOUT,1000) IDCAS,NSPE | |
17163 | 1000 FORMAT(1X,'ABSORP: warning! absorption for particle ',I3, | |
17164 | & ' impossible',/,20X,'too few spectators (',I2,')') | |
17165 | NSPE = 0 | |
17166 | ENDIF | |
17167 | ||
17168 | RETURN | |
17169 | ||
17170 | 9999 CONTINUE | |
17171 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in ABSORP' | |
17172 | IREJ = 1 | |
17173 | RETURN | |
17174 | END | |
17175 | ||
17176 | *$ CREATE DT_HADRIN.FOR | |
17177 | *COPY DT_HADRIN | |
17178 | * | |
17179 | *===hadrin=============================================================* | |
17180 | * | |
17181 | SUBROUTINE DT_HADRIN(IDPR,PPR,IDTA,PTA,MODE,IREJ) | |
17182 | ||
17183 | ************************************************************************ | |
17184 | * Interface to the HADRIN-routines for inelastic and elastic * | |
17185 | * scattering. * | |
17186 | * IDPR,PPR(5) identity, momentum of projectile * | |
17187 | * IDTA,PTA(5) identity, momentum of target * | |
17188 | * MODE = 1 inelastic interaction * | |
17189 | * = 2 elastic interaction * | |
17190 | * Revised version of the original FHAD. * | |
17191 | * This version dated 27.10.95 is written by S. Roesler * | |
17192 | ************************************************************************ | |
17193 | ||
17194 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
17195 | SAVE | |
17196 | PARAMETER ( LINP = 10 , | |
17197 | & LOUT = 6 , | |
17198 | & LDAT = 9 ) | |
17199 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3, | |
17200 | & TINY2=1.0D-2,TINY1=1.0D-1,ONE=1.0D0) | |
17201 | ||
17202 | LOGICAL LCORR,LMSSG | |
17203 | ||
17204 | * flags for input different options | |
17205 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
17206 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
17207 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
17208 | * final state after inc step | |
17209 | PARAMETER (MAXFSP=10) | |
17210 | COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP | |
17211 | * particle properties (BAMJET index convention) | |
17212 | CHARACTER*8 ANAME | |
17213 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
17214 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
17215 | * output-common for DHADRI/ELHAIN | |
17216 | * final state from HADRIN interaction | |
17217 | PARAMETER (MAXFIN=10) | |
17218 | COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN), | |
17219 | & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH | |
17220 | ||
17221 | DIMENSION PPR(5),PPR1(5),PTA(5),BGTA(4), | |
17222 | & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4),IMCORR(2) | |
17223 | ||
17224 | DATA LMSSG /.TRUE./ | |
17225 | ||
17226 | IREJ = 0 | |
17227 | NFSP = 0 | |
17228 | KCORR = 0 | |
17229 | IMCORR(1) = 0 | |
17230 | IMCORR(2) = 0 | |
17231 | LCORR = .FALSE. | |
17232 | ||
17233 | * dump initial particles for energy-momentum cons. check | |
17234 | IF (LEMCCK) THEN | |
17235 | CALL DT_EVTEMC(PPR(1),PPR(2),PPR(3),PPR(4),1,IDUM,IDUM) | |
17236 | CALL DT_EVTEMC(PTA(1),PTA(2),PTA(3),PTA(4),2,IDUM,IDUM) | |
17237 | ENDIF | |
17238 | ||
17239 | AMP2 = PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2 | |
17240 | AMT2 = PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2 | |
17241 | IF ((AMP2.LT.ZERO).OR.(AMT2.LT.ZERO).OR. | |
17242 | & (ABS(AMP2-AAM(IDPR)**2).GT.TINY5).OR. | |
17243 | & (ABS(AMT2-AAM(IDTA)**2).GT.TINY5)) THEN | |
17244 | IF (LMSSG.AND.(IOULEV(3).GT.0)) | |
17245 | & WRITE(LOUT,1000) AMP2,AAM(IDPR)**2,AMT2,AAM(IDTA)**2 | |
17246 | 1000 FORMAT(1X,'HADRIN: warning! inconsistent projectile/target', | |
17247 | & ' mass',/,20X,'AMP2 = ',E12.4,', AAM(IDPR)**2 = ', | |
17248 | & E12.4,/,20X,'AMT2 = ',E12.4,', AAM(IDTA)**2 = ',E12.4) | |
17249 | LMSSG = .FALSE. | |
17250 | LCORR = .TRUE. | |
17251 | ENDIF | |
17252 | ||
17253 | * convert initial state particles into particles which can be | |
17254 | * handled by HADRIN | |
17255 | IDHPR = IDPR | |
17256 | IDHTA = IDTA | |
17257 | IF ((IDHPR.LE.0).OR.(IDHPR.GE.111).OR.LCORR) THEN | |
17258 | IF ((IDHPR.LE.0).OR.(IDHPR.GE.111)) IDHPR = 1 | |
17259 | DO 1 K=1,4 | |
17260 | P1IN(K) = PPR(K) | |
17261 | P2IN(K) = PTA(K) | |
17262 | 1 CONTINUE | |
17263 | XM1 = AAM(IDHPR) | |
17264 | XM2 = AAM(IDHTA) | |
17265 | CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1) | |
17266 | IF (IREJ1.GT.0) THEN | |
17267 | WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.' | |
17268 | GOTO 9999 | |
17269 | ENDIF | |
17270 | DO 2 K=1,4 | |
17271 | PPR(K) = P1OUT(K) | |
17272 | PTA(K) = P2OUT(K) | |
17273 | 2 CONTINUE | |
17274 | PPR(5) = SQRT(PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2) | |
17275 | PTA(5) = SQRT(PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2) | |
17276 | ENDIF | |
17277 | ||
17278 | * Lorentz-parameter for trafo into rest-system of target | |
17279 | DO 3 K=1,4 | |
17280 | BGTA(K) = PTA(K)/PTA(5) | |
17281 | 3 CONTINUE | |
17282 | * transformation of projectile into rest-system of target | |
17283 | CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),PPR(1),PPR(2), | |
17284 | & PPR(3),PPR(4),PPRTO1,PPR1(1),PPR1(2),PPR1(3), | |
17285 | & PPR1(4)) | |
17286 | ||
17287 | * direction cosines of projectile in target rest system | |
17288 | CX = PPR1(1)/PPRTO1 | |
17289 | CY = PPR1(2)/PPRTO1 | |
17290 | CZ = PPR1(3)/PPRTO1 | |
17291 | ||
17292 | * sample inelastic interaction | |
17293 | IF (MODE.EQ.1) THEN | |
17294 | CALL DT_DHADRI(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA) | |
17295 | IF (IRH.EQ.1) GOTO 9998 | |
17296 | * sample elastic interaction | |
17297 | ELSEIF (MODE.EQ.2) THEN | |
17298 | CALL DT_ELHAIN(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA,IREJ1) | |
17299 | IF (IREJ1.NE.0) THEN | |
17300 | IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in HADRIN' | |
17301 | GOTO 9999 | |
17302 | ENDIF | |
17303 | IF (IRH.EQ.1) GOTO 9998 | |
17304 | ELSE | |
17305 | WRITE(LOUT,1001) MODE,INTHAD | |
17306 | 1001 FORMAT(1X,'HADRIN: warning! inconsistent interaction mode', | |
17307 | & I4,' (INTHAD =',I4,')') | |
17308 | GOTO 9999 | |
17309 | ENDIF | |
17310 | ||
17311 | * transform final state particles back into Lab. | |
17312 | DO 4 I=1,IRH | |
17313 | NFSP = NFSP+1 | |
17314 | PX = CXRH(I)*PLRH(I) | |
17315 | PY = CYRH(I)*PLRH(I) | |
17316 | PZ = CZRH(I)*PLRH(I) | |
17317 | CALL DT_DALTRA(BGTA(4),BGTA(1),BGTA(2),BGTA(3), | |
17318 | & PX,PY,PZ,ELRH(I),PTOFSP,PFSP(1,NFSP), | |
17319 | & PFSP(2,NFSP),PFSP(3,NFSP),PFSP(4,NFSP)) | |
17320 | IDFSP(NFSP) = ITRH(I) | |
17321 | AMFSP2 = PFSP(4,NFSP)**2-PFSP(1,NFSP)**2-PFSP(2,NFSP)**2- | |
17322 | & PFSP(3,NFSP)**2 | |
17323 | IF (AMFSP2.LT.-TINY3) THEN | |
17324 | WRITE(LOUT,1002) IDFSP(NFSP),PFSP(1,NFSP),PFSP(2,NFSP), | |
17325 | & PFSP(3,NFSP),PFSP(4,NFSP),AMFSP2 | |
17326 | 1002 FORMAT(1X,'HADRIN: warning! final state particle (id = ', | |
17327 | & I2,') with negative mass^2',/,1X,5E12.4) | |
17328 | GOTO 9999 | |
17329 | ELSE | |
17330 | PFSP(5,NFSP) = SQRT(ABS(AMFSP2)) | |
17331 | IF (ABS(PFSP(5,NFSP)-AAM(IDFSP(NFSP))).GT.TINY1) THEN | |
17332 | WRITE(LOUT,1003) IDFSP(NFSP),AAM(IDFSP(NFSP)), | |
17333 | & PFSP(5,NFSP) | |
17334 | 1003 FORMAT(1X,'HADRIN: warning! final state particle', | |
17335 | & ' (id = ',I2,') with inconsistent mass',/,1X, | |
17336 | & 2E12.4) | |
17337 | KCORR = KCORR+1 | |
17338 | IF (KCORR.GT.2) GOTO 9999 | |
17339 | IMCORR(KCORR) = NFSP | |
17340 | ENDIF | |
17341 | ENDIF | |
17342 | * dump final state particles for energy-momentum cons. check | |
17343 | IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I), | |
17344 | & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM) | |
17345 | 4 CONTINUE | |
17346 | ||
17347 | * transform momenta on mass shell in case of inconsistencies in | |
17348 | * HADRIN | |
17349 | IF (KCORR.GT.0) THEN | |
17350 | IF (KCORR.EQ.2) THEN | |
17351 | I1 = IMCORR(1) | |
17352 | I2 = IMCORR(2) | |
17353 | ELSE | |
17354 | IF (IMCORR(1).EQ.1) THEN | |
17355 | I1 = 1 | |
17356 | I2 = 2 | |
17357 | ELSE | |
17358 | I1 = 1 | |
17359 | I2 = IMCORR(1) | |
17360 | ENDIF | |
17361 | ENDIF | |
17362 | IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I1),PFSP(2,I1), | |
17363 | & PFSP(3,I1),PFSP(4,I1),2,IDUM,IDUM) | |
17364 | IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I2),PFSP(2,I2), | |
17365 | & PFSP(3,I2),PFSP(4,I2),2,IDUM,IDUM) | |
17366 | DO 5 K=1,4 | |
17367 | P1IN(K) = PFSP(K,I1) | |
17368 | P2IN(K) = PFSP(K,I2) | |
17369 | 5 CONTINUE | |
17370 | XM1 = AAM(IDFSP(I1)) | |
17371 | XM2 = AAM(IDFSP(I2)) | |
17372 | CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1) | |
17373 | IF (IREJ1.GT.0) THEN | |
17374 | WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.' | |
17375 | C GOTO 9999 | |
17376 | ENDIF | |
17377 | DO 6 K=1,4 | |
17378 | PFSP(K,I1) = P1OUT(K) | |
17379 | PFSP(K,I2) = P2OUT(K) | |
17380 | 6 CONTINUE | |
17381 | PFSP(5,I1) = SQRT(PFSP(4,I1)**2-PFSP(1,I1)**2 | |
17382 | & -PFSP(2,I1)**2-PFSP(3,I1)**2) | |
17383 | PFSP(5,I2) = SQRT(PFSP(4,I2)**2-PFSP(1,I2)**2 | |
17384 | & -PFSP(2,I2)**2-PFSP(3,I2)**2) | |
17385 | * dump final state particles for energy-momentum cons. check | |
17386 | IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I1),-PFSP(2,I1), | |
17387 | & -PFSP(3,I1),-PFSP(4,I1),2,IDUM,IDUM) | |
17388 | IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I2),-PFSP(2,I2), | |
17389 | & -PFSP(3,I2),-PFSP(4,I2),2,IDUM,IDUM) | |
17390 | ENDIF | |
17391 | ||
17392 | * check energy-momentum conservation | |
17393 | IF (LEMCCK) THEN | |
17394 | CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,102,IREJ1) | |
17395 | IF (IREJ1.NE.0) GOTO 9999 | |
17396 | ENDIF | |
17397 | ||
17398 | RETURN | |
17399 | ||
17400 | 9998 CONTINUE | |
17401 | IREJ = 2 | |
17402 | RETURN | |
17403 | ||
17404 | 9999 CONTINUE | |
17405 | IREJ = 1 | |
17406 | RETURN | |
17407 | END | |
17408 | ||
17409 | *$ CREATE DT_HADCOL.FOR | |
17410 | *COPY DT_HADCOL | |
17411 | * | |
17412 | *===hadcol=============================================================* | |
17413 | * | |
17414 | SUBROUTINE DT_HADCOL(IDPROJ,PPN,IDXTAR,IREJ) | |
17415 | ||
17416 | ************************************************************************ | |
17417 | * Interface to the HADRIN-routines for inelastic and elastic * | |
17418 | * scattering. This subroutine samples hadron-nucleus interactions * | |
17419 | * below DPM-threshold. * | |
17420 | * IDPROJ BAMJET-index of projectile hadron * | |
17421 | * PPN projectile momentum in target rest frame * | |
17422 | * IDXTAR DTEVT1-index of target nucleon undergoing * | |
17423 | * interaction with projectile hadron * | |
17424 | * This subroutine replaces HADHAD. * | |
17425 | * This version dated 5.5.95 is written by S. Roesler * | |
17426 | ************************************************************************ | |
17427 | ||
17428 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
17429 | SAVE | |
17430 | PARAMETER ( LINP = 10 , | |
17431 | & LOUT = 6 , | |
17432 | & LDAT = 9 ) | |
17433 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0) | |
17434 | ||
17435 | LOGICAL LSTART | |
17436 | ||
17437 | * event history | |
17438 | PARAMETER (NMXHKK=200000) | |
17439 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
17440 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
17441 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
17442 | * extended event history | |
17443 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
17444 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
17445 | & IHIST(2,NMXHKK) | |
17446 | * nuclear potential | |
17447 | LOGICAL LFERMI | |
17448 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, | |
17449 | & EBINDP(2),EBINDN(2),EPOT(2,210), | |
17450 | & ETACOU(2),ICOUL,LFERMI | |
17451 | * interface HADRIN-DPM | |
17452 | COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA | |
17453 | * parameter for intranuclear cascade | |
17454 | LOGICAL LPAULI | |
17455 | COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI | |
17456 | * final state after inc step | |
17457 | PARAMETER (MAXFSP=10) | |
17458 | COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP | |
17459 | * particle properties (BAMJET index convention) | |
17460 | CHARACTER*8 ANAME | |
17461 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
17462 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
17463 | ||
17464 | DIMENSION PPROJ(5),PNUC(5) | |
17465 | ||
17466 | DATA LSTART /.TRUE./ | |
17467 | ||
17468 | IREJ = 0 | |
17469 | ||
17470 | NPOINT(1) = NHKK+1 | |
17471 | ||
17472 | TAUSAV = TAUFOR | |
17473 | **sr 6/9/01 commented | |
17474 | C TAUFOR = TAUFOR/2.0D0 | |
17475 | ** | |
17476 | IF (LSTART) THEN | |
17477 | WRITE(LOUT,1000) | |
17478 | 1000 FORMAT(/,1X,'HADCOL: Scattering handled by HADRIN') | |
17479 | WRITE(LOUT,1001) TAUFOR | |
17480 | 1001 FORMAT(/,1X,'HADCOL: Formation zone parameter set to ', | |
17481 | & F5.1,' fm/c') | |
17482 | LSTART = .FALSE. | |
17483 | ENDIF | |
17484 | ||
17485 | IDNUC = IDBAM(IDXTAR) | |
17486 | IDNUC1 = IDT_MCHAD(IDNUC) | |
17487 | IDPRO1 = IDT_MCHAD(IDPROJ) | |
17488 | ||
17489 | IF ((INTHAD.EQ.1).OR.(INTHAD.EQ.2)) THEN | |
17490 | IPROC = INTHAD | |
17491 | ELSE | |
17492 | ** | |
17493 | C CALL DT_SIHNIN(IDPRO1,IDNUC1,PPN,SIGIN) | |
17494 | C CALL DT_SIHNEL(IDPRO1,IDNUC1,PPN,SIGEL) | |
17495 | DUMZER = ZERO | |
17496 | CALL DT_XSHN(IDPRO1,IDNUC1,PPN,DUMZER,SIGTOT,SIGEL) | |
17497 | SIGIN = SIGTOT-SIGEL | |
17498 | C SIGTOT = SIGIN+SIGEL | |
17499 | ** | |
17500 | IPROC = 1 | |
17501 | IF (DT_RNDM(SIGIN).LT.SIGEL/SIGTOT) IPROC = 2 | |
17502 | ENDIF | |
17503 | ||
17504 | PPROJ(1) = ZERO | |
17505 | PPROJ(2) = ZERO | |
17506 | PPROJ(3) = PPN | |
17507 | PPROJ(5) = AAM(IDPROJ) | |
17508 | PPROJ(4) = SQRT(PPROJ(5)**2+PPROJ(3)**2) | |
17509 | DO 1 K=1,5 | |
17510 | PNUC(K) = PHKK(K,IDXTAR) | |
17511 | 1 CONTINUE | |
17512 | ||
17513 | ILOOP = 0 | |
17514 | 2 CONTINUE | |
17515 | ILOOP = ILOOP+1 | |
17516 | IF (ILOOP.GT.100) GOTO 9999 | |
17517 | ||
17518 | CALL DT_HADRIN(IDPROJ,PPROJ,IDNUC,PNUC,IPROC,IREJ1) | |
17519 | IF (IREJ1.EQ.1) GOTO 9999 | |
17520 | ||
17521 | IF (IREJ1.GT.1) THEN | |
17522 | * no interaction possible | |
17523 | * require Pauli blocking | |
17524 | IF ((IDPROJ.EQ.1).AND.(PPROJ(4).LE.PFERMP(2)+PPROJ(5))) GOTO 2 | |
17525 | IF ((IDPROJ.EQ.8).AND.(PPROJ(4).LE.PFERMN(2)+PPROJ(5))) GOTO 2 | |
17526 | IF ((IIBAR(IDPROJ).NE.1).AND. | |
17527 | & (PPROJ(4).LE.EPOT(2,IDPROJ)+PPROJ(5))) GOTO 2 | |
17528 | * store incoming particle as final state particle | |
17529 | CALL DT_LTNUC(PPROJ(3),PPROJ(4),PCMS,ECMS,3) | |
17530 | CALL DT_EVTPUT(1,IDPROJ,1,0,PPROJ(1),PPROJ(2),PCMS,ECMS,0,0,0) | |
17531 | NPOINT(4) = NHKK | |
17532 | ELSE | |
17533 | * require Pauli blocking for final state nucleons | |
17534 | DO 4 I=1,NFSP | |
17535 | IF ((IDFSP(I).EQ.1).AND. | |
17536 | & (PFSP(4,I).LE.PFERMP(2)+AAM(IDFSP(I)))) GOTO 2 | |
17537 | IF ((IDFSP(I).EQ.8).AND. | |
17538 | & (PFSP(4,I).LE.PFERMN(2)+AAM(IDFSP(I)))) GOTO 2 | |
17539 | IF ((IIBAR(IDFSP(I)).NE.1).AND. | |
17540 | & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I))))GOTO 2 | |
17541 | 4 CONTINUE | |
17542 | * store final state particles | |
17543 | DO 5 I=1,NFSP | |
17544 | IST = 1 | |
17545 | IF ((IIBAR(IDFSP(I)).EQ.1).AND. | |
17546 | & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I)))) IST = 16 | |
17547 | IDHAD = IDT_IPDGHA(IDFSP(I)) | |
17548 | CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PCMS,ECMS,3) | |
17549 | CALL DT_EVTPUT(IST,IDHAD,1,IDXTAR,PFSP(1,I),PFSP(2,I), | |
17550 | & PCMS,ECMS,0,0,0) | |
17551 | IF (I.EQ.1) NPOINT(4) = NHKK | |
17552 | VHKK(1,NHKK) = 0.5D0*(VHKK(1,1)+VHKK(1,IDXTAR)) | |
17553 | VHKK(2,NHKK) = 0.5D0*(VHKK(2,1)+VHKK(2,IDXTAR)) | |
17554 | VHKK(3,NHKK) = VHKK(3,IDXTAR) | |
17555 | VHKK(4,NHKK) = VHKK(4,IDXTAR) | |
17556 | WHKK(1,NHKK) = 0.5D0*(WHKK(1,1)+WHKK(1,IDXTAR)) | |
17557 | WHKK(2,NHKK) = 0.5D0*(WHKK(2,1)+WHKK(2,IDXTAR)) | |
17558 | WHKK(3,NHKK) = WHKK(3,1) | |
17559 | WHKK(4,NHKK) = WHKK(4,1) | |
17560 | 5 CONTINUE | |
17561 | ENDIF | |
17562 | TAUFOR = TAUSAV | |
17563 | RETURN | |
17564 | ||
17565 | 9999 CONTINUE | |
17566 | IREJ = 1 | |
17567 | TAUFOR = TAUSAV | |
17568 | RETURN | |
17569 | END | |
17570 | ||
17571 | *$ CREATE DT_GETEMU.FOR | |
17572 | *COPY DT_GETEMU | |
17573 | * | |
17574 | *===getemu=============================================================* | |
17575 | * | |
17576 | SUBROUTINE DT_GETEMU(IT,ITZ,KKMAT,MODE) | |
17577 | ||
17578 | ************************************************************************ | |
17579 | * Sampling of emulsion component to be considered as target-nucleus. * | |
17580 | * This version dated 6.5.95 is written by S. Roesler. * | |
17581 | ************************************************************************ | |
17582 | ||
17583 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
17584 | SAVE | |
17585 | PARAMETER ( LINP = 10 , | |
17586 | & LOUT = 6 , | |
17587 | & LDAT = 9 ) | |
17588 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10) | |
17589 | ||
17590 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
17591 | * emulsion treatment | |
17592 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
17593 | & NCOMPO,IEMUL | |
17594 | * Glauber formalism: flags and parameters for statistics | |
17595 | LOGICAL LPROD | |
17596 | CHARACTER*8 CGLB | |
17597 | COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD | |
17598 | ||
17599 | IF (MODE.EQ.0) THEN | |
17600 | SUMFRA = ZERO | |
17601 | RR = DT_RNDM(SUMFRA) | |
17602 | IT = 0 | |
17603 | ITZ = 0 | |
17604 | DO 1 ICOMP=1,NCOMPO | |
17605 | SUMFRA = SUMFRA+EMUFRA(ICOMP) | |
17606 | IF (SUMFRA.GT.RR) THEN | |
17607 | IT = IEMUMA(ICOMP) | |
17608 | ITZ = IEMUCH(ICOMP) | |
17609 | KKMAT = ICOMP | |
17610 | GOTO 2 | |
17611 | ENDIF | |
17612 | 1 CONTINUE | |
17613 | 2 CONTINUE | |
17614 | IF (IT.LE.0) THEN | |
17615 | WRITE(LOUT,'(1X,A,E12.3)') | |
17616 | & 'Warning! norm. failure within emulsion fractions', | |
17617 | & SUMFRA | |
17618 | STOP | |
17619 | ENDIF | |
17620 | ELSEIF (MODE.EQ.1) THEN | |
17621 | NDIFF = 10000 | |
17622 | DO 3 I=1,NCOMPO | |
17623 | IDIFF = ABS(IT-IEMUMA(I)) | |
17624 | IF (IDIFF.LT.NDIFF) THEN | |
17625 | KKMAT = I | |
17626 | NDIFF = IDIFF | |
17627 | ENDIF | |
17628 | 3 CONTINUE | |
17629 | ELSE | |
17630 | STOP 'DT_GETEMU' | |
17631 | ENDIF | |
17632 | ||
17633 | * bypass for variable projectile/target/energy runs: the correct | |
17634 | * Glauber data will be always loaded on kkmat=1 | |
17635 | IF (IOGLB.EQ.100) THEN | |
17636 | KKMAT = 1 | |
17637 | ENDIF | |
17638 | ||
17639 | RETURN | |
17640 | END | |
17641 | ||
17642 | *$ CREATE DT_NCLPOT.FOR | |
17643 | *COPY DT_NCLPOT | |
17644 | * | |
17645 | *===nclpot=============================================================* | |
17646 | * | |
17647 | SUBROUTINE DT_NCLPOT(IPZ,IP,ITZ,IT,AFERP,AFERT,MODE) | |
17648 | ||
17649 | ************************************************************************ | |
17650 | * Calculation of Coulomb and nuclear potential for a given configurat. * | |
17651 | * IPZ, IP charge/mass number of proj. * | |
17652 | * ITZ, IT charge/mass number of targ. * | |
17653 | * AFERP,AFERT factors modifying proj./target pot. * | |
17654 | * if =0, FERMOD is used * | |
17655 | * MODE = 0 calculation of binding energy * | |
17656 | * = 1 pre-calculated binding energy is used * | |
17657 | * This version dated 16.11.95 is written by S. Roesler. * | |
17658 | * * | |
17659 | * Last change 28.12.2006 by S. Roesler. * | |
17660 | ************************************************************************ | |
17661 | ||
17662 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
17663 | SAVE | |
17664 | PARAMETER ( LINP = 10 , | |
17665 | & LOUT = 6 , | |
17666 | & LDAT = 9 ) | |
17667 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2, | |
17668 | & TINY10=1.0D-10) | |
17669 | ||
17670 | LOGICAL LSTART | |
17671 | ||
17672 | * particle properties (BAMJET index convention) | |
17673 | CHARACTER*8 ANAME | |
17674 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
17675 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
17676 | * nuclear potential | |
17677 | LOGICAL LFERMI | |
17678 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, | |
17679 | & EBINDP(2),EBINDN(2),EPOT(2,210), | |
17680 | & ETACOU(2),ICOUL,LFERMI | |
17681 | ||
17682 | DIMENSION IDXPOT(14) | |
17683 | * ap an lam alam sig- sig+ sig0 tet0 tet- asig- | |
17684 | DATA IDXPOT / 2, 9, 17, 18, 20, 21, 22, 97, 98, 99, | |
17685 | * asig0 asig+ atet0 atet+ | |
17686 | & 100, 101, 102, 103/ | |
17687 | ||
17688 | DATA AN /0.4D0/ | |
17689 | DATA LSTART /.TRUE./ | |
17690 | ||
17691 | IF (MODE.EQ.0) THEN | |
17692 | EBINDP(1) = ZERO | |
17693 | EBINDN(1) = ZERO | |
17694 | EBINDP(2) = ZERO | |
17695 | EBINDN(2) = ZERO | |
17696 | ENDIF | |
17697 | AIP = DBLE(IP) | |
17698 | AIPZ = DBLE(IPZ) | |
17699 | AIT = DBLE(IT) | |
17700 | AITZ = DBLE(ITZ) | |
17701 | ||
17702 | FERMIP = AFERP | |
17703 | IF (AFERP.LE.ZERO) FERMIP = FERMOD | |
17704 | FERMIT = AFERT | |
17705 | IF (AFERT.LE.ZERO) FERMIT = FERMOD | |
17706 | ||
17707 | * Fermi momenta and binding energy for projectile | |
17708 | IF ((IP.GT.1).AND.LFERMI) THEN | |
17709 | IF (MODE.EQ.0) THEN | |
17710 | C EBINDP(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ-1) | |
17711 | C EBINDN(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ) | |
17712 | BIP = AIP -ONE | |
17713 | BIPZ = AIPZ-ONE | |
17714 | EBINDP(1) = 1.0D-3*(DT_ENERGY(ONE,ONE)+DT_ENERGY(BIP,BIPZ) | |
17715 | & -DT_ENERGY(AIP,AIPZ)) | |
17716 | IF (AIP.LE.AIPZ) THEN | |
17717 | EBINDN(1) = EBINDP(1) | |
17718 | WRITE(LOUT,*) ' DT_NCLPOT: AIP.LE.AIPZ (',AIP,AIPZ,')' | |
17719 | ELSE | |
17720 | EBINDN(1) = 1.0D-3*(DT_ENERGY(ONE,ZERO) | |
17721 | & +DT_ENERGY(BIP,AIPZ)-DT_ENERGY(AIP,AIPZ)) | |
17722 | ENDIF | |
17723 | ENDIF | |
17724 | PFERMP(1) = FERMIP*AN*(AIPZ/AIP)**0.333333D0 | |
17725 | PFERMN(1) = FERMIP*AN*((AIP-AIPZ)/AIP)**0.33333D0 | |
17726 | ELSE | |
17727 | PFERMP(1) = ZERO | |
17728 | PFERMN(1) = ZERO | |
17729 | ENDIF | |
17730 | * effective nuclear potential for projectile | |
17731 | C EPOT(1,1) = PFERMP(1)**2/(2.0D0*AAM(1)) + EBINDP(1) | |
17732 | C EPOT(1,8) = PFERMN(1)**2/(2.0D0*AAM(8)) + EBINDN(1) | |
17733 | EPOT(1,1) = SQRT(PFERMP(1)**2+AAM(1)**2) -AAM(1) + EBINDP(1) | |
17734 | EPOT(1,8) = SQRT(PFERMN(1)**2+AAM(8)**2) -AAM(8) + EBINDN(1) | |
17735 | ||
17736 | * Fermi momenta and binding energy for target | |
17737 | IF ((IT.GT.1).AND.LFERMI) THEN | |
17738 | IF (MODE.EQ.0) THEN | |
17739 | C EBINDP(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ-1) | |
17740 | C EBINDN(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ) | |
17741 | BIT = AIT -ONE | |
17742 | BITZ = AITZ-ONE | |
17743 | ||
17744 | EBINDP(2) = 1.0D-3*(DT_ENERGY(ONE,ONE)+DT_ENERGY(BIT,BITZ) | |
17745 | & -DT_ENERGY(AIT,AITZ)) | |
17746 | ||
17747 | IF (AIT.LE.AITZ) THEN | |
17748 | EBINDN(2) = EBINDP(2) | |
17749 | WRITE(LOUT,*) ' DT_NCLPOT: AIT.LE.AIPT (',AIT,AIPT,')' | |
17750 | ELSE | |
17751 | ||
17752 | EBINDN(2) = 1.0D-3*(DT_ENERGY(ONE,ZERO) | |
17753 | & +DT_ENERGY(BIT,AITZ)-DT_ENERGY(AIT,AITZ)) | |
17754 | ||
17755 | ENDIF | |
17756 | ENDIF | |
17757 | PFERMP(2) = FERMIT*AN*(AITZ/AIT)**0.333333D0 | |
17758 | PFERMN(2) = FERMIT*AN*((AIT-AITZ)/AIT)**0.33333D0 | |
17759 | ELSE | |
17760 | PFERMP(2) = ZERO | |
17761 | PFERMN(2) = ZERO | |
17762 | ENDIF | |
17763 | * effective nuclear potential for target | |
17764 | C EPOT(2,1) = PFERMP(2)**2/(2.0D0*AAM(1)) + EBINDP(2) | |
17765 | C EPOT(2,8) = PFERMN(2)**2/(2.0D0*AAM(8)) + EBINDN(2) | |
17766 | EPOT(2,1) = SQRT(PFERMP(2)**2+AAM(1)**2) -AAM(1) + EBINDP(2) | |
17767 | EPOT(2,8) = SQRT(PFERMN(2)**2+AAM(8)**2) -AAM(8) + EBINDN(2) | |
17768 | ||
17769 | DO 2 I=1,14 | |
17770 | EPOT(1,IDXPOT(I)) = EPOT(1,8) | |
17771 | EPOT(2,IDXPOT(I)) = EPOT(2,8) | |
17772 | 2 CONTINUE | |
17773 | ||
17774 | * Coulomb energy | |
17775 | ETACOU(1) = ZERO | |
17776 | ETACOU(2) = ZERO | |
17777 | IF (ICOUL.EQ.1) THEN | |
17778 | IF (IP.GT.1) | |
17779 | & ETACOU(1) = 0.001116D0*AIPZ/(1.0D0+AIP**0.333D0) | |
17780 | IF (IT.GT.1) | |
17781 | & ETACOU(2) = 0.001116D0*AITZ/(1.0D0+AIT**0.333D0) | |
17782 | ENDIF | |
17783 | ||
17784 | IF (LSTART) THEN | |
17785 | WRITE(LOUT,1000) IP,IPZ,IT,ITZ,EBINDP,EBINDN, | |
17786 | & EPOT(1,1)-EBINDP(1),EPOT(2,1)-EBINDP(2), | |
17787 | & EPOT(1,8)-EBINDN(1),EPOT(2,8)-EBINDN(2), | |
17788 | & FERMOD,ETACOU | |
17789 | 1000 FORMAT(/,/,1X,'NCLPOT: quantities for inclusion of nuclear' | |
17790 | & ,' effects',/,12X,'---------------------------', | |
17791 | & '----------------',/,/,38X,'projectile', | |
17792 | & ' target',/,/,1X,'Mass number / charge', | |
17793 | & 17X,I3,' /',I3,6X,I3,' /',I3,/,1X,'Binding energy -', | |
17794 | & ' proton (GeV) ',2E14.4,/,17X,'- neutron (GeV)' | |
17795 | & ,1X,2E14.4,/,1X,'Fermi-potential - proton (GeV)', | |
17796 | & 1X,2E14.4,/,17X,'- neutron (GeV) ',2E14.4,/,/, | |
17797 | & 1X,'Scale factor for Fermi-momentum ',F4.2,/, | |
17798 | & /,1X,'Coulomb-energy ',2(E14.4,' GeV '),/,/) | |
17799 | LSTART = .FALSE. | |
17800 | ENDIF | |
17801 | ||
17802 | RETURN | |
17803 | END | |
17804 | ||
17805 | *$ CREATE DT_RESNCL.FOR | |
17806 | *COPY DT_RESNCL | |
17807 | * | |
17808 | *===resncl=============================================================* | |
17809 | * | |
17810 | SUBROUTINE DT_RESNCL(EPN,NLOOP,MODE) | |
17811 | ||
17812 | ************************************************************************ | |
17813 | * Treatment of residual nuclei and nuclear effects. * | |
17814 | * MODE = 1 initializations * | |
17815 | * = 2 treatment of final state * | |
17816 | * This version dated 16.11.95 is written by S. Roesler. * | |
17817 | * * | |
17818 | * Last change 05.01.2007 by S. Roesler. * | |
17819 | ************************************************************************ | |
17820 | ||
17821 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
17822 | SAVE | |
17823 | PARAMETER ( LINP = 10 , | |
17824 | & LOUT = 6 , | |
17825 | & LDAT = 9 ) | |
17826 | PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,THREE=3.D0,TINY3=1.0D-3, | |
17827 | & TINY2=1.0D-2,TINY1=1.0D-1,TINY4=1.0D-4,TINY10=1.0D-10, | |
17828 | & ONETHI=ONE/THREE) | |
17829 | PARAMETER (AMUAMU = 0.93149432D0, | |
17830 | & FM2MM = 1.0D-12, | |
17831 | & RNUCLE = 1.12D0) | |
17832 | PARAMETER ( EMVGEV = 1.0 D-03 ) | |
17833 | PARAMETER ( AMUGEV = 0.93149432 D+00 ) | |
17834 | PARAMETER ( AMPRTN = 0.93827231 D+00 ) | |
17835 | PARAMETER ( AMNTRN = 0.93956563 D+00 ) | |
17836 | PARAMETER ( AMELCT = 0.51099906 D-03 ) | |
17837 | PARAMETER ( HLFHLF = 0.5D+00 ) | |
17838 | PARAMETER ( FERTHO = 14.33 D-09 ) | |
17839 | PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 ) | |
17840 | PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 ) | |
17841 | PARAMETER ( AMUC12 = AMUGEV - AMUNMU ) | |
17842 | ||
17843 | * event history | |
17844 | PARAMETER (NMXHKK=200000) | |
17845 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
17846 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
17847 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
17848 | * extended event history | |
17849 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
17850 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
17851 | & IHIST(2,NMXHKK) | |
17852 | * particle properties (BAMJET index convention) | |
17853 | CHARACTER*8 ANAME | |
17854 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
17855 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
17856 | * flags for input different options | |
17857 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
17858 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
17859 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
17860 | * nuclear potential | |
17861 | LOGICAL LFERMI | |
17862 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, | |
17863 | & EBINDP(2),EBINDN(2),EPOT(2,210), | |
17864 | & ETACOU(2),ICOUL,LFERMI | |
17865 | * properties of interacting particles | |
17866 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
17867 | * properties of photon/lepton projectiles | |
17868 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC | |
17869 | * Lorentz-parameters of the current interaction | |
17870 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
17871 | & UMO,PPCM,EPROJ,PPROJ | |
17872 | * treatment of residual nuclei: wounded nucleons | |
17873 | COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210) | |
17874 | * treatment of residual nuclei: 4-momenta | |
17875 | LOGICAL LRCLPR,LRCLTA | |
17876 | COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5), | |
17877 | & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA | |
17878 | ||
17879 | DIMENSION PFSP(4),PSEC(4),PSEC0(4) | |
17880 | DIMENSION PMOMB(5000),IDXB(5000),PMOMM(10000),IDXM(10000), | |
17881 | & IDXCOR(15000),IDXOTH(NMXHKK) | |
17882 | ||
17883 | GOTO (1,2) MODE | |
17884 | ||
17885 | *------- initializations | |
17886 | 1 CONTINUE | |
17887 | ||
17888 | * initialize arrays for residual nuclei | |
17889 | DO 10 K=1,5 | |
17890 | IF (K.LE.4) THEN | |
17891 | PFSP(K) = ZERO | |
17892 | ENDIF | |
17893 | PINIPR(K) = ZERO | |
17894 | PINITA(K) = ZERO | |
17895 | PRCLPR(K) = ZERO | |
17896 | PRCLTA(K) = ZERO | |
17897 | TRCLPR(K) = ZERO | |
17898 | TRCLTA(K) = ZERO | |
17899 | 10 CONTINUE | |
17900 | SCPOT = ONE | |
17901 | NLOOP = 0 | |
17902 | ||
17903 | * correction of projectile 4-momentum for effective target pot. | |
17904 | * and Coulomb-energy (in case of hadron-nucleus interaction only) | |
17905 | IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN | |
17906 | EPNI = EPN | |
17907 | * Coulomb-energy: | |
17908 | * positively charged hadron - check energy for Coloumb pot. | |
17909 | IF (IICH(IJPROJ).EQ.1) THEN | |
17910 | THRESH = ETACOU(2)+AAM(IJPROJ) | |
17911 | IF (EPNI.LE.THRESH) THEN | |
17912 | WRITE(LOUT,1000) | |
17913 | 1000 FORMAT(/,1X,'KKINC: WARNING! projectile energy', | |
17914 | & ' below Coulomb threshold - event rejected',/) | |
17915 | ISTHKK(1) = 1 | |
17916 | RETURN | |
17917 | ENDIF | |
17918 | * negatively charged hadron - increase energy by Coulomb energy | |
17919 | ELSEIF (IICH(IJPROJ).EQ.-1) THEN | |
17920 | EPNI = EPNI+ETACOU(2) | |
17921 | ENDIF | |
17922 | IF ((IJPROJ.EQ.1).OR.(IJPROJ.EQ.8)) THEN | |
17923 | * Effective target potential | |
17924 | *sr 6.6. binding energy only (to avoid negative exc. energies) | |
17925 | C EPNI = EPNI+EPOT(2,IJPROJ) | |
17926 | EBIPOT = EBINDP(2) | |
17927 | IF ((IJPROJ.NE.1).AND.(ABS(EPOT(2,IJPROJ)).GT.5.0D-3)) | |
17928 | & EBIPOT = EBINDN(2) | |
17929 | EPNI = EPNI+ABS(EBIPOT) | |
17930 | * re-initialization of DTLTRA | |
17931 | DUM1 = ZERO | |
17932 | DUM2 = ZERO | |
17933 | CALL DT_LTINI(IJPROJ,IJTARG,EPNI,DUM1,DUM2,0) | |
17934 | ENDIF | |
17935 | ENDIF | |
17936 | ||
17937 | * projectile in n-n cms | |
17938 | IF ((IP.LE.1).AND.(IT.GT.1)) THEN | |
17939 | PMASS1 = AAM(IJPROJ) | |
17940 | C* VDM assumption | |
17941 | C IF (IJPROJ.EQ.7) PMASS1 = AAM(33) | |
17942 | IF (IJPROJ.EQ.7) PMASS1 = AAM(IJPROJ)-SQRT(VIRT) | |
17943 | PMASS2 = AAM(1) | |
17944 | PM1 = SIGN(PMASS1**2,PMASS1) | |
17945 | PM2 = SIGN(PMASS2**2,PMASS2) | |
17946 | PINIPR(4) = (UMO**2-PM2+PM1)/(TWO*UMO) | |
17947 | PINIPR(5) = PMASS1 | |
17948 | IF (PMASS1.GT.ZERO) THEN | |
17949 | PINIPR(3) = SQRT((PINIPR(4)-PINIPR(5)) | |
17950 | & *(PINIPR(4)+PINIPR(5))) | |
17951 | ELSE | |
17952 | PINIPR(3) = SQRT(PINIPR(4)**2-PM1) | |
17953 | ENDIF | |
17954 | AIT = DBLE(IT) | |
17955 | AITZ = DBLE(ITZ) | |
17956 | PINITA(5) = AIT*AMUAMU+1.0D-3*DT_ENERGY(AIT,AITZ) | |
17957 | CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3) | |
17958 | ELSEIF ((IP.GT.1).AND.(IT.LE.1)) THEN | |
17959 | PMASS1 = AAM(1) | |
17960 | PMASS2 = AAM(IJTARG) | |
17961 | PM1 = SIGN(PMASS1**2,PMASS1) | |
17962 | PM2 = SIGN(PMASS2**2,PMASS2) | |
17963 | PINITA(4) = (UMO**2-PM1+PM2)/(TWO*UMO) | |
17964 | PINITA(5) = PMASS2 | |
17965 | PINITA(3) = -SQRT((PINITA(4)-PINITA(5)) | |
17966 | & *(PINITA(4)+PINITA(5))) | |
17967 | AIP = DBLE(IP) | |
17968 | AIPZ = DBLE(IPZ) | |
17969 | PINIPR(5) = AIP*AMUAMU+1.0D-3*DT_ENERGY(AIP,AIPZ) | |
17970 | CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2) | |
17971 | ELSEIF ((IP.GT.1).AND.(IT.GT.1)) THEN | |
17972 | AIP = DBLE(IP) | |
17973 | AIPZ = DBLE(IPZ) | |
17974 | PINIPR(5) = AIP*AMUAMU+1.0D-3*DT_ENERGY(AIP,AIPZ) | |
17975 | CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2) | |
17976 | AIT = DBLE(IT) | |
17977 | AITZ = DBLE(ITZ) | |
17978 | PINITA(5) = AIT*AMUAMU+1.0D-3*DT_ENERGY(AIT,AITZ) | |
17979 | CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3) | |
17980 | ENDIF | |
17981 | ||
17982 | RETURN | |
17983 | ||
17984 | *------- treatment of final state | |
17985 | 2 CONTINUE | |
17986 | ||
17987 | NLOOP = NLOOP+1 | |
17988 | IF (NLOOP.GT.1) SCPOT = 0.10D0 | |
17989 | C WRITE(LOUT,*) 'event ',NEVHKK,NLOOP,SCPOT | |
17990 | ||
17991 | JPW = NPW | |
17992 | JPCW = NPCW | |
17993 | JTW = NTW | |
17994 | JTCW = NTCW | |
17995 | DO 40 K=1,4 | |
17996 | PFSP(K) = ZERO | |
17997 | 40 CONTINUE | |
17998 | ||
17999 | NOB = 0 | |
18000 | NOM = 0 | |
18001 | DO 900 I=NPOINT(4),NHKK | |
18002 | IDXOTH(I) = -1 | |
18003 | IF (ISTHKK(I).EQ.1) THEN | |
18004 | IF (IDBAM(I).EQ.7) GOTO 900 | |
18005 | IPOT = 0 | |
18006 | IOTHER = 0 | |
18007 | * particle moving into forward direction | |
18008 | IF (PHKK(3,I).GE.ZERO) THEN | |
18009 | * most likely to be effected by projectile potential | |
18010 | IPOT = 1 | |
18011 | * there is no projectile nucleus, try target | |
18012 | IF ((IP.LE.1).OR.((IP-NPW).LE.1)) THEN | |
18013 | IPOT = 2 | |
18014 | IF (IP.GT.1) IOTHER = 1 | |
18015 | * there is no target nucleus --> skip | |
18016 | IF ((IT.LE.1).OR.((IT-NTW).LE.1)) GOTO 900 | |
18017 | ENDIF | |
18018 | * particle moving into backward direction | |
18019 | ELSE | |
18020 | * most likely to be effected by target potential | |
18021 | IPOT = 2 | |
18022 | * there is no target nucleus, try projectile | |
18023 | IF ((IT.LE.1).OR.((IT-NTW).LE.1)) THEN | |
18024 | IPOT = 1 | |
18025 | IF (IT.GT.1) IOTHER = 1 | |
18026 | * there is no projectile nucleus --> skip | |
18027 | IF ((IP.LE.1).OR.((IP-NPW).LE.1)) GOTO 900 | |
18028 | ENDIF | |
18029 | ENDIF | |
18030 | IFLG = -IPOT | |
18031 | * nobam=3: particle is in overlap-region or neither inside proj. nor target | |
18032 | * =1: particle is not in overlap-region AND is inside target (2) | |
18033 | * =2: particle is not in overlap-region AND is inside projectile (1) | |
18034 | * flag particles which are inside the nucleus ipot but not in its | |
18035 | * overlap region | |
18036 | IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) IFLG = IPOT | |
18037 | IF (IDBAM(I).NE.0) THEN | |
18038 | * baryons: keep all nucleons and all others where flag is set | |
18039 | IF (IIBAR(IDBAM(I)).NE.0) THEN | |
18040 | IF ((IDBAM(I).EQ.1).OR.(IDBAM(I).EQ.8).OR.(IFLG.GT.0)) | |
18041 | & THEN | |
18042 | NOB = NOB+1 | |
18043 | PMOMB(NOB) = PHKK(3,I) | |
18044 | IDXB(NOB) = SIGN(10000000*IABS(IFLG) | |
18045 | & +1000000*IOTHER+I,IFLG) | |
18046 | ENDIF | |
18047 | * mesons: keep only those mesons where flag is set | |
18048 | ELSE | |
18049 | IF (IFLG.GT.0) THEN | |
18050 | NOM = NOM+1 | |
18051 | PMOMM(NOM) = PHKK(3,I) | |
18052 | IDXM(NOM) = 10000000*IFLG+1000000*IOTHER+I | |
18053 | ENDIF | |
18054 | ENDIF | |
18055 | ENDIF | |
18056 | ENDIF | |
18057 | 900 CONTINUE | |
18058 | * | |
18059 | * sort particles in the arrays according to increasing long. momentum | |
18060 | CALL DT_SORT1(PMOMB,IDXB,NOB,1,NOB,1) | |
18061 | CALL DT_SORT1(PMOMM,IDXM,NOM,1,NOM,1) | |
18062 | * | |
18063 | * shuffle indices into one and the same array according to the later | |
18064 | * sequence of correction | |
18065 | NCOR = 0 | |
18066 | IF (IT.GT.1) THEN | |
18067 | DO 910 I=1,NOB | |
18068 | IF (PMOMB(I).GT.ZERO) GOTO 911 | |
18069 | NCOR = NCOR+1 | |
18070 | IDXCOR(NCOR) = IDXB(I) | |
18071 | 910 CONTINUE | |
18072 | 911 CONTINUE | |
18073 | IF (IP.GT.1) THEN | |
18074 | DO 912 J=1,NOB | |
18075 | I = NOB+1-J | |
18076 | IF (PMOMB(I).LT.ZERO) GOTO 913 | |
18077 | NCOR = NCOR+1 | |
18078 | IDXCOR(NCOR) = IDXB(I) | |
18079 | 912 CONTINUE | |
18080 | 913 CONTINUE | |
18081 | ELSE | |
18082 | DO 914 I=1,NOB | |
18083 | IF (PMOMB(I).GT.ZERO) THEN | |
18084 | NCOR = NCOR+1 | |
18085 | IDXCOR(NCOR) = IDXB(I) | |
18086 | ENDIF | |
18087 | 914 CONTINUE | |
18088 | ENDIF | |
18089 | ELSE | |
18090 | DO 915 J=1,NOB | |
18091 | I = NOB+1-J | |
18092 | NCOR = NCOR+1 | |
18093 | IDXCOR(NCOR) = IDXB(I) | |
18094 | 915 CONTINUE | |
18095 | ENDIF | |
18096 | DO 925 I=1,NOM | |
18097 | IF (PMOMM(I).GT.ZERO) GOTO 926 | |
18098 | NCOR = NCOR+1 | |
18099 | IDXCOR(NCOR) = IDXM(I) | |
18100 | 925 CONTINUE | |
18101 | 926 CONTINUE | |
18102 | DO 927 J=1,NOM | |
18103 | I = NOM+1-J | |
18104 | IF (PMOMM(I).LT.ZERO) GOTO 928 | |
18105 | NCOR = NCOR+1 | |
18106 | IDXCOR(NCOR) = IDXM(I) | |
18107 | 927 CONTINUE | |
18108 | 928 CONTINUE | |
18109 | * | |
18110 | C IF (NEVHKK.EQ.484) THEN | |
18111 | C WRITE(LOUT,9000) JPCW,JPW-JPCW,JTCW,JTW-JTCW | |
18112 | C 9000 FORMAT(1X,'wounded nucleons (proj.-p,n targ.-p,n)',/,4I10) | |
18113 | C WRITE(LOUT,9001) NOB,NOM,NCOR | |
18114 | C 9001 FORMAT(1X,'produced particles (baryons,mesons,all)',3I10) | |
18115 | C WRITE(LOUT,'(/,A)') ' baryons ' | |
18116 | C DO 950 I=1,NOB | |
18117 | CC J = IABS(IDXB(I)) | |
18118 | CC INDEX = J-IABS(J/10000000)*10000000 | |
18119 | C IPOT = IABS(IDXB(I))/10000000 | |
18120 | C IOTHER = IABS(IDXB(I))/1000000-IPOT*10 | |
18121 | C INDEX = IABS(IDXB(I))-IPOT*10000000-IOTHER*1000000 | |
18122 | C WRITE(LOUT,9002) I,INDEX,IDXB(I),IDBAM(INDEX),PMOMB(I) | |
18123 | C 950 CONTINUE | |
18124 | C WRITE(LOUT,'(/,A)') ' mesons ' | |
18125 | C DO 951 I=1,NOM | |
18126 | CC INDEX = IDXM(I)-IABS(IDXM(I)/10000000)*10000000 | |
18127 | C IPOT = IABS(IDXM(I))/10000000 | |
18128 | C IOTHER = IABS(IDXM(I))/1000000-IPOT*10 | |
18129 | C INDEX = IABS(IDXM(I))-IPOT*10000000-IOTHER*1000000 | |
18130 | C WRITE(LOUT,9002) I,INDEX,IDXM(I),IDBAM(INDEX),PMOMM(I) | |
18131 | C 951 CONTINUE | |
18132 | C 9002 FORMAT(1X,4I14,E14.5) | |
18133 | C WRITE(LOUT,'(/,A)') ' all ' | |
18134 | C DO 952 I=1,NCOR | |
18135 | CC J = IABS(IDXCOR(I)) | |
18136 | CC INDEX = J-IABS(J/10000000)*10000000 | |
18137 | CC IPOT = IABS(IDXCOR(I))/10000000 | |
18138 | C IOTHER = IABS(IDXCOR(I))/1000000-IPOT*10 | |
18139 | C INDEX = IABS(IDXCOR(I))-IPOT*10000000-IOTHER*1000000 | |
18140 | C WRITE(LOUT,9003) I,INDEX,IDXCOR(I),IDBAM(INDEX) | |
18141 | C 952 CONTINUE | |
18142 | C 9003 FORMAT(1X,4I14) | |
18143 | C ENDIF | |
18144 | * | |
18145 | DO 20 ICOR=1,NCOR | |
18146 | IPOT = IABS(IDXCOR(ICOR))/10000000 | |
18147 | IOTHER = IABS(IDXCOR(ICOR))/1000000-IPOT*10 | |
18148 | I = IABS(IDXCOR(ICOR))-IPOT*10000000-IOTHER*1000000 | |
18149 | IDXOTH(I) = 1 | |
18150 | ||
18151 | IDSEC = IDBAM(I) | |
18152 | ||
18153 | * reduction of particle momentum by corresponding nuclear potential | |
18154 | * (this applies only if Fermi-momenta are requested) | |
18155 | ||
18156 | IF (LFERMI) THEN | |
18157 | ||
18158 | * Lorentz-transformation into the rest system of the selected nucleus | |
18159 | IMODE = -IPOT-1 | |
18160 | CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I), | |
18161 | & PSEC(1),PSEC(2),PSEC(3),PSEC(4),IDSEC,IMODE) | |
18162 | PSECO = SQRT(PSEC(1)**2+PSEC(2)**2+PSEC(3)**2) | |
18163 | AMSEC = SQRT(ABS((PSEC(4)-PSECO)*(PSEC(4)+PSECO))) | |
18164 | JPMOD = 0 | |
18165 | ||
18166 | CHKLEV = TINY3 | |
18167 | IF ((EPROJ.GE.1.0D4).AND.(IDSEC.EQ.7)) CHKLEV = TINY1 | |
18168 | IF (EPROJ.GE.2.0D6) CHKLEV = 1.0D0 | |
18169 | IF (ABS(AMSEC-AAM(IDSEC)).GT.CHKLEV) THEN | |
18170 | IF (IOULEV(3).GT.0) | |
18171 | & WRITE(LOUT,2000) I,NEVHKK,IDSEC,AMSEC,AAM(IDSEC) | |
18172 | 2000 FORMAT(1X,'RESNCL: inconsistent mass of particle', | |
18173 | & ' at entry ',I5,' (evt.',I8,')',/,' IDSEC: ', | |
18174 | & I4,' AMSEC: ',E12.3,' AAM(IDSEC): ',E12.3,/) | |
18175 | GOTO 23 | |
18176 | ENDIF | |
18177 | ||
18178 | DO 21 K=1,4 | |
18179 | PSEC0(K) = PSEC(K) | |
18180 | 21 CONTINUE | |
18181 | ||
18182 | * the correction for nuclear potential effects is applied to as many | |
18183 | * p/n as many nucleons were wounded; the momenta of other final state | |
18184 | * particles are corrected only if they materialize inside the corresp. | |
18185 | * nucleus (here: NOBAM = 1 part. outside proj., = 2 part. outside targ | |
18186 | * = 3 part. outside proj. and targ., >=10 in overlapping region) | |
18187 | IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) THEN | |
18188 | IF (IPOT.EQ.1) THEN | |
18189 | IF ((JPW.GT.0).AND.(IOTHER.EQ.0)) THEN | |
18190 | * this is most likely a wounded nucleon | |
18191 | **test | |
18192 | C RDIST = SQRT((VHKK(1,IPW(JPW))/FM2MM)**2 | |
18193 | C & +(VHKK(2,IPW(JPW))/FM2MM)**2 | |
18194 | C & +(VHKK(3,IPW(JPW))/FM2MM)**2) | |
18195 | C RAD = RNUCLE*DBLE(IP)**ONETHI | |
18196 | C FDEN = 1.4D0*DT_DENSIT(IP,RDIST,RAD) | |
18197 | C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC) | |
18198 | ** | |
18199 | PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC) | |
18200 | JPW = JPW-1 | |
18201 | JPMOD = 1 | |
18202 | ELSE | |
18203 | * correct only if part. was materialized inside nucleus | |
18204 | * and if it is ouside the overlapping region | |
18205 | IF ((NOBAM(I).NE.1).AND.(NOBAM(I).LT.3)) THEN | |
18206 | PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC) | |
18207 | JPMOD = 1 | |
18208 | ENDIF | |
18209 | ENDIF | |
18210 | ELSEIF (IPOT.EQ.2) THEN | |
18211 | IF ((JTW.GT.0).AND.(IOTHER.EQ.0)) THEN | |
18212 | * this is most likely a wounded nucleon | |
18213 | **test | |
18214 | C RDIST = SQRT((VHKK(1,ITW(JTW))/FM2MM)**2 | |
18215 | C & +(VHKK(2,ITW(JTW))/FM2MM)**2 | |
18216 | C & +(VHKK(3,ITW(JTW))/FM2MM)**2) | |
18217 | C RAD = RNUCLE*DBLE(IT)**ONETHI | |
18218 | C FDEN = 1.4D0*DT_DENSIT(IT,RDIST,RAD) | |
18219 | C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC) | |
18220 | ** | |
18221 | PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC) | |
18222 | JTW = JTW-1 | |
18223 | JPMOD = 1 | |
18224 | ELSE | |
18225 | * correct only if part. was materialized inside nucleus | |
18226 | IF ((NOBAM(I).NE.2).AND.(NOBAM(I).LT.3)) THEN | |
18227 | PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC) | |
18228 | JPMOD = 1 | |
18229 | ENDIF | |
18230 | ENDIF | |
18231 | ENDIF | |
18232 | ELSE | |
18233 | IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) THEN | |
18234 | PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC) | |
18235 | JPMOD = 1 | |
18236 | ENDIF | |
18237 | ENDIF | |
18238 | ||
18239 | IF (NLOOP.EQ.1) THEN | |
18240 | * Coulomb energy correction: | |
18241 | * the treatment of Coulomb potential correction is similar to the | |
18242 | * one for nuclear potential | |
18243 | IF (IDSEC.EQ.1) THEN | |
18244 | IF ((IPOT.EQ.1).AND.(JPCW.GT.0)) THEN | |
18245 | JPCW = JPCW-1 | |
18246 | ELSEIF ((IPOT.EQ.2).AND.(JTCW.GT.0)) THEN | |
18247 | JTCW = JTCW-1 | |
18248 | ELSE | |
18249 | IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25 | |
18250 | ENDIF | |
18251 | ELSE | |
18252 | IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25 | |
18253 | ENDIF | |
18254 | IF (IICH(IDSEC).EQ.1) THEN | |
18255 | * pos. particles: check if they are able to escape Coulomb potential | |
18256 | IF (PSEC(4).LT.AMSEC+ETACOU(IPOT)) THEN | |
18257 | ISTHKK(I) = 14+IPOT | |
18258 | IF (ISTHKK(I).EQ.15) THEN | |
18259 | DO 26 K=1,4 | |
18260 | PHKK(K,I) = PSEC0(K) | |
18261 | TRCLPR(K) = TRCLPR(K)+PSEC0(K) | |
18262 | 26 CONTINUE | |
18263 | IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1 | |
18264 | IF (IDSEC.EQ.1) NPCW = NPCW-1 | |
18265 | ELSEIF (ISTHKK(I).EQ.16) THEN | |
18266 | DO 27 K=1,4 | |
18267 | PHKK(K,I) = PSEC0(K) | |
18268 | TRCLTA(K) = TRCLTA(K)+PSEC0(K) | |
18269 | 27 CONTINUE | |
18270 | IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1 | |
18271 | IF (IDSEC.EQ.1) NTCW = NTCW-1 | |
18272 | ENDIF | |
18273 | GOTO 20 | |
18274 | ENDIF | |
18275 | ELSEIF (IICH(IDSEC).EQ.-1) THEN | |
18276 | * neg. particles: decrease energy by Coulomb-potential | |
18277 | PSEC(4) = PSEC(4)-ETACOU(IPOT) | |
18278 | JPMOD = 1 | |
18279 | ENDIF | |
18280 | ENDIF | |
18281 | ||
18282 | 25 CONTINUE | |
18283 | ||
18284 | IF (PSEC(4).LT.AMSEC) THEN | |
18285 | IF (IOULEV(6).GT.0) | |
18286 | & WRITE(LOUT,2001) I,IDSEC,PSEC(4),AMSEC | |
18287 | 2001 FORMAT(1X,'KKINC: particle at DTEVT1-pos. ',I5, | |
18288 | & ' is not allowed to escape nucleus',/, | |
18289 | & 8X,'id : ',I3,' reduced energy: ',E15.4, | |
18290 | & ' mass: ',E12.3) | |
18291 | ISTHKK(I) = 14+IPOT | |
18292 | IF (ISTHKK(I).EQ.15) THEN | |
18293 | DO 28 K=1,4 | |
18294 | PHKK(K,I) = PSEC0(K) | |
18295 | TRCLPR(K) = TRCLPR(K)+PSEC0(K) | |
18296 | 28 CONTINUE | |
18297 | IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1 | |
18298 | IF (IDSEC.EQ.1) NPCW = NPCW-1 | |
18299 | ELSEIF (ISTHKK(I).EQ.16) THEN | |
18300 | DO 29 K=1,4 | |
18301 | PHKK(K,I) = PSEC0(K) | |
18302 | TRCLTA(K) = TRCLTA(K)+PSEC0(K) | |
18303 | 29 CONTINUE | |
18304 | IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1 | |
18305 | IF (IDSEC.EQ.1) NTCW = NTCW-1 | |
18306 | ENDIF | |
18307 | GOTO 20 | |
18308 | ENDIF | |
18309 | ||
18310 | IF (JPMOD.EQ.1) THEN | |
18311 | PSECN = SQRT( (PSEC(4)-AMSEC)*(PSEC(4)+AMSEC) ) | |
18312 | * 4-momentum after correction for nuclear potential | |
18313 | DO 22 K=1,3 | |
18314 | PSEC(K) = PSEC(K)*PSECN/PSECO | |
18315 | 22 CONTINUE | |
18316 | ||
18317 | * store recoil momentum from particles escaping the nuclear potentials | |
18318 | DO 30 K=1,4 | |
18319 | IF (IPOT.EQ.1) THEN | |
18320 | TRCLPR(K) = TRCLPR(K)+PSEC0(K)-PSEC(K) | |
18321 | ELSEIF (IPOT.EQ.2) THEN | |
18322 | TRCLTA(K) = TRCLTA(K)+PSEC0(K)-PSEC(K) | |
18323 | ENDIF | |
18324 | 30 CONTINUE | |
18325 | ||
18326 | * transform momentum back into n-n cms | |
18327 | IMODE = IPOT+1 | |
18328 | CALL DT_LTRANS(PSEC(1),PSEC(2),PSEC(3),PSEC(4), | |
18329 | & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I), | |
18330 | & IDSEC,IMODE) | |
18331 | ENDIF | |
18332 | ||
18333 | ENDIF | |
18334 | ||
18335 | 23 CONTINUE | |
18336 | DO 31 K=1,4 | |
18337 | PFSP(K) = PFSP(K)+PHKK(K,I) | |
18338 | 31 CONTINUE | |
18339 | ||
18340 | 20 CONTINUE | |
18341 | ||
18342 | DO 33 I=NPOINT(4),NHKK | |
18343 | IF ((ISTHKK(I).EQ.1).AND.(IDXOTH(I).LT.0)) THEN | |
18344 | PFSP(1) = PFSP(1)+PHKK(1,I) | |
18345 | PFSP(2) = PFSP(2)+PHKK(2,I) | |
18346 | PFSP(3) = PFSP(3)+PHKK(3,I) | |
18347 | PFSP(4) = PFSP(4)+PHKK(4,I) | |
18348 | ENDIF | |
18349 | 33 CONTINUE | |
18350 | ||
18351 | DO 34 K=1,5 | |
18352 | PRCLPR(K) = TRCLPR(K) | |
18353 | PRCLTA(K) = TRCLTA(K) | |
18354 | 34 CONTINUE | |
18355 | ||
18356 | IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN | |
18357 | * hadron-nucleus interactions: get residual momentum from energy- | |
18358 | * momentum conservation | |
18359 | DO 32 K=1,4 | |
18360 | PRCLPR(K) = ZERO | |
18361 | PRCLTA(K) = PINIPR(K)+PINITA(K)-PFSP(K) | |
18362 | 32 CONTINUE | |
18363 | ELSE | |
18364 | * nucleus-hadron, nucleus-nucleus: get residual momentum from | |
18365 | * accumulated recoil momenta of particles leaving the spectators | |
18366 | * transform accumulated recoil momenta of residual nuclei into | |
18367 | * n-n cms | |
18368 | PZI = PRCLPR(3) | |
18369 | PEI = PRCLPR(4) | |
18370 | CALL DT_LTNUC(PZI,PEI,PRCLPR(3),PRCLPR(4),2) | |
18371 | PZI = PRCLTA(3) | |
18372 | PEI = PRCLTA(4) | |
18373 | CALL DT_LTNUC(PZI,PEI,PRCLTA(3),PRCLTA(4),3) | |
18374 | C IF (IP.GT.1) THEN | |
18375 | PRCLPR(3) = PRCLPR(3)+PINIPR(3) | |
18376 | PRCLPR(4) = PRCLPR(4)+PINIPR(4) | |
18377 | C ENDIF | |
18378 | IF (IT.GT.1) THEN | |
18379 | PRCLTA(3) = PRCLTA(3)+PINITA(3) | |
18380 | PRCLTA(4) = PRCLTA(4)+PINITA(4) | |
18381 | ENDIF | |
18382 | ENDIF | |
18383 | ||
18384 | * check momenta of residual nuclei | |
18385 | IF (LEMCCK) THEN | |
18386 | CALL DT_EVTEMC(-PINIPR(1),-PINIPR(2),-PINIPR(3),-PINIPR(4), | |
18387 | & 1,IDUM,IDUM) | |
18388 | CALL DT_EVTEMC(-PINITA(1),-PINITA(2),-PINITA(3),-PINITA(4), | |
18389 | & 2,IDUM,IDUM) | |
18390 | CALL DT_EVTEMC(PRCLPR(1),PRCLPR(2),PRCLPR(3),PRCLPR(4), | |
18391 | & 2,IDUM,IDUM) | |
18392 | CALL DT_EVTEMC(PRCLTA(1),PRCLTA(2),PRCLTA(3),PRCLTA(4), | |
18393 | & 2,IDUM,IDUM) | |
18394 | CALL DT_EVTEMC(PFSP(1),PFSP(2),PFSP(3),PFSP(4),2,IDUM,IDUM) | |
18395 | **sr 19.12. changed to avoid output when used with phojet | |
18396 | C CHKLEV = TINY3 | |
18397 | CHKLEV = TINY1 | |
18398 | CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,501,IREJ1) | |
18399 | C IF ((NEVHKK.EQ.409).OR.(NEVHKK.EQ.460).OR.(NEVHKK.EQ.765)) | |
18400 | C & CALL DT_EVTOUT(4) | |
18401 | IF (IREJ1.GT.0) RETURN | |
18402 | ENDIF | |
18403 | ||
18404 | RETURN | |
18405 | END | |
18406 | ||
18407 | *$ CREATE DT_SCN4BA.FOR | |
18408 | *COPY DT_SCN4BA | |
18409 | * | |
18410 | *===scn4ba=============================================================* | |
18411 | * | |
18412 | SUBROUTINE DT_SCN4BA | |
18413 | ||
18414 | ************************************************************************ | |
18415 | * SCan /DTEVT1/ 4 BAryons which are not able to escape nuclear pot. * | |
18416 | * This version dated 12.12.95 is written by S. Roesler. * | |
18417 | ************************************************************************ | |
18418 | ||
18419 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
18420 | SAVE | |
18421 | PARAMETER ( LINP = 10 , | |
18422 | & LOUT = 6 , | |
18423 | & LDAT = 9 ) | |
18424 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2, | |
18425 | & TINY10=1.0D-10) | |
18426 | ||
18427 | * event history | |
18428 | PARAMETER (NMXHKK=200000) | |
18429 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
18430 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
18431 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
18432 | * extended event history | |
18433 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
18434 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
18435 | & IHIST(2,NMXHKK) | |
18436 | * particle properties (BAMJET index convention) | |
18437 | CHARACTER*8 ANAME | |
18438 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
18439 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
18440 | * properties of interacting particles | |
18441 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
18442 | * nuclear potential | |
18443 | LOGICAL LFERMI | |
18444 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, | |
18445 | & EBINDP(2),EBINDN(2),EPOT(2,210), | |
18446 | & ETACOU(2),ICOUL,LFERMI | |
18447 | * treatment of residual nuclei: wounded nucleons | |
18448 | COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210) | |
18449 | * treatment of residual nuclei: 4-momenta | |
18450 | LOGICAL LRCLPR,LRCLTA | |
18451 | COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5), | |
18452 | & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA | |
18453 | ||
18454 | DIMENSION PLAB(2,5),PCMS(4) | |
18455 | ||
18456 | IREJ = 0 | |
18457 | ||
18458 | * get number of wounded nucleons | |
18459 | NPW = 0 | |
18460 | NPW0 = 0 | |
18461 | NPCW = 0 | |
18462 | NPSTCK = 0 | |
18463 | NTW = 0 | |
18464 | NTW0 = 0 | |
18465 | NTCW = 0 | |
18466 | NTSTCK = 0 | |
18467 | ||
18468 | ISGLPR = 0 | |
18469 | ISGLTA = 0 | |
18470 | LRCLPR = .FALSE. | |
18471 | LRCLTA = .FALSE. | |
18472 | ||
18473 | C DO 2 I=1,NHKK | |
18474 | DO 2 I=1,NPOINT(1) | |
18475 | * projectile nucleons wounded in primary interaction and in fzc | |
18476 | IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.17)) THEN | |
18477 | NPW = NPW+1 | |
18478 | IPW(NPW) = I | |
18479 | NPSTCK = NPSTCK+1 | |
18480 | IF (IDHKK(I).EQ.2212) NPCW = NPCW+1 | |
18481 | IF (ISTHKK(I).EQ.11) NPW0 = NPW0+1 | |
18482 | C IF (IP.GT.1) THEN | |
18483 | DO 5 K=1,4 | |
18484 | TRCLPR(K) = TRCLPR(K)-PHKK(K,I) | |
18485 | 5 CONTINUE | |
18486 | C ENDIF | |
18487 | * target nucleons wounded in primary interaction and in fzc | |
18488 | ELSEIF ((ISTHKK(I).EQ.12).OR.(ISTHKK(I).EQ.18)) THEN | |
18489 | NTW = NTW+1 | |
18490 | ITW(NTW) = I | |
18491 | NTSTCK = NTSTCK+1 | |
18492 | IF (IDHKK(I).EQ.2212) NTCW = NTCW+1 | |
18493 | IF (ISTHKK(I).EQ.12) NTW0 = NTW0+1 | |
18494 | IF (IT.GT.1) THEN | |
18495 | DO 6 K=1,4 | |
18496 | TRCLTA(K) = TRCLTA(K)-PHKK(K,I) | |
18497 | 6 CONTINUE | |
18498 | ENDIF | |
18499 | ELSEIF (ISTHKK(I).EQ.13) THEN | |
18500 | ISGLPR = I | |
18501 | ELSEIF (ISTHKK(I).EQ.14) THEN | |
18502 | ISGLTA = I | |
18503 | ENDIF | |
18504 | 2 CONTINUE | |
18505 | ||
18506 | DO 11 I=NPOINT(4),NHKK | |
18507 | * baryons which are unable to escape the nuclear potential of proj. | |
18508 | IF (ISTHKK(I).EQ.15) THEN | |
18509 | ISGLPR = I | |
18510 | NPSTCK = NPSTCK-1 | |
18511 | IF (IIBAR(IDBAM(I)).NE.0) THEN | |
18512 | NPW = NPW-1 | |
18513 | IF (IICH(IDBAM(I)).GT.0) NPCW = NPCW-1 | |
18514 | ENDIF | |
18515 | DO 7 K=1,4 | |
18516 | TRCLPR(K) = TRCLPR(K)+PHKK(K,I) | |
18517 | 7 CONTINUE | |
18518 | * baryons which are unable to escape the nuclear potential of targ. | |
18519 | ELSEIF (ISTHKK(I).EQ.16) THEN | |
18520 | ISGLTA = I | |
18521 | NTSTCK = NTSTCK-1 | |
18522 | IF (IIBAR(IDBAM(I)).NE.0) THEN | |
18523 | NTW = NTW-1 | |
18524 | IF (IICH(IDBAM(I)).GT.0) NTCW = NTCW-1 | |
18525 | ENDIF | |
18526 | DO 8 K=1,4 | |
18527 | TRCLTA(K) = TRCLTA(K)+PHKK(K,I) | |
18528 | 8 CONTINUE | |
18529 | ENDIF | |
18530 | 11 CONTINUE | |
18531 | ||
18532 | * residual nuclei so far | |
18533 | IRESP = IP-NPSTCK | |
18534 | IREST = IT-NTSTCK | |
18535 | ||
18536 | * ckeck for "residual nuclei" consisting of one nucleon only | |
18537 | * treat it as final state particle | |
18538 | IF (IRESP.EQ.1) THEN | |
18539 | ID = IDBAM(ISGLPR) | |
18540 | IST = ISTHKK(ISGLPR) | |
18541 | CALL DT_LTRANS(PHKK(1,ISGLPR),PHKK(2,ISGLPR), | |
18542 | & PHKK(3,ISGLPR),PHKK(4,ISGLPR), | |
18543 | & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,2) | |
18544 | IF (IST.EQ.13) THEN | |
18545 | ISTHKK(ISGLPR) = 11 | |
18546 | ELSE | |
18547 | ISTHKK(ISGLPR) = 2 | |
18548 | ENDIF | |
18549 | CALL DT_EVTPUT(1,IDHKK(ISGLPR),ISGLPR,0, | |
18550 | & PCMS(1),PCMS(2),PCMS(3),PCMS(4), | |
18551 | & IDRES(ISGLPR),IDXRES(ISGLPR),IDCH(ISGLPR)) | |
18552 | NOBAM(NHKK) = NOBAM(ISGLPR) | |
18553 | JDAHKK(1,ISGLPR) = NHKK | |
18554 | DO 21 K=1,4 | |
18555 | TRCLPR(K) = TRCLPR(K)-PHKK(K,ISGLPR) | |
18556 | 21 CONTINUE | |
18557 | ENDIF | |
18558 | IF (IREST.EQ.1) THEN | |
18559 | ID = IDBAM(ISGLTA) | |
18560 | IST = ISTHKK(ISGLTA) | |
18561 | CALL DT_LTRANS(PHKK(1,ISGLTA),PHKK(2,ISGLTA), | |
18562 | & PHKK(3,ISGLTA),PHKK(4,ISGLTA), | |
18563 | & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,3) | |
18564 | IF (IST.EQ.14) THEN | |
18565 | ISTHKK(ISGLTA) = 12 | |
18566 | ELSE | |
18567 | ISTHKK(ISGLTA) = 2 | |
18568 | ENDIF | |
18569 | CALL DT_EVTPUT(1,IDHKK(ISGLTA),ISGLTA,0, | |
18570 | & PCMS(1),PCMS(2),PCMS(3),PCMS(4), | |
18571 | & IDRES(ISGLTA),IDXRES(ISGLTA),IDCH(ISGLTA)) | |
18572 | NOBAM(NHKK) = NOBAM(ISGLTA) | |
18573 | JDAHKK(1,ISGLTA) = NHKK | |
18574 | DO 22 K=1,4 | |
18575 | TRCLTA(K) = TRCLTA(K)-PHKK(K,ISGLTA) | |
18576 | 22 CONTINUE | |
18577 | ENDIF | |
18578 | ||
18579 | * get nuclear potential corresp. to the residual nucleus | |
18580 | IPRCL = IP -NPW | |
18581 | IPZRCL = IPZ-NPCW | |
18582 | ITRCL = IT -NTW | |
18583 | ITZRCL = ITZ-NTCW | |
18584 | CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1) | |
18585 | ||
18586 | * baryons unable to escape the nuclear potential are treated as | |
18587 | * excited nucleons (ISTHKK=15,16) | |
18588 | DO 3 I=NPOINT(4),NHKK | |
18589 | IF (ISTHKK(I).EQ.1) THEN | |
18590 | ID = IDBAM(I) | |
18591 | IF ( ((ID.EQ.1).OR.(ID.EQ.8)).AND.(NOBAM(I).NE.3) ) THEN | |
18592 | * final state n and p not being outside of both nuclei are considered | |
18593 | NPOTP = 1 | |
18594 | NPOTT = 1 | |
18595 | IF ( (IP.GT.1) .AND.(IRESP.GT.1).AND. | |
18596 | & (NOBAM(I).NE.1).AND.(NPW.GT.0) ) THEN | |
18597 | * Lorentz-trsf. into proj. rest sys. for those being inside proj. | |
18598 | CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I), | |
18599 | & PHKK(4,I),PLAB(1,1),PLAB(1,2),PLAB(1,3), | |
18600 | & PLAB(1,4),ID,-2) | |
18601 | PLABT = SQRT(PLAB(1,1)**2+PLAB(1,2)**2+PLAB(1,3)**2) | |
18602 | PLAB(1,5) = SQRT(ABS( (PLAB(1,4)-PLABT)* | |
18603 | & (PLAB(1,4)+PLABT) )) | |
18604 | EKIN = PLAB(1,4)-PLAB(1,5) | |
18605 | IF (EKIN.LE.EPOT(1,ID)) NPOTP = 15 | |
18606 | IF ((ID.EQ.1).AND.(NPCW.LE.0)) NPOTP = 1 | |
18607 | ENDIF | |
18608 | IF ( (IT.GT.1) .AND.(IREST.GT.1).AND. | |
18609 | & (NOBAM(I).NE.2).AND.(NTW.GT.0) ) THEN | |
18610 | * Lorentz-trsf. into targ. rest sys. for those being inside targ. | |
18611 | CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I), | |
18612 | & PHKK(4,I),PLAB(2,1),PLAB(2,2),PLAB(2,3), | |
18613 | & PLAB(2,4),ID,-3) | |
18614 | PLABT = SQRT(PLAB(2,1)**2+PLAB(2,2)**2+PLAB(2,3)**2) | |
18615 | PLAB(2,5) = SQRT(ABS( (PLAB(2,4)-PLABT)* | |
18616 | & (PLAB(2,4)+PLABT) )) | |
18617 | EKIN = PLAB(2,4)-PLAB(2,5) | |
18618 | IF (EKIN.LE.EPOT(2,ID)) NPOTT = 16 | |
18619 | IF ((ID.EQ.1).AND.(NTCW.LE.0)) NPOTT = 1 | |
18620 | ENDIF | |
18621 | IF (PHKK(3,I).GE.ZERO) THEN | |
18622 | ISTHKK(I) = NPOTT | |
18623 | IF (NPOTP.NE.1) ISTHKK(I) = NPOTP | |
18624 | ELSE | |
18625 | ISTHKK(I) = NPOTP | |
18626 | IF (NPOTT.NE.1) ISTHKK(I) = NPOTT | |
18627 | ENDIF | |
18628 | IF (ISTHKK(I).NE.1) THEN | |
18629 | J = ISTHKK(I)-14 | |
18630 | DO 4 K=1,5 | |
18631 | PHKK(K,I) = PLAB(J,K) | |
18632 | 4 CONTINUE | |
18633 | IF (ISTHKK(I).EQ.15) THEN | |
18634 | NPW = NPW-1 | |
18635 | IF (ID.EQ.1) NPCW = NPCW-1 | |
18636 | DO 9 K=1,4 | |
18637 | TRCLPR(K) = TRCLPR(K)+PHKK(K,I) | |
18638 | 9 CONTINUE | |
18639 | ELSEIF (ISTHKK(I).EQ.16) THEN | |
18640 | NTW = NTW-1 | |
18641 | IF (ID.EQ.1) NTCW = NTCW-1 | |
18642 | DO 10 K=1,4 | |
18643 | TRCLTA(K) = TRCLTA(K)+PHKK(K,I) | |
18644 | 10 CONTINUE | |
18645 | ENDIF | |
18646 | ENDIF | |
18647 | ENDIF | |
18648 | ENDIF | |
18649 | 3 CONTINUE | |
18650 | ||
18651 | * again: get nuclear potential corresp. to the residual nucleus | |
18652 | IPRCL = IP -NPW | |
18653 | IPZRCL = IPZ-NPCW | |
18654 | ITRCL = IT -NTW | |
18655 | ITZRCL = ITZ-NTCW | |
18656 | c AFERP = 1.2D0*FERMOD*(ONE+(DBLE(IP+10-NPW0)/DBLE(IP+10))**1.1D0) | |
18657 | cC AFERP = 1.21D0*FERMOD*(ONE+(DBLE(IP+40-NPW0)/DBLE(IP+40))**1.1D0) | |
18658 | c & *(0.94D0+0.3D0*EXP(-DBLE(NPW0)/5.0D0)) /2.0D0 | |
18659 | C AFERP = 0.0D0 | |
18660 | c AFERT = 1.2D0*FERMOD*(ONE+(DBLE(IT+10-NTW0)/DBLE(IT+10))**1.1D0) | |
18661 | cC AFERT = 1.21D0*FERMOD*(ONE+(DBLE(IT+40-NTW0)/DBLE(IT+40))**1.1D0) | |
18662 | c & *(0.94D0+0.3D0*EXP(-DBLE(NTW0)/5.0D0)) /2.0D0 | |
18663 | C AFERT = 0.0D0 | |
18664 | C IF (AFERP.LT.FERMOD) AFERP = FERMOD+0.1 | |
18665 | C IF (AFERT.LT.FERMOD) AFERT = FERMOD+0.1 | |
18666 | C IF (AFERP.GT.0.85D0) AFERP = 0.85D0 | |
18667 | C IF (AFERT.GT.0.85D0) AFERT = 0.85D0 | |
18668 | AFERP = FERMOD+0.1D0 | |
18669 | AFERT = FERMOD+0.1D0 | |
18670 | ||
18671 | CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,AFERP,AFERT,1) | |
18672 | ||
18673 | RETURN | |
18674 | END | |
18675 | ||
18676 | *$ CREATE DT_FICONF.FOR | |
18677 | *COPY DT_FICONF | |
18678 | * | |
18679 | *===ficonf=============================================================* | |
18680 | * | |
18681 | SUBROUTINE DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ) | |
18682 | ||
18683 | ************************************************************************ | |
18684 | * Treatment of FInal CONFiguration including evaporation, fission and * | |
18685 | * Fermi-break-up (for light nuclei only). * | |
18686 | * Adopted from the original routine FINALE and extended to residual * | |
18687 | * projectile nuclei. * | |
18688 | * This version dated 12.12.95 is written by S. Roesler. * | |
18689 | * * | |
18690 | * Last change 27.12.2006 by S. Roesler. * | |
18691 | ************************************************************************ | |
18692 | ||
18693 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
18694 | SAVE | |
18695 | PARAMETER ( LINP = 10 , | |
18696 | & LOUT = 6 , | |
18697 | & LDAT = 9 ) | |
18698 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10) | |
18699 | PARAMETER (ANGLGB=5.0D-16) | |
18700 | PARAMETER (AMUAMU=0.93149432D0,AMELEC=0.51099906D-3) | |
18701 | ||
18702 | * event history | |
18703 | PARAMETER (NMXHKK=200000) | |
18704 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
18705 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
18706 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
18707 | * extended event history | |
18708 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
18709 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
18710 | & IHIST(2,NMXHKK) | |
18711 | * rejection counter | |
18712 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
18713 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
18714 | & IREXCI(3),IRDIFF(2),IRINC | |
18715 | * central particle production, impact parameter biasing | |
18716 | COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR | |
18717 | * particle properties (BAMJET index convention) | |
18718 | CHARACTER*8 ANAME | |
18719 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
18720 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
18721 | * treatment of residual nuclei: 4-momenta | |
18722 | LOGICAL LRCLPR,LRCLTA | |
18723 | COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5), | |
18724 | & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA | |
18725 | * treatment of residual nuclei: properties of residual nuclei | |
18726 | COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2), | |
18727 | & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2), | |
18728 | & NTOTFI(2),NPROFI(2) | |
18729 | * statistics: residual nuclei | |
18730 | COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2), | |
18731 | & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2), | |
18732 | & NINCST(2,4),NINCEV(2), | |
18733 | & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2), | |
18734 | & NRESPB(2),NRESCH(2),NRESEV(4), | |
18735 | & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240), | |
18736 | & NEVAFI(2,2) | |
18737 | * flags for input different options | |
18738 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
18739 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
18740 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
18741 | * (original name: FINUC) | |
18742 | PARAMETER (MXP=999) | |
18743 | COMMON /FKFINU/ CXR (MXP), CYR (MXP), CZR (MXP), | |
18744 | & CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP), | |
18745 | & TKI (MXP), PLR (MXP), WEI (MXP), | |
18746 | & TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP, | |
18747 | & KPART (MXP) | |
18748 | * (original name: RESNUC) | |
18749 | LOGICAL LRNFSS, LFRAGM | |
18750 | COMMON /FKRESN/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1, | |
18751 | & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT, | |
18752 | & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES, | |
18753 | & PYRES, PZRES, PTRES2, KTARP, KTARN, IGREYP, | |
18754 | & IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE, | |
18755 | & ICRES, IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU, | |
18756 | & IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG, | |
18757 | & IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS, | |
18758 | & LFRAGM | |
18759 | COMMON /FKNDAT/ AV0WEL, APFRMX, AEFRMX, AEFRMA, | |
18760 | & RDSNUC, V0WELL (2), PFRMMX (2), EFRMMX (2), | |
18761 | & EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2), | |
18762 | & VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2), | |
18763 | & PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2), | |
18764 | & EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2), | |
18765 | & ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV , | |
18766 | & AMRCSQ , ATO1O3 , ZTO1O3 , ELBNDE (0:100) | |
18767 | * (original name: PAREVT) | |
18768 | LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX, | |
18769 | & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF | |
18770 | PARAMETER ( NALLWP = 39 ) | |
18771 | COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, | |
18772 | & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY, | |
18773 | & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV, | |
18774 | & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF | |
18775 | * event flag | |
18776 | COMMON /DTEVNO/ NEVENT,ICASCA | |
18777 | ||
18778 | DIMENSION INUC(2),IDXPAR(2),IDPAR(2),AIF(2),AIZF(2),AMRCL(2), | |
18779 | & PRCL(2,4),MO1(2),MO2(2),VRCL(2,4),WRCL(2,4), | |
18780 | & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4) | |
18781 | ||
18782 | DIMENSION EXPNUC(2),EXC(2,260),NEXC(2,260) | |
18783 | LOGICAL LLCPOT | |
18784 | DATA EXC,NEXC /520*ZERO,520*0/ | |
18785 | DATA EXPNUC /4.0D-3,4.0D-3/ | |
18786 | ||
18787 | IREJ = 0 | |
18788 | LRCLPR = .FALSE. | |
18789 | LRCLTA = .FALSE. | |
18790 | ||
18791 | * skip residual nucleus treatment if not requested or in case | |
18792 | * of central collisions | |
18793 | IF ((.NOT.LEVPRT).OR.(ICENTR.GT.0).OR.(ICENTR.EQ.-1)) RETURN | |
18794 | ||
18795 | DO 1 K=1,2 | |
18796 | IDPAR(K) = 0 | |
18797 | IDXPAR(K)= 0 | |
18798 | NTOT(K) = 0 | |
18799 | NTOTFI(K)= 0 | |
18800 | NPRO(K) = 0 | |
18801 | NPROFI(K)= 0 | |
18802 | NN(K) = 0 | |
18803 | NH(K) = 0 | |
18804 | NHPOS(K) = 0 | |
18805 | NQ(K) = 0 | |
18806 | EEXC(K) = ZERO | |
18807 | MO1(K) = 0 | |
18808 | MO2(K) = 0 | |
18809 | DO 2 I=1,4 | |
18810 | VRCL(K,I) = ZERO | |
18811 | WRCL(K,I) = ZERO | |
18812 | 2 CONTINUE | |
18813 | 1 CONTINUE | |
18814 | NFSP = 0 | |
18815 | INUC(1) = IP | |
18816 | INUC(2) = IT | |
18817 | ||
18818 | DO 3 I=1,NHKK | |
18819 | ||
18820 | * number of final state particles | |
18821 | IF (ABS(ISTHKK(I)).EQ.1) THEN | |
18822 | NFSP = NFSP+1 | |
18823 | IDFSP = IDBAM(I) | |
18824 | ENDIF | |
18825 | ||
18826 | * properties of remaining nucleon configurations | |
18827 | KF = 0 | |
18828 | IF ((ISTHKK(I).EQ.13).OR.(ISTHKK(I).EQ.15)) KF = 1 | |
18829 | IF ((ISTHKK(I).EQ.14).OR.(ISTHKK(I).EQ.16)) KF = 2 | |
18830 | IF (KF.GT.0) THEN | |
18831 | IF (MO1(KF).EQ.0) MO1(KF) = I | |
18832 | MO2(KF) = I | |
18833 | * position of residual nucleus = average position of nucleons | |
18834 | DO 4 K=1,4 | |
18835 | VRCL(KF,K) = VRCL(KF,K)+VHKK(K,I) | |
18836 | WRCL(KF,K) = WRCL(KF,K)+WHKK(K,I) | |
18837 | 4 CONTINUE | |
18838 | * total number of particles contributing to each residual nucleus | |
18839 | NTOT(KF) = NTOT(KF)+1 | |
18840 | IDTMP = IDBAM(I) | |
18841 | IDXTMP = I | |
18842 | * total charge of residual nuclei | |
18843 | NQ(KF) = NQ(KF)+IICH(IDTMP) | |
18844 | * number of protons | |
18845 | IF (IDHKK(I).EQ.2212) THEN | |
18846 | NPRO(KF) = NPRO(KF)+1 | |
18847 | * number of neutrons | |
18848 | ELSEIF (IDHKK(I).EQ.2112) THEN | |
18849 | NN(KF) = NN(KF)+1 | |
18850 | ELSE | |
18851 | * number of baryons other than n, p | |
18852 | IF (IIBAR(IDTMP).EQ.1) THEN | |
18853 | NH(KF) = NH(KF)+1 | |
18854 | IF (IICH(IDTMP).EQ.1) NHPOS(KF) = NHPOS(KF)+1 | |
18855 | ELSE | |
18856 | * any other mesons (status set to 1) | |
18857 | C WRITE(LOUT,1002) KF,IDTMP | |
18858 | C1002 FORMAT(1X,'FICONF: residual nucleus ',I2, | |
18859 | C & ' containing meson ',I4,', status set to 1') | |
18860 | ISTHKK(I) = 1 | |
18861 | IDTMP = IDPAR(KF) | |
18862 | IDXTMP = IDXPAR(KF) | |
18863 | NTOT(KF) = NTOT(KF)-1 | |
18864 | ENDIF | |
18865 | ENDIF | |
18866 | IDPAR(KF) = IDTMP | |
18867 | IDXPAR(KF) = IDXTMP | |
18868 | ENDIF | |
18869 | 3 CONTINUE | |
18870 | ||
18871 | * reject elastic events (def: one final state particle = projectile) | |
18872 | IF ((IP.EQ.1).AND.(NFSP.EQ.1).AND.(IDFSP.EQ.IJPROJ)) THEN | |
18873 | IREXCI(3) = IREXCI(3)+1 | |
18874 | GOTO 9999 | |
18875 | C RETURN | |
18876 | ENDIF | |
18877 | ||
18878 | * check if one nucleus disappeared.. | |
18879 | C IF ((IP.GT.1).AND.(NTOT(1).EQ.0).AND.(NTOT(2).NE.0)) THEN | |
18880 | C DO 5 K=1,4 | |
18881 | C PRCLTA(K) = PRCLTA(K)+PRCLPR(K) | |
18882 | C PRCLPR(K) = ZERO | |
18883 | C 5 CONTINUE | |
18884 | C ELSEIF ((IT.GT.1).AND.(NTOT(2).EQ.0).AND.(NTOT(1).NE.0)) THEN | |
18885 | C DO 6 K=1,4 | |
18886 | C PRCLPR(K) = PRCLPR(K)+PRCLTA(K) | |
18887 | C PRCLTA(K) = ZERO | |
18888 | C 6 CONTINUE | |
18889 | C ENDIF | |
18890 | ||
18891 | ICOR = 0 | |
18892 | INORCL = 0 | |
18893 | DO 7 I=1,2 | |
18894 | DO 8 K=1,4 | |
18895 | * get the average of the nucleon positions | |
18896 | VRCL(I,K) = VRCL(I,K)/MAX(NTOT(I),1) | |
18897 | WRCL(I,K) = WRCL(I,K)/MAX(NTOT(I),1) | |
18898 | IF (I.EQ.1) PRCL(1,K) = PRCLPR(K) | |
18899 | IF (I.EQ.2) PRCL(2,K) = PRCLTA(K) | |
18900 | 8 CONTINUE | |
18901 | * mass number and charge of residual nuclei | |
18902 | AIF(I) = DBLE(NTOT(I)) | |
18903 | AIZF(I) = DBLE(NPRO(I)+NHPOS(I)) | |
18904 | IF (NTOT(I).GT.1) THEN | |
18905 | * masses of residual nuclei in ground state | |
18906 | AMRCL0(I) = AIF(I)*AMUAMU+1.0D-3*DT_ENERGY(AIF(I),AIZF(I)) | |
18907 | * masses of residual nuclei | |
18908 | PTORCL = SQRT(PRCL(I,1)**2+PRCL(I,2)**2+PRCL(I,3)**2) | |
18909 | AMRCL(I) = (PRCL(I,4)-PTORCL)*(PRCL(I,4)+PTORCL) | |
18910 | IF (AMRCL(I).GT.ZERO) AMRCL(I) = SQRT(AMRCL(I)) | |
18911 | * | |
18912 | * M_res^2 < 0 : configuration not allowed | |
18913 | * | |
18914 | * a) re-calculate E_exc with scaled nuclear potential | |
18915 | * (conditional jump to label 9998) | |
18916 | * b) or reject event if N_loop(max) is exceeded | |
18917 | * (conditional jump to label 9999) | |
18918 | * | |
18919 | IF (AMRCL(I).LE.ZERO) THEN | |
18920 | IF (IOULEV(3).GT.0) | |
18921 | & WRITE(LOUT,1000) I,PRCL(I,1),PRCL(I,2),PRCL(I,3), | |
18922 | & PRCL(I,4),NTOT | |
18923 | 1000 FORMAT(1X,'warning! negative excitation energy',/, | |
18924 | & I4,4E15.4,2I4) | |
18925 | AMRCL(I) = ZERO | |
18926 | EEXC(I) = ZERO | |
18927 | IF (NLOOP.LE.500) THEN | |
18928 | GOTO 9998 | |
18929 | ELSE | |
18930 | IREXCI(2) = IREXCI(2)+1 | |
18931 | GOTO 9999 | |
18932 | ENDIF | |
18933 | * | |
18934 | * 0 < M_res < M_res0 : mass below ground-state mass | |
18935 | * | |
18936 | * a) we had residual nuclei with mass N_tot and reasonable E_exc | |
18937 | * before- assign average E_exc of those configurations to this | |
18938 | * one ( Nexc(i,N_tot) > 0 ) | |
18939 | * b) or (and this applies always if run in transport codes) go up | |
18940 | * one mass number and | |
18941 | * i) if mass now larger than proj/targ mass or if run in | |
18942 | * transport codes assign average E_exc per wounded nucleon | |
18943 | * x number of wounded nucleons (Inuc-Ntot) | |
18944 | * ii) or assign average E_exc of those configurations to this | |
18945 | * one ( Nexc(i,m) > 0 ) | |
18946 | * | |
18947 | ELSEIF ((AMRCL(I).GT.ZERO).AND.(AMRCL(I).LT.AMRCL0(I))) | |
18948 | & THEN | |
18949 | M = MIN(NTOT(I),260) | |
18950 | IF (NEXC(I,M).GT.0) THEN | |
18951 | AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M)) | |
18952 | ELSE | |
18953 | 70 CONTINUE | |
18954 | M = M+1 | |
18955 | **sr corrected 27.12.06 | |
18956 | * IF (M.GE.INUC(I)) THEN | |
18957 | * AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I)) | |
18958 | IF ((M.GE.INUC(I)).OR.(ICASCA.GT.0)) THEN | |
18959 | IF ( INUC (I) .GT. NTOT (I) ) THEN | |
18960 | AMRCL(I) = AMRCL0(I) | |
18961 | & + EXPNUC(I)*DBLE(MAX(INUC(I)-NTOT(I),0)) | |
18962 | ELSE | |
18963 | AMRCL(I) = AMRCL0(I) + 0.5D+00 * EXPNUC(I) | |
18964 | END IF | |
18965 | ** | |
18966 | ELSE | |
18967 | IF (NEXC(I,M).GT.0) THEN | |
18968 | AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M)) | |
18969 | ELSE | |
18970 | GOTO 70 | |
18971 | ENDIF | |
18972 | ENDIF | |
18973 | ENDIF | |
18974 | EEXC(I) = AMRCL(I)-AMRCL0(I) | |
18975 | ICOR = ICOR+I | |
18976 | * | |
18977 | * M_res > 2.5 x M_res0 : unreasonably(?) high E_exc | |
18978 | * | |
18979 | * a) re-calculate E_exc with scaled nuclear potential | |
18980 | * (conditional jump to label 9998) | |
18981 | * b) or reject event if N_loop(max) is exceeded | |
18982 | * (conditional jump to label 9999) | |
18983 | * | |
18984 | * | |
18985 | ELSEIF (AMRCL(I).GE.2.5D0*AMRCL0(I)) THEN | |
18986 | IF (IOULEV(3).GT.0) | |
18987 | & WRITE(LOUT,1004) I,AMRCL(I),AMRCL0(I),NTOT,NEVHKK | |
18988 | 1004 FORMAT(1X,'warning! too high excitation energy',/, | |
18989 | & I4,1P,2E15.4,3I5) | |
18990 | AMRCL(I) = ZERO | |
18991 | EEXC(I) = ZERO | |
18992 | IF (NLOOP.LE.500) THEN | |
18993 | GOTO 9998 | |
18994 | ELSE | |
18995 | IREXCI(2) = IREXCI(2)+1 | |
18996 | GOTO 9999 | |
18997 | ENDIF | |
18998 | * | |
18999 | * Otherwise (reasonable E_exc) : | |
19000 | * E_exc = M_res - M_res0 | |
19001 | * in addition: calculate and save E_exc per wounded nucleon as | |
19002 | * well as E_exc in <E_exc> counter | |
19003 | * | |
19004 | ELSE | |
19005 | * excitation energies of residual nuclei | |
19006 | EEXC(I) = AMRCL(I)-AMRCL0(I) | |
19007 | **sr 27.12.06 new excitation energy correction by A.F. | |
19008 | * | |
19009 | * all parts with Ilcopt<3 commented since not used | |
19010 | * | |
19011 | * still to be done/decided: | |
19012 | * Increase Icor and put back both residual nuclei on mass shell | |
19013 | * with the exciting correction further below. | |
19014 | * For the moment the modification in the excitation energy is simply | |
19015 | * corrected by scaling the energy of the residual nucleus. | |
19016 | * | |
19017 | LLCPOT = .TRUE. | |
19018 | ILCOPT = 3 | |
19019 | IF ( LLCPOT ) THEN | |
19020 | NNCHIT = MAX ( INUC (I) - NTOT (I), 0 ) | |
19021 | IF ( ILCOPT .LE. 2 ) THEN | |
19022 | C* Patch for Fermi momentum reduction correlated with impact parameter: | |
19023 | C FRMRDC = MIN ( (PFRMAV(INUC(I))/APFRMX)**3, ONE ) | |
19024 | C DLKPRH = 0.1D+00 + 0.5D+00 / SQRT(DBLE(INUC(I))) | |
19025 | C AKPRHO = ONE - DLKPRH | |
19026 | C* f x K rho_cen + (1-f) x 0.5 x K rho_cen = frmrdc x rho_cen | |
19027 | C FRCFLL = MAX ( 2.D+00 * FRMRDC / AKPRHO - ONE, | |
19028 | C & 0.05D+00 ) | |
19029 | C* REDORI = 0.75D+00 | |
19030 | C* REDORI = ONE | |
19031 | C REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00) | |
19032 | ELSE | |
19033 | DLKPRH = ZERO | |
19034 | RDCORE = 1.14D+00 * DBLE(INUC(I))**(ONE/3.D+00) | |
19035 | * Take out roughly one/half of the skin: | |
19036 | RDCORE = RDCORE - 0.5D+00 | |
19037 | FRCFLL = RDCORE**3 | |
19038 | PRSKIN = (RDCORE+2.4D+00)**3 - FRCFLL | |
19039 | PRSKIN = 0.5D+00 * PRSKIN / ( PRSKIN + FRCFLL ) | |
19040 | FRCFLL = ONE - PRSKIN | |
19041 | FRMRDC = FRCFLL + 0.5D+00 * PRSKIN | |
19042 | REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00) | |
19043 | END IF | |
19044 | IF ( NNCHIT .GT. 0 ) THEN | |
19045 | C IF ( ILCOPT .EQ. 1 ) THEN | |
19046 | C SKINRH = ONE - FRCFLL / (DBLE(INUC(I))-ONE) | |
19047 | C DO 1220 NCH = 1, 10 | |
19048 | C ETAETA = ( ONE - SKINRH**INUC(I) | |
19049 | C & - DBLE(INUC(I))* ( ONE - FRCFLL ) | |
19050 | C & * ( ONE - SKINRH ) ) | |
19051 | C & / ( SKINRH**INUC(I) - DBLE (INUC(I)) | |
19052 | C & * ( ONE - FRCFLL) * SKINRH ) | |
19053 | C SKINRH = SKINRH * ( ONE + ETAETA ) | |
19054 | C 1220 CONTINUE | |
19055 | C PRSKIN = SKINRH**(NNCHIT-1) | |
19056 | C ELSE IF ( ILCOPT .EQ. 2 ) THEN | |
19057 | C PRSKIN = ONE - FRCFLL | |
19058 | C END IF | |
19059 | REDCTN = ZERO | |
19060 | DO 1230 NCH = 1, NNCHIT | |
19061 | IF (DT_RNDM(PRFRMI) .LT. PRSKIN) THEN | |
19062 | PRFRMI = (( ONE - 2.D+00 * DLKPRH ) | |
19063 | & * DT_RNDM(PRFRMI))**0.333333333333D+00 | |
19064 | ELSE | |
19065 | PRFRMI = ( ONE - 2.D+00 * DLKPRH | |
19066 | & * DT_RNDM(PRFRMI))**0.333333333333D+00 | |
19067 | END IF | |
19068 | REDCTN = REDCTN + PRFRMI**2 | |
19069 | 1230 CONTINUE | |
19070 | REDCTN = REDCTN / DBLE (NNCHIT) | |
19071 | ELSE | |
19072 | REDCTN = 0.5D+00 | |
19073 | END IF | |
19074 | EEXC (I) = EEXC (I) * REDCTN / REDORI | |
19075 | AMRCL (I) = AMRCL0 (I) + EEXC (I) | |
19076 | PRCL(I,4) = SQRT ( PTORCL**2 + AMRCL(I)**2 ) | |
19077 | END IF | |
19078 | ** | |
19079 | IF (ICASCA.EQ.0) THEN | |
19080 | EXPNUC(I) = EEXC(I)/MAX(1,INUC(I)-NTOT(I)) | |
19081 | M = MIN(NTOT(I),260) | |
19082 | EXC(I,M) = EXC(I,M)+EEXC(I) | |
19083 | NEXC(I,M) = NEXC(I,M)+1 | |
19084 | ENDIF | |
19085 | ENDIF | |
19086 | ELSEIF (NTOT(I).EQ.1) THEN | |
19087 | WRITE(LOUT,1003) I | |
19088 | 1003 FORMAT(1X,'FICONF: warning! NTOT(I)=1? (I=',I3,')') | |
19089 | GOTO 9999 | |
19090 | ELSE | |
19091 | AMRCL0(I) = ZERO | |
19092 | AMRCL(I) = ZERO | |
19093 | EEXC(I) = ZERO | |
19094 | INORCL = INORCL+I | |
19095 | ENDIF | |
19096 | 7 CONTINUE | |
19097 | ||
19098 | PRCLPR(5) = AMRCL(1) | |
19099 | PRCLTA(5) = AMRCL(2) | |
19100 | ||
19101 | IF (ICOR.GT.0) THEN | |
19102 | IF (INORCL.EQ.0) THEN | |
19103 | * one or both residual nuclei consist of one nucleon only, transform | |
19104 | * this nucleon on mass shell | |
19105 | DO 9 K=1,4 | |
19106 | P1IN(K) = PRCL(1,K) | |
19107 | P2IN(K) = PRCL(2,K) | |
19108 | 9 CONTINUE | |
19109 | XM1 = AMRCL(1) | |
19110 | XM2 = AMRCL(2) | |
19111 | CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1) | |
19112 | IF (IREJ1.GT.0) THEN | |
19113 | WRITE(LOUT,*) 'ficonf-mashel rejection' | |
19114 | GOTO 9999 | |
19115 | ENDIF | |
19116 | DO 10 K=1,4 | |
19117 | PRCL(1,K) = P1OUT(K) | |
19118 | PRCL(2,K) = P2OUT(K) | |
19119 | PRCLPR(K) = P1OUT(K) | |
19120 | PRCLTA(K) = P2OUT(K) | |
19121 | 10 CONTINUE | |
19122 | PRCLPR(5) = AMRCL(1) | |
19123 | PRCLTA(5) = AMRCL(2) | |
19124 | ELSE | |
19125 | IF (IOULEV(3).GT.0) | |
19126 | & WRITE(LOUT,1001) NEVHKK,INT(AIF(1)),INT(AIZF(1)), | |
19127 | & INT(AIF(2)),INT(AIZF(2)),AMRCL0(1), | |
19128 | & AMRCL(1),AMRCL(1)-AMRCL0(1),AMRCL0(2), | |
19129 | & AMRCL(2),AMRCL(2)-AMRCL0(2) | |
19130 | 1001 FORMAT(1X,'FICONF: warning! no residual nucleus for', | |
19131 | & ' correction',/,11X,'at event',I8, | |
19132 | & ', nucleon config. 1:',2I4,' 2:',2I4, | |
19133 | & 2(/,11X,3E12.3)) | |
19134 | IF (NLOOP.LE.500) THEN | |
19135 | GOTO 9998 | |
19136 | ELSE | |
19137 | IREXCI(1) = IREXCI(1)+1 | |
19138 | ENDIF | |
19139 | ENDIF | |
19140 | ENDIF | |
19141 | ||
19142 | * update counter | |
19143 | C IF (NRESEV(1).NE.NEVHKK) THEN | |
19144 | C NRESEV(1) = NEVHKK | |
19145 | C NRESEV(2) = NRESEV(2)+1 | |
19146 | C ENDIF | |
19147 | NRESEV(2) = NRESEV(2)+1 | |
19148 | DO 15 I=1,2 | |
19149 | EXCDPM(I) = EXCDPM(I)+EEXC(I) | |
19150 | EXCDPM(I+2) = EXCDPM(I+2)+(EEXC(I)/MAX(NTOT(I),1)) | |
19151 | NRESTO(I) = NRESTO(I)+NTOT(I) | |
19152 | NRESPR(I) = NRESPR(I)+NPRO(I) | |
19153 | NRESNU(I) = NRESNU(I)+NN(I) | |
19154 | NRESBA(I) = NRESBA(I)+NH(I) | |
19155 | NRESPB(I) = NRESPB(I)+NHPOS(I) | |
19156 | NRESCH(I) = NRESCH(I)+NQ(I) | |
19157 | 15 CONTINUE | |
19158 | ||
19159 | * evaporation | |
19160 | IF (LEVPRT) THEN | |
19161 | DO 13 I=1,2 | |
19162 | * initialize evaporation counter | |
19163 | EEXCFI(I) = ZERO | |
19164 | IF ((INUC(I).GT.1).AND.(AIF(I).GT.ONE).AND. | |
19165 | & (EEXC(I).GT.ZERO)) THEN | |
19166 | * put residual nuclei into DTEVT1 | |
19167 | IDRCL = 80000 | |
19168 | JMASS = INT( AIF(I)) | |
19169 | JCHAR = INT(AIZF(I)) | |
19170 | * the following patch is required to transmit the correct excitation | |
19171 | * energy to Eventd | |
19172 | IF (ITRSPT.EQ.1) THEN | |
19173 | IF ((ABS(AMRCL(I)-AMRCL0(I)-EEXC(I)).GT.1.D-04).AND. | |
19174 | & (IOULEV(3).GT.0)) | |
19175 | & WRITE(LOUT,*) | |
19176 | & ' DT_FICONF:AMRCL(I),AMRCL0(I),EEXC(I)', | |
19177 | & AMRCL(I),AMRCL0(I),EEXC(I) | |
19178 | PRCL0 = PRCL(I,4) | |
19179 | PRCL(I,4) =SQRT(AMRCL(I)**2+PRCL(I,1)**2+PRCL(I,2)**2 | |
19180 | & +PRCL(I,3)**2) | |
19181 | IF (ABS(PRCL0-PRCL(I,4)).GT.0.1D0) THEN | |
19182 | WRITE(LOUT,*) | |
19183 | & ' PRCL(I,4) recalculated :',PRCL0,PRCL(I,4) | |
19184 | ENDIF | |
19185 | ENDIF | |
19186 | CALL DT_EVTPUT(1000,IDRCL,MO1(I),MO2(I),PRCL(I,1), | |
19187 | & PRCL(I,2),PRCL(I,3),PRCL(I,4),JMASS,JCHAR,0) | |
19188 | **sr 22.6.97 | |
19189 | NOBAM(NHKK) = I | |
19190 | ** | |
19191 | DO 14 J=1,4 | |
19192 | VHKK(J,NHKK) = VRCL(I,J) | |
19193 | WHKK(J,NHKK) = WRCL(I,J) | |
19194 | 14 CONTINUE | |
19195 | * interface to evaporation module - fill final residual nucleus into | |
19196 | * common FKRESN | |
19197 | * fill resnuc only if code is not used as event generator in Fluka | |
19198 | IF (ITRSPT.NE.1) THEN | |
19199 | PXRES = PRCL(I,1) | |
19200 | PYRES = PRCL(I,2) | |
19201 | PZRES = PRCL(I,3) | |
19202 | IBRES = NPRO(I)+NN(I)+NH(I) | |
19203 | ICRES = NPRO(I)+NHPOS(I) | |
19204 | ANOW = DBLE(IBRES) | |
19205 | ZNOW = DBLE(ICRES) | |
19206 | PTRES = SQRT(PXRES**2+PYRES**2+PZRES**2) | |
19207 | * ground state mass of the residual nucleus (should be equal to AM0T) | |
19208 | AMMRES = AMRCL0(I) | |
19209 | AMNRES = AMMRES-ZNOW*AMELEC+ELBNDE(ICRES) | |
19210 | * common FKFINU | |
19211 | TV = ZERO | |
19212 | * kinetic energy of residual nucleus | |
19213 | TVRECL = PRCL(I,4)-AMRCL(I) | |
19214 | * excitation energy of residual nucleus | |
19215 | TVCMS = EEXC(I) | |
19216 | PTOLD = PTRES | |
19217 | PTRES = SQRT(ABS(TVRECL*(TVRECL+ | |
19218 | & 2.0D0*(AMMRES+TVCMS)))) | |
19219 | IF (PTOLD.LT.ANGLGB) THEN | |
19220 | CALL DT_RACO(PXRES,PYRES,PZRES) | |
19221 | PTOLD = ONE | |
19222 | ENDIF | |
19223 | PXRES = PXRES*PTRES/PTOLD | |
19224 | PYRES = PYRES*PTRES/PTOLD | |
19225 | PZRES = PZRES*PTRES/PTOLD | |
19226 | * zero counter of secondaries from evaporation | |
19227 | NP = 0 | |
19228 | * evaporation | |
19229 | WE = ONE | |
19230 | CALL DT_EVEVAP(WE) | |
19231 | * put evaporated particles and residual nuclei to DTEVT1 | |
19232 | MO = NHKK | |
19233 | CALL DT_EVA2HE(MO,EXCITF,I,IREJ1) | |
19234 | ENDIF | |
19235 | EEXCFI(I) = EXCITF | |
19236 | EXCEVA(I) = EXCEVA(I)+EXCITF | |
19237 | ENDIF | |
19238 | 13 CONTINUE | |
19239 | ENDIF | |
19240 | ||
19241 | RETURN | |
19242 | ||
19243 | C9998 IREXCI(1) = IREXCI(1)+1 | |
19244 | 9998 IREJ = IREJ+1 | |
19245 | 9999 CONTINUE | |
19246 | LRCLPR = .TRUE. | |
19247 | LRCLTA = .TRUE. | |
19248 | IREJ = IREJ+1 | |
19249 | RETURN | |
19250 | END | |
19251 | ||
19252 | *$ CREATE DT_EVA2HE.FOR | |
19253 | *COPY DT_EVA2HE | |
19254 | * * | |
19255 | *====eva2he============================================================* | |
19256 | * * | |
19257 | SUBROUTINE DT_EVA2HE(MO,EEXCF,IRCL,IREJ) | |
19258 | ||
19259 | ************************************************************************ | |
19260 | * Interface between common's of evaporation module (FKFINU,FKFHVY) * | |
19261 | * and DTEVT1. * | |
19262 | * MO DTEVT1-index of "mother" (residual) nucleus before evap. * | |
19263 | * EEXCF exitation energy of residual nucleus after evaporation * | |
19264 | * IRCL = 1 projectile residual nucleus * | |
19265 | * = 2 target residual nucleus * | |
19266 | * This version dated 19.04.95 is written by S. Roesler. * | |
19267 | * * | |
19268 | * Last change 27.12.2006 by S. Roesler. * | |
19269 | ************************************************************************ | |
19270 | ||
19271 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
19272 | SAVE | |
19273 | PARAMETER ( LINP = 10 , | |
19274 | & LOUT = 6 , | |
19275 | & LDAT = 9 ) | |
19276 | PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3) | |
19277 | ||
19278 | * event history | |
19279 | PARAMETER (NMXHKK=200000) | |
19280 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
19281 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
19282 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
19283 | * Note: DTEVT2 - special use for heavy fragments ! | |
19284 | * (IDRES(I) = mass number, IDXRES(I) = charge) | |
19285 | * extended event history | |
19286 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
19287 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
19288 | & IHIST(2,NMXHKK) | |
19289 | * particle properties (BAMJET index convention) | |
19290 | CHARACTER*8 ANAME | |
19291 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
19292 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
19293 | * flags for input different options | |
19294 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
19295 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
19296 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
19297 | * statistics: residual nuclei | |
19298 | COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2), | |
19299 | & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2), | |
19300 | & NINCST(2,4),NINCEV(2), | |
19301 | & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2), | |
19302 | & NRESPB(2),NRESCH(2),NRESEV(4), | |
19303 | & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240), | |
19304 | & NEVAFI(2,2) | |
19305 | * treatment of residual nuclei: properties of residual nuclei | |
19306 | COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2), | |
19307 | & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2), | |
19308 | & NTOTFI(2),NPROFI(2) | |
19309 | * (original name: FINUC) | |
19310 | PARAMETER (MXP=999) | |
19311 | COMMON /FKFINU/ CXR (MXP), CYR (MXP), CZR (MXP), | |
19312 | & CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP), | |
19313 | & TKI (MXP), PLR (MXP), WEI (MXP), | |
19314 | & TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP, | |
19315 | & KPART (MXP) | |
19316 | * (original name: FHEAVY,FHEAVC) | |
19317 | PARAMETER ( MXHEAV = 100 ) | |
19318 | CHARACTER*8 ANHEAV | |
19319 | COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV), | |
19320 | & CZHEAV (MXHEAV), TKHEAV (MXHEAV), | |
19321 | & PHEAVY (MXHEAV), WHEAVY (MXHEAV), | |
19322 | & AMHEAV ( 12 ) , AMNHEA ( 12 ) , | |
19323 | & KHEAVY (MXHEAV), ICHEAV ( 12 ) , | |
19324 | & IBHEAV ( 12 ) , NPHEAV | |
19325 | COMMON /FKFHVC/ ANHEAV ( 12 ) | |
19326 | * (original name: RESNUC) | |
19327 | LOGICAL LRNFSS, LFRAGM | |
19328 | COMMON /FKRESN/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1, | |
19329 | & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT, | |
19330 | & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES, | |
19331 | & PYRES, PZRES, PTRES2, KTARP, KTARN, IGREYP, | |
19332 | & IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE, | |
19333 | & ICRES, IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU, | |
19334 | & IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG, | |
19335 | & IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS, | |
19336 | & LFRAGM | |
19337 | ||
19338 | DIMENSION IPTOKP(39) | |
19339 | DATA IPTOKP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, | |
19340 | & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 99, | |
19341 | & 100, 101, 97, 102, 98, 103, 109, 115 / | |
19342 | ||
19343 | IREJ = 0 | |
19344 | ||
19345 | * skip if evaporation package is not included | |
19346 | IF (.NOT.LEVAPO) RETURN | |
19347 | ||
19348 | * update counter | |
19349 | IF (NRESEV(3).NE.NEVHKK) THEN | |
19350 | NRESEV(3) = NEVHKK | |
19351 | NRESEV(4) = NRESEV(4)+1 | |
19352 | ENDIF | |
19353 | ||
19354 | IF (LEMCCK) | |
19355 | & CALL DT_EVTEMC(PHKK(1,MO),PHKK(2,MO),PHKK(3,MO),PHKK(4,MO),1, | |
19356 | & IDUM,IDUM) | |
19357 | * mass number/charge of residual nucleus before evaporation | |
19358 | IBTOT = IDRES(MO) | |
19359 | IZTOT = IDXRES(MO) | |
19360 | ||
19361 | * protons/neutrons/gammas | |
19362 | DO 1 I=1,NP | |
19363 | PX = CXR(I)*PLR(I) | |
19364 | PY = CYR(I)*PLR(I) | |
19365 | PZ = CZR(I)*PLR(I) | |
19366 | ID = IPTOKP(KPART(I)) | |
19367 | IDPDG = IDT_IPDGHA(ID) | |
19368 | AM = ((PLR(I)+TKI(I))*(PLR(I)-TKI(I)))/ | |
19369 | & (2.0D0*MAX(TKI(I),TINY10)) | |
19370 | IF (ABS(AM-AAM(ID)).GT.TINY3) THEN | |
19371 | WRITE(LOUT,1000) ID,AM,AAM(ID) | |
19372 | 1000 FORMAT(1X,'EVA2HE: inconsistent mass of evap. ', | |
19373 | & 'particle',I3,2E10.3) | |
19374 | ENDIF | |
19375 | PE = TKI(I)+AM | |
19376 | CALL DT_EVTPUT(-1,IDPDG,MO,0,PX,PY,PZ,PE,0,0,0) | |
19377 | NOBAM(NHKK) = IRCL | |
19378 | IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM) | |
19379 | IBTOT = IBTOT-IIBAR(ID) | |
19380 | IZTOT = IZTOT-IICH(ID) | |
19381 | 1 CONTINUE | |
19382 | ||
19383 | * heavy fragments | |
19384 | DO 2 I=1,NPHEAV | |
19385 | PX = CXHEAV(I)*PHEAVY(I) | |
19386 | PY = CYHEAV(I)*PHEAVY(I) | |
19387 | PZ = CZHEAV(I)*PHEAVY(I) | |
19388 | IDHEAV = 80000 | |
19389 | AM = ((PHEAVY(I)+TKHEAV(I))*(PHEAVY(I)-TKHEAV(I)))/ | |
19390 | & (2.0D0*MAX(TKHEAV(I),TINY10)) | |
19391 | PE = TKHEAV(I)+AM | |
19392 | CALL DT_EVTPUT(-1,IDHEAV,MO,0,PX,PY,PZ,PE, | |
19393 | & IBHEAV(KHEAVY(I)),ICHEAV(KHEAVY(I)),0) | |
19394 | NOBAM(NHKK) = IRCL | |
19395 | IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM) | |
19396 | IBTOT = IBTOT-IBHEAV(KHEAVY(I)) | |
19397 | IZTOT = IZTOT-ICHEAV(KHEAVY(I)) | |
19398 | 2 CONTINUE | |
19399 | ||
19400 | IF (IBRES.GT.0) THEN | |
19401 | * residual nucleus after evaporation | |
19402 | IDNUC = 80000 | |
19403 | CALL DT_EVTPUT(1001,IDNUC,MO,0,PXRES,PYRES,PZRES,ERES, | |
19404 | & IBRES,ICRES,0) | |
19405 | NOBAM(NHKK) = IRCL | |
19406 | ENDIF | |
19407 | EEXCF = TVCMS | |
19408 | NTOTFI(IRCL) = IBRES | |
19409 | NPROFI(IRCL) = ICRES | |
19410 | IF (LEMCCK) CALL DT_EVTEMC(-PXRES,-PYRES,-PZRES,-ERES,2,IDUM,IDUM) | |
19411 | IBTOT = IBTOT-IBRES | |
19412 | IZTOT = IZTOT-ICRES | |
19413 | ||
19414 | * count events with fission | |
19415 | NEVAFI(1,IRCL) = NEVAFI(1,IRCL)+1 | |
19416 | IF (LRNFSS) NEVAFI(2,IRCL) = NEVAFI(2,IRCL)+1 | |
19417 | ||
19418 | * energy-momentum conservation check | |
19419 | IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,40,IREJ) | |
19420 | C IF (IREJ.GT.0) THEN | |
19421 | C CALL DT_EVTOUT(4) | |
19422 | C WRITE(*,*) EEXC(2),EEXCFI(2),NP,NPHEAV | |
19423 | C ENDIF | |
19424 | * baryon-number/charge conservation check | |
19425 | IF (IBTOT+IZTOT.NE.0) THEN | |
19426 | WRITE(LOUT,1001) NEVHKK,IBTOT,IZTOT | |
19427 | 1001 FORMAT(1X,'EVA2HE: baryon-number/charge conservation ', | |
19428 | & 'failure at event ',I8,' : IBTOT,IZTOT = ',2I3) | |
19429 | ENDIF | |
19430 | ||
19431 | RETURN | |
19432 | END | |
19433 | ||
19434 | *$ CREATE DT_EBIND.FOR | |
19435 | *COPY DT_EBIND | |
19436 | * | |
19437 | *===ebind==============================================================* | |
19438 | * | |
19439 | DOUBLE PRECISION FUNCTION DT_EBIND(IA,IZ) | |
19440 | ||
19441 | ************************************************************************ | |
19442 | * Binding energy for nuclei. * | |
19443 | * (Shirokov & Yudin, Yad. Fizika, Nauka, Moskva 1972) * | |
19444 | * IA mass number * | |
19445 | * IZ atomic number * | |
19446 | * This version dated 5.5.95 is updated by S. Roesler. * | |
19447 | ************************************************************************ | |
19448 | ||
19449 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
19450 | SAVE | |
19451 | PARAMETER ( LINP = 10 , | |
19452 | & LOUT = 6 , | |
19453 | & LDAT = 9 ) | |
19454 | PARAMETER (ZERO=0.0D0) | |
19455 | ||
19456 | DATA A1, A2, A3, A4, A5 | |
19457 | & / 0.01575D0, 0.0178D0, 0.000710D0, 0.0237D0, 0.034D0/ | |
19458 | ||
19459 | IF ((IA.LE.1).OR.(IZ.EQ.0)) THEN | |
19460 | WRITE(LOUT,'(1X,A,2I5)') 'DT_EBIND IA,IZ set EBIND=0. ',IA,IZ | |
19461 | DT_EBIND = ZERO | |
19462 | RETURN | |
19463 | ENDIF | |
19464 | AA = IA | |
19465 | DT_EBIND = A1*AA - A2*AA**0.666667D0-A3*IZ*IZ*AA**(-0.333333D0) | |
19466 | & -A4*(IA-2*IZ)**2/AA | |
19467 | IF (MOD(IA,2).EQ.1) THEN | |
19468 | IA5 = 0 | |
19469 | ELSEIF (MOD(IZ,2).EQ.1) THEN | |
19470 | IA5 = 1 | |
19471 | ELSE | |
19472 | IA5 = -1 | |
19473 | ENDIF | |
19474 | DT_EBIND = DT_EBIND - IA5*A5*AA**(-0.75D0) | |
19475 | ||
19476 | RETURN | |
19477 | END | |
19478 | ||
19479 | **sr 30.6. routine replaced completely | |
19480 | *$ CREATE DT_ENERGY.FOR | |
19481 | *COPY DT_ENERGY | |
19482 | * * | |
19483 | *=== energy ===========================================================* | |
19484 | * * | |
19485 | DOUBLE PRECISION FUNCTION DT_ENERGY( A, Z ) | |
19486 | ||
19487 | C INCLUDE '(DBLPRC)' | |
19488 | * DBLPRC.ADD | |
19489 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
19490 | SAVE | |
19491 | * (original name: GLOBAL) | |
19492 | PARAMETER ( KALGNM = 2 ) | |
19493 | PARAMETER ( ANGLGB = 5.0D-16 ) | |
19494 | PARAMETER ( ANGLSQ = 2.5D-31 ) | |
19495 | PARAMETER ( AXCSSV = 0.2D+16 ) | |
19496 | PARAMETER ( ANDRFL = 1.0D-38 ) | |
19497 | PARAMETER ( AVRFLW = 1.0D+38 ) | |
19498 | PARAMETER ( AINFNT = 1.0D+30 ) | |
19499 | PARAMETER ( AZRZRZ = 1.0D-30 ) | |
19500 | PARAMETER ( EINFNT = +69.07755278982137 D+00 ) | |
19501 | PARAMETER ( EZRZRZ = -69.07755278982137 D+00 ) | |
19502 | PARAMETER ( EXCSSV = +35.23192357547063 D+00 ) | |
19503 | PARAMETER ( ENGLGB = -35.23192357547063 D+00 ) | |
19504 | PARAMETER ( ONEMNS = 0.999999999999999 D+00 ) | |
19505 | PARAMETER ( ONEPLS = 1.000000000000001 D+00 ) | |
19506 | PARAMETER ( CSNNRM = 2.0D-15 ) | |
19507 | PARAMETER ( DMXTRN = 1.0D+08 ) | |
19508 | PARAMETER ( ZERZER = 0.D+00 ) | |
19509 | PARAMETER ( ONEONE = 1.D+00 ) | |
19510 | PARAMETER ( TWOTWO = 2.D+00 ) | |
19511 | PARAMETER ( THRTHR = 3.D+00 ) | |
19512 | PARAMETER ( FOUFOU = 4.D+00 ) | |
19513 | PARAMETER ( FIVFIV = 5.D+00 ) | |
19514 | PARAMETER ( SIXSIX = 6.D+00 ) | |
19515 | PARAMETER ( SEVSEV = 7.D+00 ) | |
19516 | PARAMETER ( EIGEIG = 8.D+00 ) | |
19517 | PARAMETER ( ANINEN = 9.D+00 ) | |
19518 | PARAMETER ( TENTEN = 10.D+00 ) | |
19519 | PARAMETER ( HLFHLF = 0.5D+00 ) | |
19520 | PARAMETER ( ONETHI = ONEONE / THRTHR ) | |
19521 | PARAMETER ( TWOTHI = TWOTWO / THRTHR ) | |
19522 | PARAMETER ( ONEFOU = ONEONE / FOUFOU ) | |
19523 | PARAMETER ( THRTWO = THRTHR / TWOTWO ) | |
19524 | PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 ) | |
19525 | PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 ) | |
19526 | PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 ) | |
19527 | PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 ) | |
19528 | PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 ) | |
19529 | PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 ) | |
19530 | PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 ) | |
19531 | PARAMETER ( EULERO = 0.577215664901532860606512 D+00 ) | |
19532 | PARAMETER ( EULEXP = 1.781072417990197985236504 D+00 ) | |
19533 | PARAMETER ( EULLOG =-0.5495393129816448223376619 D+00 ) | |
19534 | PARAMETER ( E1M2EU = 0.8569023337737540831433017 D+00 ) | |
19535 | PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 ) | |
19536 | PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 ) | |
19537 | PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 ) | |
19538 | PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 ) | |
19539 | PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 ) | |
19540 | PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 ) | |
19541 | PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 ) | |
19542 | PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 ) | |
19543 | PARAMETER ( CLIGHT = 2.99792458 D+10 ) | |
19544 | PARAMETER ( AVOGAD = 6.0221367 D+23 ) | |
19545 | PARAMETER ( BOLTZM = 1.380658 D-23 ) | |
19546 | PARAMETER ( AMELGR = 9.1093897 D-28 ) | |
19547 | PARAMETER ( PLCKBR = 1.05457266 D-27 ) | |
19548 | PARAMETER ( ELCCGS = 4.8032068 D-10 ) | |
19549 | PARAMETER ( ELCMKS = 1.60217733 D-19 ) | |
19550 | PARAMETER ( AMUGRM = 1.6605402 D-24 ) | |
19551 | PARAMETER ( AMMUMU = 0.113428913 D+00 ) | |
19552 | PARAMETER ( AMPRMU = 1.007276470 D+00 ) | |
19553 | PARAMETER ( AMNEMU = 1.008664904 D+00 ) | |
19554 | PARAMETER ( ALPFSC = 7.2973530791728595 D-03 ) | |
19555 | PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 ) | |
19556 | PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 ) | |
19557 | PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 ) | |
19558 | PARAMETER ( PLABRC = 0.197327053 D+00 ) | |
19559 | PARAMETER ( AMELCT = 0.51099906 D-03 ) | |
19560 | PARAMETER ( AMUGEV = 0.93149432 D+00 ) | |
19561 | PARAMETER ( AMMUON = 0.105658389 D+00 ) | |
19562 | PARAMETER ( AMPRTN = 0.93827231 D+00 ) | |
19563 | PARAMETER ( AMNTRN = 0.93956563 D+00 ) | |
19564 | PARAMETER ( AMDEUT = 1.87561339 D+00 ) | |
19565 | PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13 | |
19566 | & * 1.D-09 ) | |
19567 | PARAMETER ( RCLSEL = 2.8179409183694872 D-13 ) | |
19568 | PARAMETER ( BLTZMN = 8.617385 D-14 ) | |
19569 | PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT ) | |
19570 | PARAMETER ( GFOHB3 = 1.16639 D-05 ) | |
19571 | PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC ) | |
19572 | PARAMETER ( SIN2TW = 0.2319 D+00 ) | |
19573 | PARAMETER ( GEVMEV = 1.0 D+03 ) | |
19574 | PARAMETER ( EMVGEV = 1.0 D-03 ) | |
19575 | PARAMETER ( ALGVMV = 6.90775527898214 D+00 ) | |
19576 | PARAMETER ( RADDEG = 180.D+00 / PIPIPI ) | |
19577 | PARAMETER ( DEGRAD = PIPIPI / 180.D+00 ) | |
19578 | LOGICAL LGBIAS, LGBANA | |
19579 | COMMON /FKGLOB/ LGBIAS, LGBANA | |
19580 | C INCLUDE '(DIMPAR)' | |
19581 | * DIMPAR.ADD | |
19582 | PARAMETER ( MXXRGN = 5000 ) | |
19583 | PARAMETER ( MXXMDF = 82 ) | |
19584 | PARAMETER ( MXXMDE = 54 ) | |
19585 | PARAMETER ( MFSTCK = 1000 ) | |
19586 | PARAMETER ( MESTCK = 100 ) | |
19587 | PARAMETER ( NALLWP = 39 ) | |
19588 | PARAMETER ( NELEMX = 80 ) | |
19589 | PARAMETER ( MPDPDX = 8 ) | |
19590 | PARAMETER ( ICOMAX = 180 ) | |
19591 | PARAMETER ( NSTBIS = 304 ) | |
19592 | PARAMETER ( IDMAXP = 220 ) | |
19593 | PARAMETER ( IDMXDC = 640 ) | |
19594 | PARAMETER ( MKBMX1 = 1 ) | |
19595 | PARAMETER ( MKBMX2 = 1 ) | |
19596 | C INCLUDE '(IOUNIT)' | |
19597 | * IOUNIT.ADD | |
19598 | PARAMETER ( LUNIN = 5 ) | |
19599 | PARAMETER ( LUNOUT = 6 ) | |
19600 | **sr 19.5. set error output-unit from 15 to 6 | |
19601 | PARAMETER ( LUNERR = 6 ) | |
19602 | PARAMETER ( LUNBER = 14 ) | |
19603 | PARAMETER ( LUNECH = 8 ) | |
19604 | PARAMETER ( LUNFLU = 13 ) | |
19605 | PARAMETER ( LUNGEO = 16 ) | |
19606 | PARAMETER ( LUNPMF = 12 ) | |
19607 | PARAMETER ( LUNRAN = 2 ) | |
19608 | PARAMETER ( LUNXSC = 9 ) | |
19609 | PARAMETER ( LUNDET = 17 ) | |
19610 | PARAMETER ( LUNRAY = 10 ) | |
19611 | PARAMETER ( LUNRDB = 1 ) | |
19612 | PARAMETER ( LUNPGO = 7 ) | |
19613 | PARAMETER ( LUNPGS = 4 ) | |
19614 | PARAMETER ( LUNSCR = 3 ) | |
19615 | * | |
19616 | *----------------------------------------------------------------------* | |
19617 | * * | |
19618 | * Revised version of the original routine from EVAP: * | |
19619 | * * | |
19620 | * Created on 15 may 1990 by Alfredo Ferrari & Paola Sala * | |
19621 | * Infn - Milan * | |
19622 | * * | |
19623 | * Last change on 19-sep-95 by Alfredo Ferrari * | |
19624 | * * | |
19625 | * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! * | |
19626 | * !!! It is supposed to be used with the updated atomic !!! * | |
19627 | * !!! mass data file !!! * | |
19628 | * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! * | |
19629 | * * | |
19630 | *----------------------------------------------------------------------* | |
19631 | * | |
19632 | * Mass number below which "unknown" isotopes out of the Z-interval | |
19633 | * reported in the mass tabulations are completely unstable and made | |
19634 | * up by Z proton masses + N neutron masses: | |
19635 | PARAMETER ( KAFREE = 4 ) | |
19636 | * Mass number below which "unknown" isotopes out of the Z-interval | |
19637 | * reported in the mass tabulations are supposed to be particle unstable | |
19638 | PARAMETER ( KAPUNS = 12 ) | |
19639 | * Minimum energy required for particle unstable isotopes | |
19640 | PARAMETER ( DEPUNS = 0.5D+00 ) | |
19641 | * | |
19642 | * (original name: EVA0) | |
19643 | COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001), | |
19644 | * FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6), | |
19645 | * CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200), | |
19646 | * T (4,7), RMASS (297), ALPH (297), BET (297), | |
19647 | * APRIME (250), IA (6), IZ (6) | |
19648 | * (original name: ISOTOP) | |
19649 | PARAMETER ( NAMSMX = 270 ) | |
19650 | PARAMETER ( NZGVAX = 15 ) | |
19651 | PARAMETER ( NISMMX = 574 ) | |
19652 | COMMON /FKISOT/ WAPS (NAMSMX,NZGVAX), T12NUC (NAMSMX,NZGVAX), | |
19653 | & WAPISM (NISMMX), T12ISM (NISMMX), | |
19654 | & ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260), | |
19655 | & AMSSST (100) , ISOMNM (NSTBIS), ISONDX (2,100), | |
19656 | & JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX), | |
19657 | & INWAPS (NAMSMX), JSPISM (NISMMX), | |
19658 | & JPTISM (NISMMX), IZWISM (NISMMX), | |
19659 | & INWISM (0:NAMSMX) | |
19660 | * | |
454792a9 | 19661 | CPH SAVE KA0, KZ0, IZ0 |
9aaba0d6 | 19662 | DATA KA0, KZ0, IZ0 / -1, -1, -1 / |
19663 | * | |
19664 | IFLAG = 1 | |
19665 | GO TO 10 | |
19666 | *======================================================================* | |
19667 | * * | |
19668 | * Entry ENergy - KNOWn * | |
19669 | * * | |
19670 | *======================================================================* | |
19671 | ENTRY DT_ENKNOW ( A, Z, IZZ0 ) | |
19672 | IZZ0 =-1 | |
19673 | IFLAG = 2 | |
19674 | 10 CONTINUE | |
19675 | * | |
19676 | KA0 = NINT ( A ) | |
19677 | KZ0 = NINT ( Z ) | |
19678 | N = KA0 - KZ0 | |
19679 | * +-------------------------------------------------------------------* | |
19680 | * | Null residual nucleus: | |
19681 | IF ( KA0 .EQ. 0 .AND. KZ0 .LE. 0 ) THEN | |
19682 | IF ( IFLAG .EQ. 1 ) THEN | |
19683 | DT_ENERGY = ZERZER | |
19684 | ELSE | |
19685 | DT_ENKNOW = ZERZER | |
19686 | IZZ0 = -1 | |
19687 | END IF | |
19688 | RETURN | |
19689 | * | | |
19690 | * +-------------------------------------------------------------------* | |
19691 | * | Only protons: | |
19692 | ELSE IF ( N .LE. 0 ) THEN | |
19693 | IF ( N .LT. 0 ) THEN | |
19694 | WRITE ( LUNOUT, * ) | |
19695 | & ' DPMJET stopped in energy: mass number =< atomic number !!', | |
19696 | & KA0, KZ0 | |
19697 | WRITE ( LUNOUT, * ) | |
19698 | & ' DPMJET stopped in energy: mass number =< atomic number !!', | |
19699 | & KA0, KZ0 | |
19700 | WRITE ( 77, * ) | |
19701 | & ' ^^^DPMJET stopped in energy: mass number =< atomic number !!', | |
19702 | & KA0, KZ0 | |
19703 | STOP 'DT_ENERGY:KA0-KZ0' | |
19704 | END IF | |
19705 | IZ0 = -1 | |
19706 | IF ( IFLAG .EQ. 1 ) THEN | |
19707 | DT_ENERGY = Z * WAPS ( 1, 2 ) | |
19708 | ELSE | |
19709 | DT_ENKNOW = Z * WAPS ( 1, 2 ) | |
19710 | IZZ0 = -1 | |
19711 | END IF | |
19712 | RETURN | |
19713 | * | | |
19714 | * +-------------------------------------------------------------------* | |
19715 | * | Only neutrons: | |
19716 | ELSE IF ( KZ0 .LE. 0 ) THEN | |
19717 | IF ( KZ0 .LT. 0 ) THEN | |
19718 | WRITE ( LUNOUT, * ) | |
19719 | & ' DPMJET stopped in energy: negative atomic number !!',KA0,KZ0 | |
19720 | WRITE ( LUNOUT, * ) | |
19721 | & ' DPMJET stopped in energy: negative atomic number !!',KA0,KZ0 | |
19722 | WRITE ( 77, * ) | |
19723 | &' ^^^DPMJET stopped in energy: negative atomic number !!',KA0,KZ0 | |
19724 | STOP 'DT_ENERGY:KZ0<0' | |
19725 | END IF | |
19726 | IZ0 = -1 | |
19727 | IF ( IFLAG .EQ. 1 ) THEN | |
19728 | DT_ENERGY = A * WAPS ( 1, 1 ) | |
19729 | ELSE | |
19730 | DT_ENKNOW = A * WAPS ( 1, 1 ) | |
19731 | IZZ0 = -1 | |
19732 | END IF | |
19733 | RETURN | |
19734 | END IF | |
19735 | * | | |
19736 | * +-------------------------------------------------------------------* | |
19737 | * +-------------------------------------------------------------------* | |
19738 | * | No actual nucleus | |
19739 | * | | |
19740 | * +-------------------------------------------------------------------* | |
19741 | * +-------------------------------------------------------------------* | |
19742 | * | A larger than maximum allowed: | |
19743 | IF ( KA0 .GT. NAMSMX ) THEN | |
19744 | IZ0 = -1 | |
19745 | IF ( IFLAG .EQ. 1 ) THEN | |
19746 | DT_ENERGY = DT_ENRG( A, Z ) | |
19747 | ELSE | |
19748 | DT_ENKNOW = DT_ENRG( A, Z ) | |
19749 | IZZ0 = -1 | |
19750 | END IF | |
19751 | RETURN | |
19752 | END IF | |
19753 | * | | |
19754 | * +-------------------------------------------------------------------* | |
19755 | IZZ = INWAPS ( KA0 ) | |
19756 | * +-------------------------------------------------------------------* | |
19757 | * | Too much neutron rich with respect to the stability line: | |
19758 | IF ( KZ0 .LT. IZZ ) THEN | |
19759 | * | +----------------------------------------------------------------* | |
19760 | * | | Up to A=Kafree all "bound" masses are known, set it unbound: | |
19761 | IF ( KA0 .LE. KAFREE ) THEN | |
19762 | DT_ENERGY = AINFNT | |
19763 | * | | | |
19764 | * | +----------------------------------------------------------------* | |
19765 | * | | Up to Kapuns: be sure it is particle unstable | |
19766 | ELSE IF ( KA0 .LE. KAPUNS ) THEN | |
19767 | * | | Exp. excess mass for A,IZZ | |
19768 | ENEEXP = WAPS ( KA0, 1 ) | |
19769 | * | | Cameron excess mass for A, IZZ | |
19770 | ENECA1 = DT_ENRG( A, DBLE (IZZ) ) | |
19771 | * | | Cameron excess mass for A, Z | |
19772 | DT_ENERGY = DT_ENRG( A, Z ) | |
19773 | * | | Use just the difference according to Cameron!!! | |
19774 | DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1 | |
19775 | JZZ = INWAPS ( KA0 - 1 ) | |
19776 | LZZ = INWAPS ( KA0 - 2 ) | |
19777 | * | | +-------------------------------------------------------------* | |
19778 | * | | | Residual mass for n-decay known: | |
19779 | IF ( KZ0 .GE. JZZ .AND. KZ0 .LE. JZZ + NZGVAX - 1 ) THEN | |
19780 | IZ0 = KZ0 - JZZ + 1 | |
19781 | DT_ENERGY = MAX(DT_ENERGY,WAPS (KA0-1,IZ0) + WAPS (1,1) | |
19782 | & + DEPUNS ) | |
19783 | * | | | | |
19784 | * | | +-------------------------------------------------------------* | |
19785 | * | | | Residual mass for 2n-decay known: | |
19786 | ELSE IF ( KZ0 .GE. LZZ .AND. KZ0 .LE. LZZ + NZGVAX - 1 )THEN | |
19787 | IZ0 = KZ0 - LZZ + 1 | |
19788 | DT_ENERGY = MAX ( DT_ENERGY, WAPS (KA0-2,IZ0) + TWOTWO * | |
19789 | & ( WAPS (1,1) + DEPUNS ) ) | |
19790 | * | | | | |
19791 | * | | +-------------------------------------------------------------* | |
19792 | * | | | Set it unbound: | |
19793 | ELSE | |
19794 | DT_ENERGY = AINFNT | |
19795 | END IF | |
19796 | * | | | | |
19797 | * | | +-------------------------------------------------------------* | |
19798 | * | | | |
19799 | * | +----------------------------------------------------------------* | |
19800 | * | | Proceed as usual: | |
19801 | ELSE | |
19802 | * | | Exp. excess mass for A,IZZ | |
19803 | ENEEXP = WAPS ( KA0, 1 ) | |
19804 | * | | Cameron excess mass for A, IZZ | |
19805 | ENECA1 = DT_ENRG( A, DBLE (IZZ) ) | |
19806 | * | | Cameron excess mass for A, Z | |
19807 | DT_ENERGY = DT_ENRG( A, Z ) | |
19808 | * | | Use just the difference according to Cameron!!! | |
19809 | DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1 | |
19810 | END IF | |
19811 | * | | | |
19812 | * | +----------------------------------------------------------------* | |
19813 | * | Be sure not to have a positive energy state: | |
19814 | DT_ENERGY = MIN(DT_ENERGY,(A-Z) * WAPS (1,1) + Z * WAPS (1,2) ) | |
19815 | IZ0 = -1 | |
19816 | IF ( IFLAG .EQ. 2 ) THEN | |
19817 | DT_ENKNOW = DT_ENERGY | |
19818 | IZZ0 = -1 | |
19819 | END IF | |
19820 | RETURN | |
19821 | * | | |
19822 | * +-------------------------------------------------------------------* | |
19823 | * | Too much proton rich with respect to the stability line: | |
19824 | ELSE IF ( KZ0 .GT. IZZ + NZGVAX - 1 ) THEN | |
19825 | * | +----------------------------------------------------------------* | |
19826 | * | | Up to A=Kafree all "bound" masses are known, set it unbound: | |
19827 | IF ( KA0 .LE. KAFREE ) THEN | |
19828 | DT_ENERGY = AINFNT | |
19829 | * | | | |
19830 | * | +----------------------------------------------------------------* | |
19831 | * | | Up to Kapuns: be sure it is particle unstable | |
19832 | ELSE IF ( KA0 .LE. KAPUNS ) THEN | |
19833 | * | | Exp. excess mass for A,IZZ+NZGVAX-1 | |
19834 | ENEEXP = WAPS ( KA0, NZGVAX ) | |
19835 | * | | Cameron excess mass for A, IZZ+NZGVAX-1 | |
19836 | ENECA1 = DT_ENRG( A, DBLE (IZZ+NZGVAX-1) ) | |
19837 | * | | Cameron excess mass for A, Z | |
19838 | DT_ENERGY = DT_ENRG( A, Z ) | |
19839 | * | | Use just the difference according to Cameron!!! | |
19840 | DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1 | |
19841 | JZZ = INWAPS ( KA0 - 1 ) | |
19842 | LZZ = INWAPS ( KA0 - 2 ) | |
19843 | * | | +-------------------------------------------------------------* | |
19844 | * | | | Residual mass for p-decay known: | |
19845 | IF ( KZ0-1 .GE. JZZ .AND. KZ0-1 .LE. JZZ + NZGVAX - 1 ) THEN | |
19846 | IZ0 = KZ0 - 1 - JZZ + 1 | |
19847 | DT_ENERGY = MAX (DT_ENERGY, WAPS (KA0-1,IZ0) + WAPS (1,2) | |
19848 | & + DEPUNS ) | |
19849 | * | | | | |
19850 | * | | +-------------------------------------------------------------* | |
19851 | * | | | Residual mass for 2p-decay known: | |
19852 | ELSE IF ( KZ0-2 .GE. LZZ .AND. KZ0-2 .LE. LZZ + NZGVAX - 1 ) | |
19853 | & THEN | |
19854 | IZ0 = KZ0 - 2 - LZZ + 1 | |
19855 | DT_ENERGY = MAX ( DT_ENERGY, WAPS (KA0-2,IZ0) + TWOTWO * | |
19856 | & ( WAPS (1,2) + DEPUNS ) ) | |
19857 | * | | | | |
19858 | * | | +-------------------------------------------------------------* | |
19859 | * | | | Set it unbound: | |
19860 | ELSE | |
19861 | DT_ENERGY = AINFNT | |
19862 | END IF | |
19863 | * | | | | |
19864 | * | | +-------------------------------------------------------------* | |
19865 | * | | | |
19866 | * | +----------------------------------------------------------------* | |
19867 | * | | Proceed as usual: | |
19868 | ELSE | |
19869 | * | | Exp. excess mass for A,IZZ+NZGVAX-1 | |
19870 | ENEEXP = WAPS ( KA0, NZGVAX ) | |
19871 | * | | Cameron excess mass for A, IZZ+NZGVAX-1 | |
19872 | ENECA1 = DT_ENRG( A, DBLE (IZZ+NZGVAX-1) ) | |
19873 | * | | Cameron excess mass for A, Z | |
19874 | DT_ENERGY = DT_ENRG( A, Z ) | |
19875 | * | | Use just the difference according to Cameron!!! | |
19876 | DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1 | |
19877 | END IF | |
19878 | * | | | |
19879 | * | +----------------------------------------------------------------* | |
19880 | * | Be sure not to have a positive energy state: | |
19881 | DT_ENERGY = MIN(DT_ENERGY,(A-Z) * WAPS (1,1) + Z * WAPS (1,2) ) | |
19882 | IZ0 = -1 | |
19883 | IF ( IFLAG .EQ. 2 ) THEN | |
19884 | DT_ENKNOW = DT_ENERGY | |
19885 | IZZ0 = -1 | |
19886 | END IF | |
19887 | RETURN | |
19888 | * | | |
19889 | * +-------------------------------------------------------------------* | |
19890 | * | Known isotope or anyway isotope "inside" the stability zone | |
19891 | ELSE | |
19892 | IZ0 = KZ0 - IZZ + 1 | |
19893 | DT_ENERGY = WAPS ( KA0, IZ0 ) | |
19894 | IF ( IFLAG .EQ. 2 ) IZZ0 = IZ0 | |
19895 | * | +----------------------------------------------------------------* | |
19896 | * | | Mass not known | |
19897 | IF ( ABS (DT_ENERGY) .LT. ANGLGB .AND. (KA0 .NE. 12 .OR. KZ0 | |
19898 | & .NE. 6) ) THEN | |
19899 | IF ( IFLAG .EQ. 2 ) IZZ0 = -1 | |
19900 | * | | +-------------------------------------------------------------* | |
19901 | * | | | Set it unbound: | |
19902 | IF ( KA0 .LE. KAFREE ) THEN | |
19903 | DT_ENERGY = AINFNT | |
19904 | * | | | | |
19905 | * | | +-------------------------------------------------------------* | |
19906 | * | | | Try to get a reasonable excess mass: | |
19907 | ELSE | |
19908 | JZ0 = -100 | |
19909 | * | | | +----------------------------------------------------------* | |
19910 | * | | | | Check the closest one known: | |
19911 | DO 500 JZZ = 1, NZGVAX | |
19912 | IF ( ABS ( WAPS (KA0,JZZ) ) .GT. ANGLGB .AND. | |
19913 | & ABS (JZZ-IZ0) .LT. ABS (JZ0-IZ0) ) JZ0 = JZZ | |
19914 | IF ( ABS (JZ0-IZ0) .EQ. 1 ) GO TO 550 | |
19915 | 500 CONTINUE | |
19916 | * | | | | | |
19917 | * | | | +----------------------------------------------------------* | |
19918 | 550 CONTINUE | |
19919 | * | | | Exp. excess mass for A,IZZ+JZ0-1 | |
19920 | ENEEXP = WAPS ( KA0, JZ0 ) | |
19921 | * | | | Cameron excess mass for A, IZZ+JZ0-1 | |
19922 | ENECA1 = DT_ENRG( A, DBLE (IZZ+JZ0-1) ) | |
19923 | * | | | Cameron excess mass for A, Z | |
19924 | DT_ENERGY = DT_ENRG( A, Z ) | |
19925 | * | | | Use just the difference according to Cameron!!! | |
19926 | DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1 | |
19927 | IZ0 = -1 | |
19928 | END IF | |
19929 | * | | | | |
19930 | * | | +-------------------------------------------------------------* | |
19931 | * | | Be sure not to have a positive energy state: | |
19932 | DT_ENERGY = MIN(DT_ENERGY,(A-Z)*WAPS(1,1)+Z*WAPS (1,2) ) | |
19933 | END IF | |
19934 | * | | | |
19935 | * | +----------------------------------------------------------------* | |
19936 | IF ( IFLAG .EQ. 2 ) DT_ENKNOW = DT_ENERGY | |
19937 | RETURN | |
19938 | END IF | |
19939 | * | | |
19940 | * +-------------------------------------------------------------------* | |
19941 | *=== End of Function Energy ===========================================* | |
19942 | * RETURN | |
19943 | END | |
19944 | ** | |
19945 | ||
19946 | *$ CREATE DT_ENRG.FOR | |
19947 | *COPY DT_ENRG | |
19948 | * * | |
19949 | *=== enrg =============================================================* | |
19950 | * * | |
19951 | DOUBLE PRECISION FUNCTION DT_ENRG(A,Z) | |
19952 | ||
19953 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
19954 | SAVE | |
19955 | ||
19956 | PARAMETER ( ZERZER = 0.D+00 ) | |
19957 | PARAMETER ( ONEONE = 1.D+00 ) | |
19958 | PARAMETER ( LUNIN = 5 ) | |
19959 | PARAMETER ( LUNOUT = 6 ) | |
19960 | * | |
19961 | *----------------------------------------------------------------------* | |
19962 | * * | |
19963 | * Revised version of the original routine from EVAP: * | |
19964 | * * | |
19965 | * Created on 15 may 1990 by Alfredo Ferrari & Paola Sala * | |
19966 | * Infn - Milan * | |
19967 | * * | |
19968 | * Last change on 01-oct-94 by Alfredo Ferrari * | |
19969 | * * | |
19970 | * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! * | |
19971 | * !!! It is supposed to be used with the updated atomic !!! * | |
19972 | * !!! mass data file !!! * | |
19973 | * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! * | |
19974 | * * | |
19975 | *----------------------------------------------------------------------* | |
19976 | * | |
19977 | PARAMETER ( O16OLD = 931.145 D+00 ) | |
19978 | PARAMETER ( O16NEW = 931.19826D+00 ) | |
19979 | PARAMETER ( O16RAT = O16NEW / O16OLD ) | |
19980 | PARAMETER ( C12NEW = 931.49432D+00 ) | |
19981 | PARAMETER ( ADJUST = -8.322737768178909D-02 ) | |
19982 | PARAMETER ( AINFNT = 1.0D+30 ) | |
19983 | * (original name: EVA0) | |
19984 | COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001), | |
19985 | * FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6), | |
19986 | * CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200), | |
19987 | * T (4,7), RMASS (297), ALPH (297), BET (297), | |
19988 | * APRIME (250), IA (6), IZ (6) | |
19989 | LOGICAL LFIRST | |
454792a9 | 19990 | CPH SAVE LFIRST, EXHYDR, EXNEUT |
9aaba0d6 | 19991 | DATA LFIRST / .TRUE. / |
19992 | * | |
19993 | IF ( LFIRST ) THEN | |
19994 | LFIRST = .FALSE. | |
19995 | **sr 30.6. | |
19996 | C EXHYDR = DT_ENERGY( ONEONE, ONEONE ) | |
19997 | C EXNEUT = DT_ENERGY( ONEONE, ZERZER ) | |
19998 | EXHYDR = A | |
19999 | EXNEUT = Z | |
20000 | DT_ENRG = -AINFNT | |
20001 | RETURN | |
20002 | ** | |
20003 | END IF | |
20004 | IZ0 = NINT (Z) | |
20005 | IF ( IZ0 .LE. 0 ) THEN | |
20006 | DT_ENRG = A * EXNEUT | |
20007 | RETURN | |
20008 | END IF | |
20009 | N = NINT (A-Z) | |
20010 | IF ( N .LE. 0 ) THEN | |
20011 | DT_ENRG = Z * EXHYDR | |
20012 | RETURN | |
20013 | END IF | |
20014 | AM2ZOA= (A-Z-Z)/A | |
20015 | AM2ZOA=AM2ZOA*AM2ZOA | |
20016 | A13 = RMASS(NINT(A)) | |
20017 | * A13 = A**.3333333333333333D+00 | |
20018 | AM13 = 1.D+00/A13 | |
20019 | EV=-17.0354D+00*(1.D+00 -1.84619 D+00*AM2ZOA)*A | |
20020 | ES= 25.8357D+00*(1.D+00 -1.712185D+00*AM2ZOA)* | |
20021 | & (1.D+00 -0.62025D+00*AM13*AM13)* | |
20022 | & (A13*A13 -.62025D+00) | |
20023 | EC= 0.799D+00*Z*(Z-1.D+00)*AM13*(((1.5772D+00*AM13 +1.2273D+00)* | |
20024 | & AM13-1.5849D+00)* | |
20025 | & AM13*AM13 +1.D+00) | |
20026 | EEX= -0.4323D+00*AM13*Z**1.3333333D+00* | |
20027 | & (((0.49597D+00*AM13 -0.14518D+00)*AM13 -0.57811D+00) * AM13 | |
20028 | & + 1.D+00) | |
20029 | DT_ENRG=8.367D+00*A-0.783D+00*Z +EV +ES +EC +EEX+CAM2(IZ0)+CAM3(N) | |
20030 | DT_ENRG=(DT_ENRG + A * O16OLD ) * O16RAT - A * ( C12NEW - ADJUST ) | |
20031 | DT_ENRG = MIN ( DT_ENRG, Z * EXHYDR + ( A - Z ) * EXNEUT ) | |
20032 | RETURN | |
20033 | *=== End of function Enrg =============================================* | |
20034 | END | |
20035 | ||
20036 | *$ CREATE DT_INCINI.FOR | |
20037 | *COPY DT_INCINI | |
20038 | * * | |
20039 | *=== incini ===========================================================* | |
20040 | * * | |
20041 | SUBROUTINE DT_INCINI | |
20042 | ||
20043 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
20044 | SAVE | |
20045 | ||
20046 | PARAMETER ( ZERZER = 0.D+00 ) | |
20047 | PARAMETER ( ONEONE = 1.D+00 ) | |
20048 | PARAMETER ( TWOTWO = 2.D+00 ) | |
20049 | PARAMETER ( THRTHR = 3.D+00 ) | |
20050 | PARAMETER ( FOUFOU = 4.D+00 ) | |
20051 | PARAMETER ( EIGEIG = 8.D+00 ) | |
20052 | PARAMETER ( ANINEN = 9.D+00 ) | |
20053 | PARAMETER ( HLFHLF = 0.5D+00 ) | |
20054 | PARAMETER ( ONETHI = ONEONE / THRTHR ) | |
20055 | PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 ) | |
20056 | PARAMETER ( PLABRC = 0.197327053 D+00 ) | |
20057 | PARAMETER ( AMELCT = 0.51099906 D-03 ) | |
20058 | PARAMETER ( AMUGEV = 0.93149432 D+00 ) | |
20059 | PARAMETER ( AMPRTN = 0.93827231 D+00 ) | |
20060 | PARAMETER ( AMNTRN = 0.93956563 D+00 ) | |
20061 | PARAMETER ( AMDEUT = 1.87561339 D+00 ) | |
20062 | PARAMETER ( EMVGEV = 1.0 D-03 ) | |
20063 | ||
20064 | PARAMETER ( LUNOUT = 6 ) | |
20065 | * | |
20066 | *----------------------------------------------------------------------* | |
20067 | * * | |
20068 | * Created on 10 june 1990 by Alfredo Ferrari & Paola Sala * | |
20069 | * Infn - Milan * | |
20070 | * * | |
20071 | * Last change on 02-may-95 by Alfredo Ferrari * | |
20072 | * * | |
20073 | * * | |
20074 | *----------------------------------------------------------------------* | |
20075 | * | |
20076 | * (original name: FHEAVY,FHEAVC) | |
20077 | PARAMETER ( MXHEAV = 100 ) | |
20078 | CHARACTER*8 ANHEAV | |
20079 | COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV), | |
20080 | & CZHEAV (MXHEAV), TKHEAV (MXHEAV), | |
20081 | & PHEAVY (MXHEAV), WHEAVY (MXHEAV), | |
20082 | & AMHEAV ( 12 ) , AMNHEA ( 12 ) , | |
20083 | & KHEAVY (MXHEAV), ICHEAV ( 12 ) , | |
20084 | & IBHEAV ( 12 ) , NPHEAV | |
20085 | COMMON /FKFHVC/ ANHEAV ( 12 ) | |
20086 | * (original name: INPFLG) | |
20087 | COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK | |
20088 | * (original name: FRBKCM) | |
20089 | PARAMETER ( MXFFBK = 6 ) | |
20090 | PARAMETER ( MXZFBK = 9 ) | |
20091 | PARAMETER ( MXNFBK = 10 ) | |
20092 | PARAMETER ( MXAFBK = 16 ) | |
20093 | PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 ) | |
20094 | PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 ) | |
20095 | PARAMETER ( NXAFBK = MXAFBK + 1 ) | |
20096 | PARAMETER ( MXPSST = 300 ) | |
20097 | PARAMETER ( MXPSFB = 41000 ) | |
20098 | LOGICAL LFRMBK, LNCMSS | |
20099 | COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST), | |
20100 | & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB), | |
20101 | & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK, | |
20102 | & IFRBKN (MXPSST), IFRBKZ (MXPSST), | |
20103 | & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST), | |
20104 | & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK), | |
20105 | & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK), | |
20106 | & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF, | |
20107 | & IFBFRB, NBUFBK, LFRMBK, LNCMSS | |
20108 | * (original name: NUCDAT) | |
20109 | PARAMETER ( AMUAMU = AMUGEV ) | |
20110 | PARAMETER ( AMPROT = AMPRTN ) | |
20111 | PARAMETER ( AMNEUT = AMNTRN ) | |
20112 | PARAMETER ( AMELEC = AMELCT ) | |
20113 | PARAMETER ( R0NUCL = 1.12 D+00 ) | |
20114 | PARAMETER ( RCCOUL = 1.7 D+00 ) | |
20115 | PARAMETER ( FERTHO = 14.33 D-09 ) | |
20116 | PARAMETER ( EXPEBN = 2.39 D+00 ) | |
20117 | PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 ) | |
20118 | PARAMETER ( AMUC12 = AMUGEV - HLFHLF * AMELCT + BEXC12 / 12.D+00 ) | |
20119 | PARAMETER ( AMHYDR = AMPRTN + AMELCT ) | |
20120 | PARAMETER ( AMHTON = AMHYDR - AMNTRN ) | |
20121 | PARAMETER ( AMNTOU = AMNTRN - AMUC12 ) | |
20122 | PARAMETER ( AMUCSQ = AMUC12 * AMUC12 ) | |
20123 | PARAMETER ( EBNDAV = HLFHLF * (AMPRTN + AMNTRN) - AMUC12 ) | |
20124 | PARAMETER ( GAMMIN = 1.0D-06 ) | |
20125 | PARAMETER ( GAMNSQ = 2.0D+00 * GAMMIN * GAMMIN ) | |
20126 | PARAMETER ( TVEPSI = GAMMIN / 100.D+00 ) | |
20127 | COMMON /FKNDAT/ AV0WEL, APFRMX, AEFRMX, AEFRMA, | |
20128 | & RDSNUC, V0WELL (2), PFRMMX (2), EFRMMX (2), | |
20129 | & EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2), | |
20130 | & VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2), | |
20131 | & PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2), | |
20132 | & EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2), | |
20133 | & ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV , | |
20134 | & AMRCSQ , ATO1O3 , ZTO1O3 , ELBNDE (0:100) | |
20135 | * (original name: PAREVT) | |
20136 | LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX, | |
20137 | & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF | |
20138 | PARAMETER ( NALLWP = 39 ) | |
20139 | COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, | |
20140 | & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY, | |
20141 | & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV, | |
20142 | & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF | |
20143 | * (original name: NUCOLD) | |
20144 | COMMON /FKNOLD/ HELP (2), HHLP (2), FTVTH (2), FINCX (2), | |
20145 | & EKPOLD (2), BBOLD, ZZOLD, SQROLD, ASEASQ, | |
20146 | & FSPRED, FEX0RD | |
20147 | * | |
20148 | BBOLD = - 1.D+10 | |
20149 | ZZOLD = - 1.D+10 | |
20150 | SQROLD = - 1.D+10 | |
20151 | APFRMX = PLABRC * ( ANINEN * PIPIPI / EIGEIG )**ONETHI / R0NUCL | |
20152 | AMNUCL (1) = AMPROT | |
20153 | AMNUCL (2) = AMNEUT | |
20154 | AMNUSQ (1) = AMPROT * AMPROT | |
20155 | AMNUSQ (2) = AMNEUT * AMNEUT | |
20156 | AMNHLP = HLFHLF * ( AMNUCL (1) + AMNUCL (2) ) | |
20157 | ASQHLP = AMNHLP**2 | |
20158 | * ASQHLP = HLFHLF * ( AMNUSQ (1) + AMNUSQ (2) ) | |
20159 | AEFRMX = SQRT ( ASQHLP + APFRMX**2 ) - AMNHLP | |
20160 | AEFRMA = 0.3D+00 * APFRMX**2 / AMNHLP * ( ONEONE - APFRMX**2 / | |
20161 | & ( 5.6D+00 * ASQHLP ) ) | |
20162 | AV0WEL = AEFRMX + EBNDAV | |
20163 | EBNDNG (1) = EBNDAV | |
20164 | EBNDNG (2) = EBNDAV | |
20165 | AEXC12 = EMVGEV * DT_ENERGY( 12.D+00, 6.D+00 ) | |
20166 | CEXC12 = EMVGEV * DT_ENRG( 12.D+00, 6.D+00 ) | |
20167 | AMMC12 = 12.D+00 * AMUGEV + AEXC12 | |
20168 | AMNC12 = AMMC12 - 6.D+00 * AMELCT + FERTHO * 6.D+00**EXPEBN | |
20169 | AEXO16 = EMVGEV * DT_ENERGY( 16.D+00, 8.D+00 ) | |
20170 | CEXO16 = EMVGEV * DT_ENRG( 16.D+00, 8.D+00 ) | |
20171 | AMMO16 = 16.D+00 * AMUGEV + AEXO16 | |
20172 | AMNO16 = AMMO16 - 8.D+00 * AMELCT + FERTHO * 8.D+00**EXPEBN | |
20173 | AEXS28 = EMVGEV * DT_ENERGY( 28.D+00, 14.D+00 ) | |
20174 | CEXS28 = EMVGEV * DT_ENRG( 28.D+00, 14.D+00 ) | |
20175 | AMMS28 = 28.D+00 * AMUGEV + AEXS28 | |
20176 | AMNS28 = AMMS28 - 14.D+00 * AMELCT + FERTHO * 14.D+00**EXPEBN | |
20177 | AEXC40 = EMVGEV * DT_ENERGY( 40.D+00, 20.D+00 ) | |
20178 | CEXC40 = EMVGEV * DT_ENRG( 40.D+00, 20.D+00 ) | |
20179 | AMMC40 = 40.D+00 * AMUGEV + AEXC40 | |
20180 | AMNC40 = AMMC40 - 20.D+00 * AMELCT + FERTHO * 20.D+00**EXPEBN | |
20181 | AEXF56 = EMVGEV * DT_ENERGY( 56.D+00, 26.D+00 ) | |
20182 | CEXF56 = EMVGEV * DT_ENRG( 56.D+00, 26.D+00 ) | |
20183 | AMMF56 = 56.D+00 * AMUGEV + AEXF56 | |
20184 | AMNF56 = AMMF56 - 26.D+00 * AMELCT + FERTHO * 26.D+00**EXPEBN | |
20185 | AEX107 = EMVGEV * DT_ENERGY( 107.D+00, 47.D+00 ) | |
20186 | CEX107 = EMVGEV * DT_ENRG( 107.D+00, 47.D+00 ) | |
20187 | AMM107 = 107.D+00 * AMUGEV + AEX107 | |
20188 | AMN107 = AMM107 - 47.D+00 * AMELCT + FERTHO * 47.D+00**EXPEBN | |
20189 | AEX132 = EMVGEV * DT_ENERGY( 132.D+00, 54.D+00 ) | |
20190 | CEX132 = EMVGEV * DT_ENRG( 132.D+00, 54.D+00 ) | |
20191 | AMM132 = 132.D+00 * AMUGEV + AEX132 | |
20192 | AMN132 = AMM132 - 54.D+00 * AMELCT + FERTHO * 54.D+00**EXPEBN | |
20193 | AEX181 = EMVGEV * DT_ENERGY( 181.D+00, 73.D+00 ) | |
20194 | CEX181 = EMVGEV * DT_ENRG( 181.D+00, 73.D+00 ) | |
20195 | AMM181 = 181.D+00 * AMUGEV + AEX181 | |
20196 | AMN181 = AMM181 - 73.D+00 * AMELCT + FERTHO * 73.D+00**EXPEBN | |
20197 | AEX208 = EMVGEV * DT_ENERGY( 208.D+00, 82.D+00 ) | |
20198 | CEX208 = EMVGEV * DT_ENRG( 208.D+00, 82.D+00 ) | |
20199 | AMM208 = 208.D+00 * AMUGEV + AEX208 | |
20200 | AMN208 = AMM208 - 82.D+00 * AMELCT + FERTHO * 82.D+00**EXPEBN | |
20201 | AEX238 = EMVGEV * DT_ENERGY( 238.D+00, 92.D+00 ) | |
20202 | CEX238 = EMVGEV * DT_ENRG( 238.D+00, 92.D+00 ) | |
20203 | AMM238 = 238.D+00 * AMUGEV + AEX238 | |
20204 | AMN238 = AMM238 - 92.D+00 * AMELCT + FERTHO * 92.D+00**EXPEBN | |
20205 | ||
20206 | AMHEAV (1) = AMUGEV + EMVGEV * DT_ENERGY( ONEONE, ZERZER ) | |
20207 | AMHEAV (2) = AMUGEV + EMVGEV * DT_ENERGY( ONEONE, ONEONE ) | |
20208 | AMHEAV (3) = TWOTWO * AMUGEV | |
20209 | & + EMVGEV * DT_ENERGY( TWOTWO, ONEONE ) | |
20210 | AMHEAV (4) = THRTHR * AMUGEV | |
20211 | & + EMVGEV * DT_ENERGY( THRTHR, ONEONE ) | |
20212 | AMHEAV (5) = THRTHR * AMUGEV | |
20213 | & + EMVGEV * DT_ENERGY( THRTHR, TWOTWO ) | |
20214 | AMHEAV (6) = FOUFOU * AMUGEV | |
20215 | & + EMVGEV * DT_ENERGY( FOUFOU, TWOTWO ) | |
20216 | ELBNDE (0) = ZERZER | |
20217 | ELBNDE (1) = 13.6D-09 | |
20218 | DO 2000 IZ = 2, 100 | |
20219 | ELBNDE ( IZ ) = FERTHO * DBLE ( IZ )**EXPEBN | |
20220 | 2000 CONTINUE | |
20221 | AMNHEA (1) = AMHEAV (1) + ELBNDE (0) | |
20222 | AMNHEA (2) = AMHEAV (2) - AMELCT + ELBNDE (1) | |
20223 | AMNHEA (3) = AMHEAV (3) - AMELCT + ELBNDE (1) | |
20224 | AMNHEA (4) = AMHEAV (4) - AMELCT + ELBNDE (1) | |
20225 | AMNHEA (5) = AMHEAV (5) - TWOTWO * AMELCT + ELBNDE (2) | |
20226 | AMNHEA (6) = AMHEAV (6) - TWOTWO * AMELCT + ELBNDE (2) | |
20227 | IF ( LEVPRT ) THEN | |
20228 | WRITE ( LUNOUT, * )' **** Evaporation from residual nucleus', | |
20229 | & ' activated **** ' | |
20230 | IF ( LDEEXG ) WRITE ( LUNOUT, * )' **** Deexcitation gamma', | |
20231 | & ' production activated **** ' | |
20232 | **sr 18.5.95 | |
20233 | * commented, since obsolete | |
20234 | C IF ( LHEAVY ) WRITE ( LUNOUT, * )' **** Evaporated "heavies"', | |
20235 | C & ' transport activated **** ' | |
20236 | IF ( IFISS .GT. 0 ) | |
20237 | & WRITE ( LUNOUT, * )' **** High Energy fission ', | |
20238 | & ' requested & activated **** ' | |
20239 | IF ( LFRMBK ) | |
20240 | & WRITE ( LUNOUT, * )' **** Fermi Break Up ', | |
20241 | & ' requested & activated **** ' | |
20242 | IF ( LFRMBK ) CALL DT_FRBKIN(.FALSE.,.FALSE.) | |
20243 | ELSE | |
20244 | LDEEXG = .FALSE. | |
20245 | LHEAVY = .FALSE. | |
20246 | LFRMBK = .FALSE. | |
20247 | IFISS = 0 | |
20248 | END IF | |
20249 | RETURN | |
20250 | *=== End of subroutine incini =========================================* | |
20251 | END | |
20252 | ||
20253 | *$ CREATE DT_STALIN.FOR | |
20254 | *COPY DT_STALIN | |
20255 | * * | |
20256 | *=== stalin ===========================================================* | |
20257 | * * | |
20258 | SUBROUTINE DT_STALIN | |
20259 | ||
20260 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
20261 | SAVE | |
20262 | PARAMETER ( ANGLGB = 5.0D-16 ) | |
20263 | PARAMETER ( ZERZER = 0.D+00 ) | |
20264 | PARAMETER ( ONEONE = 1.D+00 ) | |
20265 | PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 ) | |
20266 | PARAMETER ( AMUGEV = 0.93149432 D+00 ) | |
20267 | PARAMETER ( EMVGEV = 1.0 D-03 ) | |
20268 | PARAMETER ( NSTBIS = 304 ) | |
20269 | PARAMETER ( LUNIN = 5 ) | |
20270 | PARAMETER ( LUNOUT = 6 ) | |
20271 | * | |
20272 | *----------------------------------------------------------------------* | |
20273 | * * | |
20274 | * STAbility LINe calculation: * | |
20275 | * * | |
20276 | * Created on 04 december 1992 by Alfredo Ferrari & Paola Sala * | |
20277 | * Infn - Milan * | |
20278 | * * | |
20279 | * Last change on 04-dec-92 by Alfredo Ferrari * | |
20280 | * * | |
20281 | * * | |
20282 | *----------------------------------------------------------------------* | |
20283 | * | |
20284 | * (original name: ISOTOP) | |
20285 | PARAMETER ( NAMSMX = 270 ) | |
20286 | PARAMETER ( NZGVAX = 15 ) | |
20287 | PARAMETER ( NISMMX = 574 ) | |
20288 | COMMON /FKISOT/ WAPS (NAMSMX,NZGVAX), T12NUC (NAMSMX,NZGVAX), | |
20289 | & WAPISM (NISMMX), T12ISM (NISMMX), | |
20290 | & ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260), | |
20291 | & AMSSST (100) , ISOMNM (NSTBIS), ISONDX (2,100), | |
20292 | & JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX), | |
20293 | & INWAPS (NAMSMX), JSPISM (NISMMX), | |
20294 | & JPTISM (NISMMX), IZWISM (NISMMX), | |
20295 | & INWISM (0:NAMSMX) | |
20296 | * | |
20297 | DIMENSION ZNORM (260) | |
20298 | * +-------------------------------------------------------------------* | |
20299 | * | | |
20300 | DO 1000 IZ=1,100 | |
20301 | DO 500 J=1,2 | |
20302 | ASTLIN (J,IZ) = ZERZER | |
20303 | 500 CONTINUE | |
20304 | 1000 CONTINUE | |
20305 | * | | |
20306 | * +-------------------------------------------------------------------* | |
20307 | * +-------------------------------------------------------------------* | |
20308 | * | | |
20309 | DO 2000 IA=1,260 | |
20310 | ZNORM (IA) = ZERZER | |
20311 | DO 1500 J=1,2 | |
20312 | ZSTLIN (J,IA) = ZERZER | |
20313 | 1500 CONTINUE | |
20314 | 2000 CONTINUE | |
20315 | * | | |
20316 | * +-------------------------------------------------------------------* | |
20317 | * +-------------------------------------------------------------------* | |
20318 | * | Loop on the Atomic Number | |
20319 | DO 3000 IZ=1,100 | |
20320 | AMSSST (IZ) = ZERZER | |
20321 | ANORM = ONEONE | |
20322 | ZTAR = IZ | |
20323 | * | +----------------------------------------------------------------* | |
20324 | * | | Loop on the stable isotopes | |
20325 | DO 2500 IS = ISONDX (1,IZ), ISONDX (2,IZ) | |
20326 | IA = ISOMNM (IS) | |
20327 | ASTLIN (1,IZ) = ASTLIN (1,IZ) + ABUISO (IS) * IA | |
20328 | ASTLIN (2,IZ) = ASTLIN (2,IZ) + ABUISO (IS) * IA**2 | |
20329 | ZNORM (IA) = ZNORM (IA) + ABUISO (IS) | |
20330 | ZSTLIN (1,IA) = ZSTLIN (1,IA) + ABUISO (IS) * IZ | |
20331 | ZSTLIN (2,IA) = ZSTLIN (2,IA) + ABUISO (IS) * IZ**2 | |
20332 | AHELP = IA | |
20333 | IF ( AHELP .LE. 1.00001D+00 ) THEN | |
20334 | ANORM = ONEONE / ( ONEONE - ABUISO (IS) ) | |
20335 | GO TO 2500 | |
20336 | END IF | |
20337 | AMSSST (IZ) = ABUISO (IS) * ( AHELP * AMUGEV | |
20338 | & + EMVGEV * DT_ENERGY(AHELP,ZTAR) ) + AMSSST (IZ) | |
20339 | 2500 CONTINUE | |
20340 | * | | | |
20341 | * | +----------------------------------------------------------------* | |
20342 | AMSSST (IZ) = ANORM * AMSSST (IZ) / AMUGEV | |
20343 | * | Normalize and print A_stab versus Z data: | |
20344 | ASTLIN (2,IZ) = MAX ( SQRT (ASTLIN(2,IZ)-ASTLIN(1,IZ)**2), | |
20345 | & 0.5D+00 ) | |
20346 | * WRITE (LUNOUT,*)' Z:',IZ,' A_stab:',SNGL(ASTLIN(1,IZ)), | |
20347 | * & ' Sigma_st',SNGL(ASTLIN(2,IZ)) | |
20348 | 3000 CONTINUE | |
20349 | * | | |
20350 | * +-------------------------------------------------------------------* | |
20351 | * +-------------------------------------------------------------------* | |
20352 | * | Normalize and print Z_stab versus A data: | |
20353 | DO 4000 IA=1,260 | |
20354 | ZSTLIN (1,IA) = ZSTLIN (1,IA) / MAX ( ZNORM (IA), 1.D-10 ) | |
20355 | ZSTLIN (2,IA) = ZSTLIN (2,IA) / MAX ( ZNORM (IA), 1.D-10 ) | |
20356 | ZSTLIN (2,IA) = MAX ( ZSTLIN (2,IA), ZSTLIN (1,IA)**2 ) | |
20357 | IF ( ZNORM (IA) .GT. ANGLGB ) | |
20358 | **sr 2.11. avoid underflows at Pentium | |
20359 | & ZSTLIN (2,IA) = | |
20360 | & MAX ( SQRT ( ABS(ZSTLIN(2,IA)-ZSTLIN(1,IA)**2) ), | |
20361 | C & ZSTLIN (2,IA) = MAX ( SQRT (ZSTLIN(2,IA)-ZSTLIN(1,IA)**2), | |
20362 | & 0.3D+00 ) | |
20363 | 4000 CONTINUE | |
20364 | * | | |
20365 | * +-------------------------------------------------------------------* | |
20366 | * +-------------------------------------------------------------------* | |
20367 | * | Normalize and print Z_stab versus A data: | |
20368 | DO 5000 IA=1,260 | |
20369 | IF ( ZNORM (IA) .LE. ANGLGB ) THEN | |
20370 | DO 4200 JA = IA-1,1,-1 | |
20371 | IF ( ZNORM (JA) .GT. ANGLGB ) THEN | |
20372 | IA1 = JA | |
20373 | GO TO 4300 | |
20374 | END IF | |
20375 | 4200 CONTINUE | |
20376 | 4300 CONTINUE | |
20377 | DO 4400 JA = IA+1,260 | |
20378 | IF ( ZNORM (JA) .GT. ANGLGB ) THEN | |
20379 | IA2 = JA | |
20380 | GO TO 4500 | |
20381 | END IF | |
20382 | 4400 CONTINUE | |
20383 | IA2 = IA1 | |
20384 | IA1 = IA1 - 1 | |
20385 | 4500 CONTINUE | |
20386 | ZSTLIN (1,IA) = DBLE (IA-IA1) / DBLE (IA2-IA1) | |
20387 | & * ( ZSTLIN (1,IA2) - ZSTLIN (1,IA1) ) | |
20388 | & + ZSTLIN (1,IA1) | |
20389 | ZSTLIN (2,IA) = DBLE (IA-IA1) / DBLE (IA2-IA1) | |
20390 | & * ( ZSTLIN (2,IA2) - ZSTLIN (2,IA1) ) | |
20391 | & + ZSTLIN (2,IA1) | |
20392 | END IF | |
20393 | IZ = MIN ( 100, NINT (ZSTLIN(1,IA)) ) | |
20394 | ATOZ = IZ / ASTLIN (1,IZ) | |
20395 | ZSTLIN (2,IA) = MAX ( ZSTLIN (2,IA), ATOZ * ASTLIN (2,IZ) ) | |
20396 | * WRITE (LUNOUT,*)' A:',IA,' Z_stab:',SNGL(ZSTLIN(1,IA)), | |
20397 | * & ' Sigma_st',SNGL(ZSTLIN(2,IA)) | |
20398 | 5000 CONTINUE | |
20399 | * | | |
20400 | * +-------------------------------------------------------------------* | |
20401 | RETURN | |
20402 | END | |
20403 | ||
20404 | *$ CREATE DT_BERTTP.FOR | |
20405 | *COPY DT_BERTTP | |
20406 | * | |
20407 | *=== berttp ===========================================================* | |
20408 | * * | |
20409 | SUBROUTINE DT_BERTTP | |
20410 | ||
20411 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
20412 | SAVE | |
20413 | ||
20414 | PARAMETER ( CSNNRM = 2.0D-15 ) | |
20415 | PARAMETER ( ZERZER = 0.D+00 ) | |
20416 | PARAMETER ( ONEONE = 1.D+00 ) | |
20417 | PARAMETER ( THRTHR = 3.D+00 ) | |
20418 | PARAMETER ( SIXSIX = 6.D+00 ) | |
20419 | PARAMETER ( ONETHI = ONEONE / THRTHR ) | |
20420 | PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 ) | |
20421 | PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 ) | |
20422 | PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 ) | |
20423 | PARAMETER ( EMVGEV = 1.0 D-03 ) | |
20424 | ||
20425 | PARAMETER ( NSTBIS = 304 ) | |
20426 | ||
20427 | PARAMETER ( LUNIN = 5 ) | |
20428 | PARAMETER ( LUNOUT = 6 ) | |
20429 | **sr 19.5. set error output-unit from 15 to 6 | |
20430 | PARAMETER ( LUNERR = 6 ) | |
20431 | C--------------------------------------------------------------------- | |
20432 | C SUBNAME = DT_BERTTP --- READ BERTINI DATA | |
20433 | C--------------------------------------------------------------------- | |
20434 | C ---------------------------------- I-N-C DATA | |
20435 | C COMMON R8(2127),R4(64),CRSC(600,4),R8B(336),CS(29849) | |
20436 | C REAL*8 R8,R8B,CRSC,CS | |
20437 | C REAL*4 R4 | |
20438 | C --------------------------------- EVAPORATION DATA | |
20439 | * (original name: COOKCM) | |
20440 | PARAMETER ( ASMTOG = SIXSIX / PIPIPI**2 ) | |
20441 | LOGICAL LDEFOZ, LDEFON | |
20442 | PARAMETER ( INCOOK = 150, IZCOOK = 98 ) | |
20443 | COMMON /FKCOOK/ ALPIGN, BETIGN, GAMIGN, POWIGN, | |
20444 | & SZCOOK (IZCOOK), SNCOOK (INCOOK), PZCOOK (IZCOOK), | |
20445 | & PNCOOK (INCOOK), LDEFOZ (IZCOOK), LDEFON (INCOOK) | |
20446 | * (original name: EVA0) | |
20447 | COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001), | |
20448 | * FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6), | |
20449 | * CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200), | |
20450 | * T (4,7), RMASS (297), ALPH (297), BET (297), | |
20451 | * APRIME (250), IA (6), IZ (6) | |
20452 | * (original name: FRBKCM) | |
20453 | PARAMETER ( MXFFBK = 6 ) | |
20454 | PARAMETER ( MXZFBK = 9 ) | |
20455 | PARAMETER ( MXNFBK = 10 ) | |
20456 | PARAMETER ( MXAFBK = 16 ) | |
20457 | PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 ) | |
20458 | PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 ) | |
20459 | PARAMETER ( NXAFBK = MXAFBK + 1 ) | |
20460 | PARAMETER ( MXPSST = 300 ) | |
20461 | PARAMETER ( MXPSFB = 41000 ) | |
20462 | LOGICAL LFRMBK, LNCMSS | |
20463 | COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST), | |
20464 | & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB), | |
20465 | & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK, | |
20466 | & IFRBKN (MXPSST), IFRBKZ (MXPSST), | |
20467 | & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST), | |
20468 | & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK), | |
20469 | & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK), | |
20470 | & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF, | |
20471 | & IFBFRB, NBUFBK, LFRMBK, LNCMSS | |
20472 | * (original name: HETTP) | |
20473 | COMMON /FKHETP/ NHSTP,NBERTP,IOSUB,INSRS | |
20474 | * (original name: INPFLG) | |
20475 | COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK | |
20476 | * (original name: ISOTOP) | |
20477 | PARAMETER ( NAMSMX = 270 ) | |
20478 | PARAMETER ( NZGVAX = 15 ) | |
20479 | PARAMETER ( NISMMX = 574 ) | |
20480 | COMMON /FKISOT/ WAPS (NAMSMX,NZGVAX), T12NUC (NAMSMX,NZGVAX), | |
20481 | & WAPISM (NISMMX), T12ISM (NISMMX), | |
20482 | & ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260), | |
20483 | & AMSSST (100) , ISOMNM (NSTBIS), ISONDX (2,100), | |
20484 | & JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX), | |
20485 | & INWAPS (NAMSMX), JSPISM (NISMMX), | |
20486 | & JPTISM (NISMMX), IZWISM (NISMMX), | |
20487 | & INWISM (0:NAMSMX) | |
20488 | * (original name: NUCGID,NUCGEO,NUCGE2,NUCPWI,NUCGII) | |
20489 | PARAMETER ( PI = PIPIPI ) | |
20490 | PARAMETER ( PISQ = PIPISQ ) | |
20491 | PARAMETER ( SKTOHL = 0.5456645846610345D+00 ) | |
20492 | PARAMETER ( RZNUCL = 1.12 D+00 ) | |
20493 | PARAMETER ( RMSPRO = 0.8 D+00 ) | |
20494 | PARAMETER ( R0PROT = RMSPRO / SQRT12 ) | |
20495 | PARAMETER ( ARHPRO = 1.D+00 / 8.D+00 / PI / R0PROT / R0PROT | |
20496 | & / R0PROT ) | |
20497 | PARAMETER ( RLLE04 = RZNUCL ) | |
20498 | PARAMETER ( RLLE16 = RZNUCL ) | |
20499 | PARAMETER ( RLGT16 = RZNUCL ) | |
20500 | PARAMETER ( RCLE04 = 0.75D+00 / PI / RLLE04 / RLLE04 / RLLE04 ) | |
20501 | PARAMETER ( RCLE16 = 0.75D+00 / PI / RLLE16 / RLLE16 / RLLE16 ) | |
20502 | PARAMETER ( RCGT16 = 0.75D+00 / PI / RLGT16 / RLGT16 / RLGT16 ) | |
20503 | PARAMETER ( SKLE04 = 1.4D+00 ) | |
20504 | PARAMETER ( SKLE16 = 1.9D+00 ) | |
20505 | PARAMETER ( SKGT16 = 2.4D+00 ) | |
20506 | PARAMETER ( HLLE04 = SKTOHL * SKLE04 ) | |
20507 | PARAMETER ( HLLE16 = SKTOHL * SKLE16 ) | |
20508 | PARAMETER ( HLGT16 = SKTOHL * SKGT16 ) | |
20509 | PARAMETER ( ALPHA0 = 0.1D+00 ) | |
20510 | PARAMETER ( OMALH0 = 1.D+00 - ALPHA0 ) | |
20511 | PARAMETER ( GAMSK0 = 0.9D+00 ) | |
20512 | PARAMETER ( OMGAS0 = 1.D+00 - GAMSK0 ) | |
20513 | PARAMETER ( POTME0 = 0.6666666666666667D+00 ) | |
20514 | PARAMETER ( POTBA0 = 1.D+00 ) | |
20515 | PARAMETER ( PNFRAT = 1.533D+00 ) | |
20516 | PARAMETER ( RADPIM = 0.035D+00 ) | |
20517 | PARAMETER ( RDPMHL = 14.D+00 ) | |
20518 | PARAMETER ( APMRST = 4.D+00 / 44.D+00 ) | |
20519 | PARAMETER ( APMPRO = 1.D+00 / 6.D+00 ) | |
20520 | PARAMETER ( APPPRO = 5.D+00 / 6.D+00 ) | |
20521 | PARAMETER ( AP0PFS = 0.5D+00 ) | |
20522 | PARAMETER ( AP0PFP = 1.D+00 / 3.D+00 ) | |
20523 | PARAMETER ( AP0NFP = 2.D+00 / 3.D+00 ) | |
20524 | PARAMETER ( XPAUCO = 1.88495407241652 D+00 ) | |
20525 | PARAMETER ( MXSCIN = 50 ) | |
20526 | LOGICAL LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH, LNCDCY, | |
20527 | & LNUSCT, LPREEQ, LNPHTC, LNWRAD, LPNRHO, LFTCMP, LFTCAC | |
20528 | COMMON /FKNGID/ RHOTAB (2:260), RHATAB (2:260), ALPTAB (2:260), | |
20529 | & RADTAB (2:260), SKITAB (2:260), HALTAB (2:260), | |
20530 | & SK3TAB (2:260), SK4TAB (2:260), HABTAB (2:260), | |
20531 | & CWSTAB (2:260), EKATAB (2:260), PFATAB (2:260), | |
20532 | & PFRTAB (2:260) | |
20533 | COMMON /FKNGEO/ RADTOT, RADIU1, RADIU0, RAD1O2, SKINDP, HALODP, | |
20534 | & ALPHAL, OMALHL, RADSKN, SKNEFF, CPARWS, RADPRO, | |
20535 | & RADCOR, RADCO2, RADMAX, BIMPTR, RIMPTR, XIMPTR, | |
20536 | & YIMPTR, ZIMPTR, RHOIMT, EKFPRO, PFRPRO, RHOCEN, | |
20537 | & RHOCOR, RHOSKN, EKFCEN (2), PFRCEN (2), EKFBIM, | |
20538 | & PFRBIM, RHOIMP, EKFIMP, PFRIMP, RHOIM2, EKFIM2, | |
20539 | & PFRIM2, RHOIM3, EKFIM3, PFRIM3, VPRWLL, RIMPCT, | |
20540 | & BIMPCT, XIMPCT, YIMPCT, ZIMPCT, RIMPC2, XIMPC2, | |
20541 | & YIMPC2, ZIMPC2, RIMPC3, XIMPC3, YIMPC3, ZIMPC3, | |
20542 | & XBIMPC, YBIMPC, ZBIMPC, CXIMPC, CYIMPC, CZIMPC, | |
20543 | & SQRIMP, SIGMAP, SIGMAN, SIGMAA, RHORED, R0TRAJ, | |
20544 | & R1TRAJ, SBUSED, SBTOT , SBRES , RHOAVE, EKFAVE, | |
20545 | & PFRAVE, AVEBIN, ACOLL , ZCOLL , RADSIG, OPACTY, | |
20546 | & EKECON, PNUCCO, EKEWLL, PPRWLL, PXPROJ, PYPROJ, | |
20547 | & PZPROJ, EKFERM, PNFRMI, PXFERM, PYFERM, PZFERM, | |
20548 | & EKFER2, PNFRM2, PXFER2, PYFER2, PZFER2, EKFER3, | |
20549 | & PNFRM3, PXFER3, PYFER3, PZFER3, RHOMEM, EKFMEM, | |
20550 | & BIMMEM, WLLRED, VPRBIM, POTINC, POTOUT, EEXMIN | |
20551 | COMMON /FKNGE2/ RDTTNC (2), RHONCP (2), RHONC2 (2), RHONC3 (2), | |
20552 | & RHONCT (2), AMOTHR, EKOTHR, AMCREA, EKNCLN, | |
20553 | & EEXDEL, EEXANY, CLMBBR, RDCLMB, BFCLMB, BFCEFF, | |
20554 | & BNPROJ, BNDNUC, DEBRLM, SK4PAR, UBIMPC, VBIMPC, | |
20555 | & WBIMPC, BNDPOT, SIGMAT, SIGABP, SIGABN, WLLRES, | |
20556 | & POTBAR, POTMES, AGEPRI, OPNOPA, ETHRND, | |
20557 | & BNENRG (3), DEFNUC (2), SIGMPR (4), SIGMNU (4), | |
20558 | & SIGPAB (3), SIGNAB (3), HHLP (2), FORTOT (2), | |
20559 | & FPNBLC, DPNBLC, FFTFLG, IFTFLG, | |
20560 | & IPWELL, ITNCMX, KPRIN , NTARGT, KNUCIM, KNUCI2, | |
20561 | & KNUCI3, IEVPRE, ISFCOL, ISFTAR, ISFTA2, ISFTA3, | |
20562 | & NPOTHR, ICOTHR, IBOTHR, NPUMFN, ISTNCL, ITAUCM, | |
20563 | & IABCOU, IADFLG, IGSFLG, IALFLG, ICBFLG, LPREEQ, | |
20564 | & LNPHTC, LPNRHO, LNWRAD, LFTCMP, LFTCAC | |
20565 | COMMON /FKNPWI/ ALMBAR, BIMMAX, SIGGEO, LLLMAX, LLLACT | |
20566 | COMMON /FKNGII/ HOLEXP (2*MXSCIN), XEXPIN (3,0:MXSCIN), | |
20567 | & YEXPIN (3,0:MXSCIN), ZEXPIN (3,0:MXSCIN), | |
20568 | & AGEXIN (0:MXSCIN), RHOEXP (2), EKFEXP, EHLFIX, | |
20569 | & NHLEXP, NHLFIX, IPRTYP, NNCEXI (0:MXSCIN), | |
20570 | & NCEXPI (3,0:MXSCIN), ISEXIN (3,0:MXSCIN), | |
20571 | & ISCTYP (0:MXSCIN), NUSCIN, NEXPEM, | |
20572 | & LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH, | |
20573 | & LNCDCY, LNUSCT | |
20574 | DIMENSION AWSTAB (2:260), SIGMAB (3) | |
20575 | EQUIVALENCE ( DEFPRO, DEFNUC (1) ) | |
20576 | EQUIVALENCE ( DEFNEU, DEFNUC (2) ) | |
20577 | EQUIVALENCE ( RHOIPP, RHONCP (1) ) | |
20578 | EQUIVALENCE ( RHOINP, RHONCP (2) ) | |
20579 | EQUIVALENCE ( RHOIP2, RHONC2 (1) ) | |
20580 | EQUIVALENCE ( RHOIN2, RHONC2 (2) ) | |
20581 | EQUIVALENCE ( RHOIP3, RHONC3 (1) ) | |
20582 | EQUIVALENCE ( RHOIN3, RHONC3 (2) ) | |
20583 | EQUIVALENCE ( RHOIPT, RHONCT (1) ) | |
20584 | EQUIVALENCE ( RHOINT, RHONCT (2) ) | |
20585 | EQUIVALENCE ( OMALHL, SK3PAR ) | |
20586 | EQUIVALENCE ( ALPHAL, HABPAR ) | |
20587 | EQUIVALENCE ( ALPTAB (2), AWSTAB (2) ) | |
20588 | EQUIVALENCE ( SIGMPE, SIGMPR (1) ) | |
20589 | EQUIVALENCE ( SIGMPC, SIGMPR (2) ) | |
20590 | EQUIVALENCE ( SIGMPI, SIGMPR (3) ) | |
20591 | EQUIVALENCE ( SIGMPA, SIGMPR (4) ) | |
20592 | EQUIVALENCE ( SIGMNE, SIGMNU (1) ) | |
20593 | EQUIVALENCE ( SIGMNC, SIGMNU (2) ) | |
20594 | EQUIVALENCE ( SIGMNI, SIGMNU (3) ) | |
20595 | EQUIVALENCE ( SIGMNA, SIGMNU (4) ) | |
20596 | EQUIVALENCE ( SIGMA2, SIGPAB (1) ) | |
20597 | EQUIVALENCE ( SIGMA3, SIGPAB (2) ) | |
20598 | EQUIVALENCE ( SIGMAS, SIGPAB (3) ) | |
20599 | EQUIVALENCE ( SIGPAB (1), SIGMAB (1) ) | |
20600 | * (original name: NUCLEV) | |
20601 | LOGICAL LCLVSL, LFLVSL, LRLVSL, LEQSBL | |
20602 | COMMON /FKNLEV/ PAENUC (200,2), SHENUC (200,2), DEFRMI (2), | |
20603 | & DEFMAG (2), ENNCLV (160,2), RANCLV (160,2), | |
20604 | & CUMRAD (0:160,2), RUSNUC (2), | |
20605 | & ENPLVL (114), ENNLVL(164), JUSNUC (160,2), | |
20606 | & NTANUC (2), NAVNUC (2), NLSNUC (2), NCONUC (2), | |
20607 | & NSKNUC (2), NHANUC (2), NUSNUC (2), NACNUC (2), | |
20608 | & JMXNUC (2), IPRNUC (3), JPRNUC (3), MAGNUM (8), | |
20609 | & MAGNUC (2), MGSNUC (8,2), MGSSNC (25,2), | |
20610 | & NSBSHL (2), NMNSBS (2), NPRNUC, INUCLV, LCLVSL, | |
20611 | & LFLVSL, LRLVSL, LEQSBL | |
20612 | DIMENSION JUSPRO (160), JUSNEU (160), MGSPRO (8), MGSNEU (8), | |
20613 | & MGSSPR (19) , MGSSNE (25) | |
20614 | EQUIVALENCE ( RUSNUC (1), RUSPRO ) | |
20615 | EQUIVALENCE ( RUSNUC (2), RUSNEU ) | |
20616 | EQUIVALENCE ( JUSNUC (1,1), JUSPRO (1) ) | |
20617 | EQUIVALENCE ( JUSNUC (1,2), JUSNEU (1) ) | |
20618 | EQUIVALENCE ( MGSNUC (1,1), MGSPRO (1) ) | |
20619 | EQUIVALENCE ( MGSNUC (1,2), MGSNEU (1) ) | |
20620 | EQUIVALENCE ( MGSSNC (1,1), MGSSPR (1) ) | |
20621 | EQUIVALENCE ( MGSSNC (1,2), MGSSNE (1) ) | |
20622 | EQUIVALENCE ( NTANUC (1), NTAPRO ) | |
20623 | EQUIVALENCE ( NTANUC (2), NTANEU ) | |
20624 | EQUIVALENCE ( NAVNUC (1), NAVPRO ) | |
20625 | EQUIVALENCE ( NAVNUC (2), NAVNEU ) | |
20626 | EQUIVALENCE ( NLSNUC (1), NLSPRO ) | |
20627 | EQUIVALENCE ( NLSNUC (2), NLSNEU ) | |
20628 | EQUIVALENCE ( NCONUC (1), NCOPRO ) | |
20629 | EQUIVALENCE ( NCONUC (2), NCONEU ) | |
20630 | EQUIVALENCE ( NSKNUC (1), NSKPRO ) | |
20631 | EQUIVALENCE ( NSKNUC (2), NSKNEU ) | |
20632 | EQUIVALENCE ( NHANUC (1), NHAPRO ) | |
20633 | EQUIVALENCE ( NHANUC (2), NHANEU ) | |
20634 | EQUIVALENCE ( NUSNUC (1), NUSPRO ) | |
20635 | EQUIVALENCE ( NUSNUC (2), NUSNEU ) | |
20636 | EQUIVALENCE ( NACNUC (1), NACPRO ) | |
20637 | EQUIVALENCE ( NACNUC (2), NACNEU ) | |
20638 | EQUIVALENCE ( JMXNUC (1), JMXPRO ) | |
20639 | EQUIVALENCE ( JMXNUC (2), JMXNEU ) | |
20640 | EQUIVALENCE ( MAGNUC (1), MAGPRO ) | |
20641 | EQUIVALENCE ( MAGNUC (2), MAGNEU ) | |
20642 | * (original name: PAREVT) | |
20643 | LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX, | |
20644 | & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF | |
20645 | PARAMETER ( NALLWP = 39 ) | |
20646 | COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, | |
20647 | & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY, | |
20648 | & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV, | |
20649 | & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF | |
20650 | * (original name: XSEPAR) | |
20651 | COMMON /FKXSEP/ AANXSE (100), BBNXSE (100), CCNXSE (100), | |
20652 | & DDNXSE (100), EENXSE (100), ZZNXSE (100), | |
20653 | & EMNXSE (100), XMNXSE (100), | |
20654 | & AAPXSE (100), BBPXSE (100), CCPXSE (100), | |
20655 | & DDPXSE (100), EEPXSE (100), FFPXSE (100), | |
20656 | & ZZPXSE (100), EMPXSE (100), XMPXSE (100) | |
20657 | ||
20658 | C--------------------------------------------------------------------- | |
20659 | **sr 17.5.95 | |
20660 | * modified for use in DPMJET | |
20661 | C WRITE( LUNOUT,'(A,I2)') | |
20662 | C & ' *** Reading evaporation and nuclear data from unit: ', NBERTP | |
20663 | C REWIND NBERTP | |
20664 | IF (LEVPRT) WRITE(LUNOUT,1000) | |
20665 | 1000 FORMAT(/,1X,'BERTTP:',4X,'Initialization of evaporation module', | |
20666 | & /,12X,'------------------------------------',/) | |
20667 | NBERNW = 23 | |
f87dab60 | 20668 | CPH OPEN (UNIT=NBERNW,FILE='dpmjet.dat',STATUS='UNKNOWN') |
9aaba0d6 | 20669 | |
20670 | **sr 17.5. | |
20671 | *!!!! changed to be able to read the ASCII !!!! | |
20672 | ** | |
20673 | C A. Ferrari: first of all read isotopic data | |
20674 | READ (NBERNW,*) ISONDX | |
20675 | READ (NBERNW,*) ISOMNM | |
20676 | READ (NBERNW,*) ABUISO | |
20677 | C READ (NBERTP) ISONDX | |
20678 | C READ (NBERTP) ISOMNM | |
20679 | C READ (NBERTP) ABUISO | |
20680 | DO 1 I=1,4 | |
20681 | C READ (NBERTP) (CRSC(J,I),J=1,600) | |
20682 | C A. Ferrari: commented also the dummy read to save disk space | |
20683 | C READ (NBERTP) | |
20684 | 1 CONTINUE | |
20685 | C READ (NBERTP) CS | |
20686 | C A. Ferrari: commented also the dummy read to save disk space | |
20687 | C READ (NBERTP) | |
20688 | C--------------------------------------------------------------------- | |
20689 | READ (NBERNW,*) (P0(I),P1(I),P2(I),I=1,1001) | |
20690 | READ (NBERNW,*) IA,IZ | |
20691 | DO 2 I=1,6 | |
20692 | FLA(I)=IA(I) | |
20693 | FLZ(I)=IZ(I) | |
20694 | 2 CONTINUE | |
20695 | READ (NBERNW,*) RHO,OMEGA | |
20696 | READ (NBERNW,*) EXMASS | |
20697 | READ (NBERNW,*) CAM2 | |
20698 | READ (NBERNW,*) CAM3 | |
20699 | READ (NBERNW,*) CAM4 | |
20700 | READ (NBERNW,*) CAM5 | |
20701 | READ (NBERNW,*) ((T(I,J),J=1,7),I=1,3) | |
20702 | DO 3 I=1,7 | |
20703 | T(4,I) = ZERZER | |
20704 | 3 CONTINUE | |
20705 | READ (NBERNW,*) RMASS | |
20706 | READ (NBERNW,*) ALPH | |
20707 | READ (NBERNW,*) BET | |
20708 | READ (NBERNW,*) INWAPS | |
20709 | READ (NBERNW,*) WAPS | |
20710 | READ (NBERNW,*) T12NUC | |
20711 | READ (NBERNW,*) JSPNUC | |
20712 | READ (NBERNW,*) JPTNUC | |
20713 | READ (NBERNW,*) INWISM | |
20714 | READ (NBERNW,*) IZWISM | |
20715 | READ (NBERNW,*) WAPISM | |
20716 | READ (NBERNW,*) T12ISM | |
20717 | READ (NBERNW,*) JSPISM | |
20718 | READ (NBERNW,*) JPTISM | |
20719 | READ (NBERNW,*) APRIME | |
20720 | IF (LEVPRT) | |
20721 | &WRITE( LUNOUT,'(A)' ) ' *** Evaporation: using 1977 Waps data ***' | |
20722 | READ (NBERNW,*) AHELP , BHELP , LRMSCH, LRD1O2, LTRASP | |
20723 | IF ( ABS (AHELP-ALPHA0) .GT. CSNNRM * ALPHA0 .OR. | |
20724 | & ABS (BHELP-GAMSK0) .GT. CSNNRM * GAMSK0 ) THEN | |
20725 | WRITE (LUNOUT,*) | |
20726 | & ' *** Inconsistent Nuclear Geometry data on file ***' | |
20727 | STOP | |
20728 | END IF | |
20729 | READ (NBERNW,*) RHOTAB, RHATAB, ALPTAB, RADTAB, SKITAB, HALTAB, | |
20730 | & EKATAB, PFATAB, PFRTAB | |
20731 | READ (NBERNW,*) AANXSE, BBNXSE, CCNXSE, DDNXSE, EENXSE, ZZNXSE, | |
20732 | & EMNXSE, XMNXSE | |
20733 | READ (NBERNW,*) AAPXSE, BBPXSE, CCPXSE, DDPXSE, EEPXSE, FFPXSE, | |
20734 | & ZZPXSE, EMPXSE, XMPXSE | |
20735 | * Data about Fermi-breakup: | |
20736 | READ (NBERNW,*) IPOSST, MXPDUM, MXADUM, MXNDUM, MXZDUM, IFBSTF | |
20737 | IF ( MXADUM .NE. MXAFBK .OR. MXNDUM .NE. MXNFBK .OR. MXZDUM .NE. | |
20738 | & MXZFBK .OR. MXPDUM .NE. MXPSST ) THEN | |
20739 | WRITE (LUNOUT,*)' *** Inconsistent Fermi BreakUp data', | |
20740 | & ' in the Nuclear Data file ***' | |
20741 | STOP 'STOP:BERTTP-INCONS-FERMI-BREAKUP-DATA' | |
20742 | END IF | |
20743 | READ (NBERNW,*) IFRBKN | |
20744 | READ (NBERNW,*) IFRBKZ | |
20745 | READ (NBERNW,*) IFBKSP | |
20746 | READ (NBERNW,*) IFBKST | |
20747 | READ (NBERNW,*) EEXFBK | |
20748 | ||
20749 | CLOSE (UNIT=NBERNW) | |
20750 | ||
20751 | C READ (NBERTP) (P0(I),P1(I),P2(I),I=1,1001) | |
20752 | C READ (NBERTP) IA,IZ | |
20753 | C DO 2 I=1,6 | |
20754 | C FLA(I)=IA(I) | |
20755 | C FLZ(I)=IZ(I) | |
20756 | C 2 CONTINUE | |
20757 | C READ (NBERTP) RHO,OMEGA | |
20758 | C READ (NBERTP) EXMASS | |
20759 | C READ (NBERTP) CAM2 | |
20760 | C READ (NBERTP) CAM3 | |
20761 | C READ (NBERTP) CAM4 | |
20762 | C READ (NBERTP) CAM5 | |
20763 | C READ (NBERTP) ((T(I,J),J=1,7),I=1,3) | |
20764 | C DO 3 I=1,7 | |
20765 | C T(4,I) = ZERZER | |
20766 | C 3 CONTINUE | |
20767 | C READ (NBERTP) RMASS | |
20768 | C READ (NBERTP) ALPH | |
20769 | C READ (NBERTP) BET | |
20770 | C READ (NBERTP) INWAPS | |
20771 | C READ (NBERTP) WAPS | |
20772 | C READ (NBERTP) T12NUC | |
20773 | C READ (NBERTP) JSPNUC | |
20774 | C READ (NBERTP) JPTNUC | |
20775 | C READ (NBERTP) INWISM | |
20776 | C READ (NBERTP) IZWISM | |
20777 | C READ (NBERTP) WAPISM | |
20778 | C READ (NBERTP) T12ISM | |
20779 | C READ (NBERTP) JSPISM | |
20780 | C READ (NBERTP) JPTISM | |
20781 | C READ (NBERTP) APRIME | |
20782 | C WRITE( LUNOUT,'(A)' ) ' *** Evaporation: using 1977 Waps data ***' | |
20783 | C READ (NBERTP) AHELP , BHELP , LRMSCH, LRD1O2, LTRASP | |
20784 | C IF ( ABS (AHELP-ALPHA0) .GT. CSNNRM * ALPHA0 .OR. | |
20785 | C & ABS (BHELP-GAMSK0) .GT. CSNNRM * GAMSK0 ) THEN | |
20786 | C WRITE (LUNOUT,*) | |
20787 | C & ' *** Inconsistent Nuclear Geometry data on file ***' | |
20788 | C STOP | |
20789 | C END IF | |
20790 | C READ (NBERTP) RHOTAB, RHATAB, ALPTAB, RADTAB, SKITAB, HALTAB, | |
20791 | C & EKATAB, PFATAB, PFRTAB | |
20792 | C READ (NBERTP) AANXSE, BBNXSE, CCNXSE, DDNXSE, EENXSE, ZZNXSE, | |
20793 | C & EMNXSE, XMNXSE | |
20794 | C READ (NBERTP) AAPXSE, BBPXSE, CCPXSE, DDPXSE, EEPXSE, FFPXSE, | |
20795 | C & ZZPXSE, EMPXSE, XMPXSE | |
20796 | * Data about Fermi-breakup: | |
20797 | C READ (NBERTP) IPOSST, MXPDUM, MXADUM, MXNDUM, MXZDUM, IFBSTF | |
20798 | C IF ( MXADUM .NE. MXAFBK .OR. MXNDUM .NE. MXNFBK .OR. MXZDUM .NE. | |
20799 | C & MXZFBK .OR. MXPDUM .NE. MXPSST ) THEN | |
20800 | C WRITE (LUNOUT,*)' *** Inconsistent Fermi BreakUp data', | |
20801 | C & ' in the Nuclear Data file ***' | |
20802 | C STOP 'STOP:BERTTP-INCONS-FERMI-BREAKUP-DATA' | |
20803 | C END IF | |
20804 | C READ (NBERTP) IFRBKN | |
20805 | C READ (NBERTP) IFRBKZ | |
20806 | C READ (NBERTP) IFBKSP | |
20807 | C READ (NBERTP) IFBKST | |
20808 | C READ (NBERTP) EEXFBK | |
20809 | C CLOSE (UNIT=NBERTP) | |
20810 | DO 100 JZ = 1, 130 | |
20811 | SHENUC ( JZ, 1 ) = EMVGEV * ( CAM2 (JZ) + CAM4 (JZ) ) | |
20812 | 100 CONTINUE | |
20813 | DO 200 JA = 1, 200 | |
20814 | SHENUC ( JA, 2 ) = EMVGEV * ( CAM3 (JA) + CAM5 (JA) ) | |
20815 | 200 CONTINUE | |
20816 | CALL DT_STALIN | |
20817 | IF ( ILVMOD .LE. 0 ) THEN | |
20818 | ILVMOD = IB0 | |
20819 | ELSE | |
20820 | IB0 = ILVMOD | |
20821 | END IF | |
20822 | IF ( LLVMOD ) THEN | |
20823 | DO 300 JZ = 1, IZCOOK | |
20824 | CAM4 (JZ) = PZCOOK (JZ) | |
20825 | 300 CONTINUE | |
20826 | DO 400 JN = 1, INCOOK | |
20827 | CAM5 (JN) = PNCOOK (JZ) | |
20828 | 400 CONTINUE | |
20829 | END IF | |
20830 | **sr | |
20831 | IF (LEVPRT) THEN | |
20832 | WRITE (LUNOUT,*) | |
20833 | IF ( ILVMOD .EQ. 1 ) THEN | |
20834 | WRITE (LUNOUT,*) | |
20835 | & ' **** Standard EVAP T=0 level density used ****' | |
20836 | ELSE IF ( ILVMOD .EQ. 2 ) THEN | |
20837 | WRITE (LUNOUT,*) | |
20838 | & ' **** Gilbert & Cameron T=0 N,Z-dep. level density used ****' | |
20839 | ELSE IF ( ILVMOD .EQ. 3 ) THEN | |
20840 | WRITE (LUNOUT,*) | |
20841 | & ' **** Julich A-dependent level density used ****' | |
20842 | ELSE IF ( ILVMOD .EQ. 4 ) THEN | |
20843 | WRITE (LUNOUT,*) | |
20844 | & ' **** Brancazio & Cameron T=0 N,Z-dep. level density used', | |
20845 | & ' ****' | |
20846 | ELSE | |
20847 | WRITE (LUNOUT,*) | |
20848 | & ' **** Unknown T=0 level density option requested ****' | |
20849 | STOP 'BERTTP-ILVMOD' | |
20850 | END IF | |
20851 | IF ( JLVMOD .LE. 0 ) THEN | |
20852 | GAMIGN = ZERZER | |
20853 | WRITE (LUNOUT,*) | |
20854 | & ' **** No Excitation en. dependence for level densities ****' | |
20855 | ELSE IF ( JLVMOD .EQ. 1 ) THEN | |
20856 | WRITE (LUNOUT,*) | |
20857 | & ' **** Ignyatuk (1975, 1st) level density en. dep. used ****' | |
20858 | WRITE (LUNOUT,*) | |
20859 | & ' **** with Ignyatuk (1975, 1st) set of parameters for T=oo', | |
20860 | & ' ****' | |
20861 | GAMIGN = 0.054D+00 | |
20862 | BETIGN = -6.3 D-05 | |
20863 | ALPIGN = 0.154D+00 | |
20864 | POWIGN = ZERZER | |
20865 | ELSE IF ( JLVMOD .EQ. 2 ) THEN | |
20866 | WRITE (LUNOUT,*) | |
20867 | & ' **** Ignyatuk (1975, 1st) level density en. dep. used ****' | |
20868 | WRITE (LUNOUT,*) | |
20869 | & ' **** with UNKNOWN set of parameters for T=oo ****' | |
20870 | STOP 'BERTTP-JLVMOD' | |
20871 | ELSE IF ( JLVMOD .EQ. 3 ) THEN | |
20872 | WRITE (LUNOUT,*) | |
20873 | & ' **** Ignyatuk (1975, 1st) level density en. dep. used ****' | |
20874 | WRITE (LUNOUT,*) | |
20875 | & ' **** with UNKNOWN set of parameters for T=oo ****' | |
20876 | STOP 'BERTTP-JLVMOD' | |
20877 | ELSE IF ( JLVMOD .EQ. 4 ) THEN | |
20878 | WRITE (LUNOUT,*) | |
20879 | & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****' | |
20880 | WRITE (LUNOUT,*) | |
20881 | & ' **** with Ignyatuk (1975, 2nd) set of parameters for T=oo', | |
20882 | & ' ****' | |
20883 | GAMIGN = 0.054D+00 | |
20884 | BETIGN = 0.162D+00 | |
20885 | ALPIGN = 0.114D+00 | |
20886 | POWIGN = -ONETHI | |
20887 | ELSE IF ( JLVMOD .EQ. 5 ) THEN | |
20888 | WRITE (LUNOUT,*) | |
20889 | & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****' | |
20890 | WRITE (LUNOUT,*) | |
20891 | & ' **** with Iljinov & Mebel 1st set of parameters for T=oo****' | |
20892 | GAMIGN = 0.051D+00 | |
20893 | BETIGN = 0.098D+00 | |
20894 | ALPIGN = 0.114D+00 | |
20895 | POWIGN = -ONETHI | |
20896 | ELSE IF ( JLVMOD .EQ. 6 ) THEN | |
20897 | WRITE (LUNOUT,*) | |
20898 | & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****' | |
20899 | WRITE (LUNOUT,*) | |
20900 | & ' **** with Iljinov & Mebel 2nd set of parameters for T=oo****' | |
20901 | GAMIGN = -0.46D+00 | |
20902 | BETIGN = 0.107D+00 | |
20903 | ALPIGN = 0.111D+00 | |
20904 | POWIGN = -ONETHI | |
20905 | ELSE IF ( JLVMOD .EQ. 7 ) THEN | |
20906 | WRITE (LUNOUT,*) | |
20907 | & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****' | |
20908 | WRITE (LUNOUT,*) | |
20909 | & ' **** with Iljinov & Mebel 3rd set of parameters for T=oo****' | |
20910 | GAMIGN = 0.059D+00 | |
20911 | BETIGN = 0.257D+00 | |
20912 | ALPIGN = 0.072D+00 | |
20913 | POWIGN = -ONETHI | |
20914 | ELSE IF ( JLVMOD .EQ. 8 ) THEN | |
20915 | WRITE (LUNOUT,*) | |
20916 | & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****' | |
20917 | WRITE (LUNOUT,*) | |
20918 | & ' **** with Iljinov & Mebel 4th set of parameters for T=oo****' | |
20919 | GAMIGN = -0.37D+00 | |
20920 | BETIGN = 0.229D+00 | |
20921 | ALPIGN = 0.077D+00 | |
20922 | POWIGN = -ONETHI | |
20923 | ELSE | |
20924 | WRITE (LUNOUT,*) | |
20925 | & ' **** Unknown T=oo level density option requested ****' | |
20926 | STOP 'BERTTP-JLVMOD' | |
20927 | END IF | |
20928 | IF ( LLVMOD ) THEN | |
20929 | WRITE (LUNOUT,*) | |
20930 | & ' **** Cook''s modified pairing energy used ****' | |
20931 | ELSE | |
20932 | WRITE (LUNOUT,*) | |
20933 | & ' **** Original Gilbert/Cameron pairing energy used ****' | |
20934 | END IF | |
20935 | ENDIF | |
20936 | ** | |
20937 | ||
20938 | ILVMOD = IB0 | |
20939 | DO 500 JZ = 1, 130 | |
20940 | PAENUC ( JZ, 1 ) = EMVGEV * CAM4 (JZ) | |
20941 | 500 CONTINUE | |
20942 | DO 600 JA = 1, 200 | |
20943 | PAENUC ( JA, 2 ) = EMVGEV * CAM5 (JA) | |
20944 | 600 CONTINUE | |
20945 | RETURN | |
20946 | END | |
20947 | ||
20948 | *$ CREATE DT_EVEVAP.FOR | |
20949 | *COPY DT_EVEVAP | |
20950 | * | |
20951 | *====evevap============================================================* | |
20952 | * | |
20953 | SUBROUTINE DT_EVEVAP(WE) | |
20954 | ||
20955 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
20956 | SAVE | |
20957 | PARAMETER ( LINP = 10 , | |
20958 | & LOUT = 6 , | |
20959 | & LDAT = 9 ) | |
20960 | ||
20961 | * flags for input different options | |
20962 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
20963 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
20964 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
20965 | ||
20966 | LEVAPO = .FALSE. | |
20967 | ||
20968 | RETURN | |
20969 | END | |
20970 | ||
20971 | *$ CREATE DT_FRBKIN.FOR | |
20972 | *COPY DT_FRBKIN | |
20973 | * | |
20974 | *====frbkin============================================================* | |
20975 | * | |
20976 | SUBROUTINE DT_FRBKIN(LDUM1,LDUM2) | |
20977 | ||
20978 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
20979 | SAVE | |
20980 | PARAMETER ( LINP = 10 , | |
20981 | & LOUT = 6 , | |
20982 | & LDAT = 9 ) | |
20983 | ||
20984 | LOGICAL LDUM1,LDUM2 | |
20985 | ||
20986 | RETURN | |
20987 | END | |
20988 | ||
20989 | *$ CREATE DT_EXPLOD.FOR | |
20990 | *COPY DT_EXPLOD | |
20991 | * | |
20992 | *=== explod ===========================================================* | |
20993 | * | |
20994 | SUBROUTINE DT_EXPLOD( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL, | |
20995 | & PYEXPL, PZEXPL ) | |
20996 | ||
20997 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
20998 | SAVE | |
20999 | ||
21000 | DIMENSION PXEXPL (NPEXPL), PYEXPL (NPEXPL), PZEXPL (NPEXPL), | |
21001 | & ETEXPL (NPEXPL), AMEXPL (NPEXPL) | |
21002 | ||
21003 | RETURN | |
21004 | END | |
21005 | ||
21006 | ************************************************************************ | |
21007 | * * | |
21008 | * DPMJET 3.0: cross section routines * | |
21009 | * * | |
21010 | ************************************************************************ | |
21011 | * | |
21012 | * | |
21013 | * SUBROUTINE DT_SHNDIF | |
21014 | * diffractive cross sections (all energies) | |
21015 | * SUBROUTINE DT_PHOXS | |
21016 | * total and inel. cross sections from PHOJET interpol. tables | |
21017 | * SUBROUTINE DT_XSHN | |
21018 | * total and el. cross sections for all energies | |
21019 | * SUBROUTINE DT_SIHNAB | |
21020 | * pion 2-nucleon absorption cross sections | |
21021 | * SUBROUTINE DT_SIGEMU | |
21022 | * cross section for target "compounds" | |
21023 | * SUBROUTINE DT_SIGGA | |
21024 | * photon nucleus cross sections | |
21025 | * SUBROUTINE DT_SIGGAT | |
21026 | * photon nucleus cross sections from tables | |
21027 | * SUBROUTINE DT_SANO | |
21028 | * anomalous hard photon-nucleon cross sections from tables | |
21029 | * SUBROUTINE DT_SIGGP | |
21030 | * photon nucleon cross sections | |
21031 | * SUBROUTINE DT_SIGVEL | |
21032 | * quasi-elastic vector meson prod. cross sections | |
21033 | * DOUBLE PRECISION FUNCTION DT_SIGVP | |
21034 | * sigma_VN(tilde) | |
21035 | * DOUBLE PRECISION FUNCTION DT_RRM2 | |
21036 | * DOUBLE PRECISION FUNCTION DT_RM2 | |
21037 | * DOUBLE PRECISION FUNCTION DT_SAM2 | |
21038 | * SUBROUTINE DT_CKMT | |
21039 | * SUBROUTINE DT_CKMTX | |
21040 | * SUBROUTINE DT_PDF0 | |
21041 | * SUBROUTINE DT_CKMTQ0 | |
21042 | * SUBROUTINE DT_CKMTDE | |
21043 | * SUBROUTINE DT_CKMTPR | |
21044 | * FUNCTION DT_CKMTFF | |
21045 | * | |
21046 | * SUBROUTINE DT_FLUINI | |
21047 | * total nucleon cross section fluctuation treatment | |
21048 | * | |
21049 | * SUBROUTINE DT_SIGTBL | |
21050 | * pre-tabulation of low-energy elastic x-sec. using SIHNEL | |
21051 | * SUBROUTINE DT_XSTABL | |
21052 | * service routines | |
21053 | * | |
21054 | * | |
21055 | *$ CREATE DT_SHNDIF.FOR | |
21056 | *COPY DT_SHNDIF | |
21057 | * | |
21058 | *===shndif===============================================================* | |
21059 | * | |
21060 | SUBROUTINE DT_SHNDIF(ECM,KPROJ,KTARG,SIGDIF,SIGDIH) | |
21061 | ||
21062 | ********************************************************************** | |
21063 | * Single diffractive hadron-nucleon cross sections * | |
21064 | * S.Roesler 14/1/93 * | |
21065 | * * | |
21066 | * The cross sections are calculated from extrapolated single * | |
21067 | * diffractive antiproton-proton cross sections (DTUJET92) using * | |
21068 | * scaling relations between total and single diffractive cross * | |
21069 | * sections. * | |
21070 | ********************************************************************** | |
21071 | ||
21072 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
21073 | SAVE | |
21074 | PARAMETER (ZERO=0.0D0) | |
21075 | ||
21076 | * particle properties (BAMJET index convention) | |
21077 | CHARACTER*8 ANAME | |
21078 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
21079 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
21080 | * | |
21081 | CSD1 = 4.201483727D0 | |
21082 | CSD4 = -0.4763103556D-02 | |
21083 | CSD5 = 0.4324148297D0 | |
21084 | * | |
21085 | CHMSD1 = 0.8519297242D0 | |
21086 | CHMSD4 = -0.1443076599D-01 | |
21087 | CHMSD5 = 0.4014954567D0 | |
21088 | * | |
21089 | EPN = (ECM**2 -AAM(KPROJ)**2 -AAM(KTARG)**2)/(2.0D0*AAM(KTARG)) | |
21090 | PPN = SQRT((EPN-AAM(KPROJ))*(EPN+AAM(KPROJ))) | |
21091 | * | |
21092 | SDIAPP = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN) | |
21093 | SHMSD = CHMSD1+CHMSD4*LOG(PPN)**2+CHMSD5*LOG(PPN) | |
21094 | FRAC = SHMSD/SDIAPP | |
21095 | * | |
21096 | GOTO( 10, 20,999,999,999,999,999, 10, 20,999, | |
21097 | & 999, 20, 20, 20, 20, 20, 10, 20, 20, 10, | |
21098 | & 10, 10, 20, 20, 20) KPROJ | |
21099 | * | |
21100 | 10 CONTINUE | |
21101 | *---------------------------- p - p , n - p , sigma0+- - p , | |
21102 | * Lambda - p | |
21103 | CSD1 = 6.004476070D0 | |
21104 | CSD4 = -0.1257784606D-03 | |
21105 | CSD5 = 0.2447335720D0 | |
21106 | SIGDIF = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN) | |
21107 | SIGDIH = FRAC*SIGDIF | |
21108 | RETURN | |
21109 | * | |
21110 | 20 CONTINUE | |
21111 | * | |
21112 | KPSCAL = 2 | |
21113 | KTSCAL = 1 | |
21114 | C F = SDIAPP/DT_SHNTOT(KPSCAL,KTSCAL,ECM,ZERO) | |
21115 | DUMZER = ZERO | |
21116 | CALL DT_XSHN(KPSCAL,KTSCAL,DUMZER,ECM,SIGTO,SIGEL) | |
21117 | F = SDIAPP/SIGTO | |
21118 | KT = 1 | |
21119 | C SIGDIF = DT_SHNTOT(KPROJ,KT,ECM,ZERO)*F | |
21120 | CALL DT_XSHN(KPROJ,KT,DUMZER,ECM,SIGTO,SIGEL) | |
21121 | SIGDIF = SIGTO*F | |
21122 | SIGDIH = FRAC*SIGDIF | |
21123 | RETURN | |
21124 | * | |
21125 | 999 CONTINUE | |
21126 | *-------------------------- leptons.. | |
21127 | SIGDIF = 1.D-10 | |
21128 | SIGDIH = 1.D-10 | |
21129 | RETURN | |
21130 | END | |
21131 | ||
21132 | *$ CREATE DT_PHOXS.FOR | |
21133 | *COPY DT_PHOXS | |
21134 | * | |
21135 | *===phoxs================================================================* | |
21136 | * | |
21137 | SUBROUTINE DT_PHOXS(KPROJ,KTARG,ECM,PLAB,STOT,SINE,SDIF1,BEL,MODE) | |
21138 | ||
21139 | ************************************************************************ | |
21140 | * Total/inelastic proton-nucleon cross sections taken from PHOJET- * | |
21141 | * interpolation tables. * | |
21142 | * This version dated 05.11.97 is written by S. Roesler * | |
21143 | ************************************************************************ | |
21144 | ||
21145 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
21146 | SAVE | |
21147 | ||
21148 | PARAMETER ( LINP = 10 , | |
21149 | & LOUT = 6 , | |
21150 | & LDAT = 9 ) | |
21151 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0) | |
21152 | PARAMETER (TWOPI = 6.283185307179586454D+00, | |
21153 | & PI = TWOPI/TWO, | |
21154 | & GEV2MB = 0.38938D0) | |
21155 | ||
21156 | LOGICAL LFIRST | |
21157 | DATA LFIRST /.TRUE./ | |
21158 | ||
21159 | * nucleon-nucleon event-generator | |
21160 | CHARACTER*8 CMODEL | |
21161 | LOGICAL LPHOIN | |
21162 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
21163 | * particle properties (BAMJET index convention) | |
21164 | CHARACTER*8 ANAME | |
21165 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
21166 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
21167 | ||
21168 | **PHOJET105a | |
21169 | C PARAMETER (IEETAB=10) | |
21170 | C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX | |
21171 | **PHOJET110 | |
21172 | C energy-interpolation table | |
21173 | INTEGER IEETA2 | |
21174 | PARAMETER ( IEETA2 = 20 ) | |
21175 | INTEGER ISIMAX | |
21176 | DOUBLE PRECISION SIGTAB,SIGECM | |
21177 | COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX | |
21178 | ** | |
21179 | ||
21180 | IF ((MCGENE.NE.2).AND.(MODE.NE.1)) THEN | |
21181 | WRITE(LOUT,*) MCGENE | |
21182 | 1000 FORMAT(1X,'PHOXS: warning! PHOJET not initialized (',I2,')') | |
21183 | STOP | |
21184 | ENDIF | |
21185 | ||
21186 | IF (ECM.LE.ZERO) THEN | |
21187 | EPN = SQRT(AAM(KPROJ)**2+PLAB**2) | |
21188 | ECM = SQRT(AAM(KPROJ)**2+AAM(KTARG)**2+2.0D0*EPN*AAM(KTARG)) | |
21189 | ENDIF | |
21190 | ||
21191 | IF (MODE.EQ.1) THEN | |
21192 | * DL | |
21193 | DELDL = 0.0808D0 | |
21194 | EPSDL = -0.4525D0 | |
21195 | S = ECM*ECM | |
21196 | STOT = 21.7D0*S**DELDL+56.08D0*S**EPSDL | |
21197 | ALPHAP= 0.25D0 | |
21198 | BEL = 8.5D0+2.D0*ALPHAP*LOG(S) | |
21199 | SIGEL = STOT**2/(16.D0*PI*BEL*GEV2MB) | |
21200 | SINE = STOT-SIGEL | |
21201 | SDIF1 = ZERO | |
21202 | ELSE | |
21203 | * Phojet | |
21204 | IP = 1 | |
21205 | IF(ECM.LE.SIGECM(IP,1)) THEN | |
21206 | I1 = 1 | |
21207 | I2 = 1 | |
21208 | ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN | |
21209 | DO 1 I=2,ISIMAX | |
21210 | IF (ECM.LE.SIGECM(IP,I)) GOTO 2 | |
21211 | 1 CONTINUE | |
21212 | 2 CONTINUE | |
21213 | I1 = I-1 | |
21214 | I2 = I | |
21215 | ELSE | |
21216 | IF (LFIRST) THEN | |
21217 | WRITE(LOUT,'(/1X,A,2E12.3)') | |
21218 | & 'PHOXS: warning! energy above initialization limit (', | |
21219 | & ECM,SIGECM(IP,ISIMAX) | |
21220 | LFIRST = .FALSE. | |
21221 | ENDIF | |
21222 | I1 = ISIMAX | |
21223 | I2 = ISIMAX | |
21224 | ENDIF | |
21225 | FAC2 = ZERO | |
21226 | IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1)) | |
21227 | & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1)) | |
21228 | FAC1 = ONE-FAC2 | |
21229 | STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1) | |
21230 | SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1) | |
21231 | SDIF1 = FAC2*(SIGTAB(IP,30,I2)+SIGTAB(IP,32,I2))+ | |
21232 | & FAC1*(SIGTAB(IP,30,I1)+SIGTAB(IP,32,I1)) | |
21233 | BEL = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1) | |
21234 | ENDIF | |
21235 | ||
21236 | RETURN | |
21237 | END | |
21238 | ||
21239 | *$ CREATE DT_XSHN.FOR | |
21240 | *COPY DT_XSHN | |
21241 | * | |
21242 | *===xshn===============================================================* | |
21243 | * | |
21244 | SUBROUTINE DT_XSHN(IP,IT,PL,ECM,STOT,SELA) | |
21245 | ||
21246 | ************************************************************************ | |
21247 | * Total and elastic hadron-nucleon cross section. * | |
21248 | * Below 500GeV cross sections are based on the '98 data compilation * | |
21249 | * of the PDG. At higher energies PHOJET results are used (patched to * | |
21250 | * the low energy data at 500GeV). * | |
21251 | * IP projectile index (BAMJET numbering scheme) * | |
21252 | * (should be in the range 1..25) * | |
21253 | * IT target index (BAMJET numbering scheme) * | |
21254 | * (1 = proton, 8 = neutron) * | |
21255 | * PL laboratory momentum * | |
21256 | * ECM cm. energy (ignored if PL>0) * | |
21257 | * STOT total cross section * | |
21258 | * SELA elastic cross section * | |
21259 | * Last change: 24.4.99 by S. Roesler * | |
21260 | ************************************************************************ | |
21261 | ||
21262 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
21263 | SAVE | |
21264 | ||
21265 | PARAMETER ( LINP = 10 , | |
21266 | & LOUT = 6 , | |
21267 | & LDAT = 9 ) | |
21268 | PARAMETER (ZERO=0.0D0,ONE=1.0D0) | |
21269 | ||
21270 | PARAMETER (NPOIN1 = 54, NPOIN2 = 8, | |
21271 | & PLABLO = 0.1D0, PTHRE = 5.0D0, PLABHI = 500.0D0) | |
21272 | PARAMETER (NPOINT = NPOIN1+NPOIN2+1) | |
21273 | ||
21274 | LOGICAL LFIRST | |
21275 | * particle properties (BAMJET index convention) | |
21276 | CHARACTER*8 ANAME | |
21277 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
21278 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
21279 | * nucleon-nucleon event-generator | |
21280 | CHARACTER*8 CMODEL | |
21281 | LOGICAL LPHOIN | |
21282 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
21283 | **PHOJET105a | |
21284 | C PARAMETER (IEETAB=10) | |
21285 | C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX | |
21286 | **PHOJET110 | |
21287 | C energy-interpolation table | |
21288 | INTEGER IEETA2 | |
21289 | PARAMETER ( IEETA2 = 20 ) | |
21290 | INTEGER ISIMAX | |
21291 | DOUBLE PRECISION SIGTAB,SIGECM | |
21292 | COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX | |
21293 | ||
21294 | DIMENSION APL(NPOINT),ASIGTO(10,NPOINT),ASIGEL(10,NPOINT) | |
21295 | DIMENSION IDXDAT(25,2) | |
21296 | * | |
21297 | DATA APL / | |
21298 | &-1.000,-0.969,-0.937,-0.906,-0.874,-0.843,-0.811,-0.780,-0.748, | |
21299 | &-0.717,-0.685,-0.654,-0.622,-0.591,-0.560,-0.528,-0.497,-0.465, | |
21300 | &-0.434,-0.402,-0.371,-0.339,-0.308,-0.276,-0.245,-0.213,-0.182, | |
21301 | &-0.151,-0.119,-0.088,-0.056,-0.025, 0.007, 0.038, 0.070, 0.101, | |
21302 | & 0.133, 0.164, 0.196, 0.227, 0.258, 0.290, 0.321, 0.353, 0.384, | |
21303 | & 0.416, 0.447, 0.479, 0.510, 0.542, 0.573, 0.605, 0.636, 0.668, | |
21304 | & 0.699, 0.949, 1.199, 1.449, 1.699, 1.949, 2.199, 2.449, 2.699/ | |
21305 | * | |
21306 | * total cross sections: | |
21307 | * p p | |
21308 | DATA (ASIGTO(1,K),K=1,NPOINT) / | |
21309 | & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255, | |
21310 | & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646, | |
21311 | & 1.577, 1.518, 1.462, 1.420, 1.393, 1.375, 1.363, 1.356, 1.352, | |
21312 | & 1.350, 1.351, 1.359, 1.381, 1.410, 1.444, 1.487, 1.544, 1.596, | |
21313 | & 1.650, 1.672, 1.676, 1.677, 1.677, 1.675, 1.675, 1.669, 1.664, | |
21314 | & 1.658, 1.653, 1.645, 1.640, 1.634, 1.630, 1.625, 1.620, 1.617, | |
21315 | & 1.614, 1.602, 1.594, 1.589, 1.581, 1.583, 1.588, 1.596, 1.603/ | |
21316 | * pbar p | |
21317 | DATA (ASIGTO(2,K),K=1,NPOINT) / | |
21318 | & 2.778, 2.759, 2.739, 2.718, 2.697, 2.675, 2.651, 2.626, 2.598, | |
21319 | & 2.569, 2.537, 2.502, 2.471, 2.443, 2.420, 2.389, 2.361, 2.329, | |
21320 | & 2.313, 2.304, 2.268, 2.244, 2.222, 2.212, 2.178, 2.162, 2.151, | |
21321 | & 2.132, 2.109, 2.097, 2.089, 2.078, 2.063, 2.049, 2.035, 2.024, | |
21322 | & 2.014, 2.004, 1.993, 1.981, 1.970, 1.958, 1.946, 1.933, 1.921, | |
21323 | & 1.909, 1.894, 1.885, 1.871, 1.854, 1.836, 1.825, 1.816, 1.802, | |
21324 | & 1.790, 1.744, 1.694, 1.663, 1.642, 1.614, 1.623, 1.623, 1.630/ | |
21325 | * n p | |
21326 | DATA (ASIGTO(3,K),K=1,NPOINT) / | |
21327 | & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763, | |
21328 | & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115, | |
21329 | & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569, | |
21330 | & 1.547, 1.534, 1.526, 1.522, 1.520, 1.525, 1.536, 1.550, 1.566, | |
21331 | & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609, | |
21332 | & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605, | |
21333 | & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/ | |
21334 | * pi+ p | |
21335 | DATA (ASIGTO(4,K),K=1,NPOINT) / | |
21336 | & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610, | |
21337 | & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118, | |
21338 | & 2.001, 1.875, 1.801, 1.665, 1.609, 1.484, 1.412, 1.334, 1.195, | |
21339 | & 1.160, 1.166, 1.208, 1.309, 1.356, 1.394, 1.406, 1.419, 1.473, | |
21340 | & 1.540, 1.596, 1.570, 1.533, 1.516, 1.484, 1.471, 1.478, 1.492, | |
21341 | & 1.497, 1.491, 1.479, 1.465, 1.453, 1.449, 1.450, 1.444, 1.428, | |
21342 | & 1.422, 1.406, 1.384, 1.369, 1.364, 1.369, 1.374, 1.388, 1.395/ | |
21343 | * pi- p | |
21344 | DATA (ASIGTO(5,K),K=1,NPOINT) / | |
21345 | & 0.458, 0.540, 0.626, 0.718, 0.819, 0.933, 1.063, 1.208, 1.226, | |
21346 | & 1.436, 1.470, 1.594, 1.708, 1.786, 1.852, 1.836, 1.763, 1.679, | |
21347 | & 1.590, 1.492, 1.445, 1.426, 1.423, 1.433, 1.473, 1.506, 1.547, | |
21348 | & 1.660, 1.671, 1.545, 1.591, 1.687, 1.808, 1.656, 1.582, 1.543, | |
21349 | & 1.562, 1.560, 1.537, 1.540, 1.549, 1.557, 1.557, 1.551, 1.535, | |
21350 | & 1.527, 1.511, 1.510, 1.507, 1.500, 1.491, 1.483, 1.478, 1.468, | |
21351 | & 1.463, 1.435, 1.408, 1.394, 1.384, 1.380, 1.383, 1.393, 1.411/ | |
21352 | * K+ p | |
21353 | DATA (ASIGTO(6,K),K=1,NPOINT) / | |
21354 | & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, | |
21355 | & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, | |
21356 | & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.096, 1.095, | |
21357 | & 1.098, 1.105, 1.111, 1.139, 1.169, 1.209, 1.248, 1.259, 1.268, | |
21358 | & 1.262, 1.257, 1.254, 1.252, 1.250, 1.249, 1.246, 1.244, 1.244, | |
21359 | & 1.243, 1.240, 1.238, 1.237, 1.236, 1.235, 1.235, 1.236, 1.236, | |
21360 | & 1.236, 1.233, 1.238, 1.248, 1.257, 1.272, 1.292, 1.311, 1.336/ | |
21361 | * K- p | |
21362 | DATA (ASIGTO(7,K),K=1,NPOINT) / | |
21363 | & 2.003, 2.002, 2.001, 2.000, 1.999, 1.998, 1.998, 1.997, 1.997, | |
21364 | & 1.996, 1.995, 1.993, 1.990, 1.992, 1.974, 1.912, 1.865, 1.847, | |
21365 | & 1.896, 1.950, 1.827, 1.681, 1.637, 1.616, 1.589, 1.545, 1.543, | |
21366 | & 1.532, 1.603, 1.604, 1.616, 1.658, 1.700, 1.658, 1.595, 1.508, | |
21367 | & 1.493, 1.514, 1.531, 1.523, 1.501, 1.479, 1.474, 1.467, 1.463, | |
21368 | & 1.450, 1.444, 1.435, 1.426, 1.424, 1.423, 1.415, 1.401, 1.396, | |
21369 | & 1.384, 1.364, 1.330, 1.313, 1.310, 1.309, 1.317, 1.329, 1.338/ | |
21370 | * K+ n | |
21371 | DATA (ASIGTO(8,K),K=1,NPOINT) / | |
21372 | & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584, | |
21373 | & 0.631, 0.675, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931, | |
21374 | & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.102, 1.125, 1.147, | |
21375 | & 1.168, 1.187, 1.205, 1.224, 1.248, 1.279, 1.315, 1.324, 1.301, | |
21376 | & 1.285, 1.279, 1.274, 1.273, 1.272, 1.271, 1.267, 1.263, 1.261, | |
21377 | & 1.259, 1.256, 1.252, 1.247, 1.244, 1.241, 1.240, 1.240, 1.240, | |
21378 | & 1.241, 1.243, 1.245, 1.253, 1.265, 1.275, 1.293, 1.314, 1.342/ | |
21379 | * K- n | |
21380 | DATA (ASIGTO(9,K),K=1,NPOINT) / | |
21381 | & 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, | |
21382 | & 1.778, 1.778, 1.778, 1.778, 1.778, 1.779, 1.779, 1.778, 1.773, | |
21383 | & 1.765, 1.746, 1.703, 1.646, 1.561, 1.488, 1.454, 1.437, 1.437, | |
21384 | & 1.458, 1.505, 1.561, 1.588, 1.593, 1.581, 1.551, 1.500, 1.454, | |
21385 | & 1.427, 1.408, 1.390, 1.372, 1.361, 1.356, 1.351, 1.347, 1.343, | |
21386 | & 1.341, 1.340, 1.338, 1.337, 1.335, 1.334, 1.332, 1.331, 1.330, | |
21387 | & 1.330, 1.313, 1.303, 1.288, 1.288, 1.297, 1.305, 1.320, 1.342/ | |
21388 | * Lambda p | |
21389 | DATA (ASIGTO(10,K),K=1,NPOINT) / | |
21390 | & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224, | |
21391 | & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.629, | |
21392 | & 1.599, 1.576, 1.558, 1.543, 1.530, 1.520, 1.512, 1.505, 1.499, | |
21393 | & 1.495, 1.495, 1.497, 1.504, 1.514, 1.525, 1.536, 1.550, 1.567, | |
21394 | & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609, | |
21395 | & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605, | |
21396 | & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/ | |
21397 | * | |
21398 | * elastic cross sections: | |
21399 | * p p | |
21400 | DATA (ASIGEL(1,K),K=1,NPOINT) / | |
21401 | & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255, | |
21402 | & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646, | |
21403 | & 1.577, 1.518, 1.462, 1.420, 1.393, 1.374, 1.360, 1.353, 1.350, | |
21404 | & 1.351, 1.356, 1.362, 1.369, 1.376, 1.384, 1.385, 1.399, 1.397, | |
21405 | & 1.389, 1.385, 1.379, 1.366, 1.358, 1.344, 1.320, 1.294, 1.275, | |
21406 | & 1.260, 1.248, 1.235, 1.219, 1.199, 1.172, 1.144, 1.126, 1.115, | |
21407 | & 1.104, 1.013, 0.962, 0.905, 0.869, 0.845, 0.846, 0.850, 0.868/ | |
21408 | * pbar p | |
21409 | DATA (ASIGEL(2,K),K=1,NPOINT) / | |
21410 | & 1.987, 1.985, 1.983, 1.980, 1.978, 1.975, 1.971, 1.968, 1.963, | |
21411 | & 1.958, 1.951, 1.944, 1.935, 1.925, 1.914, 1.902, 1.889, 1.875, | |
21412 | & 1.859, 1.845, 1.834, 1.817, 1.792, 1.769, 1.754, 1.738, 1.720, | |
21413 | & 1.702, 1.688, 1.676, 1.667, 1.659, 1.652, 1.645, 1.640, 1.636, | |
21414 | & 1.620, 1.591, 1.562, 1.546, 1.540, 1.524, 1.496, 1.475, 1.457, | |
21415 | & 1.429, 1.402, 1.373, 1.344, 1.330, 1.306, 1.294, 1.265, 1.228, | |
21416 | & 1.204, 1.086, 0.977, 0.933, 0.914, 0.850, 0.862, 0.848, 0.845/ | |
21417 | * n p | |
21418 | DATA (ASIGEL(3,K),K=1,NPOINT) / | |
21419 | & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763, | |
21420 | & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115, | |
21421 | & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569, | |
21422 | & 1.544, 1.527, 1.514, 1.504, 1.495, 1.486, 1.476, 1.466, 1.454, | |
21423 | & 1.440, 1.425, 1.409, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304, | |
21424 | & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136, | |
21425 | & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/ | |
21426 | * pi+ p | |
21427 | DATA (ASIGEL(4,K),K=1,NPOINT) / | |
21428 | & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610, | |
21429 | & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118, | |
21430 | & 2.001, 1.875, 1.801, 1.664, 1.610, 1.479, 1.423, 1.299, 1.166, | |
21431 | & 1.097, 1.020, 0.958, 0.914, 1.013, 1.088, 1.153, 1.167, 1.235, | |
21432 | & 1.240, 1.237, 1.202, 1.135, 1.090, 1.026, 0.975, 0.941, 0.904, | |
21433 | & 0.894, 0.884, 0.862, 0.850, 0.845, 0.827, 0.805, 0.789, 0.776, | |
21434 | & 0.763, 0.686, 0.626, 0.562, 0.505, 0.518, 0.525, 0.528, 0.528/ | |
21435 | * pi- p | |
21436 | DATA (ASIGEL(5,K),K=1,NPOINT) / | |
21437 | & 0.266, 0.278, 0.294, 0.320, 0.360, 0.419, 0.503, 0.608, 0.727, | |
21438 | & 0.850, 0.968, 1.071, 1.167, 1.305, 1.369, 1.404, 1.446, 1.217, | |
21439 | & 1.112, 1.071, 1.014, 1.002, 0.996, 1.008, 1.070, 1.126, 1.209, | |
21440 | & 1.300, 1.281, 1.188, 1.156, 1.341, 1.423, 1.314, 1.171, 1.140, | |
21441 | & 1.106, 1.071, 1.011, 1.037, 1.026, 1.024, 0.988, 0.953, 0.895, | |
21442 | & 0.894, 0.880, 0.871, 0.864, 0.853, 0.837, 0.820, 0.809, 0.800, | |
21443 | & 0.782, 0.674, 0.612, 0.530, 0.521, 0.528, 0.524, 0.542, 0.569/ | |
21444 | * K+ p | |
21445 | DATA (ASIGEL(6,K),K=1,NPOINT) / | |
21446 | & 1.064, 1.065, 1.065, 1.066, 1.066, 1.066, 1.066, 1.066, 1.066, | |
21447 | & 1.065, 1.064, 1.063, 1.062, 1.062, 1.062, 1.064, 1.066, 1.070, | |
21448 | & 1.076, 1.082, 1.088, 1.096, 1.103, 1.104, 1.104, 1.102, 1.093, | |
21449 | & 1.087, 1.084, 1.079, 1.075, 1.067, 1.058, 1.040, 1.029, 1.012, | |
21450 | & 1.003, 0.985, 0.935, 0.909, 0.880, 0.846, 0.790, 0.771, 0.759, | |
21451 | & 0.743, 0.718, 0.681, 0.666, 0.645, 0.622, 0.606, 0.594, 0.584, | |
21452 | & 0.575, 0.513, 0.453, 0.403, 0.356, 0.365, 0.389, 0.430, 0.477/ | |
21453 | * K- p | |
21454 | DATA (ASIGEL(7,K),K=1,NPOINT) / | |
21455 | & 1.941, 1.936, 1.931, 1.926, 1.919, 1.912, 1.903, 1.892, 1.878, | |
21456 | & 1.863, 1.844, 1.821, 1.791, 1.755, 1.713, 1.666, 1.615, 1.561, | |
21457 | & 1.533, 1.531, 1.518, 1.511, 1.452, 1.339, 1.265, 1.233, 1.188, | |
21458 | & 1.184, 1.236, 1.316, 1.333, 1.336, 1.333, 1.277, 1.216, 1.077, | |
21459 | & 1.018, 0.912, 0.926, 0.920, 0.910, 0.894, 0.830, 0.825, 0.800, | |
21460 | & 0.788, 0.747, 0.703, 0.707, 0.689, 0.643, 0.633, 0.635, 0.618, | |
21461 | & 0.584, 0.579, 0.461, 0.403, 0.405, 0.399, 0.408, 0.418, 0.413/ | |
21462 | * K+ n | |
21463 | DATA (ASIGEL(8,K),K=1,NPOINT) / | |
21464 | & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584, | |
21465 | & 0.631, 0.676, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931, | |
21466 | & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.103, 1.126, 1.148, | |
21467 | & 1.168, 1.187, 1.205, 1.223, 1.248, 1.282, 1.269, 1.185, 1.111, | |
21468 | & 1.063, 1.031, 0.998, 0.964, 0.928, 0.889, 0.849, 0.814, 0.785, | |
21469 | & 0.760, 0.738, 0.720, 0.703, 0.688, 0.674, 0.660, 0.648, 0.635, | |
21470 | & 0.624, 0.536, 0.473, 0.442, 0.428, 0.428, 0.436, 0.453, 0.477/ | |
21471 | * K- n | |
21472 | DATA (ASIGEL(9,K),K=1,NPOINT) / | |
21473 | & 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, | |
21474 | & 1.613, 1.613, 1.613, 1.612, 1.613, 1.614, 1.614, 1.612, 1.606, | |
21475 | & 1.593, 1.564, 1.498, 1.402, 1.240, 1.071, 0.977, 0.922, 0.914, | |
21476 | & 0.961, 1.077, 1.214, 1.271, 1.290, 1.281, 1.217, 1.096, 0.979, | |
21477 | & 0.896, 0.822, 0.736, 0.655, 0.608, 0.591, 0.580, 0.569, 0.559, | |
21478 | & 0.550, 0.540, 0.531, 0.522, 0.514, 0.507, 0.500, 0.494, 0.489, | |
21479 | & 0.485, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477/ | |
21480 | * Lambda p | |
21481 | DATA (ASIGEL(10,K),K=1,NPOINT) / | |
21482 | & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224, | |
21483 | & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.630, | |
21484 | & 1.600, 1.577, 1.558, 1.542, 1.528, 1.518, 1.510, 1.505, 1.502, | |
21485 | & 1.501, 1.500, 1.499, 1.496, 1.491, 1.485, 1.477, 1.466, 1.454, | |
21486 | & 1.440, 1.425, 1.408, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304, | |
21487 | & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136, | |
21488 | & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/ | |
21489 | ||
21490 | DATA (IDXDAT(K,1),K=1,25) / | |
21491 | & 1, 2, 0, 0, 0, 0, 0, 3, 2, 0, 0,67, 4, 5, 6, 7,10, 2,67, 3, | |
21492 | & 1, 3,45, 8, 9/ | |
21493 | DATA (IDXDAT(K,2),K=1,25) / | |
21494 | & 3, 2, 0, 0, 0, 0, 0, 1, 2, 0, 0,89, 5, 4, 8, 9, 1, 2,89, 1, | |
21495 | & 3, 1,45, 6, 7/ | |
21496 | ||
21497 | DATA LFIRST /.TRUE./ | |
21498 | ||
21499 | IF (LFIRST) THEN | |
21500 | APLABL = LOG10(PLABLO) | |
21501 | APLABH = LOG10(PLABHI) | |
21502 | APTHRE = LOG10(PTHRE) | |
21503 | ADP1 = (APTHRE-APLABL)/DBLE(NPOIN1) | |
21504 | ADP2 = (APLABH-APTHRE)/DBLE(NPOIN2) | |
21505 | DUM0 = ZERO | |
21506 | PHOPLA = PLABHI | |
21507 | PHOELA = SQRT(AAM(1)**2+PHOPLA**2) | |
21508 | ECMS = SQRT(2.0D0*AAM(1)**2+2.0D0*AAM(1)*PHOELA) | |
21509 | IF (MCGENE.EQ.2) THEN | |
21510 | IF (ECMS.LE.SIGECM(1,ISIMAX)) THEN | |
21511 | CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,0) | |
21512 | ELSE | |
21513 | CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1) | |
21514 | ENDIF | |
21515 | ELSE | |
21516 | CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1) | |
21517 | ENDIF | |
21518 | PHOSEL = PHOSTO-PHOSIN | |
21519 | APHOST = LOG10(PHOSTO) | |
21520 | APHOSE = LOG10(PHOSEL) | |
21521 | LFIRST = .FALSE. | |
21522 | ENDIF | |
21523 | STOT = ZERO | |
21524 | SELA = ZERO | |
21525 | PLAB = PL | |
21526 | ECMS = ECM | |
21527 | IF ( (IP.LT.1).OR.((IT.NE.1).AND.(IT.NE.8)) ) THEN | |
21528 | WRITE(LOUT,1000) IP,IT | |
21529 | 1000 FORMAT(1X,'DT_XSHN: cross sections not implemented for ', | |
21530 | & 'proj/target',2I4) | |
21531 | STOP | |
21532 | ENDIF | |
21533 | ||
21534 | IF ((PLAB.LE.ZERO).AND.(ECMS.GT.ZERO)) THEN | |
21535 | ELAB = (ECMS**2-AAM(IP)**2-AAM(IT)**2)/(2.0D0*AAM(IT)) | |
21536 | PLAB = SQRT((ELAB-AAM(IP))*(ELAB+AAM(IP))) | |
21537 | ELSEIF ((PLAB.LE.ZERO).AND.(ECMS.LE.ZERO)) THEN | |
21538 | WRITE(LOUT,1001) PLAB,ECMS | |
21539 | 1001 FORMAT(1X,'DT_XSHN: invalid momentum/cm-energy ',2E15.5) | |
21540 | STOP | |
21541 | ENDIF | |
21542 | ||
21543 | * index of spectrum | |
21544 | IDXP = IP | |
21545 | IF (IP.GT.25) THEN | |
21546 | IF (AAM(IP).GT.ZERO) THEN | |
21547 | IF (ABS(IIBAR(IP)).GT.0) THEN | |
21548 | IDXP = 1 | |
21549 | ELSE | |
21550 | IDXP = 13 | |
21551 | ENDIF | |
21552 | ELSE | |
21553 | IDXP = 7 | |
21554 | ENDIF | |
21555 | ENDIF | |
21556 | IDXT = 1 | |
21557 | IF (IT.EQ.8) IDXT = 2 | |
21558 | IDXS = IDXDAT(IDXP,IDXT) | |
21559 | IF (IDXS.EQ.0) RETURN | |
21560 | ||
21561 | * compute momentum bin indices | |
21562 | IF (PLAB.LT.PLABLO) THEN | |
21563 | IDX0 = 1 | |
21564 | IDX1 = 1 | |
21565 | ELSEIF (PLAB.GE.PLABHI) THEN | |
21566 | IDX0 = NPOINT | |
21567 | IDX1 = NPOINT | |
21568 | ELSE | |
21569 | APLAB = LOG10(PLAB) | |
21570 | IF ((PLAB.GE.PLABLO).AND.(PLAB.LT.PTHRE )) THEN | |
21571 | IDX0 = INT((APLAB-APLABL)/ADP1)+1 | |
21572 | ELSEIF ((PLAB.GE.PTHRE ).AND.(PLAB.LT.PLABHI)) THEN | |
21573 | IDX0 = INT((APLAB-APTHRE)/ADP2)+NPOIN1+1 | |
21574 | ENDIF | |
21575 | IDX1 = IDX0+1 | |
21576 | ENDIF | |
21577 | ||
21578 | * interpolate cross section | |
21579 | IF (IDXS.GT.10) THEN | |
21580 | IDXS1 = IDXS/10 | |
21581 | IDXS2 = IDXS-10*IDXS1 | |
21582 | IF (IDX0.EQ.IDX1) THEN | |
21583 | IF (IDX0.EQ.1) THEN | |
21584 | ASTOT = 0.5D0*(ASIGTO(IDXS1,IDX0)+ASIGTO(IDXS2,IDX0)) | |
21585 | ASELA = 0.5D0*(ASIGEL(IDXS1,IDX0)+ASIGEL(IDXS2,IDX0)) | |
21586 | ELSE | |
21587 | DUM0 = ZERO | |
21588 | CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0) | |
21589 | PHOSEL = PHOSTO-PHOSIN | |
21590 | ASTOT1 = ASIGTO(IDXS1,NPOINT)-APHOST+LOG10(PHOSTO) | |
21591 | ASELA1 = ASIGEL(IDXS1,NPOINT)-APHOSE+LOG10(PHOSEL) | |
21592 | ASTOT2 = ASIGTO(IDXS2,NPOINT)-APHOST+LOG10(PHOSTO) | |
21593 | ASELA2 = ASIGEL(IDXS2,NPOINT)-APHOSE+LOG10(PHOSEL) | |
21594 | ASTOT = 0.5D0*(ASTOT1+ASTOT2) | |
21595 | ASELA = 0.5D0*(ASELA1+ASELA2) | |
21596 | ENDIF | |
21597 | ELSE | |
21598 | FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0)) | |
21599 | ASTOT1 = ASIGTO(IDXS1,IDX0)+ | |
21600 | & FAC*(ASIGTO(IDXS1,IDX1)-ASIGTO(IDXS1,IDX0)) | |
21601 | ASTOT2 = ASIGTO(IDXS2,IDX0)+ | |
21602 | & FAC*(ASIGTO(IDXS2,IDX1)-ASIGTO(IDXS2,IDX0)) | |
21603 | ASTOT = 0.5D0*(ASTOT1+ASTOT2) | |
21604 | ASELA1 = ASIGEL(IDXS1,IDX0)+ | |
21605 | & FAC*(ASIGEL(IDXS1,IDX1)-ASIGEL(IDXS1,IDX0)) | |
21606 | ASELA2 = ASIGEL(IDXS2,IDX0)+ | |
21607 | & FAC*(ASIGEL(IDXS2,IDX1)-ASIGEL(IDXS2,IDX0)) | |
21608 | ASELA = 0.5D0*(ASELA1+ASELA2) | |
21609 | ENDIF | |
21610 | ELSE | |
21611 | IF (IDX0.EQ.IDX1) THEN | |
21612 | IF (IDX0.EQ.1) THEN | |
21613 | ASTOT = ASIGTO(IDXS,IDX0) | |
21614 | ASELA = ASIGEL(IDXS,IDX0) | |
21615 | ELSE | |
21616 | DUM0 = ZERO | |
21617 | CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0) | |
21618 | PHOSEL = PHOSTO-PHOSIN | |
21619 | ASTOT = ASIGTO(IDXS,NPOINT)-APHOST+LOG10(PHOSTO) | |
21620 | ASELA = ASIGEL(IDXS,NPOINT)-APHOSE+LOG10(PHOSEL) | |
21621 | ENDIF | |
21622 | ELSE | |
21623 | FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0)) | |
21624 | ASTOT = ASIGTO(IDXS,IDX0)+ | |
21625 | & FAC*(ASIGTO(IDXS,IDX1)-ASIGTO(IDXS,IDX0)) | |
21626 | ASELA = ASIGEL(IDXS,IDX0)+ | |
21627 | & FAC*(ASIGEL(IDXS,IDX1)-ASIGEL(IDXS,IDX0)) | |
21628 | ENDIF | |
21629 | ENDIF | |
21630 | STOT = 10.0D0**ASTOT | |
21631 | SELA = 10.0D0**ASELA | |
21632 | ||
21633 | RETURN | |
21634 | END | |
21635 | ||
21636 | *$ CREATE DT_SIHNAB.FOR | |
21637 | *COPY DT_SIHNAB | |
21638 | * | |
21639 | *===sihnab===============================================================* | |
21640 | * | |
21641 | SUBROUTINE DT_SIHNAB(IDP,IDT,PLAB,SIGABS) | |
21642 | ||
21643 | ********************************************************************** | |
21644 | * Pion 2-nucleon absorption cross sections. * | |
21645 | * (sigma_tot for pi+ d --> p p, pi- d --> n n * | |
21646 | * taken from Ritchie PRC 28 (1983) 926 ) * | |
21647 | * This version dated 18.05.96 is written by S. Roesler * | |
21648 | ********************************************************************** | |
21649 | ||
21650 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
21651 | SAVE | |
21652 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY3=1.0D-3) | |
21653 | PARAMETER (AMPR = 938.0D0, | |
21654 | & AMPI = 140.0D0, | |
21655 | & AMDE = TWO*AMPR, | |
21656 | & A = -1.2D0, | |
21657 | & B = 3.5D0, | |
21658 | & C = 7.4D0, | |
21659 | & D = 5600.0D0, | |
21660 | & ER = 2136.0D0) | |
21661 | ||
21662 | SIGABS = ZERO | |
21663 | IF ( ((IDP.NE.13).AND.(IDP.NE.14).AND.(IDP.NE.23)) | |
21664 | & .OR.((IDT.NE.1).AND.(IDT.NE.8)) ) RETURN | |
21665 | PTOT = PLAB*1.0D3 | |
21666 | EKIN = SQRT(AMPI**2+PTOT**2)-AMPI | |
21667 | IF ((EKIN.LT.TINY3).OR.(EKIN.GT.400.0D0)) RETURN | |
21668 | ECM = SQRT( (AMPI+AMDE)**2+TWO*EKIN*AMDE ) | |
21669 | SIGABS = A+B/SQRT(EKIN)+C*1.0D4/((ECM-ER)**2+D) | |
21670 | * approximate 3N-abs., I=1-abs. etc. | |
21671 | SIGABS = SIGABS/0.40D0 | |
21672 | * pi0-absorption (rough approximation!!) | |
21673 | IF (IDP.EQ.23) SIGABS = 0.5D0*SIGABS | |
21674 | ||
21675 | RETURN | |
21676 | END | |
21677 | ||
21678 | *$ CREATE DT_SIGEMU.FOR | |
21679 | *COPY DT_SIGEMU | |
21680 | * | |
21681 | *===sigemu=============================================================* | |
21682 | * | |
21683 | SUBROUTINE DT_SIGEMU | |
21684 | ||
21685 | ************************************************************************ | |
21686 | * Combined cross section for target compounds. * | |
21687 | * This version dated 6.4.98 is written by S. Roesler * | |
21688 | ************************************************************************ | |
21689 | ||
21690 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
21691 | SAVE | |
21692 | PARAMETER ( LINP = 10 , | |
21693 | & LOUT = 6 , | |
21694 | & LDAT = 9 ) | |
21695 | PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10, | |
21696 | & OHALF=0.5D0,ONE=1.0D0) | |
21697 | ||
21698 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
21699 | * Glauber formalism: cross sections | |
21700 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
21701 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
21702 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
21703 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
21704 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
21705 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
21706 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
21707 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
21708 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
21709 | & BSLOPE,NEBINI,NQBINI | |
21710 | * emulsion treatment | |
21711 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
21712 | & NCOMPO,IEMUL | |
21713 | * nucleon-nucleon event-generator | |
21714 | CHARACTER*8 CMODEL | |
21715 | LOGICAL LPHOIN | |
21716 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
21717 | ||
21718 | IF (MCGENE.NE.4) THEN | |
21719 | WRITE(LOUT,'(A)') ' DT_SIGEMU: Combined cross sections' | |
21720 | WRITE(LOUT,'(15X,A)') '-----------------------' | |
21721 | ENDIF | |
21722 | DO 1 IE=1,NEBINI | |
21723 | DO 2 IQ=1,NQBINI | |
21724 | SIGTOT = ZERO | |
21725 | SIGELA = ZERO | |
21726 | SIGQEP = ZERO | |
21727 | SIGQET = ZERO | |
21728 | SIGQE2 = ZERO | |
21729 | SIGPRO = ZERO | |
21730 | SIGDEL = ZERO | |
21731 | SIGDQE = ZERO | |
21732 | ERRTOT = ZERO | |
21733 | ERRELA = ZERO | |
21734 | ERRQEP = ZERO | |
21735 | ERRQET = ZERO | |
21736 | ERRQE2 = ZERO | |
21737 | ERRPRO = ZERO | |
21738 | ERRDEL = ZERO | |
21739 | ERRDQE = ZERO | |
21740 | IF (NCOMPO.GT.0) THEN | |
21741 | DO 3 IC=1,NCOMPO | |
21742 | SIGTOT = SIGTOT+EMUFRA(IC)*XSTOT(IE,IQ,IC) | |
21743 | SIGELA = SIGELA+EMUFRA(IC)*XSELA(IE,IQ,IC) | |
21744 | SIGQEP = SIGQEP+EMUFRA(IC)*XSQEP(IE,IQ,IC) | |
21745 | SIGQET = SIGQET+EMUFRA(IC)*XSQET(IE,IQ,IC) | |
21746 | SIGQE2 = SIGQE2+EMUFRA(IC)*XSQE2(IE,IQ,IC) | |
21747 | SIGPRO = SIGPRO+EMUFRA(IC)*XSPRO(IE,IQ,IC) | |
21748 | SIGDEL = SIGDEL+EMUFRA(IC)*XSDEL(IE,IQ,IC) | |
21749 | SIGDQE = SIGDQE+EMUFRA(IC)*XSDQE(IE,IQ,IC) | |
21750 | ERRTOT = ERRTOT+XETOT(IE,IQ,IC)**2 | |
21751 | ERRELA = ERRELA+XEELA(IE,IQ,IC)**2 | |
21752 | ERRQEP = ERRQEP+XEQEP(IE,IQ,IC)**2 | |
21753 | ERRQET = ERRQET+XEQET(IE,IQ,IC)**2 | |
21754 | ERRQE2 = ERRQE2+XEQE2(IE,IQ,IC)**2 | |
21755 | ERRPRO = ERRPRO+XEPRO(IE,IQ,IC)**2 | |
21756 | ERRDEL = ERRDEL+XEDEL(IE,IQ,IC)**2 | |
21757 | ERRDQE = ERRDQE+XEDQE(IE,IQ,IC)**2 | |
21758 | 3 CONTINUE | |
21759 | ERRTOT = SQRT(ERRTOT) | |
21760 | ERRELA = SQRT(ERRELA) | |
21761 | ERRQEP = SQRT(ERRQEP) | |
21762 | ERRQET = SQRT(ERRQET) | |
21763 | ERRQE2 = SQRT(ERRQE2) | |
21764 | ERRPRO = SQRT(ERRPRO) | |
21765 | ERRDEL = SQRT(ERRDEL) | |
21766 | ERRDQE = SQRT(ERRDQE) | |
21767 | ELSE | |
21768 | SIGTOT = XSTOT(IE,IQ,1) | |
21769 | SIGELA = XSELA(IE,IQ,1) | |
21770 | SIGQEP = XSQEP(IE,IQ,1) | |
21771 | SIGQET = XSQET(IE,IQ,1) | |
21772 | SIGQE2 = XSQE2(IE,IQ,1) | |
21773 | SIGPRO = XSPRO(IE,IQ,1) | |
21774 | SIGDEL = XSDEL(IE,IQ,1) | |
21775 | SIGDQE = XSDQE(IE,IQ,1) | |
21776 | ERRTOT = XETOT(IE,IQ,1) | |
21777 | ERRELA = XEELA(IE,IQ,1) | |
21778 | ERRQEP = XEQEP(IE,IQ,1) | |
21779 | ERRQET = XEQET(IE,IQ,1) | |
21780 | ERRQE2 = XEQE2(IE,IQ,1) | |
21781 | ERRPRO = XEPRO(IE,IQ,1) | |
21782 | ERRDEL = XEDEL(IE,IQ,1) | |
21783 | ERRDQE = XEDQE(IE,IQ,1) | |
21784 | ENDIF | |
21785 | IF (MCGENE.NE.4) THEN | |
21786 | WRITE(LOUT,1000) ECMNN(IE),Q2G(IQ) | |
21787 | 1000 FORMAT(/,1X,'E_cm =',F9.1,' GeV Q^2 =',F6.1,' GeV^2 :',/) | |
21788 | WRITE(LOUT,1001) SIGTOT,ERRTOT | |
21789 | 1001 FORMAT(1X,'total',32X,F10.4,' +-',F11.5,' mb') | |
21790 | WRITE(LOUT,1002) SIGELA,ERRELA | |
21791 | 1002 FORMAT(1X,'elastic',30X,F10.4,' +-',F11.5,' mb') | |
21792 | WRITE(LOUT,1003) SIGQEP,ERRQEP | |
21793 | 1003 FORMAT(1X,'quasi-elastic (A+B-->A+X)',12X,F10.4,' +-', | |
21794 | & F11.5,' mb') | |
21795 | WRITE(LOUT,1004) SIGQET,ERRQET | |
21796 | 1004 FORMAT(1X,'quasi-elastic (A+B-->X+B)',12X,F10.4,' +-', | |
21797 | & F11.5,' mb') | |
21798 | WRITE(LOUT,1005) SIGQE2,ERRQE2 | |
21799 | 1005 FORMAT(1X,'quasi-elastic (A+B-->X, excl. 2-4)',3X,F10.4, | |
21800 | & ' +-',F11.5,' mb') | |
21801 | WRITE(LOUT,1006) SIGPRO,ERRPRO | |
21802 | 1006 FORMAT(1X,'production',27X,F10.4,' +-',F11.5,' mb') | |
21803 | WRITE(LOUT,1007) SIGDEL,ERRDEL | |
21804 | 1007 FORMAT(1X,'diff-el ',27X,F10.4,' +-',F11.5,' mb') | |
21805 | WRITE(LOUT,1008) SIGDQE,ERRDQE | |
21806 | 1008 FORMAT(1X,'diff-qel ',27X,F10.4,' +-',F11.5,' mb') | |
21807 | ENDIF | |
21808 | ||
21809 | 2 CONTINUE | |
21810 | 1 CONTINUE | |
21811 | ||
21812 | RETURN | |
21813 | END | |
21814 | ||
21815 | *$ CREATE DT_SIGGA.FOR | |
21816 | *COPY DT_SIGGA | |
21817 | * | |
21818 | *===sigga==============================================================* | |
21819 | * | |
21820 | SUBROUTINE DT_SIGGA(NTI,XI,Q2I,ECMI,XNUI,STOT,ETOT,SIN,EIN,STOT0) | |
21821 | ||
21822 | ************************************************************************ | |
21823 | * Total/inelastic photon-nucleus cross sections. * | |
21824 | * !!!! Overwrites SHMAKI-initialization. Do not use it during * | |
21825 | * production runs !!!! * | |
21826 | * This version dated 27.03.96 is written by S. Roesler * | |
21827 | ************************************************************************ | |
21828 | ||
21829 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
21830 | SAVE | |
21831 | PARAMETER ( LINP = 10 , | |
21832 | & LOUT = 6 , | |
21833 | & LDAT = 9 ) | |
21834 | PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10, | |
21835 | & OHALF=0.5D0,ONE=1.0D0) | |
21836 | PARAMETER (AMPROT = 0.938D0) | |
21837 | ||
21838 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
21839 | * Glauber formalism: cross sections | |
21840 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
21841 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
21842 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
21843 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
21844 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
21845 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
21846 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
21847 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
21848 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
21849 | & BSLOPE,NEBINI,NQBINI | |
21850 | ||
21851 | NT = NTI | |
21852 | X = XI | |
21853 | Q2 = Q2I | |
21854 | ECM = ECMI | |
21855 | XNU = XNUI | |
21856 | IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO)) | |
21857 | & ECM = SQRT(AMPROT**2-Q2+2.0D0*XNUI*AMPROT) | |
21858 | CALL DT_XSGLAU(1,NT,7,X,Q2,ECM,1,1,-1) | |
21859 | STOT = XSTOT(1,1,1) | |
21860 | ETOT = XETOT(1,1,1) | |
21861 | SIN = XSPRO(1,1,1) | |
21862 | EIN = XEPRO(1,1,1) | |
21863 | ||
21864 | RETURN | |
21865 | END | |
21866 | ||
21867 | *$ CREATE DT_SIGGAT.FOR | |
21868 | *COPY DT_SIGGAT | |
21869 | * | |
21870 | *===siggat=============================================================* | |
21871 | * | |
21872 | SUBROUTINE DT_SIGGAT(Q2I,ECMI,STOT,NT) | |
21873 | ||
21874 | ************************************************************************ | |
21875 | * Total/inelastic photon-nucleus cross sections. * | |
21876 | * Uses pre-tabulated cross section. * | |
21877 | * This version dated 29.07.96 is written by S. Roesler * | |
21878 | ************************************************************************ | |
21879 | ||
21880 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
21881 | SAVE | |
21882 | PARAMETER ( LINP = 10 , | |
21883 | & LOUT = 6 , | |
21884 | & LDAT = 9 ) | |
21885 | PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14, | |
21886 | & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0) | |
21887 | ||
21888 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
21889 | * Glauber formalism: cross sections | |
21890 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
21891 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
21892 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
21893 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
21894 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
21895 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
21896 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
21897 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
21898 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
21899 | & BSLOPE,NEBINI,NQBINI | |
21900 | ||
21901 | NTARG = ABS(NT) | |
21902 | I1 = 1 | |
21903 | I2 = 1 | |
21904 | RATE = ONE | |
21905 | IF (NEBINI.GT.1) THEN | |
21906 | IF (ECMI.GE.ECMNN(NEBINI)) THEN | |
21907 | I1 = NEBINI | |
21908 | I2 = NEBINI | |
21909 | RATE = ONE | |
21910 | ELSEIF (ECMI.GT.ECMNN(1)) THEN | |
21911 | DO 1 I=2,NEBINI | |
21912 | IF (ECMI.LT.ECMNN(I)) THEN | |
21913 | I1 = I-1 | |
21914 | I2 = I | |
21915 | RATE = (ECMI-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1)) | |
21916 | GOTO 2 | |
21917 | ENDIF | |
21918 | 1 CONTINUE | |
21919 | 2 CONTINUE | |
21920 | ENDIF | |
21921 | ENDIF | |
21922 | J1 = 1 | |
21923 | J2 = 1 | |
21924 | RATQ = ONE | |
21925 | IF (NQBINI.GT.1) THEN | |
21926 | IF (Q2I.GE.Q2G(NQBINI)) THEN | |
21927 | J1 = NQBINI | |
21928 | J2 = NQBINI | |
21929 | RATQ = ONE | |
21930 | ELSEIF (Q2I.GT.Q2G(1)) THEN | |
21931 | DO 3 I=2,NQBINI | |
21932 | IF (Q2I.LT.Q2G(I)) THEN | |
21933 | J1 = I-1 | |
21934 | J2 = I | |
21935 | RATQ = LOG10( Q2I/MAX(Q2G(J1),TINY14))/ | |
21936 | & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14)) | |
21937 | C RATQ = (Q2I-Q2G(J1))/(Q2G(J2)-Q2G(J1)) | |
21938 | GOTO 4 | |
21939 | ENDIF | |
21940 | 3 CONTINUE | |
21941 | 4 CONTINUE | |
21942 | ENDIF | |
21943 | ENDIF | |
21944 | ||
21945 | STOT = XSTOT(I1,J1,NTARG)+ | |
21946 | & RATE*(XSTOT(I2,J1,NTARG)-XSTOT(I1,J1,NTARG))+ | |
21947 | & RATQ*(XSTOT(I1,J2,NTARG)-XSTOT(I1,J1,NTARG))+ | |
21948 | & RATE*RATQ*(XSTOT(I2,J2,NTARG)-XSTOT(I1,J2,NTARG)+ | |
21949 | & XSTOT(I1,J1,NTARG)-XSTOT(I2,J1,NTARG)) | |
21950 | ||
21951 | RETURN | |
21952 | END | |
21953 | ||
21954 | *$ CREATE DT_SANO.FOR | |
21955 | *COPY DT_SANO | |
21956 | * | |
21957 | *===sigano=============================================================* | |
21958 | * | |
21959 | DOUBLE PRECISION FUNCTION DT_SANO(ECM) | |
21960 | ||
21961 | ************************************************************************ | |
21962 | * This version dated 31.07.96 is written by S. Roesler * | |
21963 | ************************************************************************ | |
21964 | ||
21965 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
21966 | SAVE | |
21967 | PARAMETER ( LINP = 10 , | |
21968 | & LOUT = 6 , | |
21969 | & LDAT = 9 ) | |
21970 | PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14, | |
21971 | & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0) | |
21972 | PARAMETER (NE = 8) | |
21973 | ||
21974 | * VDM parameter for photon-nucleus interactions | |
21975 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
21976 | * properties of interacting particles | |
21977 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
21978 | ||
21979 | DIMENSION ECMANO(NE),FRAANO(NE),SIGHRD(NE) | |
21980 | DATA ECMANO / | |
21981 | & 0.200D+02,0.500D+02,0.100D+03,0.200D+03,0.500D+03, | |
21982 | & 0.100D+04,0.200D+04,0.500D+04 | |
21983 | & / | |
21984 | * fixed cut (3 GeV/c) | |
21985 | DATA FRAANO / | |
21986 | & 0.085D+00,0.114D+00,0.105D+00,0.091D+00,0.073D+00, | |
21987 | & 0.062D+00,0.054D+00,0.042D+00 | |
21988 | & / | |
21989 | DATA SIGHRD / | |
21990 | & 4.0099D-04,3.3104D-03,1.1905D-02,3.6435D-02,1.3493D-01, | |
21991 | & 3.3086D-01,7.6255D-01,2.1319D+00 | |
21992 | & / | |
21993 | * running cut (based on obsolete Phojet-caluclations, bugs..) | |
21994 | C DATA FRAANO / | |
21995 | C & 0.251E+00,0.313E+00,0.279E+00,0.239E+00,0.186E+00, | |
21996 | C & 0.167E+00,0.150E+00,0.131E+00 | |
21997 | C & / | |
21998 | C DATA SIGHRD / | |
21999 | C & 6.6569E-04,4.4949E-03,1.4837E-02,4.1466E-02,1.5071E-01, | |
22000 | C & 2.5736E-01,4.5593E-01,8.2550E-01 | |
22001 | C & / | |
22002 | ||
22003 | DT_SANO = ZERO | |
22004 | IF ((ISHAD(2).NE.1).OR.(IJPROJ.NE.7)) RETURN | |
22005 | J1 = 0 | |
22006 | J2 = 0 | |
22007 | RATE = ONE | |
22008 | IF (ECM.GE.ECMANO(NE)) THEN | |
22009 | J1 = NE | |
22010 | J2 = NE | |
22011 | ELSEIF (ECM.GT.ECMANO(1)) THEN | |
22012 | DO 1 IE=2,NE | |
22013 | IF (ECM.LT.ECMANO(IE)) THEN | |
22014 | J1 = IE-1 | |
22015 | J2 = IE | |
22016 | RATE = LOG10(ECM/ECMANO(J1))/LOG10(ECMANO(J2)/ECMANO(J1)) | |
22017 | GOTO 2 | |
22018 | ENDIF | |
22019 | 1 CONTINUE | |
22020 | 2 CONTINUE | |
22021 | ENDIF | |
22022 | IF ((J1.GT.0).AND.(J2.GT.0)) THEN | |
22023 | AFRA1 = LOG10(MAX(FRAANO(J1)*SIGHRD(J1),TINY14)) | |
22024 | AFRA2 = LOG10(MAX(FRAANO(J2)*SIGHRD(J2),TINY14)) | |
22025 | DT_SANO = 10.0D0**(AFRA1+RATE*(AFRA2-AFRA1)) | |
22026 | ENDIF | |
22027 | ||
22028 | RETURN | |
22029 | END | |
22030 | ||
22031 | *$ CREATE DT_SIGGP.FOR | |
22032 | *COPY DT_SIGGP | |
22033 | * | |
22034 | *===siggp==============================================================* | |
22035 | * | |
22036 | SUBROUTINE DT_SIGGP(XI,Q2I,ECMI,XNUI,STOT,SINE,SDIR) | |
22037 | ||
22038 | ************************************************************************ | |
22039 | * Total/inelastic photon-nucleon cross sections. * | |
22040 | * This version dated 30.04.96 is written by S. Roesler * | |
22041 | ************************************************************************ | |
22042 | ||
22043 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
22044 | SAVE | |
22045 | PARAMETER ( LINP = 10 , | |
22046 | & LOUT = 6 , | |
22047 | & LDAT = 9 ) | |
22048 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) | |
22049 | PARAMETER (TWOPI = 6.283185307179586476925286766559D+00, | |
22050 | & PI = TWOPI/TWO, | |
22051 | & GEV2MB = 0.38938D0, | |
22052 | & ALPHEM = ONE/137.0D0) | |
22053 | ||
22054 | * particle properties (BAMJET index convention) | |
22055 | CHARACTER*8 ANAME | |
22056 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
22057 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
22058 | * VDM parameter for photon-nucleus interactions | |
22059 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
22060 | ||
22061 | **PHOJET105a | |
22062 | C CHARACTER*8 MDLNA | |
22063 | C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100) | |
22064 | C PARAMETER (IEETAB=10) | |
22065 | C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX | |
22066 | **PHOJET110 | |
22067 | C model switches and parameters | |
22068 | CHARACTER*8 MDLNA | |
22069 | INTEGER ISWMDL,IPAMDL | |
22070 | DOUBLE PRECISION PARMDL | |
22071 | COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400) | |
22072 | C energy-interpolation table | |
22073 | INTEGER IEETA2 | |
22074 | PARAMETER ( IEETA2 = 20 ) | |
22075 | INTEGER ISIMAX | |
22076 | DOUBLE PRECISION SIGTAB,SIGECM | |
22077 | COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX | |
22078 | ** | |
22079 | ||
22080 | C PARAMETER (NPOINT=80) | |
22081 | PARAMETER (NPOINT=16) | |
22082 | DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT) | |
22083 | ||
22084 | STOT = ZERO | |
22085 | SINE = ZERO | |
22086 | SDIR = ZERO | |
22087 | ||
22088 | W2 = ECMI**2 | |
22089 | IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO)) | |
22090 | & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1) | |
22091 | Q2 = Q2I | |
22092 | X = XI | |
22093 | * photoprod. | |
22094 | IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN | |
22095 | Q2 = 0.0001D0 | |
22096 | X = Q2/(W2+Q2-AAM(1)**2) | |
22097 | * DIS | |
22098 | ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN | |
22099 | X = Q2/(W2+Q2-AAM(1)**2) | |
22100 | ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN | |
22101 | Q2 = (W2-AAM(1)**2)*X/(ONE-X) | |
22102 | ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN | |
22103 | W2 = Q2*(ONE-X)/X+AAM(1)**2 | |
22104 | ELSE | |
22105 | WRITE(LOUT,*) 'SIGGP: inconsistent input ',W2,Q2,X | |
22106 | STOP | |
22107 | ENDIF | |
22108 | ECM = SQRT(W2) | |
22109 | ||
22110 | IF (MODEGA.EQ.1) THEN | |
22111 | SCALE = SQRT(Q2) | |
22112 | CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2, | |
22113 | & IDPDF) | |
22114 | C W = SQRT(W2) | |
22115 | C ALLMF2 = PHO_ALLM97(Q2,W) | |
22116 | C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2 | |
22117 | STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB | |
22118 | SINE = ZERO | |
22119 | SDIR = ZERO | |
22120 | ELSEIF (MODEGA.EQ.2) THEN | |
22121 | IF (INTRGE(1).EQ.1) THEN | |
22122 | AMLO2 = (3.0D0*AAM(13))**2 | |
22123 | ELSEIF (INTRGE(1).EQ.2) THEN | |
22124 | AMLO2 = AAM(33)**2 | |
22125 | ELSE | |
22126 | AMLO2 = AAM(96)**2 | |
22127 | ENDIF | |
22128 | IF (INTRGE(2).EQ.1) THEN | |
22129 | AMHI2 = W2/TWO | |
22130 | ELSEIF (INTRGE(2).EQ.2) THEN | |
22131 | AMHI2 = W2/4.0D0 | |
22132 | ELSE | |
22133 | AMHI2 = W2 | |
22134 | ENDIF | |
22135 | AMHI20 = (ECM-AAM(1))**2 | |
22136 | IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20 | |
22137 | XAMLO = LOG( AMLO2+Q2 ) | |
22138 | XAMHI = LOG( AMHI2+Q2 ) | |
22139 | **PHOJET105a | |
22140 | C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT) | |
22141 | **PHOJET112 | |
22142 | CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT) | |
22143 | ** | |
22144 | SUM = ZERO | |
22145 | DO 1 J=1,NPOINT | |
22146 | AM2 = EXP(ABSZX(J))-Q2 | |
22147 | IF (AM2.LT.16.0D0) THEN | |
22148 | R = TWO | |
22149 | ELSEIF ((AM2.GE.16.0D0).AND.(AM2.LT.121.0D0)) THEN | |
22150 | R = 10.0D0/3.0D0 | |
22151 | ELSE | |
22152 | R = 11.0D0/3.0D0 | |
22153 | ENDIF | |
22154 | C FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) ) | |
22155 | FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) ) | |
22156 | & * (ONE+EPSPOL*Q2/AM2) | |
22157 | SUM = SUM+WEIGHT(J)*FAC | |
22158 | 1 CONTINUE | |
22159 | SINE = SUM | |
22160 | SDIR = DT_SIGVP(X,Q2) | |
22161 | STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*SDIR | |
22162 | SDIR = SDIR/(0.588D0+RL2+Q2) | |
22163 | C STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*DT_SIGVP(X,Q2) | |
22164 | ELSEIF (MODEGA.EQ.3) THEN | |
22165 | CALL DT_SIGGA(1,XI,Q2I,ECMI,ZERO,STOT,ETOT,SINE,EINE,DUM) | |
22166 | ELSEIF (MODEGA.EQ.4) THEN | |
22167 | * load cross sections from PHOJET interpolation table | |
22168 | IP = 1 | |
22169 | IF(ECM.LE.SIGECM(IP,1)) THEN | |
22170 | I1 = 1 | |
22171 | I2 = 1 | |
22172 | ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN | |
22173 | DO 2 I=2,ISIMAX | |
22174 | IF (ECM.LE.SIGECM(IP,I)) GOTO 3 | |
22175 | 2 CONTINUE | |
22176 | 3 CONTINUE | |
22177 | I1 = I-1 | |
22178 | I2 = I | |
22179 | ELSE | |
22180 | WRITE(LOUT,'(/1X,A,2E12.3)') | |
22181 | & 'SIGGP:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX) | |
22182 | I1 = ISIMAX | |
22183 | I2 = ISIMAX | |
22184 | ENDIF | |
22185 | FAC2 = ZERO | |
22186 | IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1)) | |
22187 | & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1)) | |
22188 | FAC1 = ONE-FAC2 | |
22189 | * cross section dependence on photon virtuality | |
22190 | FSUP1 = ZERO | |
22191 | DO 4 I=1,3 | |
22192 | FSUP1 = FSUP1+PARMDL(26+I)*(1.D0+Q2/(4.D0*PARMDL(30+I))) | |
22193 | & /(1.D0+Q2/PARMDL(30+I))**2 | |
22194 | 4 CONTINUE | |
22195 | FSUP1 = FSUP1+PARMDL(30)/(1.D0+Q2/PARMDL(34)) | |
22196 | FAC1 = FAC1*FSUP1 | |
22197 | FAC2 = FAC2*FSUP1 | |
22198 | FSUP2 = 1.0D0 | |
22199 | STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1) | |
22200 | SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1) | |
22201 | SDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1) | |
22202 | **re: | |
22203 | STOT = STOT-SDIR | |
22204 | ** | |
22205 | SDIR = SDIR/(FSUP1*FSUP2) | |
22206 | **re: | |
22207 | STOT = STOT+SDIR | |
22208 | ** | |
22209 | ENDIF | |
22210 | ||
22211 | RETURN | |
22212 | END | |
22213 | ||
22214 | *$ CREATE DT_SIGVEL.FOR | |
22215 | *COPY DT_SIGVEL | |
22216 | * | |
22217 | *===sigvel=============================================================* | |
22218 | * | |
22219 | SUBROUTINE DT_SIGVEL(XI,Q2I,ECMI,XNUI,IDXV,SVEL,SIG1,SIG2) | |
22220 | ||
22221 | ************************************************************************ | |
22222 | * Cross section for elastic vector meson production * | |
22223 | * This version dated 10.05.96 is written by S. Roesler * | |
22224 | ************************************************************************ | |
22225 | ||
22226 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
22227 | SAVE | |
22228 | PARAMETER ( LINP = 10 , | |
22229 | & LOUT = 6 , | |
22230 | & LDAT = 9 ) | |
22231 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) | |
22232 | PARAMETER (TWOPI = 6.283185307179586476925286766559D+00, | |
22233 | & PI = TWOPI/TWO, | |
22234 | & GEV2MB = 0.38938D0, | |
22235 | & ALPHEM = ONE/137.0D0) | |
22236 | ||
22237 | * particle properties (BAMJET index convention) | |
22238 | CHARACTER*8 ANAME | |
22239 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
22240 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
22241 | * VDM parameter for photon-nucleus interactions | |
22242 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
22243 | ||
22244 | W2 = ECMI**2 | |
22245 | IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO)) | |
22246 | & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1) | |
22247 | Q2 = Q2I | |
22248 | X = XI | |
22249 | * photoprod. | |
22250 | IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN | |
22251 | Q2 = 0.0001D0 | |
22252 | X = Q2/(W2+Q2-AAM(1)**2) | |
22253 | * DIS | |
22254 | ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN | |
22255 | X = Q2/(W2+Q2-AAM(1)**2) | |
22256 | ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN | |
22257 | Q2 = (W2-AAM(1)**2)*X/(ONE-X) | |
22258 | ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN | |
22259 | W2 = Q2*(ONE-X)/X+AAM(1)**2 | |
22260 | ELSE | |
22261 | WRITE(LOUT,*) 'SIGVEL: inconsistent input ',W2,Q2,X | |
22262 | STOP | |
22263 | ENDIF | |
22264 | ECM = SQRT(W2) | |
22265 | ||
22266 | AMV = AAM(IDXV) | |
22267 | AMV2 = AMV**2 | |
22268 | ||
22269 | BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2) | |
22270 | & +0.25D0*LOG(W2/(AMV2+Q2)))*GEV2MB | |
22271 | ROSH = 0.1D0 | |
22272 | STOVP = DT_SIGVP(X,Q2)/(AMV2+Q2+RL2) | |
22273 | SELVP = STOVP**2*(ONE+ROSH**2)/(8.0D0*TWOPI*BSLOPE) | |
22274 | ||
22275 | IF (IDXV.EQ.33) THEN | |
22276 | COUPL = 0.00365D0 | |
22277 | ELSE | |
22278 | STOP | |
22279 | ENDIF | |
22280 | SIG1 = (AMV2/(AMV2+Q2))**2 * (ONE+EPSPOL*Q2/AMV2) | |
22281 | SIG2 = SELVP | |
22282 | SVEL = COUPL * (AMV2/(AMV2+Q2))**2 | |
22283 | & * (ONE+EPSPOL*Q2/AMV2) * SELVP | |
22284 | ||
22285 | RETURN | |
22286 | END | |
22287 | ||
22288 | *$ CREATE DT_SIGVP.FOR | |
22289 | *COPY DT_SIGVP | |
22290 | * | |
22291 | *===sigvp==============================================================* | |
22292 | * | |
22293 | DOUBLE PRECISION FUNCTION DT_SIGVP(XI,Q2I) | |
22294 | ||
22295 | ************************************************************************ | |
22296 | * sigma_Vp * | |
22297 | ************************************************************************ | |
22298 | ||
22299 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
22300 | SAVE | |
22301 | ||
22302 | PARAMETER ( LINP = 10 , | |
22303 | & LOUT = 6 , | |
22304 | & LDAT = 9 ) | |
22305 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) | |
22306 | PARAMETER (TWOPI = 6.283185307179586476925286766559D+00, | |
22307 | & PI = TWOPI/TWO, | |
22308 | & GEV2MB = 0.38938D0, | |
22309 | & AMPROT = 0.938D0, | |
22310 | & ALPHEM = ONE/137.0D0) | |
22311 | * VDM parameter for photon-nucleus interactions | |
22312 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
22313 | ||
22314 | X = XI | |
22315 | Q2 = Q2I | |
22316 | IF (XI.LE.ZERO) X = 0.0001D0 | |
22317 | IF (Q2I.LE.ZERO) Q2 = 0.0001D0 | |
22318 | ||
22319 | ECM = SQRT( Q2*(ONE-X)/X+AMPROT**2 ) | |
22320 | ||
22321 | SCALE = SQRT(Q2) | |
22322 | IF (MODEGA.EQ.1) THEN | |
22323 | CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2, | |
22324 | & IDPDF) | |
22325 | C W = ECM | |
22326 | C ALLMF2 = PHO_ALLM97(Q2,W) | |
22327 | C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2 | |
22328 | C STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB | |
22329 | C DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2)) | |
22330 | DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))*GEV2MB | |
22331 | ELSEIF (MODEGA.EQ.4) THEN | |
22332 | CALL DT_SIGGP(X,Q2,ECM,DUM1,STOT,DUM2,DUM3) | |
22333 | C F2 = Q2*(ONE-X)/(TWOPI**2*ALPHEM*GEV2MB) * STOT | |
22334 | DT_SIGVP = 3.0D0*PI/(ALPHEM*DT_RRM2(X,Q2)) * STOT | |
22335 | ELSE | |
22336 | STOP ' DT_SIGVP: F2 not defined for this MODEGA !' | |
22337 | ENDIF | |
22338 | ||
22339 | RETURN | |
22340 | ||
22341 | END | |
22342 | ||
22343 | *$ CREATE DT_RRM2.FOR | |
22344 | *COPY DT_RRM2 | |
22345 | * | |
22346 | *===RRM2===============================================================* | |
22347 | * | |
22348 | DOUBLE PRECISION FUNCTION DT_RRM2(X,Q2) | |
22349 | ||
22350 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
22351 | SAVE | |
22352 | PARAMETER ( LINP = 10 , | |
22353 | & LOUT = 6 , | |
22354 | & LDAT = 9 ) | |
22355 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) | |
22356 | PARAMETER (TWOPI = 6.283185307179586476925286766559D+00, | |
22357 | & PI = TWOPI/TWO, | |
22358 | & GEV2MB = 0.38938D0) | |
22359 | ||
22360 | * particle properties (BAMJET index convention) | |
22361 | CHARACTER*8 ANAME | |
22362 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
22363 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
22364 | * VDM parameter for photon-nucleus interactions | |
22365 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
22366 | ||
22367 | S = Q2*(ONE-X)/X+AAM(1)**2 | |
22368 | ECM = SQRT(S) | |
22369 | ||
22370 | IF (INTRGE(1).EQ.1) THEN | |
22371 | AMLO2 = (3.0D0*AAM(13))**2 | |
22372 | ELSEIF (INTRGE(1).EQ.2) THEN | |
22373 | AMLO2 = AAM(33)**2 | |
22374 | ELSE | |
22375 | AMLO2 = AAM(96)**2 | |
22376 | ENDIF | |
22377 | IF (INTRGE(2).EQ.1) THEN | |
22378 | AMHI2 = S/TWO | |
22379 | ELSEIF (INTRGE(2).EQ.2) THEN | |
22380 | AMHI2 = S/4.0D0 | |
22381 | ELSE | |
22382 | AMHI2 = S | |
22383 | ENDIF | |
22384 | AMHI20 = (ECM-AAM(1))**2 | |
22385 | IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20 | |
22386 | ||
22387 | AM1C2 = 16.0D0 | |
22388 | AM2C2 = 121.0D0 | |
22389 | IF (AMHI2.LE.AM1C2) THEN | |
22390 | DT_RRM2 = TWO*DT_RM2(AMLO2,AMHI2,Q2) | |
22391 | ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN | |
22392 | DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+ | |
22393 | & 10.0D0/3.0D0*DT_RM2(AM1C2,AMHI2,Q2) | |
22394 | ELSE | |
22395 | DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+ | |
22396 | & 10.0D0/3.0D0*DT_RM2(AM1C2,AM2C2,Q2)+ | |
22397 | & 11.0D0/3.0D0*DT_RM2(AM2C2,AMHI2,Q2) | |
22398 | ENDIF | |
22399 | ||
22400 | RETURN | |
22401 | END | |
22402 | ||
22403 | *$ CREATE DT_RM2.FOR | |
22404 | *COPY DT_RM2 | |
22405 | * | |
22406 | *===RM2================================================================* | |
22407 | * | |
22408 | DOUBLE PRECISION FUNCTION DT_RM2(AMLO2,AMHI2,Q2) | |
22409 | ||
22410 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
22411 | SAVE | |
22412 | PARAMETER ( LINP = 10 , | |
22413 | & LOUT = 6 , | |
22414 | & LDAT = 9 ) | |
22415 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) | |
22416 | PARAMETER (TWOPI = 6.283185307179586476925286766559D+00, | |
22417 | & PI = TWOPI/TWO, | |
22418 | & GEV2MB = 0.38938D0) | |
22419 | * VDM parameter for photon-nucleus interactions | |
22420 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
22421 | ||
22422 | IF (RL2.LE.ZERO) THEN | |
22423 | DT_RM2 = -ONE/(AMHI2+Q2)+Q2/(TWO*(AMHI2+Q2)**2) - | |
22424 | & (-ONE/(AMLO2+Q2)+Q2/(TWO*(AMLO2+Q2)**2)) | |
22425 | & +EPSPOL*(-Q2/(TWO*(AMHI2+Q2)**2)+Q2/(TWO*(AMLO2+Q2)**2)) | |
22426 | ELSE | |
22427 | TMPMLO = LOG(ONE+RL2/(AMLO2+Q2)) | |
22428 | TMPMHI = LOG(ONE+RL2/(AMHI2+Q2)) | |
22429 | DT_RM2 = Q2/(RL2*(AMHI2+Q2))-(Q2+RL2)/RL2**2*TMPMHI | |
22430 | & -(Q2/(RL2*(AMLO2+Q2))-(Q2+RL2)/RL2**2*TMPMLO) | |
22431 | & +EPSPOL*( | |
22432 | & -Q2/(RL2*(AMHI2+Q2))+Q2/RL2**2*TMPMHI | |
22433 | & -(-Q2/(RL2*(AMLO2+Q2))+Q2/RL2**2*TMPMLO)) | |
22434 | ENDIF | |
22435 | ||
22436 | RETURN | |
22437 | END | |
22438 | ||
22439 | *$ CREATE DT_SAM2.FOR | |
22440 | *COPY DT_SAM2 | |
22441 | * | |
22442 | *===SAM2===============================================================* | |
22443 | * | |
22444 | DOUBLE PRECISION FUNCTION DT_SAM2(Q2,ECM) | |
22445 | ||
22446 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
22447 | SAVE | |
22448 | PARAMETER ( LINP = 10 , | |
22449 | & LOUT = 6 , | |
22450 | & LDAT = 9 ) | |
22451 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0, | |
22452 | & TENTRD=10.0D0/3.0D0,ELVTRD=11.0D0/3.0D0) | |
22453 | PARAMETER (TWOPI = 6.283185307179586476925286766559D+00, | |
22454 | & PI = TWOPI/TWO, | |
22455 | & GEV2MB = 0.38938D0) | |
22456 | ||
22457 | * particle properties (BAMJET index convention) | |
22458 | CHARACTER*8 ANAME | |
22459 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
22460 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
22461 | * VDM parameter for photon-nucleus interactions | |
22462 | COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3) | |
22463 | ||
22464 | S = ECM**2 | |
22465 | IF (INTRGE(1).EQ.1) THEN | |
22466 | AMLO2 = (3.0D0*AAM(13))**2 | |
22467 | ELSEIF (INTRGE(1).EQ.2) THEN | |
22468 | AMLO2 = AAM(33)**2 | |
22469 | ELSE | |
22470 | AMLO2 = AAM(96)**2 | |
22471 | ENDIF | |
22472 | IF (INTRGE(2).EQ.1) THEN | |
22473 | AMHI2 = S/TWO | |
22474 | ELSEIF (INTRGE(2).EQ.2) THEN | |
22475 | AMHI2 = S/4.0D0 | |
22476 | ELSE | |
22477 | AMHI2 = S | |
22478 | ENDIF | |
22479 | AMHI20 = (ECM-AAM(1))**2 | |
22480 | IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20 | |
22481 | ||
22482 | AM1C2 = 16.0D0 | |
22483 | AM2C2 = 121.0D0 | |
22484 | YLO = LOG(AMLO2+Q2) | |
22485 | YC1 = LOG(AM1C2+Q2) | |
22486 | YC2 = LOG(AM2C2+Q2) | |
22487 | YHI = LOG(AMHI2+Q2) | |
22488 | IF (AMHI2.LE.AM1C2) THEN | |
22489 | FACHI = TWO | |
22490 | ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN | |
22491 | FACHI = TENTRD | |
22492 | ELSE | |
22493 | FACHI = ELVTRD | |
22494 | ENDIF | |
22495 | ||
22496 | 1 CONTINUE | |
22497 | YSAM2 = YLO+(YHI-YLO)*DT_RNDM(AM1C2) | |
22498 | IF (YSAM2.LE.YC1) THEN | |
22499 | FAC = TWO | |
22500 | ELSEIF ((YSAM2.GT.YC1).AND.(YSAM2.LE.YC2)) THEN | |
22501 | FAC = TENTRD | |
22502 | ELSE | |
22503 | FAC = ELVTRD | |
22504 | ENDIF | |
22505 | WEIGMX = FACHI*(ONE-Q2*EXP( -YHI)) | |
22506 | XSAM2 = FAC *(ONE-Q2*EXP(-YSAM2)) | |
22507 | IF (DT_RNDM(YSAM2)*WEIGMX.GT.XSAM2) GOTO 1 | |
22508 | ||
22509 | DT_SAM2 = EXP(YSAM2)-Q2 | |
22510 | ||
22511 | RETURN | |
22512 | END | |
22513 | ||
22514 | *$ CREATE DT_CKMT.FOR | |
22515 | *COPY DT_CKMT | |
22516 | * | |
22517 | *===ckmt===============================================================* | |
22518 | * | |
22519 | SUBROUTINE DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL, | |
22520 | & F2,IPAR) | |
22521 | ||
22522 | ************************************************************************ | |
22523 | * This version dated 31.01.96 is written by S. Roesler * | |
22524 | ************************************************************************ | |
22525 | ||
22526 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
22527 | SAVE | |
22528 | PARAMETER ( LINP = 10 , | |
22529 | & LOUT = 6 , | |
22530 | & LDAT = 9 ) | |
22531 | PARAMETER (ZERO=0.0D0,TWO=2.0D0,TINY10=1.0D-10) | |
22532 | ||
22533 | PARAMETER (Q02 = 2.0D0, | |
22534 | & DQ2 = 10.05D0, | |
22535 | & Q12 = Q02+DQ2) | |
22536 | ||
22537 | DIMENSION PD(-6:6),SEA(3),VAL(2) | |
22538 | ||
22539 | CALL DT_PDF0(Q02,X,F2Q0,VAL,SEA,GLU,IPAR) | |
22540 | CALL DT_PDF0(Q12,X,F2Q1,VAL,SEA,GLU,IPAR) | |
22541 | ADQ2 = LOG10(Q12)-LOG10(Q02) | |
22542 | F2P = (F2Q1-F2Q0)/ADQ2 | |
22543 | CALL DT_CKMTX(IPAR,X,Q02,PD,F2PQ0) | |
22544 | CALL DT_CKMTX(IPAR,X,Q12,PD,F2PQ1) | |
22545 | F2PP = (F2PQ1-F2PQ0)/ADQ2 | |
22546 | FX = (F2P-F2PP)/(F2PP+LOG(DQ2)*F2PQ0+TINY10)*Q02 | |
22547 | ||
22548 | Q2 = MAX(SCALE**2.0D0,TINY10) | |
22549 | SMOOTH = 1.0D0+FX*(Q2-Q02)/Q2**2 | |
22550 | IF (Q2.LT.Q02) THEN | |
22551 | CALL DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR) | |
22552 | UPV = VAL(1) | |
22553 | DNV = VAL(2) | |
22554 | USEA = SEA(1) | |
22555 | DSEA = SEA(2) | |
22556 | STR = SEA(3) | |
22557 | CHM = 0.0D0 | |
22558 | BOT = 0.0D0 | |
22559 | TOP = 0.0D0 | |
22560 | GL = GLU | |
22561 | ELSE | |
22562 | CALL DT_CKMTX(IPAR,X,Q2,PD,F2) | |
22563 | F2 = F2*SMOOTH | |
22564 | UPV = PD(2)-PD(3) | |
22565 | DNV = PD(1)-PD(3) | |
22566 | USEA = PD(3) | |
22567 | DSEA = PD(3) | |
22568 | STR = PD(3) | |
22569 | CHM = PD(4) | |
22570 | BOT = PD(5) | |
22571 | TOP = PD(6) | |
22572 | GL = PD(0) | |
22573 | C UPV = UPV*SMOOTH | |
22574 | C DNV = DNV*SMOOTH | |
22575 | C USEA = USEA*SMOOTH | |
22576 | C DSEA = DSEA*SMOOTH | |
22577 | C STR = STR*SMOOTH | |
22578 | C CHM = CHM*SMOOTH | |
22579 | C GL = GL*SMOOTH | |
22580 | ENDIF | |
22581 | ||
22582 | RETURN | |
22583 | END | |
22584 | C | |
22585 | ||
22586 | *$ CREATE DT_CKMTX.FOR | |
22587 | *COPY DT_CKMTX | |
22588 | SUBROUTINE DT_CKMTX(IPAR,X,SCALE2,PD,F2) | |
22589 | C********************************************************************** | |
22590 | C | |
22591 | C PDF based on Regge theory, evolved with .... by .... | |
22592 | C | |
22593 | C input: IPAR 2212 proton (not installed) | |
22594 | C 45 Pomeron | |
22595 | C 100 Deuteron | |
22596 | C | |
22597 | C output: PD(-6:6) x*f(x) parton distribution functions | |
22598 | C (PDFLIB convention: d = PD(1), u = PD(2) ) | |
22599 | C | |
22600 | C********************************************************************** | |
22601 | ||
22602 | SAVE | |
22603 | DOUBLE PRECISION X,SCALE2,PD(-6:6),CDN,CUP,F2 | |
22604 | PARAMETER ( LINP = 10 , | |
22605 | & LOUT = 6 , | |
22606 | & LDAT = 9 ) | |
22607 | DIMENSION QQ(7) | |
22608 | C | |
22609 | Q2=SNGL(SCALE2) | |
22610 | Q1S=Q2 | |
22611 | XX=SNGL(X) | |
22612 | C QCD lambda for evolution | |
22613 | OWLAM = 0.23D0 | |
22614 | OWLAM2=OWLAM**2 | |
22615 | C Q0**2 for evolution | |
22616 | Q02 = 2.D0 | |
22617 | C | |
22618 | C | |
22619 | C the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=... | |
22620 | C q(6)=x*charm, q(7)=x*gluon | |
22621 | C | |
22622 | SB=0. | |
22623 | IF(Q2-Q02) 1,1,2 | |
22624 | 2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2)) | |
22625 | 1 CONTINUE | |
22626 | IF(IPAR.EQ.2212) THEN | |
22627 | CALL DT_CKMTPR(1,0,XX,SB,QQ(1)) | |
22628 | CALL DT_CKMTPR(2,0,XX,SB,QQ(2)) | |
22629 | CALL DT_CKMTPR(3,0,XX,SB,QQ(3)) | |
22630 | CALL DT_CKMTPR(4,0,XX,SB,QQ(4)) | |
22631 | CALL DT_CKMTPR(5,0,XX,SB,QQ(5)) | |
22632 | CALL DT_CKMTPR(8,0,XX,SB,QQ(6)) | |
22633 | CALL DT_CKMTPR(7,0,XX,SB,QQ(7)) | |
22634 | C ELSEIF (IPAR.EQ.45) THEN | |
22635 | C CALL CKMTPO(1,0,XX,SB,QQ(1)) | |
22636 | C CALL CKMTPO(2,0,XX,SB,QQ(2)) | |
22637 | C CALL CKMTPO(3,0,XX,SB,QQ(3)) | |
22638 | C CALL CKMTPO(4,0,XX,SB,QQ(4)) | |
22639 | C CALL CKMTPO(5,0,XX,SB,QQ(5)) | |
22640 | C CALL CKMTPO(8,0,XX,SB,QQ(6)) | |
22641 | C CALL CKMTPO(7,0,XX,SB,QQ(7)) | |
22642 | ELSEIF (IPAR.EQ.100) THEN | |
22643 | CALL DT_CKMTDE(1,0,XX,SB,QQ(1)) | |
22644 | CALL DT_CKMTDE(2,0,XX,SB,QQ(2)) | |
22645 | CALL DT_CKMTDE(3,0,XX,SB,QQ(3)) | |
22646 | CALL DT_CKMTDE(4,0,XX,SB,QQ(4)) | |
22647 | CALL DT_CKMTDE(5,0,XX,SB,QQ(5)) | |
22648 | CALL DT_CKMTDE(8,0,XX,SB,QQ(6)) | |
22649 | CALL DT_CKMTDE(7,0,XX,SB,QQ(7)) | |
22650 | ELSE | |
22651 | WRITE(LOUT,'(1X,A,I4,A)') | |
22652 | & 'CKMTX: IPAR =',IPAR,' not implemented!' | |
22653 | STOP | |
22654 | ENDIF | |
22655 | C | |
22656 | PD(-6) = 0.D0 | |
22657 | PD(-5) = 0.D0 | |
22658 | PD(-4) = DBLE(QQ(6)) | |
22659 | PD(-3) = DBLE(QQ(3)) | |
22660 | PD(-2) = DBLE(QQ(4)) | |
22661 | PD(-1) = DBLE(QQ(5)) | |
22662 | PD(0) = DBLE(QQ(7)) | |
22663 | PD(1) = DBLE(QQ(2)) | |
22664 | PD(2) = DBLE(QQ(1)) | |
22665 | PD(3) = DBLE(QQ(3)) | |
22666 | PD(4) = DBLE(QQ(6)) | |
22667 | PD(5) = 0.D0 | |
22668 | PD(6) = 0.D0 | |
22669 | IF(IPAR.EQ.45) THEN | |
22670 | CDN = (PD(1)-PD(-1))/2.D0 | |
22671 | CUP = (PD(2)-PD(-2))/2.D0 | |
22672 | PD(-1) = PD(-1) + CDN | |
22673 | PD(-2) = PD(-2) + CUP | |
22674 | PD(1) = PD(-1) | |
22675 | PD(2) = PD(-2) | |
22676 | ENDIF | |
22677 | F2 = 4.0D0/9.0D0*(PD(2)-PD(3)+2.0D0*PD(3))+ | |
22678 | & 1.0D0/9.0D0*(PD(1)-PD(3)+2.0D0*PD(3))+ | |
22679 | & 1.0D0/9.0D0*(2.0D0*PD(3))+4.0D0/9.0D0*(2.0D0*PD(4)) | |
22680 | END | |
22681 | C | |
22682 | ||
22683 | *$ CREATE DT_PDF0.FOR | |
22684 | *COPY DT_PDF0 | |
22685 | * | |
22686 | *===pdf0===============================================================* | |
22687 | * | |
22688 | SUBROUTINE DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR) | |
22689 | ||
22690 | ************************************************************************ | |
22691 | * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 * | |
22692 | * an F_2-ansatz given in Capella et al. PLB 337(1994)358. * | |
22693 | * IPAR = 2212 proton * | |
22694 | * = 100 deuteron * | |
22695 | * This version dated 31.01.96 is written by S. Roesler * | |
22696 | ************************************************************************ | |
22697 | ||
22698 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
22699 | SAVE | |
22700 | PARAMETER ( LINP = 10 , | |
22701 | & LOUT = 6 , | |
22702 | & LDAT = 9 ) | |
22703 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9) | |
22704 | ||
22705 | PARAMETER ( | |
22706 | & AA = 0.1502D0, | |
22707 | & BBDEU = 1.2D0, | |
22708 | & BUD = 0.754D0, | |
22709 | & BDD = 0.4495D0, | |
22710 | & BUP = 1.2064D0, | |
22711 | & BDP = 0.1798D0, | |
22712 | & DELTA0 = 0.07684D0, | |
22713 | & D = 1.117D0, | |
22714 | & C = 3.5489D0, | |
22715 | & A = 0.2631D0, | |
22716 | & B = 0.6452D0, | |
22717 | & ALPHAR = 0.415D0, | |
22718 | & E = 0.1D0 | |
22719 | & ) | |
22720 | ||
22721 | PARAMETER (NPOINT=16) | |
22722 | C DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT) | |
22723 | DIMENSION SEA(3),VAL(2) | |
22724 | ||
22725 | DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D)) | |
22726 | AN = 1.5D0*(1.0D0+Q2/(Q2+C)) | |
22727 | * proton, deuteron | |
22728 | IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN | |
22729 | CALL DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0) | |
22730 | SEA(1) = 0.75D0*SEA0 | |
22731 | SEA(2) = SEA(1) | |
22732 | SEA(3) = SEA(1) | |
22733 | VAL(1) = 9.0D0/4.0D0*VALU0 | |
22734 | VAL(2) = 9.0D0*VALD0 | |
22735 | GLU0 = SEA(1)/(1.0D0-X) | |
22736 | F2 = SEA0+VALU0+VALD0 | |
22737 | F2PDF = 4.0D0/9.0D0*(VAL(1)+2.0D0*SEA(1))+ | |
22738 | & 1.0D0/9.0D0*(VAL(2)+2.0D0*SEA(2))+ | |
22739 | & 1.0D0/9.0D0*(2.0D0*SEA(3)) | |
22740 | IF (ABS(F2-F2PDF).GT.TINY9) THEN | |
22741 | WRITE(LOUT,'(1X,A,2E15.5)') 'inconsistent PDF! ',F2,F2PDF | |
22742 | STOP | |
22743 | ENDIF | |
22744 | **PHOJET105a | |
22745 | C CALL GSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT) | |
22746 | **PHOJET112 | |
22747 | C CALL PHO_GAUSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT) | |
22748 | ** | |
22749 | C SUMQ = ZERO | |
22750 | C SUMG = ZERO | |
22751 | C DO 1 J=1,NPOINT | |
22752 | C CALL DT_CKMTQ0(Q2,ABSZX(J),IPAR,VALU0,VALD0,SEA0) | |
22753 | C VALU0 = 9.0D0/4.0D0*VALU0 | |
22754 | C VALD0 = 9.0D0*VALD0 | |
22755 | C SEA0 = 0.75D0*SEA0 | |
22756 | C SUMQ = SUMQ+ (VALU0+VALD0+6.0D0*SEA0) *WEIGHT(J) | |
22757 | C SUMG = SUMG+ (SEA0/(1.0D0-ABSZX(J))) *WEIGHT(J) | |
22758 | C 1 CONTINUE | |
22759 | C GLU = GLU0*(1.0D0-SUMQ)/SUMG | |
22760 | ELSE | |
22761 | WRITE(LOUT,'(1X,A,I4,A)') | |
22762 | & 'PDF0: IPAR =',IPAR,' not implemented!' | |
22763 | STOP | |
22764 | ENDIF | |
22765 | ||
22766 | RETURN | |
22767 | END | |
22768 | ||
22769 | *$ CREATE DT_CKMTQ0.FOR | |
22770 | *COPY DT_CKMTQ0 | |
22771 | * | |
22772 | *===ckmtq0=============================================================* | |
22773 | * | |
22774 | SUBROUTINE DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0) | |
22775 | ||
22776 | ************************************************************************ | |
22777 | * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 * | |
22778 | * an F_2-ansatz given in Capella et al. PLB 337(1994)358. * | |
22779 | * IPAR = 2212 proton * | |
22780 | * = 100 deuteron * | |
22781 | * This version dated 31.01.96 is written by S. Roesler * | |
22782 | ************************************************************************ | |
22783 | ||
22784 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
22785 | SAVE | |
22786 | PARAMETER ( LINP = 10 , | |
22787 | & LOUT = 6 , | |
22788 | & LDAT = 9 ) | |
22789 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9) | |
22790 | ||
22791 | PARAMETER ( | |
22792 | & AA = 0.1502D0, | |
22793 | & BBDEU = 1.2D0, | |
22794 | & BUD = 0.754D0, | |
22795 | & BDD = 0.4495D0, | |
22796 | & BUP = 1.2064D0, | |
22797 | & BDP = 0.1798D0, | |
22798 | & DELTA0 = 0.07684D0, | |
22799 | & D = 1.117D0, | |
22800 | & C = 3.5489D0, | |
22801 | & A = 0.2631D0, | |
22802 | & B = 0.6452D0, | |
22803 | & ALPHAR = 0.415D0, | |
22804 | & E = 0.1D0 | |
22805 | & ) | |
22806 | ||
22807 | DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D)) | |
22808 | AN = 1.5D0*(1.0D0+Q2/(Q2+C)) | |
22809 | * proton, deuteron | |
22810 | IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN | |
22811 | IF (IPAR.EQ.2212) THEN | |
22812 | BU = BUP | |
22813 | BD = BDP | |
22814 | ELSE | |
22815 | BU = BUD | |
22816 | BD = BDD | |
22817 | ENDIF | |
22818 | SEA0 = AA*X**(-DELTA)*(1.0D0-X)**(AN+4.0D0)* | |
22819 | & (Q2/(Q2+A))**(1.0D0+DELTA) | |
22820 | VALU0 = BU*X**(1.0D0-ALPHAR)*(1.0D0-X)**AN* | |
22821 | & (Q2/(Q2+B))**(ALPHAR) | |
22822 | VALD0 = BD*X**(1.0D0-ALPHAR)*(1.0D0-X)**(AN+1.0D0)* | |
22823 | & (Q2/(Q2+B))**(ALPHAR) | |
22824 | ELSE | |
22825 | WRITE(LOUT,'(1X,A,I4,A)') | |
22826 | & 'CKMTQ0: IPAR =',IPAR,' not implemented!' | |
22827 | STOP | |
22828 | ENDIF | |
22829 | RETURN | |
22830 | END | |
22831 | C | |
22832 | C | |
22833 | ||
22834 | *$ CREATE DT_CKMTDE.FOR | |
22835 | *COPY DT_CKMTDE | |
22836 | SUBROUTINE DT_CKMTDE(I,NDRV,X,S,ANS) | |
22837 | C | |
22838 | C********************************************************************** | |
22839 | C Deuteron - PDFs | |
22840 | C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc | |
22841 | C ANS = PDF(I) | |
22842 | C This version by S. Roesler, 30.01.96 | |
22843 | C********************************************************************** | |
22844 | ||
22845 | SAVE | |
22846 | DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000) | |
22847 | EQUIVALENCE (GF(1,1,1),DL(1)) | |
22848 | DATA DELTA/.13/ | |
22849 | C | |
22850 | DATA (DL(K),K= 1, 85) / | |
22851 | &0.351858E+00,0.388489E+00,0.325356E+00,0.325356E+00,0.325356E+00, | |
22852 | &0.325356E+00,0.445218E+01,0.000000E+00,0.419818E+00,0.459249E+00, | |
22853 | &0.391167E+00,0.391143E+00,0.391125E+00,0.391167E+00,0.628186E+01, | |
22854 | &0.703797E-01,0.498333E+00,0.540626E+00,0.467466E+00,0.467423E+00, | |
22855 | &0.467393E+00,0.467466E+00,0.837368E+01,0.151191E+00,0.587839E+00, | |
22856 | &0.633058E+00,0.554689E+00,0.554630E+00,0.554595E+00,0.554689E+00, | |
22857 | &0.107170E+02,0.242877E+00,0.688652E+00,0.736861E+00,0.653150E+00, | |
22858 | &0.653080E+00,0.653046E+00,0.653150E+00,0.132960E+02,0.345760E+00, | |
22859 | &0.800961E+00,0.852226E+00,0.763038E+00,0.762961E+00,0.762933E+00, | |
22860 | &0.763038E+00,0.160884E+02,0.460033E+00,0.924829E+00,0.979213E+00, | |
22861 | &0.884414E+00,0.884335E+00,0.884319E+00,0.884414E+00,0.190679E+02, | |
22862 | &0.585764E+00,0.106016E+01,0.111773E+01,0.101719E+01,0.101711E+01, | |
22863 | &0.101711E+01,0.101719E+01,0.222033E+02,0.722864E+00,0.120670E+01, | |
22864 | &0.126752E+01,0.116110E+01,0.116102E+01,0.116105E+01,0.116110E+01, | |
22865 | &0.254603E+02,0.871079E+00,0.136402E+01,0.142815E+01,0.131571E+01, | |
22866 | &0.131565E+01,0.131570E+01,0.131571E+01,0.288020E+02,0.102998E+01, | |
22867 | &0.153151E+01,0.159900E+01,0.148043E+01,0.148038E+01,0.148046E+01/ | |
22868 | DATA (DL(K),K= 86, 170) / | |
22869 | &0.148043E+01,0.321898E+02,0.119897E+01,0.170838E+01,0.177930E+01, | |
22870 | &0.165447E+01,0.165444E+01,0.165455E+01,0.165447E+01,0.355845E+02, | |
22871 | &0.137726E+01,0.189369E+01,0.196807E+01,0.183687E+01,0.183686E+01, | |
22872 | &0.183701E+01,0.183687E+01,0.389473E+02,0.156390E+01,0.208631E+01, | |
22873 | &0.216422E+01,0.202653E+01,0.202654E+01,0.202673E+01,0.202653E+01, | |
22874 | &0.422402E+02,0.175779E+01,0.228501E+01,0.236648E+01,0.222220E+01, | |
22875 | &0.222224E+01,0.222248E+01,0.222220E+01,0.454277E+02,0.195768E+01, | |
22876 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22877 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22878 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22879 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22880 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22881 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22882 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22883 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22884 | &0.326035E+00,0.380777E+00,0.286363E+00,0.286363E+00,0.286363E+00, | |
22885 | &0.286363E+00,0.392252E+01,-.138778E-16,0.380092E+00,0.438587E+00/ | |
22886 | DATA (DL(K),K= 171, 255) / | |
22887 | &0.337452E+00,0.337430E+00,0.337424E+00,0.337452E+00,0.532193E+01, | |
22888 | &0.553645E-01,0.440879E+00,0.503177E+00,0.395208E+00,0.395169E+00, | |
22889 | &0.395165E+00,0.395208E+00,0.686454E+01,0.117354E+00,0.508415E+00, | |
22890 | &0.574566E+00,0.459649E+00,0.459600E+00,0.459604E+00,0.459649E+00, | |
22891 | &0.853316E+01,0.185994E+00,0.582647E+00,0.652699E+00,0.530722E+00, | |
22892 | &0.530667E+00,0.530687E+00,0.530722E+00,0.103093E+02,0.261237E+00, | |
22893 | &0.663404E+00,0.737405E+00,0.608254E+00,0.608199E+00,0.608241E+00, | |
22894 | &0.608254E+00,0.121710E+02,0.342917E+00,0.750429E+00,0.828423E+00, | |
22895 | &0.691990E+00,0.691941E+00,0.692009E+00,0.691990E+00,0.140946E+02, | |
22896 | &0.430783E+00,0.843361E+00,0.925391E+00,0.781571E+00,0.781533E+00, | |
22897 | &0.781632E+00,0.781571E+00,0.160553E+02,0.524479E+00,0.941741E+00, | |
22898 | &0.102784E+01,0.876538E+00,0.876515E+00,0.876650E+00,0.876538E+00, | |
22899 | &0.180277E+02,0.623549E+00,0.104501E+01,0.113521E+01,0.976335E+00, | |
22900 | &0.976332E+00,0.976506E+00,0.976335E+00,0.199863E+02,0.727439E+00, | |
22901 | &0.115251E+01,0.124685E+01,0.108031E+01,0.108034E+01,0.108055E+01, | |
22902 | &0.108031E+01,0.219066E+02,0.835506E+00,0.126352E+01,0.136201E+01, | |
22903 | &0.118775E+01,0.118780E+01,0.118806E+01,0.118775E+01,0.237652E+02/ | |
22904 | DATA (DL(K),K= 256, 340) / | |
22905 | &0.947020E+00,0.137724E+01,0.147989E+01,0.129783E+01,0.129791E+01, | |
22906 | &0.129822E+01,0.129783E+01,0.255406E+02,0.106119E+01,0.149279E+01, | |
22907 | &0.159961E+01,0.140972E+01,0.140984E+01,0.141019E+01,0.140972E+01, | |
22908 | &0.272135E+02,0.117715E+01,0.160929E+01,0.172028E+01,0.152252E+01, | |
22909 | &0.152267E+01,0.152308E+01,0.152252E+01,0.287669E+02,0.129402E+01, | |
22910 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22911 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22912 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22913 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22914 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22915 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22916 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22917 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22918 | &0.309785E+00,0.391282E+00,0.250518E+00,0.250518E+00,0.250518E+00, | |
22919 | &0.250518E+00,0.343842E+01,-.138778E-16,0.352113E+00,0.438463E+00, | |
22920 | &0.288877E+00,0.288863E+00,0.288878E+00,0.288877E+00,0.446765E+01, | |
22921 | &0.424850E-01,0.398382E+00,0.489596E+00,0.331132E+00,0.331111E+00/ | |
22922 | DATA (DL(K),K= 341, 425) / | |
22923 | &0.331148E+00,0.331132E+00,0.555902E+01,0.888369E-01,0.448375E+00, | |
22924 | &0.544458E+00,0.377064E+00,0.377043E+00,0.377108E+00,0.377064E+00, | |
22925 | &0.669490E+01,0.138845E+00,0.501854E+00,0.602811E+00,0.426440E+00, | |
22926 | &0.426425E+00,0.426523E+00,0.426440E+00,0.785892E+01,0.192281E+00, | |
22927 | &0.558506E+00,0.664331E+00,0.478946E+00,0.478944E+00,0.479079E+00, | |
22928 | &0.478946E+00,0.903368E+01,0.248834E+00,0.617972E+00,0.728657E+00, | |
22929 | &0.534229E+00,0.534244E+00,0.534421E+00,0.534229E+00,0.102022E+02, | |
22930 | &0.308155E+00,0.679844E+00,0.795370E+00,0.591883E+00,0.591921E+00, | |
22931 | &0.592141E+00,0.591883E+00,0.113479E+02,0.369841E+00,0.743667E+00, | |
22932 | &0.864009E+00,0.651460E+00,0.651525E+00,0.651792E+00,0.651460E+00, | |
22933 | &0.124553E+02,0.433447E+00,0.808951E+00,0.934073E+00,0.712474E+00, | |
22934 | &0.712571E+00,0.712885E+00,0.712474E+00,0.135102E+02,0.498486E+00, | |
22935 | &0.875171E+00,0.100503E+01,0.774408E+00,0.774541E+00,0.774902E+00, | |
22936 | &0.774408E+00,0.144999E+02,0.564446E+00,0.941784E+00,0.107632E+01, | |
22937 | &0.836726E+00,0.836897E+00,0.837307E+00,0.836726E+00,0.154136E+02, | |
22938 | &0.630788E+00,0.100823E+01,0.114738E+01,0.898879E+00,0.899092E+00, | |
22939 | &0.899551E+00,0.898879E+00,0.162423E+02,0.696967E+00,0.107396E+01/ | |
22940 | DATA (DL(K),K= 426, 510) / | |
22941 | &0.121764E+01,0.960319E+00,0.960577E+00,0.961084E+00,0.960319E+00, | |
22942 | &0.169791E+02,0.762433E+00,0.113843E+01,0.128655E+01,0.102051E+01, | |
22943 | &0.102081E+01,0.102137E+01,0.102051E+01,0.176190E+02,0.826647E+00, | |
22944 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22945 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22946 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22947 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22948 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22949 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22950 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22951 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22952 | &0.304680E+00,0.425088E+00,0.216504E+00,0.216504E+00,0.216504E+00, | |
22953 | &0.216504E+00,0.298356E+01,0.000000E+00,0.337300E+00,0.463627E+00, | |
22954 | &0.244023E+00,0.244024E+00,0.244063E+00,0.244023E+00,0.370271E+01, | |
22955 | &0.316585E-01,0.371787E+00,0.503942E+00,0.273415E+00,0.273423E+00, | |
22956 | &0.273505E+00,0.273415E+00,0.443039E+01,0.651685E-01,0.407853E+00, | |
22957 | &0.545739E+00,0.304395E+00,0.304418E+00,0.304545E+00,0.304395E+00/ | |
22958 | DATA (DL(K),K= 511, 595) / | |
22959 | &0.515321E+01,0.100252E+00,0.445229E+00,0.588741E+00,0.336700E+00, | |
22960 | &0.336744E+00,0.336918E+00,0.336700E+00,0.586004E+01,0.136648E+00, | |
22961 | &0.483606E+00,0.632629E+00,0.370026E+00,0.370095E+00,0.370318E+00, | |
22962 | &0.370026E+00,0.654027E+01,0.174056E+00,0.522666E+00,0.677074E+00, | |
22963 | &0.404062E+00,0.404162E+00,0.404433E+00,0.404062E+00,0.718442E+01, | |
22964 | &0.212167E+00,0.562075E+00,0.721735E+00,0.438483E+00,0.438618E+00, | |
22965 | &0.438938E+00,0.438483E+00,0.778423E+01,0.250658E+00,0.601494E+00, | |
22966 | &0.766258E+00,0.472959E+00,0.473131E+00,0.473500E+00,0.472959E+00, | |
22967 | &0.833276E+01,0.289199E+00,0.640580E+00,0.810290E+00,0.507156E+00, | |
22968 | &0.507369E+00,0.507784E+00,0.507156E+00,0.882448E+01,0.327457E+00, | |
22969 | &0.678993E+00,0.853479E+00,0.540747E+00,0.541003E+00,0.541463E+00, | |
22970 | &0.540747E+00,0.925529E+01,0.365104E+00,0.716405E+00,0.895483E+00, | |
22971 | &0.573411E+00,0.573714E+00,0.574216E+00,0.573411E+00,0.962250E+01, | |
22972 | &0.401821E+00,0.752501E+00,0.935975E+00,0.604848E+00,0.605197E+00, | |
22973 | &0.605740E+00,0.604848E+00,0.992478E+01,0.437304E+00,0.786987E+00, | |
22974 | &0.974647E+00,0.634775E+00,0.635173E+00,0.635752E+00,0.634775E+00, | |
22975 | &0.101620E+02,0.471269E+00,0.819594E+00,0.101122E+01,0.662936E+00/ | |
22976 | DATA (DL(K),K= 596, 680) / | |
22977 | &0.663382E+00,0.663995E+00,0.662936E+00,0.103354E+02,0.503459E+00, | |
22978 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22979 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22980 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22981 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22982 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22983 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22984 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22985 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
22986 | &0.312661E+00,0.487836E+00,0.182562E+00,0.182562E+00,0.182562E+00, | |
22987 | &0.182562E+00,0.253626E+01,0.000000E+00,0.336910E+00,0.518440E+00, | |
22988 | &0.200702E+00,0.200721E+00,0.200779E+00,0.200702E+00,0.299460E+01, | |
22989 | &0.224425E-01,0.361554E+00,0.549164E+00,0.219359E+00,0.219402E+00, | |
22990 | &0.219517E+00,0.219359E+00,0.343183E+01,0.453742E-01,0.386348E+00, | |
22991 | &0.579759E+00,0.238296E+00,0.238367E+00,0.238536E+00,0.238296E+00, | |
22992 | &0.384076E+01,0.685610E-01,0.411080E+00,0.610003E+00,0.257305E+00, | |
22993 | &0.257408E+00,0.257630E+00,0.257305E+00,0.421619E+01,0.917987E-01/ | |
22994 | DATA (DL(K),K= 681, 765) / | |
22995 | &0.435528E+00,0.639668E+00,0.276174E+00,0.276313E+00,0.276583E+00, | |
22996 | &0.276174E+00,0.455400E+01,0.114876E+00,0.459476E+00,0.668531E+00, | |
22997 | &0.294698E+00,0.294875E+00,0.295191E+00,0.294698E+00,0.485107E+01, | |
22998 | &0.137589E+00,0.482719E+00,0.696375E+00,0.312682E+00,0.312900E+00, | |
22999 | &0.313258E+00,0.312682E+00,0.510539E+01,0.159742E+00,0.505060E+00, | |
23000 | &0.722995E+00,0.329941E+00,0.330200E+00,0.330596E+00,0.329941E+00, | |
23001 | &0.531589E+01,0.181149E+00,0.526315E+00,0.748199E+00,0.346303E+00, | |
23002 | &0.346604E+00,0.347034E+00,0.346303E+00,0.548250E+01,0.201638E+00, | |
23003 | &0.546317E+00,0.771808E+00,0.361613E+00,0.361957E+00,0.362418E+00, | |
23004 | &0.361613E+00,0.560595E+01,0.221052E+00,0.564917E+00,0.793667E+00, | |
23005 | &0.375735E+00,0.376122E+00,0.376609E+00,0.375735E+00,0.568772E+01, | |
23006 | &0.239253E+00,0.581987E+00,0.813638E+00,0.388553E+00,0.388982E+00, | |
23007 | &0.389491E+00,0.388553E+00,0.572992E+01,0.256122E+00,0.597419E+00, | |
23008 | &0.831608E+00,0.399972E+00,0.400443E+00,0.400970E+00,0.399972E+00, | |
23009 | &0.573516E+01,0.271562E+00,0.611129E+00,0.847487E+00,0.409919E+00, | |
23010 | &0.410430E+00,0.410972E+00,0.409919E+00,0.570642E+01,0.285497E+00, | |
23011 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23012 | DATA (DL(K),K= 766, 850) / | |
23013 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23014 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23015 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23016 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23017 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23018 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23019 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23020 | &0.335149E+00,0.582072E+00,0.146415E+00,0.146415E+00,0.146415E+00, | |
23021 | &0.146415E+00,0.206772E+01,0.000000E+00,0.351552E+00,0.603437E+00, | |
23022 | &0.156515E+00,0.156542E+00,0.156595E+00,0.156515E+00,0.231143E+01, | |
23023 | &0.146091E-01,0.367407E+00,0.623737E+00,0.166387E+00,0.166442E+00, | |
23024 | &0.166542E+00,0.166387E+00,0.252488E+01,0.289315E-01,0.382571E+00, | |
23025 | &0.642832E+00,0.175891E+00,0.175976E+00,0.176118E+00,0.175891E+00, | |
23026 | &0.270658E+01,0.428312E-01,0.396926E+00,0.660609E+00,0.184917E+00, | |
23027 | &0.185034E+00,0.185212E+00,0.184917E+00,0.285608E+01,0.561981E-01, | |
23028 | &0.410365E+00,0.676962E+00,0.193365E+00,0.193513E+00,0.193722E+00, | |
23029 | &0.193365E+00,0.297375E+01,0.689319E-01,0.422792E+00,0.691796E+00/ | |
23030 | DATA (DL(K),K= 851, 935) / | |
23031 | &0.201144E+00,0.201324E+00,0.201560E+00,0.201144E+00,0.306050E+01, | |
23032 | &0.809434E-01,0.434123E+00,0.705030E+00,0.208181E+00,0.208393E+00, | |
23033 | &0.208650E+00,0.208181E+00,0.311775E+01,0.921567E-01,0.444287E+00, | |
23034 | &0.716596E+00,0.214413E+00,0.214656E+00,0.214931E+00,0.214413E+00, | |
23035 | &0.314738E+01,0.102508E+00,0.453228E+00,0.726441E+00,0.219792E+00, | |
23036 | &0.220066E+00,0.220354E+00,0.219792E+00,0.315156E+01,0.111949E+00, | |
23037 | &0.460906E+00,0.734527E+00,0.224285E+00,0.224589E+00,0.224886E+00, | |
23038 | &0.224285E+00,0.313271E+01,0.120441E+00,0.467291E+00,0.740835E+00, | |
23039 | &0.227870E+00,0.228203E+00,0.228506E+00,0.227870E+00,0.309338E+01, | |
23040 | &0.127963E+00,0.472372E+00,0.745357E+00,0.230541E+00,0.230902E+00, | |
23041 | &0.231208E+00,0.230541E+00,0.303621E+01,0.134506E+00,0.476148E+00, | |
23042 | &0.748105E+00,0.232304E+00,0.232690E+00,0.232996E+00,0.232304E+00, | |
23043 | &0.296381E+01,0.140070E+00,0.478635E+00,0.749103E+00,0.233176E+00, | |
23044 | &0.233586E+00,0.233889E+00,0.233176E+00,0.287874E+01,0.144672E+00, | |
23045 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23046 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23047 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23048 | DATA (DL(K),K= 936, 1020) / | |
23049 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23050 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23051 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23052 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23053 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23054 | &0.370162E+00,0.695827E+00,0.105823E+00,0.105823E+00,0.105823E+00, | |
23055 | &0.105823E+00,0.154556E+01,0.208167E-16,0.378214E+00,0.703794E+00, | |
23056 | &0.109539E+00,0.109554E+00,0.109571E+00,0.109539E+00,0.162770E+01, | |
23057 | &0.818783E-02,0.385258E+00,0.710067E+00,0.112818E+00,0.112847E+00, | |
23058 | &0.112879E+00,0.112818E+00,0.168578E+01,0.158212E-01,0.391264E+00, | |
23059 | &0.714648E+00,0.115620E+00,0.115666E+00,0.115709E+00,0.115620E+00, | |
23060 | &0.172175E+01,0.228667E-01,0.396214E+00,0.717539E+00,0.117923E+00, | |
23061 | &0.117985E+00,0.118037E+00,0.117923E+00,0.173756E+01,0.293009E-01, | |
23062 | &0.400098E+00,0.718759E+00,0.119711E+00,0.119790E+00,0.119848E+00, | |
23063 | &0.119711E+00,0.173541E+01,0.351123E-01,0.402915E+00,0.718332E+00, | |
23064 | &0.120979E+00,0.121074E+00,0.121137E+00,0.120979E+00,0.171755E+01, | |
23065 | &0.402951E-01,0.404672E+00,0.716292E+00,0.121728E+00,0.121840E+00/ | |
23066 | DATA (DL(K),K= 1021, 1105) / | |
23067 | &0.121905E+00,0.121728E+00,0.168619E+01,0.448514E-01,0.405385E+00, | |
23068 | &0.712681E+00,0.121967E+00,0.122095E+00,0.122161E+00,0.121967E+00, | |
23069 | &0.164352E+01,0.487902E-01,0.405077E+00,0.707551E+00,0.121712E+00, | |
23070 | &0.121855E+00,0.121920E+00,0.121712E+00,0.159162E+01,0.521265E-01, | |
23071 | &0.403778E+00,0.700963E+00,0.120984E+00,0.121141E+00,0.121204E+00, | |
23072 | &0.120984E+00,0.153245E+01,0.548814E-01,0.401525E+00,0.692984E+00, | |
23073 | &0.119809E+00,0.119980E+00,0.120040E+00,0.119809E+00,0.146780E+01, | |
23074 | &0.570807E-01,0.398361E+00,0.683691E+00,0.118218E+00,0.118402E+00, | |
23075 | &0.118457E+00,0.118218E+00,0.139928E+01,0.587542E-01,0.394333E+00, | |
23076 | &0.673166E+00,0.116244E+00,0.116440E+00,0.116490E+00,0.116244E+00, | |
23077 | &0.132834E+01,0.599355E-01,0.389495E+00,0.661496E+00,0.113924E+00, | |
23078 | &0.114131E+00,0.114175E+00,0.113924E+00,0.125620E+01,0.606602E-01, | |
23079 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23080 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23081 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23082 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23083 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23084 | DATA (DL(K),K= 1106, 1190) / | |
23085 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23086 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23087 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23088 | &0.394012E+00,0.757115E+00,0.772117E-01,0.772117E-01,0.772117E-01, | |
23089 | &0.772117E-01,0.117279E+01,0.346945E-17,0.395841E+00,0.752988E+00, | |
23090 | &0.780501E-01,0.780655E-01,0.780723E-01,0.780501E-01,0.118528E+01, | |
23091 | &0.491697E-02,0.396627E+00,0.747223E+00,0.785386E-01,0.785692E-01, | |
23092 | &0.785806E-01,0.785386E-01,0.118242E+01,0.932754E-02,0.396401E+00, | |
23093 | &0.739901E+00,0.786820E-01,0.787273E-01,0.787413E-01,0.786820E-01, | |
23094 | &0.116673E+01,0.132427E-01,0.395190E+00,0.731092E+00,0.784870E-01, | |
23095 | &0.785464E-01,0.785613E-01,0.784870E-01,0.114033E+01,0.166738E-01, | |
23096 | &0.393030E+00,0.720878E+00,0.779683E-01,0.780410E-01,0.780555E-01, | |
23097 | &0.779683E-01,0.110528E+01,0.196392E-01,0.389962E+00,0.709342E+00, | |
23098 | &0.771427E-01,0.772280E-01,0.772409E-01,0.771427E-01,0.106344E+01, | |
23099 | &0.221591E-01,0.386027E+00,0.696571E+00,0.760304E-01,0.761276E-01, | |
23100 | &0.761378E-01,0.760304E-01,0.101653E+01,0.242567E-01,0.381274E+00, | |
23101 | &0.682657E+00,0.746543E-01,0.747623E-01,0.747692E-01,0.746543E-01/ | |
23102 | DATA (DL(K),K= 1191, 1275) / | |
23103 | &0.966057E+00,0.259571E-01,0.375752E+00,0.667695E+00,0.730389E-01, | |
23104 | &0.731569E-01,0.731598E-01,0.730389E-01,0.913345E+00,0.272876E-01, | |
23105 | &0.369514E+00,0.651782E+00,0.712104E-01,0.713374E-01,0.713358E-01, | |
23106 | &0.712104E-01,0.859530E+00,0.282763E-01,0.362616E+00,0.635021E+00, | |
23107 | &0.691957E-01,0.693307E-01,0.693243E-01,0.691957E-01,0.805566E+00, | |
23108 | &0.289524E-01,0.355116E+00,0.617511E+00,0.670220E-01,0.671640E-01, | |
23109 | &0.671526E-01,0.670220E-01,0.752235E+00,0.293453E-01,0.347072E+00, | |
23110 | &0.599357E+00,0.647162E-01,0.648642E-01,0.648478E-01,0.647162E-01, | |
23111 | &0.700161E+00,0.294844E-01,0.338543E+00,0.580659E+00,0.623046E-01, | |
23112 | &0.624578E-01,0.624363E-01,0.623046E-01,0.649828E+00,0.293983E-01, | |
23113 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23114 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23115 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23116 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23117 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23118 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23119 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23120 | DATA (DL(K),K= 1276, 1360) / | |
23121 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23122 | &0.408305E+00,0.775318E+00,0.509141E-01,0.509141E-01,0.509141E-01, | |
23123 | &0.509141E-01,0.818839E+00,-.867362E-17,0.403619E+00,0.758058E+00, | |
23124 | &0.502245E-01,0.502351E-01,0.502337E-01,0.502245E-01,0.795347E+00, | |
23125 | &0.264045E-02,0.398068E+00,0.739709E+00,0.493454E-01,0.493661E-01, | |
23126 | &0.493626E-01,0.493454E-01,0.764942E+00,0.491508E-02,0.391719E+00, | |
23127 | &0.720394E+00,0.482952E-01,0.483253E-01,0.483192E-01,0.482952E-01, | |
23128 | &0.729624E+00,0.685202E-02,0.384627E+00,0.700222E+00,0.470896E-01, | |
23129 | &0.471285E-01,0.471194E-01,0.470896E-01,0.690906E+00,0.847433E-02, | |
23130 | &0.376851E+00,0.679300E+00,0.457475E-01,0.457946E-01,0.457822E-01, | |
23131 | &0.457475E-01,0.650078E+00,0.980774E-02,0.368452E+00,0.657739E+00, | |
23132 | &0.442875E-01,0.443419E-01,0.443261E-01,0.442875E-01,0.608239E+00, | |
23133 | &0.108769E-01,0.359490E+00,0.635646E+00,0.427281E-01,0.427892E-01, | |
23134 | &0.427698E-01,0.427281E-01,0.566280E+00,0.117061E-01,0.350026E+00, | |
23135 | &0.613128E+00,0.410878E-01,0.411549E-01,0.411320E-01,0.410878E-01, | |
23136 | &0.524918E+00,0.123191E-01,0.340122E+00,0.590292E+00,0.393848E-01, | |
23137 | &0.394571E-01,0.394308E-01,0.393848E-01,0.484713E+00,0.127393E-01/ | |
23138 | DATA (DL(K),K= 1361, 1445) / | |
23139 | &0.329838E+00,0.567240E+00,0.376363E-01,0.377132E-01,0.376836E-01, | |
23140 | &0.376363E-01,0.446084E+00,0.129888E-01,0.319236E+00,0.544074E+00, | |
23141 | &0.358589E-01,0.359396E-01,0.359068E-01,0.358589E-01,0.409328E+00, | |
23142 | &0.130888E-01,0.308374E+00,0.520890E+00,0.340678E-01,0.341517E-01, | |
23143 | &0.341160E-01,0.340678E-01,0.374641E+00,0.130594E-01,0.297312E+00, | |
23144 | &0.497781E+00,0.322772E-01,0.323636E-01,0.323253E-01,0.322772E-01, | |
23145 | &0.342135E+00,0.129195E-01,0.286106E+00,0.474837E+00,0.304999E-01, | |
23146 | &0.305882E-01,0.305474E-01,0.304999E-01,0.311854E+00,0.126863E-01, | |
23147 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23148 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23149 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23150 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23151 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23152 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23153 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23154 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23155 | &0.407248E+00,0.746438E+00,0.335640E-01,0.335640E-01,0.335640E-01/ | |
23156 | DATA (DL(K),K= 1446, 1530) / | |
23157 | &0.335640E-01,0.573540E+00,0.173472E-16,0.397516E+00,0.719825E+00, | |
23158 | &0.324649E-01,0.324735E-01,0.324698E-01,0.324649E-01,0.540770E+00, | |
23159 | &0.147177E-02,0.387197E+00,0.692869E+00,0.312911E-01,0.313075E-01, | |
23160 | &0.313000E-01,0.312911E-01,0.505972E+00,0.269995E-02,0.376365E+00, | |
23161 | &0.665689E+00,0.300576E-01,0.300811E-01,0.300699E-01,0.300576E-01, | |
23162 | &0.470389E+00,0.371147E-02,0.365085E+00,0.638387E+00,0.287770E-01, | |
23163 | &0.288070E-01,0.287922E-01,0.287770E-01,0.434885E+00,0.452768E-02, | |
23164 | &0.353423E+00,0.611066E+00,0.274623E-01,0.274980E-01,0.274797E-01, | |
23165 | &0.274623E-01,0.400103E+00,0.516996E-02,0.341442E+00,0.583823E+00, | |
23166 | &0.261256E-01,0.261663E-01,0.261448E-01,0.261256E-01,0.366541E+00, | |
23167 | &0.565807E-02,0.329207E+00,0.556753E+00,0.247782E-01,0.248234E-01, | |
23168 | &0.247989E-01,0.247782E-01,0.334555E+00,0.601048E-02,0.316777E+00, | |
23169 | &0.529946E+00,0.234308E-01,0.234798E-01,0.234525E-01,0.234308E-01, | |
23170 | &0.304384E+00,0.624451E-02,0.304214E+00,0.503489E+00,0.220932E-01, | |
23171 | &0.221452E-01,0.221155E-01,0.220932E-01,0.276170E+00,0.637618E-02, | |
23172 | &0.291575E+00,0.477462E+00,0.207739E-01,0.208286E-01,0.207966E-01, | |
23173 | &0.207739E-01,0.249976E+00,0.642028E-02,0.278917E+00,0.451941E+00/ | |
23174 | DATA (DL(K),K= 1531, 1615) / | |
23175 | &0.194809E-01,0.195376E-01,0.195037E-01,0.194809E-01,0.225809E+00, | |
23176 | &0.639038E-02,0.266293E+00,0.426995E+00,0.182209E-01,0.182791E-01, | |
23177 | &0.182436E-01,0.182209E-01,0.203629E+00,0.629880E-02,0.253754E+00, | |
23178 | &0.402686E+00,0.169996E-01,0.170587E-01,0.170219E-01,0.169996E-01, | |
23179 | &0.183361E+00,0.615665E-02,0.241347E+00,0.379071E+00,0.158217E-01, | |
23180 | &0.158814E-01,0.158436E-01,0.158217E-01,0.164907E+00,0.597385E-02, | |
23181 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23182 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23183 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23184 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23185 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23186 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23187 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23188 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23189 | &0.395106E+00,0.689399E+00,0.218554E-01,0.218554E-01,0.218554E-01, | |
23190 | &0.218554E-01,0.398362E+00,-.173472E-17,0.381441E+00,0.656777E+00, | |
23191 | &0.207816E-01,0.207886E-01,0.207844E-01,0.207816E-01,0.366703E+00/ | |
23192 | DATA (DL(K),K= 1616, 1700) / | |
23193 | &0.826643E-03,0.367505E+00,0.624578E+00,0.197001E-01,0.197133E-01, | |
23194 | &0.197053E-01,0.197001E-01,0.335573E+00,0.149886E-02,0.353373E+00, | |
23195 | &0.592889E+00,0.186195E-01,0.186383E-01,0.186266E-01,0.186195E-01, | |
23196 | &0.305590E+00,0.203730E-02,0.339106E+00,0.561783E+00,0.175468E-01, | |
23197 | &0.175705E-01,0.175555E-01,0.175468E-01,0.277136E+00,0.245817E-02, | |
23198 | &0.324766E+00,0.531331E+00,0.164887E-01,0.165166E-01,0.164986E-01, | |
23199 | &0.164887E-01,0.250424E+00,0.277666E-02,0.310411E+00,0.501599E+00, | |
23200 | &0.154510E-01,0.154825E-01,0.154618E-01,0.154510E-01,0.225588E+00, | |
23201 | &0.300658E-02,0.296100E+00,0.472648E+00,0.144390E-01,0.144735E-01, | |
23202 | &0.144504E-01,0.144390E-01,0.202681E+00,0.316040E-02,0.281885E+00, | |
23203 | &0.444535E+00,0.134570E-01,0.134940E-01,0.134689E-01,0.134570E-01, | |
23204 | &0.181693E+00,0.324944E-02,0.267820E+00,0.417309E+00,0.125091E-01, | |
23205 | &0.125481E-01,0.125212E-01,0.125091E-01,0.162572E+00,0.328396E-02, | |
23206 | &0.253953E+00,0.391017E+00,0.115984E-01,0.116389E-01,0.116106E-01, | |
23207 | &0.115984E-01,0.145235E+00,0.327313E-02,0.240328E+00,0.365695E+00, | |
23208 | &0.107275E-01,0.107690E-01,0.107396E-01,0.107275E-01,0.129575E+00, | |
23209 | &0.322510E-02,0.226989E+00,0.341375E+00,0.989805E-02,0.994030E-02/ | |
23210 | DATA (DL(K),K= 1701, 1785) / | |
23211 | &0.990998E-02,0.989805E-02,0.115477E+00,0.314713E-02,0.213972E+00, | |
23212 | &0.318081E+00,0.911149E-02,0.915408E-02,0.912316E-02,0.911149E-02, | |
23213 | &0.102820E+00,0.304556E-02,0.201311E+00,0.295830E+00,0.836852E-02, | |
23214 | &0.841111E-02,0.837984E-02,0.836852E-02,0.914804E-01,0.292596E-02, | |
23215 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23216 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23217 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23218 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23219 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23220 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23221 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23222 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23223 | &0.374678E+00,0.616087E+00,0.139531E-01,0.139531E-01,0.139531E-01, | |
23224 | &0.139531E-01,0.272491E+00,-.693889E-17,0.358052E+00,0.580345E+00, | |
23225 | &0.130624E-01,0.130680E-01,0.130641E-01,0.130624E-01,0.245861E+00, | |
23226 | &0.460255E-03,0.341487E+00,0.545719E+00,0.121971E-01,0.122076E-01, | |
23227 | &0.122002E-01,0.121971E-01,0.220877E+00,0.826785E-03,0.325046E+00/ | |
23228 | DATA (DL(K),K= 1786, 1870) / | |
23229 | &0.512244E+00,0.113599E-01,0.113748E-01,0.113641E-01,0.113599E-01, | |
23230 | &0.197730E+00,0.111366E-02,0.308783E+00,0.479952E+00,0.105534E-01, | |
23231 | &0.105720E-01,0.105585E-01,0.105534E-01,0.176497E+00,0.133192E-02, | |
23232 | &0.292747E+00,0.448868E+00,0.977938E-02,0.980112E-02,0.978518E-02, | |
23233 | &0.977938E-02,0.157150E+00,0.149139E-02,0.276986E+00,0.419015E+00, | |
23234 | &0.903955E-02,0.906394E-02,0.904584E-02,0.903955E-02,0.139631E+00, | |
23235 | &0.160093E-02,0.261546E+00,0.390412E+00,0.833509E-02,0.836165E-02, | |
23236 | &0.834171E-02,0.833509E-02,0.123850E+00,0.166838E-02,0.246467E+00, | |
23237 | &0.363074E+00,0.766687E-02,0.769516E-02,0.767369E-02,0.766687E-02, | |
23238 | &0.109695E+00,0.170073E-02,0.231787E+00,0.337008E+00,0.703540E-02, | |
23239 | &0.706500E-02,0.704230E-02,0.703540E-02,0.970428E-01,0.170416E-02, | |
23240 | &0.217542E+00,0.312218E+00,0.644083E-02,0.647137E-02,0.644772E-02, | |
23241 | &0.644083E-02,0.857658E-01,0.168409E-02,0.203759E+00,0.288701E+00, | |
23242 | &0.588300E-02,0.591415E-02,0.588981E-02,0.588300E-02,0.757385E-01, | |
23243 | &0.164528E-02,0.190467E+00,0.266449E+00,0.536147E-02,0.539292E-02, | |
23244 | &0.536812E-02,0.536147E-02,0.668383E-01,0.159185E-02,0.177686E+00, | |
23245 | &0.245447E+00,0.487551E-02,0.490698E-02,0.488195E-02,0.487551E-02/ | |
23246 | DATA (DL(K),K= 1871, 1955) / | |
23247 | &0.589492E-01,0.152735E-02,0.165434E+00,0.225677E+00,0.442416E-02, | |
23248 | &0.445543E-02,0.443037E-02,0.442416E-02,0.519652E-01,0.145483E-02, | |
23249 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23250 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23251 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23252 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23253 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23254 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23255 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23256 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23257 | &0.348042E+00,0.534691E+00,0.867977E-02,0.867977E-02,0.867977E-02, | |
23258 | &0.867977E-02,0.182547E+00,-.693889E-17,0.329349E+00,0.498248E+00, | |
23259 | &0.800724E-02,0.801198E-02,0.800836E-02,0.800724E-02,0.161948E+00, | |
23260 | &0.250949E-03,0.311047E+00,0.463485E+00,0.737155E-02,0.738040E-02, | |
23261 | &0.737356E-02,0.737155E-02,0.143267E+00,0.447662E-03,0.293181E+00, | |
23262 | &0.430377E+00,0.677169E-02,0.678409E-02,0.677441E-02,0.677169E-02, | |
23263 | &0.126447E+00,0.598803E-03,0.275787E+00,0.398907E+00,0.620726E-02/ | |
23264 | DATA (DL(K),K= 1956, 2040) / | |
23265 | &0.622265E-02,0.621051E-02,0.620726E-02,0.111401E+00,0.711280E-03, | |
23266 | &0.258900E+00,0.369051E+00,0.567741E-02,0.569532E-02,0.568106E-02, | |
23267 | &0.567741E-02,0.979944E-01,0.790986E-03,0.242550E+00,0.340785E+00, | |
23268 | &0.518138E-02,0.520134E-02,0.518531E-02,0.518138E-02,0.860936E-01, | |
23269 | &0.843227E-03,0.226765E+00,0.314083E+00,0.471828E-02,0.473987E-02, | |
23270 | &0.472238E-02,0.471828E-02,0.755615E-01,0.872644E-03,0.211568E+00, | |
23271 | &0.288916E+00,0.428714E-02,0.430998E-02,0.429133E-02,0.428714E-02, | |
23272 | &0.662627E-01,0.883319E-03,0.196981E+00,0.265252E+00,0.388691E-02, | |
23273 | &0.391065E-02,0.389112E-02,0.388691E-02,0.580684E-01,0.878818E-03, | |
23274 | &0.183020E+00,0.243053E+00,0.351645E-02,0.354077E-02,0.352060E-02, | |
23275 | &0.351645E-02,0.508578E-01,0.862228E-03,0.169696E+00,0.222280E+00, | |
23276 | &0.317451E-02,0.319914E-02,0.317858E-02,0.317451E-02,0.445190E-01, | |
23277 | &0.836224E-03,0.157017E+00,0.202888E+00,0.285982E-02,0.288450E-02, | |
23278 | &0.286376E-02,0.285982E-02,0.389523E-01,0.803096E-03,0.144987E+00, | |
23279 | &0.184832E+00,0.257101E-02,0.259553E-02,0.257480E-02,0.257101E-02, | |
23280 | &0.340677E-01,0.764787E-03,0.133605E+00,0.168060E+00,0.230670E-02, | |
23281 | &0.233087E-02,0.231031E-02,0.230670E-02,0.297820E-01,0.722929E-03/ | |
23282 | DATA (DL(K),K= 2041, 2125) / | |
23283 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23284 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23285 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23286 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23287 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23288 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23289 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23290 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23291 | &0.316867E+00,0.451111E+00,0.522815E-02,0.522815E-02,0.522815E-02, | |
23292 | &0.522815E-02,0.119118E+00,0.889046E-17,0.296950E+00,0.415915E+00, | |
23293 | &0.475497E-02,0.475914E-02,0.475574E-02,0.475497E-02,0.104204E+00, | |
23294 | &0.132513E-03,0.277735E+00,0.382805E+00,0.431809E-02,0.432582E-02, | |
23295 | &0.431944E-02,0.431809E-02,0.910279E-01,0.235347E-03,0.259241E+00, | |
23296 | &0.351694E+00,0.391455E-02,0.392531E-02,0.391637E-02,0.391455E-02, | |
23297 | &0.794222E-01,0.313322E-03,0.241485E+00,0.322517E+00,0.354249E-02, | |
23298 | &0.355575E-02,0.354464E-02,0.354249E-02,0.692354E-01,0.370408E-03, | |
23299 | &0.224480E+00,0.295202E+00,0.319987E-02,0.321518E-02,0.320226E-02/ | |
23300 | DATA (DL(K),K= 2126, 2210) / | |
23301 | &0.319987E-02,0.603106E-01,0.409866E-03,0.208235E+00,0.269681E+00, | |
23302 | &0.288490E-02,0.290184E-02,0.288744E-02,0.288490E-02,0.525034E-01, | |
23303 | &0.434663E-03,0.192759E+00,0.245887E+00,0.259589E-02,0.261407E-02, | |
23304 | &0.259852E-02,0.259589E-02,0.456838E-01,0.447393E-03,0.178054E+00, | |
23305 | &0.223752E+00,0.233123E-02,0.235033E-02,0.233390E-02,0.233123E-02, | |
23306 | &0.397318E-01,0.450314E-03,0.164120E+00,0.203207E+00,0.208941E-02, | |
23307 | &0.210910E-02,0.209206E-02,0.208941E-02,0.345396E-01,0.445394E-03, | |
23308 | &0.150954E+00,0.184182E+00,0.186896E-02,0.188897E-02,0.187155E-02, | |
23309 | &0.186896E-02,0.300131E-01,0.434333E-03,0.138548E+00,0.166608E+00, | |
23310 | &0.166844E-02,0.168854E-02,0.167096E-02,0.166844E-02,0.260692E-01, | |
23311 | &0.418584E-03,0.126892E+00,0.150412E+00,0.148650E-02,0.150648E-02, | |
23312 | &0.148891E-02,0.148650E-02,0.226325E-01,0.399380E-03,0.115971E+00, | |
23313 | &0.135523E+00,0.132180E-02,0.134148E-02,0.132409E-02,0.132180E-02, | |
23314 | &0.196374E-01,0.377764E-03,0.105767E+00,0.121870E+00,0.117308E-02, | |
23315 | &0.119231E-02,0.117524E-02,0.117308E-02,0.170312E-01,0.354610E-03, | |
23316 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23317 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23318 | DATA (DL(K),K= 2211, 2295) / | |
23319 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23320 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23321 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23322 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23323 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23324 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23325 | &0.282579E+00,0.369670E+00,0.302765E-02,0.302765E-02,0.302765E-02, | |
23326 | &0.302765E-02,0.752529E-01,-.455365E-17,0.262229E+00,0.337209E+00, | |
23327 | &0.271512E-02,0.271883E-02,0.271564E-02,0.271512E-02,0.651086E-01, | |
23328 | &0.669321E-04,0.242857E+00,0.307069E+00,0.243269E-02,0.243953E-02, | |
23329 | &0.243360E-02,0.243269E-02,0.563252E-01,0.118744E-03,0.224455E+00, | |
23330 | &0.279111E+00,0.217687E-02,0.218631E-02,0.217808E-02,0.217687E-02, | |
23331 | &0.487143E-01,0.157767E-03,0.207014E+00,0.253223E+00,0.194534E-02, | |
23332 | &0.195689E-02,0.194675E-02,0.194534E-02,0.421227E-01,0.186063E-03, | |
23333 | &0.190523E+00,0.229293E+00,0.173585E-02,0.174909E-02,0.173741E-02, | |
23334 | &0.173585E-02,0.364156E-01,0.205286E-03,0.174969E+00,0.207218E+00, | |
23335 | &0.154647E-02,0.156100E-02,0.154811E-02,0.154647E-02,0.314732E-01/ | |
23336 | DATA (DL(K),K= 2296, 2380) / | |
23337 | &0.216964E-03,0.160335E+00,0.186895E+00,0.137545E-02,0.139092E-02, | |
23338 | &0.137713E-02,0.137545E-02,0.271927E-01,0.222455E-03,0.146604E+00, | |
23339 | &0.168227E+00,0.122121E-02,0.123733E-02,0.122290E-02,0.122121E-02, | |
23340 | &0.234852E-01,0.222947E-03,0.133756E+00,0.151116E+00,0.108234E-02, | |
23341 | &0.109881E-02,0.108400E-02,0.108234E-02,0.202747E-01,0.219474E-03, | |
23342 | &0.121765E+00,0.135471E+00,0.957502E-03,0.974107E-03,0.959112E-03, | |
23343 | &0.957502E-03,0.174932E-01,0.212928E-03,0.110606E+00,0.121198E+00, | |
23344 | &0.845493E-03,0.862024E-03,0.847037E-03,0.845493E-03,0.150824E-01, | |
23345 | &0.204075E-03,0.100250E+00,0.108210E+00,0.745196E-03,0.761482E-03, | |
23346 | &0.746662E-03,0.745196E-03,0.129965E-01,0.193573E-03,0.906661E-01, | |
23347 | &0.964191E-01,0.655569E-03,0.671466E-03,0.656948E-03,0.655569E-03, | |
23348 | &0.111930E-01,0.181962E-03,0.818218E-01,0.857412E-01,0.575637E-03, | |
23349 | &0.591030E-03,0.576925E-03,0.575637E-03,0.962922E-02,0.169687E-03, | |
23350 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23351 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23352 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23353 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23354 | DATA (DL(K),K= 2381, 2465) / | |
23355 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23356 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23357 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23358 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23359 | &0.246444E+00,0.293515E+00,0.167124E-02,0.167124E-02,0.167124E-02, | |
23360 | &0.167124E-02,0.456929E-01,-.260209E-17,0.226393E+00,0.264836E+00, | |
23361 | &0.147748E-02,0.148085E-02,0.147783E-02,0.147748E-02,0.392393E-01, | |
23362 | &0.318190E-04,0.207552E+00,0.238550E+00,0.130596E-02,0.131212E-02, | |
23363 | &0.130656E-02,0.130596E-02,0.337276E-01,0.566426E-04,0.189877E+00, | |
23364 | &0.214470E+00,0.115347E-02,0.116190E-02,0.115427E-02,0.115347E-02, | |
23365 | &0.290012E-01,0.753776E-04,0.173336E+00,0.192452E+00,0.101789E-02, | |
23366 | &0.102811E-02,0.101881E-02,0.101789E-02,0.249381E-01,0.889466E-04, | |
23367 | &0.157889E+00,0.172355E+00,0.897268E-03,0.908872E-03,0.898270E-03, | |
23368 | &0.897268E-03,0.214419E-01,0.980950E-04,0.143501E+00,0.154046E+00, | |
23369 | &0.789951E-03,0.802565E-03,0.790996E-03,0.789951E-03,0.184296E-01, | |
23370 | &0.103536E-03,0.130132E+00,0.137402E+00,0.694510E-03,0.707811E-03, | |
23371 | &0.695568E-03,0.694510E-03,0.158331E-01,0.105929E-03,0.117743E+00/ | |
23372 | DATA (DL(K),K= 2466, 2550) / | |
23373 | &0.122303E+00,0.609684E-03,0.623394E-03,0.610733E-03,0.609684E-03, | |
23374 | &0.135929E-01,0.105853E-03,0.106293E+00,0.108637E+00,0.534365E-03, | |
23375 | &0.548244E-03,0.535386E-03,0.534365E-03,0.116583E-01,0.103825E-03, | |
23376 | &0.957386E-01,0.962976E-01,0.467572E-03,0.481416E-03,0.468551E-03, | |
23377 | &0.467572E-03,0.999103E-02,0.100301E-03,0.860376E-01,0.851820E-01, | |
23378 | &0.408422E-03,0.422062E-03,0.409350E-03,0.408422E-03,0.855563E-02, | |
23379 | &0.956675E-04,0.771455E-01,0.751930E-01,0.356117E-03,0.369416E-03, | |
23380 | &0.356989E-03,0.356117E-03,0.731542E-02,0.902499E-04,0.690178E-01, | |
23381 | &0.662386E-01,0.309950E-03,0.322797E-03,0.310761E-03,0.309950E-03, | |
23382 | &0.624633E-02,0.843305E-04,0.616096E-01,0.582312E-01,0.269281E-03, | |
23383 | &0.281590E-03,0.270030E-03,0.269281E-03,0.533230E-02,0.781441E-04, | |
23384 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23385 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23386 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23387 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23388 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23389 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23390 | DATA (DL(K),K= 2551, 2635) / | |
23391 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23392 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23393 | &0.209608E+00,0.224862E+00,0.869706E-03,0.869706E-03,0.869706E-03, | |
23394 | &0.869706E-03,0.264204E-01,-.138236E-17,0.190523E+00,0.200603E+00, | |
23395 | &0.757542E-03,0.760626E-03,0.757768E-03,0.757542E-03,0.226261E-01, | |
23396 | &0.138827E-04,0.172819E+00,0.178656E+00,0.660281E-03,0.665837E-03, | |
23397 | &0.660670E-03,0.660281E-03,0.194018E-01,0.249832E-04,0.156420E+00, | |
23398 | &0.158805E+00,0.575414E-03,0.582918E-03,0.575917E-03,0.575414E-03, | |
23399 | &0.166434E-01,0.334851E-04,0.141265E+00,0.140883E+00,0.501258E-03, | |
23400 | &0.510252E-03,0.501836E-03,0.501258E-03,0.142710E-01,0.397017E-04, | |
23401 | &0.127291E+00,0.124732E+00,0.436386E-03,0.446473E-03,0.437008E-03, | |
23402 | &0.436386E-03,0.122297E-01,0.439154E-04,0.114437E+00,0.110205E+00, | |
23403 | &0.379575E-03,0.390415E-03,0.380217E-03,0.379575E-03,0.104701E-01, | |
23404 | &0.464110E-04,0.102644E+00,0.971655E-01,0.329805E-03,0.341109E-03, | |
23405 | &0.330448E-03,0.329805E-03,0.895086E-02,0.474758E-04,0.918521E-01, | |
23406 | &0.854876E-01,0.286206E-03,0.297729E-03,0.286836E-03,0.286206E-03, | |
23407 | &0.764249E-02,0.473771E-04,0.820032E-01,0.750529E-01,0.248027E-03/ | |
23408 | DATA (DL(K),K= 2636, 2720) / | |
23409 | &0.259564E-03,0.248633E-03,0.248027E-03,0.651744E-02,0.463561E-04, | |
23410 | &0.730394E-01,0.657510E-01,0.214611E-03,0.225995E-03,0.215186E-03, | |
23411 | &0.214611E-03,0.554573E-02,0.446239E-04,0.649040E-01,0.574789E-01, | |
23412 | &0.185396E-03,0.196491E-03,0.185935E-03,0.185396E-03,0.470938E-02, | |
23413 | &0.423722E-04,0.575411E-01,0.501405E-01,0.159891E-03,0.170590E-03, | |
23414 | &0.160391E-03,0.159891E-03,0.399752E-02,0.397689E-04,0.508960E-01, | |
23415 | &0.436466E-01,0.137650E-03,0.147874E-03,0.138111E-03,0.137650E-03, | |
23416 | &0.338807E-02,0.369434E-04,0.449157E-01,0.379141E-01,0.118285E-03, | |
23417 | &0.127973E-03,0.118705E-03,0.118285E-03,0.286125E-02,0.340035E-04, | |
23418 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23419 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23420 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23421 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23422 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23423 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23424 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23425 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23426 | DATA (DL(K),K= 2721, 2805) / | |
23427 | &0.173133E+00,0.165162E+00,0.420483E-03,0.420483E-03,0.420483E-03, | |
23428 | &0.420483E-03,0.143704E-01,0.418773E-17,0.155600E+00,0.145586E+00, | |
23429 | &0.360490E-03,0.363140E-03,0.360629E-03,0.360490E-03,0.123560E-01, | |
23430 | &0.533279E-05,0.139551E+00,0.128113E+00,0.309555E-03,0.314310E-03, | |
23431 | &0.309792E-03,0.309555E-03,0.106262E-01,0.982612E-05,0.124876E+00, | |
23432 | &0.112516E+00,0.265952E-03,0.272344E-03,0.266256E-03,0.265952E-03, | |
23433 | &0.913151E-02,0.133834E-04,0.111490E+00,0.986188E-01,0.228522E-03, | |
23434 | &0.236138E-03,0.228869E-03,0.228522E-03,0.783135E-02,0.160429E-04, | |
23435 | &0.993081E-01,0.862590E-01,0.196336E-03,0.204821E-03,0.196706E-03, | |
23436 | &0.196336E-03,0.670031E-02,0.178799E-04,0.882484E-01,0.752883E-01, | |
23437 | &0.168604E-03,0.177655E-03,0.168981E-03,0.168604E-03,0.572016E-02, | |
23438 | &0.189837E-04,0.782334E-01,0.655714E-01,0.144684E-03,0.154047E-03, | |
23439 | &0.145058E-03,0.144684E-03,0.487276E-02,0.194655E-04,0.691885E-01, | |
23440 | &0.569841E-01,0.124035E-03,0.133497E-03,0.124397E-03,0.124035E-03, | |
23441 | &0.413648E-02,0.194296E-04,0.610420E-01,0.494128E-01,0.106203E-03, | |
23442 | &0.115592E-03,0.106548E-03,0.106203E-03,0.350042E-02,0.189800E-04, | |
23443 | &0.537249E-01,0.427533E-01,0.908141E-04,0.999895E-04,0.911377E-04/ | |
23444 | DATA (DL(K),K= 2806, 2890) / | |
23445 | &0.908141E-04,0.295961E-02,0.182192E-04,0.471713E-01,0.369100E-01, | |
23446 | &0.775359E-04,0.863895E-04,0.778360E-04,0.775359E-04,0.249629E-02, | |
23447 | &0.172287E-04,0.413182E-01,0.317957E-01,0.660857E-04,0.745356E-04, | |
23448 | &0.663611E-04,0.660857E-04,0.209482E-02,0.160791E-04,0.361056E-01, | |
23449 | &0.273306E-01,0.562298E-04,0.642173E-04,0.564804E-04,0.562298E-04, | |
23450 | &0.175588E-02,0.148407E-04,0.314766E-01,0.234421E-01,0.477598E-04, | |
23451 | &0.552457E-04,0.479859E-04,0.477598E-04,0.147398E-02,0.135653E-04, | |
23452 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23453 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23454 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23455 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23456 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23457 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23458 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23459 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23460 | &0.138007E+00,0.115214E+00,0.185072E-03,0.185072E-03,0.185072E-03, | |
23461 | &0.185072E-03,0.722856E-02,-.380826E-17,0.122517E+00,0.100251E+00/ | |
23462 | DATA (DL(K),K= 2891, 2975) / | |
23463 | &0.155814E-03,0.158287E-03,0.155901E-03,0.155814E-03,0.630580E-02, | |
23464 | &0.155371E-05,0.108535E+00,0.870870E-01,0.131535E-03,0.135909E-03, | |
23465 | &0.131680E-03,0.131535E-03,0.547867E-02,0.304952E-05,0.959260E-01, | |
23466 | &0.754985E-01,0.111183E-03,0.116980E-03,0.111366E-03,0.111183E-03, | |
23467 | &0.473794E-02,0.433106E-05,0.845828E-01,0.653163E-01,0.940433E-04, | |
23468 | &0.100851E-03,0.942493E-04,0.940433E-04,0.407647E-02,0.533613E-05, | |
23469 | &0.744017E-01,0.563870E-01,0.795843E-04,0.870596E-04,0.798007E-04, | |
23470 | &0.795843E-04,0.349165E-02,0.606691E-05,0.652864E-01,0.485720E-01, | |
23471 | &0.673476E-04,0.752069E-04,0.675656E-04,0.673476E-04,0.297273E-02, | |
23472 | &0.652898E-05,0.571466E-01,0.417472E-01,0.569700E-04,0.649812E-04, | |
23473 | &0.571831E-04,0.569700E-04,0.251732E-02,0.675028E-05,0.498975E-01, | |
23474 | &0.358008E-01,0.481618E-04,0.561391E-04,0.483654E-04,0.481618E-04, | |
23475 | &0.212754E-02,0.677236E-05,0.434594E-01,0.306320E-01,0.406746E-04, | |
23476 | &0.484724E-04,0.408657E-04,0.406746E-04,0.179059E-02,0.662814E-05, | |
23477 | &0.377578E-01,0.261500E-01,0.343050E-04,0.418123E-04,0.344818E-04, | |
23478 | &0.343050E-04,0.149563E-02,0.635273E-05,0.327229E-01,0.222734E-01, | |
23479 | &0.288923E-04,0.360279E-04,0.290540E-04,0.288923E-04,0.124695E-02/ | |
23480 | DATA (DL(K),K= 2976, 3060) / | |
23481 | &0.598767E-05,0.282894E-01,0.189287E-01,0.242960E-04,0.310036E-04, | |
23482 | &0.244423E-04,0.242960E-04,0.104112E-02,0.556344E-05,0.243968E-01, | |
23483 | &0.160504E-01,0.203920E-04,0.266363E-04,0.205232E-04,0.203920E-04, | |
23484 | &0.863677E-03,0.510070E-05,0.209890E-01,0.135797E-01,0.170822E-04, | |
23485 | &0.228449E-04,0.171989E-04,0.170822E-04,0.711641E-03,0.462338E-05, | |
23486 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23487 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23488 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23489 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23490 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23491 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23492 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23493 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23494 | &0.105155E+00,0.752467E-01,0.719932E-04,0.719932E-04,0.719932E-04, | |
23495 | &0.719932E-04,0.328057E-02,-.758942E-18,0.920856E-01,0.645455E-01, | |
23496 | &0.592305E-04,0.615087E-04,0.592802E-04,0.592305E-04,0.295327E-02, | |
23497 | &0.945234E-07,0.804695E-01,0.552770E-01,0.489125E-04,0.528632E-04/ | |
23498 | DATA (DL(K),K= 3061, 3145) / | |
23499 | &0.489946E-04,0.489125E-04,0.261804E-02,0.365139E-06,0.701499E-01, | |
23500 | &0.472409E-01,0.404786E-04,0.456186E-04,0.405807E-04,0.404786E-04, | |
23501 | &0.229460E-02,0.686912E-06,0.610049E-01,0.402864E-01,0.335367E-04, | |
23502 | &0.394631E-04,0.336495E-04,0.335367E-04,0.198445E-02,0.981070E-06, | |
23503 | &0.529201E-01,0.342803E-01,0.278134E-04,0.342044E-04,0.279301E-04, | |
23504 | &0.278134E-04,0.169772E-02,0.122521E-05,0.457907E-01,0.291037E-01, | |
23505 | &0.230821E-04,0.296833E-04,0.231978E-04,0.230821E-04,0.144575E-02, | |
23506 | &0.140819E-05,0.395205E-01,0.246522E-01,0.191553E-04,0.257661E-04, | |
23507 | &0.192666E-04,0.191553E-04,0.122125E-02,0.152152E-05,0.340212E-01, | |
23508 | &0.208330E-01,0.158874E-04,0.223546E-04,0.159921E-04,0.158874E-04, | |
23509 | &0.101912E-02,0.156880E-05,0.292116E-01,0.175644E-01,0.131678E-04, | |
23510 | &0.193783E-04,0.132645E-04,0.131678E-04,0.847586E-03,0.156432E-05, | |
23511 | &0.250173E-01,0.147740E-01,0.109029E-04,0.167762E-04,0.109910E-04, | |
23512 | &0.109029E-04,0.705515E-03,0.151845E-05,0.213702E-01,0.123979E-01, | |
23513 | &0.901273E-05,0.144953E-04,0.909200E-05,0.901273E-05,0.581767E-03, | |
23514 | &0.143817E-05,0.182083E-01,0.103797E-01,0.743733E-05,0.124978E-04, | |
23515 | &0.750792E-05,0.743733E-05,0.475483E-03,0.133574E-05,0.154751E-01/ | |
23516 | DATA (DL(K),K= 3146, 3230) / | |
23517 | &0.867011E-02,0.612722E-05,0.107517E-04,0.618950E-05,0.612722E-05, | |
23518 | &0.390116E-03,0.122183E-05,0.131193E-01,0.722560E-02,0.503734E-05, | |
23519 | &0.922584E-05,0.509185E-05,0.503734E-05,0.319980E-03,0.110130E-05, | |
23520 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23521 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23522 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23523 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23524 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23525 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23526 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23527 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23528 | &0.754424E-01,0.449848E-01,0.236444E-04,0.236444E-04,0.236444E-04, | |
23529 | &0.236444E-04,0.129291E-02,0.113079E-17,0.650429E-01,0.379660E-01, | |
23530 | &0.187739E-04,0.207130E-04,0.187990E-04,0.187739E-04,0.124038E-02, | |
23531 | &-.327995E-06,0.559588E-01,0.319936E-01,0.149625E-04,0.182671E-04, | |
23532 | &0.150033E-04,0.149625E-04,0.113497E-02,-.464337E-06,0.480234E-01, | |
23533 | &0.269030E-01,0.119484E-04,0.161746E-04,0.119982E-04,0.119484E-04/ | |
23534 | DATA (DL(K),K= 3231, 3315) / | |
23535 | &0.100877E-02,-.490618E-06,0.411091E-01,0.225716E-01,0.954833E-05, | |
23536 | &0.143391E-04,0.960250E-05,0.954833E-05,0.883852E-03,-.461770E-06, | |
23537 | &0.350995E-01,0.188947E-01,0.763738E-05,0.127129E-04,0.769248E-05, | |
23538 | &0.763738E-05,0.760077E-03,-.403363E-06,0.298897E-01,0.157798E-01, | |
23539 | &0.611070E-05,0.112548E-04,0.616439E-05,0.611070E-05,0.639505E-03, | |
23540 | &-.335607E-06,0.253856E-01,0.131470E-01,0.488993E-05,0.994021E-05, | |
23541 | &0.494070E-05,0.488993E-05,0.534131E-03,-.267652E-06,0.215026E-01, | |
23542 | &0.109271E-01,0.391276E-05,0.875190E-05,0.395967E-05,0.391276E-05, | |
23543 | &0.445478E-03,-.205292E-06,0.181648E-01,0.906007E-02,0.312720E-05, | |
23544 | &0.767418E-05,0.316978E-05,0.312720E-05,0.366232E-03,-.154024E-06, | |
23545 | &0.153041E-01,0.749382E-02,0.249633E-05,0.670002E-05,0.253440E-05, | |
23546 | &0.249633E-05,0.297435E-03,-.112673E-06,0.128596E-01,0.618334E-02, | |
23547 | &0.199074E-05,0.582360E-05,0.202435E-05,0.199074E-05,0.242305E-03, | |
23548 | &-.794410E-07,0.107770E-01,0.508977E-02,0.158457E-05,0.503733E-05, | |
23549 | &0.161393E-05,0.158457E-05,0.196927E-03,-.546702E-07,0.900806E-02, | |
23550 | &0.417964E-02,0.125888E-05,0.433619E-05,0.128428E-05,0.125888E-05, | |
23551 | &0.158171E-03,-.364714E-07,0.751006E-02,0.342418E-02,0.998674E-06/ | |
23552 | DATA (DL(K),K= 3316, 3400) / | |
23553 | &0.371518E-05,0.102046E-05,0.998674E-06,0.126865E-03,-.228706E-07, | |
23554 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23555 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23556 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23557 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23558 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23559 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23560 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23561 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23562 | &0.496787E-01,0.236961E-01,0.607312E-05,0.607312E-05,0.607312E-05, | |
23563 | &0.607312E-05,0.415108E-03,-.140523E-17,0.420445E-01,0.196196E-01, | |
23564 | &0.443589E-05,0.603481E-05,0.444683E-05,0.443589E-05,0.444425E-03, | |
23565 | &-.375397E-06,0.355108E-01,0.162223E-01,0.321766E-05,0.587645E-05, | |
23566 | &0.323504E-05,0.321766E-05,0.432635E-03,-.593989E-06,0.299148E-01, | |
23567 | &0.133836E-01,0.231504E-05,0.562250E-05,0.233581E-05,0.231504E-05, | |
23568 | &0.395801E-03,-.699904E-06,0.251339E-01,0.110157E-01,0.164651E-05, | |
23569 | &0.526880E-05,0.166853E-05,0.164651E-05,0.344925E-03,-.733095E-06/ | |
23570 | DATA (DL(K),K= 3401, 3485) / | |
23571 | &0.210605E-01,0.904539E-02,0.115940E-05,0.485739E-05,0.118122E-05, | |
23572 | &0.115940E-05,0.294439E-03,-.715193E-06,0.175989E-01,0.740944E-02, | |
23573 | &0.808365E-06,0.441709E-05,0.829075E-06,0.808365E-06,0.249093E-03, | |
23574 | &-.665420E-06,0.146656E-01,0.605433E-02,0.555563E-06,0.396078E-05, | |
23575 | &0.574607E-06,0.555563E-06,0.205675E-03,-.600648E-06,0.121872E-01, | |
23576 | &0.493466E-02,0.375914E-06,0.350822E-05,0.393011E-06,0.375914E-06, | |
23577 | &0.166757E-03,-.529210E-06,0.100993E-01,0.401191E-02,0.250032E-06, | |
23578 | &0.307359E-05,0.265094E-06,0.250032E-06,0.135196E-03,-.456996E-06, | |
23579 | &0.834582E-02,0.325348E-02,0.162261E-06,0.266488E-05,0.175325E-06, | |
23580 | &0.162261E-06,0.108862E-03,-.388821E-06,0.687767E-02,0.263179E-02, | |
23581 | &0.102273E-06,0.228913E-05,0.113453E-06,0.102273E-06,0.865539E-04, | |
23582 | &-.326325E-06,0.565221E-02,0.212357E-02,0.620694E-07,0.194975E-05, | |
23583 | &0.715290E-07,0.620694E-07,0.687156E-04,-.270547E-06,0.463248E-02, | |
23584 | &0.170926E-02,0.351992E-07,0.164711E-05,0.431226E-07,0.351992E-07, | |
23585 | &0.543744E-04,-.222379E-06,0.378655E-02,0.137242E-02,0.178902E-07, | |
23586 | &0.138124E-05,0.244675E-07,0.178902E-07,0.426626E-04,-.181158E-06, | |
23587 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23588 | DATA (DL(K),K= 3486, 3570) / | |
23589 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23590 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23591 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23592 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23593 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23594 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23595 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23596 | &0.286141E-01,0.102357E-01,0.105702E-05,0.105702E-05,0.105702E-05, | |
23597 | &0.105702E-05,0.963318E-04,0.591070E-18,0.236608E-01,0.827483E-02, | |
23598 | &0.548552E-06,0.163293E-05,0.551993E-06,0.548552E-06,0.133058E-03, | |
23599 | &-.268677E-06,0.195282E-01,0.668247E-02,0.238780E-06,0.183459E-05, | |
23600 | &0.243802E-06,0.238780E-06,0.135119E-03,-.393414E-06,0.160742E-01, | |
23601 | &0.538444E-02,0.599864E-07,0.183277E-05,0.655085E-07,0.599864E-07, | |
23602 | &0.124554E-03,-.428349E-06,0.131940E-01,0.432750E-02,-.392825E-07, | |
23603 | &0.172071E-05,-.338391E-07,-.392825E-07,0.111121E-03,-.415550E-06, | |
23604 | &0.107996E-01,0.346954E-02,-.875089E-07,0.154604E-05,-.824926E-07, | |
23605 | &-.875089E-07,0.941854E-04,-.376855E-06,0.881435E-02,0.277463E-02/ | |
23606 | DATA (DL(K),K= 3571, 3655) / | |
23607 | &-.103962E-06,0.135013E-05,-.995446E-07,-.103962E-06,0.772195E-04, | |
23608 | &-.326008E-06,0.717317E-02,0.221313E-02,-.102844E-06,0.115335E-05, | |
23609 | &-.990733E-07,-.102844E-06,0.626565E-04,-.272858E-06,0.582050E-02, | |
23610 | &0.176061E-02,-.929503E-07,0.967229E-06,-.898064E-07,-.929503E-07, | |
23611 | &0.499930E-04,-.222828E-06,0.470908E-02,0.139692E-02,-.791495E-07, | |
23612 | &0.800414E-06,-.765797E-07,-.791495E-07,0.394181E-04,-.178141E-06, | |
23613 | &0.379875E-02,0.110542E-02,-.647230E-07,0.655119E-06,-.626567E-07, | |
23614 | &-.647230E-07,0.309999E-04,-.140000E-06,0.305549E-02,0.872447E-03, | |
23615 | &-.515215E-07,0.530834E-06,-.498829E-07,-.515215E-07,0.240354E-04, | |
23616 | &-.108633E-06,0.245058E-02,0.686769E-03,-.400234E-07,0.426835E-06, | |
23617 | &-.387401E-07,-.400234E-07,0.184613E-04,-.832544E-07,0.195984E-02, | |
23618 | &0.539209E-03,-.304312E-07,0.341169E-06,-.294373E-07,-.304312E-07, | |
23619 | &0.143512E-04,-.630818E-07,0.156297E-02,0.422273E-03,-.228633E-07, | |
23620 | &0.271199E-06,-.221014E-07,-.228633E-07,0.110898E-04,-.474683E-07, | |
23621 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23622 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23623 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23624 | DATA (DL(K),K= 3656, 3740) / | |
23625 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23626 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23627 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23628 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23629 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23630 | &0.129345E-01,0.308444E-02,0.903693E-07,0.903693E-07,0.903693E-07, | |
23631 | &0.903693E-07,0.123538E-04,-.166230E-18,0.103598E-01,0.241354E-02, | |
23632 | &0.155648E-06,-.205296E-06,0.154889E-06,0.155648E-06,0.267249E-04, | |
23633 | &0.880707E-07,0.828507E-02,0.188764E-02,0.176333E-06,-.341498E-06, | |
23634 | &0.175220E-06,0.176333E-06,0.306432E-04,0.125718E-06,0.660736E-02, | |
23635 | &0.147304E-02,0.173444E-06,-.383695E-06,0.172215E-06,0.173444E-06, | |
23636 | &0.280787E-04,0.135578E-06,0.525320E-02,0.114618E-02,0.158651E-06, | |
23637 | &-.373371E-06,0.157437E-06,0.158651E-06,0.243526E-04,0.130412E-06, | |
23638 | &0.416429E-02,0.889584E-03,0.137131E-06,-.333468E-06,0.136012E-06, | |
23639 | &0.137131E-06,0.203463E-04,0.116115E-06,0.329102E-02,0.688580E-03, | |
23640 | &0.113839E-06,-.280874E-06,0.112853E-06,0.113839E-06,0.161038E-04, | |
23641 | &0.982305E-07,0.259282E-02,0.531508E-03,0.914374E-07,-.225427E-06/ | |
23642 | DATA (DL(K),K= 3741, 3825) / | |
23643 | &0.905971E-07,0.914374E-07,0.125639E-04,0.798741E-07,0.203641E-02, | |
23644 | &0.409120E-03,0.709595E-07,-.173123E-06,0.702607E-07,0.709595E-07, | |
23645 | &0.979247E-05,0.624138E-07,0.159441E-02,0.314027E-03,0.532256E-07, | |
23646 | &-.127272E-06,0.526566E-07,0.532256E-07,0.741899E-05,0.469253E-07, | |
23647 | &0.124447E-02,0.240357E-03,0.385509E-07,-.888851E-07,0.380956E-07, | |
23648 | &0.385509E-07,0.554070E-05,0.339174E-07,0.968328E-03,0.183454E-03, | |
23649 | &0.267272E-07,-.580277E-07,0.263687E-07,0.267272E-07,0.420032E-05, | |
23650 | &0.233280E-07,0.751159E-03,0.139632E-03,0.174605E-07,-.342016E-07, | |
23651 | &0.171822E-07,0.174605E-07,0.315522E-05,0.149727E-07,0.580936E-03, | |
23652 | &0.105986E-03,0.104515E-07,-.164567E-07,0.102383E-07,0.104515E-07, | |
23653 | &0.230829E-05,0.863527E-08,0.447955E-03,0.802293E-04,0.531954E-08, | |
23654 | &-.376312E-08,0.515829E-08,0.531954E-08,0.170771E-05,0.399662E-08, | |
23655 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23656 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23657 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23658 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23659 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23660 | DATA (DL(K),K= 3826, 3910) / | |
23661 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23662 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23663 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23664 | &0.324478E-02,0.386879E-03,0.135983E-08,0.135983E-08,0.135983E-08, | |
23665 | &0.135983E-08,0.371787E-06,-.274599E-19,0.246219E-02,0.286505E-03, | |
23666 | &-.106852E-06,0.327611E-06,-.106589E-06,-.106852E-06,0.231631E-05, | |
23667 | &-.107814E-06,0.186777E-02,0.212413E-03,-.161566E-06,0.492001E-06, | |
23668 | &-.161179E-06,-.161566E-06,0.311589E-05,-.162249E-06,0.141322E-02, | |
23669 | &0.157212E-03,-.183398E-06,0.557106E-06,-.182972E-06,-.183398E-06, | |
23670 | &0.267943E-05,-.183884E-06,0.106518E-02,0.115892E-03,-.185231E-06, | |
23671 | &0.562185E-06,-.184809E-06,-.185231E-06,0.203027E-05,-.185573E-06, | |
23672 | &0.800350E-03,0.851995E-04,-.174680E-06,0.530096E-06,-.174290E-06, | |
23673 | &-.174680E-06,0.165870E-05,-.174922E-06,0.599444E-03,0.624676E-04, | |
23674 | &-.157644E-06,0.478420E-06,-.157300E-06,-.157644E-06,0.130112E-05, | |
23675 | &-.157815E-06,0.447433E-03,0.456556E-04,-.137838E-06,0.418429E-06, | |
23676 | &-.137543E-06,-.137838E-06,0.903220E-06,-.137958E-06,0.332836E-03, | |
23677 | &0.332643E-04,-.117616E-06,0.357179E-06,-.117368E-06,-.117616E-06/ | |
23678 | DATA (DL(K),K= 3911, 3995) / | |
23679 | &0.636187E-06,-.117699E-06,0.246754E-03,0.241622E-04,-.984560E-07, | |
23680 | &0.299077E-06,-.982529E-07,-.984560E-07,0.481221E-06,-.985144E-07, | |
23681 | &0.182315E-03,0.174961E-04,-.811089E-07,0.246465E-06,-.809446E-07, | |
23682 | &-.811089E-07,0.342859E-06,-.811495E-07,0.134250E-03,0.126299E-04, | |
23683 | &-.659052E-07,0.200354E-06,-.657742E-07,-.659052E-07,0.227840E-06, | |
23684 | &-.659334E-07,0.985288E-04,0.908931E-05,-.529252E-07,0.160947E-06, | |
23685 | &-.528218E-07,-.529252E-07,0.161641E-06,-.529447E-07,0.720750E-04, | |
23686 | &0.652153E-05,-.420621E-07,0.127943E-06,-.419814E-07,-.420621E-07, | |
23687 | &0.119540E-06,-.420756E-07,0.525538E-04,0.466527E-05,-.331141E-07, | |
23688 | &0.100758E-06,-.330516E-07,-.331141E-07,0.808991E-07,-.331233E-07, | |
23689 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23690 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23691 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23692 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23693 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23694 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23695 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23696 | DATA (DL(K),K= 3996, 4000) / | |
23697 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
23698 | C | |
23699 | ANS = 0. | |
23700 | IF (X.GT.0.9985) RETURN | |
23701 | IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN | |
23702 | C | |
23703 | IS = S/DELTA+1 | |
23704 | IS1 = IS+1 | |
23705 | DO 1 L=1,25 | |
23706 | KL = L+NDRV*25 | |
23707 | F1(L) = GF(I,IS,KL) | |
23708 | F2(L) = GF(I,IS1,KL) | |
23709 | 1 CONTINUE | |
23710 | A1 = DT_CKMTFF(X,F1) | |
23711 | A2 = DT_CKMTFF(X,F2) | |
23712 | C A1=ALOG(A1) | |
23713 | C A2=ALOG(A2) | |
23714 | S1 = (IS-1)*DELTA | |
23715 | S2 = S1+DELTA | |
23716 | ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1) | |
23717 | C ANS=EXP(ANS) | |
23718 | RETURN | |
23719 | END | |
23720 | C | |
23721 | C | |
23722 | ||
23723 | *$ CREATE DT_CKMTPR.FOR | |
23724 | *COPY DT_CKMTPR | |
23725 | SUBROUTINE DT_CKMTPR(I,NDRV,X,S,ANS) | |
23726 | C | |
23727 | C********************************************************************** | |
23728 | C Proton - PDFs | |
23729 | C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc | |
23730 | C ANS = PDF(I) | |
23731 | C This version by S. Roesler, 31.01.96 | |
23732 | C********************************************************************** | |
23733 | ||
23734 | SAVE | |
23735 | DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000) | |
23736 | EQUIVALENCE (GF(1,1,1),DL(1)) | |
23737 | DATA DELTA/.10/ | |
23738 | C | |
23739 | DATA (DL(K),K= 1, 85) / | |
23740 | &0.367759E+00,0.350609E+00,0.325356E+00,0.325356E+00,0.325356E+00, | |
23741 | &0.325356E+00,0.533117E+01,0.138778E-16,0.427988E+00,0.409718E+00, | |
23742 | &0.382948E+00,0.382920E+00,0.382933E+00,0.382948E+00,0.686279E+01, | |
23743 | &0.611113E-01,0.494752E+00,0.475328E+00,0.447011E+00,0.446959E+00, | |
23744 | &0.446984E+00,0.447011E+00,0.855688E+01,0.128659E+00,0.568248E+00, | |
23745 | &0.547637E+00,0.517743E+00,0.517671E+00,0.517705E+00,0.517743E+00, | |
23746 | &0.104074E+02,0.202846E+00,0.648622E+00,0.626792E+00,0.595289E+00, | |
23747 | &0.595201E+00,0.595244E+00,0.595289E+00,0.124065E+02,0.283819E+00, | |
23748 | &0.735974E+00,0.712890E+00,0.679748E+00,0.679648E+00,0.679696E+00, | |
23749 | &0.679748E+00,0.145441E+02,0.371679E+00,0.830359E+00,0.805987E+00, | |
23750 | &0.771173E+00,0.771066E+00,0.771119E+00,0.771173E+00,0.168081E+02, | |
23751 | &0.466485E+00,0.931778E+00,0.906084E+00,0.869566E+00,0.869456E+00, | |
23752 | &0.869511E+00,0.869566E+00,0.191850E+02,0.568240E+00,0.104018E+01, | |
23753 | &0.101313E+01,0.974873E+00,0.974763E+00,0.974819E+00,0.974873E+00, | |
23754 | &0.216593E+02,0.676890E+00,0.115544E+01,0.112700E+01,0.108698E+01, | |
23755 | &0.108687E+01,0.108693E+01,0.108698E+01,0.242146E+02,0.792321E+00, | |
23756 | &0.127738E+01,0.124751E+01,0.120570E+01,0.120560E+01,0.120565E+01/ | |
23757 | DATA (DL(K),K= 86, 170) / | |
23758 | &0.120570E+01,0.268333E+02,0.914356E+00,0.140577E+01,0.137444E+01, | |
23759 | &0.133079E+01,0.133070E+01,0.133075E+01,0.133079E+01,0.294970E+02, | |
23760 | &0.104275E+01,0.154028E+01,0.150745E+01,0.146194E+01,0.146187E+01, | |
23761 | &0.146192E+01,0.146194E+01,0.321867E+02,0.117720E+01,0.168054E+01, | |
23762 | &0.164619E+01,0.159879E+01,0.159874E+01,0.159877E+01,0.159879E+01, | |
23763 | &0.348836E+02,0.131732E+01,0.182613E+01,0.179020E+01,0.174088E+01, | |
23764 | &0.174086E+01,0.174088E+01,0.174088E+01,0.375685E+02,0.146269E+01, | |
23765 | &0.197653E+01,0.193901E+01,0.188774E+01,0.188774E+01,0.188775E+01, | |
23766 | &0.188774E+01,0.402228E+02,0.161282E+01,0.213121E+01,0.209205E+01, | |
23767 | &0.203880E+01,0.203884E+01,0.203884E+01,0.203880E+01,0.428285E+02, | |
23768 | &0.176714E+01,0.228955E+01,0.224873E+01,0.219348E+01,0.219355E+01, | |
23769 | &0.219353E+01,0.219348E+01,0.453682E+02,0.192507E+01,0.245093E+01, | |
23770 | &0.240840E+01,0.235113E+01,0.235123E+01,0.235120E+01,0.235113E+01, | |
23771 | &0.478258E+02,0.208597E+01,0.000000E+00,0.000000E+00,0.000000E+00, | |
23772 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23773 | &0.349839E+00,0.324128E+00,0.286363E+00,0.286363E+00,0.286363E+00, | |
23774 | &0.286363E+00,0.469694E+01,0.000000E+00,0.398361E+00,0.371065E+00/ | |
23775 | DATA (DL(K),K= 171, 255) / | |
23776 | &0.331239E+00,0.331213E+00,0.331227E+00,0.331239E+00,0.586152E+01, | |
23777 | &0.481683E-01,0.451010E+00,0.422096E+00,0.380182E+00,0.380137E+00, | |
23778 | &0.380161E+00,0.380182E+00,0.711349E+01,0.100378E+00,0.507782E+00, | |
23779 | &0.477215E+00,0.433187E+00,0.433128E+00,0.433160E+00,0.433187E+00, | |
23780 | &0.844371E+01,0.156627E+00,0.568644E+00,0.536390E+00,0.490220E+00, | |
23781 | &0.490152E+00,0.490190E+00,0.490220E+00,0.984291E+01,0.216886E+00, | |
23782 | &0.633517E+00,0.599543E+00,0.551204E+00,0.551133E+00,0.551174E+00, | |
23783 | &0.551204E+00,0.113005E+02,0.281079E+00,0.702295E+00,0.666565E+00, | |
23784 | &0.616031E+00,0.615963E+00,0.616004E+00,0.616031E+00,0.128050E+02, | |
23785 | &0.349101E+00,0.774832E+00,0.737311E+00,0.684556E+00,0.684495E+00, | |
23786 | &0.684535E+00,0.684556E+00,0.143447E+02,0.420809E+00,0.850945E+00, | |
23787 | &0.811598E+00,0.756596E+00,0.756547E+00,0.756583E+00,0.756596E+00, | |
23788 | &0.159073E+02,0.496022E+00,0.930413E+00,0.889207E+00,0.831933E+00, | |
23789 | &0.831901E+00,0.831931E+00,0.831933E+00,0.174801E+02,0.574524E+00, | |
23790 | &0.101298E+01,0.969882E+00,0.910312E+00,0.910301E+00,0.910324E+00, | |
23791 | &0.910312E+00,0.190508E+02,0.656061E+00,0.109836E+01,0.105333E+01, | |
23792 | &0.991445E+00,0.991459E+00,0.991471E+00,0.991445E+00,0.206070E+02/ | |
23793 | DATA (DL(K),K= 256, 340) / | |
23794 | &0.740345E+00,0.118622E+01,0.113923E+01,0.107501E+01,0.107505E+01, | |
23795 | &0.107505E+01,0.107501E+01,0.221368E+02,0.827056E+00,0.127622E+01, | |
23796 | &0.122724E+01,0.116065E+01,0.116073E+01,0.116072E+01,0.116065E+01, | |
23797 | &0.236287E+02,0.915845E+00,0.136797E+01,0.131696E+01,0.124800E+01, | |
23798 | &0.124812E+01,0.124809E+01,0.124800E+01,0.250721E+02,0.100634E+01, | |
23799 | &0.146107E+01,0.140801E+01,0.133666E+01,0.133681E+01,0.133677E+01, | |
23800 | &0.133666E+01,0.264571E+02,0.109813E+01,0.155511E+01,0.149996E+01, | |
23801 | &0.142621E+01,0.142641E+01,0.142634E+01,0.142621E+01,0.277747E+02, | |
23802 | &0.119081E+01,0.164964E+01,0.159239E+01,0.151622E+01,0.151646E+01, | |
23803 | &0.151638E+01,0.151622E+01,0.290168E+02,0.128396E+01,0.174424E+01, | |
23804 | &0.168485E+01,0.160626E+01,0.160655E+01,0.160645E+01,0.160626E+01, | |
23805 | &0.301765E+02,0.137713E+01,0.000000E+00,0.000000E+00,0.000000E+00, | |
23806 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23807 | &0.345345E+00,0.306823E+00,0.250518E+00,0.250518E+00,0.250518E+00, | |
23808 | &0.250518E+00,0.411726E+01,-.138778E-16,0.384210E+00,0.343514E+00, | |
23809 | &0.284500E+00,0.284487E+00,0.284496E+00,0.284500E+00,0.496835E+01, | |
23810 | &0.371582E-01,0.425419E+00,0.382518E+00,0.320782E+00,0.320762E+00/ | |
23811 | DATA (DL(K),K= 341, 425) / | |
23812 | &0.320777E+00,0.320782E+00,0.585504E+01,0.765988E-01,0.468853E+00, | |
23813 | &0.423717E+00,0.359246E+00,0.359226E+00,0.359243E+00,0.359246E+00, | |
23814 | &0.676824E+01,0.118207E+00,0.514392E+00,0.466990E+00,0.399771E+00, | |
23815 | &0.399758E+00,0.399775E+00,0.399771E+00,0.769967E+01,0.161865E+00, | |
23816 | &0.561883E+00,0.512186E+00,0.442209E+00,0.442208E+00,0.442222E+00, | |
23817 | &0.442209E+00,0.864071E+01,0.207426E+00,0.611162E+00,0.559140E+00, | |
23818 | &0.486395E+00,0.486411E+00,0.486420E+00,0.486395E+00,0.958280E+01, | |
23819 | &0.254727E+00,0.662044E+00,0.607667E+00,0.532145E+00,0.532185E+00, | |
23820 | &0.532185E+00,0.532145E+00,0.105176E+02,0.303587E+00,0.714325E+00, | |
23821 | &0.657566E+00,0.579261E+00,0.579328E+00,0.579318E+00,0.579261E+00, | |
23822 | &0.114370E+02,0.353808E+00,0.767786E+00,0.708618E+00,0.627526E+00, | |
23823 | &0.627625E+00,0.627603E+00,0.627526E+00,0.123333E+02,0.405174E+00, | |
23824 | &0.822195E+00,0.760591E+00,0.676711E+00,0.676846E+00,0.676810E+00, | |
23825 | &0.676711E+00,0.131994E+02,0.457458E+00,0.877307E+00,0.813242E+00, | |
23826 | &0.726575E+00,0.726750E+00,0.726697E+00,0.726575E+00,0.140286E+02, | |
23827 | &0.510420E+00,0.932865E+00,0.866317E+00,0.776867E+00,0.777085E+00, | |
23828 | &0.777015E+00,0.776867E+00,0.148150E+02,0.563809E+00,0.988608E+00/ | |
23829 | DATA (DL(K),K= 426, 510) / | |
23830 | &0.919556E+00,0.827330E+00,0.827594E+00,0.827505E+00,0.827330E+00, | |
23831 | &0.155533E+02,0.617368E+00,0.104427E+01,0.972694E+00,0.877703E+00, | |
23832 | &0.878016E+00,0.877907E+00,0.877703E+00,0.162391E+02,0.670837E+00, | |
23833 | &0.109958E+01,0.102547E+01,0.927723E+00,0.928088E+00,0.927957E+00, | |
23834 | &0.927723E+00,0.168687E+02,0.723954E+00,0.115428E+01,0.107761E+01, | |
23835 | &0.977132E+00,0.977550E+00,0.977397E+00,0.977132E+00,0.174391E+02, | |
23836 | &0.776458E+00,0.120809E+01,0.112886E+01,0.102567E+01,0.102615E+01, | |
23837 | &0.102597E+01,0.102567E+01,0.179481E+02,0.828097E+00,0.126078E+01, | |
23838 | &0.117898E+01,0.107310E+01,0.107363E+01,0.107343E+01,0.107310E+01, | |
23839 | &0.183942E+02,0.878621E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23840 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23841 | &0.357586E+00,0.299938E+00,0.216504E+00,0.216504E+00,0.216504E+00, | |
23842 | &0.216504E+00,0.357260E+01,-.277556E-16,0.388529E+00,0.327984E+00, | |
23843 | &0.241161E+00,0.241168E+00,0.241168E+00,0.241161E+00,0.415893E+01, | |
23844 | &0.278429E-01,0.420472E+00,0.357015E+00,0.266823E+00,0.266844E+00, | |
23845 | &0.266842E+00,0.266823E+00,0.474689E+01,0.566783E-01,0.453271E+00, | |
23846 | &0.386886E+00,0.293349E+00,0.293389E+00,0.293381E+00,0.293349E+00/ | |
23847 | DATA (DL(K),K= 511, 595) / | |
23848 | &0.532982E+01,0.863668E-01,0.486793E+00,0.417464E+00,0.320608E+00, | |
23849 | &0.320673E+00,0.320657E+00,0.320608E+00,0.590219E+01,0.116779E+00, | |
23850 | &0.520887E+00,0.448601E+00,0.348454E+00,0.348549E+00,0.348523E+00, | |
23851 | &0.348454E+00,0.645868E+01,0.147773E+00,0.555403E+00,0.480149E+00, | |
23852 | &0.376740E+00,0.376870E+00,0.376831E+00,0.376740E+00,0.699440E+01, | |
23853 | &0.179201E+00,0.590183E+00,0.511950E+00,0.405314E+00,0.405482E+00, | |
23854 | &0.405429E+00,0.405314E+00,0.750493E+01,0.210912E+00,0.625064E+00, | |
23855 | &0.543845E+00,0.434019E+00,0.434229E+00,0.434159E+00,0.434019E+00, | |
23856 | &0.798636E+01,0.242750E+00,0.659882E+00,0.575673E+00,0.462696E+00, | |
23857 | &0.462952E+00,0.462864E+00,0.462696E+00,0.843528E+01,0.274558E+00, | |
23858 | &0.694472E+00,0.607271E+00,0.491188E+00,0.491492E+00,0.491385E+00, | |
23859 | &0.491188E+00,0.884885E+01,0.306178E+00,0.728669E+00,0.638478E+00, | |
23860 | &0.519337E+00,0.519690E+00,0.519563E+00,0.519337E+00,0.922480E+01, | |
23861 | &0.337451E+00,0.762311E+00,0.669133E+00,0.546987E+00,0.547392E+00, | |
23862 | &0.547244E+00,0.546987E+00,0.956139E+01,0.368224E+00,0.795240E+00, | |
23863 | &0.699084E+00,0.573988E+00,0.574447E+00,0.574277E+00,0.573988E+00, | |
23864 | &0.985744E+01,0.398346E+00,0.827302E+00,0.728181E+00,0.600196E+00/ | |
23865 | DATA (DL(K),K= 596, 680) / | |
23866 | &0.600710E+00,0.600518E+00,0.600196E+00,0.101123E+02,0.427671E+00, | |
23867 | &0.858354E+00,0.756282E+00,0.625475E+00,0.626044E+00,0.625829E+00, | |
23868 | &0.625475E+00,0.103258E+02,0.456064E+00,0.888257E+00,0.783256E+00, | |
23869 | &0.649696E+00,0.650321E+00,0.650083E+00,0.649696E+00,0.104982E+02, | |
23870 | &0.483395E+00,0.916887E+00,0.808981E+00,0.672742E+00,0.673422E+00, | |
23871 | &0.673161E+00,0.672742E+00,0.106303E+02,0.509546E+00,0.944126E+00, | |
23872 | &0.833345E+00,0.694506E+00,0.695243E+00,0.694958E+00,0.694506E+00, | |
23873 | &0.107231E+02,0.534410E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23874 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23875 | &0.390721E+00,0.304671E+00,0.182562E+00,0.182562E+00,0.182562E+00, | |
23876 | &0.182562E+00,0.303699E+01,0.693889E-17,0.414806E+00,0.325059E+00, | |
23877 | &0.199103E+00,0.199133E+00,0.199124E+00,0.199103E+00,0.339971E+01, | |
23878 | &0.198528E-01,0.438929E+00,0.345508E+00,0.215797E+00,0.215862E+00, | |
23879 | &0.215842E+00,0.215797E+00,0.374624E+01,0.398420E-01,0.462973E+00, | |
23880 | &0.365903E+00,0.232531E+00,0.232635E+00,0.232601E+00,0.232531E+00, | |
23881 | &0.407322E+01,0.598565E-01,0.486835E+00,0.386142E+00,0.249208E+00, | |
23882 | &0.249352E+00,0.249304E+00,0.249208E+00,0.437817E+01,0.797987E-01/ | |
23883 | DATA (DL(K),K= 681, 765) / | |
23884 | &0.510407E+00,0.406123E+00,0.265725E+00,0.265913E+00,0.265849E+00, | |
23885 | &0.265725E+00,0.465901E+01,0.995694E-01,0.533588E+00,0.425746E+00, | |
23886 | &0.281986E+00,0.282220E+00,0.282139E+00,0.281986E+00,0.491410E+01, | |
23887 | &0.119072E+00,0.556274E+00,0.444912E+00,0.297897E+00,0.298178E+00, | |
23888 | &0.298079E+00,0.297897E+00,0.514220E+01,0.138212E+00,0.578369E+00, | |
23889 | &0.463528E+00,0.313366E+00,0.313696E+00,0.313578E+00,0.313366E+00, | |
23890 | &0.534249E+01,0.156900E+00,0.599777E+00,0.481503E+00,0.328308E+00, | |
23891 | &0.328688E+00,0.328549E+00,0.328308E+00,0.551456E+01,0.175048E+00, | |
23892 | &0.620409E+00,0.498752E+00,0.342642E+00,0.343071E+00,0.342913E+00, | |
23893 | &0.342642E+00,0.565833E+01,0.192575E+00,0.640181E+00,0.515196E+00, | |
23894 | &0.356292E+00,0.356770E+00,0.356592E+00,0.356292E+00,0.577410E+01, | |
23895 | &0.209407E+00,0.659017E+00,0.530764E+00,0.369190E+00,0.369718E+00, | |
23896 | &0.369519E+00,0.369190E+00,0.586243E+01,0.225474E+00,0.676845E+00, | |
23897 | &0.545389E+00,0.381275E+00,0.381852E+00,0.381633E+00,0.381275E+00, | |
23898 | &0.592421E+01,0.240714E+00,0.693604E+00,0.559015E+00,0.392493E+00, | |
23899 | &0.393118E+00,0.392880E+00,0.392493E+00,0.596052E+01,0.255072E+00, | |
23900 | &0.709239E+00,0.571593E+00,0.402799E+00,0.403472E+00,0.403213E+00/ | |
23901 | DATA (DL(K),K= 766, 850) / | |
23902 | &0.402799E+00,0.597267E+01,0.268502E+00,0.723703E+00,0.583081E+00, | |
23903 | &0.412157E+00,0.412875E+00,0.412597E+00,0.412157E+00,0.596211E+01, | |
23904 | &0.280966E+00,0.736960E+00,0.593447E+00,0.420536E+00,0.421299E+00, | |
23905 | &0.421002E+00,0.420536E+00,0.593045E+01,0.292434E+00,0.748980E+00, | |
23906 | &0.602669E+00,0.427918E+00,0.428723E+00,0.428408E+00,0.427918E+00, | |
23907 | &0.587934E+01,0.302884E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23908 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23909 | &0.448390E+00,0.320678E+00,0.146415E+00,0.146415E+00,0.146415E+00, | |
23910 | &0.146415E+00,0.247594E+01,0.000000E+00,0.465760E+00,0.333734E+00, | |
23911 | &0.155974E+00,0.156013E+00,0.156000E+00,0.155974E+00,0.265633E+01, | |
23912 | &0.130329E-01,0.482525E+00,0.346293E+00,0.165233E+00,0.165311E+00, | |
23913 | &0.165285E+00,0.165233E+00,0.281612E+01,0.257304E-01,0.498626E+00, | |
23914 | &0.358294E+00,0.174131E+00,0.174249E+00,0.174209E+00,0.174131E+00, | |
23915 | &0.295484E+01,0.380345E-01,0.514008E+00,0.369688E+00,0.182622E+00, | |
23916 | &0.182779E+00,0.182724E+00,0.182622E+00,0.307242E+01,0.498976E-01, | |
23917 | &0.528624E+00,0.380432E+00,0.190660E+00,0.190856E+00,0.190786E+00, | |
23918 | &0.190660E+00,0.316911E+01,0.612760E-01,0.542428E+00,0.390485E+00/ | |
23919 | DATA (DL(K),K= 851, 935) / | |
23920 | &0.198205E+00,0.198441E+00,0.198356E+00,0.198205E+00,0.324538E+01, | |
23921 | &0.721303E-01,0.555382E+00,0.399810E+00,0.205224E+00,0.205498E+00, | |
23922 | &0.205398E+00,0.205224E+00,0.330192E+01,0.824256E-01,0.567448E+00, | |
23923 | &0.408377E+00,0.211687E+00,0.211997E+00,0.211882E+00,0.211687E+00, | |
23924 | &0.333960E+01,0.921319E-01,0.578597E+00,0.416159E+00,0.217568E+00, | |
23925 | &0.217915E+00,0.217784E+00,0.217568E+00,0.335945E+01,0.101224E+00, | |
23926 | &0.588802E+00,0.423136E+00,0.222847E+00,0.223229E+00,0.223084E+00, | |
23927 | &0.222847E+00,0.336262E+01,0.109681E+00,0.598043E+00,0.429293E+00, | |
23928 | &0.227512E+00,0.227928E+00,0.227768E+00,0.227512E+00,0.335036E+01, | |
23929 | &0.117489E+00,0.606305E+00,0.434619E+00,0.231551E+00,0.232000E+00, | |
23930 | &0.231826E+00,0.231551E+00,0.332398E+01,0.124636E+00,0.613579E+00, | |
23931 | &0.439110E+00,0.234962E+00,0.235442E+00,0.235254E+00,0.234962E+00, | |
23932 | &0.328483E+01,0.131119E+00,0.619860E+00,0.442766E+00,0.237745E+00, | |
23933 | &0.238254E+00,0.238053E+00,0.237745E+00,0.323429E+01,0.136936E+00, | |
23934 | &0.625150E+00,0.445594E+00,0.239905E+00,0.240441E+00,0.240228E+00, | |
23935 | &0.239905E+00,0.317371E+01,0.142091E+00,0.629453E+00,0.447603E+00, | |
23936 | &0.241452E+00,0.242014E+00,0.241788E+00,0.241452E+00,0.310443E+01/ | |
23937 | DATA (DL(K),K= 936, 1020) / | |
23938 | &0.146594E+00,0.632782E+00,0.448808E+00,0.242400E+00,0.242987E+00, | |
23939 | &0.242749E+00,0.242400E+00,0.302775E+01,0.150456E+00,0.635151E+00, | |
23940 | &0.449228E+00,0.242767E+00,0.243376E+00,0.243127E+00,0.242767E+00, | |
23941 | &0.294491E+01,0.153694E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23942 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23943 | &0.528765E+00,0.341825E+00,0.105823E+00,0.105823E+00,0.105823E+00, | |
23944 | &0.105823E+00,0.185069E+01,-.138778E-16,0.538124E+00,0.347118E+00, | |
23945 | &0.109762E+00,0.109780E+00,0.109774E+00,0.109762E+00,0.189644E+01, | |
23946 | &0.738880E-02,0.546541E+00,0.351712E+00,0.113300E+00,0.113336E+00, | |
23947 | &0.113324E+00,0.113300E+00,0.192700E+01,0.143076E-01,0.554014E+00, | |
23948 | &0.355607E+00,0.116431E+00,0.116485E+00,0.116466E+00,0.116431E+00, | |
23949 | &0.194356E+01,0.207515E-01,0.560546E+00,0.358805E+00,0.119150E+00, | |
23950 | &0.119222E+00,0.119196E+00,0.119150E+00,0.194722E+01,0.267179E-01, | |
23951 | &0.566139E+00,0.361311E+00,0.121459E+00,0.121549E+00,0.121515E+00, | |
23952 | &0.121459E+00,0.193921E+01,0.322084E-01,0.570802E+00,0.363134E+00, | |
23953 | &0.123359E+00,0.123467E+00,0.123426E+00,0.123359E+00,0.192071E+01, | |
23954 | &0.372262E-01,0.574542E+00,0.364286E+00,0.124858E+00,0.124983E+00/ | |
23955 | DATA (DL(K),K= 1021, 1105) / | |
23956 | &0.124933E+00,0.124858E+00,0.189295E+01,0.417774E-01,0.577372E+00, | |
23957 | &0.364779E+00,0.125961E+00,0.126103E+00,0.126046E+00,0.125961E+00, | |
23958 | &0.185710E+01,0.458703E-01,0.579307E+00,0.364629E+00,0.126681E+00, | |
23959 | &0.126839E+00,0.126774E+00,0.126681E+00,0.181432E+01,0.495154E-01, | |
23960 | &0.580363E+00,0.363857E+00,0.127029E+00,0.127202E+00,0.127130E+00, | |
23961 | &0.127029E+00,0.176571E+01,0.527252E-01,0.580561E+00,0.362483E+00, | |
23962 | &0.127020E+00,0.127208E+00,0.127128E+00,0.127020E+00,0.171231E+01, | |
23963 | &0.555142E-01,0.579923E+00,0.360529E+00,0.126670E+00,0.126872E+00, | |
23964 | &0.126785E+00,0.126670E+00,0.165511E+01,0.578985E-01,0.578474E+00, | |
23965 | &0.358021E+00,0.125998E+00,0.126213E+00,0.126119E+00,0.125998E+00, | |
23966 | &0.159501E+01,0.598958E-01,0.576241E+00,0.354987E+00,0.125022E+00, | |
23967 | &0.125249E+00,0.125148E+00,0.125022E+00,0.153284E+01,0.615248E-01, | |
23968 | &0.573252E+00,0.351453E+00,0.123762E+00,0.124000E+00,0.123893E+00, | |
23969 | &0.123762E+00,0.146934E+01,0.628056E-01,0.569539E+00,0.347450E+00, | |
23970 | &0.122240E+00,0.122488E+00,0.122375E+00,0.122240E+00,0.140517E+01, | |
23971 | &0.637587E-01,0.565134E+00,0.343008E+00,0.120476E+00,0.120733E+00, | |
23972 | &0.120615E+00,0.120476E+00,0.134093E+01,0.644054E-01,0.560071E+00/ | |
23973 | DATA (DL(K),K= 1106, 1190) / | |
23974 | &0.338158E+00,0.118493E+00,0.118758E+00,0.118635E+00,0.118493E+00, | |
23975 | &0.127712E+01,0.647671E-01,0.000000E+00,0.000000E+00,0.000000E+00, | |
23976 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
23977 | &0.584093E+00,0.349173E+00,0.772117E-01,0.772117E-01,0.772117E-01, | |
23978 | &0.772117E-01,0.140433E+01,0.346945E-17,0.586736E+00,0.349017E+00, | |
23979 | &0.785355E-01,0.785519E-01,0.785448E-01,0.785355E-01,0.139434E+01, | |
23980 | &0.447504E-02,0.588402E+00,0.348237E+00,0.795437E-01,0.795759E-01, | |
23981 | &0.795617E-01,0.795437E-01,0.137550E+01,0.854114E-02,0.589124E+00, | |
23982 | &0.346861E+00,0.802498E-01,0.802970E-01,0.802758E-01,0.802498E-01, | |
23983 | &0.134918E+01,0.122148E-01,0.588930E+00,0.344912E+00,0.806656E-01, | |
23984 | &0.807271E-01,0.806990E-01,0.806656E-01,0.131652E+01,0.155101E-01, | |
23985 | &0.587849E+00,0.342417E+00,0.808055E-01,0.808805E-01,0.808457E-01, | |
23986 | &0.808055E-01,0.127862E+01,0.184435E-01,0.585912E+00,0.339402E+00, | |
23987 | &0.806843E-01,0.807718E-01,0.807306E-01,0.806843E-01,0.123648E+01, | |
23988 | &0.210315E-01,0.583151E+00,0.335894E+00,0.803173E-01,0.804166E-01, | |
23989 | &0.803692E-01,0.803173E-01,0.119104E+01,0.232909E-01,0.579599E+00, | |
23990 | &0.331923E+00,0.797205E-01,0.798308E-01,0.797775E-01,0.797205E-01/ | |
23991 | DATA (DL(K),K= 1191, 1275) / | |
23992 | &0.114317E+01,0.252394E-01,0.575288E+00,0.327516E+00,0.789107E-01, | |
23993 | &0.790310E-01,0.789721E-01,0.789107E-01,0.109362E+01,0.268946E-01, | |
23994 | &0.570253E+00,0.322704E+00,0.779045E-01,0.780341E-01,0.779698E-01, | |
23995 | &0.779045E-01,0.104307E+01,0.282745E-01,0.564530E+00,0.317515E+00, | |
23996 | &0.767190E-01,0.768570E-01,0.767878E-01,0.767190E-01,0.992143E+00, | |
23997 | &0.293974E-01,0.558155E+00,0.311981E+00,0.753713E-01,0.755169E-01, | |
23998 | &0.754432E-01,0.753713E-01,0.941341E+00,0.302812E-01,0.551166E+00, | |
23999 | &0.306131E+00,0.738784E-01,0.740308E-01,0.739528E-01,0.738784E-01, | |
24000 | &0.891113E+00,0.309441E-01,0.543599E+00,0.299995E+00,0.722571E-01, | |
24001 | &0.724154E-01,0.723336E-01,0.722571E-01,0.841829E+00,0.314037E-01, | |
24002 | &0.535494E+00,0.293603E+00,0.705237E-01,0.706871E-01,0.706019E-01, | |
24003 | &0.705237E-01,0.793794E+00,0.316774E-01,0.526888E+00,0.286986E+00, | |
24004 | &0.686941E-01,0.688619E-01,0.687736E-01,0.686941E-01,0.747249E+00, | |
24005 | &0.317823E-01,0.517822E+00,0.280172E+00,0.667836E-01,0.669551E-01, | |
24006 | &0.668640E-01,0.667836E-01,0.702381E+00,0.317346E-01,0.508333E+00, | |
24007 | &0.273189E+00,0.648068E-01,0.649814E-01,0.648879E-01,0.648068E-01, | |
24008 | &0.659330E+00,0.315501E-01,0.000000E+00,0.000000E+00,0.000000E+00/ | |
24009 | DATA (DL(K),K= 1276, 1360) / | |
24010 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24011 | &0.622739E+00,0.340676E+00,0.509141E-01,0.509141E-01,0.509141E-01, | |
24012 | &0.509141E-01,0.980502E+00,-.173472E-17,0.617764E+00,0.335457E+00, | |
24013 | &0.507607E-01,0.507701E-01,0.507651E-01,0.507607E-01,0.944375E+00, | |
24014 | &0.242386E-02,0.611957E+00,0.329837E+00,0.504236E-01,0.504417E-01, | |
24015 | &0.504321E-01,0.504236E-01,0.905225E+00,0.455851E-02,0.605372E+00, | |
24016 | &0.323853E+00,0.499207E-01,0.499471E-01,0.499328E-01,0.499207E-01, | |
24017 | &0.864035E+00,0.642656E-02,0.598052E+00,0.317537E+00,0.492668E-01, | |
24018 | &0.493008E-01,0.492822E-01,0.492668E-01,0.821557E+00,0.804638E-02, | |
24019 | &0.590044E+00,0.310919E+00,0.484772E-01,0.485183E-01,0.484955E-01, | |
24020 | &0.484772E-01,0.778444E+00,0.943663E-02,0.581391E+00,0.304033E+00, | |
24021 | &0.475665E-01,0.476142E-01,0.475874E-01,0.475665E-01,0.735263E+00, | |
24022 | &0.106150E-01,0.572137E+00,0.296908E+00,0.465487E-01,0.466024E-01, | |
24023 | &0.465720E-01,0.465487E-01,0.692487E+00,0.115984E-01,0.562326E+00, | |
24024 | &0.289573E+00,0.454376E-01,0.454968E-01,0.454629E-01,0.454376E-01, | |
24025 | &0.650510E+00,0.124032E-01,0.552003E+00,0.282060E+00,0.442463E-01, | |
24026 | &0.443103E-01,0.442733E-01,0.442463E-01,0.609652E+00,0.130451E-01/ | |
24027 | DATA (DL(K),K= 1361, 1445) / | |
24028 | &0.541210E+00,0.274395E+00,0.429871E-01,0.430555E-01,0.430156E-01, | |
24029 | &0.429871E-01,0.570164E+00,0.135389E-01,0.529991E+00,0.266608E+00, | |
24030 | &0.416720E-01,0.417443E-01,0.417018E-01,0.416720E-01,0.532237E+00, | |
24031 | &0.138989E-01,0.518389E+00,0.258725E+00,0.403123E-01,0.403879E-01, | |
24032 | &0.403431E-01,0.403123E-01,0.496010E+00,0.141386E-01,0.506446E+00, | |
24033 | &0.250772E+00,0.389186E-01,0.389971E-01,0.389501E-01,0.389186E-01, | |
24034 | &0.461573E+00,0.142708E-01,0.494204E+00,0.242775E+00,0.375006E-01, | |
24035 | &0.375815E-01,0.375327E-01,0.375006E-01,0.428979E+00,0.143074E-01, | |
24036 | &0.481705E+00,0.234757E+00,0.360674E-01,0.361503E-01,0.361000E-01, | |
24037 | &0.360674E-01,0.398246E+00,0.142598E-01,0.468990E+00,0.226741E+00, | |
24038 | &0.346276E-01,0.347120E-01,0.346605E-01,0.346276E-01,0.369363E+00, | |
24039 | &0.141385E-01,0.456098E+00,0.218750E+00,0.331887E-01,0.332743E-01, | |
24040 | &0.332216E-01,0.331887E-01,0.342300E+00,0.139532E-01,0.443068E+00, | |
24041 | &0.210804E+00,0.317576E-01,0.318440E-01,0.317905E-01,0.317576E-01, | |
24042 | &0.317005E+00,0.137130E-01,0.000000E+00,0.000000E+00,0.000000E+00, | |
24043 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24044 | &0.631458E+00,0.318714E+00,0.335640E-01,0.335640E-01,0.335640E-01/ | |
24045 | DATA (DL(K),K= 1446, 1530) / | |
24046 | &0.335640E-01,0.686773E+00,0.346945E-17,0.620274E+00,0.310241E+00, | |
24047 | &0.329311E-01,0.329377E-01,0.329337E-01,0.329311E-01,0.646559E+00, | |
24048 | &0.135960E-02,0.608504E+00,0.301610E+00,0.322083E-01,0.322210E-01, | |
24049 | &0.322133E-01,0.322083E-01,0.606503E+00,0.252820E-02,0.596205E+00, | |
24050 | &0.292854E+00,0.314099E-01,0.314281E-01,0.314169E-01,0.314099E-01, | |
24051 | &0.567134E+00,0.352543E-02,0.583429E+00,0.284002E+00,0.305470E-01, | |
24052 | &0.305704E-01,0.305558E-01,0.305470E-01,0.528824E+00,0.436693E-02, | |
24053 | &0.570223E+00,0.275080E+00,0.296307E-01,0.296586E-01,0.296411E-01, | |
24054 | &0.296307E-01,0.491848E+00,0.506768E-02,0.556637E+00,0.266115E+00, | |
24055 | &0.286709E-01,0.287030E-01,0.286827E-01,0.286709E-01,0.456422E+00, | |
24056 | &0.564157E-02,0.542717E+00,0.257131E+00,0.276770E-01,0.277128E-01, | |
24057 | &0.276900E-01,0.276770E-01,0.422697E+00,0.610148E-02,0.528511E+00, | |
24058 | &0.248154E+00,0.266578E-01,0.266968E-01,0.266718E-01,0.266578E-01, | |
24059 | &0.390771E+00,0.645942E-02,0.514062E+00,0.239205E+00,0.256210E-01, | |
24060 | &0.256629E-01,0.256359E-01,0.256210E-01,0.360700E+00,0.672653E-02, | |
24061 | &0.499417E+00,0.230307E+00,0.245741E-01,0.246185E-01,0.245896E-01, | |
24062 | &0.245741E-01,0.332498E+00,0.691312E-02,0.484617E+00,0.221480E+00/ | |
24063 | DATA (DL(K),K= 1531, 1615) / | |
24064 | &0.235237E-01,0.235701E-01,0.235397E-01,0.235237E-01,0.306153E+00, | |
24065 | &0.702875E-02,0.469706E+00,0.212745E+00,0.224757E-01,0.225238E-01, | |
24066 | &0.224921E-01,0.224757E-01,0.281624E+00,0.708222E-02,0.454725E+00, | |
24067 | &0.204118E+00,0.214355E-01,0.214850E-01,0.214522E-01,0.214355E-01, | |
24068 | &0.258855E+00,0.708159E-02,0.439713E+00,0.195618E+00,0.204079E-01, | |
24069 | &0.204586E-01,0.204249E-01,0.204079E-01,0.237774E+00,0.703428E-02, | |
24070 | &0.424709E+00,0.187259E+00,0.193972E-01,0.194486E-01,0.194142E-01, | |
24071 | &0.193972E-01,0.218298E+00,0.694702E-02,0.409750E+00,0.179057E+00, | |
24072 | &0.184069E-01,0.184588E-01,0.184239E-01,0.184069E-01,0.200339E+00, | |
24073 | &0.682594E-02,0.394870E+00,0.171023E+00,0.174402E-01,0.174924E-01, | |
24074 | &0.174571E-01,0.174402E-01,0.183804E+00,0.667657E-02,0.380104E+00, | |
24075 | &0.163171E+00,0.164997E-01,0.165519E-01,0.165164E-01,0.164997E-01, | |
24076 | &0.168600E+00,0.650389E-02,0.000000E+00,0.000000E+00,0.000000E+00, | |
24077 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24078 | &0.619056E+00,0.288873E+00,0.218554E-01,0.218554E-01,0.218554E-01, | |
24079 | &0.218554E-01,0.477010E+00,-.867362E-17,0.602890E+00,0.278444E+00, | |
24080 | &0.211480E-01,0.211530E-01,0.211497E-01,0.211480E-01,0.440877E+00/ | |
24081 | DATA (DL(K),K= 1616, 1700) / | |
24082 | &0.767466E-03,0.586431E+00,0.268081E+00,0.204081E-01,0.204175E-01, | |
24083 | &0.204113E-01,0.204081E-01,0.406417E+00,0.141432E-02,0.569736E+00, | |
24084 | &0.257807E+00,0.196446E-01,0.196581E-01,0.196491E-01,0.196446E-01, | |
24085 | &0.373808E+00,0.195508E-02,0.552853E+00,0.247642E+00,0.188646E-01, | |
24086 | &0.188816E-01,0.188701E-01,0.188646E-01,0.343145E+00,0.240123E-02, | |
24087 | &0.535829E+00,0.237603E+00,0.180743E-01,0.180945E-01,0.180808E-01, | |
24088 | &0.180743E-01,0.314460E+00,0.276332E-02,0.518710E+00,0.227710E+00, | |
24089 | &0.172796E-01,0.173025E-01,0.172868E-01,0.172796E-01,0.287750E+00, | |
24090 | &0.305100E-02,0.501539E+00,0.217977E+00,0.164854E-01,0.165108E-01, | |
24091 | &0.164933E-01,0.164854E-01,0.262983E+00,0.327305E-02,0.484360E+00, | |
24092 | &0.208420E+00,0.156964E-01,0.157239E-01,0.157049E-01,0.156964E-01, | |
24093 | &0.240098E+00,0.343744E-02,0.467213E+00,0.199053E+00,0.149165E-01, | |
24094 | &0.149457E-01,0.149254E-01,0.149165E-01,0.219021E+00,0.355144E-02, | |
24095 | &0.450140E+00,0.189889E+00,0.141493E-01,0.141800E-01,0.141586E-01, | |
24096 | &0.141493E-01,0.199660E+00,0.362164E-02,0.433177E+00,0.180939E+00, | |
24097 | &0.133978E-01,0.134297E-01,0.134073E-01,0.133978E-01,0.181918E+00, | |
24098 | &0.365401E-02,0.416362E+00,0.172214E+00,0.126646E-01,0.126974E-01/ | |
24099 | DATA (DL(K),K= 1701, 1785) / | |
24100 | &0.126742E-01,0.126646E-01,0.165692E+00,0.365394E-02,0.399729E+00, | |
24101 | &0.163725E+00,0.119518E-01,0.119853E-01,0.119615E-01,0.119518E-01, | |
24102 | &0.150875E+00,0.362628E-02,0.383310E+00,0.155477E+00,0.112613E-01, | |
24103 | &0.112952E-01,0.112711E-01,0.112613E-01,0.137364E+00,0.357539E-02, | |
24104 | &0.367138E+00,0.147479E+00,0.105945E-01,0.106287E-01,0.106042E-01, | |
24105 | &0.105945E-01,0.125056E+00,0.350515E-02,0.351239E+00,0.139737E+00, | |
24106 | &0.995250E-02,0.998673E-02,0.996211E-02,0.995250E-02,0.113852E+00, | |
24107 | &0.341903E-02,0.335641E+00,0.132253E+00,0.933610E-02,0.937024E-02, | |
24108 | &0.934557E-02,0.933610E-02,0.103659E+00,0.332009E-02,0.320367E+00, | |
24109 | &0.125033E+00,0.874584E-02,0.877973E-02,0.875514E-02,0.874584E-02, | |
24110 | &0.943886E-01,0.321106E-02,0.000000E+00,0.000000E+00,0.000000E+00, | |
24111 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24112 | &0.591114E+00,0.254807E+00,0.139531E-01,0.139531E-01,0.139531E-01, | |
24113 | &0.139531E-01,0.326288E+00,0.000000E+00,0.571121E+00,0.243424E+00, | |
24114 | &0.133325E-01,0.133362E-01,0.133336E-01,0.133325E-01,0.296956E+00, | |
24115 | &0.429082E-03,0.551151E+00,0.232297E+00,0.127105E-01,0.127175E-01, | |
24116 | &0.127126E-01,0.127105E-01,0.269811E+00,0.785137E-03,0.531253E+00/ | |
24117 | DATA (DL(K),K= 1786, 1870) / | |
24118 | &0.221436E+00,0.120916E-01,0.121015E-01,0.120945E-01,0.120916E-01, | |
24119 | &0.244803E+00,0.107790E-02,0.511467E+00,0.210850E+00,0.114794E-01, | |
24120 | &0.114918E-01,0.114829E-01,0.114794E-01,0.221863E+00,0.131504E-02, | |
24121 | &0.491833E+00,0.200545E+00,0.108767E-01,0.108913E-01,0.108808E-01, | |
24122 | &0.108767E-01,0.200886E+00,0.150337E-02,0.472388E+00,0.190531E+00, | |
24123 | &0.102861E-01,0.103027E-01,0.102907E-01,0.102861E-01,0.181762E+00, | |
24124 | &0.164910E-02,0.453170E+00,0.180812E+00,0.970979E-02,0.972799E-02, | |
24125 | &0.971477E-02,0.970979E-02,0.164371E+00,0.175777E-02,0.434213E+00, | |
24126 | &0.171394E+00,0.914959E-02,0.916916E-02,0.915488E-02,0.914959E-02, | |
24127 | &0.148589E+00,0.183434E-02,0.415548E+00,0.162282E+00,0.860700E-02, | |
24128 | &0.862770E-02,0.861252E-02,0.860700E-02,0.134293E+00,0.188328E-02, | |
24129 | &0.397208E+00,0.153479E+00,0.808323E-02,0.810484E-02,0.808891E-02, | |
24130 | &0.808323E-02,0.121361E+00,0.190856E-02,0.379220E+00,0.144989E+00, | |
24131 | &0.757922E-02,0.760152E-02,0.758501E-02,0.757922E-02,0.109676E+00, | |
24132 | &0.191374E-02,0.361611E+00,0.136811E+00,0.709565E-02,0.711846E-02, | |
24133 | &0.710150E-02,0.709565E-02,0.991261E-01,0.190199E-02,0.344406E+00, | |
24134 | &0.128948E+00,0.663300E-02,0.665614E-02,0.663885E-02,0.663300E-02/ | |
24135 | DATA (DL(K),K= 1871, 1955) / | |
24136 | &0.896059E-01,0.187610E-02,0.327627E+00,0.121398E+00,0.619152E-02, | |
24137 | &0.621484E-02,0.619734E-02,0.619152E-02,0.810177E-01,0.183856E-02, | |
24138 | &0.311292E+00,0.114161E+00,0.577130E-02,0.579466E-02,0.577706E-02, | |
24139 | &0.577130E-02,0.732709E-01,0.179155E-02,0.295421E+00,0.107235E+00, | |
24140 | &0.537228E-02,0.539554E-02,0.537794E-02,0.537228E-02,0.662824E-01, | |
24141 | &0.173700E-02,0.280026E+00,0.100616E+00,0.499423E-02,0.501728E-02, | |
24142 | &0.499977E-02,0.499423E-02,0.599766E-01,0.167658E-02,0.265121E+00, | |
24143 | &0.943000E-01,0.463683E-02,0.465958E-02,0.464223E-02,0.463683E-02, | |
24144 | &0.542848E-01,0.161174E-02,0.000000E+00,0.000000E+00,0.000000E+00, | |
24145 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24146 | &0.551659E+00,0.219084E+00,0.867977E-02,0.867977E-02,0.867977E-02, | |
24147 | &0.867977E-02,0.218587E+00,-.173472E-16,0.528947E+00,0.207536E+00, | |
24148 | &0.819621E-02,0.819909E-02,0.819696E-02,0.819621E-02,0.196367E+00, | |
24149 | &0.234843E-03,0.506575E+00,0.196391E+00,0.772540E-02,0.773082E-02, | |
24150 | &0.772680E-02,0.772540E-02,0.176280E+00,0.427503E-03,0.484579E+00, | |
24151 | &0.185646E+00,0.726876E-02,0.727639E-02,0.727069E-02,0.726876E-02, | |
24152 | &0.158158E+00,0.583933E-03,0.462988E+00,0.175298E+00,0.682746E-02/ | |
24153 | DATA (DL(K),K= 1956, 2040) / | |
24154 | &0.683702E-02,0.682985E-02,0.682746E-02,0.141851E+00,0.708874E-03, | |
24155 | &0.441830E+00,0.165345E+00,0.640226E-02,0.641347E-02,0.640502E-02, | |
24156 | &0.640226E-02,0.127203E+00,0.806409E-03,0.421129E+00,0.155783E+00, | |
24157 | &0.599380E-02,0.600641E-02,0.599686E-02,0.599380E-02,0.114065E+00, | |
24158 | &0.880249E-03,0.400912E+00,0.146609E+00,0.560252E-02,0.561629E-02, | |
24159 | &0.560581E-02,0.560252E-02,0.102296E+00,0.933676E-03,0.381199E+00, | |
24160 | &0.137819E+00,0.522870E-02,0.524342E-02,0.523217E-02,0.522870E-02, | |
24161 | &0.917608E-01,0.969607E-03,0.362011E+00,0.129407E+00,0.487247E-02, | |
24162 | &0.488796E-02,0.487607E-02,0.487247E-02,0.823356E-01,0.990632E-03, | |
24163 | &0.343367E+00,0.121370E+00,0.453385E-02,0.454992E-02,0.453753E-02, | |
24164 | &0.453385E-02,0.739054E-01,0.999042E-03,0.325282E+00,0.113700E+00, | |
24165 | &0.421272E-02,0.422921E-02,0.421644E-02,0.421272E-02,0.663651E-01, | |
24166 | &0.996863E-03,0.307770E+00,0.106393E+00,0.390887E-02,0.392563E-02, | |
24167 | &0.391260E-02,0.390887E-02,0.596195E-01,0.985881E-03,0.290841E+00, | |
24168 | &0.994399E-01,0.362199E-02,0.363889E-02,0.362570E-02,0.362199E-02, | |
24169 | &0.535826E-01,0.967664E-03,0.274506E+00,0.928343E-01,0.335170E-02, | |
24170 | &0.336862E-02,0.335536E-02,0.335170E-02,0.481769E-01,0.943587E-03/ | |
24171 | DATA (DL(K),K= 2041, 2125) / | |
24172 | &0.258771E+00,0.865679E-01,0.309756E-02,0.311439E-02,0.310114E-02, | |
24173 | &0.309756E-02,0.433336E-01,0.914850E-03,0.243639E+00,0.806321E-01, | |
24174 | &0.285905E-02,0.287571E-02,0.286255E-02,0.285905E-02,0.389912E-01, | |
24175 | &0.882497E-03,0.229113E+00,0.750177E-01,0.263565E-02,0.265205E-02, | |
24176 | &0.263905E-02,0.263565E-02,0.350948E-01,0.847432E-03,0.215193E+00, | |
24177 | &0.697152E-01,0.242677E-02,0.244285E-02,0.243005E-02,0.242677E-02, | |
24178 | &0.315960E-01,0.810432E-03,0.000000E+00,0.000000E+00,0.000000E+00, | |
24179 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24180 | &0.503850E+00,0.183581E+00,0.522815E-02,0.522815E-02,0.522815E-02, | |
24181 | &0.522815E-02,0.142635E+00,0.123599E-16,0.479478E+00,0.172477E+00, | |
24182 | &0.488093E-02,0.488328E-02,0.488147E-02,0.488093E-02,0.126767E+00, | |
24183 | &0.124505E-03,0.455750E+00,0.161879E+00,0.455054E-02,0.455493E-02, | |
24184 | &0.455153E-02,0.455054E-02,0.112695E+00,0.225968E-03,0.432681E+00, | |
24185 | &0.151771E+00,0.423664E-02,0.424278E-02,0.423800E-02,0.423664E-02, | |
24186 | &0.100212E+00,0.307702E-03,0.410286E+00,0.142140E+00,0.393907E-02, | |
24187 | &0.394671E-02,0.394073E-02,0.393907E-02,0.891488E-01,0.372395E-03, | |
24188 | &0.388577E+00,0.132974E+00,0.365743E-02,0.366634E-02,0.365934E-02/ | |
24189 | DATA (DL(K),K= 2126, 2210) / | |
24190 | &0.365743E-02,0.793490E-01,0.422302E-03,0.367563E+00,0.124259E+00, | |
24191 | &0.339138E-02,0.340133E-02,0.339347E-02,0.339138E-02,0.706688E-01, | |
24192 | &0.459484E-03,0.347256E+00,0.115984E+00,0.314049E-02,0.315129E-02, | |
24193 | &0.314273E-02,0.314049E-02,0.629792E-01,0.485762E-03,0.327660E+00, | |
24194 | &0.108136E+00,0.290433E-02,0.291580E-02,0.290667E-02,0.290433E-02, | |
24195 | &0.561642E-01,0.502744E-03,0.308782E+00,0.100701E+00,0.268243E-02, | |
24196 | &0.269440E-02,0.268483E-02,0.268243E-02,0.501207E-01,0.511853E-03, | |
24197 | &0.290625E+00,0.936693E-01,0.247429E-02,0.248663E-02,0.247672E-02, | |
24198 | &0.247429E-02,0.447569E-01,0.514346E-03,0.273189E+00,0.870261E-01, | |
24199 | &0.227939E-02,0.229197E-02,0.228184E-02,0.227939E-02,0.399920E-01, | |
24200 | &0.511328E-03,0.256475E+00,0.807592E-01,0.209722E-02,0.210991E-02, | |
24201 | &0.209965E-02,0.209722E-02,0.357547E-01,0.503769E-03,0.240478E+00, | |
24202 | &0.748555E-01,0.192721E-02,0.193992E-02,0.192961E-02,0.192721E-02, | |
24203 | &0.319825E-01,0.492518E-03,0.225194E+00,0.693019E-01,0.176883E-02, | |
24204 | &0.178147E-02,0.177117E-02,0.176883E-02,0.286209E-01,0.478318E-03, | |
24205 | &0.210615E+00,0.640851E-01,0.162151E-02,0.163400E-02,0.162379E-02, | |
24206 | &0.162151E-02,0.256219E-01,0.461813E-03,0.196733E+00,0.591917E-01/ | |
24207 | DATA (DL(K),K= 2211, 2295) / | |
24208 | &0.148471E-02,0.149698E-02,0.148691E-02,0.148471E-02,0.229436E-01, | |
24209 | &0.443561E-03,0.183536E+00,0.546085E-01,0.135786E-02,0.136986E-02, | |
24210 | &0.135998E-02,0.135786E-02,0.205496E-01,0.424043E-03,0.171011E+00, | |
24211 | &0.503219E-01,0.124042E-02,0.125211E-02,0.124246E-02,0.124042E-02, | |
24212 | &0.184079E-01,0.403672E-03,0.000000E+00,0.000000E+00,0.000000E+00, | |
24213 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24214 | &0.450310E+00,0.149685E+00,0.302765E-02,0.302765E-02,0.302765E-02, | |
24215 | &0.302765E-02,0.901099E-01,-.108420E-17,0.425282E+00,0.139479E+00, | |
24216 | &0.279499E-02,0.279691E-02,0.279537E-02,0.279499E-02,0.794239E-01, | |
24217 | &0.632140E-04,0.401169E+00,0.129837E+00,0.257801E-02,0.258157E-02, | |
24218 | &0.257870E-02,0.257801E-02,0.700941E-01,0.114711E-03,0.377966E+00, | |
24219 | &0.120733E+00,0.237556E-02,0.238052E-02,0.237650E-02,0.237556E-02, | |
24220 | &0.619270E-01,0.156107E-03,0.355668E+00,0.112145E+00,0.218688E-02, | |
24221 | &0.219301E-02,0.218802E-02,0.218688E-02,0.547717E-01,0.188777E-03, | |
24222 | &0.334269E+00,0.104052E+00,0.201113E-02,0.201823E-02,0.201243E-02, | |
24223 | &0.201113E-02,0.484974E-01,0.213848E-03,0.313762E+00,0.964335E-01, | |
24224 | &0.184758E-02,0.185546E-02,0.184900E-02,0.184758E-02,0.429879E-01/ | |
24225 | DATA (DL(K),K= 2296, 2380) / | |
24226 | &0.232367E-03,0.294139E+00,0.892696E-01,0.169553E-02,0.170402E-02, | |
24227 | &0.169703E-02,0.169553E-02,0.381432E-01,0.245270E-03,0.275389E+00, | |
24228 | &0.825414E-01,0.155431E-02,0.156326E-02,0.155586E-02,0.155431E-02, | |
24229 | &0.338762E-01,0.253383E-03,0.257502E+00,0.762303E-01,0.142329E-02, | |
24230 | &0.143258E-02,0.142487E-02,0.142329E-02,0.301119E-01,0.257441E-03, | |
24231 | &0.240464E+00,0.703180E-01,0.130188E-02,0.131138E-02,0.130347E-02, | |
24232 | &0.130188E-02,0.267853E-01,0.258098E-03,0.224262E+00,0.647867E-01, | |
24233 | &0.118950E-02,0.119912E-02,0.119108E-02,0.118950E-02,0.238409E-01, | |
24234 | &0.255929E-03,0.208879E+00,0.596190E-01,0.108562E-02,0.109526E-02, | |
24235 | &0.108717E-02,0.108562E-02,0.212308E-01,0.251442E-03,0.194298E+00, | |
24236 | &0.547975E-01,0.989698E-03,0.999283E-03,0.991221E-03,0.989698E-03, | |
24237 | &0.189136E-01,0.245082E-03,0.180499E+00,0.503054E-01,0.901248E-03, | |
24238 | &0.910711E-03,0.902726E-03,0.901248E-03,0.168537E-01,0.237238E-03, | |
24239 | &0.167463E+00,0.461263E-01,0.819789E-03,0.829074E-03,0.821215E-03, | |
24240 | &0.819789E-03,0.150206E-01,0.228250E-03,0.155167E+00,0.422438E-01, | |
24241 | &0.744866E-03,0.753925E-03,0.746234E-03,0.744866E-03,0.133878E-01, | |
24242 | &0.218412E-03,0.143590E+00,0.386421E-01,0.676043E-03,0.684836E-03/ | |
24243 | DATA (DL(K),K= 2381, 2465) / | |
24244 | &0.677349E-03,0.676043E-03,0.119320E-01,0.207976E-03,0.132706E+00, | |
24245 | &0.353058E-01,0.612907E-03,0.621403E-03,0.614147E-03,0.612907E-03, | |
24246 | &0.106334E-01,0.197159E-03,0.000000E+00,0.000000E+00,0.000000E+00, | |
24247 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24248 | &0.393307E+00,0.118409E+00,0.167124E-02,0.167124E-02,0.167124E-02, | |
24249 | &0.167124E-02,0.547140E-01,0.433681E-17,0.368555E+00,0.109414E+00, | |
24250 | &0.152547E-02,0.152705E-02,0.152573E-02,0.152547E-02,0.479708E-01, | |
24251 | &0.303147E-04,0.344946E+00,0.101001E+00,0.139202E-02,0.139494E-02, | |
24252 | &0.139249E-02,0.139202E-02,0.421517E-01,0.552185E-04,0.322450E+00, | |
24253 | &0.931345E-01,0.126960E-02,0.127363E-02,0.127024E-02,0.126960E-02, | |
24254 | &0.371043E-01,0.753524E-04,0.301043E+00,0.857854E-01,0.115731E-02, | |
24255 | &0.116225E-02,0.115808E-02,0.115731E-02,0.327131E-01,0.913172E-04, | |
24256 | &0.280698E+00,0.789267E-01,0.105427E-02,0.105995E-02,0.105514E-02, | |
24257 | &0.105427E-02,0.288844E-01,0.103605E-03,0.261390E+00,0.725323E-01, | |
24258 | &0.959726E-03,0.965979E-03,0.960659E-03,0.959726E-03,0.255366E-01, | |
24259 | &0.112688E-03,0.243091E+00,0.665774E-01,0.872987E-03,0.879676E-03, | |
24260 | &0.873966E-03,0.872987E-03,0.226017E-01,0.119000E-03,0.225775E+00/ | |
24261 | DATA (DL(K),K= 2466, 2550) / | |
24262 | &0.610385E-01,0.793435E-03,0.800438E-03,0.794441E-03,0.793435E-03, | |
24263 | &0.200219E-01,0.122931E-03,0.209414E+00,0.558928E-01,0.720508E-03, | |
24264 | &0.727716E-03,0.721524E-03,0.720508E-03,0.177490E-01,0.124835E-03, | |
24265 | &0.193979E+00,0.511187E-01,0.653691E-03,0.661011E-03,0.654703E-03, | |
24266 | &0.653691E-03,0.157425E-01,0.125031E-03,0.179441E+00,0.466950E-01, | |
24267 | &0.592513E-03,0.599863E-03,0.593511E-03,0.592513E-03,0.139674E-01, | |
24268 | &0.123805E-03,0.165770E+00,0.426018E-01,0.536539E-03,0.543850E-03, | |
24269 | &0.537513E-03,0.536539E-03,0.123945E-01,0.121411E-03,0.152935E+00, | |
24270 | &0.388195E-01,0.485370E-03,0.492584E-03,0.486314E-03,0.485370E-03, | |
24271 | &0.109993E-01,0.118076E-03,0.140905E+00,0.353295E-01,0.438636E-03, | |
24272 | &0.445702E-03,0.439543E-03,0.438636E-03,0.976027E-02,0.113999E-03, | |
24273 | &0.129648E+00,0.321137E-01,0.395992E-03,0.402871E-03,0.396859E-03, | |
24274 | &0.395992E-03,0.865895E-02,0.109353E-03,0.119131E+00,0.291550E-01, | |
24275 | &0.357120E-03,0.363779E-03,0.357945E-03,0.357120E-03,0.767960E-02, | |
24276 | &0.104292E-03,0.109323E+00,0.264366E-01,0.321725E-03,0.328139E-03, | |
24277 | &0.322505E-03,0.321725E-03,0.680866E-02,0.989468E-04,0.100191E+00, | |
24278 | &0.239428E-01,0.289531E-03,0.295679E-03,0.290266E-03,0.289531E-03/ | |
24279 | DATA (DL(K),K= 2551, 2635) / | |
24280 | &0.603390E-02,0.934295E-04,0.000000E+00,0.000000E+00,0.000000E+00, | |
24281 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24282 | &0.334851E+00,0.904666E-01,0.869706E-03,0.869706E-03,0.869706E-03, | |
24283 | &0.869706E-03,0.316365E-01,-.311708E-17,0.311223E+00,0.828706E-01, | |
24284 | &0.784673E-03,0.785968E-03,0.784847E-03,0.784673E-03,0.277037E-01, | |
24285 | &0.134749E-04,0.288910E+00,0.758361E-01,0.708234E-03,0.710597E-03, | |
24286 | &0.708543E-03,0.708234E-03,0.243298E-01,0.247881E-04,0.267855E+00, | |
24287 | &0.693222E-01,0.639256E-03,0.642491E-03,0.639671E-03,0.639256E-03, | |
24288 | &0.214125E-01,0.340882E-04,0.248015E+00,0.632964E-01,0.576953E-03, | |
24289 | &0.580887E-03,0.577448E-03,0.576953E-03,0.188764E-01,0.415701E-04, | |
24290 | &0.229343E+00,0.577274E-01,0.520615E-03,0.525096E-03,0.521167E-03, | |
24291 | &0.520615E-03,0.166642E-01,0.474027E-04,0.211794E+00,0.525860E-01, | |
24292 | &0.469624E-03,0.474520E-03,0.470215E-03,0.469624E-03,0.147265E-01, | |
24293 | &0.517615E-04,0.195325E+00,0.478447E-01,0.423445E-03,0.428640E-03, | |
24294 | &0.424060E-03,0.423445E-03,0.130234E-01,0.548213E-04,0.179891E+00, | |
24295 | &0.434776E-01,0.381606E-03,0.387001E-03,0.382232E-03,0.381606E-03, | |
24296 | &0.115226E-01,0.567474E-04,0.165449E+00,0.394601E-01,0.343691E-03/ | |
24297 | DATA (DL(K),K= 2636, 2720) / | |
24298 | &0.349200E-03,0.344317E-03,0.343691E-03,0.101965E-01,0.576952E-04, | |
24299 | &0.151958E+00,0.357691E-01,0.309329E-03,0.314879E-03,0.309948E-03, | |
24300 | &0.309329E-03,0.902217E-02,0.578101E-04,0.139374E+00,0.323826E-01, | |
24301 | &0.278192E-03,0.283721E-03,0.278796E-03,0.278192E-03,0.798131E-02, | |
24302 | &0.572266E-04,0.127655E+00,0.292797E-01,0.249984E-03,0.255440E-03, | |
24303 | &0.250569E-03,0.249984E-03,0.705796E-02,0.560672E-04,0.116760E+00, | |
24304 | &0.264406E-01,0.224440E-03,0.229782E-03,0.225002E-03,0.224440E-03, | |
24305 | &0.623793E-02,0.544420E-04,0.106647E+00,0.238467E-01,0.201321E-03, | |
24306 | &0.206513E-03,0.201856E-03,0.201321E-03,0.550962E-02,0.524504E-04, | |
24307 | &0.972762E-01,0.214802E-01,0.180411E-03,0.185425E-03,0.180918E-03, | |
24308 | &0.180411E-03,0.486321E-02,0.501804E-04,0.886073E-01,0.193242E-01, | |
24309 | &0.161512E-03,0.166328E-03,0.161990E-03,0.161512E-03,0.428946E-02, | |
24310 | &0.477087E-04,0.806013E-01,0.173629E-01,0.144446E-03,0.149048E-03, | |
24311 | &0.144894E-03,0.144446E-03,0.378030E-02,0.451020E-04,0.732197E-01, | |
24312 | &0.155814E-01,0.129049E-03,0.133425E-03,0.129467E-03,0.129049E-03, | |
24313 | &0.332897E-02,0.424179E-04,0.000000E+00,0.000000E+00,0.000000E+00, | |
24314 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
24315 | DATA (DL(K),K= 2721, 2805) / | |
24316 | &0.276761E+00,0.663170E-01,0.420483E-03,0.420483E-03,0.420483E-03, | |
24317 | &0.420483E-03,0.172075E-01,0.418773E-17,0.255003E+00,0.601925E-01, | |
24318 | &0.374768E-03,0.375776E-03,0.374876E-03,0.374768E-03,0.151410E-01, | |
24319 | &0.540038E-05,0.234664E+00,0.545789E-01,0.334420E-03,0.336252E-03, | |
24320 | &0.334612E-03,0.334420E-03,0.133594E-01,0.101360E-04,0.215665E+00, | |
24321 | &0.494328E-01,0.298611E-03,0.301108E-03,0.298867E-03,0.298611E-03, | |
24322 | &0.118079E-01,0.141555E-04,0.197941E+00,0.447203E-01,0.266766E-03, | |
24323 | &0.269787E-03,0.267068E-03,0.266766E-03,0.104461E-01,0.174750E-04, | |
24324 | &0.181428E+00,0.404089E-01,0.238391E-03,0.241815E-03,0.238726E-03, | |
24325 | &0.238391E-03,0.924609E-02,0.201244E-04,0.166064E+00,0.364687E-01, | |
24326 | &0.213061E-03,0.216782E-03,0.213417E-03,0.213061E-03,0.818507E-02, | |
24327 | &0.221467E-04,0.151790E+00,0.328719E-01,0.190418E-03,0.194343E-03, | |
24328 | &0.190785E-03,0.190418E-03,0.724366E-02,0.235974E-04,0.138548E+00, | |
24329 | &0.295925E-01,0.170150E-03,0.174202E-03,0.170521E-03,0.170150E-03, | |
24330 | &0.640614E-02,0.245354E-04,0.126282E+00,0.266063E-01,0.151991E-03, | |
24331 | &0.156104E-03,0.152359E-03,0.151991E-03,0.566089E-02,0.250221E-04, | |
24332 | &0.114939E+00,0.238907E-01,0.135710E-03,0.139827E-03,0.136071E-03/ | |
24333 | DATA (DL(K),K= 2806, 2890) / | |
24334 | &0.135710E-03,0.499773E-02,0.251191E-04,0.104465E+00,0.214245E-01, | |
24335 | &0.121106E-03,0.125180E-03,0.121455E-03,0.121106E-03,0.440691E-02, | |
24336 | &0.248850E-04,0.948101E-01,0.191879E-01,0.108002E-03,0.111994E-03, | |
24337 | &0.108337E-03,0.108002E-03,0.388094E-02,0.243760E-04,0.859247E-01, | |
24338 | &0.171625E-01,0.962435E-04,0.100124E-03,0.965624E-04,0.962435E-04, | |
24339 | &0.341379E-02,0.236445E-04,0.777613E-01,0.153309E-01,0.856948E-04, | |
24340 | &0.894394E-04,0.859960E-04,0.856948E-04,0.299910E-02,0.227378E-04, | |
24341 | &0.702736E-01,0.136770E-01,0.762337E-04,0.798235E-04,0.765166E-04, | |
24342 | &0.762337E-04,0.263116E-02,0.216984E-04,0.634174E-01,0.121859E-01, | |
24343 | &0.677528E-04,0.711742E-04,0.680169E-04,0.677528E-04,0.230551E-02, | |
24344 | &0.205642E-04,0.571500E-01,0.108434E-01,0.601554E-04,0.633990E-04, | |
24345 | &0.604008E-04,0.601554E-04,0.201791E-02,0.193681E-04,0.514305E-01, | |
24346 | &0.963651E-02,0.533545E-04,0.564148E-04,0.535814E-04,0.533545E-04, | |
24347 | &0.176404E-02,0.181381E-04,0.000000E+00,0.000000E+00,0.000000E+00, | |
24348 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24349 | &0.220700E+00,0.461964E-01,0.185072E-03,0.185072E-03,0.185072E-03, | |
24350 | &0.185072E-03,0.865568E-02,-.294090E-17,0.201438E+00,0.415162E-01/ | |
24351 | DATA (DL(K),K= 2891, 2975) / | |
24352 | &0.162774E-03,0.163610E-03,0.162842E-03,0.162774E-03,0.772611E-02, | |
24353 | &0.184134E-05,0.183625E+00,0.372730E-01,0.143469E-03,0.144974E-03, | |
24354 | &0.143588E-03,0.143469E-03,0.690038E-02,0.359959E-05,0.167162E+00, | |
24355 | &0.334245E-01,0.126634E-03,0.128666E-03,0.126791E-03,0.126634E-03, | |
24356 | &0.616000E-02,0.518075E-05,0.151966E+00,0.299378E-01,0.111904E-03, | |
24357 | &0.114340E-03,0.112088E-03,0.111904E-03,0.549219E-02,0.654232E-05, | |
24358 | &0.137959E+00,0.267821E-01,0.989836E-04,0.101716E-03,0.991845E-04, | |
24359 | &0.989836E-04,0.488896E-02,0.767008E-05,0.125065E+00,0.239289E-01, | |
24360 | &0.876157E-04,0.905559E-04,0.878269E-04,0.876157E-04,0.434253E-02, | |
24361 | &0.855860E-05,0.113213E+00,0.213524E-01,0.775899E-04,0.806611E-04, | |
24362 | &0.778055E-04,0.775899E-04,0.384886E-02,0.921640E-05,0.102335E+00, | |
24363 | &0.190285E-01,0.687292E-04,0.718676E-04,0.689446E-04,0.687292E-04, | |
24364 | &0.340422E-02,0.965961E-05,0.923671E-01,0.169353E-01,0.608829E-04, | |
24365 | &0.640353E-04,0.610944E-04,0.608829E-04,0.300332E-02,0.990752E-05, | |
24366 | &0.832476E-01,0.150523E-01,0.539242E-04,0.570473E-04,0.541291E-04, | |
24367 | &0.539242E-04,0.264288E-02,0.998320E-05,0.749179E-01,0.133608E-01, | |
24368 | &0.477459E-04,0.508046E-04,0.479422E-04,0.477459E-04,0.232088E-02/ | |
24369 | DATA (DL(K),K= 2976, 3060) / | |
24370 | &0.991147E-05,0.673221E-01,0.118435E-01,0.422554E-04,0.452220E-04, | |
24371 | &0.424417E-04,0.422554E-04,0.203376E-02,0.971603E-05,0.604073E-01, | |
24372 | &0.104845E-01,0.373730E-04,0.402263E-04,0.375483E-04,0.373730E-04, | |
24373 | &0.177791E-02,0.941959E-05,0.541231E-01,0.926900E-02,0.330304E-04, | |
24374 | &0.357544E-04,0.331943E-04,0.330304E-04,0.155117E-02,0.904408E-05, | |
24375 | &0.484216E-01,0.818347E-02,0.291681E-04,0.317517E-04,0.293202E-04, | |
24376 | &0.291681E-04,0.135108E-02,0.860921E-05,0.432578E-01,0.721549E-02, | |
24377 | &0.257333E-04,0.281694E-04,0.258738E-04,0.257333E-04,0.117463E-02, | |
24378 | &0.813214E-05,0.385889E-01,0.635362E-02,0.226802E-04,0.249648E-04, | |
24379 | &0.228093E-04,0.226802E-04,0.101941E-02,0.762814E-05,0.343746E-01, | |
24380 | &0.558739E-02,0.199682E-04,0.221003E-04,0.200863E-04,0.199682E-04, | |
24381 | &0.883469E-03,0.711035E-05,0.000000E+00,0.000000E+00,0.000000E+00, | |
24382 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24383 | &0.168205E+00,0.301419E-01,0.719932E-04,0.719932E-04,0.719932E-04, | |
24384 | &0.719932E-04,0.392825E-02,-.205998E-17,0.151922E+00,0.267932E-01, | |
24385 | &0.623634E-04,0.630456E-04,0.624028E-04,0.623634E-04,0.361412E-02, | |
24386 | &0.457084E-06,0.137042E+00,0.237932E-01,0.541981E-04,0.554098E-04/ | |
24387 | DATA (DL(K),K= 3061, 3145) / | |
24388 | &0.542663E-04,0.541981E-04,0.330342E-02,0.989813E-06,0.123446E+00, | |
24389 | &0.211038E-01,0.472163E-04,0.488314E-04,0.473050E-04,0.472163E-04, | |
24390 | &0.300140E-02,0.152631E-05,0.111042E+00,0.186954E-01,0.412159E-04, | |
24391 | &0.431273E-04,0.413184E-04,0.412159E-04,0.270826E-02,0.202092E-05, | |
24392 | &0.997395E-01,0.165410E-01,0.360433E-04,0.381615E-04,0.361542E-04, | |
24393 | &0.360433E-04,0.242968E-02,0.245400E-05,0.894558E-01,0.146159E-01, | |
24394 | &0.315670E-04,0.338178E-04,0.316822E-04,0.315670E-04,0.216928E-02, | |
24395 | &0.281218E-05,0.801130E-01,0.128978E-01,0.276779E-04,0.300002E-04, | |
24396 | &0.277940E-04,0.276779E-04,0.192603E-02,0.308878E-05,0.716379E-01, | |
24397 | &0.113663E-01,0.242878E-04,0.266317E-04,0.244024E-04,0.242878E-04, | |
24398 | &0.170100E-02,0.328451E-05,0.639623E-01,0.100031E-01,0.213246E-04, | |
24399 | &0.236502E-04,0.214357E-04,0.213246E-04,0.149649E-02,0.340483E-05, | |
24400 | &0.570222E-01,0.879131E-02,0.187277E-04,0.210033E-04,0.188341E-04, | |
24401 | &0.187277E-04,0.131163E-02,0.345656E-05,0.507574E-01,0.771565E-02, | |
24402 | &0.164465E-04,0.186476E-04,0.165471E-04,0.164465E-04,0.114469E-02, | |
24403 | &0.344782E-05,0.451118E-01,0.676223E-02,0.144396E-04,0.165480E-04, | |
24404 | &0.145339E-04,0.144396E-04,0.995649E-03,0.338831E-05,0.400330E-01/ | |
24405 | DATA (DL(K),K= 3146, 3230) / | |
24406 | &0.591841E-02,0.126720E-04,0.146744E-04,0.127597E-04,0.126720E-04, | |
24407 | &0.863829E-03,0.328754E-05,0.354720E-01,0.517273E-02,0.111137E-04, | |
24408 | &0.130013E-04,0.111946E-04,0.111137E-04,0.747293E-03,0.315403E-05, | |
24409 | &0.313830E-01,0.451477E-02,0.973915E-05,0.115067E-04,0.981339E-05, | |
24410 | &0.973915E-05,0.644664E-03,0.299600E-05,0.277237E-01,0.393511E-02, | |
24411 | &0.852687E-05,0.101721E-04,0.859457E-05,0.852687E-05,0.555034E-03, | |
24412 | &0.282099E-05,0.244545E-01,0.342521E-02,0.745784E-05,0.898076E-05, | |
24413 | &0.751926E-05,0.745784E-05,0.476998E-03,0.263530E-05,0.215390E-01, | |
24414 | &0.297737E-02,0.651555E-05,0.791817E-05,0.657100E-05,0.651555E-05, | |
24415 | &0.409096E-03,0.244427E-05,0.000000E+00,0.000000E+00,0.000000E+00, | |
24416 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24417 | &0.120694E+00,0.180081E-01,0.236444E-04,0.236444E-04,0.236444E-04, | |
24418 | &0.236444E-04,0.154817E-02,0.416656E-17,0.107713E+00,0.158098E-01, | |
24419 | &0.200945E-04,0.206098E-04,0.201146E-04,0.200945E-04,0.151249E-02, | |
24420 | &0.192118E-07,0.960063E-01,0.138667E-01,0.171552E-04,0.180593E-04, | |
24421 | &0.171894E-04,0.171552E-04,0.143574E-02,0.116516E-06,0.854477E-01, | |
24422 | &0.121473E-01,0.146986E-04,0.158894E-04,0.147425E-04,0.146986E-04/ | |
24423 | DATA (DL(K),K= 3231, 3315) / | |
24424 | &0.133744E-02,0.251060E-06,0.759386E-01,0.106275E-01,0.126329E-04, | |
24425 | &0.140252E-04,0.126830E-04,0.126329E-04,0.122900E-02,0.395272E-06, | |
24426 | &0.673865E-01,0.928577E-02,0.108901E-04,0.124142E-04,0.109436E-04, | |
24427 | &0.108901E-04,0.111367E-02,0.535145E-06,0.597062E-01,0.810254E-02, | |
24428 | &0.941160E-05,0.110108E-04,0.946648E-05,0.941160E-05,0.996785E-03, | |
24429 | &0.659421E-06,0.528194E-01,0.706039E-02,0.815165E-05,0.978016E-05, | |
24430 | &0.820627E-05,0.815165E-05,0.885152E-03,0.762600E-06,0.466540E-01, | |
24431 | &0.614371E-02,0.707299E-05,0.869464E-05,0.712616E-05,0.707299E-05, | |
24432 | &0.780484E-03,0.842072E-06,0.411433E-01,0.533850E-02,0.614470E-05, | |
24433 | &0.773135E-05,0.619559E-05,0.614470E-05,0.682563E-03,0.896683E-06, | |
24434 | &0.362261E-01,0.463223E-02,0.534297E-05,0.687330E-05,0.539102E-05, | |
24435 | &0.534297E-05,0.593317E-03,0.928176E-06,0.318459E-01,0.401364E-02, | |
24436 | &0.464848E-05,0.610690E-05,0.469333E-05,0.464848E-05,0.513720E-03, | |
24437 | &0.939174E-06,0.279510E-01,0.347266E-02,0.404483E-05,0.542054E-05, | |
24438 | &0.408628E-05,0.404483E-05,0.442713E-03,0.932117E-06,0.244935E-01, | |
24439 | &0.300029E-02,0.351893E-05,0.480507E-05,0.355692E-05,0.351893E-05, | |
24440 | &0.379744E-03,0.910085E-06,0.214299E-01,0.258845E-02,0.306021E-05/ | |
24441 | DATA (DL(K),K= 3316, 3400) / | |
24442 | &0.425313E-05,0.309476E-05,0.306021E-05,0.324785E-03,0.876365E-06, | |
24443 | &0.187200E-01,0.222996E-02,0.265958E-05,0.375823E-05,0.269081E-05, | |
24444 | &0.265958E-05,0.277080E-03,0.833755E-06,0.163273E-01,0.191840E-02, | |
24445 | &0.230942E-05,0.331477E-05,0.233747E-05,0.230942E-05,0.235661E-03, | |
24446 | &0.784780E-06,0.142185E-01,0.164805E-02,0.200337E-05,0.291797E-05, | |
24447 | &0.202844E-05,0.200337E-05,0.199949E-03,0.731774E-06,0.123631E-01, | |
24448 | &0.141382E-02,0.173596E-05,0.256351E-05,0.175824E-05,0.173596E-05, | |
24449 | &0.169376E-03,0.676674E-06,0.000000E+00,0.000000E+00,0.000000E+00, | |
24450 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24451 | &0.794823E-01,0.948208E-02,0.607312E-05,0.607312E-05,0.607312E-05, | |
24452 | &0.607312E-05,0.497062E-03,-.140523E-17,0.699344E-01,0.820355E-02, | |
24453 | &0.500852E-05,0.538347E-05,0.501731E-05,0.500852E-05,0.542262E-03, | |
24454 | &-.714686E-07,0.614560E-01,0.709106E-02,0.415227E-05,0.479898E-05, | |
24455 | &0.416702E-05,0.415227E-05,0.549985E-03,-.960102E-07,0.539240E-01, | |
24456 | &0.612155E-02,0.345977E-05,0.429563E-05,0.347839E-05,0.345977E-05, | |
24457 | &0.531288E-03,-.894946E-07,0.472426E-01,0.527757E-02,0.289508E-05, | |
24458 | &0.385164E-05,0.291595E-05,0.289508E-05,0.495120E-03,-.668594E-07/ | |
24459 | DATA (DL(K),K= 3401, 3485) / | |
24460 | &0.413245E-01,0.454380E-02,0.243524E-05,0.345851E-05,0.245713E-05, | |
24461 | &0.243524E-05,0.452156E-03,-.338861E-07,0.360903E-01,0.390658E-02, | |
24462 | &0.205923E-05,0.310726E-05,0.208123E-05,0.205923E-05,0.406686E-03, | |
24463 | &0.329349E-08,0.314681E-01,0.335393E-02,0.174861E-05,0.278918E-05, | |
24464 | &0.177007E-05,0.174861E-05,0.359402E-03,0.387747E-07,0.273932E-01, | |
24465 | &0.287528E-02,0.149082E-05,0.250013E-05,0.151127E-05,0.149082E-05, | |
24466 | &0.313779E-03,0.705560E-07,0.238068E-01,0.246132E-02,0.127582E-05, | |
24467 | &0.223699E-05,0.129498E-05,0.127582E-05,0.272195E-03,0.975744E-07, | |
24468 | &0.206558E-01,0.210383E-02,0.109488E-05,0.199657E-05,0.111257E-05, | |
24469 | &0.109488E-05,0.234227E-03,0.118651E-06,0.178921E-01,0.179558E-02, | |
24470 | &0.941584E-06,0.177694E-05,0.957733E-06,0.941584E-06,0.199907E-03, | |
24471 | &0.133780E-06,0.154726E-01,0.153020E-02,0.811157E-06,0.157680E-05, | |
24472 | &0.825743E-06,0.811157E-06,0.169849E-03,0.143581E-06,0.133582E-01, | |
24473 | &0.130209E-02,0.699567E-06,0.139481E-05,0.712624E-06,0.699567E-06, | |
24474 | &0.143794E-03,0.148591E-06,0.115137E-01,0.110634E-02,0.603631E-06, | |
24475 | &0.122977E-05,0.615228E-06,0.603631E-06,0.121163E-03,0.149477E-06, | |
24476 | &0.990774E-02,0.938615E-03,0.520920E-06,0.108072E-05,0.531148E-06/ | |
24477 | DATA (DL(K),K= 3486, 3570) / | |
24478 | &0.520920E-06,0.101725E-03,0.147055E-06,0.851194E-02,0.795146E-03, | |
24479 | &0.449441E-06,0.946634E-06,0.458405E-06,0.449441E-06,0.852238E-04, | |
24480 | &0.142064E-06,0.730103E-02,0.672622E-03,0.387542E-06,0.826497E-06, | |
24481 | &0.395353E-06,0.387542E-06,0.712290E-04,0.135149E-06,0.625244E-02, | |
24482 | &0.568155E-03,0.333888E-06,0.719316E-06,0.340658E-06,0.333888E-06, | |
24483 | &0.593824E-04,0.126902E-06,0.000000E+00,0.000000E+00,0.000000E+00, | |
24484 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24485 | &0.457819E-01,0.409492E-02,0.105702E-05,0.105702E-05,0.105702E-05, | |
24486 | &0.105702E-05,0.115350E-03,0.265810E-18,0.395724E-01,0.347873E-02, | |
24487 | &0.812397E-06,0.103880E-05,0.815187E-06,0.812397E-06,0.160406E-03, | |
24488 | &-.555147E-07,0.341639E-01,0.295295E-02,0.627904E-06,0.987449E-06, | |
24489 | &0.632305E-06,0.627904E-06,0.174490E-03,-.847266E-07,0.294481E-01, | |
24490 | &0.250329E-02,0.490075E-06,0.920197E-06,0.495305E-06,0.490075E-06, | |
24491 | &0.174490E-03,-.944763E-07,0.253423E-01,0.211912E-02,0.387225E-06, | |
24492 | &0.845257E-06,0.392760E-06,0.387225E-06,0.167111E-03,-.916775E-07, | |
24493 | &0.217735E-01,0.179138E-02,0.309989E-06,0.766697E-06,0.315473E-06, | |
24494 | &0.309989E-06,0.152540E-03,-.819158E-07,0.186760E-01,0.151211E-02/ | |
24495 | DATA (DL(K),K= 3571, 3655) / | |
24496 | &0.252109E-06,0.688927E-06,0.257316E-06,0.252109E-06,0.135295E-03, | |
24497 | &-.682145E-07,0.159921E-01,0.127447E-02,0.208612E-06,0.614302E-06, | |
24498 | &0.213410E-06,0.208612E-06,0.118648E-03,-.528734E-07,0.136704E-01, | |
24499 | &0.107254E-02,0.175203E-06,0.543807E-06,0.179526E-06,0.175203E-06, | |
24500 | &0.102484E-03,-.379748E-07,0.116656E-01,0.901214E-03,0.149064E-06, | |
24501 | &0.478363E-06,0.152890E-06,0.149064E-06,0.871530E-04,-.245007E-07, | |
24502 | &0.993760E-02,0.756074E-03,0.128274E-06,0.418496E-06,0.131610E-06, | |
24503 | &0.128274E-06,0.735682E-04,-.128491E-07,0.845081E-02,0.633315E-03, | |
24504 | &0.111313E-06,0.364260E-06,0.114187E-06,0.111313E-06,0.617706E-04, | |
24505 | &-.327698E-08,0.717398E-02,0.529654E-03,0.971373E-07,0.315568E-06, | |
24506 | &0.995871E-07,0.971373E-07,0.514764E-04,0.421954E-08,0.607950E-02, | |
24507 | &0.442265E-03,0.850687E-07,0.272228E-06,0.871375E-07,0.850687E-07, | |
24508 | &0.426580E-04,0.982709E-08,0.514311E-02,0.368716E-03,0.746164E-07, | |
24509 | &0.233927E-06,0.763489E-07,0.746164E-07,0.352463E-04,0.137715E-07, | |
24510 | &0.434349E-02,0.306920E-03,0.654439E-07,0.200291E-06,0.668838E-07, | |
24511 | &0.654439E-07,0.290260E-04,0.163078E-07,0.366196E-02,0.255085E-03, | |
24512 | &0.573307E-07,0.170932E-06,0.585192E-07,0.573307E-07,0.238196E-04/ | |
24513 | DATA (DL(K),K= 3656, 3740) / | |
24514 | &0.177037E-07,0.308217E-02,0.211681E-03,0.501185E-07,0.145441E-06, | |
24515 | &0.510931E-07,0.501185E-07,0.195033E-04,0.182028E-07,0.258987E-02, | |
24516 | &0.175396E-03,0.436915E-07,0.123415E-06,0.444860E-07,0.436915E-07, | |
24517 | &0.159423E-04,0.180204E-07,0.000000E+00,0.000000E+00,0.000000E+00, | |
24518 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24519 | &0.206951E-01,0.123383E-02,0.903693E-07,0.903693E-07,0.903693E-07, | |
24520 | &0.903693E-07,0.147928E-04,0.131925E-18,0.174566E-01,0.102241E-02, | |
24521 | &0.892028E-07,0.129792E-07,0.885875E-07,0.892028E-07,0.328931E-04, | |
24522 | &0.168541E-07,0.147092E-01,0.846741E-03,0.841992E-07,-.346085E-07, | |
24523 | &0.832249E-07,0.841992E-07,0.410825E-04,0.262547E-07,0.123736E-01, | |
24524 | &0.700287E-03,0.769173E-07,-.620958E-07,0.757563E-07,0.769173E-07, | |
24525 | &0.418512E-04,0.305542E-07,0.103910E-01,0.578275E-03,0.688622E-07, | |
24526 | &-.753692E-07,0.676306E-07,0.688622E-07,0.392599E-04,0.318183E-07, | |
24527 | &0.871109E-02,0.476815E-03,0.611778E-07,-.782788E-07,0.599557E-07, | |
24528 | &0.611778E-07,0.356221E-04,0.316149E-07,0.728984E-02,0.392546E-03, | |
24529 | &0.537256E-07,-.749101E-07,0.525642E-07,0.537256E-07,0.312295E-04, | |
24530 | &0.301630E-07,0.608951E-02,0.322656E-03,0.466227E-07,-.678673E-07/ | |
24531 | DATA (DL(K),K= 3741, 3825) / | |
24532 | &0.455521E-07,0.466227E-07,0.265816E-04,0.278681E-07,0.507758E-02, | |
24533 | &0.264779E-03,0.400790E-07,-.588670E-07,0.391148E-07,0.400790E-07, | |
24534 | &0.223044E-04,0.251720E-07,0.422604E-02,0.216927E-03,0.341205E-07, | |
24535 | &-.492124E-07,0.332680E-07,0.341205E-07,0.185283E-04,0.222885E-07, | |
24536 | &0.351082E-02,0.177427E-03,0.287480E-07,-.397442E-07,0.280058E-07, | |
24537 | &0.287480E-07,0.152122E-04,0.193702E-07,0.291126E-02,0.144878E-03, | |
24538 | &0.239699E-07,-.309608E-07,0.233320E-07,0.239699E-07,0.123840E-04, | |
24539 | &0.165481E-07,0.240962E-02,0.118102E-03,0.197695E-07,-.231453E-07, | |
24540 | &0.192276E-07,0.197695E-07,0.100316E-04,0.139043E-07,0.199075E-02, | |
24541 | &0.961132E-04,0.161186E-07,-.164194E-07,0.156628E-07,0.161186E-07, | |
24542 | &0.808648E-05,0.114903E-07,0.164168E-02,0.780880E-04,0.129826E-07, | |
24543 | &-.107955E-07,0.126029E-07,0.129826E-07,0.648861E-05,0.933575E-08, | |
24544 | &0.135135E-02,0.633381E-04,0.103192E-07,-.622051E-08,0.100055E-07, | |
24545 | &0.103192E-07,0.519042E-05,0.744979E-08,0.111036E-02,0.512898E-04, | |
24546 | &0.808255E-08,-.260101E-08,0.782557E-08,0.808255E-08,0.414192E-05, | |
24547 | &0.582811E-08,0.910718E-03,0.414657E-04,0.622640E-08,0.177583E-09, | |
24548 | &0.601750E-08,0.622640E-08,0.329729E-05,0.445766E-08,0.745657E-03/ | |
24549 | DATA (DL(K),K= 3826, 3910) / | |
24550 | &0.334694E-04,0.470431E-08,0.223586E-08,0.453577E-08,0.470431E-08, | |
24551 | &0.261981E-05,0.331859E-08,0.000000E+00,0.000000E+00,0.000000E+00, | |
24552 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00, | |
24553 | &0.519165E-02,0.154752E-03,0.135983E-08,0.135983E-08,0.135983E-08, | |
24554 | &0.135983E-08,0.445189E-06,0.165858E-19,0.420352E-02,0.123002E-03, | |
24555 | &-.202651E-07,0.730203E-07,-.200511E-07,-.202651E-07,0.358557E-05, | |
24556 | &-.213089E-07,0.340143E-02,0.977718E-04,-.356451E-07,0.114908E-06, | |
24557 | &-.353066E-07,-.356451E-07,0.384652E-05,-.364475E-07,0.274771E-02, | |
24558 | &0.776124E-04,-.435588E-07,0.139200E-06,-.431556E-07,-.435588E-07, | |
24559 | &0.404834E-05,-.441752E-07,0.221524E-02,0.614950E-04,-.471629E-07, | |
24560 | &0.150069E-06,-.467352E-07,-.471629E-07,0.391615E-05,-.476355E-07, | |
24561 | &0.178268E-02,0.486476E-04,-.477545E-07,0.151420E-06,-.473296E-07, | |
24562 | &-.477545E-07,0.334100E-05,-.481163E-07,0.143185E-02,0.384202E-04, | |
24563 | &-.462359E-07,0.146515E-06,-.458316E-07,-.462359E-07,0.275426E-05, | |
24564 | &-.465126E-07,0.114781E-02,0.302894E-04,-.434031E-07,0.137587E-06, | |
24565 | &-.430295E-07,-.434031E-07,0.226010E-05,-.436143E-07,0.918288E-03, | |
24566 | &0.238367E-04,-.398089E-07,0.126321E-06,-.394715E-07,-.398089E-07/ | |
24567 | DATA (DL(K),K= 3911, 3995) / | |
24568 | &0.180947E-05,-.399700E-07,0.733193E-03,0.187249E-04,-.358525E-07, | |
24569 | &0.113940E-06,-.355529E-07,-.358525E-07,0.142045E-05,-.359751E-07, | |
24570 | &0.584227E-03,0.146823E-04,-.318183E-07,0.101291E-06,-.315563E-07, | |
24571 | &-.318183E-07,0.110919E-05,-.319115E-07,0.464586E-03,0.114914E-04, | |
24572 | &-.278936E-07,0.889550E-07,-.276671E-07,-.278936E-07,0.860964E-06, | |
24573 | &-.279643E-07,0.368700E-03,0.897731E-05,-.241972E-07,0.773096E-07, | |
24574 | &-.240033E-07,-.241972E-07,0.662825E-06,-.242508E-07,0.292013E-03, | |
24575 | &0.700034E-05,-.208001E-07,0.665779E-07,-.206356E-07,-.208001E-07, | |
24576 | &0.508061E-06,-.208406E-07,0.230814E-03,0.544870E-05,-.177366E-07, | |
24577 | &0.568734E-07,-.175982E-07,-.177366E-07,0.388493E-06,-.177672E-07, | |
24578 | &0.182078E-03,0.423324E-05,-.150157E-07,0.482316E-07,-.149000E-07, | |
24579 | &-.150157E-07,0.296111E-06,-.150387E-07,0.143349E-03,0.328297E-05, | |
24580 | &-.126295E-07,0.406343E-07,-.125335E-07,-.126295E-07,0.225104E-06, | |
24581 | &-.126468E-07,0.112639E-03,0.254145E-05,-.105595E-07,0.340280E-07, | |
24582 | &-.104803E-07,-.105595E-07,0.170871E-06,-.105726E-07,0.883377E-04, | |
24583 | &0.196395E-05,-.878062E-08,0.283380E-07,-.871555E-08,-.878062E-08, | |
24584 | &0.129517E-06,-.879039E-08,0.000000E+00,0.000000E+00,0.000000E+00/ | |
24585 | DATA (DL(K),K= 3996, 4000) / | |
24586 | &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/ | |
24587 | C | |
24588 | ANS = 0. | |
24589 | IF (X.GT.0.9985) RETURN | |
24590 | IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN | |
24591 | C | |
24592 | IS = S/DELTA+1 | |
24593 | IS1 = IS+1 | |
24594 | DO 1 L=1,25 | |
24595 | KL = L+NDRV*25 | |
24596 | F1(L) = GF(I,IS,KL) | |
24597 | F2(L) = GF(I,IS1,KL) | |
24598 | 1 CONTINUE | |
24599 | A1 = DT_CKMTFF(X,F1) | |
24600 | A2 = DT_CKMTFF(X,F2) | |
24601 | C A1=ALOG(A1) | |
24602 | C A2=ALOG(A2) | |
24603 | S1 = (IS-1)*DELTA | |
24604 | S2 = S1+DELTA | |
24605 | ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1) | |
24606 | C ANS=EXP(ANS) | |
24607 | RETURN | |
24608 | END | |
24609 | C | |
24610 | ||
24611 | *$ CREATE DT_CKMTFF.FOR | |
24612 | *COPY DT_CKMTFF | |
24613 | FUNCTION DT_CKMTFF(X,FVL) | |
24614 | C********************************************************************** | |
24615 | C | |
24616 | C LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE | |
24617 | C FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1. | |
24618 | C NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED | |
24619 | C IN MAIN ROUTINE. | |
24620 | C | |
24621 | C********************************************************************** | |
24622 | ||
24623 | SAVE | |
24624 | DIMENSION FVL(25),XGRID(25) | |
24625 | DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15, | |
24626 | *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/ | |
24627 | C | |
24628 | DT_CKMTFF=0. | |
24629 | DO 1 I=1,NX | |
24630 | IF(X.LT.XGRID(I)) GO TO 2 | |
24631 | 1 CONTINUE | |
24632 | 2 I=I-1 | |
24633 | IF(I.EQ.0) THEN | |
24634 | I=I+1 | |
24635 | ELSE IF(I.GT.23) THEN | |
24636 | I=23 | |
24637 | ENDIF | |
24638 | J=I+1 | |
24639 | K=J+1 | |
24640 | AXI=LOG(XGRID(I)) | |
24641 | BXI=LOG(1.-XGRID(I)) | |
24642 | AXJ=LOG(XGRID(J)) | |
24643 | BXJ=LOG(1.-XGRID(J)) | |
24644 | AXK=LOG(XGRID(K)) | |
24645 | BXK=LOG(1.-XGRID(K)) | |
24646 | FI=LOG(ABS(FVL(I)) +1.E-15) | |
24647 | FJ=LOG(ABS(FVL(J)) +1.E-16) | |
24648 | FK=LOG(ABS(FVL(K)) +1.E-17) | |
24649 | DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ) | |
24650 | ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ* | |
24651 | $ BXI))/DET | |
24652 | ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET | |
24653 | BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET | |
24654 | IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.) | |
24655 | 1RETURN | |
24656 | C IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN | |
24657 | C WRITE(6,2001) X,FVL | |
24658 | C 2001 FORMAT(8E12.4) | |
24659 | C WRITE(6,2001) ALPHA,BETA,ALOGA,DET | |
24660 | C ENDIF | |
24661 | DT_CKMTFF=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA | |
24662 | RETURN | |
24663 | END | |
24664 | ||
24665 | *$ CREATE DT_FLUINI.FOR | |
24666 | *COPY DT_FLUINI | |
24667 | * | |
24668 | *===fluini=============================================================* | |
24669 | * | |
24670 | SUBROUTINE DT_FLUINI | |
24671 | ||
24672 | ************************************************************************ | |
24673 | * Initialisation of the nucleon-nucleon cross section fluctuation * | |
24674 | * treatment. The original version by J. Ranft. * | |
24675 | * This version dated 21.04.95 is revised by S. Roesler. * | |
24676 | ************************************************************************ | |
24677 | ||
24678 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
24679 | SAVE | |
24680 | PARAMETER ( LINP = 10 , | |
24681 | & LOUT = 6 , | |
24682 | & LDAT = 9 ) | |
24683 | PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0) | |
24684 | ||
24685 | PARAMETER ( A = 0.1D0, | |
24686 | & B = 0.893D0, | |
24687 | & OM = 1.1D0, | |
24688 | & N = 6, | |
24689 | & DX = 0.003D0) | |
24690 | ||
24691 | * n-n cross section fluctuations | |
24692 | PARAMETER (NBINS = 1000) | |
24693 | COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT | |
24694 | DIMENSION FLUSI(NBINS),FLUIX(NBINS) | |
24695 | ||
24696 | WRITE(LOUT,1000) | |
24697 | 1000 FORMAT(/,1X,'FLUINI: hadronic cross section fluctuations ', | |
24698 | & 'treated') | |
24699 | ||
24700 | FLUSU = ZERO | |
24701 | FLUSUU = ZERO | |
24702 | ||
24703 | DO 1 I=1,NBINS | |
24704 | X = DBLE(I)*DX | |
24705 | FLUIX(I) = X | |
24706 | FLUS = ((X-B)/(OM*B))**N | |
24707 | IF (FLUS.LE.20.0D0) THEN | |
24708 | FLUSI(I) = (X/B)*EXP(-FLUS)/(X/B+A) | |
24709 | ELSE | |
24710 | FLUSI(I) = ZERO | |
24711 | ENDIF | |
24712 | FLUSU = FLUSU+FLUSI(I) | |
24713 | 1 CONTINUE | |
24714 | DO 2 I=1,NBINS | |
24715 | FLUSUU = FLUSUU+FLUSI(I)/FLUSU | |
24716 | FLUSI(I) = FLUSUU | |
24717 | 2 CONTINUE | |
24718 | ||
24719 | C WRITE(LOUT,1001) | |
24720 | C1001 FORMAT(1X,'FLUCTUATIONS') | |
24721 | C CALL PLOT(FLUIX,FLUSI,1000,1,1000,0.0D0,0.06D0,0.0D0,0.01D0) | |
24722 | ||
24723 | DO 3 I=1,NBINS | |
24724 | AF = DBLE(I)*0.001D0 | |
24725 | DO 4 J=1,NBINS | |
24726 | IF (AF.LE.FLUSI(J)) THEN | |
24727 | FLUIXX(I) = FLUIX(J) | |
24728 | GOTO 5 | |
24729 | ENDIF | |
24730 | 4 CONTINUE | |
24731 | 5 CONTINUE | |
24732 | 3 CONTINUE | |
24733 | FLUIXX(1) = FLUIX(1) | |
24734 | FLUIXX(NBINS) = FLUIX(NBINS) | |
24735 | ||
24736 | RETURN | |
24737 | END | |
24738 | ||
24739 | *$ CREATE DT_SIGTBL.FOR | |
24740 | *COPY DT_SIGTBL | |
24741 | * | |
24742 | *===sigtab=============================================================* | |
24743 | * | |
24744 | SUBROUTINE DT_SIGTBL(JP,JT,PTOT,SIGE,MODE) | |
24745 | ||
24746 | ************************************************************************ | |
24747 | * This version dated 18.11.95 is written by S. Roesler * | |
24748 | ************************************************************************ | |
24749 | ||
24750 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
24751 | SAVE | |
24752 | PARAMETER ( LINP = 10 , | |
24753 | & LOUT = 6 , | |
24754 | & LDAT = 9 ) | |
24755 | ||
24756 | PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10, | |
24757 | & OHALF=0.5D0,ONE=1.0D0) | |
24758 | PARAMETER (PLO=0.01D0,PHI=20.0D0,NBINS=150) | |
24759 | ||
24760 | LOGICAL LINIT | |
24761 | ||
24762 | * particle properties (BAMJET index convention) | |
24763 | CHARACTER*8 ANAME | |
24764 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
24765 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
24766 | ||
24767 | DIMENSION SIGEP(5,NBINS+1),SIGEN(5,NBINS+1),IDSIG(23) | |
24768 | DATA IDSIG / 1, 0, 0, 0, 0, 0, 0, 2, 0, 0, | |
24769 | & 0, 0, 3, 4, 0, 0, 0, 0, 0, 0, | |
24770 | & 0, 0, 5/ | |
24771 | DATA LINIT /.FALSE./ | |
24772 | ||
24773 | * precalculation and tabulation of elastic cross sections | |
24774 | IF (ABS(MODE).EQ.1) THEN | |
24775 | IF (MODE.EQ.1) | |
24776 | & OPEN(LDAT,FILE='outdata0/sigtab.out',STATUS='UNKNOWN') | |
24777 | PLABLX = LOG10(PLO) | |
24778 | PLABHX = LOG10(PHI) | |
24779 | DPLAB = (PLABHX-PLABLX)/DBLE(NBINS) | |
24780 | DO 1 I=1,NBINS+1 | |
24781 | PLAB = PLABLX+DBLE(I-1)*DPLAB | |
24782 | PLAB = 10**PLAB | |
24783 | DO 2 IPROJ=1,23 | |
24784 | IDX = IDSIG(IPROJ) | |
24785 | IF (IDX.GT.0) THEN | |
24786 | C CALL DT_SIHNEL(IPROJ,1,PLAB,SIGEP(IDX,I)) | |
24787 | C CALL DT_SIHNEL(IPROJ,8,PLAB,SIGEN(IDX,I)) | |
24788 | DUMZER = ZERO | |
24789 | CALL DT_XSHN(IPROJ,1,PLAB,DUMZER,SIGTOT,SIGEP(IDX,I)) | |
24790 | CALL DT_XSHN(IPROJ,8,PLAB,DUMZER,SIGTOT,SIGEN(IDX,I)) | |
24791 | ENDIF | |
24792 | 2 CONTINUE | |
24793 | IF (MODE.EQ.1) THEN | |
24794 | WRITE(LDAT,1000) PLAB,(SIGEP(IDX,I),IDX=1,5), | |
24795 | & (SIGEN(IDX,I),IDX=1,5) | |
24796 | 1000 FORMAT(F5.1,10F7.2) | |
24797 | ENDIF | |
24798 | 1 CONTINUE | |
24799 | IF (MODE.EQ.1) CLOSE(LDAT) | |
24800 | LINIT = .TRUE. | |
24801 | ELSE | |
24802 | SIGE = -ONE | |
24803 | IF (LINIT.AND.(JP.LE.23).AND.(PTOT.GE.PLO) | |
24804 | & .AND.(PTOT.LE.PHI) ) THEN | |
24805 | IDX = IDSIG(JP) | |
24806 | IF ( (IDX.GT.0).AND.((JT.EQ.1).OR.(JT.EQ.8)) ) THEN | |
24807 | PLABX = LOG10(PTOT) | |
24808 | IF (PLABX.LE.PLABLX) THEN | |
24809 | I1 = 1 | |
24810 | I2 = 1 | |
24811 | ELSEIF (PLABX.GE.PLABHX) THEN | |
24812 | I1 = NBINS+1 | |
24813 | I2 = NBINS+1 | |
24814 | ELSE | |
24815 | I1 = INT((PLABX-PLABLX)/DPLAB)+1 | |
24816 | I2 = I1+1 | |
24817 | ENDIF | |
24818 | PLAB1X = PLABLX+DBLE(I1-1)*DPLAB | |
24819 | PLAB2X = PLABLX+DBLE(I2-1)*DPLAB | |
24820 | PBIN = PLAB2X-PLAB1X | |
24821 | IF (PBIN.GT.TINY10) THEN | |
24822 | RATX = (PLABX-PLAB1X)/(PLAB2X-PLAB1X) | |
24823 | ELSE | |
24824 | RATX = ZERO | |
24825 | ENDIF | |
24826 | IF (JT.EQ.1) THEN | |
24827 | SIG1 = SIGEP(IDX,I1) | |
24828 | SIG2 = SIGEP(IDX,I2) | |
24829 | ELSE | |
24830 | SIG1 = SIGEN(IDX,I1) | |
24831 | SIG2 = SIGEN(IDX,I2) | |
24832 | ENDIF | |
24833 | SIGE = SIG1+RATX*(SIG2-SIG1) | |
24834 | ENDIF | |
24835 | ENDIF | |
24836 | ENDIF | |
24837 | ||
24838 | RETURN | |
24839 | END | |
24840 | ||
24841 | *$ CREATE DT_XSTABL.FOR | |
24842 | *COPY DT_XSTABL | |
24843 | * | |
24844 | *===xstabl=============================================================* | |
24845 | * | |
24846 | SUBROUTINE DT_XSTABL(WHAT,IXSQEL,IRATIO) | |
24847 | ||
24848 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
24849 | SAVE | |
24850 | PARAMETER ( LINP = 10 , | |
24851 | & LOUT = 6 , | |
24852 | & LDAT = 9 ) | |
24853 | PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10, | |
24854 | & OHALF=0.5D0,ONE=1.0D0,TWO=2.0D0) | |
24855 | LOGICAL LLAB,LELOG,LQLOG | |
24856 | ||
24857 | * particle properties (BAMJET index convention) | |
24858 | CHARACTER*8 ANAME | |
24859 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
24860 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
24861 | * properties of interacting particles | |
24862 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
24863 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
24864 | * Glauber formalism: cross sections | |
24865 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
24866 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
24867 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
24868 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
24869 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
24870 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
24871 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
24872 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
24873 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
24874 | & BSLOPE,NEBINI,NQBINI | |
24875 | * emulsion treatment | |
24876 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
24877 | & NCOMPO,IEMUL | |
24878 | ||
24879 | DIMENSION WHAT(6) | |
24880 | ||
24881 | LLAB = (WHAT(1).GT.ZERO).OR.(WHAT(2).GT.ZERO) | |
24882 | ELO = ABS(WHAT(1)) | |
24883 | EHI = ABS(WHAT(2)) | |
24884 | IF (ELO.GT.EHI) ELO = EHI | |
24885 | LELOG = WHAT(3).LT.ZERO | |
24886 | NEBINS = MAX(INT(ABS(WHAT(3))),1) | |
24887 | DEBINS = (EHI-ELO)/DBLE(NEBINS) | |
24888 | IF (LELOG) THEN | |
24889 | AELO = LOG10(ELO) | |
24890 | AEHI = LOG10(EHI) | |
24891 | ADEBIN = (AEHI-AELO)/DBLE(NEBINS) | |
24892 | ENDIF | |
24893 | Q2LO = WHAT(4) | |
24894 | Q2HI = WHAT(5) | |
24895 | IF (Q2LO.GT.Q2HI) Q2LO = Q2HI | |
24896 | LQLOG = WHAT(6).LT.ZERO | |
24897 | NQBINS = MAX(INT(ABS(WHAT(6))),1) | |
24898 | DQBINS = (Q2HI-Q2LO)/DBLE(NQBINS) | |
24899 | IF (LQLOG) THEN | |
24900 | AQ2LO = LOG10(Q2LO) | |
24901 | AQ2HI = LOG10(Q2HI) | |
24902 | ADQBIN = (AQ2HI-AQ2LO)/DBLE(NQBINS) | |
24903 | ENDIF | |
24904 | ||
24905 | IF ( ELO.EQ. EHI) NEBINS = 0 | |
24906 | IF (Q2LO.EQ.Q2HI) NQBINS = 0 | |
24907 | ||
24908 | WRITE(LOUT,1000) ELO,EHI,LLAB,IXSQEL,Q2LO,Q2HI,IJPROJ,IP,IT | |
24909 | 1000 FORMAT(/,1X,'XSTABL: E_lo =',E10.3,' GeV E_hi =',E10.3, | |
24910 | & ' GeV Lab = ',L1,' qel: ',I2,/,10X,'Q2_lo =',F10.5, | |
24911 | & ' GeV^2 Q2_hi =',F10.5,' GeV^2',/,10X,'id_p = ',I2, | |
24912 | & ' A_p = ',I3,' A_t = ',I3,/) | |
24913 | ||
24914 | C IF (IJPROJ.NE.7) THEN | |
24915 | WRITE(LOUT,'(1X,A,/)')'(E,STOT,SELA,SQEP,SQET,SQE2,SINE,SPROD)' | |
24916 | * normalize fractions of emulsion components | |
24917 | IF (NCOMPO.GT.0) THEN | |
24918 | SUMFRA = ZERO | |
24919 | DO 10 I=1,NCOMPO | |
24920 | SUMFRA = SUMFRA+EMUFRA(I) | |
24921 | 10 CONTINUE | |
24922 | IF (SUMFRA.GT.ZERO) THEN | |
24923 | DO 11 I=1,NCOMPO | |
24924 | EMUFRA(I) = EMUFRA(I)/SUMFRA | |
24925 | 11 CONTINUE | |
24926 | ENDIF | |
24927 | ENDIF | |
24928 | C ELSE | |
24929 | C WRITE(LOUT,'(1X,A,/)') '(Q2,E,STOT,ETOT,SIN,EIN,STOT0)' | |
24930 | C ENDIF | |
24931 | DO 1 I=1,NEBINS+1 | |
24932 | IF (LELOG) THEN | |
24933 | E = 10**(AELO+DBLE(I-1)*ADEBIN) | |
24934 | ELSE | |
24935 | E = ELO+DBLE(I-1)*DEBINS | |
24936 | ENDIF | |
24937 | DO 2 J=1,NQBINS+1 | |
24938 | IF (LQLOG) THEN | |
24939 | Q2 = 10**(AQ2LO+DBLE(J-1)*ADQBIN) | |
24940 | ELSE | |
24941 | Q2 = Q2LO+DBLE(J-1)*DQBINS | |
24942 | ENDIF | |
24943 | c IF (IJPROJ.NE.7) THEN | |
24944 | IF (LLAB) THEN | |
24945 | PLAB = ZERO | |
24946 | ECM = ZERO | |
24947 | CALL DT_LTINI(IJPROJ,1,E,PPN0,ECM,0) | |
24948 | ELSE | |
24949 | ECM = E | |
24950 | ENDIF | |
24951 | XI = ZERO | |
24952 | Q2I = ZERO | |
24953 | IF (IJPROJ.EQ.7) Q2I = Q2 | |
24954 | IF (NCOMPO.GT.0) THEN | |
24955 | DO 20 IC=1,NCOMPO | |
24956 | IIT = IEMUMA(IC) | |
24957 | CALL DT_XSGLAU(IP,IIT,IJPROJ,XI,Q2I,ECM,1,1,-IC) | |
24958 | 20 CONTINUE | |
24959 | ELSE | |
24960 | CALL DT_XSGLAU(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,-1) | |
24961 | C CALL AMPLIT(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,1) | |
24962 | ENDIF | |
24963 | IF (NCOMPO.GT.0) THEN | |
24964 | XTOT = ZERO | |
24965 | ETOT = ZERO | |
24966 | XELA = ZERO | |
24967 | EELA = ZERO | |
24968 | XQEP = ZERO | |
24969 | EQEP = ZERO | |
24970 | XQET = ZERO | |
24971 | EQET = ZERO | |
24972 | XQE2 = ZERO | |
24973 | EQE2 = ZERO | |
24974 | XPRO = ZERO | |
24975 | EPRO = ZERO | |
24976 | XPRO1= ZERO | |
24977 | XDEL = ZERO | |
24978 | EDEL = ZERO | |
24979 | XDQE = ZERO | |
24980 | EDQE = ZERO | |
24981 | DO 21 IC=1,NCOMPO | |
24982 | XTOT = XTOT+EMUFRA(IC)*XSTOT(1,1,IC) | |
24983 | ETOT = ETOT+EMUFRA(IC)*XETOT(1,1,IC)**2 | |
24984 | XELA = XELA+EMUFRA(IC)*XSELA(1,1,IC) | |
24985 | EELA = EELA+EMUFRA(IC)*XEELA(1,1,IC)**2 | |
24986 | XQEP = XQEP+EMUFRA(IC)*XSQEP(1,1,IC) | |
24987 | EQEP = EQEP+EMUFRA(IC)*XEQEP(1,1,IC)**2 | |
24988 | XQET = XQET+EMUFRA(IC)*XSQET(1,1,IC) | |
24989 | EQET = EQET+EMUFRA(IC)*XEQET(1,1,IC)**2 | |
24990 | XQE2 = XQE2+EMUFRA(IC)*XSQE2(1,1,IC) | |
24991 | EQE2 = EQE2+EMUFRA(IC)*XEQE2(1,1,IC)**2 | |
24992 | XPRO = XPRO+EMUFRA(IC)*XSPRO(1,1,IC) | |
24993 | EPRO = EPRO+EMUFRA(IC)*XEPRO(1,1,IC)**2 | |
24994 | XDEL = XDEL+EMUFRA(IC)*XSDEL(1,1,IC) | |
24995 | EDEL = EDEL+EMUFRA(IC)*XEDEL(1,1,IC)**2 | |
24996 | XDQE = XDQE+EMUFRA(IC)*XSDQE(1,1,IC) | |
24997 | EDQE = EDQE+EMUFRA(IC)*XEDQE(1,1,IC)**2 | |
24998 | YPRO = XSTOT(1,1,IC)-XSELA(1,1,IC) | |
24999 | & -XSQEP(1,1,IC)-XSQET(1,1,IC) | |
25000 | & -XSQE2(1,1,IC) | |
25001 | XPRO1= XPRO1+EMUFRA(IC)*YPRO | |
25002 | 21 CONTINUE | |
25003 | ETOT = SQRT(ETOT) | |
25004 | EELA = SQRT(EELA) | |
25005 | EQEP = SQRT(EQEP) | |
25006 | EQET = SQRT(EQET) | |
25007 | EQE2 = SQRT(EQE2) | |
25008 | EPRO = SQRT(EPRO) | |
25009 | EDEL = SQRT(EDEL) | |
25010 | EDQE = SQRT(EDQE) | |
25011 | WRITE(LOUT,'(8E9.3)') | |
25012 | & E,XTOT,XELA,XQEP,XQET,XQE2,XPRO,XPRO1 | |
25013 | C WRITE(LOUT,'(4E9.3)') | |
25014 | C & E,XDEL,XDQE,XDEL+XDQE | |
25015 | ELSE | |
25016 | WRITE(LOUT,'(11E10.3)') | |
25017 | & E, | |
25018 | & XSTOT(1,1,1),XSELA(1,1,1),XSQEP(1,1,1),XSQET(1,1,1), | |
25019 | & XSQE2(1,1,1),XSPRO(1,1,1), | |
25020 | & XSTOT(1,1,1)-XSELA(1,1,1)-XSQEP(1,1,1)-XSQET(1,1,1) | |
25021 | & -XSQE2(1,1,1),XSDEL(1,1,1),XSDQE(1,1,1), | |
25022 | & XSDEL(1,1,1)+XSDQE(1,1,1) | |
25023 | C WRITE(LOUT,'(4E9.3)') E,XSDEL(1,1,1),XSDQE(1,1,1), | |
25024 | C & XSDEL(1,1,1)+XSDQE(1,1,1) | |
25025 | ENDIF | |
25026 | c ELSE | |
25027 | c IF (LLAB) THEN | |
25028 | c IF (IT.GT.1) THEN | |
25029 | c IF (IXSQEL.EQ.0) THEN | |
25030 | cC CALL DT_SIGGA(IT, Q2, E,ZERO,ZERO, | |
25031 | cC CALL DT_SIGGA(IT, E,Q2,ZERO,ZERO, | |
25032 | c CALL DT_SIGGA(IT,ZERO,Q2,ZERO,E, | |
25033 | c & STOT,ETOT,SIN,EIN,STOT0) | |
25034 | c IF (IRATIO.EQ.1) THEN | |
25035 | c CALL DT_SIGGP( Q2, E,ZERO,ZERO,STGP,SIGP,SDGP) | |
25036 | cC CALL DT_SIGGP( E,Q2,ZERO,ZERO,STGP,SIGP,SDGP) | |
25037 | cC CALL DT_SIGGP(ZERO,Q2,ZERO,E,STGP,SIGP,SDGP) | |
25038 | c*!! save cross sections | |
25039 | c STOTA = STOT | |
25040 | c ETOTA = ETOT | |
25041 | c STOTP = STGP | |
25042 | c*!! | |
25043 | c STOT = STOT/(DBLE(IT)*STGP) | |
25044 | c SIN = SIN/(DBLE(IT)*SIGP) | |
25045 | c STOT0 = STGP | |
25046 | c ETOT = ZERO | |
25047 | c EIN = ZERO | |
25048 | c ENDIF | |
25049 | c ELSE | |
25050 | c WRITE(LOUT,*) | |
25051 | c & ' XSTABL: qel. xs. not implemented for nuclei' | |
25052 | c STOP | |
25053 | c ENDIF | |
25054 | c ELSE | |
25055 | c ETOT = ZERO | |
25056 | c EIN = ZERO | |
25057 | c STOT0= ZERO | |
25058 | c IF (IXSQEL.EQ.0) THEN | |
25059 | c CALL DT_SIGGP(ZERO,Q2,ZERO,E,STOT,SIN,SDIR) | |
25060 | c ELSE | |
25061 | c SIN = ZERO | |
25062 | c CALL DT_SIGVEL(ZERO,Q2,ZERO,E,IXSQEL,STOT,SIN,STOT0) | |
25063 | c ENDIF | |
25064 | c ENDIF | |
25065 | c ELSE | |
25066 | c IF (IT.GT.1) THEN | |
25067 | c IF (IXSQEL.EQ.0) THEN | |
25068 | c CALL DT_SIGGA(IT,ZERO,Q2,E,ZERO, | |
25069 | c & STOT,ETOT,SIN,EIN,STOT0) | |
25070 | c IF (IRATIO.EQ.1) THEN | |
25071 | c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STGP,SIGP,SDGP) | |
25072 | c*!! save cross sections | |
25073 | c STOTA = STOT | |
25074 | c ETOTA = ETOT | |
25075 | c STOTP = STGP | |
25076 | c*!! | |
25077 | c STOT = STOT/(DBLE(IT)*STGP) | |
25078 | c SIN = SIN/(DBLE(IT)*SIGP) | |
25079 | c STOT0 = STGP | |
25080 | c ETOT = ZERO | |
25081 | c EIN = ZERO | |
25082 | c ENDIF | |
25083 | c ELSE | |
25084 | c WRITE(LOUT,*) | |
25085 | c & ' XSTABL: qel. xs. not implemented for nuclei' | |
25086 | c STOP | |
25087 | c ENDIF | |
25088 | c ELSE | |
25089 | c ETOT = ZERO | |
25090 | c EIN = ZERO | |
25091 | c STOT0= ZERO | |
25092 | c IF (IXSQEL.EQ.0) THEN | |
25093 | c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STOT,SIN,SDIR) | |
25094 | c ELSE | |
25095 | c SIN = ZERO | |
25096 | c CALL DT_SIGVEL(ZERO,Q2,E,ZERO,IXSQEL,STOT,SIN,STOT0) | |
25097 | c ENDIF | |
25098 | c ENDIF | |
25099 | c ENDIF | |
25100 | cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,STOTA,ETOTA,STOTP,ZERO | |
25101 | cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,SDIR | |
25102 | cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,STOT0 | |
25103 | c WRITE(LOUT,'(1X,6E10.3)')Q2,E,STOT,ETOT,SIN,EIN | |
25104 | c ENDIF | |
25105 | 2 CONTINUE | |
25106 | 1 CONTINUE | |
25107 | ||
25108 | RETURN | |
25109 | END | |
25110 | ||
25111 | *$ CREATE DT_TESTXS.FOR | |
25112 | *COPY DT_TESTXS | |
25113 | * | |
25114 | *===testxs=============================================================* | |
25115 | * | |
25116 | SUBROUTINE DT_TESTXS | |
25117 | ||
25118 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25119 | SAVE | |
25120 | ||
25121 | DIMENSION XSTOT(26,2),XSELA(26,2) | |
25122 | ||
25123 | OPEN(10,FILE='testxs_ptot.out',STATUS='UNKNOWN') | |
25124 | OPEN(11,FILE='testxs_pela.out',STATUS='UNKNOWN') | |
25125 | OPEN(12,FILE='testxs_ntot.out',STATUS='UNKNOWN') | |
25126 | OPEN(13,FILE='testxs_nela.out',STATUS='UNKNOWN') | |
25127 | DUMECM = 0.0D0 | |
25128 | PLABL = 0.01D0 | |
25129 | PLABH = 10000.0D0 | |
25130 | NBINS = 120 | |
25131 | APLABL = LOG10(PLABL) | |
25132 | APLABH = LOG10(PLABH) | |
25133 | ADPLAB = (APLABH-APLABL)/DBLE(NBINS) | |
25134 | DO 1 I=1,NBINS+1 | |
25135 | ADP = APLABL+DBLE(I-1)*ADPLAB | |
25136 | P = 10.0D0**ADP | |
25137 | DO 2 J=1,26 | |
25138 | CALL DT_XSHN(J,1,P,DUMECM,XSTOT(J,1),XSELA(J,1)) | |
25139 | CALL DT_XSHN(J,8,P,DUMECM,XSTOT(J,2),XSELA(J,2)) | |
25140 | 2 CONTINUE | |
25141 | WRITE(10,1000) P,(XSTOT(K,1),K=1,26) | |
25142 | WRITE(11,1000) P,(XSELA(K,1),K=1,26) | |
25143 | WRITE(12,1000) P,(XSTOT(K,2),K=1,26) | |
25144 | WRITE(13,1000) P,(XSELA(K,2),K=1,26) | |
25145 | 1 CONTINUE | |
25146 | 1000 FORMAT(F8.3,26F9.3) | |
25147 | ||
25148 | RETURN | |
25149 | END | |
25150 | ||
25151 | ************************************************************************ | |
25152 | * * | |
25153 | * DTUNUC 2.0: library routines * | |
25154 | * processed by S. Roesler, 6.5.95 * | |
25155 | * * | |
25156 | ************************************************************************ | |
25157 | * | |
25158 | * 1) Handling of parton momenta | |
25159 | * SUBROUTINE MASHEL | |
25160 | * SUBROUTINE DFERMI | |
25161 | * | |
25162 | * 2) Handling of parton flavors and particle indices | |
25163 | * INTEGER FUNCTION IPDG2B | |
25164 | * INTEGER FUNCTION IB2PDG | |
25165 | * INTEGER FUNCTION IQUARK | |
25166 | * INTEGER FUNCTION IBJQUA | |
25167 | * INTEGER FUNCTION ICIHAD | |
25168 | * INTEGER FUNCTION IPDGHA | |
25169 | * INTEGER FUNCTION MCHAD | |
25170 | * SUBROUTINE FLAHAD | |
25171 | * | |
25172 | * 3) Energy-momentum and quantum number conservation check routines | |
25173 | * SUBROUTINE EMC1 | |
25174 | * SUBROUTINE EMC2 | |
25175 | * SUBROUTINE EVTEMC | |
25176 | * SUBROUTINE EVTFLC | |
25177 | * SUBROUTINE EVTCHG | |
25178 | * | |
25179 | * 4) Transformations | |
25180 | * SUBROUTINE LTINI | |
25181 | * SUBROUTINE LTRANS | |
25182 | * SUBROUTINE LTNUC | |
25183 | * SUBROUTINE DALTRA | |
25184 | * SUBROUTINE DTRAFO | |
25185 | * SUBROUTINE STTRAN | |
25186 | * SUBROUTINE MYTRAN | |
25187 | * SUBROUTINE LT2LAO | |
25188 | * SUBROUTINE LT2LAB | |
25189 | * | |
25190 | * 5) Sampling from distributions | |
25191 | * INTEGER FUNCTION NPOISS | |
25192 | * DOUBLE PRECISION FUNCTION SAMPXB | |
25193 | * DOUBLE PRECISION FUNCTION SAMPEX | |
25194 | * DOUBLE PRECISION FUNCTION SAMSQX | |
25195 | * DOUBLE PRECISION FUNCTION BETREJ | |
25196 | * DOUBLE PRECISION FUNCTION DGAMRN | |
25197 | * DOUBLE PRECISION FUNCTION DBETAR | |
25198 | * SUBROUTINE RANNOR | |
25199 | * SUBROUTINE DPOLI | |
25200 | * SUBROUTINE DSFECF | |
25201 | * SUBROUTINE RACO | |
25202 | * | |
25203 | * 6) Special functions, algorithms and service routines | |
25204 | * DOUBLE PRECISION FUNCTION YLAMB | |
25205 | * SUBROUTINE SORT | |
25206 | * SUBROUTINE SORT1 | |
25207 | * SUBROUTINE DT_XTIME | |
25208 | * | |
25209 | * 7) Random number generator package | |
25210 | * DOUBLE PRECISION FUNCTION DT_RNDM | |
25211 | * SUBROUTINE DT_RNDMST | |
25212 | * SUBROUTINE DT_RNDMIN | |
25213 | * SUBROUTINE DT_RNDMOU | |
25214 | * SUBROUTINE DT_RNDMTE | |
25215 | * | |
25216 | ************************************************************************ | |
25217 | * * | |
25218 | * 1) Handling of parton momenta * | |
25219 | * * | |
25220 | ************************************************************************ | |
25221 | *$ CREATE DT_MASHEL.FOR | |
25222 | *COPY DT_MASHEL | |
25223 | * | |
25224 | *===mashel=============================================================* | |
25225 | * | |
25226 | SUBROUTINE DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ) | |
25227 | ||
25228 | ************************************************************************ | |
25229 | * * | |
25230 | * rescaling of momenta of two partons to put both * | |
25231 | * on mass shell * | |
25232 | * * | |
25233 | * input: PA1,PA2 input momentum vectors * | |
25234 | * XM1,2 desired masses of particles afterwards * | |
25235 | * P1,P2 changed momentum vectors * | |
25236 | * * | |
25237 | * The original version is written by R. Engel. * | |
25238 | * This version dated 12.12.94 is modified by S. Roesler. * | |
25239 | ************************************************************************ | |
25240 | ||
25241 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25242 | SAVE | |
25243 | PARAMETER ( LINP = 10 , | |
25244 | & LOUT = 6 , | |
25245 | & LDAT = 9 ) | |
25246 | PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0) | |
25247 | ||
25248 | DIMENSION PA1(4),PA2(4),P1(4),P2(4) | |
25249 | ||
25250 | IREJ = 0 | |
25251 | ||
25252 | * Lorentz transformation into system CMS | |
25253 | PX = PA1(1)+PA2(1) | |
25254 | PY = PA1(2)+PA2(2) | |
25255 | PZ = PA1(3)+PA2(3) | |
25256 | EE = PA1(4)+PA2(4) | |
25257 | XPTOT = SQRT(PX**2+PY**2+PZ**2) | |
25258 | XMS = (EE-XPTOT)*(EE+XPTOT) | |
25259 | IF(XMS.LT.(XM1+XM2)**2) THEN | |
25260 | C WRITE(LOUT,'(3E12.4)')XMS,XM1,XM2 | |
25261 | GOTO 9999 | |
25262 | ENDIF | |
25263 | XMS = SQRT(XMS) | |
25264 | BGX = PX/XMS | |
25265 | BGY = PY/XMS | |
25266 | BGZ = PZ/XMS | |
25267 | GAM = EE/XMS | |
25268 | CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3), | |
25269 | & PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4)) | |
25270 | * rotation angles | |
25271 | COD = P1(3)/PTOT1 | |
25272 | C SID = SQRT((ONE-COD)*(ONE+COD)) | |
25273 | PPT = SQRT(P1(1)**2+P1(2)**2) | |
25274 | SID = PPT/PTOT1 | |
25275 | COF = ONE | |
25276 | SIF = ZERO | |
25277 | IF(PTOT1*SID.GT.TINY10) THEN | |
25278 | COF = P1(1)/(SID*PTOT1) | |
25279 | SIF = P1(2)/(SID*PTOT1) | |
25280 | ANORF = SQRT(COF*COF+SIF*SIF) | |
25281 | COF = COF/ANORF | |
25282 | SIF = SIF/ANORF | |
25283 | ENDIF | |
25284 | * new CM momentum and energies (for masses XM1,XM2) | |
25285 | XM12 = SIGN(XM1**2,XM1) | |
25286 | XM22 = SIGN(XM2**2,XM2) | |
25287 | SS = XMS**2 | |
25288 | PCMP = DT_YLAMB(SS,XM12,XM22)/(2.D0*XMS) | |
25289 | EE1 = SQRT(XM12+PCMP**2) | |
25290 | EE2 = XMS-EE1 | |
25291 | * back rotation | |
25292 | MODE = 1 | |
25293 | CALL DT_MYTRAN(MODE,ZERO,ZERO,PCMP,COD,SID,COF,SIF,XX,YY,ZZ) | |
25294 | CALL DT_DALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1, | |
25295 | & PTOT1,P1(1),P1(2),P1(3),P1(4)) | |
25296 | CALL DT_DALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2, | |
25297 | & PTOT2,P2(1),P2(2),P2(3),P2(4)) | |
25298 | * check consistency | |
25299 | DEL = XMS*0.0001D0 | |
25300 | IF (ABS(PX-P1(1)-P2(1)).GT.DEL) THEN | |
25301 | IDEV = 1 | |
25302 | ELSEIF (ABS(PY-P1(2)-P2(2)).GT.DEL) THEN | |
25303 | IDEV = 2 | |
25304 | ELSEIF (ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN | |
25305 | IDEV = 3 | |
25306 | ELSEIF (ABS(EE-P1(4)-P2(4)).GT.DEL) THEN | |
25307 | IDEV = 4 | |
25308 | ELSE | |
25309 | IDEV = 0 | |
25310 | ENDIF | |
25311 | IF (IDEV.NE.0) THEN | |
25312 | WRITE(LOUT,'(/1X,A,I3)') | |
25313 | & 'MASHEL: inconsistent transformation',IDEV | |
25314 | WRITE(LOUT,'(1X,A)') 'MASHEL: input momenta/masses:' | |
25315 | WRITE(LOUT,'(1X,5E12.5)') (PA1(K),K=1,4),XM1 | |
25316 | WRITE(LOUT,'(1X,5E12.5)') (PA2(K),K=1,4),XM2 | |
25317 | WRITE(LOUT,'(1X,A)') 'MASHEL: output momenta:' | |
25318 | WRITE(LOUT,'(5X,4E12.5)') (P1(K),K=1,4) | |
25319 | WRITE(LOUT,'(5X,4E12.5)') (P2(K),K=1,4) | |
25320 | ENDIF | |
25321 | RETURN | |
25322 | ||
25323 | 9999 CONTINUE | |
25324 | IREJ = 1 | |
25325 | RETURN | |
25326 | END | |
25327 | ||
25328 | *$ CREATE DT_DFERMI.FOR | |
25329 | *COPY DT_DFERMI | |
25330 | * | |
25331 | *===dfermi=============================================================* | |
25332 | * | |
25333 | SUBROUTINE DT_DFERMI(GPART) | |
25334 | ||
25335 | ************************************************************************ | |
25336 | * Find largest of three random numbers. * | |
25337 | ************************************************************************ | |
25338 | ||
25339 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25340 | SAVE | |
25341 | ||
25342 | DIMENSION G(3) | |
25343 | ||
25344 | DO 10 I=1,3 | |
25345 | G(I)=DT_RNDM(GPART) | |
25346 | 10 CONTINUE | |
25347 | IF (G(3).LT.G(2)) GOTO 40 | |
25348 | IF (G(3).LT.G(1)) GOTO 30 | |
25349 | GPART = G(3) | |
25350 | 20 RETURN | |
25351 | 30 GPART = G(1) | |
25352 | GOTO 20 | |
25353 | 40 IF (G(2).LT.G(1)) GOTO 30 | |
25354 | GPART = G(2) | |
25355 | GOTO 20 | |
25356 | ||
25357 | END | |
25358 | ||
25359 | ************************************************************************ | |
25360 | * * | |
25361 | * 2) Handling of parton flavors and particle indices * | |
25362 | * * | |
25363 | ************************************************************************ | |
25364 | *$ CREATE IDT_IPDG2B.FOR | |
25365 | *COPY IDT_IPDG2B | |
25366 | * | |
25367 | *===ipdg2b=============================================================* | |
25368 | * | |
25369 | INTEGER FUNCTION IDT_IPDG2B(ID,NN,MODE) | |
25370 | ||
25371 | ************************************************************************ | |
25372 | * * | |
25373 | * conversion of quark numbering scheme * | |
25374 | * * | |
25375 | * input: PDG parton numbering * | |
25376 | * for diquarks: NN number of the constituent quark * | |
25377 | * (e.g. ID=2301,NN=1 -> ICONV2=1) * | |
25378 | * * | |
25379 | * output: BAMJET particle codes * | |
25380 | * 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) * | |
25381 | * 2 d 8 a-d -2 a-d * | |
25382 | * 3 s 9 a-s -3 a-s * | |
25383 | * 4 c 10 a-c -4 a-c * | |
25384 | * * | |
25385 | * This is a modified version of ICONV2 written by R. Engel. * | |
25386 | * This version dated 13.12.94 is written by S. Roesler. * | |
25387 | ************************************************************************ | |
25388 | ||
25389 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25390 | SAVE | |
25391 | PARAMETER ( LINP = 10 , | |
25392 | & LOUT = 6 , | |
25393 | & LDAT = 9 ) | |
25394 | ||
25395 | IDA = ABS(ID) | |
25396 | * diquarks | |
25397 | IF (IDA.GT.6) THEN | |
25398 | KF = 3 | |
25399 | IF (IDA.GE.1000) KF = 4 | |
25400 | IDA = IDA/(10**(KF-NN)) | |
25401 | IDA = MOD(IDA,10) | |
25402 | ENDIF | |
25403 | * exchange up and dn quarks | |
25404 | IF (IDA.EQ.1) THEN | |
25405 | IDA = 2 | |
25406 | ELSEIF (IDA.EQ.2) THEN | |
25407 | IDA = 1 | |
25408 | ENDIF | |
25409 | * antiquarks | |
25410 | IF (ID.LT.0) THEN | |
25411 | IF (MODE.EQ.1) THEN | |
25412 | IDA = IDA+6 | |
25413 | ELSE | |
25414 | IDA = -IDA | |
25415 | ENDIF | |
25416 | ENDIF | |
25417 | IDT_IPDG2B = IDA | |
25418 | ||
25419 | RETURN | |
25420 | END | |
25421 | ||
25422 | *$ CREATE IDT_IB2PDG.FOR | |
25423 | *COPY IDT_IB2PDG | |
25424 | * | |
25425 | *===ib2pdg=============================================================* | |
25426 | * | |
25427 | INTEGER FUNCTION IDT_IB2PDG(ID1,ID2,MODE) | |
25428 | ||
25429 | ************************************************************************ | |
25430 | * * | |
25431 | * conversion of quark numbering scheme * | |
25432 | * * | |
25433 | * input: BAMJET particle codes * | |
25434 | * 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) * | |
25435 | * 2 d 8 a-d -2 a-d * | |
25436 | * 3 s 9 a-s -3 a-s * | |
25437 | * 4 c 10 a-c -4 a-c * | |
25438 | * * | |
25439 | * output: PDG parton numbering * | |
25440 | * * | |
25441 | * This version dated 13.12.94 is written by S. Roesler. * | |
25442 | ************************************************************************ | |
25443 | ||
25444 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25445 | SAVE | |
25446 | PARAMETER ( LINP = 10 , | |
25447 | & LOUT = 6 , | |
25448 | & LDAT = 9 ) | |
25449 | ||
25450 | DIMENSION IHKKQ(-6:6),IHKKQQ(-3:3,-3:3) | |
25451 | DATA IHKKQ/-6,-5,-4,-3,-1,-2,0,2,1,3,4,5,6/ | |
25452 | DATA IHKKQQ/-3303,-3103,-3203,0,0,0,0, -3103,-1103,-2103,0,0,0,0, | |
25453 | &-3203,-2103,-2203,0,0,0,0, 0,0,0,0,0,0,0, 0,0,0,0,2203,2103,3203, | |
25454 | &0,0,0,0,2103,1103,3103, 0,0,0,0,3203,3103,3303/ | |
25455 | ||
25456 | IDA = ID1 | |
25457 | IDB = ID2 | |
25458 | IF (MODE.EQ.1) THEN | |
25459 | IF (ID1.GT.6) IDA = -(ID1-6) | |
25460 | IF (ID2.GT.6) IDB = -(ID2-6) | |
25461 | ENDIF | |
25462 | IF (ID2.EQ.0) THEN | |
25463 | IDT_IB2PDG = IHKKQ(IDA) | |
25464 | ELSE | |
25465 | IDT_IB2PDG = IHKKQQ(IDA,IDB) | |
25466 | ENDIF | |
25467 | ||
25468 | RETURN | |
25469 | END | |
25470 | ||
25471 | *$ CREATE IDT_IQUARK.FOR | |
25472 | *COPY IDT_IQUARK | |
25473 | * | |
25474 | *===ipdgqu=============================================================* | |
25475 | * | |
25476 | INTEGER FUNCTION IDT_IQUARK(K,IDBAMJ) | |
25477 | ||
25478 | ************************************************************************ | |
25479 | * * | |
25480 | * quark contents according to PDG conventions * | |
25481 | * (random selection in case of quark mixing) * | |
25482 | * * | |
25483 | * input: IDBAMJ BAMJET particle code * | |
25484 | * K 1..3 quark number * | |
25485 | * * | |
25486 | * output: 1 d (anti --> neg.) * | |
25487 | * 2 u * | |
25488 | * 3 s * | |
25489 | * 4 c * | |
25490 | * * | |
25491 | * This version written by R. Engel. * | |
25492 | ************************************************************************ | |
25493 | ||
25494 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25495 | SAVE | |
25496 | ||
25497 | IQ = IDT_IBJQUA(K,IDBAMJ) | |
25498 | * quark-antiquark | |
25499 | IF (IQ.GT.6) THEN | |
25500 | IQ = 6-IQ | |
25501 | ENDIF | |
25502 | * exchange of up and down | |
25503 | IF (ABS(IQ).EQ.1) THEN | |
25504 | IQ = SIGN(2,IQ) | |
25505 | ELSEIF (ABS(IQ).EQ.2) THEN | |
25506 | IQ = SIGN(1,IQ) | |
25507 | ENDIF | |
25508 | IDT_IQUARK = IQ | |
25509 | ||
25510 | RETURN | |
25511 | END | |
25512 | ||
25513 | *$ CREATE IDT_IBJQUA.FOR | |
25514 | *COPY IDT_IBJQUA | |
25515 | * | |
25516 | *===ibamq==============================================================* | |
25517 | * | |
25518 | INTEGER FUNCTION IDT_IBJQUA(K,IDBAMJ) | |
25519 | ||
25520 | ************************************************************************ | |
25521 | * * | |
25522 | * quark contents according to BAMJET conventions * | |
25523 | * (random selection in case of quark mixing) * | |
25524 | * * | |
25525 | * input: IDBAMJ BAMJET particle code * | |
25526 | * K 1..3 quark number * | |
25527 | * * | |
25528 | * output: 1 u 7 u bar * | |
25529 | * 2 d 8 d bar * | |
25530 | * 3 s 9 s bar * | |
25531 | * 4 c 10 c bar * | |
25532 | * * | |
25533 | * This version written by R. Engel. * | |
25534 | ************************************************************************ | |
25535 | ||
25536 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25537 | SAVE | |
25538 | ||
25539 | DIMENSION ITAB(3,210) | |
25540 | DATA ((ITAB(I,K),I=1,3),K=1,30) / | |
25541 | & 1, 1, 2, 7, 7, 8, 0, 0, 0, | |
25542 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25543 | & 0, 0, 0, 1, 2, 2, 7, 8, 8, | |
25544 | *sr 10.1.94 | |
25545 | C & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25546 | & 0, 0, 0, 0, 0, 0, 3, 8, 0, | |
25547 | * | |
25548 | & 1, 8, 0, 2, 7, 0, 1, 9, 0, | |
25549 | *sr 10.1.94 | |
25550 | C & 3, 7, 0, 0, 0, 0, 0, 0, 0, | |
25551 | & 3, 7, 0, 3, 1, 2, 9, 7, 8, | |
25552 | *sr 10.1.94 | |
25553 | C & 0, 0, 0, 2, 2, 3, 1, 1, 3, | |
25554 | & 2, 9, 0, 2, 2, 3, 1, 1, 3, | |
25555 | * | |
25556 | & 1, 2, 3, 201,202, 0, 2, 9, 0, | |
25557 | & 3, 8, 0, 0, 0, 0, 0, 0, 0, | |
25558 | & 0, 0, 0, 0, 0, 0, 0, 0, 0 / | |
25559 | DATA ((ITAB(I,K),I=1,3),K=31,60) / | |
25560 | & 3, 9, 0, 1, 8, 0, 203,204, 0, | |
25561 | & 2, 7, 0, 0, 0, 0, 1, 9, 0, | |
25562 | & 2, 9, 0, 3, 7, 0, 3, 8, 0, | |
25563 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25564 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25565 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25566 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25567 | & 0, 0, 0, 1, 1, 1, 1, 1, 2, | |
25568 | & 1, 2, 2, 2, 2, 2, 0, 0, 0, | |
25569 | & 0, 0, 0, 0, 0, 0, 0, 0, 0 / | |
25570 | DATA ((ITAB(I,K),I=1,3),K=61,90) / | |
25571 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25572 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25573 | & 7, 7, 7, 7, 7, 8, 7, 8, 8, | |
25574 | & 8, 8, 8, 0, 0, 0, 0, 0, 0, | |
25575 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25576 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25577 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25578 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25579 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25580 | & 0, 0, 0, 0, 0, 0, 0, 0, 0 / | |
25581 | DATA ((ITAB(I,K),I=1,3),K=91,120) / | |
25582 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25583 | & 0, 0, 0, 0, 0, 0, 3, 9, 0, | |
25584 | & 1, 3, 3, 2, 3, 3, 7, 7, 9, | |
25585 | & 7, 8, 9, 8, 8, 9, 7, 9, 9, | |
25586 | & 8, 9, 9, 1, 1, 3, 1, 2, 3, | |
25587 | & 2, 2, 3, 1, 3, 3, 2, 3, 3, | |
25588 | & 3, 3, 3, 7, 7, 9, 7, 8, 9, | |
25589 | & 8, 8, 9, 7, 9, 9, 8, 9, 9, | |
25590 | & 9, 9, 9, 4, 7, 0, 4, 8, 0, | |
25591 | & 2, 10, 0, 1, 10, 0, 4, 9, 0 / | |
25592 | DATA ((ITAB(I,K),I=1,3),K=121,150) / | |
25593 | & 3, 10, 0, 4, 10, 0, 4, 7, 0, | |
25594 | & 4, 8, 0, 2, 10, 0, 1, 10, 0, | |
25595 | & 4, 9, 0, 3, 10, 0, 4, 10, 0, | |
25596 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25597 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25598 | & 0, 0, 0, 1, 2, 4, 1, 3, 4, | |
25599 | & 2, 3, 4, 1, 1, 4, 0, 0, 0, | |
25600 | & 2, 2, 4, 0, 0, 0, 0, 0, 0, | |
25601 | & 3, 3, 4, 1, 4, 4, 2, 4, 4, | |
25602 | & 3, 4, 4, 7, 8, 10, 7, 9, 10 / | |
25603 | DATA ((ITAB(I,K),I=1,3),K=151,180) / | |
25604 | & 8, 9, 10, 7, 7, 10, 0, 0, 0, | |
25605 | & 8, 8, 10, 0, 0, 0, 0, 0, 0, | |
25606 | & 9, 9, 10, 7, 10, 10, 8, 10, 10, | |
25607 | & 9, 10, 10, 1, 1, 4, 1, 2, 4, | |
25608 | & 2, 2, 4, 1, 3, 4, 2, 3, 4, | |
25609 | & 3, 3, 4, 1, 4, 4, 2, 4, 4, | |
25610 | & 3, 4, 4, 4, 4, 4, 7, 7, 10, | |
25611 | & 7, 8, 10, 8, 8, 10, 7, 9, 10, | |
25612 | & 8, 9, 10, 9, 9, 10, 7, 10, 10, | |
25613 | & 8, 10, 10, 9, 10, 10, 10, 10, 10 / | |
25614 | DATA ((ITAB(I,K),I=1,3),K=181,210) / | |
25615 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25616 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25617 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25618 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25619 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25620 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25621 | & 0, 0, 0, 0, 0, 0, 1, 7, 0, | |
25622 | & 2, 8, 0, 1, 7, 0, 2, 8, 0, | |
25623 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
25624 | & 0, 0, 0, 0, 0, 0, 0, 0, 0 / | |
25625 | DATA IDOLD /0/ | |
25626 | ||
25627 | ONE = 1.0D0 | |
25628 | IF (ITAB(1,IDBAMJ).LE.200) THEN | |
25629 | ID = ITAB(K,IDBAMJ) | |
25630 | ELSE | |
25631 | IF(IDOLD.NE.IDBAMJ) THEN | |
25632 | IT = AINT((ITAB(2,IDBAMJ)-ITAB(1,IDBAMJ)+0.999999D0)* | |
25633 | & DT_RNDM(ONE)+ITAB(1,IDBAMJ)) | |
25634 | ELSE | |
25635 | IDOLD = 0 | |
25636 | ENDIF | |
25637 | ID = ITAB(K,IT) | |
25638 | ENDIF | |
25639 | IDOLD = IDBAMJ | |
25640 | IDT_IBJQUA = ID | |
25641 | ||
25642 | RETURN | |
25643 | END | |
25644 | ||
25645 | *$ CREATE IDT_ICIHAD.FOR | |
25646 | *COPY IDT_ICIHAD | |
25647 | * | |
25648 | *===icihad=============================================================* | |
25649 | * | |
25650 | INTEGER FUNCTION IDT_ICIHAD(MCIND) | |
25651 | ||
25652 | ************************************************************************ | |
25653 | * Conversion of particle index PDG proposal --> BAMJET-index scheme * | |
25654 | * This is a completely new version dated 25.10.95. * | |
25655 | * Renamed to be not in conflict with the modified PHOJET-version * | |
25656 | ************************************************************************ | |
25657 | ||
25658 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25659 | SAVE | |
25660 | ||
25661 | * hadron index conversion (BAMJET <--> PDG) | |
25662 | COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22), | |
25663 | & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19), | |
25664 | & IAMCIN(210) | |
25665 | ||
25666 | IDT_ICIHAD = 0 | |
25667 | KPDG = ABS(MCIND) | |
25668 | IF ((KPDG.EQ.0).OR.(KPDG.GT.70000)) RETURN | |
25669 | IF (MCIND.LT.0) THEN | |
25670 | JSIGN = 1 | |
25671 | ELSE | |
25672 | JSIGN = 2 | |
25673 | ENDIF | |
25674 | IF (KPDG.GE.10000) THEN | |
25675 | DO 1 I=1,19 | |
25676 | IDT_ICIHAD = IBAM5(JSIGN,I) | |
25677 | IF (IPDG5(JSIGN,I).EQ.MCIND) GOTO 5 | |
25678 | IDT_ICIHAD = 0 | |
25679 | 1 CONTINUE | |
25680 | ELSEIF (KPDG.GE.1000) THEN | |
25681 | DO 2 I=1,29 | |
25682 | IDT_ICIHAD = IBAM4(JSIGN,I) | |
25683 | IF (IPDG4(JSIGN,I).EQ.MCIND) GOTO 5 | |
25684 | IDT_ICIHAD = 0 | |
25685 | 2 CONTINUE | |
25686 | ELSEIF (KPDG.GE.100) THEN | |
25687 | DO 3 I=1,22 | |
25688 | IDT_ICIHAD = IBAM3(JSIGN,I) | |
25689 | IF (IPDG3(JSIGN,I).EQ.MCIND) GOTO 5 | |
25690 | IDT_ICIHAD = 0 | |
25691 | 3 CONTINUE | |
25692 | ELSEIF (KPDG.GE.10) THEN | |
25693 | DO 4 I=1,7 | |
25694 | IDT_ICIHAD = IBAM2(JSIGN,I) | |
25695 | IF (IPDG2(JSIGN,I).EQ.MCIND) GOTO 5 | |
25696 | IDT_ICIHAD = 0 | |
25697 | 4 CONTINUE | |
25698 | ENDIF | |
25699 | 5 CONTINUE | |
25700 | ||
25701 | RETURN | |
25702 | END | |
25703 | ||
25704 | *$ CREATE IDT_IPDGHA.FOR | |
25705 | *COPY IDT_IPDGHA | |
25706 | * | |
25707 | *===ipdgha=============================================================* | |
25708 | * | |
25709 | INTEGER FUNCTION IDT_IPDGHA(MCIND) | |
25710 | ||
25711 | ************************************************************************ | |
25712 | * Conversion of particle index BAMJET-index scheme --> PDG proposal * | |
25713 | * Adopted from the original by S. Roesler. This version dated 12.5.95 * | |
25714 | * Renamed to be not in conflict with the modified PHOJET-version * | |
25715 | ************************************************************************ | |
25716 | ||
25717 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25718 | SAVE | |
25719 | ||
25720 | * hadron index conversion (BAMJET <--> PDG) | |
25721 | COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22), | |
25722 | & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19), | |
25723 | & IAMCIN(210) | |
25724 | ||
25725 | IDT_IPDGHA = IAMCIN(MCIND) | |
25726 | ||
25727 | RETURN | |
25728 | END | |
25729 | ||
25730 | *$ CREATE DT_FLAHAD.FOR | |
25731 | *COPY DT_FLAHAD | |
25732 | * | |
25733 | *===flahad=============================================================* | |
25734 | * | |
25735 | SUBROUTINE DT_FLAHAD(ID,IF1,IF2,IF3) | |
25736 | ||
25737 | ************************************************************************ | |
25738 | * sampling of FLAvor composition for HADrons/photons * | |
25739 | * ID BAMJET-id of hadron * | |
25740 | * IF1,2,3 flavor content * | |
25741 | * (u,d,s: 1,2,3; au,ad,as: -1,-1,-3) * | |
25742 | * Note: - u,d numbering as in BAMJET * | |
25743 | * - ID .le. 30 !! * | |
25744 | * This version dated 12.03.96 is written by S. Roesler * | |
25745 | ************************************************************************ | |
25746 | ||
25747 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25748 | SAVE | |
25749 | ||
25750 | * auxiliary common for reggeon exchange (DTUNUC 1.x) | |
25751 | COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6), | |
25752 | & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6), | |
25753 | & IQTCHR(-6:6),MQUARK(3,39) | |
25754 | ||
25755 | DIMENSION JSEL(3,6) | |
25756 | DATA JSEL/ 1,2,3, 2,3,1, 3,1,2, 1,3,2, 2,1,3, 3,2,1/ | |
25757 | ||
25758 | ONE = 1.0D0 | |
25759 | IF (ID.EQ.7) THEN | |
25760 | * photon (charge dependent flavour sampling) | |
25761 | K = INT(DT_RNDM(ONE)*6.D0+1.D0) | |
25762 | IF (K.LE.4) THEN | |
25763 | IF1 = 2 | |
25764 | IF2 = -2 | |
25765 | ELSE IF(K.EQ.5) THEN | |
25766 | IF1 = 1 | |
25767 | IF2 = -1 | |
25768 | ELSE | |
25769 | IF1 = 3 | |
25770 | IF2 = -3 | |
25771 | ENDIF | |
25772 | IF(DT_RNDM(ONE).LT.0.5D0) THEN | |
25773 | K = IF1 | |
25774 | IF1 = IF2 | |
25775 | IF2 = K | |
25776 | ENDIF | |
25777 | IF3 = 0 | |
25778 | ELSE | |
25779 | * hadron | |
25780 | IX = INT(1.0D0+5.99999D0*DT_RNDM(ONE)) | |
25781 | IF1 = MQUARK(JSEL(1,IX),ID) | |
25782 | IF2 = MQUARK(JSEL(2,IX),ID) | |
25783 | IF3 = MQUARK(JSEL(3,IX),ID) | |
25784 | IF ((IF1.EQ.0).AND.(IF3.NE.0)) THEN | |
25785 | IF1 = IF3 | |
25786 | IF3 = 0 | |
25787 | ELSEIF ((IF2.EQ.0).AND.(IF3.NE.0)) THEN | |
25788 | IF2 = IF3 | |
25789 | IF3 = 0 | |
25790 | ENDIF | |
25791 | ENDIF | |
25792 | ||
25793 | RETURN | |
25794 | END | |
25795 | ||
25796 | *$ CREATE IDT_MCHAD.FOR | |
25797 | *COPY IDT_MCHAD | |
25798 | * | |
25799 | *===mchad==============================================================* | |
25800 | * | |
25801 | INTEGER FUNCTION IDT_MCHAD(ITDTU) | |
25802 | ||
25803 | ************************************************************************ | |
25804 | * Conversion of particle index BAMJET-index scheme --> HADRIN index s. * | |
25805 | * Adopted from the original by S. Roesler. This version dated 6.5.95 * | |
25806 | * * | |
25807 | * Last change 28.12.2006 by S. Roesler. * | |
25808 | ************************************************************************ | |
25809 | ||
25810 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25811 | SAVE | |
25812 | ||
25813 | DIMENSION ITRANS(210) | |
25814 | DATA ITRANS / 1, 2, -1, -1, -1, -1, -1, 8, 9, -1, -1, 24, 13, 14, | |
25815 | &15, 16, 8, 9, 25, 8, 1, 8, 23, 24, 25, -1, -1, -1, -1, -1, 23, 13, | |
25816 | &23, 14, 23, 15, 24, 16, 25, 15, 24, 16, 25, 15, 24, 16, 25, 1, 8, | |
25817 | &8, 8, 1, 1, 1, 8, 8, 1, 1, 8, 8, 1, 8, 1, 8, 1, 8, 2, 2, 9, 9, 2, | |
25818 | &2, 9, 9, 2, 9, 1, 13, 23, 14, 1, 1, 8, 8, 1, 1, 23, 14, 1, 8, 1, | |
25819 | &8, 1, 8, 23, 23, 8, 8, 2, 9, 9, 9, 9, 1, 8, 8, 8, 8, 8, 2, 9, 9, | |
25820 | &9, 9, 9, 85*- 1,7*-1,1,8,-1/ | |
25821 | ||
25822 | IF ( ITDTU .GT. 0 ) THEN | |
25823 | IDT_MCHAD = ITRANS(ITDTU) | |
25824 | ELSE | |
25825 | IDT_MCHAD = -1 | |
25826 | END IF | |
25827 | ||
25828 | RETURN | |
25829 | END | |
25830 | ||
25831 | ************************************************************************ | |
25832 | * * | |
25833 | * 3) Energy-momentum and quantum number conservation check routines * | |
25834 | * * | |
25835 | ************************************************************************ | |
25836 | *$ CREATE DT_EMC1.FOR | |
25837 | *COPY DT_EMC1 | |
25838 | * | |
25839 | *===emc1===============================================================* | |
25840 | * | |
25841 | SUBROUTINE DT_EMC1(PP1,PP2,PT1,PT2,MODE,IPOS,IREJ) | |
25842 | ||
25843 | ************************************************************************ | |
25844 | * This version dated 15.12.94 is written by S. Roesler * | |
25845 | ************************************************************************ | |
25846 | ||
25847 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25848 | SAVE | |
25849 | PARAMETER ( LINP = 10 , | |
25850 | & LOUT = 6 , | |
25851 | & LDAT = 9 ) | |
25852 | PARAMETER (TINY10=1.0D-10) | |
25853 | ||
25854 | DIMENSION PP1(4),PP2(4),PT1(4),PT2(4) | |
25855 | ||
25856 | IREJ = 0 | |
25857 | ||
25858 | IF ((MODE.EQ.0).OR.(ABS(MODE).GT.3)) | |
25859 | & WRITE(LOUT,'(1X,A,I6)')'EMC1: not supported MODE ',MODE | |
25860 | ||
25861 | IF ((MODE.GT.0).AND.(MODE.LT.3)) THEN | |
25862 | IF (MODE.EQ.1) THEN | |
25863 | CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),1,IDUM,IDUM) | |
25864 | ELSEIF (MODE.EQ.2) THEN | |
25865 | CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),2,IDUM,IDUM) | |
25866 | ENDIF | |
25867 | CALL DT_EVTEMC(PP2(1),PP2(2),PP2(3),PP2(4),2,IDUM,IDUM) | |
25868 | CALL DT_EVTEMC(PT1(1),PT1(2),PT1(3),PT1(4),2,IDUM,IDUM) | |
25869 | CALL DT_EVTEMC(PT2(1),PT2(2),PT2(3),PT2(4),2,IDUM,IDUM) | |
25870 | ELSEIF (MODE.LT.0) THEN | |
25871 | IF (MODE.EQ.-1) THEN | |
25872 | CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),1,IDUM,IDUM) | |
25873 | ELSEIF (MODE.EQ.-2) THEN | |
25874 | CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),2,IDUM,IDUM) | |
25875 | ENDIF | |
25876 | CALL DT_EVTEMC(-PP2(1),-PP2(2),-PP2(3),-PP2(4),2,IDUM,IDUM) | |
25877 | CALL DT_EVTEMC(-PT1(1),-PT1(2),-PT1(3),-PT1(4),2,IDUM,IDUM) | |
25878 | CALL DT_EVTEMC(-PT2(1),-PT2(2),-PT2(3),-PT2(4),2,IDUM,IDUM) | |
25879 | ENDIF | |
25880 | ||
25881 | IF (ABS(MODE).EQ.3) THEN | |
25882 | CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,IPOS,IREJ1) | |
25883 | IF (IREJ1.NE.0) GOTO 9999 | |
25884 | ENDIF | |
25885 | RETURN | |
25886 | ||
25887 | 9999 CONTINUE | |
25888 | IREJ = 1 | |
25889 | RETURN | |
25890 | END | |
25891 | ||
25892 | *$ CREATE DT_EMC2.FOR | |
25893 | *COPY DT_EMC2 | |
25894 | * | |
25895 | *===emc2===============================================================* | |
25896 | * | |
25897 | SUBROUTINE DT_EMC2(IP1,IP2,IP3,IP4,IP5,MP,IN1,IN2,IN3,IN4,IN5,MN, | |
25898 | & MODE,IPOS,IREJ) | |
25899 | ||
25900 | ************************************************************************ | |
25901 | * MODE = 1 energy-momentum cons. check * | |
25902 | * = 2 flavor-cons. check * | |
25903 | * = 3 energy-momentum & flavor cons. check * | |
25904 | * = 4 energy-momentum & charge cons. check * | |
25905 | * = 5 energy-momentum & flavor & charge cons. check * | |
25906 | * This version dated 16.01.95 is written by S. Roesler * | |
25907 | ************************************************************************ | |
25908 | ||
25909 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25910 | SAVE | |
25911 | PARAMETER ( LINP = 10 , | |
25912 | & LOUT = 6 , | |
25913 | & LDAT = 9 ) | |
25914 | PARAMETER (TINY10=1.0D-10,ZERO=0.0D0) | |
25915 | ||
25916 | * event history | |
25917 | PARAMETER (NMXHKK=200000) | |
25918 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
25919 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
25920 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
25921 | * extended event history | |
25922 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
25923 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
25924 | & IHIST(2,NMXHKK) | |
25925 | ||
25926 | IREJ = 0 | |
25927 | IREJ1 = 0 | |
25928 | IREJ2 = 0 | |
25929 | IREJ3 = 0 | |
25930 | ||
25931 | IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5)) | |
25932 | & CALL DT_EVTEMC(ZERO,ZERO,ZERO,ZERO,1,IDUM,IDUM) | |
25933 | IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5)) | |
25934 | & CALL DT_EVTFLC(0,IDUM,1,IDUM,IDUM) | |
25935 | IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,1,IDUM,IDUM) | |
25936 | DO 1 I=1,NHKK | |
25937 | IF ((ISTHKK(I).EQ.IP1).OR.(ISTHKK(I).EQ.IP2).OR. | |
25938 | & (ISTHKK(I).EQ.IP3).OR.(ISTHKK(I).EQ.IP4).OR. | |
25939 | & (ISTHKK(I).EQ.IP5)) THEN | |
25940 | IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4) | |
25941 | & .OR.(MODE.EQ.5)) | |
25942 | & CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I), | |
25943 | & 2,IDUM,IDUM) | |
25944 | IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5)) | |
25945 | & CALL DT_EVTFLC(IDHKK(I),MP,2,IDUM,IDUM) | |
25946 | IF ((MODE.EQ.4).OR.(MODE.EQ.5)) | |
25947 | & CALL DT_EVTCHG(IDHKK(I),2,IDUM,IDUM) | |
25948 | ENDIF | |
25949 | IF ((ISTHKK(I).EQ.IN1).OR.(ISTHKK(I).EQ.IN2).OR. | |
25950 | & (ISTHKK(I).EQ.IN3).OR.(ISTHKK(I).EQ.IN4).OR. | |
25951 | & (ISTHKK(I).EQ.IN5)) THEN | |
25952 | IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4) | |
25953 | & .OR.(MODE.EQ.5)) | |
25954 | & CALL DT_EVTEMC(-PHKK(1,I),-PHKK(2,I),-PHKK(3,I),-PHKK(4,I), | |
25955 | & 2,IDUM,IDUM) | |
25956 | IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5)) | |
25957 | & CALL DT_EVTFLC(IDHKK(I),MN,-2,IDUM,IDUM) | |
25958 | IF ((MODE.EQ.4).OR.(MODE.EQ.5)) | |
25959 | & CALL DT_EVTCHG(IDHKK(I),-2,IDUM,IDUM) | |
25960 | ENDIF | |
25961 | 1 CONTINUE | |
25962 | IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5)) | |
25963 | & CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,IPOS,IREJ1) | |
25964 | IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5)) | |
25965 | & CALL DT_EVTFLC(0,IDUM,3,IPOS,IREJ2) | |
25966 | IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,3,IPOS,IREJ3) | |
25967 | IF ((IREJ1.NE.0).OR.(IREJ2.NE.0).OR.(IREJ3.NE.0)) GOTO 9999 | |
25968 | ||
25969 | RETURN | |
25970 | ||
25971 | 9999 CONTINUE | |
25972 | IREJ = 1 | |
25973 | RETURN | |
25974 | END | |
25975 | ||
25976 | *$ CREATE DT_EVTEMC.FOR | |
25977 | *COPY DT_EVTEMC | |
25978 | * | |
25979 | *===evtemc=============================================================* | |
25980 | * | |
25981 | SUBROUTINE DT_EVTEMC(PXIO,PYIO,PZIO,EIO,IMODE,IPOS,IREJ) | |
25982 | ||
25983 | ************************************************************************ | |
25984 | * This version dated 13.12.94 is written by S. Roesler * | |
25985 | ************************************************************************ | |
25986 | ||
25987 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
25988 | SAVE | |
25989 | PARAMETER ( LINP = 10 , | |
25990 | & LOUT = 6 , | |
25991 | & LDAT = 9 ) | |
25992 | PARAMETER (TINY1=1.0D-1,TINY2=1.0D-2,TINY4=1.0D-4,TINY10=1.0D-10, | |
25993 | & ZERO=0.0D0) | |
25994 | ||
25995 | * event history | |
25996 | PARAMETER (NMXHKK=200000) | |
25997 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
25998 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
25999 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
26000 | * flags for input different options | |
26001 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
26002 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
26003 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
26004 | ||
26005 | IREJ = 0 | |
26006 | ||
26007 | MODE = IMODE | |
26008 | CHKLEV = TINY10 | |
26009 | IF (MODE.EQ.4) THEN | |
26010 | CHKLEV = TINY2 | |
26011 | MODE = 3 | |
26012 | ELSEIF (MODE.EQ.5) THEN | |
26013 | CHKLEV = TINY1 | |
26014 | MODE = 3 | |
26015 | ELSEIF (MODE.EQ.-1) THEN | |
26016 | CHKLEV = EIO | |
26017 | MODE = 3 | |
26018 | ENDIF | |
26019 | ||
26020 | IF (ABS(MODE).EQ.3) THEN | |
26021 | PXDEV = PX | |
26022 | PYDEV = PY | |
26023 | PZDEV = PZ | |
26024 | EDEV = E | |
26025 | IF ((IFRAG(1).EQ.2).AND.(CHKLEV.LT.TINY4)) CHKLEV = TINY4 | |
26026 | IF ((ABS(PXDEV).GT.CHKLEV).OR.(ABS(PYDEV).GT.CHKLEV).OR. | |
26027 | & (ABS(PZDEV).GT.CHKLEV).OR.(ABS(EDEV).GT.CHKLEV)) THEN | |
26028 | IF (IOULEV(2).GT.0) WRITE(LOUT,'(1X,A,I4,A,I8,A,/,4G10.3)') | |
26029 | & 'EVTEMC: energy-momentum cons. failure at pos. ',IPOS, | |
26030 | & ' event ',NEVHKK, | |
26031 | & ' ! ',PXDEV,PYDEV,PZDEV,EDEV | |
26032 | PX = 0.0D0 | |
26033 | PY = 0.0D0 | |
26034 | PZ = 0.0D0 | |
26035 | E = 0.0D0 | |
26036 | GOTO 9999 | |
26037 | ENDIF | |
26038 | PX = 0.0D0 | |
26039 | PY = 0.0D0 | |
26040 | PZ = 0.0D0 | |
26041 | E = 0.0D0 | |
26042 | RETURN | |
26043 | ENDIF | |
26044 | ||
26045 | IF (MODE.EQ.1) THEN | |
26046 | PX = 0.0D0 | |
26047 | PY = 0.0D0 | |
26048 | PZ = 0.0D0 | |
26049 | E = 0.0D0 | |
26050 | ENDIF | |
26051 | ||
26052 | PX = PX+PXIO | |
26053 | PY = PY+PYIO | |
26054 | PZ = PZ+PZIO | |
26055 | E = E+EIO | |
26056 | ||
26057 | RETURN | |
26058 | ||
26059 | 9999 CONTINUE | |
26060 | IREJ = 1 | |
26061 | RETURN | |
26062 | END | |
26063 | ||
26064 | *$ CREATE DT_EVTFLC.FOR | |
26065 | *COPY DT_EVTFLC | |
26066 | * | |
26067 | *===evtflc=============================================================* | |
26068 | * | |
26069 | SUBROUTINE DT_EVTFLC(ID,ID1,MODE,IPOS,IREJ) | |
26070 | ||
26071 | ************************************************************************ | |
26072 | * Flavor conservation check. * | |
26073 | * ID identity of particle * | |
26074 | * ID1 = 1 ID for q,aq,qq,aqaq in PDG-numbering scheme * | |
26075 | * = 2 ID for particle/resonance in BAMJET numbering scheme * | |
26076 | * = 3 ID for particle/resonance in PDG numbering scheme * | |
26077 | * MODE = 1 initialization and add ID * | |
26078 | * =-1 initialization and subtract ID * | |
26079 | * = 2 add ID * | |
26080 | * =-2 subtract ID * | |
26081 | * = 3 check flavor cons. * | |
26082 | * IPOS flag to give position of call of EVTFLC to output * | |
26083 | * unit in case of violation * | |
26084 | * This version dated 10.01.95 is written by S. Roesler * | |
26085 | ************************************************************************ | |
26086 | ||
26087 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26088 | SAVE | |
26089 | PARAMETER ( LINP = 10 , | |
26090 | & LOUT = 6 , | |
26091 | & LDAT = 9 ) | |
26092 | PARAMETER (TINY10=1.0D-10) | |
26093 | ||
26094 | IREJ = 0 | |
26095 | ||
26096 | IF (MODE.EQ.3) THEN | |
26097 | IF (IFL.NE.0) THEN | |
26098 | WRITE(LOUT,'(1X,A,I3,A,I3)') | |
26099 | & 'EVTFLC: flavor-conservation failure at pos. ',IPOS, | |
26100 | & ' ! IFL = ',IFL | |
26101 | IFL = 0 | |
26102 | GOTO 9999 | |
26103 | ENDIF | |
26104 | IFL = 0 | |
26105 | RETURN | |
26106 | ENDIF | |
26107 | ||
26108 | IF (MODE.EQ.1) IFL = 0 | |
26109 | IF (ID.EQ.0) RETURN | |
26110 | ||
26111 | IF (ID1.EQ.1) THEN | |
26112 | IDD = ABS(ID) | |
26113 | NQ = 1 | |
26114 | IF ((IDD.GE.100).AND.(IDD.LT.1000)) NQ = 2 | |
26115 | IF (IDD.GE.1000) NQ = 3 | |
26116 | DO 1 I=1,NQ | |
26117 | IFBAM = IDT_IPDG2B(ID,I,2) | |
26118 | IF (ABS(IFBAM).EQ.1) THEN | |
26119 | IFBAM = SIGN(2,IFBAM) | |
26120 | ELSEIF (ABS(IFBAM).EQ.2) THEN | |
26121 | IFBAM = SIGN(1,IFBAM) | |
26122 | ENDIF | |
26123 | IF (MODE.GT.0) THEN | |
26124 | IFL = IFL+IFBAM | |
26125 | ELSE | |
26126 | IFL = IFL-IFBAM | |
26127 | ENDIF | |
26128 | 1 CONTINUE | |
26129 | RETURN | |
26130 | ENDIF | |
26131 | ||
26132 | IDD = ID | |
26133 | IF (ID1.EQ.3) IDD = IDT_ICIHAD(ID) | |
26134 | IF ((ID1.EQ.2).OR.(ID1.EQ.3)) THEN | |
26135 | DO 2 I=1,3 | |
26136 | IF (MODE.GT.0) THEN | |
26137 | IFL = IFL+IDT_IQUARK(I,IDD) | |
26138 | ELSE | |
26139 | IFL = IFL-IDT_IQUARK(I,IDD) | |
26140 | ENDIF | |
26141 | 2 CONTINUE | |
26142 | ENDIF | |
26143 | RETURN | |
26144 | ||
26145 | 9999 CONTINUE | |
26146 | IREJ = 1 | |
26147 | RETURN | |
26148 | END | |
26149 | ||
26150 | *$ CREATE DT_EVTCHG.FOR | |
26151 | *COPY DT_EVTCHG | |
26152 | * | |
26153 | *===evtchg=============================================================* | |
26154 | * | |
26155 | SUBROUTINE DT_EVTCHG(ID,MODE,IPOS,IREJ) | |
26156 | ||
26157 | ************************************************************************ | |
26158 | * Charge conservation check. * | |
26159 | * ID identity of particle (PDG-numbering scheme) * | |
26160 | * MODE = 1 initialization * | |
26161 | * =-2 subtract ID-charge * | |
26162 | * = 2 add ID-charge * | |
26163 | * = 3 check charge cons. * | |
26164 | * IPOS flag to give position of call of EVTCHG to output * | |
26165 | * unit in case of violation * | |
26166 | * This version dated 10.01.95 is written by S. Roesler * | |
26167 | * Last change: s.r. 21.01.01 * | |
26168 | ************************************************************************ | |
26169 | ||
26170 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26171 | SAVE | |
26172 | PARAMETER ( LINP = 10 , | |
26173 | & LOUT = 6 , | |
26174 | & LDAT = 9 ) | |
26175 | ||
26176 | * event history | |
26177 | PARAMETER (NMXHKK=200000) | |
26178 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
26179 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
26180 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
26181 | * particle properties (BAMJET index convention) | |
26182 | CHARACTER*8 ANAME | |
26183 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
26184 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
26185 | ||
26186 | IREJ = 0 | |
26187 | ||
26188 | IF (MODE.EQ.1) THEN | |
26189 | ICH = 0 | |
26190 | IBAR = 0 | |
26191 | RETURN | |
26192 | ENDIF | |
26193 | ||
26194 | IF (MODE.EQ.3) THEN | |
26195 | IF ((ICH.NE.0).OR.(IBAR.NE.0)) THEN | |
26196 | WRITE(LOUT,'(1X,A,I3,A,2I3,A,I8)') | |
26197 | & 'EVTCHG: charge/baryo.-cons. failure at pos. ',IPOS, | |
26198 | & '! ICH/IBAR= ',ICH,IBAR,' event ',NEVHKK | |
26199 | ICH = 0 | |
26200 | IBAR = 0 | |
26201 | GOTO 9999 | |
26202 | ENDIF | |
26203 | ICH = 0 | |
26204 | IBAR = 0 | |
26205 | RETURN | |
26206 | ENDIF | |
26207 | ||
26208 | IF (ID.EQ.0) RETURN | |
26209 | ||
26210 | IDD = IDT_ICIHAD(ID) | |
26211 | * modification 21.1.01: use intrinsic phojet-functions to determine charge | |
26212 | * and baryon number | |
26213 | C IF (IDD.GT.0) THEN | |
26214 | C IF (MODE.EQ.2) THEN | |
26215 | C ICH = ICH+IICH(IDD) | |
26216 | C IBAR = IBAR+IIBAR(IDD) | |
26217 | C ELSEIF (MODE.EQ.-2) THEN | |
26218 | C ICH = ICH-IICH(IDD) | |
26219 | C IBAR = IBAR-IIBAR(IDD) | |
26220 | C ENDIF | |
26221 | C ELSE | |
26222 | C WRITE(LOUT,'(1X,A,3I6)') 'EVTCHG: (IDD = 0 !), IDD,ID=',IDD,ID | |
26223 | C CALL DT_EVTOUT(4) | |
26224 | C STOP | |
26225 | C ENDIF | |
26226 | IF (MODE.EQ.2) THEN | |
26227 | ICH = ICH+IPHO_CHR3(ID,1)/3 | |
26228 | IBAR = IBAR+IPHO_BAR3(ID,1)/3 | |
26229 | ELSEIF (MODE.EQ.-2) THEN | |
26230 | ICH = ICH-IPHO_CHR3(ID,1)/3 | |
26231 | IBAR = IBAR-IPHO_BAR3(ID,1)/3 | |
26232 | ENDIF | |
26233 | ||
26234 | RETURN | |
26235 | ||
26236 | 9999 CONTINUE | |
26237 | IREJ = 1 | |
26238 | RETURN | |
26239 | END | |
26240 | ||
26241 | ************************************************************************ | |
26242 | * * | |
26243 | * 4) Transformations * | |
26244 | * * | |
26245 | ************************************************************************ | |
26246 | *$ CREATE DT_LTINI.FOR | |
26247 | *COPY DT_LTINI | |
26248 | * | |
26249 | *===ltini==============================================================* | |
26250 | * | |
26251 | SUBROUTINE DT_LTINI(IDPR,IDTA,EPN0,PPN0,ECM0,MODE) | |
26252 | ||
26253 | ************************************************************************ | |
26254 | * Initializations of Lorentz-transformations, calculation of Lorentz- * | |
26255 | * parameters. * | |
26256 | * This version dated 13.11.95 is written by S. Roesler. * | |
26257 | ************************************************************************ | |
26258 | ||
26259 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26260 | SAVE | |
26261 | PARAMETER ( LINP = 10 , | |
26262 | & LOUT = 6 , | |
26263 | & LDAT = 9 ) | |
26264 | PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3, | |
26265 | & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0) | |
26266 | ||
26267 | * Lorentz-parameters of the current interaction | |
26268 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
26269 | & UMO,PPCM,EPROJ,PPROJ | |
26270 | * properties of photon/lepton projectiles | |
26271 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC | |
26272 | * particle properties (BAMJET index convention) | |
26273 | CHARACTER*8 ANAME | |
26274 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
26275 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
26276 | * nucleon-nucleon event-generator | |
26277 | CHARACTER*8 CMODEL | |
26278 | LOGICAL LPHOIN | |
26279 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
26280 | ||
26281 | Q2 = VIRT | |
26282 | IDP = IDPR | |
26283 | IF (MCGENE.NE.3) THEN | |
26284 | * lepton-projectiles and PHOJET: initialize real photon instead | |
26285 | IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR. | |
26286 | & (IDPR.EQ.10).OR.(IDPR.EQ.11).OR. | |
26287 | & (IDPR.EQ. 5).OR.(IDPR.EQ. 6)) THEN | |
26288 | IDP = 7 | |
26289 | Q2 = ZERO | |
26290 | ENDIF | |
26291 | ENDIF | |
26292 | IDT = IDTA | |
26293 | EPN = EPN0 | |
26294 | PPN = PPN0 | |
26295 | ECM = ECM0 | |
26296 | AMP = AAM(IDP)-SQRT(ABS(Q2)) | |
26297 | AMT = AAM(IDT) | |
26298 | AMP2 = SIGN(AMP**2,AMP) | |
26299 | AMT2 = AMT**2 | |
26300 | IF (ECM0.GT.ZERO) THEN | |
26301 | EPN = (ECM**2-AMP2-AMT2)/(TWO*AMT) | |
26302 | IF (AMP2.GT.ZERO) THEN | |
26303 | PPN = SQRT((EPN+AMP)*(EPN-AMP)) | |
26304 | ELSE | |
26305 | PPN = SQRT(EPN**2-AMP2) | |
26306 | ENDIF | |
26307 | ELSE | |
26308 | IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN | |
26309 | IF (IDP.EQ.7) EPN = ABS(EPN) | |
26310 | IF (EPN.LT.ZERO) EPN = ABS(EPN)+AMP | |
26311 | IF (AMP2.GT.ZERO) THEN | |
26312 | PPN = SQRT((EPN+AMP)*(EPN-AMP)) | |
26313 | ELSE | |
26314 | PPN = SQRT(EPN**2-AMP2) | |
26315 | ENDIF | |
26316 | ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN | |
26317 | IF (AMP2.GT.ZERO) THEN | |
26318 | EPN = PPN*SQRT(ONE+(AMP/PPN)**2) | |
26319 | ELSE | |
26320 | EPN = SQRT(PPN**2+AMP2) | |
26321 | ENDIF | |
26322 | ENDIF | |
26323 | ECM = SQRT(AMP2+AMT2+TWO*AMT*EPN) | |
26324 | ENDIF | |
26325 | UMO = ECM | |
26326 | EPROJ = EPN | |
26327 | PPROJ = PPN | |
26328 | IF (AMP2.GT.ZERO) THEN | |
26329 | ETARG = (ECM**2-AMP2-AMT2)/(TWO*AMP) | |
26330 | PTARG = -SQRT((ETARG+AMT)*(ETARG-AMT)) | |
26331 | ELSE | |
26332 | ETARG = TINY10 | |
26333 | PTARG = TINY10 | |
26334 | ENDIF | |
26335 | * photon-projectiles (get momentum in cm-frame for virtuality Q^2) | |
26336 | IF (IDP.EQ.7) THEN | |
26337 | PGAMM(1) = ZERO | |
26338 | PGAMM(2) = ZERO | |
26339 | AMGAM = AMP | |
26340 | AMGAM2 = AMP2 | |
26341 | IF (ECM0.GT.ZERO) THEN | |
26342 | S = ECM0**2 | |
26343 | ELSE | |
26344 | IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN | |
26345 | S = AMGAM2+AMT2+TWO*AMT*ABS(EPN0) | |
26346 | ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN | |
26347 | S = AMGAM2+AMT2+TWO*AMT*SQRT(PPN0**2+AMGAM2) | |
26348 | ENDIF | |
26349 | ENDIF | |
26350 | PGAMM(3) = SQRT( (S**2-TWO*AMGAM2*S-TWO*AMT2*S-TWO*AMGAM2*AMT2 | |
26351 | & +AMGAM2**2+AMT2**2)/(4.0D0*S) ) | |
26352 | PGAMM(4) = SQRT(AMGAM2+PGAMM(3)**2) | |
26353 | IF (MODE.EQ.1) THEN | |
26354 | PNUCL(1) = ZERO | |
26355 | PNUCL(2) = ZERO | |
26356 | PNUCL(3) = -PGAMM(3) | |
26357 | PNUCL(4) = SQRT(S)-PGAMM(4) | |
26358 | ENDIF | |
26359 | ENDIF | |
26360 | IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR. | |
26361 | & (IDPR.EQ.10).OR.(IDPR.EQ.11)) THEN | |
26362 | PLEPT0(1) = ZERO | |
26363 | PLEPT0(2) = ZERO | |
26364 | * neglect lepton masses | |
26365 | C AMLPT2 = AAM(IDPR)**2 | |
26366 | AMLPT2 = ZERO | |
26367 | * | |
26368 | IF (ECM0.GT.ZERO) THEN | |
26369 | S = ECM0**2 | |
26370 | ELSE | |
26371 | IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN | |
26372 | S = AMLPT2+AMT2+TWO*AMT*ABS(EPN0) | |
26373 | ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN | |
26374 | S = AMLPT2+AMT2+TWO*AMT*SQRT(PPN0**2+AMLPT2) | |
26375 | ENDIF | |
26376 | ENDIF | |
26377 | PLEPT0(3) = SQRT( (S**2-TWO*AMLPT2*S-TWO*AMT2*S-TWO*AMLPT2*AMT2 | |
26378 | & +AMLPT2**2+AMT2**2)/(4.0D0*S) ) | |
26379 | PLEPT0(4) = SQRT(AMLPT2+PLEPT0(3)**2) | |
26380 | PNUCL(1) = ZERO | |
26381 | PNUCL(2) = ZERO | |
26382 | PNUCL(3) = -PLEPT0(3) | |
26383 | PNUCL(4) = SQRT(S)-PLEPT0(4) | |
26384 | ENDIF | |
26385 | * Lorentz-parameter for transformation Lab. - projectile rest system | |
26386 | IF ((IDP.EQ.7).OR.(AMP.LT.TINY10)) THEN | |
26387 | GALAB = TINY10 | |
26388 | BGLAB = TINY10 | |
26389 | BLAB = TINY10 | |
26390 | ELSE | |
26391 | GALAB = EPROJ/AMP | |
26392 | BGLAB = PPROJ/AMP | |
26393 | BLAB = BGLAB/GALAB | |
26394 | ENDIF | |
26395 | * Lorentz-parameter for transf. proj. rest sys. - nucl.-nucl. cms. | |
26396 | IF (IDP.EQ.7) THEN | |
26397 | GACMS(1) = TINY10 | |
26398 | BGCMS(1) = TINY10 | |
26399 | ELSE | |
26400 | GACMS(1) = (ETARG+AMP)/UMO | |
26401 | BGCMS(1) = PTARG/UMO | |
26402 | ENDIF | |
26403 | * Lorentz-parameter for transformation Lab. - nucl.-nucl. cms. | |
26404 | GACMS(2) = (EPROJ+AMT)/UMO | |
26405 | BGCMS(2) = PPROJ/UMO | |
26406 | PPCM = GACMS(2)*PPROJ-BGCMS(2)*EPROJ | |
26407 | ||
26408 | EPN0 = EPN | |
26409 | PPN0 = PPN | |
26410 | ECM0 = ECM | |
26411 | ||
26412 | RETURN | |
26413 | END | |
26414 | ||
26415 | *$ CREATE DT_LTRANS.FOR | |
26416 | *COPY DT_LTRANS | |
26417 | * | |
26418 | *===ltrans=============================================================* | |
26419 | * | |
26420 | SUBROUTINE DT_LTRANS(PXI,PYI,PZI,PEI,PXO,PYO,PZO,PEO,ID,MODE) | |
26421 | ||
26422 | ************************************************************************ | |
26423 | * Lorentz-transformations. * | |
26424 | * MODE = 1(-1) projectile rest syst. --> Lab (back) * | |
26425 | * = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) * | |
26426 | * = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) * | |
26427 | * This version dated 01.11.95 is written by S. Roesler. * | |
26428 | ************************************************************************ | |
26429 | ||
26430 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26431 | SAVE | |
26432 | PARAMETER ( LINP = 10 , | |
26433 | & LOUT = 6 , | |
26434 | & LDAT = 9 ) | |
26435 | PARAMETER (TINY3=1.0D-3,ZERO=0.0D0,TWO=2.0D0) | |
26436 | ||
26437 | PARAMETER (SQTINF=1.0D+15) | |
26438 | ||
26439 | * particle properties (BAMJET index convention) | |
26440 | CHARACTER*8 ANAME | |
26441 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
26442 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
26443 | ||
26444 | PXO = PXI | |
26445 | PYO = PYI | |
26446 | CALL DT_LTNUC(PZI,PEI,PZO,PEO,MODE) | |
26447 | ||
26448 | * check particle mass for consistency (numerical rounding errors) | |
26449 | PO = SQRT(PXO*PXO+PYO*PYO+PZO*PZO) | |
26450 | AMO2 = (PEO-PO)*(PEO+PO) | |
26451 | AMORQ2 = AAM(ID)**2 | |
26452 | AMDIF2 = ABS(AMO2-AMORQ2) | |
26453 | IF ((AMDIF2.GT.TINY3).AND.(PEO.LT.SQTINF).AND.(PO.GT.ZERO)) THEN | |
26454 | DELTA = (AMORQ2-AMO2)/(TWO*(PEO+PO)) | |
26455 | PEO = PEO+DELTA | |
26456 | PO1 = PO -DELTA | |
26457 | PXO = PXO*PO1/PO | |
26458 | PYO = PYO*PO1/PO | |
26459 | PZO = PZO*PO1/PO | |
26460 | C WRITE(6,*) 'LTRANS corrected', AMDIF2,PZI,PEI,PZO,PEO,MODE,ID | |
26461 | ENDIF | |
26462 | ||
26463 | RETURN | |
26464 | END | |
26465 | ||
26466 | *$ CREATE DT_LTNUC.FOR | |
26467 | *COPY DT_LTNUC | |
26468 | * | |
26469 | *===ltnuc==============================================================* | |
26470 | * | |
26471 | SUBROUTINE DT_LTNUC(PIN,EIN,POUT,EOUT,MODE) | |
26472 | ||
26473 | ************************************************************************ | |
26474 | * Lorentz-transformations. * | |
26475 | * PIN longitudnal momentum (input) * | |
26476 | * EIN energy (input) * | |
26477 | * POUT transformed long. momentum (output) * | |
26478 | * EOUT transformed energy (output) * | |
26479 | * MODE = 1(-1) projectile rest syst. --> Lab (back) * | |
26480 | * = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) * | |
26481 | * = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) * | |
26482 | * This version dated 01.11.95 is written by S. Roesler. * | |
26483 | ************************************************************************ | |
26484 | ||
26485 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26486 | SAVE | |
26487 | PARAMETER ( LINP = 10 , | |
26488 | & LOUT = 6 , | |
26489 | & LDAT = 9 ) | |
26490 | PARAMETER (ZERO=0.0D0) | |
26491 | ||
26492 | * Lorentz-parameters of the current interaction | |
26493 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
26494 | & UMO,PPCM,EPROJ,PPROJ | |
26495 | ||
26496 | BDUM1 = ZERO | |
26497 | BDUM2 = ZERO | |
26498 | PDUM1 = ZERO | |
26499 | PDUM2 = ZERO | |
26500 | IF (ABS(MODE).EQ.1) THEN | |
26501 | BG = -SIGN(BGLAB,DBLE(MODE)) | |
26502 | CALL DT_DALTRA(GALAB,BDUM1,BDUM2,-BG,PDUM1,PDUM2,PIN,EIN, | |
26503 | & DUM1,DUM2,DUM3,POUT,EOUT) | |
26504 | ELSEIF (ABS(MODE).EQ.2) THEN | |
26505 | BG = SIGN(BGCMS(1),DBLE(MODE)) | |
26506 | CALL DT_DALTRA(GACMS(1),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN, | |
26507 | & DUM1,DUM2,DUM3,POUT,EOUT) | |
26508 | ELSEIF (ABS(MODE).EQ.3) THEN | |
26509 | BG = -SIGN(BGCMS(2),DBLE(MODE)) | |
26510 | CALL DT_DALTRA(GACMS(2),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN, | |
26511 | & DUM1,DUM2,DUM3,POUT,EOUT) | |
26512 | ELSE | |
26513 | WRITE(LOUT,1000) MODE | |
26514 | 1000 FORMAT(1X,'LTNUC: not supported mode (MODE = ',I3,')') | |
26515 | EOUT = EIN | |
26516 | POUT = PIN | |
26517 | ENDIF | |
26518 | ||
26519 | RETURN | |
26520 | END | |
26521 | ||
26522 | *$ CREATE DT_DALTRA.FOR | |
26523 | *COPY DT_DALTRA | |
26524 | * | |
26525 | *===daltra=============================================================* | |
26526 | * | |
26527 | SUBROUTINE DT_DALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E) | |
26528 | ||
26529 | ************************************************************************ | |
26530 | * Arbitrary Lorentz-transformation. * | |
26531 | * Adopted from the original by S. Roesler. This version dated 15.01.95 * | |
26532 | ************************************************************************ | |
26533 | ||
26534 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26535 | SAVE | |
26536 | PARAMETER (ONE=1.0D0) | |
26537 | ||
26538 | EP = PCX*BGX+PCY*BGY+PCZ*BGZ | |
26539 | PE = EP/(GA+ONE)+EC | |
26540 | PX = PCX+BGX*PE | |
26541 | PY = PCY+BGY*PE | |
26542 | PZ = PCZ+BGZ*PE | |
26543 | P = SQRT(PX*PX+PY*PY+PZ*PZ) | |
26544 | E = GA*EC+EP | |
26545 | ||
26546 | RETURN | |
26547 | END | |
26548 | ||
26549 | *$ CREATE DT_DTRAFO.FOR | |
26550 | *COPY DT_DTRAFO | |
26551 | * | |
26552 | *====dtrafo============================================================* | |
26553 | * | |
26554 | SUBROUTINE DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM, | |
26555 | & PL,CXL,CYL,CZL,EL) | |
26556 | ||
26557 | C LORENTZ TRANSFORMATION INTO THE LAB - SYSTEM | |
26558 | ||
26559 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26560 | SAVE | |
26561 | ||
26562 | IF (ABS(COD).GT.1.0D0) COD = SIGN(1.0D0,COD) | |
26563 | SID = SQRT(1.D0-COD*COD) | |
26564 | PLX = P*SID*COF | |
26565 | PLY = P*SID*SIF | |
26566 | PCMZ = P*COD | |
26567 | PLZ = GAM*PCMZ+BGAM*ECM | |
26568 | PL = SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ) | |
26569 | EL = GAM*ECM+BGAM*PCMZ | |
26570 | C ROTATION INTO THE ORIGINAL DIRECTION | |
26571 | COZ = PLZ/PL | |
26572 | SIZ = SQRT(1.D0-COZ**2) | |
26573 | CALL DT_STTRAN(CX,CY,CZ,COZ,SIZ,SIF,COF,CXL,CYL,CZL) | |
26574 | ||
26575 | RETURN | |
26576 | END | |
26577 | ||
26578 | *$ CREATE DT_STTRAN.FOR | |
26579 | *COPY DT_STTRAN | |
26580 | * | |
26581 | *====sttran============================================================* | |
26582 | * | |
26583 | SUBROUTINE DT_STTRAN(XO,YO,ZO,CDE,SDE,SFE,CFE,X,Y,Z) | |
26584 | ||
26585 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26586 | SAVE | |
26587 | DATA ANGLSQ/1.D-30/ | |
26588 | ************************************************************************ | |
26589 | * VERSION BY J. RANFT * | |
26590 | * LEIPZIG * | |
26591 | * * | |
26592 | * THIS IS A SUBROUTINE OF FLUKA TO GIVE NEW DIRECTION COSINES * | |
26593 | * * | |
26594 | * INPUT VARIABLES: * | |
26595 | * XO,YO,ZO = ORIGINAL DIRECTION COSINES * | |
26596 | * CDE,SDE = COSINE AND SINE OF THE POLAR (THETA) * | |
26597 | * ANGLE OF "SCATTERING" * | |
26598 | * SDE = SINE OF THE POLAR (THETA) ANGLE OF "SCATTERING" * | |
26599 | * SFE,CFE = SINE AND COSINE OF THE AZIMUTHAL (PHI) ANGLE * | |
26600 | * OF "SCATTERING" * | |
26601 | * * | |
26602 | * OUTPUT VARIABLES: * | |
26603 | * X,Y,Z = NEW DIRECTION COSINES * | |
26604 | * * | |
26605 | * ROTATION OF COORDINATE SYSTEM (SEE CERN 64-47 ) * | |
26606 | ************************************************************************ | |
26607 | * | |
26608 | * | |
26609 | * Changed by A. Ferrari | |
26610 | * | |
26611 | * IF (ABS(XO)-0.0001D0) 1,1,2 | |
26612 | * 1 IF (ABS(YO)-0.0001D0) 3,3,2 | |
26613 | * 3 CONTINUE | |
26614 | A = XO**2 + YO**2 | |
26615 | IF ( A .LT. ANGLSQ ) THEN | |
26616 | X=SDE*CFE | |
26617 | Y=SDE*SFE | |
26618 | Z=CDE*ZO | |
26619 | ELSE | |
26620 | XI=SDE*CFE | |
26621 | YI=SDE*SFE | |
26622 | ZI=CDE | |
26623 | A=SQRT(A) | |
26624 | X=-YO*XI/A-ZO*XO*YI/A+XO*ZI | |
26625 | Y=XO*XI/A-ZO*YO*YI/A+YO*ZI | |
26626 | Z=A*YI+ZO*ZI | |
26627 | ENDIF | |
26628 | ||
26629 | RETURN | |
26630 | END | |
26631 | ||
26632 | *$ CREATE DT_MYTRAN.FOR | |
26633 | *COPY DT_MYTRAN | |
26634 | * | |
26635 | *===mytran=============================================================* | |
26636 | * | |
26637 | SUBROUTINE DT_MYTRAN(IMODE,XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z) | |
26638 | ||
26639 | ************************************************************************ | |
26640 | * This subroutine rotates the coordinate frame * | |
26641 | * a) theta around y * | |
26642 | * b) phi around z if IMODE = 1 * | |
26643 | * * | |
26644 | * x' cos(ph) -sin(ph) 0 cos(th) 0 sin(th) x * | |
26645 | * y' = A B = sin(ph) cos(ph) 0 . 0 1 0 y * | |
26646 | * z' 0 0 1 -sin(th) 0 cos(th) z * | |
26647 | * * | |
26648 | * and vice versa if IMODE = 0. * | |
26649 | * This version dated 5.4.94 is based on the original version DTRAN * | |
26650 | * by J. Ranft and is written by S. Roesler. * | |
26651 | ************************************************************************ | |
26652 | ||
26653 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26654 | SAVE | |
26655 | PARAMETER ( LINP = 10 , | |
26656 | & LOUT = 6 , | |
26657 | & LDAT = 9 ) | |
26658 | ||
26659 | IF (IMODE.EQ.1) THEN | |
26660 | X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO | |
26661 | Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO | |
26662 | Z=-SDE *XO +CDE *ZO | |
26663 | ELSE | |
26664 | X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO | |
26665 | Y= -SFE*XO+CFE*YO | |
26666 | Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO | |
26667 | ENDIF | |
26668 | RETURN | |
26669 | END | |
26670 | ||
26671 | *$ CREATE DT_LT2LAO.FOR | |
26672 | *COPY DT_LT2LAO | |
26673 | * | |
26674 | *===lt2lab=============================================================* | |
26675 | * | |
26676 | SUBROUTINE DT_LT2LAO | |
26677 | ||
26678 | ************************************************************************ | |
26679 | * Lorentz-transformation to lab-system. This subroutine scans DTEVT1 * | |
26680 | * for final state particles/fragments defined in nucleon-nucleon-cms * | |
26681 | * and transforms them back to the lab. * | |
26682 | * This version dated 16.11.95 is written by S. Roesler * | |
26683 | ************************************************************************ | |
26684 | ||
26685 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26686 | SAVE | |
26687 | PARAMETER ( LINP = 10 , | |
26688 | & LOUT = 6 , | |
26689 | & LDAT = 9 ) | |
26690 | ||
26691 | * event history | |
26692 | PARAMETER (NMXHKK=200000) | |
26693 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
26694 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
26695 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
26696 | * extended event history | |
26697 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
26698 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
26699 | & IHIST(2,NMXHKK) | |
26700 | ||
26701 | NEND = NHKK | |
26702 | NPOINT(5) = NHKK+1 | |
26703 | IF ( (NPOINT(4).EQ.0).OR.(NEND.LT.NPOINT(4)) ) RETURN | |
26704 | DO 1 I=NPOINT(4),NEND | |
26705 | C DO 1 I=1,NEND | |
26706 | IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR. | |
26707 | & (ISTHKK(I).EQ.1001)) THEN | |
26708 | CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3) | |
26709 | NOB = NOBAM(I) | |
26710 | CALL DT_EVTPUT(ISTHKK(I),IDHKK(I),I,0,PHKK(1,I),PHKK(2,I), | |
26711 | & PZ,PE,IDRES(I),IDXRES(I),IDCH(I)) | |
26712 | IF ((ISTHKK(I).EQ.1000).OR.(ISTHKK(I).EQ.1001)) THEN | |
26713 | ISTHKK(I) = 3*ISTHKK(I) | |
26714 | NOBAM(NHKK) = NOB | |
26715 | ELSE | |
26716 | IF (ISTHKK(I).EQ.-1) NOBAM(NHKK) = NOB | |
26717 | ISTHKK(I) = SIGN(3,ISTHKK(I)) | |
26718 | ENDIF | |
26719 | JDAHKK(1,I) = NHKK | |
26720 | ENDIF | |
26721 | 1 CONTINUE | |
26722 | ||
26723 | RETURN | |
26724 | END | |
26725 | ||
26726 | *$ CREATE DT_LT2LAB.FOR | |
26727 | *COPY DT_LT2LAB | |
26728 | * | |
26729 | *===lt2lab=============================================================* | |
26730 | * | |
26731 | SUBROUTINE DT_LT2LAB | |
26732 | ||
26733 | ************************************************************************ | |
26734 | * Lorentz-transformation to lab-system. This subroutine scans DTEVT1 * | |
26735 | * for final state particles/fragments defined in nucleon-nucleon-cms * | |
26736 | * and transforms them to the lab. * | |
26737 | * This version dated 07.01.96 is written by S. Roesler * | |
26738 | ************************************************************************ | |
26739 | ||
26740 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26741 | SAVE | |
26742 | PARAMETER ( LINP = 10 , | |
26743 | & LOUT = 6 , | |
26744 | & LDAT = 9 ) | |
26745 | ||
26746 | * event history | |
26747 | PARAMETER (NMXHKK=200000) | |
26748 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
26749 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
26750 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
26751 | * extended event history | |
26752 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
26753 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
26754 | & IHIST(2,NMXHKK) | |
26755 | ||
26756 | IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN | |
26757 | DO 1 I=NPOINT(4),NHKK | |
26758 | IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR. | |
26759 | & (ISTHKK(I).EQ.1001)) THEN | |
26760 | CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3) | |
26761 | PHKK(3,I) = PZ | |
26762 | PHKK(4,I) = PE | |
26763 | ENDIF | |
26764 | 1 CONTINUE | |
26765 | ||
26766 | RETURN | |
26767 | END | |
26768 | ||
26769 | ************************************************************************ | |
26770 | * * | |
26771 | * 5) Sampling from distributions * | |
26772 | * * | |
26773 | ************************************************************************ | |
26774 | *$ CREATE IDT_NPOISS.FOR | |
26775 | *COPY IDT_NPOISS | |
26776 | * | |
26777 | *===npoiss=============================================================* | |
26778 | * | |
26779 | INTEGER FUNCTION IDT_NPOISS(AVN) | |
26780 | ||
26781 | ************************************************************************ | |
26782 | * Sample according to Poisson distribution with Poisson parameter AVN. * | |
26783 | * The original version written by J. Ranft. * | |
26784 | * This version dated 11.1.95 is written by S. Roesler. * | |
26785 | ************************************************************************ | |
26786 | ||
26787 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26788 | SAVE | |
26789 | PARAMETER ( LINP = 10 , | |
26790 | & LOUT = 6 , | |
26791 | & LDAT = 9 ) | |
26792 | ||
26793 | EXPAVN = EXP(-AVN) | |
26794 | K = 1 | |
26795 | A = 1.0D0 | |
26796 | ||
26797 | 10 CONTINUE | |
26798 | A = DT_RNDM(A)*A | |
26799 | IF (A.GE.EXPAVN) THEN | |
26800 | K = K+1 | |
26801 | GOTO 10 | |
26802 | ENDIF | |
26803 | IDT_NPOISS = K-1 | |
26804 | ||
26805 | RETURN | |
26806 | END | |
26807 | ||
26808 | *$ CREATE DT_SAMPXB.FOR | |
26809 | *COPY DT_SAMPXB | |
26810 | * | |
26811 | *===sampxb=============================================================* | |
26812 | * | |
26813 | DOUBLE PRECISION FUNCTION DT_SAMPXB(X1,X2,B) | |
26814 | ||
26815 | ************************************************************************ | |
26816 | * Sampling from f(x)=1./SQRT(X**2+B**2) between x1 and x2. * | |
26817 | * Processed by S. Roesler, 6.5.95 * | |
26818 | ************************************************************************ | |
26819 | ||
26820 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26821 | SAVE | |
26822 | PARAMETER (TWO=2.0D0) | |
26823 | ||
26824 | A1 = LOG(X1+SQRT(X1**2+B**2)) | |
26825 | A2 = LOG(X2+SQRT(X2**2+B**2)) | |
26826 | AN = A2-A1 | |
26827 | A = AN*DT_RNDM(A1)+A1 | |
26828 | BB = EXP(A) | |
26829 | DT_SAMPXB = (BB**2-B**2)/(TWO*BB) | |
26830 | ||
26831 | RETURN | |
26832 | END | |
26833 | ||
26834 | *$ CREATE DT_SAMPEX.FOR | |
26835 | *COPY DT_SAMPEX | |
26836 | * | |
26837 | *===sampex=============================================================* | |
26838 | * | |
26839 | DOUBLE PRECISION FUNCTION DT_SAMPEX(X1,X2) | |
26840 | ||
26841 | ************************************************************************ | |
26842 | * Sampling from f(x)=1./x between x1 and x2. * | |
26843 | * Processed by S. Roesler, 6.5.95 * | |
26844 | ************************************************************************ | |
26845 | ||
26846 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26847 | SAVE | |
26848 | PARAMETER (ONE=1.0D0) | |
26849 | ||
26850 | R = DT_RNDM(X1) | |
26851 | AL1 = LOG(X1) | |
26852 | AL2 = LOG(X2) | |
26853 | DT_SAMPEX = EXP((ONE-R)*AL1+R*AL2) | |
26854 | ||
26855 | RETURN | |
26856 | END | |
26857 | ||
26858 | *$ CREATE DT_SAMSQX.FOR | |
26859 | *COPY DT_SAMSQX | |
26860 | * | |
26861 | *===samsqx=============================================================* | |
26862 | * | |
26863 | DOUBLE PRECISION FUNCTION DT_SAMSQX(X1,X2) | |
26864 | ||
26865 | ************************************************************************ | |
26866 | * Sampling from f(x)=1./x^0.5 between x1 and x2. * | |
26867 | * Processed by S. Roesler, 6.5.95 * | |
26868 | ************************************************************************ | |
26869 | ||
26870 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26871 | SAVE | |
26872 | PARAMETER (ONE=1.0D0) | |
26873 | ||
26874 | R = DT_RNDM(X1) | |
26875 | DT_SAMSQX = (R*SQRT(X2)+(ONE-R)*SQRT(X1))**2 | |
26876 | ||
26877 | RETURN | |
26878 | END | |
26879 | ||
26880 | *$ CREATE DT_SAMPLW.FOR | |
26881 | *COPY DT_SAMPLW | |
26882 | * | |
26883 | *===samplw=============================================================* | |
26884 | * | |
26885 | DOUBLE PRECISION FUNCTION DT_SAMPLW(XMIN,XMAX,B) | |
26886 | ||
26887 | ************************************************************************ | |
26888 | * Sampling from f(x)=1/x^b between x_min and x_max. * | |
26889 | * S. Roesler, 18.4.98 * | |
26890 | ************************************************************************ | |
26891 | ||
26892 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26893 | SAVE | |
26894 | PARAMETER (ONE=1.0D0) | |
26895 | ||
26896 | R = DT_RNDM(B) | |
26897 | IF (B.EQ.ONE) THEN | |
26898 | DT_SAMPLW = EXP(R*LOG(XMAX)+(ONE-R)*LOG(XMIN)) | |
26899 | ELSE | |
26900 | ONEMB = ONE-B | |
26901 | DT_SAMPLW = (R*XMAX**ONEMB+(ONE-R)*XMIN**ONEMB)**(ONE/ONEMB) | |
26902 | ENDIF | |
26903 | ||
26904 | RETURN | |
26905 | END | |
26906 | ||
26907 | *$ CREATE DT_BETREJ.FOR | |
26908 | *COPY DT_BETREJ | |
26909 | * | |
26910 | *===betrej=============================================================* | |
26911 | * | |
26912 | DOUBLE PRECISION FUNCTION DT_BETREJ(GAM,ETA,XMIN,XMAX) | |
26913 | ||
26914 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26915 | SAVE | |
26916 | ||
26917 | PARAMETER ( LINP = 10 , | |
26918 | & LOUT = 6 , | |
26919 | & LDAT = 9 ) | |
26920 | PARAMETER (ONE=1.0D0) | |
26921 | ||
26922 | IF (XMIN.GE.XMAX)THEN | |
26923 | WRITE (LOUT,500) XMIN,XMAX | |
26924 | 500 FORMAT(1X,'DT_BETREJ: XMIN<XMAX execution stopped ',2F10.5) | |
26925 | STOP | |
26926 | ENDIF | |
26927 | ||
26928 | 10 CONTINUE | |
26929 | XX = XMIN+(XMAX-XMIN)*DT_RNDM(ETA) | |
26930 | BETMAX = XMIN**(GAM-ONE)*(ONE-XMIN)**(ETA-ONE) | |
26931 | YY = BETMAX*DT_RNDM(XX) | |
26932 | BETXX = XX**(GAM-ONE)*(ONE-XX)**(ETA-ONE) | |
26933 | IF (YY.GT.BETXX) GOTO 10 | |
26934 | DT_BETREJ = XX | |
26935 | ||
26936 | RETURN | |
26937 | END | |
26938 | ||
26939 | *$ CREATE DT_DGAMRN.FOR | |
26940 | *COPY DT_DGAMRN | |
26941 | * | |
26942 | *===dgamrn=============================================================* | |
26943 | * | |
26944 | DOUBLE PRECISION FUNCTION DT_DGAMRN(ALAM,ETA) | |
26945 | ||
26946 | ************************************************************************ | |
26947 | * Sampling from Gamma-distribution. * | |
26948 | * F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA) * | |
26949 | * Processed by S. Roesler, 6.5.95 * | |
26950 | ************************************************************************ | |
26951 | ||
26952 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26953 | SAVE | |
26954 | PARAMETER (ZERO=0.0D0,TINY9=1.0D-9,ONE=1.0D0) | |
26955 | ||
26956 | NCOU = 0 | |
26957 | N = INT(ETA) | |
26958 | F = ETA-DBLE(N) | |
26959 | IF (F.EQ.ZERO) GOTO 20 | |
26960 | 10 R = DT_RNDM(F) | |
26961 | NCOU = NCOU+1 | |
26962 | IF (NCOU.GE.11) GOTO 20 | |
26963 | IF (R.LT.F/(F+2.71828D0)) GOTO 30 | |
26964 | YYY = LOG(DT_RNDM(R)+TINY9)/F | |
26965 | IF (ABS(YYY).GT.50.0D0) GOTO 20 | |
26966 | Y = EXP(YYY) | |
26967 | IF (LOG(DT_RNDM(Y)+TINY9).GT.-Y) GOTO 10 | |
26968 | GOTO 40 | |
26969 | 20 Y = 0.0D0 | |
26970 | GOTO 50 | |
26971 | 30 Y = ONE-LOG(DT_RNDM(Y)+TINY9) | |
26972 | IF (DT_RNDM(R).GT.Y**(F-ONE)) GOTO 10 | |
26973 | 40 IF (N.EQ.0) GOTO 70 | |
26974 | 50 Z = 1.0D0 | |
26975 | DO 60 I = 1,N | |
26976 | 60 Z = Z*DT_RNDM(Z) | |
26977 | Y = Y-LOG(Z+TINY9) | |
26978 | 70 DT_DGAMRN = Y/ALAM | |
26979 | ||
26980 | RETURN | |
26981 | END | |
26982 | ||
26983 | *$ CREATE DT_DBETAR.FOR | |
26984 | *COPY DT_DBETAR | |
26985 | * | |
26986 | *===dbetar=============================================================* | |
26987 | * | |
26988 | DOUBLE PRECISION FUNCTION DT_DBETAR(GAM,ETA) | |
26989 | ||
26990 | ************************************************************************ | |
26991 | * Sampling from Beta -distribution between 0.0 and 1.0 * | |
26992 | * F(X)=X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM)/(GAMM(GAM)*GAMM(ETA))* | |
26993 | * Processed by S. Roesler, 6.5.95 * | |
26994 | ************************************************************************ | |
26995 | ||
26996 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
26997 | SAVE | |
26998 | ||
26999 | Y = DT_DGAMRN(1.0D0,GAM) | |
27000 | Z = DT_DGAMRN(1.0D0,ETA) | |
27001 | DT_DBETAR = Y/(Y+Z) | |
27002 | ||
27003 | RETURN | |
27004 | END | |
27005 | ||
27006 | *$ CREATE DT_RANNOR.FOR | |
27007 | *COPY DT_RANNOR | |
27008 | * | |
27009 | *===rannor=============================================================* | |
27010 | * | |
27011 | SUBROUTINE DT_RANNOR(X,Y) | |
27012 | ||
27013 | ************************************************************************ | |
27014 | * Sampling from Gaussian distribution. * | |
27015 | * Processed by S. Roesler, 6.5.95 * | |
27016 | ************************************************************************ | |
27017 | ||
27018 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27019 | SAVE | |
27020 | PARAMETER (TINY10=1.0D-10) | |
27021 | ||
27022 | CALL DT_DSFECF(SFE,CFE) | |
27023 | V = MAX(TINY10,DT_RNDM(X)) | |
27024 | A = SQRT(-2.D0*LOG(V)) | |
27025 | X = A*SFE | |
27026 | Y = A*CFE | |
27027 | ||
27028 | RETURN | |
27029 | END | |
27030 | ||
27031 | *$ CREATE DT_DPOLI.FOR | |
27032 | *COPY DT_DPOLI | |
27033 | * | |
27034 | *===dpoli==============================================================* | |
27035 | * | |
27036 | SUBROUTINE DT_DPOLI(CS,SI) | |
27037 | ||
27038 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27039 | SAVE | |
27040 | ||
27041 | U = DT_RNDM(CS) | |
27042 | CS = DT_RNDM(U) | |
27043 | IF (U.LT.0.5D0) CS=-CS | |
27044 | SI = SQRT(1.0D0-CS*CS+1.0D-10) | |
27045 | ||
27046 | RETURN | |
27047 | END | |
27048 | ||
27049 | *$ CREATE DT_DSFECF.FOR | |
27050 | *COPY DT_DSFECF | |
27051 | * | |
27052 | *===dsfecf=============================================================* | |
27053 | * | |
27054 | SUBROUTINE DT_DSFECF(SFE,CFE) | |
27055 | ||
27056 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27057 | SAVE | |
27058 | PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0) | |
27059 | ||
27060 | 1 CONTINUE | |
27061 | X = DT_RNDM(SFE) | |
27062 | Y = DT_RNDM(X) | |
27063 | XX = X*X | |
27064 | YY = Y*Y | |
27065 | XY = XX+YY | |
27066 | IF (XY.GT.ONE) GOTO 1 | |
27067 | CFE = (XX-YY)/XY | |
27068 | SFE = TWO*X*Y/XY | |
27069 | IF (DT_RNDM(X).LT.OHALF) SFE = -SFE | |
27070 | RETURN | |
27071 | END | |
27072 | ||
27073 | *$ CREATE DT_RACO.FOR | |
27074 | *COPY DT_RACO | |
27075 | * | |
27076 | *===raco===============================================================* | |
27077 | * | |
27078 | SUBROUTINE DT_RACO(WX,WY,WZ) | |
27079 | ||
27080 | ************************************************************************ | |
27081 | * Direction cosines of random uniform (isotropic) direction in three * | |
27082 | * dimensional space * | |
27083 | * Processed by S. Roesler, 20.11.95 * | |
27084 | ************************************************************************ | |
27085 | ||
27086 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27087 | SAVE | |
27088 | PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0) | |
27089 | ||
27090 | 10 CONTINUE | |
27091 | X = TWO*DT_RNDM(WX)-ONE | |
27092 | Y = DT_RNDM(X) | |
27093 | X2 = X*X | |
27094 | Y2 = Y*Y | |
27095 | IF (X2+Y2.GT.ONE) GOTO 10 | |
27096 | ||
27097 | CFE = (X2-Y2)/(X2+Y2) | |
27098 | SFE = TWO*X*Y/(X2+Y2) | |
27099 | * z = 1/2 [ 1 + cos (theta) ] | |
27100 | Z = DT_RNDM(X) | |
27101 | * 1/2 sin (theta) | |
27102 | WZ = SQRT(Z*(ONE-Z)) | |
27103 | WX = TWO*WZ*CFE | |
27104 | WY = TWO*WZ*SFE | |
27105 | WZ = TWO*Z-ONE | |
27106 | ||
27107 | RETURN | |
27108 | END | |
27109 | ||
27110 | ************************************************************************ | |
27111 | * * | |
27112 | * 6) Special functions, algorithms and service routines * | |
27113 | * * | |
27114 | ************************************************************************ | |
27115 | *$ CREATE DT_YLAMB.FOR | |
27116 | *COPY DT_YLAMB | |
27117 | * | |
27118 | *===ylamb==============================================================* | |
27119 | * | |
27120 | DOUBLE PRECISION FUNCTION DT_YLAMB(X,Y,Z) | |
27121 | ||
27122 | ************************************************************************ | |
27123 | * * | |
27124 | * auxiliary function for three particle decay mode * | |
27125 | * (standard LAMBDA**(1/2) function) * | |
27126 | * * | |
27127 | * Adopted from an original version written by R. Engel. * | |
27128 | * This version dated 12.12.94 is written by S. Roesler. * | |
27129 | ************************************************************************ | |
27130 | ||
27131 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27132 | SAVE | |
27133 | ||
27134 | YZ = Y-Z | |
27135 | XLAM = X*X-2.D0*X*(Y+Z)+YZ*YZ | |
27136 | IF (XLAM.LE.0.D0) XLAM = ABS(XLAM) | |
27137 | DT_YLAMB = SQRT(XLAM) | |
27138 | ||
27139 | RETURN | |
27140 | END | |
27141 | ||
27142 | *$ CREATE DT_SORT.FOR | |
27143 | *COPY DT_SORT | |
27144 | * | |
27145 | *===sort1==============================================================* | |
27146 | * | |
27147 | SUBROUTINE DT_SORT(A,N,I0,I1,MODE) | |
27148 | ||
27149 | ************************************************************************ | |
27150 | * This subroutine sorts entries in A in increasing/decreasing order * | |
27151 | * of A(3,i). * | |
27152 | * MODE = 1 increasing in A(3,i=1..N) * | |
27153 | * = 2 decreasing in A(3,i=1..N) * | |
27154 | * This version dated 21.04.95 is revised by S. Roesler * | |
27155 | ************************************************************************ | |
27156 | ||
27157 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27158 | SAVE | |
27159 | ||
27160 | DIMENSION A(3,N) | |
27161 | ||
27162 | M = I1 | |
27163 | 10 CONTINUE | |
27164 | M = I1-1 | |
27165 | IF (M.LE.0) RETURN | |
27166 | L = 0 | |
27167 | DO 20 I=I0,M | |
27168 | J = I+1 | |
27169 | IF (MODE.EQ.1) THEN | |
27170 | IF (A(3,I).LE.A(3,J)) GOTO 20 | |
27171 | ELSE | |
27172 | IF (A(3,I).GE.A(3,J)) GOTO 20 | |
27173 | ENDIF | |
27174 | B = A(3,I) | |
27175 | C = A(1,I) | |
27176 | D = A(2,I) | |
27177 | A(3,I) = A(3,J) | |
27178 | A(2,I) = A(2,J) | |
27179 | A(1,I) = A(1,J) | |
27180 | A(3,J) = B | |
27181 | A(1,J) = C | |
27182 | A(2,J) = D | |
27183 | L = 1 | |
27184 | 20 CONTINUE | |
27185 | IF (L.EQ.1) GOTO 10 | |
27186 | ||
27187 | RETURN | |
27188 | END | |
27189 | ||
27190 | *$ CREATE DT_SORT1.FOR | |
27191 | *COPY DT_SORT1 | |
27192 | * | |
27193 | *===sort1==============================================================* | |
27194 | * | |
27195 | SUBROUTINE DT_SORT1(A,IDX,N,I0,I1,MODE) | |
27196 | ||
27197 | ************************************************************************ | |
27198 | * This subroutine sorts entries in A in increasing/decreasing order * | |
27199 | * of A(i). * | |
27200 | * MODE = 1 increasing in A(i=1..N) * | |
27201 | * = 2 decreasing in A(i=1..N) * | |
27202 | * This version dated 21.04.95 is revised by S. Roesler * | |
27203 | ************************************************************************ | |
27204 | ||
27205 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27206 | SAVE | |
27207 | ||
27208 | DIMENSION A(N),IDX(N) | |
27209 | ||
27210 | M = I1 | |
27211 | 10 CONTINUE | |
27212 | M = I1-1 | |
27213 | IF (M.LE.0) RETURN | |
27214 | L = 0 | |
27215 | DO 20 I=I0,M | |
27216 | J = I+1 | |
27217 | IF (MODE.EQ.1) THEN | |
27218 | IF (A(I).LE.A(J)) GOTO 20 | |
27219 | ELSE | |
27220 | IF (A(I).GE.A(J)) GOTO 20 | |
27221 | ENDIF | |
27222 | B = A(I) | |
27223 | A(I) = A(J) | |
27224 | A(J) = B | |
27225 | IX = IDX(I) | |
27226 | IDX(I) = IDX(J) | |
27227 | IDX(J) = IX | |
27228 | L = 1 | |
27229 | 20 CONTINUE | |
27230 | IF (L.EQ.1) GOTO 10 | |
27231 | ||
27232 | RETURN | |
27233 | END | |
27234 | ||
27235 | *$ CREATE DT_XTIME.FOR | |
27236 | *COPY DT_XTIME | |
27237 | * | |
27238 | *===xtime==============================================================* | |
27239 | * | |
27240 | SUBROUTINE DT_XTIME | |
27241 | ||
27242 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27243 | SAVE | |
27244 | PARAMETER ( LINP = 10 , | |
27245 | & LOUT = 6 , | |
27246 | & LDAT = 9 ) | |
27247 | ||
27248 | CHARACTER DAT*9,TIM*11 | |
27249 | ||
27250 | DAT = ' ' | |
27251 | TIM = ' ' | |
27252 | C CALL GETDAT(IYEAR,IMONTH,IDAY) | |
27253 | C CALL GETTIM(IHOUR,IMINUT,ISECND,IHSCND) | |
27254 | ||
27255 | C CALL DATE(DAT) | |
27256 | C CALL TIME(TIM) | |
27257 | C WRITE(LOUT,1000) DAT,TIM | |
27258 | 1000 FORMAT(/,2X,'Date: ',A9,3X,'Time: ',A11,/) | |
27259 | ||
27260 | RETURN | |
27261 | END | |
27262 | ||
27263 | ************************************************************************ | |
27264 | * * | |
27265 | * 7) Random number generator package * | |
27266 | * * | |
27267 | * THIS IS A PACKAGE CONTAINING A RANDOM NUMBER GENERATOR AND * | |
27268 | * SERVICE ROUTINES. * | |
27269 | * THE ALGORITHM IS FROM * | |
27270 | * 'TOWARD A UNVERSAL RANDOM NUMBER GENERATOR' * | |
27271 | * G.MARSAGLIA, A.ZAMAN ; FSU-SCRI-87-50 * | |
27272 | * IMPLEMENTATION BY K. HAHN DEC. 88, * | |
27273 | * THIS GENERATOR SHOULD NOT DEPEND ON THE HARD WARE ( IF A REAL HAS * | |
27274 | * AT LEAST 24 SIGNIFICANT BITS IN INTERNAL REPRESENTATION ), * | |
27275 | * THE PERIOD IS ABOUT 2**144, * | |
27276 | * TIME FOR ONE CALL AT IBM-XT IS ABOUT 0.7 MILLISECONDS, * | |
27277 | * THE PACKAGE CONTAINS * | |
27278 | * FUNCTION DT_RNDM(I) : GENERATOR * | |
27279 | * SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB4): INITIALIZATION * | |
27280 | * SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) : PUT SEED TO GENERATOR * | |
27281 | * SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) : TAKE SEED FROM GENERATOR * | |
27282 | * SUBROUTINE DT_RNDMTE(IO) : TEST OF GENERATOR * | |
27283 | *--- * | |
27284 | * FUNCTION DT_RNDM(I) * | |
27285 | * GIVES UNIFORMLY DISTRIBUTED RANDOM NUMBERS IN (0..1) * | |
27286 | * I - DUMMY VARIABLE, NOT USED * | |
27287 | * SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1) * | |
27288 | * INITIALIZES THE GENERATOR, MUST BE CALLED BEFORE USING DT_RNDM * | |
27289 | * NA1,NA2,NA3,NB1 - VALUES FOR INITIALIZING THE GENERATOR * | |
27290 | * NA? MUST BE IN 1..178 AND NOT ALL 1 * | |
27291 | * 12,34,56 ARE THE STANDARD VALUES * | |
27292 | * NB1 MUST BE IN 1..168 * | |
27293 | * 78 IS THE STANDARD VALUE * | |
27294 | * SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) * | |
27295 | * PUTS SEED TO GENERATOR ( BRINGS GENERATOR IN THE SAME STATUS * | |
27296 | * AS AFTER THE LAST DT_RNDMOU CALL ) * | |
27297 | * U(97),C,CD,CM,I,J - SEED VALUES AS TAKEN FROM DT_RNDMOU * | |
27298 | * SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) * | |
27299 | * TAKES SEED FROM GENERATOR * | |
27300 | * U(97),C,CD,CM,I,J - SEED VALUES * | |
27301 | * SUBROUTINE DT_RNDMTE(IO) * | |
27302 | * TEST OF THE GENERATOR * | |
27303 | * IO - DEFINES OUTPUT * | |
27304 | * = 0 OUTPUT ONLY IF AN ERROR IS DETECTED * | |
27305 | * = 1 OUTPUT INDEPENDEND ON AN ERROR * | |
27306 | * DT_RNDMTE USES DT_RNDMIN AND DT_RNDMOU TO BRING GENERATOR TO * | |
27307 | * SAME STATUS * | |
27308 | * AS BEFORE CALL OF DT_RNDMTE * | |
27309 | ************************************************************************ | |
27310 | *$ CREATE DT_RNDM.FOR | |
27311 | *COPY DT_RNDM | |
27312 | * | |
839efe5b | 27313 | c$$$*===rndm===============================================================* |
27314 | c$$$* | |
27315 | c$$$ DOUBLE PRECISION FUNCTION DT_RNDM(VDUMMY) | |
27316 | c$$$ | |
27317 | c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27318 | c$$$ SAVE | |
27319 | c$$$ | |
27320 | c$$$* random number generator | |
27321 | c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J | |
27322 | c$$$ | |
27323 | c$$$* counter of calls to random number generator | |
27324 | c$$$* uncomment if needed | |
27325 | c$$$C COMMON /DTRNCT/ IRNCT0,IRNCT1 | |
27326 | c$$$C LOGICAL LFIRST | |
27327 | c$$$C DATA LFIRST /.TRUE./ | |
27328 | c$$$ | |
27329 | c$$$* counter of calls to random number generator | |
27330 | c$$$* uncomment if needed | |
27331 | c$$$C IF (LFIRST) THEN | |
27332 | c$$$C IRNCT0 = 0 | |
27333 | c$$$C IRNCT1 = 0 | |
27334 | c$$$C LFIRST = .FALSE. | |
27335 | c$$$C ENDIF | |
27336 | c$$$ 100 CONTINUE | |
27337 | c$$$ DT_RNDM = U(I)-U(J) | |
27338 | c$$$ IF ( DT_RNDM.LT.0.0D0 ) DT_RNDM = DT_RNDM+1.0D0 | |
27339 | c$$$ U(I) = DT_RNDM | |
27340 | c$$$ I = I-1 | |
27341 | c$$$ IF ( I.EQ.0 ) I = 97 | |
27342 | c$$$ J = J-1 | |
27343 | c$$$ IF ( J.EQ.0 ) J = 97 | |
27344 | c$$$ C = C-CD | |
27345 | c$$$ IF ( C.LT.0.0D0 ) C = C+CM | |
27346 | c$$$ DT_RNDM = DT_RNDM-C | |
27347 | c$$$ IF ( DT_RNDM.LT.0.0D0 ) DT_RNDM = DT_RNDM+1.0D0 | |
27348 | c$$$ | |
27349 | c$$$ IF ((DT_RNDM.EQ.0.D0).OR.(DT_RNDM.EQ.1.D0)) GOTO 100 | |
27350 | c$$$ | |
27351 | c$$$* counter of calls to random number generator | |
27352 | c$$$* uncomment if needed | |
27353 | c$$$C IRNCT0 = IRNCT0+1 | |
27354 | c$$$ | |
27355 | c$$$ RETURN | |
27356 | c$$$ END | |
27357 | c$$$ | |
27358 | c$$$*$ CREATE DT_RNDMST.FOR | |
27359 | c$$$*COPY DT_RNDMST | |
27360 | c$$$* | |
27361 | c$$$*===rndmst=============================================================* | |
27362 | c$$$* | |
27363 | c$$$ SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1) | |
27364 | c$$$ | |
27365 | c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27366 | c$$$ SAVE | |
27367 | c$$$ | |
27368 | c$$$* random number generator | |
27369 | c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J | |
27370 | c$$$ | |
27371 | c$$$ MA1 = NA1 | |
27372 | c$$$ MA2 = NA2 | |
27373 | c$$$ MA3 = NA3 | |
27374 | c$$$ MB1 = NB1 | |
27375 | c$$$ I = 97 | |
27376 | c$$$ J = 33 | |
27377 | c$$$ DO 20 II2 = 1,97 | |
27378 | c$$$ S = 0 | |
27379 | c$$$ T = 0.5D0 | |
27380 | c$$$ DO 10 II1 = 1,24 | |
27381 | c$$$ MAT = MOD(MOD(MA1*MA2,179)*MA3,179) | |
27382 | c$$$ MA1 = MA2 | |
27383 | c$$$ MA2 = MA3 | |
27384 | c$$$ MA3 = MAT | |
27385 | c$$$ MB1 = MOD(53*MB1+1,169) | |
27386 | c$$$ IF ( MOD(MB1*MAT,64).GE.32 ) S = S+T | |
27387 | c$$$ 10 T = 0.5D0*T | |
27388 | c$$$ 20 U(II2) = S | |
27389 | c$$$ C = 362436.0D0/16777216.0D0 | |
27390 | c$$$ CD = 7654321.0D0/16777216.0D0 | |
27391 | c$$$ CM = 16777213.0D0/16777216.0D0 | |
27392 | c$$$ RETURN | |
27393 | c$$$ END | |
27394 | c$$$ | |
27395 | c$$$*$ CREATE DT_RNDMIN.FOR | |
27396 | c$$$*COPY DT_RNDMIN | |
27397 | c$$$* | |
27398 | c$$$*===rndmin=============================================================* | |
27399 | c$$$* | |
27400 | c$$$ SUBROUTINE DT_RNDMIN(UIN,CIN,CDIN,CMIN,IIN,JIN) | |
27401 | c$$$ | |
27402 | c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27403 | c$$$ SAVE | |
27404 | c$$$ | |
27405 | c$$$* random number generator | |
27406 | c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J | |
27407 | c$$$ | |
27408 | c$$$ DIMENSION UIN(97) | |
27409 | c$$$ | |
27410 | c$$$ DO 10 KKK = 1,97 | |
27411 | c$$$ 10 U(KKK) = UIN(KKK) | |
27412 | c$$$ C = CIN | |
27413 | c$$$ CD = CDIN | |
27414 | c$$$ CM = CMIN | |
27415 | c$$$ I = IIN | |
27416 | c$$$ J = JIN | |
27417 | c$$$ | |
27418 | c$$$ RETURN | |
27419 | c$$$ END | |
27420 | c$$$ | |
27421 | c$$$*$ CREATE DT_RNDMOU.FOR | |
27422 | c$$$*COPY DT_RNDMOU | |
27423 | c$$$* | |
27424 | c$$$*===rndmou=============================================================* | |
27425 | c$$$* | |
27426 | c$$$ SUBROUTINE DT_RNDMOU(UOUT,COUT,CDOUT,CMOUT,IOUT,JOUT) | |
27427 | c$$$ | |
27428 | c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27429 | c$$$ SAVE | |
27430 | c$$$ | |
27431 | c$$$* random number generator | |
27432 | c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J | |
27433 | c$$$ | |
27434 | c$$$ DIMENSION UOUT(97) | |
27435 | c$$$ | |
27436 | c$$$ DO 10 KKK = 1,97 | |
27437 | c$$$ 10 UOUT(KKK) = U(KKK) | |
27438 | c$$$ COUT = C | |
27439 | c$$$ CDOUT = CD | |
27440 | c$$$ CMOUT = CM | |
27441 | c$$$ IOUT = I | |
27442 | c$$$ JOUT = J | |
27443 | c$$$ | |
27444 | c$$$ RETURN | |
27445 | c$$$ END | |
27446 | c$$$ | |
27447 | c$$$*$ CREATE DT_RNDMTE.FOR | |
27448 | c$$$*COPY DT_RNDMTE | |
27449 | c$$$* | |
27450 | c$$$*===rndmte=============================================================* | |
27451 | c$$$* | |
27452 | c$$$ SUBROUTINE DT_RNDMTE(IO) | |
27453 | c$$$ | |
27454 | c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27455 | c$$$ SAVE | |
27456 | c$$$ | |
27457 | c$$$ DIMENSION UU(97),U(6),X(6),D(6) | |
27458 | c$$$ DATA U / 6533892.D0, 14220222.D0, 7275067.D0, 6172232.D0, | |
27459 | c$$$ +8354498.D0, 10633180.D0/ | |
27460 | c$$$ | |
27461 | c$$$ CALL DT_RNDMOU(UU,CC,CCD,CCM,II,JJ) | |
27462 | c$$$ CALL DT_RNDMST(12,34,56,78) | |
27463 | c$$$ DO 10 II1 = 1,20000 | |
27464 | c$$$ 10 XX = DT_RNDM(XX) | |
27465 | c$$$ SD = 0.0D0 | |
27466 | c$$$ DO 20 II2 = 1,6 | |
27467 | c$$$ X(II2) = 4096.D0*(4096.D0*DT_RNDM(SD)) | |
27468 | c$$$ D(II2) = X(II2)-U(II2) | |
27469 | c$$$ 20 SD = SD+D(II2) | |
27470 | c$$$ CALL DT_RNDMIN(UU,CC,CCD,CCM,II,JJ) | |
27471 | c$$$**sr 24.01.95 | |
27472 | c$$$C IF ( IO.EQ. 1.OR. SD.NE.0. 0) WRITE(6,500) (U(I),X(I),D(I),I=1,6) | |
27473 | c$$$ IF ((IO.EQ.1).OR.(SD.NE.0.0)) THEN | |
27474 | c$$$C WRITE(6,1000) | |
27475 | c$$$ 1000 FORMAT(/,/,1X,'DT_RNDMTE: Test of random-number generator...', | |
27476 | c$$$ & ' passed') | |
27477 | c$$$ ENDIF | |
27478 | c$$$** | |
27479 | c$$$ RETURN | |
27480 | c$$$ 500 FORMAT(' === TEST OF THE RANDOM-GENERATOR ===',/, | |
27481 | c$$$ &' EXPECTED VALUE CALCULATED VALUE DIFFERENCE',/, 6(F17. | |
27482 | c$$$ &1,F20.1,F15.3,/), ' === END OF TEST ;', | |
27483 | c$$$ &' GENERATOR HAS THE SAME STATUS AS BEFORE CALLING DT_RNDMTE') | |
27484 | c$$$ END | |
9aaba0d6 | 27485 | * |
27486 | *$ CREATE PHO_RNDM.FOR | |
27487 | *COPY PHO_RNDM | |
27488 | * | |
27489 | *===pho_rndm===========================================================* | |
27490 | * | |
27491 | DOUBLE PRECISION FUNCTION PHO_RNDM(DUMMY) | |
27492 | ||
27493 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27494 | SAVE | |
27495 | ||
27496 | PHO_RNDM = DT_RNDM(DUMMY) | |
27497 | ||
27498 | RETURN | |
27499 | END | |
27500 | ||
27501 | *$ CREATE PYR.FOR | |
27502 | *COPY PYR | |
27503 | * | |
27504 | *===pyr================================================================* | |
27505 | * | |
27506 | DOUBLE PRECISION FUNCTION PYR(IDUMMY) | |
27507 | ||
27508 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27509 | SAVE | |
27510 | ||
27511 | DUMMY = DBLE(IDUMMY) | |
27512 | PYR = DT_RNDM(DUMMY) | |
27513 | ||
27514 | RETURN | |
27515 | END | |
27516 | ||
27517 | *$ CREATE DT_TITLE.FOR | |
27518 | *COPY DT_TITLE | |
27519 | * | |
27520 | *===title==============================================================* | |
27521 | * | |
27522 | SUBROUTINE DT_TITLE | |
27523 | ||
27524 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27525 | SAVE | |
27526 | PARAMETER ( LINP = 10 , | |
27527 | & LOUT = 6 , | |
27528 | & LDAT = 9 ) | |
27529 | ||
27530 | CHARACTER*6 CVERSI | |
27531 | CHARACTER*11 CCHANG | |
27532 | DATA CVERSI,CCHANG /'3.0-5 ','08 Jan 2007'/ | |
27533 | ||
27534 | CALL DT_XTIME | |
27535 | WRITE(LOUT,1000) CVERSI,CCHANG | |
27536 | 1000 FORMAT(1X,'+-------------------------------------------------', | |
27537 | & '----------------------+',/, | |
27538 | & 1X,'|',71X,'|',/, | |
27539 | & 1X,'|',26X,'DPMJET version ',A6,24X,'|',/, | |
27540 | & 1X,'|',71X,'|',/, | |
27541 | & 1X,'|',22X,'(Last change: ',A11,')',23X,'|',/, | |
27542 | & 1X,'|',71X,'|',/, | |
27543 | & 1X,'|',12X,'Authors: Stefan Roesler (CERN)',27X,'|',/, | |
27544 | & 1X,'|',21X,'Ralph Engel (FZ Karlsruhe)',19X,'|',/, | |
27545 | & 1X,'|',21X,'Johannes Ranft (Siegen Univ.)',19X,'|',/, | |
27546 | & 1X,'|',71X,'|',/, | |
27547 | & 1X,'|',12X,'http://home.cern.ch/~sroesler/dpmjet3.html', | |
27548 | & 17X,'|',/, | |
27549 | & 1X,'|',71X,'|',/, | |
27550 | & 1X,'+-------------------------------------------------', | |
27551 | & '----------------------+',/, | |
27552 | & 1X,'| Please send suggestions, bug reports, etc. to: ', | |
27553 | & 'Stefan.Roesler@cern.ch |',/, | |
27554 | & 1X,'+-------------------------------------------------', | |
27555 | & '----------------------+',/) | |
27556 | ||
27557 | RETURN | |
27558 | END | |
27559 | ||
27560 | *$ CREATE DT_EVTINI.FOR | |
27561 | *COPY DT_EVTINI | |
27562 | * | |
27563 | *===evtini=============================================================* | |
27564 | * | |
27565 | SUBROUTINE DT_EVTINI | |
27566 | ||
27567 | ************************************************************************ | |
27568 | * Initialization of DTEVT1. * | |
27569 | * This version dated 15.01.94 is written by S. Roesler * | |
27570 | ************************************************************************ | |
27571 | ||
27572 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27573 | SAVE | |
27574 | PARAMETER ( LINP = 10 , | |
27575 | & LOUT = 6 , | |
27576 | & LDAT = 9 ) | |
27577 | ||
27578 | * event history | |
27579 | PARAMETER (NMXHKK=200000) | |
27580 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
27581 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
27582 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
27583 | * extended event history | |
27584 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
27585 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
27586 | & IHIST(2,NMXHKK) | |
27587 | * event flag | |
27588 | COMMON /DTEVNO/ NEVENT,ICASCA | |
27589 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
27590 | * emulsion treatment | |
27591 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
27592 | & NCOMPO,IEMUL | |
27593 | ||
27594 | * initialization of DTEVT1/DTEVT2 | |
27595 | NEND = NHKK | |
27596 | IF (NEVENT.EQ.1) NEND = NMXHKK | |
27597 | NHKK = 0 | |
27598 | NEVHKK = NEVENT | |
27599 | DO 1 I=1,NEND | |
27600 | ISTHKK(I) = 0 | |
27601 | IDHKK(I) = 0 | |
27602 | JMOHKK(1,I) = 0 | |
27603 | JMOHKK(2,I) = 0 | |
27604 | JDAHKK(1,I) = 0 | |
27605 | JDAHKK(2,I) = 0 | |
27606 | IDRES(I) = 0 | |
27607 | IDXRES(I) = 0 | |
27608 | NOBAM(I) = 0 | |
27609 | IDCH(I) = 0 | |
27610 | IHIST(1,I) = 0 | |
27611 | IHIST(2,I) = 0 | |
27612 | DO 2 J=1,4 | |
27613 | PHKK(J,I) = 0.0D0 | |
27614 | VHKK(J,I) = 0.0D0 | |
27615 | WHKK(J,I) = 0.0D0 | |
27616 | 2 CONTINUE | |
27617 | PHKK(5,I) = 0.0D0 | |
27618 | 1 CONTINUE | |
27619 | DO 3 I=1,10 | |
27620 | NPOINT(I) = 0 | |
27621 | 3 CONTINUE | |
27622 | CALL DT_CHASTA(-1) | |
27623 | ||
27624 | C* initialization of DTLTRA | |
27625 | C IF (NCOMPO.GT.0) CALL DT_LTINI(ID,EPN,PPN,ECM) | |
27626 | ||
27627 | RETURN | |
27628 | END | |
27629 | ||
27630 | *$ CREATE DT_STATIS.FOR | |
27631 | *COPY DT_STATIS | |
27632 | * | |
27633 | *===statis=============================================================* | |
27634 | * | |
27635 | SUBROUTINE DT_STATIS(MODE) | |
27636 | ||
27637 | ************************************************************************ | |
27638 | * Initialization and output of run-statistics. * | |
27639 | * MODE = 1 initialization * | |
27640 | * = 2 output * | |
27641 | * This version dated 23.01.94 is written by S. Roesler * | |
27642 | ************************************************************************ | |
27643 | ||
27644 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27645 | SAVE | |
27646 | PARAMETER ( LINP = 10 , | |
27647 | & LOUT = 6 , | |
27648 | & LDAT = 9 ) | |
27649 | PARAMETER (TINY3=1.0D-3) | |
27650 | ||
27651 | * statistics | |
27652 | COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA, | |
27653 | & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5), | |
27654 | & ICEVTG(8,0:30) | |
27655 | * rejection counter | |
27656 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
27657 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
27658 | & IREXCI(3),IRDIFF(2),IRINC | |
27659 | * central particle production, impact parameter biasing | |
27660 | COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR | |
27661 | * various options for treatment of partons (DTUNUC 1.x) | |
27662 | * (chain recombination, Cronin,..) | |
27663 | LOGICAL LCO2CR,LINTPT | |
27664 | COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, | |
27665 | & LCO2CR,LINTPT | |
27666 | * nucleon-nucleon event-generator | |
27667 | CHARACTER*8 CMODEL | |
27668 | LOGICAL LPHOIN | |
27669 | COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN | |
27670 | * flags for particle decays | |
27671 | COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20), | |
27672 | & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20), | |
27673 | & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0 | |
27674 | * diquark-breaking mechanism | |
27675 | COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3 | |
27676 | ||
27677 | DIMENSION PP(4),PT(4) | |
27678 | ||
27679 | GOTO (1,2) MODE | |
27680 | ||
27681 | * initialization | |
27682 | 1 CONTINUE | |
27683 | ||
27684 | * initialize statistics counter | |
27685 | ICREQU = 0 | |
27686 | ICSAMP = 0 | |
27687 | ICCPRO = 0 | |
27688 | ICDPR = 0 | |
27689 | ICDTA = 0 | |
27690 | ICRJSS = 0 | |
27691 | ICVV2S = 0 | |
27692 | DO 10 I=1,9 | |
27693 | ICRES(I) = 0 | |
27694 | ICCHAI(1,I) = 0 | |
27695 | ICCHAI(2,I) = 0 | |
27696 | 10 CONTINUE | |
27697 | * initialize rejection counter | |
27698 | IRPT = 0 | |
27699 | IRHHA = 0 | |
27700 | LOMRES = 0 | |
27701 | LOBRES = 0 | |
27702 | IRFRAG = 0 | |
27703 | IREVT = 0 | |
27704 | IRRES(1) = 0 | |
27705 | IRRES(2) = 0 | |
27706 | IRCHKI(1) = 0 | |
27707 | IRCHKI(2) = 0 | |
27708 | IRCRON(1) = 0 | |
27709 | IRCRON(2) = 0 | |
27710 | IRCRON(3) = 0 | |
27711 | IRDIFF(1) = 0 | |
27712 | IRDIFF(2) = 0 | |
27713 | IRINC = 0 | |
27714 | DO 11 I=1,5 | |
27715 | ICDIFF(I) = 0 | |
27716 | 11 CONTINUE | |
27717 | DO 12 I=1,8 | |
27718 | DO 13 J=0,30 | |
27719 | ICEVTG(I,J) = 0 | |
27720 | 13 CONTINUE | |
27721 | 12 CONTINUE | |
27722 | ||
27723 | RETURN | |
27724 | ||
27725 | * output | |
27726 | 2 CONTINUE | |
27727 | ||
27728 | * statistics counter | |
27729 | WRITE(LOUT,1000) | |
27730 | 1000 FORMAT(/,/,1X,'STATIS:',20X,'statistics of the run',/, | |
27731 | & 28X,'---------------------') | |
27732 | WRITE(LOUT,1001) ICREQU,ICSAMP,DBLE(ICSAMP)/DBLE(ICREQU) | |
27733 | 1001 FORMAT(/,1X,'number of events requested / sampled',13X, | |
27734 | & I8,' / ',I8,/,1X,'number of samp. evts per requested ', | |
27735 | & 'event',11X,F9.1) | |
27736 | IF (ICDIFF(1).NE.0) THEN | |
27737 | WRITE(LOUT,1009) ICDIFF | |
27738 | 1009 FORMAT(/,1X,'diffractive events: total ',I8,/,49X, | |
27739 | & 'low mass high mass',/,24X,'single diffraction', | |
27740 | & 7X,I8,4X,I8,/,24X,'double diffraction',7X,I8,4X,I8) | |
27741 | ENDIF | |
27742 | IF (ICENTR.GT.0) THEN | |
27743 | WRITE(LOUT,1002) DBLE(ICCPRO)/DBLE(ICSAMP), | |
27744 | & DBLE(ICSAMP)/DBLE(ICCPRO) | |
27745 | 1002 FORMAT(/,1X,'central production:',/,2X,'mean number', | |
27746 | & ' of sampled Glauber-events per event',9X,F9.1,/, | |
27747 | & 2X,'fraction of production cross section',21X,F10.6) | |
27748 | ENDIF | |
27749 | WRITE(LOUT,1003) DBLE(ICDPR)/DBLE(ICSAMP), | |
27750 | & DBLE(ICDTA)/DBLE(ICSAMP) | |
27751 | 1003 FORMAT(/,54X,'proj. targ.',/,1X,'average number of wounded', | |
27752 | & ' nucleons after x-sampling',2(4X,F6.2)) | |
27753 | ||
27754 | IF (MCGENE.EQ.1) THEN | |
27755 | WRITE(LOUT,1004) DBLE(ICRJSS)/DBLE(ICSAMP) | |
27756 | 1004 FORMAT(/,1X,'mean number of sea-sea chain rejections per', | |
27757 | & ' event',3X,F9.1) | |
27758 | IF (ISICHA.EQ.1) THEN | |
27759 | WRITE(LOUT,1005) DBLE(ICVV2S)/DBLE(ICSAMP) | |
27760 | 1005 FORMAT(/,1X,'Reggeon contribution:',/,1X,'mean number ', | |
27761 | & 'of single chains per event',13X,F9.1) | |
27762 | ENDIF | |
27763 | WRITE(LOUT,1006) | |
27764 | 1006 FORMAT(/,1X,'chain system statistics: (per event)',/, | |
27765 | & 23X,'mean number of chains mean number of chains',/, | |
27766 | & 23X,'sampled hadronized having mass of a reso.') | |
27767 | WRITE(LOUT,1007) (DBLE(ICCHAI(1,J))/(2.0D0*DBLE(ICSAMP)), | |
27768 | & DBLE(ICCHAI(2,J))/(2.0D0*DBLE(ICREQU)), | |
27769 | & DBLE(ICRES(J))/(2.0D0*DBLE(ICREQU)),J=1,8), | |
27770 | & DBLE(ICCHAI(2,9))/MAX(DBLE(ICCHAI(1,9)),TINY3) | |
27771 | 1007 FORMAT(1X,'sea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/, | |
27772 | & 1X,'disea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/, | |
27773 | & 1X,'sea - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/, | |
27774 | & 1X,'sea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/, | |
27775 | & 1X,'disea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/, | |
27776 | & 1X,'valence - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/, | |
27777 | & 1X,'valence - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/, | |
27778 | & 1X,'valence - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/, | |
27779 | & 1X,'fused chains ',18X,F4.1,17X,F4.1,/) | |
27780 | WRITE(LOUT,1008) | |
27781 | & (DBLE(IRCRON(I))/MAX(DBLE(IRCRON(1)),TINY3),I=2,3), | |
27782 | & DBLE(IRPT)/DBLE(ICREQU),(DBLE(IRRES(I))/DBLE(ICREQU),I=1,2), | |
27783 | & DBLE(LOMRES)/DBLE(ICREQU),DBLE(LOBRES)/DBLE(ICREQU), | |
27784 | & (DBLE(IRCHKI(I))/DBLE(ICREQU),I=1,2), | |
27785 | & (DBLE(IRDIFF(I))/DBLE(ICREQU),I=1,2), | |
27786 | & DBLE(IRHHA)/DBLE(ICREQU), | |
27787 | & DBLE(IRFRAG)/DBLE(ICREQU),DBLE(IREVT)/DBLE(ICREQU), | |
27788 | & (DBLE(IREXCI(I))/DBLE(ICREQU),I=1,2),IREXCI(3) | |
27789 | 1008 FORMAT(/,1X,'Rejection counter: (NEVT = no. of events)',/,/, | |
27790 | & 1X,'Cronin-effect (CRONIN)',15X,'IRCRON(2)/IRCRON(1) = ', | |
27791 | & F7.2,/,38X,'IRCRON(3)/IRCRON(1) = ',F7.2,/,1X, | |
27792 | & 'Intrins. p_t (GETSPT)',21X,'IRPT /NEVT = ',F7.2,/, | |
27793 | & 1X,'Chain mass corr. for resonances (EVTRES)',2X, | |
27794 | & 'IRRES(1) /NEVT = ',F7.2,/,33X,'(CH2RES) IRRES(2) /', | |
27795 | & 'NEVT = ',F7.2,/,43X,'LOMRES /NEVT = ',F7.2,/, | |
27796 | & 43X,'LOBRES /NEVT = ',F7.2,/,1X,'Kinem. corr. of', | |
27797 | & ' 2-chain systems (CHKINE) IRCHKI(1)/NEVT = ',F7.2,/, | |
27798 | & 43X,'IRCHKI(2)/NEVT = ',F7.2,/,1X,'Diffraction',31X, | |
27799 | & 'IRDIFF(1)/NEVT = ',F7.2,/,43X,'IRDIFF(2)/NEVT = ', | |
27800 | & F7.2,/,1X,'Total no. of rej.', | |
27801 | & ' in chain-systems treatment (GETCSY)',/,43X, | |
27802 | & 'IRHHA /NEVT = ',F7.2,/,1X,'Fragmentation (EVTFRA)', | |
27803 | & ' (not yet used!)',4X,'IRFRAG /NEVT = ',F7.2,/, | |
27804 | & 1X,'Total no. of rej. in DPM-treatment of one event', | |
27805 | & ' (EVENTA)',/,43X,'IREVT /NEVT = ',F7.2,/,1X, | |
27806 | & 'Treatment of final nucleon conf.',10X,'IREXCI(1)/NEVT = ' | |
27807 | & ,F7.2,/,43X,'IREXCI(2)/NEVT = ',F7.2,/,48X, | |
27808 | & 'IREXCI(3) = ',I5,/) | |
27809 | ELSEIF (MCGENE.EQ.2) THEN | |
27810 | WRITE(LOUT,1010) ELOJET | |
27811 | 1010 FORMAT(/,/,1X,'PHOJET-treatment of chain systems above ', | |
27812 | & F4.1,' GeV') | |
27813 | WRITE(LOUT,1011) | |
27814 | 1011 FORMAT(/,1X,'1. chain system statistics - total numbers:',/, | |
27815 | & 30X,'--------------',/,/,12X,'s-s',5X,'d-s',5X,'s-d', | |
27816 | & 5X,'s-v',5X,'d-v',5X,'v-s',5X,'v-d',5X,'v-v') | |
27817 | WRITE(LOUT,1012) ((ICEVTG(I,J),I=1,8),J=0,1), | |
27818 | & (INT(ICCHAI(2,I)/2.0D0),I=1,8), | |
27819 | & (ICEVTG(I,2),I=1,8),(ICEVTG(I,29),I=1,8), | |
27820 | & ((ICEVTG(I,J),I=1,8),J=3,7), | |
27821 | & ((ICEVTG(I,J),I=1,8),J=19,21), | |
27822 | & (ICEVTG(I,8),I=1,8), | |
27823 | & ((ICEVTG(I,J),I=1,8),J=22,24), | |
27824 | & (ICEVTG(I,9),I=1,8), | |
27825 | & ((ICEVTG(I,J),I=1,8),J=25,28), | |
27826 | & ((ICEVTG(I,J),I=1,8),J=10,18) | |
27827 | 1012 FORMAT(/,1X,'req.to.',8I8,/,/,1X,'low rq.',8I8,/,1X,'low ac.', | |
27828 | & 8I8,/,/,1X,'PHOJET ',8I8,/,' sngl ',8I8,/,/, | |
27829 | & ' no-dif.',8I8,/, | |
27830 | & ' el-sca.',8I8,/,' qel-sc.',8I8,/,' dbl-Po.',8I8,/, | |
27831 | & ' diff-1 ',8I8,/,' low ',8I8,/,' high ',8I8,/, | |
27832 | & ' h-diff',8I8,/,' diff-2 ',8I8,/,' low ',8I8,/, | |
27833 | & ' high ',8I8,/,' h-diff',8I8,/,' dbl-di.',8I8,/, | |
27834 | & ' lo-lo ',8I8,/,' hi-hi ',8I8,/,' lo-hi ',8I8,/, | |
27835 | & ' hi-lo ',8I8,/, | |
27836 | & ' dir-ga.',8I8,/,/,' dir-1 ',8I8,/,' dir-2 ',8I8,/, | |
27837 | & ' dbl-dir',8I8,/,' s-Pom. ',8I8,/,' h-Pom. ',8I8,/, | |
27838 | & ' s-Reg. ',8I8,/,' enh-trg',8I8,/,' enh-log',8I8) | |
27839 | WRITE(LOUT,1013) | |
27840 | 1013 FORMAT(/,1X,'2. chain system statistics -', | |
27841 | & ' mean numbers per evt:',/,30X,'---------------------', | |
27842 | & /,/,16X,'s-s',7X,'d-s',7X,'s-d') | |
27843 | WRITE(LOUT,1014) | |
27844 | & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=0,1), | |
27845 | & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=1,3), | |
27846 | & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=2,18) | |
27847 | 1014 FORMAT(/,1X,'req.to. ',3E10.2,/,/,1X,'low rq. ',3E10.2,/, | |
27848 | & 1X,'low ac. ',3E10.2,/,/,1X,'PHOJET ',3E10.2,/,/, | |
27849 | & ' no-dif. ',3E10.2,/,' el-sca. ',3E10.2,/, | |
27850 | & ' qel-sc. ',3E10.2,/,' dbl-Po. ',3E10.2,/, | |
27851 | & ' diff-1 ',3E10.2,/,' diff-2 ',3E10.2,/, | |
27852 | & ' dbl-di. ',3E10.2,/,' dir-ga. ',3E10.2,/,/, | |
27853 | & ' dir-1 ',3E10.2,/,' dir-2 ',3E10.2,/, | |
27854 | & ' dbl-dir ',3E10.2,/,' s-Pom. ',3E10.2,/, | |
27855 | & ' h-Pom. ',3E10.2,/,' s-Reg. ',3E10.2,/, | |
27856 | & ' enh-trg ',3E10.2,/,' enh-log ',3E10.2) | |
27857 | WRITE(LOUT,1015) | |
27858 | 1015 FORMAT(/,16X,'s-v',7X,'d-v',7X,'v-s',7X,'v-d',7X,'v-v') | |
27859 | WRITE(LOUT,1016) | |
27860 | & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=0,1), | |
27861 | & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=4,8), | |
27862 | & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=2,18) | |
27863 | 1016 FORMAT(/,1X,'req.to. ',5E10.2,/,/,1X,'low rq. ',5E10.2,/, | |
27864 | & 1X,'low ac. ',5E10.2,/,/,1X,'PHOJET ',5E10.2,/,/, | |
27865 | & ' no-dif. ',5E10.2,/,' el-sca. ',5E10.2,/, | |
27866 | & ' qel-sc. ',5E10.2,/,' dbl-Po. ',5E10.2,/, | |
27867 | & ' diff-1 ',5E10.2,/,' diff-2 ',5E10.2,/, | |
27868 | & ' dbl-di. ',5E10.2,/,' dir-ga. ',5E10.2,/,/, | |
27869 | & ' dir-1 ',5E10.2,/,' dir-2 ',5E10.2,/, | |
27870 | & ' dbl-dir ',5E10.2,/,' s-Pom. ',5E10.2,/, | |
27871 | & ' h-Pom. ',5E10.2,/,' s-Reg. ',5E10.2,/, | |
27872 | & ' enh-trg ',5E10.2,/,' enh-log ',5E10.2) | |
27873 | ||
27874 | ENDIF | |
27875 | CALL DT_CHASTA(1) | |
27876 | ||
27877 | IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0) | |
27878 | & .OR.(PDBSEA(3).GT.0.0D0)) THEN | |
27879 | WRITE(LOUT,*)'YGS1S,YGS2S,YUS1S,YUS2S', | |
27880 | & DBRKA(1,1)+DBRKA(2,1),DBRKA(1,2)+DBRKA(2,2), | |
27881 | & DBRKA(1,3)+DBRKA(2,3),DBRKA(1,4)+DBRKA(2,4) | |
27882 | WRITE(LOUT,*)'YGS1R,YGS2R,YUS1R,YUS2R', | |
27883 | & DBRKR(1,1)+DBRKR(2,1),DBRKR(1,2)+DBRKR(2,2), | |
27884 | & DBRKR(1,3)+DBRKR(2,3),DBRKR(1,4)+DBRKR(2,4) | |
27885 | WRITE(LOUT,*)'YGSA1S,YGSA2S,YUSA1S,YUSA2S', | |
27886 | & DBRKA(1,5)+DBRKA(2,5),DBRKA(1,6)+DBRKA(2,6), | |
27887 | & DBRKA(1,7)+DBRKA(2,7),DBRKA(1,8)+DBRKA(2,8) | |
27888 | WRITE(LOUT,*)'YGSA1R,YGSA2R,YUSA1R,YUSA2R', | |
27889 | & DBRKR(1,5)+DBRKR(2,5),DBRKR(1,6)+DBRKR(2,6), | |
27890 | & DBRKR(1,7)+DBRKR(2,7),DBRKR(1,8)+DBRKR(2,8) | |
27891 | WRITE(LOUT,*)'YG31S,YG32S,YU31S,YU32S', | |
27892 | & DBRKA(3,1),DBRKA(3,2), | |
27893 | & DBRKA(3,3),DBRKA(3,4) | |
27894 | WRITE(LOUT,*)'YG31R,YG32R,YU31R,YU32R', | |
27895 | & DBRKR(3,1),DBRKR(3,2), | |
27896 | & DBRKR(3,3),DBRKR(3,4) | |
27897 | WRITE(LOUT,*)'YG3A1S,YG3A2S,YU3A1S,YU3A2S', | |
27898 | & DBRKA(3,5),DBRKA(3,6), | |
27899 | & DBRKA(3,7),DBRKA(3,8) | |
27900 | WRITE(LOUT,*)'YG3A1R,YG3A2R,YU3A1R,YU3A2R', | |
27901 | & DBRKR(3,5),DBRKR(3,6), | |
27902 | & DBRKR(3,7),DBRKR(3,8) | |
27903 | ENDIF | |
27904 | ||
27905 | FAC = 1.0D0 | |
27906 | IF (MCGENE.EQ.2) THEN | |
27907 | C CALL PHO_PHIST(-2,SIGMAX) | |
27908 | CALL PHO_EVENT(-2,PP,PT,FAC,IREJ1) | |
27909 | ENDIF | |
27910 | ||
27911 | CALL DT_XTIME | |
27912 | ||
27913 | RETURN | |
27914 | END | |
27915 | ||
27916 | *$ CREATE DT_EVTOUT.FOR | |
27917 | *COPY DT_EVTOUT | |
27918 | * | |
27919 | *===evtout=============================================================* | |
27920 | * | |
27921 | SUBROUTINE DT_EVTOUT(MODE) | |
27922 | ||
27923 | ************************************************************************ | |
27924 | * MODE = 1 plot content of complete DTEVT1 to out. unit * | |
27925 | * 3 plot entries of extended DTEVT1 (DTEVT2) * | |
27926 | * 4 plot entries of DTEVT1 and DTEVT2 * | |
27927 | * This version dated 11.12.94 is written by S. Roesler * | |
27928 | ************************************************************************ | |
27929 | ||
27930 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27931 | SAVE | |
27932 | PARAMETER ( LINP = 10 , | |
27933 | & LOUT = 6 , | |
27934 | & LDAT = 9 ) | |
27935 | * event history | |
27936 | PARAMETER (NMXHKK=200000) | |
27937 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
27938 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
27939 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
27940 | ||
27941 | DIMENSION IRANGE(NMXHKK) | |
27942 | ||
27943 | IF (MODE.EQ.2) RETURN | |
27944 | ||
27945 | CALL DT_EVTPLO(IRANGE,MODE) | |
27946 | ||
27947 | RETURN | |
27948 | END | |
27949 | ||
27950 | *$ CREATE DT_EVTPLO.FOR | |
27951 | *COPY DT_EVTPLO | |
27952 | * | |
27953 | *===evtplo=============================================================* | |
27954 | * | |
27955 | SUBROUTINE DT_EVTPLO(IRANGE,MODE) | |
27956 | ||
27957 | ************************************************************************ | |
27958 | * MODE = 1 plot content of complete DTEVT1 to out. unit * | |
27959 | * 2 plot entries of DTEVT1 given by IRANGE * | |
27960 | * 3 plot entries of extended DTEVT1 (DTEVT2) * | |
27961 | * 4 plot entries of DTEVT1 and DTEVT2 * | |
27962 | * 5 plot rejection counter * | |
27963 | * This version dated 11.12.94 is written by S. Roesler * | |
27964 | ************************************************************************ | |
27965 | ||
27966 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
27967 | SAVE | |
27968 | PARAMETER ( LINP = 10 , | |
27969 | & LOUT = 6 , | |
27970 | & LDAT = 9 ) | |
27971 | ||
27972 | CHARACTER*16 CHAU | |
27973 | ||
27974 | * event history | |
27975 | PARAMETER (NMXHKK=200000) | |
27976 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
27977 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
27978 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
27979 | * extended event history | |
27980 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
27981 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
27982 | & IHIST(2,NMXHKK) | |
27983 | * rejection counter | |
27984 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
27985 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
27986 | & IREXCI(3),IRDIFF(2),IRINC | |
27987 | ||
27988 | DIMENSION IRANGE(NMXHKK) | |
27989 | ||
27990 | IF ((MODE.EQ.1).OR.(MODE.EQ.4)) THEN | |
27991 | WRITE(LOUT,1000) | |
27992 | 1000 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTEVT1/',/, | |
27993 | & 15X,' --------------------------',/,/, | |
27994 | & ' ST ID M1 M2 D1 D2 PX PY', | |
27995 | & ' PZ E M',/) | |
27996 | DO 1 I=1,NHKK | |
27997 | WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I), | |
27998 | & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I), | |
27999 | & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I), | |
28000 | & PHKK(5,I) | |
28001 | C WRITE(LOUT,1011) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I), | |
28002 | C & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I), | |
28003 | C & PHKK(3,I),PHKK(4,I) | |
28004 | C WRITE(LOUT,'(4E15.4)') | |
28005 | C & VHKK(1,I),VHKK(2,I),VHKK(3,I),VHKK(4,I) | |
28006 | 1001 FORMAT(I5,I5,I6,4I5,3F7.3,F8.3,F8.4) | |
28007 | 1011 FORMAT(I5,I5,I6,4I5,2E15.5) | |
28008 | 1 CONTINUE | |
28009 | WRITE(LOUT,*) | |
28010 | C DO 4 I=1,NHKK | |
28011 | C WRITE(LOUT,1006) I,ISTHKK(I), | |
28012 | C & VHKK(1,I),VHKK(2,I),VHKK(3,I),WHKK(1,I), | |
28013 | C & WHKK(2,I),WHKK(3,I) | |
28014 | C1006 FORMAT(1X,I4,I6,6E10.3) | |
28015 | C 4 CONTINUE | |
28016 | ENDIF | |
28017 | ||
28018 | IF (MODE.EQ.2) THEN | |
28019 | WRITE(LOUT,1000) | |
28020 | NC = 0 | |
28021 | 2 CONTINUE | |
28022 | NC = NC+1 | |
28023 | IF (IRANGE(NC).EQ.-100) GOTO 9999 | |
28024 | I = IRANGE(NC) | |
28025 | WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I), | |
28026 | & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I), | |
28027 | & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I), | |
28028 | & PHKK(5,I) | |
28029 | GOTO 2 | |
28030 | ENDIF | |
28031 | ||
28032 | IF ((MODE.EQ.3).OR.(MODE.EQ.4)) THEN | |
28033 | WRITE(LOUT,1002) | |
28034 | 1002 FORMAT(/,1X,'EVTPLO:',14X, | |
28035 | & ' content of COMMON /DTEVT1/,/DTEVT2/',/, | |
28036 | & 15X,' -----------------------------------',/,/, | |
28037 | & ' ST ID M1 M2 D1 D2 IDR IDXR', | |
28038 | & ' NOBAM IDCH M',/) | |
28039 | DO 3 I=1,NHKK | |
28040 | C IF ((ISTHKK(I).GT.10).OR.(ISTHKK(I).EQ.1)) THEN | |
28041 | KF = IDHKK(I) | |
28042 | IDCHK = KF/10000 | |
28043 | IF ((((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND. | |
28044 | & (KF.NE.80000)).OR.(IDHKK(I).EQ.99999)) KF = 92 | |
28045 | CALL PYNAME(KF,CHAU) | |
28046 | WRITE(LOUT,1003) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I), | |
28047 | & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I), | |
28048 | & IDRES(I),IDXRES(I),NOBAM(I),IDCH(I), | |
28049 | & PHKK(5,I),CHAU | |
28050 | 1003 FORMAT(I5,I5,I6,4I5,4I4,F8.4,2X,A) | |
28051 | C ENDIF | |
28052 | 3 CONTINUE | |
28053 | ENDIF | |
28054 | ||
28055 | IF (MODE.EQ.5) THEN | |
28056 | WRITE(LOUT,1004) | |
28057 | 1004 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTREJC/',/, | |
28058 | & 15X,' --------------------------',/) | |
28059 | WRITE(LOUT,1005) IRPT,IRHHA,IRRES,LOMRES,LOBRES,IREMC,IRFRAG, | |
28060 | & IRSEA,IRCRON | |
28061 | 1005 FORMAT(1X,'IRPT = ',I5,' IRHHA = ',I5,/, | |
28062 | & 1X,'IRRES = ',2I5,' LOMRES = ',I5,' LOBRES = ',I5,/, | |
28063 | & 1X,'IREMC = ',10I5,/, | |
28064 | & 1X,'IRFRAG = ',I5,' IRSEA = ',I5,' IRCRON = ',I5,/) | |
28065 | ENDIF | |
28066 | ||
28067 | 9999 RETURN | |
28068 | END | |
28069 | ||
28070 | *$ CREATE DT_EVTPUT.FOR | |
28071 | *COPY DT_EVTPUT | |
28072 | * | |
28073 | *===evtput=============================================================* | |
28074 | * | |
28075 | SUBROUTINE DT_EVTPUT(IST,ID,M1,M2,PX,PY,PZ,E,IDR,IDXR,IDC) | |
28076 | ||
28077 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
28078 | SAVE | |
28079 | PARAMETER ( LINP = 10 , | |
28080 | & LOUT = 6 , | |
28081 | & LDAT = 9 ) | |
28082 | PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,TINY3=1.0D-3, | |
28083 | & TINY2=1.0D-2,SQTINF=1.0D+15,ZERO=0.0D0) | |
28084 | ||
28085 | * event history | |
28086 | PARAMETER (NMXHKK=200000) | |
28087 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
28088 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
28089 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
28090 | * extended event history | |
28091 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
28092 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
28093 | & IHIST(2,NMXHKK) | |
28094 | * Lorentz-parameters of the current interaction | |
28095 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
28096 | & UMO,PPCM,EPROJ,PPROJ | |
28097 | * particle properties (BAMJET index convention) | |
28098 | CHARACTER*8 ANAME | |
28099 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
28100 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
28101 | ||
28102 | C IF (MODE.GT.100) THEN | |
28103 | C WRITE(LOUT,'(1X,A,I5,A,I5)') | |
28104 | C & 'EVTPUT: reset NHKK = ',NHKK,' to NHKK =',NHKK-MODE+100 | |
28105 | C NHKK = NHKK-MODE+100 | |
28106 | C RETURN | |
28107 | C ENDIF | |
28108 | MO1 = M1 | |
28109 | MO2 = M2 | |
28110 | NHKK = NHKK+1 | |
28111 | ||
28112 | IF (NHKK.GT.NMXHKK) THEN | |
28113 | WRITE(LOUT,1000) NHKK | |
28114 | 1000 FORMAT(1X,'EVTPUT: NHKK exeeds NMXHKK = ',I7, | |
28115 | & '! program execution stopped..') | |
28116 | STOP | |
28117 | ENDIF | |
28118 | IF (M1.LT.0) MO1 = NHKK+M1 | |
28119 | IF (M2.LT.0) MO2 = NHKK+M2 | |
28120 | ISTHKK(NHKK) = IST | |
28121 | IDHKK(NHKK) = ID | |
28122 | JMOHKK(1,NHKK) = MO1 | |
28123 | JMOHKK(2,NHKK) = MO2 | |
28124 | JDAHKK(1,NHKK) = 0 | |
28125 | JDAHKK(2,NHKK) = 0 | |
28126 | IDRES(NHKK) = IDR | |
28127 | IDXRES(NHKK) = IDXR | |
28128 | IDCH(NHKK) = IDC | |
28129 | ** here we need to do something.. | |
28130 | IF (ID.EQ.88888) THEN | |
28131 | IDMO1 = ABS(IDHKK(MO1)) | |
28132 | IDMO2 = ABS(IDHKK(MO2)) | |
28133 | IF ((IDMO1.LT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 3 | |
28134 | IF ((IDMO1.LT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 4 | |
28135 | IF ((IDMO1.GT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 5 | |
28136 | IF ((IDMO1.GT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 6 | |
28137 | ELSE | |
28138 | NOBAM(NHKK) = 0 | |
28139 | ENDIF | |
28140 | IDBAM(NHKK) = IDT_ICIHAD(ID) | |
28141 | IF (MO1.GT.0) THEN | |
28142 | IF (JDAHKK(1,MO1).NE.0) THEN | |
28143 | JDAHKK(2,MO1) = NHKK | |
28144 | ELSE | |
28145 | JDAHKK(1,MO1) = NHKK | |
28146 | ENDIF | |
28147 | ENDIF | |
28148 | IF (MO2.GT.0) THEN | |
28149 | IF (JDAHKK(1,MO2).NE.0) THEN | |
28150 | JDAHKK(2,MO2) = NHKK | |
28151 | ELSE | |
28152 | JDAHKK(1,MO2) = NHKK | |
28153 | ENDIF | |
28154 | ENDIF | |
28155 | C IF ((IDBAM(NHKK).GT.0).AND.(IDBAM(NHKK).NE.7)) THEN | |
28156 | C PTOT = SQRT(PX**2+PY**2+PZ**2) | |
28157 | C AM0 = SQRT(ABS( (E-PTOT)*(E+PTOT) )) | |
28158 | C AMRQ = AAM(IDBAM(NHKK)) | |
28159 | C AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ) | |
28160 | C IF ((ABS(AMDIF2).GT.TINY3).AND.(E.LT.SQTINF).AND. | |
28161 | C & (PTOT.GT.ZERO)) THEN | |
28162 | C DELTA = -AMDIF2/(2.0D0*(E+PTOT)) | |
28163 | CC DELTA = (AMRQ2-AM2)/(2.0D0*(E+PTOT)) | |
28164 | C E = E+DELTA | |
28165 | C PTOT1 = PTOT-DELTA | |
28166 | C PX = PX*PTOT1/PTOT | |
28167 | C PY = PY*PTOT1/PTOT | |
28168 | C PZ = PZ*PTOT1/PTOT | |
28169 | C ENDIF | |
28170 | C ENDIF | |
28171 | PHKK(1,NHKK) = PX | |
28172 | PHKK(2,NHKK) = PY | |
28173 | PHKK(3,NHKK) = PZ | |
28174 | PHKK(4,NHKK) = E | |
28175 | PTOT = SQRT( PX**2+PY**2+PZ**2 ) | |
28176 | IF ((IDHKK(NHKK).GE.22).AND.(IDHKK(NHKK).LE.24)) THEN | |
28177 | PHKK(5,NHKK) = PHKK(4,NHKK)**2-PTOT**2 | |
28178 | PHKK(5,NHKK) = SIGN(SQRT(ABS(PHKK(5,NHKK))),PHKK(5,NHKK)) | |
28179 | ELSE | |
28180 | PHKK(5,NHKK) = (PHKK(4,NHKK)-PTOT)*(PHKK(4,NHKK)+PTOT) | |
28181 | C IF ((PHKK(5,NHKK).LT.0.0D0).AND.(ABS(PHKK(5,NHKK)).GT.TINY4)) | |
28182 | C & WRITE(LOUT,'(1X,A,G10.3)') | |
28183 | C & 'EVTPUT: negative mass**2 ',PHKK(5,NHKK) | |
28184 | PHKK(5,NHKK) = SQRT(ABS(PHKK(5,NHKK))) | |
28185 | ENDIF | |
28186 | IDCHK = ID/10000 | |
28187 | IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.(ID.NE.80000)) THEN | |
28188 | * special treatment for chains: | |
28189 | * z coordinate of chain in Lab = pos. of target nucleon | |
28190 | * time of chain-creation in Lab = time of passage of projectile | |
28191 | * nucleus at pos. of taget nucleus | |
28192 | C VHKK(1,NHKK) = 0.5D0*(VHKK(1,MO1)+VHKK(1,MO2)) | |
28193 | C VHKK(2,NHKK) = 0.5D0*(VHKK(2,MO1)+VHKK(2,MO2)) | |
28194 | VHKK(1,NHKK) = VHKK(1,MO2) | |
28195 | VHKK(2,NHKK) = VHKK(2,MO2) | |
28196 | VHKK(3,NHKK) = VHKK(3,MO2) | |
28197 | VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB | |
28198 | C WHKK(1,NHKK) = 0.5D0*(WHKK(1,MO1)+WHKK(1,MO2)) | |
28199 | C WHKK(2,NHKK) = 0.5D0*(WHKK(2,MO1)+WHKK(2,MO2)) | |
28200 | WHKK(1,NHKK) = WHKK(1,MO1) | |
28201 | WHKK(2,NHKK) = WHKK(2,MO1) | |
28202 | WHKK(3,NHKK) = WHKK(3,MO1) | |
28203 | WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB | |
28204 | ELSE | |
28205 | IF (MO1.GT.0) THEN | |
28206 | DO 1 I=1,4 | |
28207 | VHKK(I,NHKK) = VHKK(I,MO1) | |
28208 | WHKK(I,NHKK) = WHKK(I,MO1) | |
28209 | 1 CONTINUE | |
28210 | ELSE | |
28211 | DO 2 I=1,4 | |
28212 | VHKK(I,NHKK) = ZERO | |
28213 | WHKK(I,NHKK) = ZERO | |
28214 | 2 CONTINUE | |
28215 | ENDIF | |
28216 | ENDIF | |
28217 | ||
28218 | RETURN | |
28219 | END | |
28220 | ||
28221 | *$ CREATE DT_CHASTA.FOR | |
28222 | *COPY DT_CHASTA | |
28223 | * | |
28224 | *===chasta=============================================================* | |
28225 | * | |
28226 | SUBROUTINE DT_CHASTA(MODE) | |
28227 | ||
28228 | ************************************************************************ | |
28229 | * This subroutine performs CHAin STAtistics and checks sequence of * | |
28230 | * partons in dtevt1 and sorts them with projectile partons coming * | |
28231 | * first if necessary. * | |
28232 | * * | |
28233 | * This version dated 8.5.00 is written by S. Roesler. * | |
28234 | ************************************************************************ | |
28235 | ||
28236 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
28237 | SAVE | |
28238 | PARAMETER ( LINP = 10 , | |
28239 | & LOUT = 6 , | |
28240 | & LDAT = 9 ) | |
28241 | ||
28242 | CHARACTER*5 CCHTYP | |
28243 | ||
28244 | * event history | |
28245 | PARAMETER (NMXHKK=200000) | |
28246 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
28247 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
28248 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
28249 | * extended event history | |
28250 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
28251 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
28252 | & IHIST(2,NMXHKK) | |
28253 | * pointer to chains in hkkevt common (used by qq-breaking mechanisms) | |
28254 | PARAMETER (MAXCHN=10000) | |
28255 | COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN | |
28256 | ||
28257 | DIMENSION ICHCFG(10,10,9,2),ICHTYP(5,5), | |
28258 | & CCHTYP(9),ICHSTA(10),ITOT(10) | |
28259 | DATA ICHCFG /1800*0/ | |
28260 | DATA (ICHTYP(1,K),K=1,5) / 0, 1, 3, 0, 0/ | |
28261 | DATA (ICHTYP(2,K),K=1,5) / 2, 0, 0, 5, 0/ | |
28262 | DATA (ICHTYP(3,K),K=1,5) / 4, 0, 0, 7, 0/ | |
28263 | DATA (ICHTYP(4,K),K=1,5) / 0, 6, 8, 0, 0/ | |
28264 | DATA (ICHTYP(5,K),K=1,5) / 0, 0, 0, 0, 9/ | |
28265 | DATA ICHSTA / 21, 22, 31, 32, 41, 42, 51, 52, 61, 62/ | |
28266 | DATA CCHTYP / ' q aq','aq q ',' q d ',' d q ','aq ad', | |
28267 | & 'ad aq',' d ad','ad d ',' g g '/ | |
28268 | * | |
28269 | * initialization | |
28270 | * | |
28271 | IF (MODE.EQ.-1) THEN | |
28272 | NCHAIN = 0 | |
28273 | * | |
28274 | * loop over DTEVT1 and analyse chain configurations | |
28275 | * | |
28276 | ELSEIF (MODE.EQ.0) THEN | |
28277 | DO 21 IDX=NPOINT(3),NHKK | |
28278 | IDCHK = IDHKK(IDX)/10000 | |
28279 | IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND. | |
28280 | & (IDHKK(IDX).NE.80000).AND. | |
28281 | & (ISTHKK(IDX).NE.2).AND.(IDRES(IDX).EQ.0)) THEN | |
28282 | IF (JMOHKK(1,IDX).GT.JMOHKK(2,IDX)) THEN | |
28283 | WRITE(LOUT,*) ' CHASTA: JMOHKK(1,x) > JMOHKK(2,x) ', | |
28284 | & ' at entry ',IDX | |
28285 | GOTO 21 | |
28286 | ENDIF | |
28287 | * | |
28288 | IST1 = ABS(ISTHKK(JMOHKK(1,IDX))) | |
28289 | IST2 = ABS(ISTHKK(JMOHKK(2,IDX))) | |
28290 | IMO1 = IST1/10 | |
28291 | IMO1 = IST1-10*IMO1 | |
28292 | IMO2 = IST2/10 | |
28293 | IMO2 = IST2-10*IMO2 | |
28294 | * swop parton entries if necessary since we need projectile partons | |
28295 | * to come first in the common | |
28296 | IF (IMO1.GT.IMO2) THEN | |
28297 | NPTN = JMOHKK(2,IDX)-JMOHKK(1,IDX)+1 | |
28298 | DO 22 K=1,NPTN/2 | |
28299 | I0 = JMOHKK(1,IDX)-1+K | |
28300 | I1 = JMOHKK(2,IDX)+1-K | |
28301 | ITMP = ISTHKK(I0) | |
28302 | ISTHKK(I0) = ISTHKK(I1) | |
28303 | ISTHKK(I1) = ITMP | |
28304 | ITMP = IDHKK(I0) | |
28305 | IDHKK(I0) = IDHKK(I1) | |
28306 | IDHKK(I1) = ITMP | |
28307 | IF (JDAHKK(1,JMOHKK(1,I0)).EQ.I0) | |
28308 | & JDAHKK(1,JMOHKK(1,I0)) = I1 | |
28309 | IF (JDAHKK(2,JMOHKK(1,I0)).EQ.I0) | |
28310 | & JDAHKK(2,JMOHKK(1,I0)) = I1 | |
28311 | IF (JDAHKK(1,JMOHKK(2,I0)).EQ.I0) | |
28312 | & JDAHKK(1,JMOHKK(2,I0)) = I1 | |
28313 | IF (JDAHKK(2,JMOHKK(2,I0)).EQ.I0) | |
28314 | & JDAHKK(2,JMOHKK(2,I0)) = I1 | |
28315 | IF (JDAHKK(1,JMOHKK(1,I1)).EQ.I1) | |
28316 | & JDAHKK(1,JMOHKK(1,I1)) = I0 | |
28317 | IF (JDAHKK(2,JMOHKK(1,I1)).EQ.I1) | |
28318 | & JDAHKK(2,JMOHKK(1,I1)) = I0 | |
28319 | IF (JDAHKK(1,JMOHKK(2,I1)).EQ.I1) | |
28320 | & JDAHKK(1,JMOHKK(2,I1)) = I0 | |
28321 | IF (JDAHKK(2,JMOHKK(2,I1)).EQ.I1) | |
28322 | & JDAHKK(2,JMOHKK(2,I1)) = I0 | |
28323 | ITMP = JMOHKK(1,I0) | |
28324 | JMOHKK(1,I0) = JMOHKK(1,I1) | |
28325 | JMOHKK(1,I1) = ITMP | |
28326 | ITMP = JMOHKK(2,I0) | |
28327 | JMOHKK(2,I0) = JMOHKK(2,I1) | |
28328 | JMOHKK(2,I1) = ITMP | |
28329 | ITMP = JDAHKK(1,I0) | |
28330 | JDAHKK(1,I0) = JDAHKK(1,I1) | |
28331 | JDAHKK(1,I1) = ITMP | |
28332 | ITMP = JDAHKK(2,I0) | |
28333 | JDAHKK(2,I0) = JDAHKK(2,I1) | |
28334 | JDAHKK(2,I1) = ITMP | |
28335 | DO 23 J=1,4 | |
28336 | RTMP1 = PHKK(J,I0) | |
28337 | RTMP2 = VHKK(J,I0) | |
28338 | RTMP3 = WHKK(J,I0) | |
28339 | PHKK(J,I0) = PHKK(J,I1) | |
28340 | VHKK(J,I0) = VHKK(J,I1) | |
28341 | WHKK(J,I0) = WHKK(J,I1) | |
28342 | PHKK(J,I1) = RTMP1 | |
28343 | VHKK(J,I1) = RTMP2 | |
28344 | WHKK(J,I1) = RTMP3 | |
28345 | 23 CONTINUE | |
28346 | RTMP1 = PHKK(5,I0) | |
28347 | PHKK(5,I0) = PHKK(5,I1) | |
28348 | PHKK(5,I1) = RTMP1 | |
28349 | ITMP = IDRES(I0) | |
28350 | IDRES(I0) = IDRES(I1) | |
28351 | IDRES(I1) = ITMP | |
28352 | ITMP = IDXRES(I0) | |
28353 | IDXRES(I0) = IDXRES(I1) | |
28354 | IDXRES(I1) = ITMP | |
28355 | ITMP = NOBAM(I0) | |
28356 | NOBAM(I0) = NOBAM(I1) | |
28357 | NOBAM(I1) = ITMP | |
28358 | ITMP = IDBAM(I0) | |
28359 | IDBAM(I0) = IDBAM(I1) | |
28360 | IDBAM(I1) = ITMP | |
28361 | ITMP = IDCH(I0) | |
28362 | IDCH(I0) = IDCH(I1) | |
28363 | IDCH(I1) = ITMP | |
28364 | ITMP = IHIST(1,I0) | |
28365 | IHIST(1,I0) = IHIST(1,I1) | |
28366 | IHIST(1,I1) = ITMP | |
28367 | ITMP = IHIST(2,I0) | |
28368 | IHIST(2,I0) = IHIST(2,I1) | |
28369 | IHIST(2,I1) = ITMP | |
28370 | 22 CONTINUE | |
28371 | ENDIF | |
28372 | IST1 = ABS(ISTHKK(JMOHKK(1,IDX))) | |
28373 | IST2 = ABS(ISTHKK(JMOHKK(2,IDX))) | |
28374 | * | |
28375 | * parton 1 (projectile side) | |
28376 | IF (IST1.EQ.21) THEN | |
28377 | IDX1 = 1 | |
28378 | ELSEIF (IST1.EQ.22) THEN | |
28379 | IDX1 = 2 | |
28380 | ELSEIF (IST1.EQ.31) THEN | |
28381 | IDX1 = 3 | |
28382 | ELSEIF (IST1.EQ.32) THEN | |
28383 | IDX1 = 4 | |
28384 | ELSEIF (IST1.EQ.41) THEN | |
28385 | IDX1 = 5 | |
28386 | ELSEIF (IST1.EQ.42) THEN | |
28387 | IDX1 = 6 | |
28388 | ELSEIF (IST1.EQ.51) THEN | |
28389 | IDX1 = 7 | |
28390 | ELSEIF (IST1.EQ.52) THEN | |
28391 | IDX1 = 8 | |
28392 | ELSEIF (IST1.EQ.61) THEN | |
28393 | IDX1 = 9 | |
28394 | ELSEIF (IST1.EQ.62) THEN | |
28395 | IDX1 = 10 | |
28396 | ELSE | |
28397 | c WRITE(LOUT,*) | |
28398 | c & ' CHASTA: unknown parton status flag (', | |
28399 | c & IST1,') at entry ',JMOHKK(1,IDX),'(',IDX,')' | |
28400 | GOTO 21 | |
28401 | ENDIF | |
28402 | ID = IDHKK(JMOHKK(1,IDX)) | |
28403 | IF (ABS(ID).LE.4) THEN | |
28404 | IF (ID.GT.0) THEN | |
28405 | ITYP1 = 1 | |
28406 | ELSE | |
28407 | ITYP1 = 2 | |
28408 | ENDIF | |
28409 | ELSEIF (ABS(ID).GE.1000) THEN | |
28410 | IF (ID.GT.0) THEN | |
28411 | ITYP1 = 3 | |
28412 | ELSE | |
28413 | ITYP1 = 4 | |
28414 | ENDIF | |
28415 | ELSEIF (ID.EQ.21) THEN | |
28416 | ITYP1 = 5 | |
28417 | ELSE | |
28418 | WRITE(LOUT,*) | |
28419 | & ' CHASTA: inconsistent parton identity (', | |
28420 | & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')' | |
28421 | GOTO 21 | |
28422 | ENDIF | |
28423 | * | |
28424 | * parton 2 (target side) | |
28425 | IF (IST2.EQ.21) THEN | |
28426 | IDX2 = 1 | |
28427 | ELSEIF (IST2.EQ.22) THEN | |
28428 | IDX2 = 2 | |
28429 | ELSEIF (IST2.EQ.31) THEN | |
28430 | IDX2 = 3 | |
28431 | ELSEIF (IST2.EQ.32) THEN | |
28432 | IDX2 = 4 | |
28433 | ELSEIF (IST2.EQ.41) THEN | |
28434 | IDX2 = 5 | |
28435 | ELSEIF (IST2.EQ.42) THEN | |
28436 | IDX2 = 6 | |
28437 | ELSEIF (IST2.EQ.51) THEN | |
28438 | IDX2 = 7 | |
28439 | ELSEIF (IST2.EQ.52) THEN | |
28440 | IDX2 = 8 | |
28441 | ELSEIF (IST2.EQ.61) THEN | |
28442 | IDX2 = 9 | |
28443 | ELSEIF (IST2.EQ.62) THEN | |
28444 | IDX2 = 10 | |
28445 | ELSE | |
28446 | c WRITE(LOUT,*) | |
28447 | c & ' CHASTA: unknown parton status flag (', | |
28448 | c & IST2,') at entry ',JMOHKK(2,IDX),'(',IDX,')' | |
28449 | GOTO 21 | |
28450 | ENDIF | |
28451 | ID = IDHKK(JMOHKK(2,IDX)) | |
28452 | IF (ABS(ID).LE.4) THEN | |
28453 | IF (ID.GT.0) THEN | |
28454 | ITYP2 = 1 | |
28455 | ELSE | |
28456 | ITYP2 = 2 | |
28457 | ENDIF | |
28458 | ELSEIF (ABS(ID).GE.1000) THEN | |
28459 | IF (ID.GT.0) THEN | |
28460 | ITYP2 = 3 | |
28461 | ELSE | |
28462 | ITYP2 = 4 | |
28463 | ENDIF | |
28464 | ELSEIF (ID.EQ.21) THEN | |
28465 | ITYP2 = 5 | |
28466 | ELSE | |
28467 | WRITE(LOUT,*) | |
28468 | & ' CHASTA: inconsistent parton identity (', | |
28469 | & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')' | |
28470 | GOTO 21 | |
28471 | ENDIF | |
28472 | * | |
28473 | * fill counter | |
28474 | ITYPE = ICHTYP(ITYP1,ITYP2) | |
28475 | IF (ITYPE.NE.0) THEN | |
28476 | ICHCFG(IDX1,IDX2,ITYPE,1) =ICHCFG(IDX1,IDX2,ITYPE,1)+1 | |
28477 | NGLUON = JMOHKK(2,IDX)-JMOHKK(1,IDX)-1 | |
28478 | ICHCFG(IDX1,IDX2,ITYPE,2) = | |
28479 | & ICHCFG(IDX1,IDX2,ITYPE,2)+NGLUON | |
28480 | ||
28481 | NCHAIN = NCHAIN+1 | |
28482 | IF (NCHAIN.GT.MAXCHN) THEN | |
28483 | WRITE(LOUT,*) ' CHASTA: NCHAIN > MAXCHN ! ', | |
28484 | & NCHAIN,MAXCHN | |
28485 | STOP | |
28486 | ENDIF | |
28487 | IDXCHN(1,NCHAIN) = IDX | |
28488 | IDXCHN(2,NCHAIN) = ITYPE | |
28489 | ELSE | |
28490 | WRITE(LOUT,*) | |
28491 | & ' CHASTA: inconsistent chain at entry ',IDX | |
28492 | GOTO 21 | |
28493 | ENDIF | |
28494 | ENDIF | |
28495 | 21 CONTINUE | |
28496 | * | |
28497 | * write statistics to output unit | |
28498 | * | |
28499 | ELSEIF (MODE.EQ.1) THEN | |
28500 | WRITE(LOUT,'(/,A)') ' CHASTA: generated chain configurations' | |
28501 | DO 31 I=1,10 | |
28502 | WRITE(LOUT,'(/,2A)') | |
28503 | & ' -----------------------------------------', | |
28504 | & '------------------------------------' | |
28505 | WRITE(LOUT,'(2A)') | |
28506 | & ' p\\t 21 22 31 32 41', | |
28507 | & ' 42 51 52 61 62' | |
28508 | WRITE(LOUT,'(2A)') | |
28509 | & ' -----------------------------------------', | |
28510 | & '------------------------------------' | |
28511 | DO 32 J=1,10 | |
28512 | ITOT(J) = 0 | |
28513 | DO 33 K=1,9 | |
28514 | ITOT(J) = ITOT(J)+ICHCFG(I,J,K,1) | |
28515 | 33 CONTINUE | |
28516 | 32 CONTINUE | |
28517 | WRITE(LOUT,'(1X,I2,5X,10I7,/)') ICHSTA(I),(ITOT(J),J=1,10) | |
28518 | DO 34 K=1,9 | |
28519 | ISUM = 0 | |
28520 | DO 35 J=1,10 | |
28521 | ISUM = ISUM+ICHCFG(I,J,K,1) | |
28522 | 35 CONTINUE | |
28523 | IF (ISUM.GT.0) | |
28524 | & WRITE(LOUT,'(1X,A5,2X,10I7)') | |
28525 | & CCHTYP(K),(ICHCFG(I,J,K,1),J=1,10) | |
28526 | 34 CONTINUE | |
28527 | C WRITE(LOUT,'(2A)') | |
28528 | C & ' -----------------------------------------', | |
28529 | C & '-------------------------------' | |
28530 | 31 CONTINUE | |
28531 | * | |
28532 | ELSE | |
28533 | WRITE(LOUT,*) ' CHASTA: MODE ',MODE,' not supported !' | |
28534 | STOP | |
28535 | ENDIF | |
28536 | ||
28537 | RETURN | |
28538 | END | |
28539 | *$ CREATE PHO_PHIST.FOR | |
28540 | *COPY PHO_PHIST | |
28541 | * | |
28542 | *===pohist=============================================================* | |
28543 | * | |
28544 | SUBROUTINE PHO_PHIST(IMODE,WEIGHT) | |
28545 | ||
28546 | IMPLICIT DOUBLE PRECISION (A-H,O-X,Z) | |
28547 | SAVE | |
28548 | ||
28549 | PARAMETER ( LINP = 10 , | |
28550 | & LOUT = 6 , | |
28551 | & LDAT = 9 ) | |
28552 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
28553 | * Glauber formalism: cross sections | |
28554 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
28555 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
28556 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
28557 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
28558 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
28559 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
28560 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
28561 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
28562 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
28563 | & BSLOPE,NEBINI,NQBINI | |
28564 | ||
28565 | ILAB = 0 | |
28566 | IF (IMODE.EQ.10) THEN | |
28567 | IMODE = 1 | |
28568 | ILAB = 1 | |
28569 | ENDIF | |
28570 | IF (ABS(IMODE).LT.1000) THEN | |
28571 | * PHOJET-statistics | |
28572 | C CALL POHISX(IMODE,WEIGHT) | |
28573 | IF (IMODE.EQ.-1) THEN | |
28574 | MODE = 1 | |
28575 | XSTOT(1,1,1) = WEIGHT | |
28576 | ENDIF | |
28577 | IF (IMODE.EQ. 1) MODE = 2 | |
28578 | IF (IMODE.EQ.-2) MODE = 3 | |
28579 | IF (MODE.EQ.2) CALL DT_SWPPHO(ILAB) | |
28580 | C IF (MODE.EQ.3) WRITE(LOUT,*) | |
28581 | C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization' | |
28582 | CALL DT_HISTOG(MODE) | |
28583 | CALL DT_USRHIS(MODE) | |
28584 | ELSE | |
28585 | * DTUNUC-statistics | |
28586 | MODE = IMODE/1000 | |
28587 | C IF (MODE.EQ.3) WRITE(LOUT,*) | |
28588 | C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization' | |
28589 | CALL DT_HISTOG(MODE) | |
28590 | CALL DT_USRHIS(MODE) | |
28591 | ENDIF | |
28592 | ||
28593 | RETURN | |
28594 | END | |
28595 | ||
28596 | *$ CREATE DT_SWPPHO.FOR | |
28597 | *COPY DT_SWPPHO | |
28598 | * | |
28599 | *===swppho=============================================================* | |
28600 | * | |
28601 | SUBROUTINE DT_SWPPHO(ILAB) | |
28602 | ||
28603 | IMPLICIT DOUBLE PRECISION (A-H,O-X,Z) | |
28604 | SAVE | |
28605 | PARAMETER ( LINP = 10 , | |
28606 | & LOUT = 6 , | |
28607 | & LDAT = 9 ) | |
28608 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14) | |
28609 | ||
28610 | LOGICAL LSTART | |
28611 | ||
28612 | * event history | |
28613 | PARAMETER (NMXHKK=200000) | |
28614 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
28615 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
28616 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
28617 | * extended event history | |
28618 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
28619 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
28620 | & IHIST(2,NMXHKK) | |
28621 | * flags for input different options | |
28622 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
28623 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
28624 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
28625 | * properties of photon/lepton projectiles | |
28626 | COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC | |
28627 | ||
28628 | **PHOJET105a | |
28629 | C PARAMETER (NMXHEP=2000) | |
28630 | C COMMON/HEPEVS/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP), | |
28631 | C &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP) | |
28632 | C COMMON /GLOCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2) | |
28633 | C COMMON /PLASAV/ PLAB | |
28634 | **PHOJET110 | |
28635 | C standard particle data interface | |
28636 | INTEGER NMXHEP | |
28637 | PARAMETER (NMXHEP=4000) | |
28638 | INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP | |
28639 | DOUBLE PRECISION PHEP,VHEP | |
28640 | COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP), | |
28641 | & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP), | |
28642 | & VHEP(4,NMXHEP) | |
28643 | C extension to standard particle data interface (PHOJET specific) | |
28644 | INTEGER IMPART,IPHIST,ICOLOR | |
28645 | COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP) | |
28646 | C global event kinematics and particle IDs | |
28647 | INTEGER IFPAP,IFPAB | |
28648 | DOUBLE PRECISION ECM,PCM,PMASS,PVIRT | |
28649 | COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2) | |
28650 | ** | |
28651 | DATA ICOUNT/0/ | |
28652 | ||
28653 | DATA LSTART /.TRUE./ | |
28654 | ||
28655 | C IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0).AND.LSTART) THEN | |
28656 | IF ((IFRAME.EQ.1).AND.LSTART) THEN | |
28657 | UMO = ECM | |
28658 | ELA = ZERO | |
28659 | PLA = ZERO | |
28660 | IDP = IDT_ICIHAD(IFPAP(1)) | |
28661 | IDT = IDT_ICIHAD(IFPAP(2)) | |
28662 | VIRT = PVIRT(1) | |
28663 | CALL DT_LTINI(IDP,IDT,ELA,PLA,UMO,0) | |
28664 | PLAB = PLA | |
28665 | LSTART = .FALSE. | |
28666 | ENDIF | |
28667 | ||
28668 | NHKK = 0 | |
28669 | ICOUNT = ICOUNT+1 | |
28670 | C NEVHKK = NEVHEP | |
28671 | NEVHKK = ICOUNT | |
28672 | IF (MOD(ICOUNT,500).EQ.0) WRITE(LOUT,*)' SWPPHO: event # ',ICOUNT | |
28673 | DO 1 I=3,NHEP | |
28674 | IF (ISTHEP(I).EQ.1) THEN | |
28675 | NHKK = NHKK+1 | |
28676 | ISTHKK(NHKK) = 1 | |
28677 | IDHKK(NHKK) = IDHEP(I) | |
28678 | JMOHKK(1,NHKK) = 0 | |
28679 | JMOHKK(2,NHKK) = 0 | |
28680 | JDAHKK(1,NHKK) = 0 | |
28681 | JDAHKK(2,NHKK) = 0 | |
28682 | DO 2 K=1,4 | |
28683 | PHKK(K,NHKK) = PHEP(K,I) | |
28684 | VHKK(K,NHKK) = ZERO | |
28685 | WHKK(K,NHKK) = ZERO | |
28686 | 2 CONTINUE | |
28687 | IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0)) | |
28688 | & CALL DT_LTNUC(PHEP(3,I),PHEP(4,I), | |
28689 | & PHKK(3,NHKK),PHKK(4,NHKK),-3) | |
28690 | PHKK(5,NHKK) = PHEP(5,I) | |
28691 | IDRES(NHKK) = 0 | |
28692 | IDXRES(NHKK) = 0 | |
28693 | NOBAM(NHKK) = 0 | |
28694 | IDBAM(NHKK) = IDT_ICIHAD(IDHEP(I)) | |
28695 | IDCH(NHKK) = 0 | |
28696 | ENDIF | |
28697 | 1 CONTINUE | |
28698 | ||
28699 | RETURN | |
28700 | END | |
28701 | ||
28702 | *$ CREATE DT_HISTOG.FOR | |
28703 | *COPY DT_HISTOG | |
28704 | * | |
28705 | *===histog=============================================================* | |
28706 | * | |
28707 | SUBROUTINE DT_HISTOG(MODE) | |
28708 | ||
28709 | ************************************************************************ | |
28710 | * This version dated 25.03.96 is written by S. Roesler * | |
28711 | ************************************************************************ | |
28712 | ||
28713 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
28714 | SAVE | |
28715 | PARAMETER ( LINP = 10 , | |
28716 | & LOUT = 6 , | |
28717 | & LDAT = 9 ) | |
28718 | ||
28719 | LOGICAL LFSP,LRNL | |
28720 | ||
28721 | * event history | |
28722 | PARAMETER (NMXHKK=200000) | |
28723 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
28724 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
28725 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
28726 | * extended event history | |
28727 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
28728 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
28729 | & IHIST(2,NMXHKK) | |
28730 | * event flag used for histograms | |
28731 | COMMON /DTNORM/ ICEVT,IEVHKK | |
28732 | * flags for activated histograms | |
28733 | COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL | |
28734 | ||
28735 | IEVHKK = NEVHKK | |
28736 | GOTO (1,2,3) MODE | |
28737 | ||
28738 | *------------------------------------------------------------------ | |
28739 | * initialization | |
28740 | 1 CONTINUE | |
28741 | ICEVT = 0 | |
28742 | IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,1) | |
28743 | IF (IHISPP(2).EQ.1) CALL DT_HIMULT(1) | |
28744 | ||
28745 | RETURN | |
28746 | *------------------------------------------------------------------ | |
28747 | * filling of histogram with event-record | |
28748 | 2 CONTINUE | |
28749 | ICEVT = ICEVT+1 | |
28750 | ||
28751 | DO 20 I=1,NHKK | |
28752 | CALL DT_SWPFSP(I,LFSP,LRNL) | |
28753 | IF (LFSP) THEN | |
28754 | IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,2) | |
28755 | IF (IHISPP(2).EQ.1) CALL DT_HIMULT(2) | |
28756 | ENDIF | |
28757 | IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,5) | |
28758 | 20 CONTINUE | |
28759 | IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,4) | |
28760 | ||
28761 | RETURN | |
28762 | *------------------------------------------------------------------ | |
28763 | * output | |
28764 | 3 CONTINUE | |
28765 | IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,3) | |
28766 | IF (IHISPP(2).EQ.1) CALL DT_HIMULT(3) | |
28767 | ||
28768 | RETURN | |
28769 | END | |
28770 | ||
28771 | *$ CREATE DT_SWPFSP.FOR | |
28772 | *COPY DT_SWPFSP | |
28773 | * | |
28774 | *===swpfsp=============================================================* | |
28775 | * | |
28776 | SUBROUTINE DT_SWPFSP(IDX,LFSP,LRNL) | |
28777 | ||
28778 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
28779 | SAVE | |
28780 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14) | |
28781 | PARAMETER (TWOPI=6.283185307179586476925286766559D+00, | |
28782 | & PI =TWOPI/TWO, | |
28783 | & BOG =TWOPI/360.0D0) | |
28784 | ||
28785 | * event history | |
28786 | PARAMETER (NMXHKK=200000) | |
28787 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
28788 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
28789 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
28790 | * extended event history | |
28791 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
28792 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
28793 | & IHIST(2,NMXHKK) | |
28794 | * particle properties (BAMJET index convention) | |
28795 | CHARACTER*8 ANAME | |
28796 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
28797 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
28798 | * Lorentz-parameters of the current interaction | |
28799 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
28800 | & UMO,PPCM,EPROJ,PPROJ | |
28801 | * flags for input different options | |
28802 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
28803 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
28804 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
28805 | * (original name: PAREVT) | |
28806 | LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX, | |
28807 | & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF | |
28808 | PARAMETER ( NALLWP = 39 ) | |
28809 | COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, | |
28810 | & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY, | |
28811 | & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV, | |
28812 | & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF | |
28813 | * temporary storage for one final state particle | |
28814 | LOGICAL LFRAG,LGREY,LBLACK | |
28815 | COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN, | |
28816 | & SINTHE,COSTHE,THETA,THECMS, | |
28817 | & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF, | |
28818 | & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF, | |
28819 | & LFRAG,LGREY,LBLACK | |
28820 | ||
28821 | LOGICAL LFSP,LRNL | |
28822 | ||
28823 | LFSP = .FALSE. | |
28824 | LRNL = .FALSE. | |
28825 | ISTRNL = 1000 | |
28826 | MULDEF = 1 | |
28827 | IF (LEVPRT) ISTRNL = 1001 | |
28828 | ||
28829 | IF (ABS(ISTHKK(IDX)).EQ.1) THEN | |
28830 | IST = ISTHKK(IDX) | |
28831 | IDPDG = IDHKK(IDX) | |
28832 | LFRAG = .FALSE. | |
28833 | IF (IDHKK(IDX).LT.80000) THEN | |
28834 | IDBJT = IDBAM(IDX) | |
28835 | IBARY = IIBAR(IDBJT) | |
28836 | ICHAR = IICH(IDBJT) | |
28837 | AMASS = AAM(IDBJT) | |
28838 | ELSEIF (IDHKK(IDX).EQ.80000) THEN | |
28839 | IDBJT = 0 | |
28840 | IBARY = IDRES(IDX) | |
28841 | ICHAR = IDXRES(IDX) | |
28842 | AMASS = PHKK(5,IDX) | |
28843 | INUT = IBARY-ICHAR | |
28844 | IF ((ICHAR.EQ.1).AND.(INUT.EQ.1)) IDBJT = 116 | |
28845 | IF ((ICHAR.EQ.1).AND.(INUT.EQ.2)) IDBJT = 117 | |
28846 | IF ((ICHAR.EQ.2).AND.(INUT.EQ.1)) IDBJT = 118 | |
28847 | IF ((ICHAR.EQ.2).AND.(INUT.EQ.2)) IDBJT = 119 | |
28848 | IF (IDBJT.EQ.0) LFRAG = .TRUE. | |
28849 | ELSE | |
28850 | GOTO 9999 | |
28851 | ENDIF | |
28852 | PE = PHKK(4,IDX) | |
28853 | PX = PHKK(1,IDX) | |
28854 | PY = PHKK(2,IDX) | |
28855 | PZ = PHKK(3,IDX) | |
28856 | PT2 = PX**2+PY**2 | |
28857 | PT = SQRT(PT2) | |
28858 | PTOT = SQRT(PT2+PZ**2) | |
28859 | SINTHE = PT/MAX(PTOT,TINY14) | |
28860 | COSTHE = PZ/MAX(PTOT,TINY14) | |
28861 | IF (COSTHE.GT.ONE) THEN | |
28862 | THETA = ZERO | |
28863 | ELSEIF (COSTHE.LT.-ONE) THEN | |
28864 | THETA = TWOPI/2.0D0 | |
28865 | ELSE | |
28866 | THETA = ACOS(COSTHE) | |
28867 | ENDIF | |
28868 | EKIN = PE-AMASS | |
28869 | **sr 15.4.96 new E_t-definition | |
28870 | IF (IBARY.GT.0) THEN | |
28871 | ET = EKIN*SINTHE | |
28872 | ELSEIF (IBARY.LT.0) THEN | |
28873 | ET = (EKIN+TWO*AMASS)*SINTHE | |
28874 | ELSE | |
28875 | ET = PE*SINTHE | |
28876 | ENDIF | |
28877 | ** | |
28878 | XLAB = PZ/MAX(PPROJ,TINY14) | |
28879 | C XLAB = PE/MAX(EPROJ,TINY14) | |
28880 | BETA = SQRT(ABS( (ONE-AMASS/MAX(PE,TINY14)) | |
28881 | & *(ONE+AMASS/MAX(PE,TINY14)) )) | |
28882 | PPLUS = PE+PZ | |
28883 | PMINUS = PE-PZ | |
28884 | IF (PMINUS.GT.TINY14) THEN | |
28885 | YY = 0.5D0*LOG(ABS(PPLUS/PMINUS)) | |
28886 | ELSE | |
28887 | YY = 100.0D0 | |
28888 | ENDIF | |
28889 | IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN | |
28890 | ETA = -LOG(TAN(THETA/TWO)) | |
28891 | ELSE | |
28892 | ETA = 100.0D0 | |
28893 | ENDIF | |
28894 | IF (IFRAME.EQ.1) THEN | |
28895 | CALL DT_LTNUC(PZ,PE,PZCMS,EECMS,3) | |
28896 | PPLUS = EECMS+PZCMS | |
28897 | PMINUS = EECMS-PZCMS | |
28898 | IF ((PPLUS*PMINUS).GT.TINY14) THEN | |
28899 | YYCMS = 0.5D0*LOG(ABS(PPLUS/PMINUS)) | |
28900 | ELSE | |
28901 | YYCMS = 100.0D0 | |
28902 | ENDIF | |
28903 | PTOTCM = SQRT(PT2+PZCMS**2) | |
28904 | COSTH = PZCMS/MAX(PTOTCM,TINY14) | |
28905 | IF (COSTH.GT.ONE) THEN | |
28906 | THECMS = ZERO | |
28907 | ELSEIF (COSTH.LT.-ONE) THEN | |
28908 | THECMS = TWOPI/2.0D0 | |
28909 | ELSE | |
28910 | THECMS = ACOS(COSTH) | |
28911 | ENDIF | |
28912 | IF ((THECMS.GT.TINY14).AND.((PI-THECMS).GT.TINY14)) THEN | |
28913 | ETACMS = -LOG(TAN(THECMS/TWO)) | |
28914 | ELSE | |
28915 | ETACMS = 100.0D0 | |
28916 | ENDIF | |
28917 | XF = PZCMS/MAX(PPCM,TINY14) | |
28918 | THECMS = THECMS/BOG | |
28919 | ELSE | |
28920 | PZCMS = PZ | |
28921 | EECMS = PE | |
28922 | YYCMS = YY | |
28923 | ETACMS = ETA | |
28924 | XF = XLAB | |
28925 | THECMS = THETA/BOG | |
28926 | ENDIF | |
28927 | THETA = THETA/BOG | |
28928 | ||
28929 | * set flag for "grey/black" | |
28930 | LGREY = .FALSE. | |
28931 | LBLACK = .FALSE. | |
28932 | EK = EKIN | |
28933 | IF (IDHKK(IDX).EQ.80000) EK = EKIN/DBLE(IBARY) | |
28934 | IF (MULDEF.EQ.1) THEN | |
28935 | * EMU01-Def. | |
28936 | IF ( ( (IDBJT.EQ. 1).AND.(EK.GT. 26.0D-3).AND. | |
28937 | & (EK.LE.375.0D-3) ).OR. | |
28938 | & ( (IDBJT.EQ.13).AND.(EK.GT. 12.0D-3).AND. | |
28939 | & (EK.LE. 56.0D-3) ).OR. | |
28940 | & ( (IDBJT.EQ.14).AND.(EK.GT. 12.0D-3).AND. | |
28941 | & (EK.LE. 56.0D-3) ).OR. | |
28942 | & ( (IDBJT.EQ.15).AND.(EK.GT. 20.0D-3).AND. | |
28943 | & (EK.LE.198.0D-3) ).OR. | |
28944 | & ( (IDBJT.EQ.16).AND.(EK.GT. 20.0D-3).AND. | |
28945 | & (EK.LE.198.0D-3) ).OR. | |
28946 | & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND. | |
28947 | & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND. | |
28948 | & (IDBJT.NE.16).AND. | |
28949 | & (BETA.GT.0.23D0).AND.(BETA.LE.0.70D0) ) ) | |
28950 | & LGREY = .TRUE. | |
28951 | IF ( ( (IDBJT.EQ. 1).AND.(EK.LE. 26.0D-3) ).OR. | |
28952 | & ( (IDBJT.EQ.13).AND.(EK.LE. 12.0D-3) ).OR. | |
28953 | & ( (IDBJT.EQ.14).AND.(EK.LE. 12.0D-3) ).OR. | |
28954 | & ( (IDBJT.EQ.15).AND.(EK.LE. 20.0D-3) ).OR. | |
28955 | & ( (IDBJT.EQ.16).AND.(EK.LE. 20.0D-3) ).OR. | |
28956 | & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND. | |
28957 | & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND. | |
28958 | & (IDBJT.NE.16).AND.(BETA.LE.0.23D0) ) ) | |
28959 | & LBLACK = .TRUE. | |
28960 | ELSE | |
28961 | * common Def. | |
28962 | IF ((BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)) LGREY=.TRUE. | |
28963 | IF (BETA.LE.0.23D0) LBLACK=.TRUE. | |
28964 | ENDIF | |
28965 | LFSP = .TRUE. | |
28966 | ELSEIF (ABS(ISTHKK(IDX)).EQ.ISTRNL) THEN | |
28967 | IST = ISTHKK(IDX) | |
28968 | IDPDG = IDHKK(IDX) | |
28969 | LFRAG = .TRUE. | |
28970 | IDBJT = 0 | |
28971 | IBARY = IDRES(IDX) | |
28972 | ICHAR = IDXRES(IDX) | |
28973 | AMASS = PHKK(5,IDX) | |
28974 | PE = PHKK(4,IDX) | |
28975 | PX = PHKK(1,IDX) | |
28976 | PY = PHKK(2,IDX) | |
28977 | PZ = PHKK(3,IDX) | |
28978 | PT2 = PX**2+PY**2 | |
28979 | PT = SQRT(PT2) | |
28980 | PTOT = SQRT(PT2+PZ**2) | |
28981 | SINTHE = PT/MAX(PTOT,TINY14) | |
28982 | COSTHE = PZ/MAX(PTOT,TINY14) | |
28983 | IF (COSTHE.GT.ONE) THEN | |
28984 | THETA = ZERO | |
28985 | ELSEIF (COSTHE.LT.-ONE) THEN | |
28986 | THETA = TWOPI/2.0D0 | |
28987 | ELSE | |
28988 | THETA = ACOS(COSTHE) | |
28989 | ENDIF | |
28990 | EKIN = PE-AMASS | |
28991 | **sr 15.4.96 new E_t-definition | |
28992 | C ET = PE*SINTHE | |
28993 | ET = EKIN*SINTHE | |
28994 | ** | |
28995 | IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN | |
28996 | ETA = -LOG(TAN(THETA/TWO)) | |
28997 | ELSE | |
28998 | ETA = 100.0D0 | |
28999 | ENDIF | |
29000 | THETA = THETA/BOG | |
29001 | LRNL = .TRUE. | |
29002 | ENDIF | |
29003 | ||
29004 | 9999 CONTINUE | |
29005 | RETURN | |
29006 | END | |
29007 | ||
29008 | *$ CREATE DT_HIMULT.FOR | |
29009 | *COPY DT_HIMULT | |
29010 | * | |
29011 | *===himult=============================================================* | |
29012 | * | |
29013 | SUBROUTINE DT_HIMULT(MODE) | |
29014 | ||
29015 | ************************************************************************ | |
29016 | * Tables of average energies/multiplicities. * | |
29017 | * This version dated 30.08.2000 is written by S. Roesler * | |
29018 | ************************************************************************ | |
29019 | ||
29020 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
29021 | SAVE | |
29022 | PARAMETER ( LINP = 10 , | |
29023 | & LOUT = 6 , | |
29024 | & LDAT = 9 ) | |
29025 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14) | |
29026 | ||
29027 | PARAMETER (SWMEXP=1.7D0) | |
29028 | ||
29029 | CHARACTER*8 ANAMEH(4) | |
29030 | ||
29031 | * particle properties (BAMJET index convention) | |
29032 | CHARACTER*8 ANAME | |
29033 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
29034 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
29035 | * temporary storage for one final state particle | |
29036 | LOGICAL LFRAG,LGREY,LBLACK | |
29037 | COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN, | |
29038 | & SINTHE,COSTHE,THETA,THECMS, | |
29039 | & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF, | |
29040 | & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF, | |
29041 | & LFRAG,LGREY,LBLACK | |
29042 | * event flag used for histograms | |
29043 | COMMON /DTNORM/ ICEVT,IEVHKK | |
29044 | * Lorentz-parameters of the current interaction | |
29045 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
29046 | & UMO,PPCM,EPROJ,PPROJ | |
29047 | ||
29048 | PARAMETER (NOPART=210) | |
29049 | DIMENSION AVMULT(4,NOPART),AVE(4,NOPART),AVSWM(4,NOPART), | |
29050 | & AVPT(4,NOPART),IAVPT(4,NOPART) | |
29051 | DATA ANAMEH /'DEUTERON','3-H ','3-HE ','4-HE '/ | |
29052 | ||
29053 | GOTO (1,2,3) MODE | |
29054 | ||
29055 | *------------------------------------------------------------------ | |
29056 | * initialization | |
29057 | 1 CONTINUE | |
29058 | DO 10 I=1,NOPART | |
29059 | DO 11 J=1,4 | |
29060 | AVMULT(J,I) = ZERO | |
29061 | AVE(J,I) = ZERO | |
29062 | AVSWM(J,I) = ZERO | |
29063 | AVPT(J,I) = ZERO | |
29064 | IAVPT(J,I) = 0 | |
29065 | 11 CONTINUE | |
29066 | 10 CONTINUE | |
29067 | ||
29068 | RETURN | |
29069 | ||
29070 | *------------------------------------------------------------------ | |
29071 | * filling of histogram with event-record | |
29072 | 2 CONTINUE | |
29073 | IF (PE.LT.0.0D0) THEN | |
29074 | WRITE(LOUT,*) ' HIMULT: PE < 0 ! ',PE | |
29075 | RETURN | |
29076 | ENDIF | |
29077 | IF (.NOT.LFRAG) THEN | |
29078 | IVEL = 2 | |
29079 | IF (LGREY) IVEL = 3 | |
29080 | IF (LBLACK) IVEL = 4 | |
29081 | AVE(1,IDBJT) = AVE(1,IDBJT) +PE | |
29082 | AVE(IVEL,IDBJT) = AVE(IVEL,IDBJT)+PE | |
29083 | AVPT(1,IDBJT) = AVPT(1,IDBJT) +PT | |
29084 | AVPT(IVEL,IDBJT) = AVPT(IVEL,IDBJT)+PT | |
29085 | IAVPT(1,IDBJT) = IAVPT(1,IDBJT) +1 | |
29086 | IAVPT(IVEL,IDBJT) = IAVPT(IVEL,IDBJT)+1 | |
29087 | AVSWM(1,IDBJT) = AVSWM(1,IDBJT) +PE**SWMEXP | |
29088 | AVSWM(IVEL,IDBJT) = AVSWM(IVEL,IDBJT)+PE**SWMEXP | |
29089 | AVMULT(1,IDBJT) = AVMULT(1,IDBJT) +ONE | |
29090 | AVMULT(IVEL,IDBJT) = AVMULT(IVEL,IDBJT)+ONE | |
29091 | IF (IDBJT.LT.116) THEN | |
29092 | * total energy, multiplicity | |
29093 | AVE(1,30) = AVE(1,30) +PE | |
29094 | AVE(IVEL,30) = AVE(IVEL,30)+PE | |
29095 | AVPT(1,30) = AVPT(1,30) +PT | |
29096 | AVPT(IVEL,30) = AVPT(IVEL,30)+PT | |
29097 | IAVPT(1,30) = IAVPT(1,30) +1 | |
29098 | IAVPT(IVEL,30) = IAVPT(IVEL,30)+1 | |
29099 | AVSWM(1,30) = AVSWM(1,30)+PE**SWMEXP | |
29100 | AVSWM(IVEL,30) = AVSWM(IVEL,30)+PE**SWMEXP | |
29101 | AVMULT(1,30) = AVMULT(1,30) +ONE | |
29102 | AVMULT(IVEL,30) = AVMULT(IVEL,30)+ONE | |
29103 | * charged energy, multiplicity | |
29104 | IF (ICHAR.LT.0) THEN | |
29105 | AVE(1,26) = AVE(1,26) +PE | |
29106 | AVE(IVEL,26) = AVE(IVEL,26)+PE | |
29107 | AVPT(1,26) = AVPT(1,26) +PT | |
29108 | AVPT(IVEL,26) = AVPT(IVEL,26)+PT | |
29109 | IAVPT(1,26) = IAVPT(1,26) +1 | |
29110 | IAVPT(IVEL,26) = IAVPT(IVEL,26)+1 | |
29111 | AVSWM(1,26) = AVSWM(1,26) +PE**SWMEXP | |
29112 | AVSWM(IVEL,26) = AVSWM(IVEL,26)+PE**SWMEXP | |
29113 | AVMULT(1,26) = AVMULT(1,26) +ONE | |
29114 | AVMULT(IVEL,26) = AVMULT(IVEL,26)+ONE | |
29115 | ENDIF | |
29116 | IF (ICHAR.NE.0) THEN | |
29117 | AVE(1,27) = AVE(1,27) +PE | |
29118 | AVE(IVEL,27) = AVE(IVEL,27)+PE | |
29119 | AVPT(1,27) = AVPT(1,27) +PT | |
29120 | AVPT(IVEL,27) = AVPT(IVEL,27)+PT | |
29121 | IAVPT(1,27) = IAVPT(1,27) +1 | |
29122 | IAVPT(IVEL,27) = IAVPT(IVEL,27)+1 | |
29123 | AVSWM(1,27) = AVSWM(1,27) +PE**SWMEXP | |
29124 | AVSWM(IVEL,27) = AVSWM(IVEL,27)+PE**SWMEXP | |
29125 | AVMULT(1,27) = AVMULT(1,27) +ONE | |
29126 | AVMULT(IVEL,27) = AVMULT(IVEL,27)+ONE | |
29127 | ENDIF | |
29128 | ENDIF | |
29129 | ENDIF | |
29130 | ||
29131 | RETURN | |
29132 | ||
29133 | *------------------------------------------------------------------ | |
29134 | * output | |
29135 | 3 CONTINUE | |
29136 | WRITE(LOUT,3000) | |
29137 | 3000 FORMAT(/,1X,'HIMULT:',21X,'particle - statistics',/, | |
29138 | & 29X,'---------------------',/) | |
29139 | IF (MULDEF.EQ.1) THEN | |
29140 | WRITE(LOUT,'(1X,A,/)') 'fast/grey/black: EMU-def.' | |
29141 | ELSE | |
29142 | BETGRE = 0.7D0 | |
29143 | BETBLC = 0.23D0 | |
29144 | WRITE(LOUT,3002) BETGRE,BETGRE,BETBLC,BETBLC | |
29145 | 3002 FORMAT(1X,'fast: beta > ',F4.2,' grey: ',F4.2,' > beta > ' | |
29146 | & ,F4.2,' black: beta < ',F4.2,/) | |
29147 | ENDIF | |
29148 | WRITE(LOUT,3003) SWMEXP | |
29149 | 3003 FORMAT(1X,'particle |',12X,'average multiplicity',/, | |
29150 | & 13X,'| total fast', | |
29151 | C & ' grey black K f(',F3.1,')',/,1X, | |
29152 | & ' grey black <pt> f(',F3.1,')',/,1X, | |
29153 | & '------------+--------------', | |
29154 | & '-------------------------------------------------') | |
29155 | DO 30 I=1,NOPART | |
29156 | DO 31 J=1,4 | |
29157 | AVMULT(J,I) = AVMULT(J,I)/DBLE(MAX(ICEVT,1)) | |
29158 | AVE(J,I) = AVE(J,I)/DBLE(MAX(ICEVT,1))/EPROJ | |
29159 | AVPT(J,I) = AVPT(J,I)/DBLE(MAX(IAVPT(J,I),1)) | |
29160 | AVSWM(J,I) = AVSWM(J,I)/DBLE(MAX(ICEVT,1))/EPROJ**SWMEXP | |
29161 | 31 CONTINUE | |
29162 | IF (I.LE.115) THEN | |
29163 | WRITE(LOUT,3004) ANAME(I),I, | |
29164 | & AVMULT(1,I),AVMULT(2,I), | |
29165 | & AVMULT(3,I),AVMULT(4,I), | |
29166 | C & AVE(1,I),AVSWM(1,I) | |
29167 | & AVPT(1,I),AVSWM(1,I) | |
29168 | ELSEIF (I.LE.119) THEN | |
29169 | WRITE(LOUT,3004) ANAMEH(I-115),I, | |
29170 | & AVMULT(1,I),AVMULT(2,I), | |
29171 | & AVMULT(3,I),AVMULT(4,I), | |
29172 | C & AVE(1,I),AVSWM(1,I) | |
29173 | & AVPT(1,I),AVSWM(1,I) | |
29174 | ENDIF | |
29175 | 3004 FORMAT(1X,A8,I4,'| ',2F13.6,2F9.5,2F9.5) | |
29176 | 30 CONTINUE | |
29177 | **temporary | |
29178 | C WRITE(LOUT,'(A,F7.3)') ' number of charged heavy particles: ', | |
29179 | C & AVMULT(3,27)+AVMULT(4,27) | |
29180 | ** | |
29181 | ||
29182 | RETURN | |
29183 | END | |
29184 | ||
29185 | *$ CREATE DT_HISTAT.FOR | |
29186 | *COPY DT_HISTAT | |
29187 | * | |
29188 | *===histat=============================================================* | |
29189 | * | |
29190 | SUBROUTINE DT_HISTAT(IDX,MODE) | |
29191 | ||
29192 | ************************************************************************ | |
29193 | * This version dated 26.02.96 is written by S. Roesler * | |
29194 | * * | |
29195 | * Last change 27.12.2006 by S. Roesler. * | |
29196 | ************************************************************************ | |
29197 | ||
29198 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
29199 | SAVE | |
29200 | PARAMETER ( LINP = 10 , | |
29201 | & LOUT = 6 , | |
29202 | & LDAT = 9 ) | |
29203 | PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14) | |
29204 | PARAMETER (NDIM=199) | |
29205 | ||
29206 | * event history | |
29207 | PARAMETER (NMXHKK=200000) | |
29208 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
29209 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
29210 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
29211 | * extended event history | |
29212 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
29213 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
29214 | & IHIST(2,NMXHKK) | |
29215 | * particle properties (BAMJET index convention) | |
29216 | CHARACTER*8 ANAME | |
29217 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
29218 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
29219 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
29220 | * Glauber formalism: cross sections | |
29221 | COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, | |
29222 | & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), | |
29223 | & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), | |
29224 | & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), | |
29225 | & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), | |
29226 | & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), | |
29227 | & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), | |
29228 | & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), | |
29229 | & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), | |
29230 | & BSLOPE,NEBINI,NQBINI | |
29231 | * emulsion treatment | |
29232 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
29233 | & NCOMPO,IEMUL | |
29234 | * properties of interacting particles | |
29235 | COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG | |
29236 | * rejection counter | |
29237 | COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES, | |
29238 | & IRCHKI(2),IRFRAG,IRCRON(3),IREVT, | |
29239 | & IREXCI(3),IRDIFF(2),IRINC | |
29240 | * statistics: residual nuclei | |
29241 | COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2), | |
29242 | & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2), | |
29243 | & NINCST(2,4),NINCEV(2), | |
29244 | & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2), | |
29245 | & NRESPB(2),NRESCH(2),NRESEV(4), | |
29246 | & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240), | |
29247 | & NEVAFI(2,2) | |
29248 | * parameter for intranuclear cascade | |
29249 | LOGICAL LPAULI | |
29250 | COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI | |
29251 | * (original name: PAREVT) | |
29252 | LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX, | |
29253 | & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF | |
29254 | PARAMETER ( NALLWP = 39 ) | |
29255 | COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, | |
29256 | & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY, | |
29257 | & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV, | |
29258 | & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF | |
29259 | * (original name: FRBKCM) | |
29260 | PARAMETER ( MXFFBK = 6 ) | |
29261 | PARAMETER ( MXZFBK = 9 ) | |
29262 | PARAMETER ( MXNFBK = 10 ) | |
29263 | PARAMETER ( MXAFBK = 16 ) | |
29264 | PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 ) | |
29265 | PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 ) | |
29266 | PARAMETER ( NXAFBK = MXAFBK + 1 ) | |
29267 | PARAMETER ( MXPSST = 300 ) | |
29268 | PARAMETER ( MXPSFB = 41000 ) | |
29269 | LOGICAL LFRMBK, LNCMSS | |
29270 | COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST), | |
29271 | & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB), | |
29272 | & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK, | |
29273 | & IFRBKN (MXPSST), IFRBKZ (MXPSST), | |
29274 | & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST), | |
29275 | & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK), | |
29276 | & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK), | |
29277 | & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF, | |
29278 | & IFBFRB, NBUFBK, LFRMBK, LNCMSS | |
29279 | * (original name: INPFLG) | |
29280 | COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK | |
29281 | * temporary storage for one final state particle | |
29282 | LOGICAL LFRAG,LGREY,LBLACK | |
29283 | COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN, | |
29284 | & SINTHE,COSTHE,THETA,THECMS, | |
29285 | & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF, | |
29286 | & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF, | |
29287 | & LFRAG,LGREY,LBLACK | |
29288 | * event flag used for histograms | |
29289 | COMMON /DTNORM/ ICEVT,IEVHKK | |
29290 | * statistics: double-Pomeron exchange | |
29291 | COMMON /DTFLG2/ INTFLG,IPOPO | |
29292 | ||
29293 | DIMENSION EMUSAM(NCOMPX) | |
29294 | ||
29295 | CHARACTER*13 CMSG(3) | |
29296 | DATA CMSG /'not requested','not requested','not requested'/ | |
29297 | ||
29298 | GOTO (1,2,3,4,5) MODE | |
29299 | ||
29300 | *------------------------------------------------------------------ | |
29301 | * initialization | |
29302 | 1 CONTINUE | |
29303 | * emulsion treatment | |
29304 | IF (NCOMPO.GT.0) THEN | |
29305 | DO 10 I=1,NCOMPX | |
29306 | EMUSAM(I) = ZERO | |
29307 | 10 CONTINUE | |
29308 | ENDIF | |
29309 | * common /DTSTA2/, statistics on i.n.c., residual nuclei, evap. | |
29310 | NINCGE = 0 | |
29311 | DO 11 I=1,2 | |
29312 | EXCDPM(I) = ZERO | |
29313 | EXCDPM(I+2) = ZERO | |
29314 | EXCEVA(I) = ZERO | |
29315 | NINCWO(I) = 0 | |
29316 | NINCEV(I) = 0 | |
29317 | NRESTO(I) = 0 | |
29318 | NRESPR(I) = 0 | |
29319 | NRESNU(I) = 0 | |
29320 | NRESBA(I) = 0 | |
29321 | NRESPB(I) = 0 | |
29322 | NRESCH(I) = 0 | |
29323 | NRESEV(I) = 0 | |
29324 | NRESEV(I+2) = 0 | |
29325 | NEVAGA(I) = 0 | |
29326 | NEVAHT(I) = 0 | |
29327 | NEVAFI(1,I) = 0 | |
29328 | NEVAFI(2,I) = 0 | |
29329 | DO 12 J=1,6 | |
29330 | IF (J.LE.2) NINCHR(I,J) = 0 | |
29331 | IF (J.LE.3) NINCCO(I,J) = 0 | |
29332 | IF (J.LE.4) NINCST(I,J) = 0 | |
29333 | NEVA(I,J) = 0 | |
29334 | 12 CONTINUE | |
29335 | DO 13 J=1,210 | |
29336 | NEVAHY(1,I,J) = 0 | |
29337 | NEVAHY(2,I,J) = 0 | |
29338 | 13 CONTINUE | |
29339 | 11 CONTINUE | |
29340 | MAXGEN = 0 | |
29341 | **dble Po statistics. | |
29342 | KPOPO = 0 | |
29343 | ||
29344 | RETURN | |
29345 | *------------------------------------------------------------------ | |
29346 | * filling of histogram with event-record | |
29347 | 2 CONTINUE | |
29348 | IF (IST.EQ.-1) THEN | |
29349 | IF (.NOT.LFRAG) THEN | |
29350 | IF (IDPDG.EQ.2212) THEN | |
29351 | NEVA(NOBAM(IDX),1) = NEVA(NOBAM(IDX),1)+1 | |
29352 | ELSEIF (IDPDG.EQ.2112) THEN | |
29353 | NEVA(NOBAM(IDX),2) = NEVA(NOBAM(IDX),2)+1 | |
29354 | ELSEIF (IDPDG.EQ.22) THEN | |
29355 | NEVAGA(NOBAM(IDX)) = NEVAGA(NOBAM(IDX))+1 | |
29356 | ELSEIF (IDPDG.EQ.80000) THEN | |
29357 | IF (IDBJT.EQ.116) THEN | |
29358 | NEVA(NOBAM(IDX),3) = NEVA(NOBAM(IDX),3)+1 | |
29359 | ELSEIF (IDBJT.EQ.117) THEN | |
29360 | NEVA(NOBAM(IDX),4) = NEVA(NOBAM(IDX),4)+1 | |
29361 | ELSEIF (IDBJT.EQ.118) THEN | |
29362 | NEVA(NOBAM(IDX),5) = NEVA(NOBAM(IDX),5)+1 | |
29363 | ELSEIF (IDBJT.EQ.119) THEN | |
29364 | NEVA(NOBAM(IDX),6) = NEVA(NOBAM(IDX),6)+1 | |
29365 | ENDIF | |
29366 | ENDIF | |
29367 | ELSE | |
29368 | * heavy fragments (here: fission products only) | |
29369 | NEVAHY(NOBAM(IDX),1,IBARY) = NEVAHY(NOBAM(IDX),1,IBARY)+1 | |
29370 | NEVAHY(NOBAM(IDX),2,ICHAR) = NEVAHY(NOBAM(IDX),2,ICHAR)+1 | |
29371 | NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1 | |
29372 | ENDIF | |
29373 | ELSEIF ((IST.EQ.1).AND.(.NOT.LFRAG)) THEN | |
29374 | IF (IDCH(IDX).GT.MAXGEN) MAXGEN = IDCH(IDX) | |
29375 | ENDIF | |
29376 | ||
29377 | RETURN | |
29378 | *------------------------------------------------------------------ | |
29379 | * output | |
29380 | 3 CONTINUE | |
29381 | ||
29382 | **dble Po statistics. | |
29383 | C WRITE(LOUT,'(1X,A,2I7,2E12.4)') | |
29384 | C & '# evts. / # dble-Po. evts / s_in / s_popo :', | |
29385 | C & ICEVT,KPOPO,XSPRO(1,1,1),XSPRO(1,1,1)*DBLE(KPOPO)/DBLE(ICEVT) | |
29386 | ||
29387 | * emulsion treatment | |
29388 | IF (NCOMPO.GT.0) THEN | |
29389 | WRITE(LOUT,3000) | |
29390 | 3000 FORMAT(/,1X,'HISTAT:',14X,'statistics - target emulsion',/, | |
29391 | & 22X,'----------------------------',/,/,19X, | |
29392 | & 'mass charge fraction',/,39X, | |
29393 | & 'input treated',/) | |
29394 | DO 30 I=1,NCOMPO | |
29395 | WRITE(LOUT,3013) I,IEMUMA(I),IEMUCH(I),EMUFRA(I), | |
29396 | & EMUSAM(I)/DBLE(ICEVT) | |
29397 | 3013 FORMAT(12X,I2,1X,2I8,6X,F7.3,5X,F7.3) | |
29398 | 30 CONTINUE | |
29399 | ENDIF | |
29400 | ||
29401 | * i.n.c. statistics: output | |
29402 | WRITE(LOUT,3001) ICEVT,NRESEV(2),IRINC | |
29403 | 3001 FORMAT(/,1X,'HISTAT:',14X,'statistics - intranuclear cascade',/, | |
29404 | & 22X,'---------------------------------',/,/,1X, | |
29405 | & 'no. of events for normalization: (accepted final events,', | |
29406 | & ' evt)',4X,I6,/,34X,'(events before evap.-step, evt1)',I6, | |
29407 | & /,1X,'no. of rejected events due to intranuclear', | |
29408 | & ' cascade',15X,I6,/) | |
29409 | ICEV = MAX(ICEVT,1) | |
29410 | ICEV1 = ICEV | |
29411 | IF (LEVPRT) ICEV1 = MAX(NRESEV(2),1) | |
29412 | WRITE(LOUT,3002) | |
29413 | & (DBLE(NINCWO(I))/DBLE(ICEV),I=1,2), | |
29414 | & ((DBLE(NINCST(I,J))/DBLE(ICEV),I=1,2),J=1,4), | |
29415 | & KTAUGE,DBLE(NINCGE)/DBLE(ICEV), | |
29416 | & (DBLE(NINCCO(I,1)+NINCCO(I,2)+NINCCO(I,3))/DBLE(ICEV1),I=1,2), | |
29417 | & (DBLE(NINCCO(I,2))/DBLE(ICEV1),I=1,2), | |
29418 | & (DBLE(NINCCO(I,3))/DBLE(ICEV1),I=1,2), | |
29419 | & (DBLE(NINCCO(I,1))/DBLE(ICEV1),I=1,2) | |
29420 | 3002 FORMAT(1X,'no. of wounded nucl. in proj./ target (mean per evt)', | |
29421 | & 5X,F6.2,' /',F6.2,/,1X,'no. of particles unable to escape', | |
29422 | & ' proj./ target (mean per evt)',/,8X,'baryons: pos. ', | |
29423 | & F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3,/,8X, | |
29424 | & 'mesons: pos. ',F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3, | |
29425 | & /,1X,'maximum no. of generations treated (maximum allowed:' | |
29426 | & ,I4,')',/,43X,'(mean per evt)',5X,F6.2,/,1X,'no. of sec.', | |
29427 | & ' interactions in proj./ target (mean per evt1)', | |
29428 | & F7.3,' /',F7.3,/,8X,'out of which by inelastic', | |
29429 | & ' interactions',12X,F7.3,' /',F7.3,/,21X,'by elastic ', | |
29430 | & 'interactions',14X,F7.3,' /',F7.3,/,21X,'by absorption ', | |
29431 | & '(ap, K-, pi- only) ',F7.3,' /',F7.3,/) | |
29432 | WRITE(LOUT,3003) NRESEV(2),NRESEV(4),IREXCI, | |
29433 | & IREXCI(1)+IREXCI(2)+IREXCI(3) | |
29434 | 3003 FORMAT(/,1X,'HISTAT:',14X,'statistics - residual nuclei, ', | |
29435 | & 'evaporation',/,22X,'-----------------------------', | |
29436 | & '------------',/,/,1X,'no. of events for normal.: ', | |
29437 | & '(events handled by FICONF, evt)',7X,I6,/,28X,'(events', | |
29438 | & ' passing the evap.-step, evt1) ',I6,/,1X,'no. of', | |
29439 | & ' rejected events (',I4,',',I4,',',I4,')',22X,I6,/) | |
29440 | ||
29441 | WRITE(LOUT,3004) | |
29442 | 3004 FORMAT(/,22X,'1) before evaporation-step:',/) | |
29443 | ICEV = MAX(NRESEV(2),1) | |
29444 | WRITE(LOUT,3005) | |
29445 | & (DBLE(NRESTO(I))/DBLE(ICEV),I=1,2), | |
29446 | & (DBLE(NRESPR(I))/DBLE(ICEV),I=1,2), | |
29447 | & (DBLE(NRESNU(I))/DBLE(ICEV),I=1,2), | |
29448 | & (DBLE(NRESBA(I))/DBLE(ICEV),I=1,2), | |
29449 | & (DBLE(NRESPB(I))/DBLE(ICEV),I=1,2), | |
29450 | & (DBLE(NRESCH(I))/DBLE(ICEV),I=1,2), | |
29451 | & (EXCDPM(I)/DBLE(ICEV),I=1,2), | |
29452 | & (EXCDPM(I+2)/DBLE(ICEV),I=1,2) | |
29453 | 3005 FORMAT(1X,'residual nuclei: (mean values per evt)',12X, | |
29454 | & 'proj. / target',/,/,8X,'total number of particles',15X, | |
29455 | & 2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X, | |
29456 | & 'neutrons',18X,2F9.3,/,22X,'baryons',19X,2F9.3,/,22X, | |
29457 | & 'pos. baryons',14X,2F9.3,/,8X,'total charge',28X,2F9.3,/, | |
29458 | & /,8X,'excitation energy (bef. evap.-step) ',2E11.3,/, | |
29459 | & 8X,'excitation energy per nucleon ',2E11.3,/,/) | |
29460 | ||
29461 | * evaporation / fission / fragmentation statistics: output | |
29462 | ICEV = MAX(NRESEV(2),1) | |
29463 | ICEV1 = MAX(NRESEV(4),1) | |
29464 | NTEVA1 = | |
29465 | & NEVA(1,1)+NEVA(1,2)+NEVA(1,3)+NEVA(1,4)+NEVA(1,5)+NEVA(1,6) | |
29466 | NTEVA2 = | |
29467 | & NEVA(2,1)+NEVA(2,2)+NEVA(2,3)+NEVA(2,4)+NEVA(2,5)+NEVA(2,6) | |
29468 | IF (LEVPRT) THEN | |
29469 | IF (IFISS.EQ.1) CMSG(1) = 'requested ' | |
29470 | IF (LFRMBK) CMSG(2) = 'requested ' | |
29471 | IF (LDEEXG) CMSG(3) = 'requested ' | |
29472 | WRITE(LOUT,3006) | |
29473 | & CMSG, | |
29474 | & DBLE(NTEVA1)/DBLE(ICEV1),DBLE(NTEVA2)/DBLE(ICEV1), | |
29475 | & (DBLE(NEVA(I,1))/DBLE(ICEV1),I=1,2), | |
29476 | & (DBLE(NEVA(I,2))/DBLE(ICEV1),I=1,2), | |
29477 | & (DBLE(NEVA(I,3))/DBLE(ICEV1),I=1,2), | |
29478 | & (DBLE(NEVA(I,4))/DBLE(ICEV1),I=1,2), | |
29479 | & (DBLE(NEVA(I,5))/DBLE(ICEV1),I=1,2), | |
29480 | & (DBLE(NEVA(I,6))/DBLE(ICEV1),I=1,2), | |
29481 | & (DBLE(NEVAGA(I))/DBLE(ICEV1),I=1,2), | |
29482 | & (DBLE(NEVAHT(I))/DBLE(ICEV1),I=1,2) | |
29483 | 3006 FORMAT(22X,'2) after evaporation-step:',/,/,1X,'Fission:', | |
29484 | & 13X,A13,/,1X,'Fermi-Break-up:',6X,A13,/,1X,'Gamma-', | |
29485 | & 'deexcitation:',2X,A13,/,/, | |
29486 | & 1X,'evaporation/deexcitation: (mean values per evt1) ', | |
29487 | & 'proj. / target',/,/,8X,'total number of evap. particles', | |
29488 | & 9X,2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X, | |
29489 | & 'neutrons',18X,2F9.3,/,22X,'deuterons',17X,2F9.3,/,22X, | |
29490 | & '3-H',23X,2F9.3,/,22X,'3-He',22X,2F9.3,/,22X,'4-He',22X, | |
29491 | & 2F9.3,/,8X,'nucl. deexcit. gammas',19X,2F9.3,/,8X, | |
29492 | & 'heavy fragments',25X,2F9.3,/) | |
29493 | IF (IFISS.EQ.1) THEN | |
29494 | WRITE(LOUT,3007) NEVAFI(1,1),NEVAFI(1,2), | |
29495 | & NEVAFI(2,1),NEVAFI(2,2), | |
29496 | & DBLE(NEVAFI(2,1))/DBLE(MAX(NEVAFI(1,1),1))*100.0D0, | |
29497 | & DBLE(NEVAFI(2,2))/DBLE(MAX(NEVAFI(1,2),1))*100.0D0 | |
29498 | 3007 FORMAT(1X,'Fission: total number of events',14X,2I9,/ | |
29499 | & 12X,'out of which fission occured',8X,2I9,/, | |
29500 | & 50X,'(',F5.2,'%) (',F5.2,'%)',/) | |
29501 | ENDIF | |
29502 | C IF ((LFRMBK).OR.(IFISS.EQ.1)) THEN | |
29503 | C WRITE(LOUT,3008) | |
29504 | C3008 FORMAT(1X,'heavy fragments - statistics:',7X,'charge', | |
29505 | C & ' proj. / target',/) | |
29506 | C DO 31 I=1,210 | |
29507 | C IF ((NEVAHY(1,2,I).NE.0).OR.(NEVAHY(2,2,I).NE.0)) THEN | |
29508 | C WRITE(LOUT,3009) I, | |
29509 | C & (DBLE(NEVAHY(K,2,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2) | |
29510 | C3009 FORMAT(38X,I3,3X,2E12.3) | |
29511 | C ENDIF | |
29512 | C 31 CONTINUE | |
29513 | C WRITE(LOUT,3010) | |
29514 | C3010 FORMAT(1X,'heavy fragments - statistics:',7X,'mass ', | |
29515 | C & ' proj. / target',/) | |
29516 | C DO 32 I=1,210 | |
29517 | C IF ((NEVAHY(1,1,I).NE.0).OR.(NEVAHY(2,1,I).NE.0)) THEN | |
29518 | C WRITE(LOUT,3011) I, | |
29519 | C & (DBLE(NEVAHY(K,1,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2) | |
29520 | C3011 FORMAT(38X,I3,3X,2E12.3) | |
29521 | C ENDIF | |
29522 | C 32 CONTINUE | |
29523 | C WRITE(LOUT,*) | |
29524 | C ENDIF | |
29525 | ELSE | |
29526 | WRITE(LOUT,3012) | |
29527 | 3012 FORMAT(22X,'2) after evaporation-step:',/,/,1X, | |
29528 | & 'Evaporation: not requested',/) | |
29529 | ENDIF | |
29530 | ||
29531 | RETURN | |
29532 | *------------------------------------------------------------------ | |
29533 | * filling of histogram with event-record | |
29534 | 4 CONTINUE | |
29535 | * emulsion treatment | |
29536 | IF (NCOMPO.GT.0) THEN | |
29537 | DO 40 I=1,NCOMPO | |
29538 | IF (IT.EQ.IEMUMA(I)) THEN | |
29539 | EMUSAM(I) = EMUSAM(I)+ONE | |
29540 | ENDIF | |
29541 | 40 CONTINUE | |
29542 | ENDIF | |
29543 | NINCGE = NINCGE+MAXGEN | |
29544 | MAXGEN = 0 | |
29545 | **dble Po statistics. | |
29546 | IF (IPOPO.EQ.1) KPOPO = KPOPO+1 | |
29547 | ||
29548 | RETURN | |
29549 | *------------------------------------------------------------------ | |
29550 | * filling of histogram with event-record | |
29551 | 5 CONTINUE | |
29552 | IF ((ISTHKK(IDX).EQ.15).OR.(ISTHKK(IDX).EQ.16)) THEN | |
29553 | IB = IIBAR(IDBAM(IDX)) | |
29554 | IC = IICH(IDBAM(IDX)) | |
29555 | J = ISTHKK(IDX)-14 | |
29556 | IF ( ((ABS(IB).EQ.1).AND.(IC.EQ.1)).OR.(IC.EQ.0) ) THEN | |
29557 | NINCST(J,1) = NINCST(J,1)+1 | |
29558 | ELSEIF ((ABS(IB).EQ.1).AND.(IC.EQ.-1)) THEN | |
29559 | NINCST(J,2) = NINCST(J,2)+1 | |
29560 | ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ. 1)) THEN | |
29561 | NINCST(J,3) = NINCST(J,3)+1 | |
29562 | ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ.-1)) THEN | |
29563 | NINCST(J,4) = NINCST(J,4)+1 | |
29564 | ENDIF | |
29565 | ELSEIF (ISTHKK(IDX).EQ.17) THEN | |
29566 | NINCWO(1) = NINCWO(1)+1 | |
29567 | ELSEIF (ISTHKK(IDX).EQ.18) THEN | |
29568 | NINCWO(2) = NINCWO(2)+1 | |
29569 | ELSEIF (ISTHKK(IDX).EQ.1001) THEN | |
29570 | IB = IDRES(IDX) | |
29571 | IC = IDXRES(IDX) | |
29572 | IF (IC.GT.0) THEN | |
29573 | NEVAHY(NOBAM(IDX),1,IB) = NEVAHY(NOBAM(IDX),1,IB)+1 | |
29574 | NEVAHY(NOBAM(IDX),2,IC) = NEVAHY(NOBAM(IDX),2,IC)+1 | |
29575 | ENDIF | |
29576 | NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1 | |
29577 | ENDIF | |
29578 | ||
29579 | RETURN | |
29580 | END | |
29581 | ||
29582 | *$ CREATE DT_NEWHGR.FOR | |
29583 | *COPY DT_NEWHGR | |
29584 | * | |
29585 | *===newhgr=============================================================* | |
29586 | * | |
29587 | SUBROUTINE DT_NEWHGR(XLIM1,XLIM2,XLIM3,XLIMB,IBIN,IREFN) | |
29588 | ||
29589 | ************************************************************************ | |
29590 | * * | |
29591 | * Histogram initialization. * | |
29592 | * * | |
29593 | * input: XLIM1/XLIM2 lower/upper edge of histogram-window * | |
29594 | * XLIM3 bin size * | |
29595 | * IBIN > 0 number of bins in equidistant lin. binning * | |
29596 | * = -1 reset histograms * | |
29597 | * < -1 |IBIN| number of bins in equidistant log. * | |
29598 | * binning or log. binning in user def. struc. * | |
29599 | * XLIMB(*) user defined bin structure * | |
29600 | * * | |
29601 | * The bin structure is sensitive to * | |
29602 | * XLIM1, XLIM3, IBIN if XLIM3 > 0 (lin.) * | |
29603 | * XLIM1, XLIM2, IBIN if XLIM3 = 0 (lin. & log.) * | |
29604 | * XLIMB, IBIN if XLIM3 < 0 * | |
29605 | * * | |
29606 | * * | |
29607 | * output: IREFN histogram index * | |
29608 | * (= -1 for inconsistent histogr. request) * | |
29609 | * * | |
29610 | * This subroutine is based on a original version by R. Engel. * | |
29611 | * This version dated 22.4.95 is written by S. Roesler. * | |
29612 | ************************************************************************ | |
29613 | ||
29614 | IMPLICIT DOUBLE PRECISION(A-H,O-Z) | |
29615 | SAVE | |
29616 | PARAMETER ( LINP = 10 , | |
29617 | & LOUT = 6 , | |
29618 | & LDAT = 9 ) | |
29619 | ||
29620 | LOGICAL LSTART | |
29621 | ||
29622 | PARAMETER (ZERO = 0.0D0, | |
29623 | & TINY = 1.0D-10) | |
29624 | ||
29625 | DIMENSION XLIMB(*) | |
29626 | ||
29627 | * histograms | |
29628 | PARAMETER (NHIS=150, NDIM=250) | |
29629 | COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS), | |
29630 | & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL | |
29631 | * auxiliary common for histograms | |
29632 | COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS) | |
29633 | ||
29634 | DATA LSTART /.TRUE./ | |
29635 | ||
29636 | * reset histogram counter | |
29637 | IF (LSTART.OR.(IBIN.EQ.-1)) THEN | |
29638 | IHISL = 0 | |
29639 | IF (IBIN.EQ.-1) RETURN | |
29640 | LSTART = .FALSE. | |
29641 | ENDIF | |
29642 | ||
29643 | IHIS = IHISL+1 | |
29644 | * check for maximum number of allowed histograms | |
29645 | IF (IHIS.GT.NHIS) THEN | |
29646 | WRITE(LOUT,1003) IHIS,NHIS,IHIS | |
29647 | 1003 FORMAT(1X,'NEWHGR: warning! number of histograms (', | |
29648 | & I4,') exceeds array size (',I4,')',/,21X, | |
29649 | & 'histogram',I3,' skipped!') | |
29650 | GOTO 9999 | |
29651 | ENDIF | |
29652 | ||
29653 | IREFN = IHIS | |
29654 | IBINS(IHIS) = ABS(IBIN) | |
29655 | * check requested number of bins | |
29656 | IF (IBINS(IHIS).GE.NDIM) THEN | |
29657 | WRITE(LOUT,1000) IBIN,NDIM,NDIM | |
29658 | 1000 FORMAT(1X,'NEWHGR: warning! number of bins (', | |
29659 | & I3,') exceeds array size (',I3,')',/,21X, | |
29660 | & 'and will be reset to ',I3) | |
29661 | IBINS(IHIS) = NDIM | |
29662 | ENDIF | |
29663 | IF (IBINS(IHIS).EQ.0) THEN | |
29664 | WRITE(LOUT,1001) IBIN,IHIS | |
29665 | 1001 FORMAT(1X,'NEWHGR: warning! inconsistent number of', | |
29666 | & ' bins (',I3,')',/,21X,'histogram',I3,' skipped!') | |
29667 | GOTO 9999 | |
29668 | ENDIF | |
29669 | ||
29670 | * initialize arrays | |
29671 | DO 1 I=1,NDIM | |
29672 | DO 2 K=1,3 | |
29673 | HIST(K,IHIS,I) = ZERO | |
29674 | HIST(K+3,IHIS,I) = ZERO | |
29675 | TMPHIS(K,IHIS,I) = ZERO | |
29676 | 2 CONTINUE | |
29677 | HIST(7,IHIS,I) = ZERO | |
29678 | 1 CONTINUE | |
29679 | DENTRY(1,IHIS)= ZERO | |
29680 | DENTRY(2,IHIS)= ZERO | |
29681 | OVERF(IHIS) = ZERO | |
29682 | UNDERF(IHIS) = ZERO | |
29683 | TMPUFL(IHIS) = ZERO | |
29684 | TMPOFL(IHIS) = ZERO | |
29685 | ||
29686 | * bin str. sensitive to lower edge, bin size, and numb. of bins | |
29687 | IF (XLIM3.GT.ZERO) THEN | |
29688 | DO 3 K=1,IBINS(IHIS)+1 | |
29689 | HIST(1,IHIS,K) = XLIM1+DBLE(K-1)*XLIM3 | |
29690 | 3 CONTINUE | |
29691 | ISWI(IHIS) = 1 | |
29692 | * bin str. sensitive to lower/upper edge and numb. of bins | |
29693 | ELSEIF (XLIM3.EQ.ZERO) THEN | |
29694 | * linear binning | |
29695 | IF (IBIN.GT.0) THEN | |
29696 | XLOW = XLIM1 | |
29697 | XHI = XLIM2 | |
29698 | IF (XLIM2.LE.XLIM1) THEN | |
29699 | WRITE(LOUT,1002) XLIM1,XLIM2 | |
29700 | 1002 FORMAT(1X,'NEWHGR: warning! inconsistent x-range', | |
29701 | & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')') | |
29702 | GOTO 9999 | |
29703 | ENDIF | |
29704 | ISWI(IHIS) = 1 | |
29705 | ELSEIF (IBIN.LT.-1) THEN | |
29706 | * logarithmic binning | |
29707 | IF ((XLIM1.LE.ZERO).OR.(XLIM2.LE.ZERO)) THEN | |
29708 | WRITE(LOUT,1004) XLIM1,XLIM2 | |
29709 | 1004 FORMAT(1X,'NEWHGR: warning! inconsistent log. ', | |
29710 | & 'binning',/,21X,'(XLIM1,XLIM2 = ',2E11.4,')') | |
29711 | GOTO 9999 | |
29712 | ENDIF | |
29713 | IF (XLIM2.LE.XLIM1) THEN | |
29714 | WRITE(LOUT,1005) XLIM1,XLIM2 | |
29715 | 1005 FORMAT(1X,'NEWHGR: warning! inconsistent x-range', | |
29716 | & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')') | |
29717 | GOTO 9999 | |
29718 | ENDIF | |
29719 | XLOW = LOG10(XLIM1) | |
29720 | XHI = LOG10(XLIM2) | |
29721 | ISWI(IHIS) = 3 | |
29722 | ENDIF | |
29723 | DX = ABS(XHI-XLOW)/DBLE(MAX(IBINS(IHIS),1)) | |
29724 | DO 4 K=1,IBINS(IHIS)+1 | |
29725 | HIST(1,IHIS,K) = XLOW+DBLE(K-1)*DX | |
29726 | 4 CONTINUE | |
29727 | ELSE | |
29728 | * user defined bin structure | |
29729 | DO 5 K=1,IBINS(IHIS)+1 | |
29730 | IF (IBIN.GT.0) THEN | |
29731 | HIST(1,IHIS,K) = XLIMB(K) | |
29732 | ISWI(IHIS) = 2 | |
29733 | ELSEIF (IBIN.LT.-1) THEN | |
29734 | HIST(1,IHIS,K) = LOG10(XLIMB(K)) | |
29735 | ISWI(IHIS) = 4 | |
29736 | ENDIF | |
29737 | 5 CONTINUE | |
29738 | ENDIF | |
29739 | ||
29740 | * histogram accepted | |
29741 | IHISL = IHIS | |
29742 | ||
29743 | RETURN | |
29744 | ||
29745 | 9999 CONTINUE | |
29746 | IREFN = -1 | |
29747 | RETURN | |
29748 | END | |
29749 | ||
29750 | *$ CREATE DT_FILHGR.FOR | |
29751 | *COPY DT_FILHGR | |
29752 | * | |
29753 | *===filhgr=============================================================* | |
29754 | * | |
29755 | SUBROUTINE DT_FILHGR(XI,YI,IHIS,NEVT) | |
29756 | ||
29757 | ************************************************************************ | |
29758 | * * | |
29759 | * Scoring for histogram IHIS. * | |
29760 | * * | |
29761 | * This subroutine is based on a original version by R. Engel. * | |
29762 | * This version dated 23.4.95 is written by S. Roesler. * | |
29763 | ************************************************************************ | |
29764 | ||
29765 | IMPLICIT DOUBLE PRECISION(A-H,O-Z) | |
29766 | SAVE | |
29767 | PARAMETER ( LINP = 10 , | |
29768 | & LOUT = 6 , | |
29769 | & LDAT = 9 ) | |
29770 | ||
29771 | PARAMETER (ZERO = 0.0D0, | |
29772 | & ONE = 1.0D0, | |
29773 | & TINY = 1.0D-10) | |
29774 | ||
29775 | * histograms | |
29776 | PARAMETER (NHIS=150, NDIM=250) | |
29777 | COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS), | |
29778 | & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL | |
29779 | * auxiliary common for histograms | |
29780 | COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS) | |
29781 | ||
29782 | DATA NCEVT /1/ | |
29783 | ||
29784 | X = XI | |
29785 | Y = YI | |
29786 | ||
29787 | * dump content of temorary arrays into histograms | |
29788 | IF ((NEVT.NE.NCEVT).OR.(NEVT.LT.0)) THEN | |
29789 | CALL DT_EVTHIS(IDUM) | |
29790 | NCEVT = NEVT | |
29791 | ENDIF | |
29792 | ||
29793 | * check histogram index | |
29794 | IF (IHIS.EQ.-1) RETURN | |
29795 | IF ((IHIS.LT.1).OR.(IHIS.GT.IHISL)) THEN | |
29796 | C WRITE(LOUT,1000) IHIS,IHISL | |
29797 | 1000 FORMAT(1X,'FILHGR: warning! histogram index',I4, | |
29798 | & ' out of range (1..',I3,')') | |
29799 | RETURN | |
29800 | ENDIF | |
29801 | ||
29802 | IF ((ISWI(IHIS).EQ.1).OR.(ISWI(IHIS).EQ.3)) THEN | |
29803 | * bin structure not explicitly given | |
29804 | IF ((ISWI(IHIS).EQ.3).AND.(X.GT.ZERO)) X = LOG10(X) | |
29805 | DX = ABS(HIST(1,IHIS,2)-HIST(1,IHIS,1)) | |
29806 | IF (X.LT.HIST(1,IHIS,1)) THEN | |
29807 | I1 = 0 | |
29808 | ELSE | |
29809 | I1 = INT( (X-HIST(1,IHIS,1))/MAX(DX,TINY) )+1 | |
29810 | ENDIF | |
29811 | ||
29812 | ELSEIF ((ISWI(IHIS).EQ.2).OR.(ISWI(IHIS).EQ.4)) THEN | |
29813 | * user defined bin structure | |
29814 | IF ((ISWI(IHIS).EQ.4).AND.(X.GT.ZERO)) X = LOG10(X) | |
29815 | IF (X.LT.HIST(1,IHIS,1)) THEN | |
29816 | I1 = 0 | |
29817 | ELSE IF (X.GT.HIST(1,IHIS,IBINS(IHIS)+1)) THEN | |
29818 | I1 = IBINS(IHIS)+1 | |
29819 | ELSE | |
29820 | * binary sort algorithm | |
29821 | KMIN = 0 | |
29822 | KMAX = IBINS(IHIS)+1 | |
29823 | 1 CONTINUE | |
29824 | IF ((KMAX-KMIN).EQ.1) GOTO 2 | |
29825 | KK = (KMAX+KMIN)/2 | |
29826 | IF (X.LE.HIST(1,IHIS,KK)) THEN | |
29827 | KMAX=KK | |
29828 | ELSE | |
29829 | KMIN=KK | |
29830 | ENDIF | |
29831 | GOTO 1 | |
29832 | 2 CONTINUE | |
29833 | I1 = KMIN | |
29834 | ENDIF | |
29835 | ||
29836 | ELSE | |
29837 | WRITE(LOUT,1001) | |
29838 | 1001 FORMAT(1X,'FILHGR: warning! histogram not initialized') | |
29839 | RETURN | |
29840 | ENDIF | |
29841 | ||
29842 | * scoring | |
29843 | IF (I1.LE.0) THEN | |
29844 | TMPUFL(IHIS) = TMPUFL(IHIS)+ONE | |
29845 | ELSEIF (I1.LE.IBINS(IHIS)) THEN | |
29846 | TMPHIS(1,IHIS,I1) = TMPHIS(1,IHIS,I1)+ONE | |
29847 | IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN | |
29848 | TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+10**X | |
29849 | ELSE | |
29850 | TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+X | |
29851 | ENDIF | |
29852 | TMPHIS(3,IHIS,I1) = TMPHIS(3,IHIS,I1)+Y | |
29853 | ELSE | |
29854 | TMPOFL(IHIS) = TMPOFL(IHIS)+ONE | |
29855 | ENDIF | |
29856 | ||
29857 | RETURN | |
29858 | END | |
29859 | ||
29860 | *$ CREATE DT_EVTHIS.FOR | |
29861 | *COPY DT_EVTHIS | |
29862 | * | |
29863 | *===evthis=============================================================* | |
29864 | * | |
29865 | SUBROUTINE DT_EVTHIS(NEVT) | |
29866 | ||
29867 | ************************************************************************ | |
29868 | * Dump content of temorary histograms into /DTHIS1/. This subroutine * | |
29869 | * is called after each event and for the last event before any call * | |
29870 | * to OUTHGR. * | |
29871 | * NEVT number of events dumped, this is only needed to * | |
29872 | * get the normalization after the last event * | |
29873 | * This version dated 23.4.95 is written by S. Roesler. * | |
29874 | ************************************************************************ | |
29875 | ||
29876 | IMPLICIT DOUBLE PRECISION(A-H,O-Z) | |
29877 | SAVE | |
29878 | PARAMETER ( LINP = 10 , | |
29879 | & LOUT = 6 , | |
29880 | & LDAT = 9 ) | |
29881 | ||
29882 | LOGICAL LNOETY | |
29883 | ||
29884 | PARAMETER (ZERO = 0.0D0, | |
29885 | & ONE = 1.0D0, | |
29886 | & TINY = 1.0D-10) | |
29887 | ||
29888 | * histograms | |
29889 | PARAMETER (NHIS=150, NDIM=250) | |
29890 | COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS), | |
29891 | & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL | |
29892 | * auxiliary common for histograms | |
29893 | COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS) | |
29894 | ||
29895 | DATA NCEVT /0/ | |
29896 | ||
29897 | NCEVT = NCEVT+1 | |
29898 | NEVT = NCEVT | |
29899 | ||
29900 | DO 1 I=1,IHISL | |
29901 | LNOETY = .TRUE. | |
29902 | DO 2 J=1,IBINS(I) | |
29903 | IF (TMPHIS(1,I,J).GT.ZERO) THEN | |
29904 | LNOETY = .FALSE. | |
29905 | HIST(2,I,J) = HIST(2,I,J)+ONE | |
29906 | HIST(7,I,J) = HIST(7,I,J)+TMPHIS(1,I,J) | |
29907 | DENTRY(2,I) = DENTRY(2,I)+TMPHIS(1,I,J) | |
29908 | AVX = TMPHIS(2,I,J)/TMPHIS(1,I,J) | |
29909 | HIST(3,I,J) = HIST(3,I,J)+TMPHIS(3,I,J)*AVX | |
29910 | HIST(4,I,J) = HIST(4,I,J)+TMPHIS(3,I,J)*AVX**2 | |
29911 | HIST(5,I,J) = HIST(5,I,J)+TMPHIS(3,I,J) | |
29912 | HIST(6,I,J) = HIST(6,I,J)+TMPHIS(3,I,J)**2 | |
29913 | TMPHIS(1,I,J) = ZERO | |
29914 | TMPHIS(2,I,J) = ZERO | |
29915 | TMPHIS(3,I,J) = ZERO | |
29916 | ENDIF | |
29917 | 2 CONTINUE | |
29918 | IF (LNOETY) THEN | |
29919 | IF (TMPUFL(I).GT.ZERO) THEN | |
29920 | UNDERF(I) = UNDERF(I)+ONE | |
29921 | TMPUFL(I) = ZERO | |
29922 | ELSEIF (TMPOFL(I).GT.ZERO) THEN | |
29923 | OVERF(I) = OVERF(I)+ONE | |
29924 | TMPOFL(I) = ZERO | |
29925 | ENDIF | |
29926 | ELSE | |
29927 | DENTRY(1,I) = DENTRY(1,I)+ONE | |
29928 | ENDIF | |
29929 | 1 CONTINUE | |
29930 | ||
29931 | RETURN | |
29932 | END | |
29933 | ||
29934 | *$ CREATE DT_OUTHGR.FOR | |
29935 | *COPY DT_OUTHGR | |
29936 | * | |
29937 | *===outhgr=============================================================* | |
29938 | * | |
29939 | SUBROUTINE DT_OUTHGR(I1,I2,I3,I4,I5,I6,CHEAD,IHEAD,NEVTS,FAC, | |
29940 | & ILOGY,INORM,NMODE) | |
29941 | ||
29942 | ************************************************************************ | |
29943 | * * | |
29944 | * Plot histogram(s) to standard output unit * | |
29945 | * * | |
29946 | * I1..6 indices of histograms to be plotted * | |
29947 | * CHEAD,IHEAD header string,integer * | |
29948 | * NEVTS number of events * | |
29949 | * FAC scaling factor * | |
29950 | * ILOGY = 1 logarithmic y-axis * | |
29951 | * INORM normalization * | |
29952 | * = 0 no further normalization (FAC is obsolete) * | |
29953 | * = 1 per event and bin width * | |
29954 | * = 2 per entry and bin width * | |
29955 | * = 3 per bin entry * | |
29956 | * = 4 per event and "bin width" x1^2...x2^2 * | |
29957 | * = 5 per event and "log. bin width" ln x1..ln x2 * | |
29958 | * = 6 per event * | |
29959 | * MODE = 0 no output but normalization applied * | |
29960 | * = 1 all valid histograms separately (small frame) * | |
29961 | * all valid histograms separately (small frame) * | |
29962 | * = -1 and tables as histograms * | |
29963 | * = 2 all valid histograms (one plot, wide frame) * | |
29964 | * all valid histograms (one plot, wide frame) * | |
29965 | * = -2 and tables as histograms * | |
29966 | * * | |
29967 | * * | |
29968 | * Note: All histograms to be plotted with one call to this * | |
29969 | * subroutine and |MODE|=2 must have the same bin structure! * | |
29970 | * There is no test included ensuring this fact. * | |
29971 | * * | |
29972 | * This version dated 23.4.95 is written by S. Roesler. * | |
29973 | ************************************************************************ | |
29974 | ||
29975 | IMPLICIT DOUBLE PRECISION(A-H,O-Z) | |
29976 | SAVE | |
29977 | PARAMETER ( LINP = 10 , | |
29978 | & LOUT = 6 , | |
29979 | & LDAT = 9 ) | |
29980 | ||
29981 | CHARACTER*72 CHEAD | |
29982 | ||
29983 | PARAMETER (ZERO = 0.0D0, | |
29984 | & IZERO = 0, | |
29985 | & ONE = 1.0D0, | |
29986 | & TWO = 2.0D0, | |
29987 | & OHALF = 0.5D0, | |
29988 | & EPS = 1.0D-5, | |
29989 | & TINY = 1.0D-8, | |
29990 | & SMALL = -1.0D8, | |
29991 | & RLARGE = 1.0D8 ) | |
29992 | ||
29993 | * histograms | |
29994 | PARAMETER (NHIS=150, NDIM=250) | |
29995 | COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS), | |
29996 | & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL | |
29997 | ||
29998 | PARAMETER (NDIM2 = 2*NDIM) | |
29999 | DIMENSION XX(NDIM2),YY(NDIM2) | |
30000 | ||
30001 | PARAMETER (NHISTO = 6) | |
30002 | DIMENSION YY1(NDIM,NHISTO),XX1(NDIM,NHISTO),IDX1(NHISTO), | |
30003 | & IDX(NHISTO) | |
30004 | ||
30005 | CHARACTER*43 CNORM(0:8) | |
30006 | DATA CNORM /'no further normalization ', | |
30007 | & 'per event and bin width ', | |
30008 | & 'per entry1 and bin width ', | |
30009 | & 'per bin entry ', | |
30010 | & 'per event and "bin width" x1^2...x2^2 ', | |
30011 | & 'per event and "log. bin width" ln x1..ln x2', | |
30012 | & 'per event ', | |
30013 | & 'per bin entry1 ', | |
30014 | & 'per entry2 and bin width '/ | |
30015 | ||
30016 | IDX1(1) = I1 | |
30017 | IDX1(2) = I2 | |
30018 | IDX1(3) = I3 | |
30019 | IDX1(4) = I4 | |
30020 | IDX1(5) = I5 | |
30021 | IDX1(6) = I6 | |
30022 | ||
30023 | MODE = NMODE | |
30024 | ||
30025 | * initialization if "wide frame" is requested | |
30026 | IF (ABS(MODE).EQ.2) THEN | |
30027 | DO 1 I=1,NHISTO | |
30028 | DO 2 J=1,NDIM | |
30029 | XX1(J,I) = ZERO | |
30030 | YY1(J,I) = ZERO | |
30031 | 2 CONTINUE | |
30032 | 1 CONTINUE | |
30033 | ENDIF | |
30034 | ||
30035 | * plot header | |
30036 | WRITE(LOUT,'(/1X,A,I3,/,1X,70A1)') CHEAD,IHEAD,('=',II=1,70) | |
30037 | ||
30038 | * check histogram indices | |
30039 | NHI = 0 | |
30040 | DO 3 I=1,NHISTO | |
30041 | IF ((IDX1(I).GE.1).AND.(IDX1(I).LE.IHISL)) THEN | |
30042 | IF (ISWI(IDX1(I)).NE.0) THEN | |
30043 | IF (DENTRY(1,IDX1(I)).LT.ONE) THEN | |
30044 | WRITE(LOUT,1000) | |
30045 | & IDX1(I),UNDERF(IDX1(I)),OVERF(IDX1(I)) | |
30046 | 1000 FORMAT(/,1X,'OUTHGR: warning! no entries in', | |
30047 | & ' histogram ',I3,/,21X,'underflows:',F10.0, | |
30048 | & ' overflows: ',F10.0) | |
30049 | ELSE | |
30050 | NHI = NHI+1 | |
30051 | IDX(NHI) = IDX1(I) | |
30052 | ENDIF | |
30053 | ENDIF | |
30054 | ENDIF | |
30055 | 3 CONTINUE | |
30056 | IF (NHI.EQ.0) THEN | |
30057 | WRITE(LOUT,1001) | |
30058 | 1001 FORMAT(/,1X,'OUTHGR: warning! histogram indices not valid') | |
30059 | RETURN | |
30060 | ENDIF | |
30061 | ||
30062 | * check normalization request | |
30063 | IF ( ((FAC.EQ.ZERO).AND.(INORM.NE.0)).OR. | |
30064 | & ((NEVTS.LT.1).AND.((INORM.EQ.1).OR.(INORM.EQ.4).OR. | |
30065 | & (INORM.EQ.5).OR.(INORM.EQ.6))).OR. | |
30066 | & (INORM.LT.0).OR.(INORM.GT.8) ) THEN | |
30067 | WRITE(LOUT,1002) NEVTS,INORM,FAC | |
30068 | 1002 FORMAT(/,1X,'OUTHGR: warning! normalization request not ', | |
30069 | & 'valid',/,21X,'NEVTS = ',I7,4X,'INORM = ',I2,4X, | |
30070 | & 'FAC = ',E11.4) | |
30071 | RETURN | |
30072 | ENDIF | |
30073 | ||
30074 | WRITE(LOUT,'(/,1X,A,I8)') 'number of events:',NEVTS | |
30075 | ||
30076 | * apply normalization | |
30077 | DO 4 N=1,NHI | |
30078 | ||
30079 | I = IDX(N) | |
30080 | ||
30081 | IF (ISWI(I).EQ.1) THEN | |
30082 | WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I) | |
30083 | 1003 FORMAT(/,1X,'histo.',I4,', linear binning from',2X,E10.4, | |
30084 | & ' to',2X,E10.4,',',2X,I3,' bins') | |
30085 | ELSEIF (ISWI(I).EQ.2) THEN | |
30086 | WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I) | |
30087 | WRITE(LOUT,1007) | |
30088 | 1007 FORMAT(1X,'user defined bin structure') | |
30089 | ELSEIF (ISWI(I).EQ.3) THEN | |
30090 | WRITE(LOUT,1004) | |
30091 | & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I) | |
30092 | 1004 FORMAT(/,1X,'histo.',I4,', logar. binning from',2X,E10.4, | |
30093 | & ' to',2X,E10.4,',',2X,I3,' bins') | |
30094 | ELSEIF (ISWI(I).EQ.4) THEN | |
30095 | WRITE(LOUT,1004) | |
30096 | & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I) | |
30097 | WRITE(LOUT,1007) | |
30098 | ELSE | |
30099 | WRITE(LOUT,1008) ISWI(I) | |
30100 | 1008 FORMAT(/,1X,'warning! inconsistent bin structure flag ',I4) | |
30101 | ENDIF | |
30102 | WRITE(LOUT,1005) DENTRY(1,I),DENTRY(2,I),UNDERF(I),OVERF(I) | |
30103 | 1005 FORMAT(13X,'entries:',2F9.0,' underfl.:',F8.0, | |
30104 | & ' overfl.:',F8.0) | |
30105 | WRITE(LOUT,1009) CNORM(INORM) | |
30106 | 1009 FORMAT(1X,'normalization: ',A,/) | |
30107 | ||
30108 | DO 5 K=1,IBINS(I) | |
30109 | CALL DT_GETBIN(I,K,NEVTS,INORM,XLOW,XHI,XMEAN,YMEAN,YERR) | |
30110 | YMEAN = FAC*YMEAN | |
30111 | YERR = FAC*YERR | |
30112 | WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,YERR,HIST(2,I,K) | |
30113 | WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,YERR,HIST(2,I,K) | |
30114 | 1006 FORMAT(1X,5E11.3) | |
30115 | * small frame | |
30116 | II = 2*K | |
30117 | XX(II-1) = HIST(1,I,K) | |
30118 | XX(II) = HIST(1,I,K+1) | |
30119 | YY(II-1) = YMEAN | |
30120 | YY(II) = YMEAN | |
30121 | * wide frame | |
30122 | XX1(K,N) = XMEAN | |
30123 | IF ((ISWI(I).EQ.3).OR.(ISWI(I).EQ.4)) | |
30124 | & XX1(K,N) = LOG10(XMEAN) | |
30125 | YY1(K,N) = YMEAN | |
30126 | 5 CONTINUE | |
30127 | ||
30128 | * plot small frame | |
30129 | IF (ABS(MODE).EQ.1) THEN | |
30130 | IBIN2 = 2*IBINS(I) | |
30131 | WRITE(LOUT,'(/,1X,A)') 'Preview:' | |
30132 | IF(ILOGY.EQ.1) THEN | |
30133 | CALL DT_XGLOGY(IBIN2,1,XX,YY,YY) | |
30134 | ELSE | |
30135 | CALL DT_XGRAPH(IBIN2,1,XX,YY,YY) | |
30136 | ENDIF | |
30137 | ENDIF | |
30138 | ||
30139 | 4 CONTINUE | |
30140 | ||
30141 | * plot wide frame | |
30142 | IF (ABS(MODE).EQ.2) THEN | |
30143 | WRITE(LOUT,'(/,1X,A)') 'Preview:' | |
30144 | NSIZE = NDIM*NHISTO | |
30145 | DXLOW = HIST(1,IDX(1),1) | |
30146 | DDX = ABS(HIST(1,IDX(1),2)-HIST(1,IDX(1),1)) | |
30147 | YLOW = RLARGE | |
30148 | YHI = SMALL | |
30149 | DO 6 I=1,NHISTO | |
30150 | DO 7 J=1,NDIM | |
30151 | IF (YY1(J,I).LT.YLOW) THEN | |
30152 | IF (ILOGY.EQ.1) THEN | |
30153 | IF (YY1(J,I).GT.ZERO) YLOW = YY1(J,I) | |
30154 | ELSE | |
30155 | YLOW = YY1(J,I) | |
30156 | ENDIF | |
30157 | ENDIF | |
30158 | IF (YY1(J,I).GT.YHI) YHI = YY1(J,I) | |
30159 | 7 CONTINUE | |
30160 | 6 CONTINUE | |
30161 | DY = (YHI-YLOW)/DBLE(NDIM) | |
30162 | IF (DY.LE.ZERO) THEN | |
30163 | WRITE(LOUT,'(1X,A,6I4,A,2E12.4)') | |
30164 | & 'OUTHGR: warning! zero bin width for histograms ', | |
30165 | & IDX,': ',YLOW,YHI | |
30166 | RETURN | |
30167 | ENDIF | |
30168 | IF (ILOGY.EQ.1) THEN | |
30169 | YLOW = LOG10(YLOW) | |
30170 | DY = (LOG10(YHI)-YLOW)/100.0D0 | |
30171 | DO 8 I=1,NHISTO | |
30172 | DO 9 J=1,NDIM | |
30173 | IF (YY1(J,I).LE.ZERO) THEN | |
30174 | YY1(J,I) = YLOW | |
30175 | ELSE | |
30176 | YY1(J,I) = LOG10(YY1(J,I)) | |
30177 | ENDIF | |
30178 | 9 CONTINUE | |
30179 | 8 CONTINUE | |
30180 | ENDIF | |
30181 | CALL DT_SRPLOT(XX1,YY1,NSIZE,NHISTO,NDIM,DXLOW,DDX,YLOW,DY) | |
30182 | ENDIF | |
30183 | ||
30184 | RETURN | |
30185 | END | |
30186 | ||
30187 | *$ CREATE DT_GETBIN.FOR | |
30188 | *COPY DT_GETBIN | |
30189 | * | |
30190 | *===getbin=============================================================* | |
30191 | * | |
30192 | SUBROUTINE DT_GETBIN(IHIS,IBIN,KEVT,NORM,XLOW,XHI, | |
30193 | & XMEAN,YMEAN,YERR) | |
30194 | ||
30195 | ************************************************************************ | |
30196 | * This version dated 23.4.95 is written by S. Roesler. * | |
30197 | ************************************************************************ | |
30198 | ||
30199 | IMPLICIT DOUBLE PRECISION(A-H,O-Z) | |
30200 | SAVE | |
30201 | PARAMETER ( LINP = 10 , | |
30202 | & LOUT = 6 , | |
30203 | & LDAT = 9 ) | |
30204 | ||
30205 | PARAMETER (ZERO = 0.0D0, | |
30206 | & ONE = 1.0D0, | |
30207 | & TINY35 = 1.0D-35) | |
30208 | ||
30209 | * histograms | |
30210 | PARAMETER (NHIS=150, NDIM=250) | |
30211 | COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS), | |
30212 | & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL | |
30213 | ||
30214 | XLOW = HIST(1,IHIS,IBIN) | |
30215 | XHI = HIST(1,IHIS,IBIN+1) | |
30216 | IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN | |
30217 | XLOW = 10**XLOW | |
30218 | XHI = 10**XHI | |
30219 | ENDIF | |
30220 | IF (NORM.EQ.2) THEN | |
30221 | DX = XHI-XLOW | |
30222 | NEVT = INT(DENTRY(1,IHIS)) | |
30223 | ELSEIF (NORM.EQ.3) THEN | |
30224 | DX = ONE | |
30225 | NEVT = INT(HIST(2,IHIS,IBIN)) | |
30226 | ELSEIF (NORM.EQ.4) THEN | |
30227 | DX = XHI**2-XLOW**2 | |
30228 | NEVT = KEVT | |
30229 | ELSEIF (NORM.EQ.5) THEN | |
30230 | DX = LOG(ABS(XHI))-LOG(ABS(XLOW)) | |
30231 | NEVT = KEVT | |
30232 | ELSEIF (NORM.EQ.6) THEN | |
30233 | DX = ONE | |
30234 | NEVT = KEVT | |
30235 | ELSEIF (NORM.EQ.7) THEN | |
30236 | DX = ONE | |
30237 | NEVT = INT(HIST(7,IHIS,IBIN)) | |
30238 | ELSEIF (NORM.EQ.8) THEN | |
30239 | DX = XHI-XLOW | |
30240 | NEVT = INT(DENTRY(2,IHIS)) | |
30241 | ELSE | |
30242 | DX = ABS(XHI-XLOW) | |
30243 | NEVT = KEVT | |
30244 | ENDIF | |
30245 | IF (ABS(DX).LT.TINY35) DX = ONE | |
30246 | NEVT = MAX(NEVT,1) | |
30247 | YMEAN = HIST(5,IHIS,IBIN)/DX/DBLE(NEVT) | |
30248 | YMEAN2 = HIST(6,IHIS,IBIN)/DX**2/DBLE(NEVT) | |
30249 | YERR = SQRT(ABS(YMEAN2-YMEAN**2))/SQRT(DBLE(NEVT)) | |
30250 | YSUM = HIST(5,IHIS,IBIN) | |
30251 | IF (ABS(YSUM).LT.TINY35) YSUM = ONE | |
30252 | C XMEAN = HIST(3,IHIS,IBIN)/YSUM/MAX(HIST(2,IHIS,IBIN),ONE) | |
30253 | XMEAN = HIST(3,IHIS,IBIN)/YSUM | |
30254 | IF (XMEAN.EQ.ZERO) XMEAN = XLOW | |
30255 | ||
30256 | RETURN | |
30257 | END | |
30258 | ||
30259 | *$ CREATE DT_JOIHIS.FOR | |
30260 | *COPY DT_JOIHIS | |
30261 | * | |
30262 | *===joihis=============================================================* | |
30263 | * | |
30264 | SUBROUTINE DT_JOIHIS(IH1,IH2,COPER,FAC1,FAC2,KEVT,NORM,ILOGY,MODE) | |
30265 | ||
30266 | ************************************************************************ | |
30267 | * * | |
30268 | * Operation on histograms. * | |
30269 | * * | |
30270 | * input: IH1,IH2 histogram indices to be joined * | |
30271 | * COPER character defining the requested operation, * | |
30272 | * i.e. '+', '-', '*', '/' * | |
30273 | * FAC1,FAC2 factors for joining, i.e. * | |
30274 | * FAC1*histo1 COPER FAC2*histo2 * | |
30275 | * * | |
30276 | * This version dated 23.4.95 is written by S. Roesler. * | |
30277 | ************************************************************************ | |
30278 | ||
30279 | IMPLICIT DOUBLE PRECISION(A-H,O-Z) | |
30280 | SAVE | |
30281 | PARAMETER ( LINP = 10 , | |
30282 | & LOUT = 6 , | |
30283 | & LDAT = 9 ) | |
30284 | ||
30285 | CHARACTER COPER*1 | |
30286 | ||
30287 | PARAMETER (ZERO = 0.0D0, | |
30288 | & ONE = 1.0D0, | |
30289 | & OHALF = 0.5D0, | |
30290 | & TINY8 = 1.0D-8, | |
30291 | & SMALL = -1.0D8, | |
30292 | & RLARGE = 1.0D8 ) | |
30293 | ||
30294 | * histograms | |
30295 | PARAMETER (NHIS=150, NDIM=250) | |
30296 | COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS), | |
30297 | & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL | |
30298 | ||
30299 | PARAMETER (NDIM2 = 2*NDIM) | |
30300 | DIMENSION XX(NDIM2),YY(NDIM2),YY1(NDIM),XX1(NDIM) | |
30301 | ||
30302 | CHARACTER*43 CNORM(0:6) | |
30303 | DATA CNORM /'no further normalization ', | |
30304 | & 'per event and bin width ', | |
30305 | & 'per entry and bin width ', | |
30306 | & 'per bin entry ', | |
30307 | & 'per event and "bin width" x1^2...x2^2 ', | |
30308 | & 'per event and "log. bin width" ln x1..ln x2', | |
30309 | & 'per event '/ | |
30310 | ||
30311 | * check histogram indices | |
30312 | IF ((IH1.LT. 1).OR.(IH2.LT. 1).OR. | |
30313 | & (IH1.GT.IHISL).OR.(IH2.GT.IHISL)) THEN | |
30314 | WRITE(LOUT,1000) IH1,IH2,IHISL | |
30315 | 1000 FORMAT(1X,'JOIHIS: warning! inconsistent histogram ', | |
30316 | & 'indices (',I3,',',I3,'),',/,21X,'valid range: 1,',I3) | |
30317 | GOTO 9999 | |
30318 | ENDIF | |
30319 | ||
30320 | * check bin structure of histograms to be joined | |
30321 | IF (IBINS(IH1).NE.IBINS(IH2)) THEN | |
30322 | WRITE(LOUT,1001) IH1,IH2,IBINS(IH1),IBINS(IH2) | |
30323 | 1001 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3, | |
30324 | & ' and ',I3,' failed',/,21X, | |
30325 | & 'due to different numbers of bins (',I3,',',I3,')') | |
30326 | GOTO 9999 | |
30327 | ENDIF | |
30328 | DO 1 K=1,IBINS(IH1)+1 | |
30329 | IF (ABS(HIST(1,IH1,K)-HIST(1,IH2,K)).GT.TINY8) THEN | |
30330 | WRITE(LOUT,1002) IH1,IH2,K,HIST(1,IH1,K),HIST(1,IH2,K) | |
30331 | 1002 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3, | |
30332 | & ' and ',I3,' failed at bin edge ',I3,/,21X, | |
30333 | & 'X1,X2 = ',2E11.4) | |
30334 | GOTO 9999 | |
30335 | ENDIF | |
30336 | 1 CONTINUE | |
30337 | ||
30338 | WRITE(LOUT,1003) IH1,IH2,COPER,FAC1,FAC2 | |
30339 | 1003 FORMAT(1X,'JOIHIS: joining histograms ',I3,',',I3,' with ', | |
30340 | & 'operation ',A,/,11X,'and factors ',2E11.4) | |
30341 | WRITE(LOUT,1004) CNORM(NORM) | |
30342 | 1004 FORMAT(1X,'normalization: ',A,/) | |
30343 | ||
30344 | DO 2 K=1,IBINS(IH1) | |
30345 | CALL DT_GETBIN(IH1,K,KEVT,NORM,XLOW1,XHI1,XMEAN1,YMEAN1,YERR1) | |
30346 | CALL DT_GETBIN(IH2,K,KEVT,NORM,XLOW2,XHI2,XMEAN2,YMEAN2,YERR2) | |
30347 | XLOW = XLOW1 | |
30348 | XHI = XHI1 | |
30349 | XMEAN = OHALF*(XMEAN1+XMEAN2) | |
30350 | IF (COPER.EQ.'+') THEN | |
30351 | YMEAN = FAC1*YMEAN1+FAC2*YMEAN2 | |
30352 | ELSEIF (COPER.EQ.'*') THEN | |
30353 | YMEAN = FAC1*YMEAN1*FAC2*YMEAN2 | |
30354 | ELSEIF (COPER.EQ.'/') THEN | |
30355 | IF (YMEAN2.EQ.ZERO) THEN | |
30356 | YMEAN = ZERO | |
30357 | ELSE | |
30358 | IF (FAC2.EQ.ZERO) FAC2 = ONE | |
30359 | YMEAN = FAC1*YMEAN1/(FAC2*YMEAN2) | |
30360 | ENDIF | |
30361 | ELSE | |
30362 | GOTO 9998 | |
30363 | ENDIF | |
30364 | WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K) | |
30365 | WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K) | |
30366 | 1006 FORMAT(1X,5E11.3) | |
30367 | * small frame | |
30368 | II = 2*K | |
30369 | XX(II-1) = HIST(1,IH1,K) | |
30370 | XX(II) = HIST(1,IH1,K+1) | |
30371 | YY(II-1) = YMEAN | |
30372 | YY(II) = YMEAN | |
30373 | * wide frame | |
30374 | XX1(K) = XMEAN | |
30375 | IF ((ISWI(IH1).EQ.3).OR.(ISWI(IH1).EQ.4)) XX1(K) = LOG10(XMEAN) | |
30376 | YY1(K) = YMEAN | |
30377 | 2 CONTINUE | |
30378 | ||
30379 | * plot small frame | |
30380 | IF (ABS(MODE).EQ.1) THEN | |
30381 | IBIN2 = 2*IBINS(IH1) | |
30382 | WRITE(LOUT,'(/,1X,A)') 'Preview:' | |
30383 | IF(ILOGY.EQ.1) THEN | |
30384 | CALL DT_XGLOGY(IBIN2,1,XX,YY,YY) | |
30385 | ELSE | |
30386 | CALL DT_XGRAPH(IBIN2,1,XX,YY,YY) | |
30387 | ENDIF | |
30388 | ENDIF | |
30389 | ||
30390 | * plot wide frame | |
30391 | IF (ABS(MODE).EQ.2) THEN | |
30392 | WRITE(LOUT,'(/,1X,A)') 'Preview:' | |
30393 | NSIZE = NDIM | |
30394 | DXLOW = HIST(1,IH1,1) | |
30395 | DDX = ABS(HIST(1,IH1,2)-HIST(1,IH1,1)) | |
30396 | YLOW = RLARGE | |
30397 | YHI = SMALL | |
30398 | DO 3 I=1,NDIM | |
30399 | IF (YY1(I).LT.YLOW) THEN | |
30400 | IF (ILOGY.EQ.1) THEN | |
30401 | IF (YY1(I).GT.ZERO) YLOW = YY1(I) | |
30402 | ELSE | |
30403 | YLOW = YY1(I) | |
30404 | ENDIF | |
30405 | ENDIF | |
30406 | IF (YY1(I).GT.YHI) YHI = YY1(I) | |
30407 | 3 CONTINUE | |
30408 | DY = (YHI-YLOW)/DBLE(NDIM) | |
30409 | IF (DY.LE.ZERO) THEN | |
30410 | WRITE(LOUT,'(1X,A,2I4,A,2E12.4)') | |
30411 | & 'JOIHIS: warning! zero bin width for histograms ', | |
30412 | & IH1,IH2,': ',YLOW,YHI | |
30413 | RETURN | |
30414 | ENDIF | |
30415 | IF (ILOGY.EQ.1) THEN | |
30416 | YLOW = LOG10(YLOW) | |
30417 | DY = (LOG10(YHI)-YLOW)/100.0D0 | |
30418 | DO 4 I=1,NDIM | |
30419 | IF (YY1(I).LE.ZERO) THEN | |
30420 | YY1(I) = YLOW | |
30421 | ELSE | |
30422 | YY1(I) = LOG10(YY1(I)) | |
30423 | ENDIF | |
30424 | 4 CONTINUE | |
30425 | ENDIF | |
30426 | CALL DT_SRPLOT(XX1,YY1,NSIZE,1,NDIM,DXLOW,DDX,YLOW,DY) | |
30427 | ENDIF | |
30428 | ||
30429 | RETURN | |
30430 | ||
30431 | 9998 CONTINUE | |
30432 | WRITE(LOUT,1005) COPER | |
30433 | 1005 FORMAT(1X,'JOIHIS: unknown operation ',A) | |
30434 | ||
30435 | 9999 CONTINUE | |
30436 | RETURN | |
30437 | END | |
30438 | ||
30439 | *$ CREATE DT_XGRAPH.FOR | |
30440 | *COPY DT_XGRAPH | |
30441 | * | |
30442 | *===qgraph=============================================================* | |
30443 | * | |
30444 | SUBROUTINE DT_XGRAPH(N,IARG,X,Y1,Y2) | |
30445 | C*********************************************************************** | |
30446 | C | |
30447 | C calculate quasi graphic picture with 25 lines and 79 columns | |
30448 | C ranges will be chosen automatically | |
30449 | C | |
30450 | C input N dimension of input fields | |
30451 | C IARG number of curves (fields) to plot | |
30452 | C X field of X | |
30453 | C Y1 field of Y1 | |
30454 | C Y2 field of Y2 | |
30455 | C | |
30456 | C This subroutine is written by R. Engel. | |
30457 | C*********************************************************************** | |
30458 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
30459 | SAVE | |
30460 | ||
30461 | PARAMETER ( LINP = 10 , | |
30462 | & LOUT = 6 , | |
30463 | & LDAT = 9 ) | |
30464 | C | |
30465 | DIMENSION X(N),Y1(N),Y2(N) | |
30466 | PARAMETER (EPS=1.D-30) | |
30467 | PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20) | |
30468 | CHARACTER SYMB(5) | |
30469 | CHARACTER COL(0:149,0:49) | |
30470 | C | |
30471 | DATA SYMB /'0','e','z','#','x'/ | |
30472 | C | |
30473 | ISPALT=IBREIT-10 | |
30474 | C | |
30475 | C*** automatic range fitting | |
30476 | C | |
30477 | XMAX=X(1) | |
30478 | XMIN=X(1) | |
30479 | DO 600 I=1,N | |
30480 | XMAX=MAX(X(I),XMAX) | |
30481 | XMIN=MIN(X(I),XMIN) | |
30482 | 600 CONTINUE | |
30483 | XZOOM=(XMAX-XMIN)/DBLE(ISPALT) | |
30484 | C | |
30485 | ITEST=0 | |
30486 | DO 1100 K=0,IZEIL-1 | |
30487 | ITEST=ITEST+1 | |
30488 | IF (ITEST.EQ.IYRAST) THEN | |
30489 | DO 1010 L=1,ISPALT-1 | |
30490 | COL(L,K)='-' | |
30491 | 1010 CONTINUE | |
30492 | COL(ISPALT,K)='+' | |
30493 | ITEST=0 | |
30494 | DO 1020 L=0,ISPALT-1,IXRAST | |
30495 | COL(L,K)='+' | |
30496 | 1020 CONTINUE | |
30497 | ELSE | |
30498 | DO 1030 L=1,ISPALT-1 | |
30499 | COL(L,K)=' ' | |
30500 | 1030 CONTINUE | |
30501 | DO 1040 L=0,ISPALT-1,IXRAST | |
30502 | COL(L,K)='|' | |
30503 | 1040 CONTINUE | |
30504 | COL(ISPALT,K)='|' | |
30505 | ENDIF | |
30506 | 1100 CONTINUE | |
30507 | C | |
30508 | C*** plot curve Y1 | |
30509 | C | |
30510 | YMAX=Y1(1) | |
30511 | YMIN=Y1(1) | |
30512 | DO 500 I=1,N | |
30513 | YMAX=MAX(Y1(I),YMAX) | |
30514 | YMIN=MIN(Y1(I),YMIN) | |
30515 | 500 CONTINUE | |
30516 | IF(IARG.GT.1) THEN | |
30517 | DO 550 I=1,N | |
30518 | YMAX=MAX(Y2(I),YMAX) | |
30519 | YMIN=MIN(Y2(I),YMIN) | |
30520 | 550 CONTINUE | |
30521 | ENDIF | |
30522 | YMAX=(YMAX-YMIN)/40.0D0+YMAX | |
30523 | YMIN=YMIN-(YMAX-YMIN)/40.0D0 | |
30524 | YZOOM=(YMAX-YMIN)/DBLE(IZEIL) | |
30525 | IF(YZOOM.LT.EPS) THEN | |
30526 | WRITE(LOUT,'(1X,A)') | |
30527 | & 'XGRAPH:WARNING: MIN = MAX, OUTPUT SUPPRESSED' | |
30528 | RETURN | |
30529 | ENDIF | |
30530 | C | |
30531 | C*** plot curve Y1 | |
30532 | C | |
30533 | ILAST=-1 | |
30534 | LLAST=-1 | |
30535 | DO 1200 K=1,N | |
30536 | L=NINT((X(K)-XMIN)/XZOOM) | |
30537 | I=NINT((YMAX-Y1(K))/YZOOM) | |
30538 | IF(ILAST.GE.0) THEN | |
30539 | LD = L-LLAST | |
30540 | ID = I-ILAST | |
30541 | DO 55 II=0,LD,SIGN(1,LD) | |
30542 | DO 66 KK=0,ID,SIGN(1,ID) | |
30543 | COL(II+LLAST,KK+ILAST)=SYMB(1) | |
30544 | 66 CONTINUE | |
30545 | 55 CONTINUE | |
30546 | ELSE | |
30547 | COL(L,I)=SYMB(1) | |
30548 | ENDIF | |
30549 | ILAST = I | |
30550 | LLAST = L | |
30551 | 1200 CONTINUE | |
30552 | C | |
30553 | IF(IARG.GT.1) THEN | |
30554 | C | |
30555 | C*** plot curve Y2 | |
30556 | C | |
30557 | DO 1250 K=1,N | |
30558 | L=NINT((X(K)-XMIN)/XZOOM) | |
30559 | I=NINT((YMAX-Y2(K))/YZOOM) | |
30560 | COL(L,I)=SYMB(2) | |
30561 | 1250 CONTINUE | |
30562 | ENDIF | |
30563 | C | |
30564 | C*** write it | |
30565 | C | |
30566 | WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT) | |
30567 | C | |
30568 | C*** write range of X | |
30569 | C | |
30570 | XZOOM = (XMAX-XMIN)/DBLE(7) | |
30571 | WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7) | |
30572 | C | |
30573 | DO 1300 K=0,IZEIL-1 | |
30574 | YPOS=YMAX-((DBLE(K)+0.5D0)*YZOOM) | |
30575 | WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT) | |
30576 | 110 FORMAT(1X,1PE9.2,70A1) | |
30577 | 1300 CONTINUE | |
30578 | C | |
30579 | C*** write range of X | |
30580 | C | |
30581 | XZOOM = (XMAX-XMIN)/DBLE(7) | |
30582 | WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7) | |
30583 | WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT) | |
30584 | 120 FORMAT(6X,7(1PE10.3)) | |
30585 | END | |
30586 | ||
30587 | *$ CREATE DT_XGLOGY.FOR | |
30588 | *COPY DT_XGLOGY | |
30589 | * | |
30590 | *===qglogy=============================================================* | |
30591 | * | |
30592 | SUBROUTINE DT_XGLOGY(N,IARG,X,Y1,Y2) | |
30593 | C*********************************************************************** | |
30594 | C | |
30595 | C calculate quasi graphic picture with 25 lines and 79 columns | |
30596 | C logarithmic y axis | |
30597 | C ranges will be chosen automatically | |
30598 | C | |
30599 | C input N dimension of input fields | |
30600 | C IARG number of curves (fields) to plot | |
30601 | C X field of X | |
30602 | C Y1 field of Y1 | |
30603 | C Y2 field of Y2 | |
30604 | C | |
30605 | C This subroutine is written by R. Engel. | |
30606 | C*********************************************************************** | |
30607 | C | |
30608 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
30609 | SAVE | |
30610 | ||
30611 | PARAMETER ( LINP = 10 , | |
30612 | & LOUT = 6 , | |
30613 | & LDAT = 9 ) | |
30614 | DIMENSION X(N),Y1(N),Y2(N) | |
30615 | PARAMETER (EPS=1.D-30) | |
30616 | PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20) | |
30617 | CHARACTER SYMB(5) | |
30618 | CHARACTER COL(0:149,0:49) | |
30619 | PARAMETER (DEPS = 1.D-10) | |
30620 | C | |
30621 | DATA SYMB /'0','e','z','#','x'/ | |
30622 | C | |
30623 | ISPALT=IBREIT-10 | |
30624 | C | |
30625 | C*** automatic range fitting | |
30626 | C | |
30627 | XMAX=X(1) | |
30628 | XMIN=X(1) | |
30629 | DO 600 I=1,N | |
30630 | XMAX=MAX(X(I),XMAX) | |
30631 | XMIN=MIN(X(I),XMIN) | |
30632 | 600 CONTINUE | |
30633 | XZOOM=(XMAX-XMIN)/DBLE(ISPALT) | |
30634 | C | |
30635 | ITEST=0 | |
30636 | DO 1100 K=0,IZEIL-1 | |
30637 | ITEST=ITEST+1 | |
30638 | IF (ITEST.EQ.IYRAST) THEN | |
30639 | DO 1010 L=1,ISPALT-1 | |
30640 | COL(L,K)='-' | |
30641 | 1010 CONTINUE | |
30642 | COL(ISPALT,K)='+' | |
30643 | ITEST=0 | |
30644 | DO 1020 L=0,ISPALT-1,IXRAST | |
30645 | COL(L,K)='+' | |
30646 | 1020 CONTINUE | |
30647 | ELSE | |
30648 | DO 1030 L=1,ISPALT-1 | |
30649 | COL(L,K)=' ' | |
30650 | 1030 CONTINUE | |
30651 | DO 1040 L=0,ISPALT-1,IXRAST | |
30652 | COL(L,K)='|' | |
30653 | 1040 CONTINUE | |
30654 | COL(ISPALT,K)='|' | |
30655 | ENDIF | |
30656 | 1100 CONTINUE | |
30657 | C | |
30658 | C*** plot curve Y1 | |
30659 | C | |
30660 | YMAX=Y1(1) | |
30661 | YMIN=MAX(Y1(1),EPS) | |
30662 | DO 500 I=1,N | |
30663 | YMAX =MAX(Y1(I),YMAX) | |
30664 | IF(Y1(I).GT.EPS) THEN | |
30665 | IF(YMIN.EQ.EPS) THEN | |
30666 | YMIN = Y1(I)/10.D0 | |
30667 | ELSE | |
30668 | YMIN = MIN(Y1(I),YMIN) | |
30669 | ENDIF | |
30670 | ENDIF | |
30671 | 500 CONTINUE | |
30672 | IF(IARG.GT.1) THEN | |
30673 | DO 550 I=1,N | |
30674 | YMAX=MAX(Y2(I),YMAX) | |
30675 | IF(Y2(I).GT.EPS) THEN | |
30676 | IF(YMIN.EQ.EPS) THEN | |
30677 | YMIN = Y2(I) | |
30678 | ELSE | |
30679 | YMIN = MIN(Y2(I),YMIN) | |
30680 | ENDIF | |
30681 | ENDIF | |
30682 | 550 CONTINUE | |
30683 | ENDIF | |
30684 | C | |
30685 | DO 560 I=1,N | |
30686 | Y1(I) = MAX(Y1(I),YMIN) | |
30687 | 560 CONTINUE | |
30688 | IF(IARG.GT.1) THEN | |
30689 | DO 570 I=1,N | |
30690 | Y2(I) = MAX(Y2(I),YMIN) | |
30691 | 570 CONTINUE | |
30692 | ENDIF | |
30693 | C | |
30694 | IF(YMAX.LE.YMIN) THEN | |
30695 | WRITE(LOUT,'(/1X,A,2E12.3,/)') | |
30696 | & 'XGLOGY:ERROR:YMIN,YMAX ',YMIN,YMAX | |
30697 | WRITE(LOUT,'(1X,A)') 'MIN = MAX, OUTPUT SUPPRESSED' | |
30698 | RETURN | |
30699 | ENDIF | |
30700 | C | |
30701 | YMA=(LOG10(YMAX)-LOG10(YMIN))/20.0D0+LOG10(YMAX) | |
30702 | YMI=LOG10(YMIN)-(LOG10(YMAX)-LOG10(YMIN))/20.0D0 | |
30703 | YZOOM=(YMA-YMI)/DBLE(IZEIL) | |
30704 | IF(YZOOM.LT.EPS) THEN | |
30705 | WRITE(LOUT,'(1X,A)') | |
30706 | & 'XGLOGY:WARNING: MIN = MAX, OUTPUT SUPPRESSED' | |
30707 | RETURN | |
30708 | ENDIF | |
30709 | C | |
30710 | C*** plot curve Y1 | |
30711 | C | |
30712 | ILAST=-1 | |
30713 | LLAST=-1 | |
30714 | DO 1200 K=1,N | |
30715 | L=NINT((X(K)-XMIN)/XZOOM) | |
30716 | I=NINT((YMA-LOG10(Y1(K)))/YZOOM) | |
30717 | IF(ILAST.GE.0) THEN | |
30718 | LD = L-LLAST | |
30719 | ID = I-ILAST | |
30720 | DO 55 II=0,LD,SIGN(1,LD) | |
30721 | DO 66 KK=0,ID,SIGN(1,ID) | |
30722 | COL(II+LLAST,KK+ILAST)=SYMB(1) | |
30723 | 66 CONTINUE | |
30724 | 55 CONTINUE | |
30725 | ELSE | |
30726 | COL(L,I)=SYMB(1) | |
30727 | ENDIF | |
30728 | ILAST = I | |
30729 | LLAST = L | |
30730 | 1200 CONTINUE | |
30731 | C | |
30732 | IF(IARG.GT.1) THEN | |
30733 | C | |
30734 | C*** plot curve Y2 | |
30735 | C | |
30736 | DO 1250 K=1,N | |
30737 | L=NINT((X(K)-XMIN)/XZOOM) | |
30738 | I=NINT((YMA-LOG10(Y2(K)))/YZOOM) | |
30739 | COL(L,I)=SYMB(2) | |
30740 | 1250 CONTINUE | |
30741 | ENDIF | |
30742 | C | |
30743 | C*** write it | |
30744 | C | |
30745 | WRITE(LOUT,'(2X,A)') '(LOGARITHMIC Y AXIS)' | |
30746 | WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT) | |
30747 | C | |
30748 | C*** write range of X | |
30749 | C | |
30750 | XZOOM1 = (XMAX-XMIN)/DBLE(7) | |
30751 | WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7) | |
30752 | C | |
30753 | DO 1300 K=0,IZEIL-1 | |
30754 | YPOS=10.D0**(YMA-((DBLE(K)+0.5D0)*YZOOM)) | |
30755 | WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT) | |
30756 | 110 FORMAT(1X,1PE9.2,70A1) | |
30757 | 1300 CONTINUE | |
30758 | C | |
30759 | C*** write range of X | |
30760 | C | |
30761 | WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7) | |
30762 | WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT) | |
30763 | 120 FORMAT(6X,7(1PE10.3)) | |
30764 | C | |
30765 | END | |
30766 | ||
30767 | *$ CREATE DT_SRPLOT.FOR | |
30768 | *COPY DT_SRPLOT | |
30769 | * | |
30770 | *===plot===============================================================* | |
30771 | * | |
30772 | SUBROUTINE DT_SRPLOT(X,Y,N,M,MM,XO,DX,YO,DY) | |
30773 | ||
30774 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
30775 | SAVE | |
30776 | ||
30777 | PARAMETER ( LINP = 10 , | |
30778 | & LOUT = 6 , | |
30779 | & LDAT = 9 ) | |
30780 | * | |
30781 | * initial version | |
30782 | * J. Ranft, (FORTRAN-Programmierung,J.R.,Teubner, Leipzig, 72) | |
30783 | * This is a subroutine of fluka to plot Y across the page | |
30784 | * as a function of X down the page. Up to 37 curves can be | |
30785 | * plotted in the same picture with different plotting characters. | |
30786 | * Output of first 10 overprinted characters addad by FB 88 | |
30787 | * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - | |
30788 | * | |
30789 | * Input Variables: | |
30790 | * X = array containing the values of X | |
30791 | * Y = array containing the values of Y | |
30792 | * N = number of values in X and in Y | |
30793 | * can exceed the fixed number of lines | |
30794 | * M = number of different curves X,Y are containing | |
30795 | * MM = number of points in each curve i.e. N=M*MM | |
30796 | * XO = smallest value of X to be plotted | |
30797 | * DX = increment of X between subsequent lines | |
30798 | * YO = smallest value of Y to be plotted | |
30799 | * DY = increment of Y between subsequent character spaces | |
30800 | * | |
30801 | * other variables used inside: | |
30802 | * XX = numbers along the X-coordinate axis | |
30803 | * YY = numbers along the Y-coordinate axis | |
30804 | * LL = ten lines temporary storage for the plot | |
30805 | * L = character set used to plot different curves | |
30806 | * LOV = memorizes overprinted symbols | |
30807 | * the first 10 overprinted symbols are printed on | |
30808 | * the end of the line to avoid ambiguities | |
30809 | * (added by FB as considered quite helpful) | |
30810 | * | |
30811 | ********************************************************************* | |
30812 | * | |
30813 | DIMENSION XX(61),YY(61),LL(101,10) | |
30814 | DIMENSION X(N),Y(N),L(40),LOV(40,10) | |
333481d6 | 30815 | INTEGER*4 LL, L, LOV |
9aaba0d6 | 30816 | DATA L/ |
30817 | 11H*,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1HZ, | |
30818 | 21H+,1HA,1HO,1HB,1HC,1HD,1HE,1HF,1HG,1HH, | |
30819 | 31HI,1HJ,1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR, | |
30820 | 41HS,1HT,1HU,1HV,1HW,1HX,1HY,1H1,1H-,1H / | |
30821 | * | |
30822 | * | |
30823 | MN=51 | |
30824 | DO 10 I=1,MN | |
30825 | AI=I-1 | |
30826 | 10 XX(I)=XO+AI*DX | |
30827 | DO 20 I=1,11 | |
30828 | AI=I-1 | |
30829 | 20 YY(I)=YO+10.0D0*AI*DY | |
30830 | WRITE(LOUT, 500) (YY(I),I=1,11) | |
30831 | MMN=MN-1 | |
30832 | * | |
30833 | * | |
30834 | DO 90 JJ=1,MMN,10 | |
30835 | JJJ=JJ-1 | |
30836 | DO 30 I=1,101 | |
30837 | DO 30 J=1,10 | |
30838 | 30 LL(I,J)=L(40) | |
30839 | DO 40 I=1,101 | |
30840 | 40 LL(I,1)=L(39) | |
30841 | DO 50 I=1,101,10 | |
30842 | DO 50 J=1,10 | |
30843 | 50 LL(I,J)=L(38) | |
30844 | DO 60 I=1,40 | |
30845 | DO 60 J=1,10 | |
30846 | 60 LOV(I,J)=L(40) | |
30847 | * | |
30848 | * | |
30849 | DO 70 I=1,M | |
30850 | DO 70 J=1,MM | |
30851 | II=J+(I-1)*MM | |
30852 | AIX=(X(II)-(XO-DX/2.0D0))/DX+1.0D0 | |
30853 | AIY=(Y(II)-(YO-DY/2.0D0))/DY+1.0D0 | |
30854 | AIX=AIX-DBLE(JJJ) | |
30855 | * changed Sept.88 by FB to avoid INTEGER OVERFLOW | |
30856 | IF( AIX .GT. 1.D0.AND. AIX .LT. 11.D0.AND. AIY .GT. 1.D0.AND | |
30857 | + . AIY .LT. 102.D0) THEN | |
30858 | IX=INT(AIX) | |
30859 | IY=INT(AIY) | |
30860 | IF( IX.GT. 0.AND. IX.LE. 10.AND. IY.GT. 0.AND. IY.LE. 101) | |
30861 | + THEN | |
30862 | IF(LL(IY,IX).NE.L(38).AND.LL(IY,IX).NE.L(39)) LOV(I,IX) | |
30863 | + =LL(IY,IX) | |
30864 | LL(IY,IX)=L(I) | |
30865 | ENDIF | |
30866 | ENDIF | |
30867 | 70 CONTINUE | |
30868 | * | |
30869 | * | |
30870 | DO 80 I=1,10 | |
30871 | II=I+JJJ | |
30872 | III=II+1 | |
30873 | WRITE(LOUT,510) XX(II),XX(III) , (LL(J,I),J=1,101) , | |
30874 | & (LOV(J,I),J=1,10) | |
30875 | 80 CONTINUE | |
30876 | 90 CONTINUE | |
30877 | * | |
30878 | * | |
30879 | WRITE(LOUT, 520) | |
30880 | WRITE(LOUT, 500) (YY(I),I=1,11) | |
30881 | RETURN | |
30882 | * | |
30883 | 500 FORMAT(11X,11(1PE10.2),11HOVERPRINTED) | |
30884 | 510 FORMAT(1X,2(1PE10.2),101A1,1H ,10A1) | |
30885 | 520 FORMAT(20X,10('1---------'),'1') | |
30886 | END | |
30887 | ||
30888 | *$ CREATE DT_DEFSET.FOR | |
30889 | *COPY DT_DEFSET | |
30890 | * | |
30891 | *===defset=============================================================* | |
30892 | * | |
30893 | BLOCK DATA DT_DEFSET | |
30894 | ||
30895 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
30896 | SAVE | |
30897 | ||
30898 | * flags for input different options | |
30899 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
30900 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
30901 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
30902 | PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50) | |
30903 | * emulsion treatment | |
30904 | COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), | |
30905 | & NCOMPO,IEMUL | |
30906 | ||
30907 | * / DTFLG1 / | |
30908 | DATA IFRAG / 2, 1 / | |
30909 | DATA IRESCO / 1 / | |
30910 | DATA IMSHL / 1 / | |
30911 | DATA IRESRJ / 0 / | |
30912 | DATA IOULEV / -1, -1, -1, -1, -1, -1 / | |
30913 | DATA LEMCCK / .FALSE. / | |
30914 | DATA LHADRO / .FALSE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE., | |
30915 | & .TRUE.,.TRUE.,.TRUE./ | |
30916 | DATA LSEADI / .TRUE. / | |
30917 | DATA LEVAPO / .TRUE. / | |
30918 | DATA IFRAME / 1 / | |
30919 | DATA ITRSPT / 0 / | |
30920 | ||
30921 | * / DTCOMP / | |
30922 | DATA EMUFRA / NCOMPX*0.0D0 / | |
30923 | DATA IEMUMA / NCOMPX*1 / | |
30924 | DATA IEMUCH / NCOMPX*1 / | |
30925 | DATA NCOMPO / 0 / | |
30926 | DATA IEMUL / 0 / | |
30927 | ||
30928 | END | |
30929 | ||
30930 | *$ CREATE DT_HADPRP.FOR | |
30931 | *COPY DT_HADPRP | |
30932 | * | |
30933 | *===hadprp=============================================================* | |
30934 | * | |
30935 | BLOCK DATA DT_HADPRP | |
30936 | ||
30937 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
30938 | SAVE | |
30939 | ||
30940 | * auxiliary common for reggeon exchange (DTUNUC 1.x) | |
30941 | COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6), | |
30942 | & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6), | |
30943 | & IQTCHR(-6:6),MQUARK(3,39) | |
30944 | * hadron index conversion (BAMJET <--> PDG) | |
30945 | COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22), | |
30946 | & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19), | |
30947 | & IAMCIN(210) | |
30948 | * names of hadrons used in input-cards | |
30949 | CHARACTER*8 BTYPE | |
30950 | COMMON /DTPAIN/ BTYPE(30) | |
30951 | ||
30952 | * / DTQUAR / | |
30953 | *----------------------------------------------------------------------* | |
30954 | * * | |
30955 | * Quark content of particles: * | |
30956 | * index quark el. charge bar. charge isospin isospin3 * | |
30957 | * 1 = u 2/3 1/3 1/2 1/2 * | |
30958 | * -1 = ubar -2/3 -1/3 1/2 -1/2 * | |
30959 | * 2 = d -1/3 1/3 1/2 -1/2 * | |
30960 | * -2 = dbar 1/3 -1/3 1/2 1/2 * | |
30961 | * 3 = s -1/3 1/3 0 0 * | |
30962 | * -3 = sbar 1/3 -1/3 0 0 * | |
30963 | * 4 = c 2/3 1/3 0 0 * | |
30964 | * -4 = cbar -2/3 -1/3 0 0 * | |
30965 | * 5 = b -1/3 1/3 0 0 * | |
30966 | * -5 = bbar 1/3 -1/3 0 0 * | |
30967 | * 6 = t 2/3 1/3 0 0 * | |
30968 | * -6 = tbar -2/3 -1/3 0 0 * | |
30969 | * * | |
30970 | * Mquark = particle quark composition (Paprop numbering) * | |
30971 | * Iqechr = electric charge ( in 1/3 unit ) * | |
30972 | * Iqbchr = baryonic charge ( in 1/3 unit ) * | |
30973 | * Iqichr = isospin ( in 1/2 unit ), z component * | |
30974 | * Iqschr = strangeness * | |
30975 | * Iqcchr = charm * | |
30976 | * Iquchr = beauty * | |
30977 | * Iqtchr = ...... * | |
30978 | * * | |
30979 | *----------------------------------------------------------------------* | |
30980 | DATA IQECHR / -2, 1, -2, 1, 1, -2, 0, 2, -1, -1, 2, -1, 2 / | |
30981 | DATA IQBCHR / 6*-1, 0, 6*1 / | |
30982 | DATA IQICHR / 4*0, 1, -1, 0, 1, -1, 4*0 / | |
30983 | DATA IQSCHR / 3*0, 1, 5*0, -1, 3*0 / | |
30984 | DATA IQCCHR / 2*0, -1, 7*0, 1, 2*0 / | |
30985 | DATA IQUCHR / 0, 1, 9*0, -1, 0 / | |
30986 | DATA IQTCHR / -1, 11*0, 1 / | |
30987 | DATA MQUARK / | |
30988 | & 2, 1, 1, -2,-1,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
30989 | & 0, 0, 0, 0, 0, 0, 2, 2, 1, -2,-2,-1, 0, 0, 0, | |
30990 | & 0, 0, 0, 0, 0, 0, 1,-2, 0, 2,-1, 0, 1,-3, 0, | |
30991 | & 3,-1, 0, 1, 2, 3, -1,-2,-3, 0, 0, 0, 2, 2, 3, | |
30992 | & 1, 1, 3, 1, 2, 3, 1,-1, 0, 2,-3, 0, 3,-2, 0, | |
30993 | & 2,-2, 0, 3,-3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
30994 | & -1,-1,-3, -1,-2,-3, -2,-2,-3, 1, 3, 3, -1,-3,-3, | |
30995 | & 2, 3, 3, -2,-3,-3, 3, 3, 3, -3,-3,-3 / | |
30996 | ||
30997 | * / DTHAIC / | |
30998 | * (renamed) (HAdron InDex COnversion) | |
30999 | * translation table version filled up by r.e. 25.01.94 * | |
31000 | DATA IAMCIN / | |
31001 | &2212,-2212,11,-11,12, -12,22,2112,-2112,-13, | |
31002 | &13,130,211,-211,321, -321,3122,-3122,310,3112, | |
31003 | &3222,3212,111,311,-311, 0,0,0,0,0, | |
31004 | &221,213,113,-213,223, 323,313,-323,-313,10323, | |
31005 | &10313,-10323,-10313,30323,30313, -30323,-30313,3224,3214,3114, | |
31006 | &3216,3218,2224,2214,2114, 1114,12224,12214,12114,11114, | |
31007 | &99999,99999,22212,22112,32124, 31214,-2224,-2214,-2114,-1114, | |
31008 | &-12224,-12214,-12114,-11114,-2124, -1214,4*99999, | |
31009 | &5*99999, 5*99999, | |
31010 | &4*99999,331, 333,3322,3312,-3222,-3212, | |
31011 | &-3112,-3322,-3312,3224,3214, 3114,3324,3314,3334,-3224, | |
31012 | &-3214,-3114,-3324,-3314,-3334, 421,411,-411,-421,431, | |
31013 | &-431,441,423,413,-413, -423,433,-433,20443,443, | |
31014 | &-15,15,16,-16,14, -14,4122,4232,4132,4222, | |
31015 | &4212,4112,3*99999, 3*99999,-4122,-4232, | |
31016 | &-4132,-4222,-4212,-4112,99999, 5*99999, | |
31017 | &5*99999, 5*99999, | |
31018 | &10*99999, | |
31019 | &5*99999 , 20211,20111,-20211,99999,20321, | |
31020 | &-20321,20311,-20311,7*99999 , | |
31021 | &7*99999,12212,12112,99999/ | |
31022 | ||
31023 | * / DTHAIC / | |
31024 | * (HAdron InDex COnversion) | |
31025 | DATA (IPDG2(1,K),K=1,7) | |
31026 | & / -11, -12, -13, -15, -16, -14, 0/ | |
31027 | DATA (IBAM2(1,K),K=1,7) | |
31028 | & / 4, 6, 10, 131, 134, 136, 0/ | |
31029 | DATA (IPDG2(2,K),K=1,7) | |
31030 | & / 11, 12, 22, 13, 15, 16, 14/ | |
31031 | DATA (IBAM2(2,K),K=1,7) | |
31032 | & / 3, 5, 7, 11, 132, 133, 135/ | |
31033 | DATA (IPDG3(1,K),K=1,22) | |
31034 | & / -211, -321, -311, -213, -323, -313, -411, -421, | |
31035 | & -431, -413, -423, -433, 0, 0, 0, 0, | |
31036 | & 0, 0, 0, 0, 0, 0/ | |
31037 | DATA (IBAM3(1,K),K=1,22) | |
31038 | & / 14, 16, 25, 34, 38, 39, 118, 119, | |
31039 | & 121, 125, 126, 128, 0, 0, 0, 0, | |
31040 | & 0, 0, 0, 0, 0, 0/ | |
31041 | DATA (IPDG3(2,K),K=1,22) | |
31042 | & / 130, 211, 321, 310, 111, 311, 221, 213, | |
31043 | & 113, 223, 323, 313, 331, 333, 421, 411, | |
31044 | & 431, 441, 423, 413, 433, 443/ | |
31045 | DATA (IBAM3(2,K),K=1,22) | |
31046 | & / 12, 13, 15, 19, 23, 24, 31, 32, | |
31047 | & 33, 35, 36, 37, 95, 96, 116, 117, | |
31048 | & 120, 122, 123, 124, 127, 130/ | |
31049 | DATA (IPDG4(1,K),K=1,29) | |
31050 | & / -2212, -2112, -3122, -2224, -2214, -2114, -1114, -2124, | |
31051 | & -1214, -3222, -3212, -3112, -3322, -3312, -3224, -3214, | |
31052 | & -3114, -3324, -3314, -3334, -4122, -4232, -4132, -4222, | |
31053 | & -4212, -4112, 0, 0, 0/ | |
31054 | DATA (IBAM4(1,K),K=1,29) | |
31055 | & / 2, 9, 18, 67, 68, 69, 70, 75, | |
31056 | & 76, 99, 100, 101, 102, 103, 110, 111, | |
31057 | & 112, 113, 114, 115, 149, 150, 151, 152, | |
31058 | & 153, 154, 0, 0, 0/ | |
31059 | DATA (IPDG4(2,K),K=1,29) | |
31060 | & / 2212, 2112, 3122, 3112, 3222, 3212, 3224, 3214, | |
31061 | & 3114, 3216, 3218, 2224, 2214, 2114, 1114, 3322, | |
31062 | & 3312, 3224, 3214, 3114, 3324, 3314, 3334, 4122, | |
31063 | & 4232, 4132, 4222, 4212, 4112/ | |
31064 | DATA (IBAM4(2,K),K=1,29) | |
31065 | & / 1, 8, 17, 20, 21, 22, 48, 49, | |
31066 | & 50, 51, 52, 53, 54, 55, 56, 97, | |
31067 | & 98, 104, 105, 106, 107, 108, 109, 137, | |
31068 | & 138, 139, 140, 141, 142/ | |
31069 | DATA (IPDG5(1,K),K=1,19) | |
31070 | & /-10323,-10313,-30323,-30313,-12224,-12214,-12114,-11114, | |
31071 | & -20211,-20321,-20311, 0, 0, 0, 0, 0, | |
31072 | & 0, 0, 0/ | |
31073 | DATA (IBAM5(1,K),K=1,19) | |
31074 | & / 42, 43, 46, 47, 71, 72, 73, 74, | |
31075 | & 188, 191, 193, 0, 0, 0, 0, 0, | |
31076 | & 0, 0, 0/ | |
31077 | DATA (IPDG5(2,K),K=1,19) | |
31078 | & / 10323, 10313, 30323, 30313, 12224, 12214, 12114, 11114, | |
31079 | & 22212, 22112, 32124, 31214, 20443, 20211, 20111, 20321, | |
31080 | & 20311, 12212, 12112/ | |
31081 | DATA (IBAM5(2,K),K=1,19) | |
31082 | & / 40, 41, 44, 45, 57, 58, 59, 60, | |
31083 | & 63, 64, 65, 66, 129, 186, 187, 190, | |
31084 | & 192, 208, 209/ | |
31085 | ||
31086 | * / DTPAIN / | |
31087 | * internal particle names | |
31088 | DATA BTYPE / 'PROTON ' , 'APROTON ' , 'ELECTRON' , 'POSITRON' , | |
31089 | &'NEUTRIE ' , 'ANEUTRIE' , 'PHOTON ' , 'NEUTRON ' , 'ANEUTRON' , | |
31090 | &'MUON+ ' , 'MUON- ' , 'KAONLONG' , 'PION+ ' , 'PION- ' , | |
31091 | &'KAON+ ' , 'KAON- ' , 'LAMBDA ' , 'ALAMBDA ' , 'KAONSHRT' , | |
31092 | &'SIGMA- ' , 'SIGMA+ ' , 'SIGMAZER' , 'PIZERO ' , 'KAONZERO' , | |
31093 | &'AKAONZER' , 'NEUTRIM ' , 'ANEUTRIM' , 'NEUTRIT ' , 'ANEUTRIT' , | |
31094 | &'BLANK ' / | |
31095 | ||
31096 | END | |
31097 | ||
31098 | *$ CREATE DT_BLKD46.FOR | |
31099 | *COPY DT_BLKD46 | |
31100 | * | |
31101 | *===blkd46=============================================================* | |
31102 | * | |
31103 | BLOCK DATA DT_BLKD46 | |
31104 | ||
31105 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
31106 | SAVE | |
31107 | ||
31108 | PARAMETER ( AMELCT = 0.51099906 D-03 ) | |
31109 | PARAMETER ( AMMUON = 0.105658389 D+00 ) | |
31110 | ||
31111 | * particle properties (BAMJET index convention) | |
31112 | CHARACTER*8 ANAME | |
31113 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
31114 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
31115 | ||
31116 | * / DTPART / | |
31117 | * Particle masses Engel version JETSET compatible | |
31118 | C DATA (AAM(K),K=1,85) / | |
31119 | C & .9383D+00, .9383D+00, AMELCT , AMELCT , .0000D+00, | |
31120 | C & .0000D+00, .0000D+00, .9396D+00, .9396D+00, AMMUON , | |
31121 | C & AMMUON , .4977D+00, .1396D+00, .1396D+00, .4936D+00, | |
31122 | C & .4936D+00, .1116D+01, .1116D+01, .4977D+00, .1197D+01, | |
31123 | C & .1189D+01, .1193D+01, .1350D+00, .4977D+00, .4977D+00, | |
31124 | C & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00, | |
31125 | C & .5488D+00, .7669D+00, .7700D+00, .7669D+00, .7820D+00, | |
31126 | C & .8921D+00, .8962D+00, .8921D+00, .8962D+00, .1300D+01, | |
31127 | C & .1300D+01, .1300D+01, .1300D+01, .1421D+01, .1421D+01, | |
31128 | C & .1421D+01, .1421D+01, .1383D+01, .1384D+01, .1387D+01, | |
31129 | C & .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01, | |
31130 | C & .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01, | |
31131 | C & .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01, | |
31132 | C & .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01, | |
31133 | C & .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01, | |
31134 | C & .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00, | |
31135 | C & .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01 / | |
31136 | C DATA (AAM(K),K=86,183) / | |
31137 | C & .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01, | |
31138 | C & .1700D+01, .1700D+01, .1820D+01, .2030D+01, .9575D+00, | |
31139 | C & .1019D+01, .1315D+01, .1321D+01, .1189D+01, .1193D+01, | |
31140 | C & .1197D+01, .1315D+01, .1321D+01, .1383D+01, .1384D+01, | |
31141 | C & .1387D+01, .1532D+01, .1535D+01, .1672D+01, .1383D+01, | |
31142 | C & .1384D+01, .1387D+01, .1532D+01, .1535D+01, .1672D+01, | |
31143 | C & .1865D+01, .1869D+01, .1869D+01, .1865D+01, .1969D+01, | |
31144 | C & .1969D+01, .2980D+01, .2007D+01, .2010D+01, .2010D+01, | |
31145 | C & .2007D+01, .2113D+01, .2113D+01, .3686D+01, .3097D+01, | |
31146 | C & .1784D+01, .1784D+01, .0000D+00, .0000D+00, .0000D+00, | |
31147 | C & .0000D+00, .2285D+01, .2460D+01, .2460D+01, .2452D+01, | |
31148 | C & .2453D+01, .2454D+01, .2560D+01, .2560D+01, .2730D+01, | |
31149 | C & .3610D+01, .3610D+01, .3790D+01, .2285D+01, .2460D+01, | |
31150 | C & .2460D+01, .2452D+01, .2453D+01, .2454D+01, .2560D+01, | |
31151 | C & .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01, | |
31152 | C & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01, | |
31153 | C & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01, | |
31154 | C & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01, | |
31155 | C & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01, | |
31156 | C & .1250D+01, .1250D+01, .1250D+01 / | |
31157 | C DATA (AAM ( I ), I = 184,210 ) / | |
31158 | C & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00, | |
31159 | C & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00, | |
31160 | C & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00, | |
31161 | C & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00, | |
31162 | C & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00, | |
31163 | C & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00, | |
31164 | C & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00, | |
31165 | C & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00, | |
31166 | C & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/ | |
31167 | * sr 25.1.06: particle masses adjusted to Pythia | |
31168 | DATA (AAM(K),K=1,85) / | |
31169 | & .938270E+00,.938270E+00, AMELCT , AMELCT ,.000000E+00, | |
31170 | & .000000E+00,.000000E+00,.939570E+00,.939570E+00, AMMUON , | |
31171 | & AMMUON ,.497670E+00,.139570E+00,.139570E+00,.493600E+00, | |
31172 | & .493600E+00,.111568E+01,.111568E+01,.497670E+00,.119744E+01, | |
31173 | & .118937E+01,.119255E+01,.134980E+00,.497670E+00,.497670E+00, | |
31174 | & .0000D+00, .0000D+00, .0000D+00 , .0000D+00, .0000D+00, | |
31175 | & .547450E+00,.766900E+00,.768500E+00,.766900E+00,.781940E+00, | |
31176 | & .891600E+00,.896100E+00,.891600E+00,.896100E+00,.129000E+01, | |
31177 | & .129000E+01,.129000E+01,.129000E+01, .1421D+01, .1421D+01, | |
31178 | & .1421D+01, .1421D+01,.138280E+01,.138370E+01,.138720E+01, | |
31179 | & .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01, | |
31180 | & .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01, | |
31181 | & .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01, | |
31182 | & .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01, | |
31183 | & .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01, | |
31184 | & .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00, | |
31185 | & .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01 / | |
31186 | DATA (AAM(K),K=86,183) / | |
31187 | & .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01, | |
31188 | & .1700D+01, .1700D+01, .1820D+01, .2030D+01,.957770E+00, | |
31189 | & .101940E+01,.131490E+01,.132130E+01,.118937E+01,.119255E+01, | |
31190 | & .119744E+01,.131490E+01,.132130E+01,.138280E+01,.138370E+01, | |
31191 | & .138720E+01,.153180E+01, .1535D+01,.167245E+01,.138280E+01, | |
31192 | & .138370E+01,.138720E+01,.153180E+01, .1535D+01,.167245E+01, | |
31193 | & .186450E+01,.186930E+01,.186930E+01,.186450E+01,.196850E+01, | |
31194 | & .196850E+01,.297980E+01,.200670E+01, .2010D+01, .2010D+01, | |
31195 | & .200670E+01,.211240E+01,.211240E+01, .3686D+01,.309688E+01, | |
31196 | & .177700E+01,.177700E+01, .0000D+00, .0000D+00, .0000D+00, | |
31197 | & .0000D+00,.228490E+01,.246560E+01,.247030E+01,.245290E+01, | |
31198 | & .245350E+01,.245210E+01, .2560D+01, .2560D+01, .2730D+01, | |
31199 | & .3610D+01, .3610D+01, .3790D+01,.228490E+01,.246560E+01, | |
31200 | & .2460D+01,.245290E+01,.245350E+01,.245210E+01, .2560D+01, | |
31201 | & .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01, | |
31202 | & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01, | |
31203 | & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01, | |
31204 | & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01, | |
31205 | & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01, | |
31206 | & .1250D+01, .1250D+01, .1250D+01 / | |
31207 | DATA (AAM ( I ), I = 184,210 ) / | |
31208 | & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00, | |
31209 | & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00, | |
31210 | & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00, | |
31211 | & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00, | |
31212 | & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00, | |
31213 | & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00, | |
31214 | & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00, | |
31215 | & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00, | |
31216 | & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/ | |
31217 | * Particle mean lives | |
31218 | DATA (TAU(K),K=1,183) / | |
31219 | & .1000D+19, .1000D+19, .1000D+19, .1000D+19, .1000D+19, | |
31220 | & .1000D+19, .1000D+19, .9180D+03, .9180D+03, .2200D-05, | |
31221 | & .2200D-05, .5200D-07, .2600D-07, .2600D-07, .1200D-07, | |
31222 | & .1200D-07, .2600D-09, .2600D-09, .9000D-10, .1500D-09, | |
31223 | & .8000D-10, .5000D-14, .8000D-16, .0000D+00, .0000D+00, | |
31224 | & 70*.0000D+00, | |
31225 | & .0000D+00, .3000D-09, .1700D-09, .8000D-10, .1000D-13, | |
31226 | & .1500D-09, .3000D-09, .1700D-09, .0000D+00, .0000D+00, | |
31227 | & .0000D+00, .0000D+00, .0000D+00, .1000D-09, .0000D+00, | |
31228 | & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .1000D-09, | |
31229 | & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00, | |
31230 | & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00, | |
31231 | & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00, | |
31232 | & .9000D-11, .9000D-11, .9000D-11, .9000D-11, .1000D+19, | |
31233 | & .1000D+19, .0000D+00, .0000D+00, .0000D+00, .0000D+00, | |
31234 | & 40*.0000D+00, | |
31235 | & .0000D+00, .0000D+00, .0000D+00 / | |
31236 | DATA ( TAU ( I ), I = 184,210 ) / | |
31237 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, | |
31238 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, | |
31239 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, | |
31240 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, | |
31241 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, | |
31242 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, | |
31243 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, | |
31244 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00, | |
31245 | & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00/ | |
31246 | * Resonance width Gamma in GeV | |
31247 | DATA (GA(K),K= 1,85) / | |
31248 | & 30*.0000D+00, | |
31249 | & .8500D-06, .1520D+00, .1520D+00, .1520D+00, .1000D-01, | |
31250 | & .7900D-01, .7900D-01, .7900D-01, .7900D-01, .4500D+00, | |
31251 | & .4500D+00, .4500D+00, .4500D+00, .1080D+00, .1080D+00, | |
31252 | & .1080D+00, .1080D+00, .5000D-01, .5000D-01, .5000D-01, | |
31253 | & .8500D-01, .1800D+00, .1150D+00, .1150D+00, .1150D+00, | |
31254 | & .1150D+00, .2000D+00, .2000D+00, .2000D+00, .2000D+00, | |
31255 | & .2000D+00, .2000D+00, .1000D+00, .1000D+00, .2000D+00, | |
31256 | & .2000D+00, .1150D+00, .1150D+00, .1150D+00, .1150D+00, | |
31257 | & .2000D+00, .2000D+00, .2000D+00, .2000D+00, .1000D+00, | |
31258 | & .1000D+00, .2000D+00, .1000D+00, .1000D+00, .1000D+00, | |
31259 | & .1000D+00, .1000D+00, .1000D+00, .1000D+00, .2000D+00 / | |
31260 | DATA (GA(K),K= 86,183) / | |
31261 | & .2000D+00, .2000D+00, .2000D+00, .1500D+00, .1500D+00, | |
31262 | & .1500D+00, .1500D+00, .8500D-01, .1800D+00, .2000D-02, | |
31263 | & .4000D-02, .0000D+00, .0000D+00, .0000D+00, .0000D+00, | |
31264 | & .0000D+00, .0000D+00, .0000D+00, .3400D-01, .3400D-01, | |
31265 | & .3600D-01, .9000D-02, .9000D-02, .0000D+00, .3400D-01, | |
31266 | & .3400D-01, .3600D-01, .9000D-02, .9000D-02, .0000D+00, | |
31267 | & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00, | |
31268 | & .0000D+00, .0000D+00, .5000D-02, .2000D-02, .2000D-02, | |
31269 | & .5000D-02, .2000D-02, .2000D-02, .2000D-03, .7000D-03, | |
31270 | & 50*.0000D+00, | |
31271 | & .3000D+00, .3000D+00, .3000D+00 / | |
31272 | DATA ( GA ( I ), I = 184,210 ) / | |
31273 | & 2.00000000000000D-01, 2.00000000000000D-01, 3.00000000000000D-01, | |
31274 | & 3.00000000000000D-01, 3.00000000000000D-01, 2.70000000000000D-01, | |
31275 | & 2.50000000000000D-01, 2.50000000000000D-01, 2.50000000000000D-01, | |
31276 | & 2.50000000000000D-01, 1.50000000000000D-01, 1.50000000000000D-01, | |
31277 | & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01, | |
31278 | & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01, | |
31279 | & 6.00000000000000D-02, 6.00000000000000D-02, 6.00000000000000D-02, | |
31280 | & 6.00000000000000D-02, 5.50000000000000D-02, 5.50000000000000D-02, | |
31281 | & 2.00000000000000D-01, 2.00000000000000D-01, 0.00000000000000D+00/ | |
31282 | * Particle names | |
31283 | * S+1385+Sigma+(1385) L02030+Lambda0(2030) | |
31284 | * Rho77=Rho(770) Om783=Omega(783) K*14=K*(1420) and so on | |
31285 | * designation N*@@ means N*@1(@2) | |
31286 | DATA (ANAME(K),K=1,85) / | |
31287 | & 'P ','AP ','E- ','E+ ','NUE ', | |
31288 | & 'ANUE ','GAM ','NEU ','ANEU ','MUE+ ', | |
31289 | & 'MUE- ','K0L ','PI+ ','PI- ','K+ ', | |
31290 | & 'K- ','LAM ','ALAM ','K0S ','SIGM- ', | |
31291 | & 'SIGM+ ','SIGM0 ','PI0 ','K0 ','AK0 ', | |
31292 | & 'BLANK ','BLANK ','BLANK ','BLANK ','BLANK ', | |
31293 | & 'ETA550 ','RHO+77 ','RHO077 ','RHO-77 ','OM0783 ', | |
31294 | & 'K*+892 ','K*0892 ','K*-892 ','AK*089 ','KA+125 ', | |
31295 | & 'KA0125 ','KA-125 ','AKA012 ','K*+142 ','K*0142 ', | |
31296 | & 'K*-142 ','AK*014 ','S+1385 ','S01385 ','S-1385 ', | |
31297 | & 'L01820 ','L02030 ','N*++12 ','N*+ 12 ','N*012 ', | |
31298 | & 'N*-12 ','N*++16 ','N*+16 ','N*016 ','N*-16 ', | |
31299 | & 'N*+14 ','N*014 ','N*+15 ','N*015 ','N*+18 ', | |
31300 | & 'N*018 ','AN--12 ','AN*-12 ','AN*012 ','AN*+12 ', | |
31301 | & 'AN--16 ','AN*-16 ','AN*016 ','AN*+16 ','AN*-15 ', | |
31302 | & 'AN*015 ','DE*=24 ','RPI+49 ','RPI049 ','RPI-49 ', | |
31303 | & 'PIN++ ','PIN+0 ','PIN+- ','PIN-0 ','PPPI ' / | |
31304 | DATA (ANAME(K),K=86,183) / | |
31305 | & 'PNPI ','APPPI ','APNPI ','K+PPI ','K-PPI ', | |
31306 | & 'K+NPI ','K-NPI ','S+1820 ','S-2030 ','ETA* ', | |
31307 | & 'PHI ','TETA0 ','TETA- ','ASIG- ','ASIG0 ', | |
31308 | & 'ASIG+ ','ATETA0 ','ATETA+ ','SIG*+ ','SIG*0 ', | |
31309 | & 'SIG*- ','TETA*0 ','TETA* ','OMEGA- ','ASIG*- ', | |
31310 | & 'ASIG*0 ','ASIG*+ ','ATET*0 ','ATET*+ ','OMEGA+ ', | |
31311 | & 'D0 ','D+ ','D- ','AD0 ','F+ ', | |
31312 | & 'F- ','ETAC ','D*0 ','D*+ ','D*- ', | |
31313 | & 'AD*0 ','F*+ ','F*- ','PSI ','JPSI ', | |
31314 | & 'TAU+ ','TAU- ','NUET ','ANUET ','NUEM ', | |
31315 | & 'ANUEM ','C0+ ','A+ ','A0 ','C1++ ', | |
31316 | & 'C1+ ','C10 ','S+ ','S0 ','T0 ', | |
31317 | & 'XU++ ','XD+ ','XS+ ','AC0- ','AA- ', | |
31318 | & 'AA0 ','AC1-- ','AC1- ','AC10 ','AS- ', | |
31319 | & 'AS0 ','AT0 ','AXU-- ','AXD- ','AXS ', | |
31320 | & 'C1*++ ','C1*+ ','C1*0 ','S*+ ','S*0 ', | |
31321 | & 'T*0 ','XU*++ ','XD*+ ','XS*+ ','TETA++ ', | |
31322 | & 'AC1*-- ','AC1*- ','AC1*0 ','AS*- ','AS*0 ', | |
31323 | & 'AT*0 ','AXU*-- ','AXD*- ','AXS*- ','ATET-- ', | |
31324 | & 'RO ','R+ ','R- ' / | |
31325 | DATA ( ANAME ( I ), I = 184,210 ) / | |
31326 | &'AN*-14 ','AN*014 ','PI+130 ','PI0130 ','PI-130 ','F01400 ', | |
31327 | &'K*+146 ','K*-146 ','K*0146 ','AK0146 ','L01600 ','AL0160 ', | |
31328 | &'S+1660 ','S01660 ','S-1660 ','AS-166 ','AS0166 ','AS+166 ', | |
31329 | &'X01950 ','X-1950 ','AX0195 ','AX+195 ','OM-225 ','AOM+22 ', | |
31330 | &'N*+14 ','N*014 ','BLANK '/ | |
31331 | * Charge of particles and resonances | |
31332 | DATA (IICH ( I ), I = 1,210 ) / | |
31333 | & 1, -1, -1, 1, 0, 0, 0, 0, 0, 1, -1, 0, 1, -1, 1, | |
31334 | & -1, 0, 0, 0, -1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
31335 | & 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0, | |
31336 | & -1, 0, 1, 0, -1, 0, 0, 2, 1, 0, -1, 2, 1, 0, -1, | |
31337 | & 1, 0, 1, 0, 1, 0, -2, -1, 0, 1, -2, -1, 0, 1, -1, | |
31338 | & 0, 1, 1, 0, -1, 2, 1, 0, -1, 2, 1, 0, -1, 2, 0, | |
31339 | & 1, -1, 1, -1, 0, 0, 0, -1, -1, 0, 1, 0, 1, 1, 0, | |
31340 | & -1, 0, -1, -1, -1, 0, 1, 0, 1, 1, 0, 1, -1, 0, 1, | |
31341 | & -1, 0, 0, 1, -1, 0, 1, -1, 0, 0, 1, -1, 0, 0, 0, | |
31342 | & 0, 1, 1, 0, 2, 1, 0, 1, 0, 0, 2, 1, 1, -1, -1, | |
31343 | & 0, -2, -1, 0, -1, 0, 0, -2, -1, -1, 2, 1, 0, 1, 0, | |
31344 | & 0, 2, 1, 1, 2, -2, -1, 0, -1, 0, 0, -2, -1, -1, -2, | |
31345 | & 0, 1, -1, -1, 0, 1, 0, -1, 0, 1, -1, 0, 0, 0, 0, | |
31346 | & 1, 0, -1, -1, 0, 1, 0, -1, 0, 1, -1, 1, 1, 0, 0/ | |
31347 | * Particle baryonic charges | |
31348 | DATA (IIBAR ( I ), I = 1,210 ) / | |
31349 | & 1, -1, 0, 0, 0, 0, 0, 1, -1, 0, 0, 0, 0, 0, 0, | |
31350 | & 0, 1, -1, 0, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, | |
31351 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
31352 | & 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, | |
31353 | & 1, 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1, | |
31354 | & -1, 2, 0, 0, 0, 1, 1, 1, 1, 2, 2, 0, 0, 1, 1, | |
31355 | & 1, 1, 1, 1, 0, 0, 1, 1, -1, -1, -1, -1, -1, 1, 1, | |
31356 | & 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, 0, 0, 0, 0, 0, | |
31357 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
31358 | & 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, -1, -1, | |
31359 | & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 1, 1, 1, 1, 1, | |
31360 | & 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, | |
31361 | & 0, 0, 0, -1, -1, 0, 0, 0, 0, 0, 0, 0, 0, 1, -1, | |
31362 | & 1, 1, 1, -1, -1, -1, 1, 1, -1, -1, 1, -1, 1, 1, 0/ | |
31363 | * First number of decay channels used for resonances | |
31364 | * and decaying particles | |
31365 | DATA K1/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 16, 17, | |
31366 | & 18, 24, 30, 34, 38, 40, 41, 43, 44, 136, 138, 330, 327, 328, | |
31367 | & 2*330, 46, 51, 52, 54, 55, 58, | |
31368 | * 50 | |
31369 | & 60, 62, 64, 66, 68, 70, 72, 74, 82, 90, 98, 106, 109, 112, 114, | |
31370 | & 123, 140, 141, 143, 145, 146, 150, 157, 164, 168, 174, 180, 187, | |
31371 | & 194, 202, 210, 211, 213, 215, 216, 220, 227, 234, 238, 245, 252, | |
31372 | * 85 | |
31373 | & 254, 255, 256, 257, 259, 262, 265, 267, 269, 272, 276, 279, 282, | |
31374 | & 286, 290, 293, 299, 331, 335, 339, 340, 341, 343, 344, 345, 346, | |
31375 | & 347, 350, 353, 356, 358, 360, 363, 366, 369, 372, 374, 376, 379, | |
31376 | & 383, 385, 387, 391, 394, 397, 400, 402, 405, 408, 410, 412, 414, | |
31377 | & 417, 420, 425, 430, 431, 432, 433, 434, 448, 452, 457, 458, 459, | |
31378 | & 460, 461, 462, 466, 468, 470, 472, 486, 490, 495, 496, 497, 498, | |
31379 | & 499, 500, 504, 506, 508, 510, 511, 512, 513, 514, 515, 516, 517, | |
31380 | & 518, 519, 522, 523, 524, 525, 526, 527, 528, 529, 530, 531, 534, | |
31381 | & 537, 539, 541, 547, 553, 558, 563, 568, 572, 573, 574, 575, 576, | |
31382 | & 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588, 589, | |
31383 | & 590, 596, 602 / | |
31384 | * Last number of decay channels used for resonances | |
31385 | * and decaying particles | |
31386 | DATA K2/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 15, 16, 17, | |
31387 | & 23, 29, 31, 35, 39, 40, 42, 43, 45, 137, 139, 330, 327, 328, | |
31388 | & 2* 330, 50, 51, 53, 54, 57, | |
31389 | * 50 | |
31390 | & 59, 61, 63, 65, 67, 69, 71, 73, 81, 89, 97, 105, 108, 111, 113, | |
31391 | & 122, 135, 140, 142, 144, 145, 149, 156, 163, 167, 173, 179, 186, | |
31392 | & 193, 201, 209, 210, 212, 214, 215, 219, 226, 233, 237, 244, 251, | |
31393 | * 85 | |
31394 | & 253, 254, 255, 256, 258, 261, 264, 266, 268, 271, 275, 278, 281, | |
31395 | & 285, 289, 292, 298, 307, 334, 338, 339, 340, 342, 343, 344, 345, | |
31396 | & 346, 349, 352, 355, 357, 359, 362, 365, 368, 371, 373, 375, 378, | |
31397 | & 382, 384, 386, 390, 393, 396, 399, 401, 404, 407, 409, 411, 413, | |
31398 | & 416, 419, 424, 429, 430, 431, 432, 433, 447, 451, 456, 457, 458, | |
31399 | & 459, 460, 461, 465, 467, 469, 471, 485, 489, 494, 495, 496, 497, | |
31400 | & 498, 499, 503, 505, 507, 509, 510, 511, 512, 513, 514, 515, 516, | |
31401 | & 517, 518, 521, 522, 523, 524, 525, 526, 527, 528, 529, 530, 533, | |
31402 | & 536, 538, 540, 546, 552, 557, 562, 567, 571, 572, 573, 574, 575, | |
31403 | & 576, 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588, | |
31404 | & 589, 595, 601, 602 / | |
31405 | ||
31406 | END | |
31407 | ||
31408 | *$ CREATE DT_BLKD47.FOR | |
31409 | *COPY DT_BLKD47 | |
31410 | * | |
31411 | *===blkd47=============================================================* | |
31412 | * | |
31413 | BLOCK DATA DT_BLKD47 | |
31414 | ||
31415 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
31416 | SAVE | |
31417 | ||
31418 | * HADRIN: decay channel information | |
31419 | PARAMETER (IDMAX9=602) | |
31420 | CHARACTER*8 ZKNAME | |
31421 | COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3) | |
31422 | ||
31423 | * Name of decay channel | |
31424 | * Designation N*@ means N*@1(1236) | |
31425 | * @1=# means ++, @1 = = means -- | |
31426 | * Designation P+/0/- means Pi+/Pi0/Pi- , respectively | |
31427 | DATA (ZKNAME(K),K= 1, 85) / | |
31428 | & 'P ','AP ','E- ','E+ ','NUE ', | |
31429 | & 'ANUE ','GAM ','PE-NUE ','APEANU ','EANUNU ', | |
31430 | & 'E-NUAN ','3PI0 ','PI+-0 ','PIMUNU ','PIE-NU ', | |
31431 | & 'MU+NUE ','MU-NUE ','MU+NUE ','PI+PI0 ','PI++- ', | |
31432 | & 'PI+00 ','M+P0NU ','E+P0NU ','MU-NU ','PI-0 ', | |
31433 | & 'PI+-- ','PI-00 ','M-P0NU ','E-P0NU ','PPI- ', | |
31434 | & 'NPI0 ','PD-NUE ','PM-NUE ','APPI+ ','ANPI0 ', | |
31435 | & 'APE+NU ','APM+NU ','PI+PI- ','PI0PI0 ','NPI- ', | |
31436 | & 'PPI0 ','NPI+ ','LAGA ','GAGA ','GAE+E- ', | |
31437 | & 'GAGA ','GAGAP0 ','PI000 ','PI+-0 ','PI+-GA ', | |
31438 | & 'PI+0 ','PI+- ','PI00 ','PI-0 ','PI+-0 ', | |
31439 | & 'PI+- ','PI0GA ','K+PI0 ','K0PI+ ','KOPI0 ', | |
31440 | & 'K+PI- ','K-PI0 ','AK0PI- ','AK0PI0 ','K-PI+ ', | |
31441 | & 'K+PI0 ','K0PI+ ','K0PI0 ','K+PI- ','K-PI0 ', | |
31442 | & 'K0PI- ','AK0PI0 ','K-PI+ ','K+PI0 ','K0PI+ ', | |
31443 | & 'K+89P0 ','K08PI+ ','K+RO77 ','K0RO+7 ','K+OM07 ', | |
31444 | & 'K+E055 ','K0PI0 ','K+PI+ ','K089P0 ','K+8PI- ' / | |
31445 | DATA (ZKNAME(K),K= 86,170) / | |
31446 | & 'K0R077 ','K+R-77 ','K+R-77 ','K0OM07 ','K0E055 ', | |
31447 | & 'K-PI0 ','K0PI- ','K-89P0 ','AK08P- ','K-R077 ', | |
31448 | & 'AK0R-7 ','K-OM07 ','K-E055 ','AK0PI0 ','K-PI+ ', | |
31449 | & 'AK08P0 ','K-8PI+ ','AK0R07 ','AK0OM7 ','AK0E05 ', | |
31450 | & 'LA0PI+ ','SI0PI+ ','SI+PI0 ','LA0PI0 ','SI+PI- ', | |
31451 | & 'SI-PI+ ','LA0PI- ','SI0PI- ','NEUAK0 ','PK- ', | |
31452 | & 'SI+PI- ','SI0PI0 ','SI-PI+ ','LA0ET0 ','S+1PI- ', | |
31453 | & 'S-1PI+ ','SO1PI0 ','NEUAK0 ','PK- ','LA0PI0 ', | |
31454 | & 'LA0OM0 ','LA0RO0 ','SI+RO- ','SI-RO+ ','SI0RO0 ', | |
31455 | & 'LA0ET0 ','SI0ET0 ','SI+PI- ','SI-PI+ ','SI0PI0 ', | |
31456 | & 'K0S ','K0L ','K0S ','K0L ','P PI+ ', | |
31457 | & 'P PI0 ','N PI+ ','P PI- ','N PI0 ','N PI- ', | |
31458 | & 'P PI+ ','N*#PI0 ','N*+PI+ ','PRHO+ ','P PI0 ', | |
31459 | & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ', | |
31460 | & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ', | |
31461 | & 'N*-PI+ ','PRHO- ','NRHO0 ','N PI- ','N*0PI- ', | |
31462 | & 'N*-PI0 ','NRHO- ','PETA0 ','N*#PI- ','N*+PI0 ' / | |
31463 | DATA (ZKNAME(K),K=171,255) / | |
31464 | & 'N*0PI+ ','PRHO0 ','NRHO+ ','NETA0 ','N*+PI- ', | |
31465 | & 'N*0PI0 ','N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ', | |
31466 | & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ', | |
31467 | & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ', | |
31468 | & 'N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ','N PI+ ', | |
31469 | & 'PRHO0 ','NRHO+ ','LAMK+ ','S+ K0 ','S0 K+ ', | |
31470 | & 'PETA0 ','P PI- ','N PI0 ','PRHO- ','NRHO0 ', | |
31471 | & 'LAMK0 ','S0 K0 ','S- K+ ','NETA/ ','APPI- ', | |
31472 | & 'APPI0 ','ANPI- ','APPI+ ','ANPI0 ','ANPI+ ', | |
31473 | & 'APPI- ','AN*=P0 ','AN*-P- ','APRHO- ','APPI0 ', | |
31474 | & 'ANPI- ','AN*=P+ ','AN*-P0 ','AN*0P- ','APRHO0 ', | |
31475 | & 'ANRHO- ','APPI+ ','ANPI0 ','AN*-P+ ','AN*0P0 ', | |
31476 | & 'AN*+P- ','APRHO+ ','ANRHO0 ','ANPI+ ','AN*0P+ ', | |
31477 | & 'AN*+P0 ','ANRHO+ ','APPI0 ','ANPI- ','AN*=P+ ', | |
31478 | & 'AN*-P0 ','AN*0P- ','APRHO0 ','ANRHO- ','APPI+, ', | |
31479 | & 'ANPI0 ','AN*-P+ ','AN*0P0 ','AN*+P- ','APRHO+ ', | |
31480 | & 'ANRHO0 ','PN*014 ','NN*=14 ','PI+0 ','PI+- ' / | |
31481 | DATA (ZKNAME(K),K=256,340) / | |
31482 | & 'PI-0 ','P+0 ','N++ ','P+- ','P00 ', | |
31483 | & 'N+0 ','N+- ','N00 ','P-0 ','N-0 ', | |
31484 | & 'P-- ','PPPI0 ','PNPI+ ','PNPI0 ','PPPI- ', | |
31485 | & 'NNPI+ ','APPPI0 ','APNPI+ ','ANNPI0 ','ANPPI- ', | |
31486 | & 'APNPI0 ','APPPI- ','ANNPI- ','K+PPI0 ','K+NPI+ ', | |
31487 | & 'K0PPI0 ','K-PPI0 ','K-NPI+ ','AKPPI- ','AKNPI0 ', | |
31488 | & 'K+NPI0 ','K+PPI- ','K0PPI0 ','K0NPI+ ','K-NPI0 ', | |
31489 | & 'K-PPI- ','AKNPI- ','PAK0 ','SI+PI0 ','SI0PI+ ', | |
31490 | & 'SI+ETA ','S+1PI0 ','S01PI+ ','NEUK- ','LA0PI- ', | |
31491 | & 'SI-OM0 ','LA0RO- ','SI0RO- ','SI-RO0 ','SI-ET0 ', | |
31492 | & 'SI0PI- ','SI-0 ','BLANC ','BLANC ','BLANC ', | |
31493 | & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ', | |
31494 | & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ', | |
31495 | & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ', | |
31496 | & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ', | |
31497 | & 'EPI+- ','EPI00 ','GAPI+- ','GAGA* ','K+- ', | |
31498 | & 'KLKS ','PI+-0 ','EGA ','LPI0 ','LPI ' / | |
31499 | DATA (ZKNAME(K),K=341,425) / | |
31500 | & 'APPI0 ','ANPI- ','ALAGA ','ANPI ','ALPI0 ', | |
31501 | & 'ALPI+ ','LAPI+ ','SI+PI0 ','SI0PI+ ','LAPI0 ', | |
31502 | & 'SI+PI- ','SI-PI+ ','LAPI- ','SI-PI0 ','SI0PI- ', | |
31503 | & 'TE0PI0 ','TE-PI+ ','TE0PI- ','TE-PI0 ','TE0PI ', | |
31504 | & 'TE-PI ','LAK- ','ALPI- ','AS-PI0 ','AS0PI- ', | |
31505 | & 'ALPI0 ','AS+PI- ','AS-PI+ ','ALPI+ ','AS+PI0 ', | |
31506 | & 'AS0PI+ ','AT0PI0 ','AT+PI- ','AT0PI+ ','AT+PI0 ', | |
31507 | & 'AT0PI ','AT+PI ','ALK+ ','K-PI+ ','K-PI+0 ', | |
31508 | & 'K0PI+- ','K0PI0 ','K-PI++ ','AK0PI+ ','K+PI-- ', | |
31509 | & 'K0PI- ','K+PI- ','K+PI-0 ','AKPI-+ ','AK0PI0 ', | |
31510 | & 'ETAPIF ','K++- ','K+AK0 ','ETAPI- ','K--+ ', | |
31511 | & 'K-K0 ','PI00 ','PI+- ','GAGA ','D0PI0 ', | |
31512 | & 'D0GA ','D0PI+ ','D+PI0 ','DFGA ','AD0PI- ', | |
31513 | & 'D-PI0 ','D-GA ','AD0PI0 ','AD0GA ','F+GA ', | |
31514 | & 'F+GA ','F-GA ','F-GA ','PSPI+- ','PSPI00 ', | |
31515 | & 'PSETA ','E+E- ','MUE+- ','PI+-0 ','M+NN ', | |
31516 | & 'E+NN ','RHO+NT ','PI+ANT ','K*+ANT ','M-NN ' / | |
31517 | DATA (ZKNAME(K),K=426,510) / | |
31518 | & 'E-NN ','RHO-NT ','PI-NT ','K*-NT ','NUET ', | |
31519 | & 'ANUET ','NUEM ','ANUEM ','SI+ETA ','SI+ET* ', | |
31520 | & 'PAK0 ','TET0K+ ','SI*+ET ','N*+AK0 ','N*++K- ', | |
31521 | & 'LAMRO+ ','SI0RO+ ','SI+RO0 ','SI+OME ','PAK*0 ', | |
31522 | & 'N*+AK* ','N*++K* ','SI+AK0 ','TET0PI ','SI+AK* ', | |
31523 | & 'TET0RO ','SI0AK* ','SI+K*- ','TET0OM ','TET-RO ', | |
31524 | & 'SI*0AK ','C0+PI+ ','C0+PI0 ','C0+PI- ','A+GAM ', | |
31525 | & 'A0GAM ','TET0AK ','TET0K* ','OM-RO+ ','OM-PI+ ', | |
31526 | & 'C1++AK ','A+PI+ ','C0+AK0 ','A0PI+ ','A+AK0 ', | |
31527 | & 'T0PI+ ','ASI-ET ','ASI-E* ','APK0 ','ATET0K ', | |
31528 | & 'ASI*-E ','AN*-K0 ','AN*--K ','ALAMRO ','ASI0RO ', | |
31529 | & 'ASI-RO ','ASI-OM ','APK*0 ','AN*-K* ','AN*--K ', | |
31530 | & 'ASI-K0 ','ATETPI ','ASI-K* ','ATETRO ','ASI0K* ', | |
31531 | & 'ASI-K* ','ATE0OM ','ATE+RO ','ASI*0K ','AC-PI- ', | |
31532 | & 'AC-PI0 ','AC-PI+ ','AA-GAM ','AA0GAM ','ATET0K ', | |
31533 | & 'ATE0K* ','AOM+RO ','AOM+PI ','AC1--K ','AA-PI- ', | |
31534 | & 'AC0-K0 ','AA0PI- ','AA-K0 ','AT0PI- ','C1++GA ' / | |
31535 | DATA (ZKNAME(K),K=511,540) / | |
31536 | & 'C1++GA ','C10GAM ','S+GAM ','S0GAM ','T0GAM ', | |
31537 | & 'XU++GA ','XD+GAM ','XS+GAM ','A+AKPI ','T02PI+ ', | |
31538 | & 'C1++2K ','AC1--G ','AC1-GA ','AC10GA ','AS-GAM ', | |
31539 | & 'AS0GAM ','AT0GAM ','AXU--G ','AXD-GA ','AXS-GA ', | |
31540 | & 'AA-KPI ','AT02PI ','AC1--K ','RH-PI+ ','RH+PI- ', | |
31541 | & 'RH3PI0 ','RH0PI+ ','RH+PI0 ','RH0PI- ','RH-PI0 ' / | |
31542 | DATA (ZKNAME(I),I=541,602)/ | |
31543 | & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHO0','ANRHO-','ANETA ', | |
31544 | & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0','RH0PI+','RH+PI0', | |
31545 | & '3PI+00','3PI-++','F0PI+ ','RH+PI-','RH0PI0','3PI000','3PI0+-', | |
31546 | & 'F0PI0 ','RH0PI-','RH-PI0','3PI-00','3PI--+','F0PI- ','PI0PI0', | |
31547 | & 'PI+PI-','K+K- ','K0AK0 ','L01600','AL0160','K*+146','K*-146', | |
31548 | & 'K*0146','AK0146','S+1660','S01660','S-1660','AS-166','AS0166', | |
31549 | & 'AS+166','X01690','X-1690','AX0169','AX+169','OM-225','AOM+22', | |
31550 | & 'N*PPI0','N*NPI+','N*P2P0','N*PP+-','N*D+P0','N*D0P+','N*NPI0', | |
31551 | & 'N*PPI-','N*N2P0','N*NP+-','N*D+P-','N*D0P0','BLANK '/ | |
31552 | * Weight of decay channel | |
31553 | DATA (WT(K),K= 1, 85) / | |
31554 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, | |
31555 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, | |
31556 | & .1000D+01, .2100D+00, .1200D+00, .2700D+00, .4000D+00, | |
31557 | & .1000D+01, .1000D+01, .6400D+00, .2100D+00, .6000D-01, | |
31558 | & .2000D-01, .3000D-01, .4000D-01, .6400D+00, .2100D+00, | |
31559 | & .6000D-01, .2000D-01, .3000D-01, .4000D-01, .6400D+00, | |
31560 | & .3600D+00, .0000D+00, .0000D+00, .6400D+00, .3600D+00, | |
31561 | & .0000D+00, .0000D+00, .6900D+00, .3100D+00, .1000D+01, | |
31562 | & .5200D+00, .4800D+00, .1000D+01, .9900D+00, .1000D-01, | |
31563 | & .3800D+00, .3000D-01, .3000D+00, .2400D+00, .5000D-01, | |
31564 | & .1000D+01, .1000D+01, .0000D+00, .1000D+01, .9000D+00, | |
31565 | & .1000D-01, .9000D-01, .3300D+00, .6700D+00, .3300D+00, | |
31566 | & .6700D+00, .3300D+00, .6700D+00, .3300D+00, .6700D+00, | |
31567 | & .3300D+00, .6700D+00, .3300D+00, .6700D+00, .3300D+00, | |
31568 | & .6700D+00, .3300D+00, .6700D+00, .1900D+00, .3800D+00, | |
31569 | & .9000D-01, .2000D+00, .3000D-01, .4000D-01, .5000D-01, | |
31570 | & .2000D-01, .1900D+00, .3800D+00, .9000D-01, .2000D+00 / | |
31571 | DATA (WT(K),K= 86,170) / | |
31572 | & .3000D-01, .4000D-01, .5000D-01, .2000D-01, .1900D+00, | |
31573 | & .3800D+00, .9000D-01, .2000D+00, .3000D-01, .4000D-01, | |
31574 | & .5000D-01, .2000D-01, .1900D+00, .3800D+00, .9000D-01, | |
31575 | & .2000D+00, .3000D-01, .4000D-01, .5000D-01, .2000D-01, | |
31576 | & .8800D+00, .6000D-01, .6000D-01, .8800D+00, .6000D-01, | |
31577 | & .6000D-01, .8800D+00, .1200D+00, .1900D+00, .1900D+00, | |
31578 | & .1600D+00, .1600D+00, .1700D+00, .3000D-01, .3000D-01, | |
31579 | & .3000D-01, .4000D-01, .1000D+00, .1000D+00, .2000D+00, | |
31580 | & .1200D+00, .1000D+00, .4000D-01, .4000D-01, .5000D-01, | |
31581 | & .7500D-01, .7500D-01, .3000D-01, .3000D-01, .4000D-01, | |
31582 | & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01, | |
31583 | & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01, | |
31584 | & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00, | |
31585 | & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00, | |
31586 | & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01, | |
31587 | & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00, | |
31588 | & .2700D+00, .3000D+00, .4000D+00, .2000D+00, .1250D+00 / | |
31589 | DATA (WT(K),K=171,255) / | |
31590 | & .7500D-01, .7500D-01, .1250D+00, .4000D+00, .7500D-01, | |
31591 | & .1250D+00, .2000D+00, .1250D+00, .7500D-01, .1800D+00, | |
31592 | & .3700D+00, .1300D+00, .8000D-01, .4000D-01, .7000D-01, | |
31593 | & .1300D+00, .3700D+00, .1800D+00, .4000D-01, .8000D-01, | |
31594 | & .1300D+00, .1300D+00, .7000D-01, .7000D-01, .1300D+00, | |
31595 | & .2300D+00, .4700D+00, .5000D-01, .2000D-01, .1000D-01, | |
31596 | & .2000D-01, .1300D+00, .7000D-01, .4700D+00, .2300D+00, | |
31597 | & .5000D-01, .1000D-01, .2000D-01, .2000D-01, .1000D+01, | |
31598 | & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01, | |
31599 | & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00, | |
31600 | & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00, | |
31601 | & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01, | |
31602 | & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00, | |
31603 | & .2700D+00, .3000D+00, .1800D+00, .3700D+00, .1300D+00, | |
31604 | & .8000D-01, .4000D-01, .7000D-01, .1300D+00, .3700D+00, | |
31605 | & .1800D+00, .4000D-01, .8000D-01, .1300D+00, .1300D+00, | |
31606 | & .7000D-01, .5000D+00, .5000D+00, .1000D+01, .1000D+01 / | |
31607 | DATA (WT(K),K=256,340) / | |
31608 | & .1000D+01, .8000D+00, .2000D+00, .6000D+00, .3000D+00, | |
31609 | & .1000D+00, .6000D+00, .3000D+00, .1000D+00, .8000D+00, | |
31610 | & .2000D+00, .3300D+00, .6700D+00, .6600D+00, .1700D+00, | |
31611 | & .1700D+00, .3200D+00, .1700D+00, .3200D+00, .1900D+00, | |
31612 | & .3300D+00, .3300D+00, .3400D+00, .3000D+00, .5000D-01, | |
31613 | & .6500D+00, .3800D+00, .1200D+00, .3800D+00, .1200D+00, | |
31614 | & .3800D+00, .1200D+00, .3800D+00, .1200D+00, .3000D+00, | |
31615 | & .5000D-01, .6500D+00, .3800D+00, .2500D+00, .2500D+00, | |
31616 | & .2000D-01, .5000D-01, .5000D-01, .2000D+00, .2000D+00, | |
31617 | & .1200D+00, .1000D+00, .7000D-01, .7000D-01, .1400D+00, | |
31618 | & .5000D-01, .5000D-01, .1000D+01, .1000D+01, .1000D+01, | |
31619 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, | |
31620 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, | |
31621 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, | |
31622 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, | |
31623 | & .4800D+00, .2400D+00, .2600D+00, .2000D-01, .4700D+00, | |
31624 | & .3500D+00, .1500D+00, .3000D-01, .1000D+01, .1000D+01 / | |
31625 | DATA (WT(K),K=341,425) / | |
31626 | & .5200D+00, .4800D+00, .1000D+01, .1000D+01, .1000D+01, | |
31627 | & .1000D+01, .9000D+00, .5000D-01, .5000D-01, .9000D+00, | |
31628 | & .5000D-01, .5000D-01, .9000D+00, .5000D-01, .5000D-01, | |
31629 | & .3300D+00, .6700D+00, .6700D+00, .3300D+00, .2500D+00, | |
31630 | & .2500D+00, .5000D+00, .9000D+00, .5000D-01, .5000D-01, | |
31631 | & .9000D+00, .5000D-01, .5000D-01, .9000D+00, .5000D-01, | |
31632 | & .5000D-01, .3300D+00, .6700D+00, .6700D+00, .3300D+00, | |
31633 | & .2500D+00, .2500D+00, .5000D+00, .1000D+00, .5000D+00, | |
31634 | & .1600D+00, .2400D+00, .7000D+00, .3000D+00, .7000D+00, | |
31635 | & .3000D+00, .1000D+00, .5000D+00, .1600D+00, .2400D+00, | |
31636 | & .3000D+00, .4000D+00, .3000D+00, .3000D+00, .4000D+00, | |
31637 | & .3000D+00, .4900D+00, .4900D+00, .2000D-01, .5500D+00, | |
31638 | & .4500D+00, .6800D+00, .3000D+00, .2000D-01, .6800D+00, | |
31639 | & .3000D+00, .2000D-01, .5500D+00, .4500D+00, .9000D+00, | |
31640 | & .1000D+00, .9000D+00, .1000D+00, .6000D+00, .3000D+00, | |
31641 | & .1000D+00, .1000D+00, .1000D+00, .8000D+00, .2800D+00, | |
31642 | & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .2800D+00 / | |
31643 | DATA (WT(K),K=426,510) / | |
31644 | & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .1000D+01, | |
31645 | & .1000D+01, .1000D+01, .1000D+01, .2000D-01, .3000D-01, | |
31646 | & .7000D-01, .2000D-01, .2000D-01, .4000D-01, .1300D+00, | |
31647 | & .7000D-01, .6000D-01, .6000D-01, .2000D+00, .1400D+00, | |
31648 | & .4000D-01, .1000D+00, .2500D+00, .3000D-01, .3000D+00, | |
31649 | & .4200D+00, .2200D+00, .3500D+00, .1900D+00, .1600D+00, | |
31650 | & .8000D-01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, | |
31651 | & .1000D+01, .3700D+00, .2000D+00, .3600D+00, .7000D-01, | |
31652 | & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00, | |
31653 | & .5000D+00, .2000D-01, .3000D-01, .7000D-01, .2000D-01, | |
31654 | & .2000D-01, .4000D-01, .1300D+00, .7000D-01, .6000D-01, | |
31655 | & .6000D-01, .2000D+00, .1400D+00, .4000D-01, .1000D+00, | |
31656 | & .2500D+00, .3000D-01, .3000D+00, .4200D+00, .2200D+00, | |
31657 | & .3500D+00, .1900D+00, .1600D+00, .8000D-01, .1000D+01, | |
31658 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .3700D+00, | |
31659 | & .2000D+00, .3600D+00, .7000D-01, .5000D+00, .5000D+00, | |
31660 | & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01 / | |
31661 | DATA (WT(K),K=511,540) / | |
31662 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, | |
31663 | & .1000D+01, .1000D+01, .1000D+01, .3000D+00, .3000D+00, | |
31664 | & .4000D+00, .1000D+01, .1000D+01, .1000D+01, .1000D+01, | |
31665 | & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01, | |
31666 | & .3000D+00, .3000D+00, .4000D+00, .3300D+00, .3300D+00, | |
31667 | & .3400D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00 / | |
31668 | C | |
31669 | DATA (WT(I),I=541,602) / .0D+00, .3334D+00, .2083D+00, 2*.125D+00, | |
31670 | & .2083D+00, .0D+00, .125D+00, .2083D+00, .3334D+00, .2083D+00, | |
31671 | & .125D+00, 0.2D+00, 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00, | |
31672 | & 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00, 0.2D+00, 0.3D+00, | |
31673 | & 0.3D+00, 0.0D+00, 0.31D+00, 0.62D+00, 0.035D+00, 0.035D+00, | |
31674 | & 18*1.D+00, 0.5D+00, 0.16D+00, 2*0.12D+00, 2*0.05D+00, 0.5D+00, | |
31675 | & 0.16D+00, 2*0.12D+00, 2*0.05D+00, 1.D+00 / | |
31676 | * Particle numbers in decay channel | |
31677 | DATA (NZK(K,1),K= 1,170) / | |
31678 | & 1, 2, 3, 4, 5, 6, 7, 1, 2, 4, | |
31679 | & 3, 23, 13, 13, 13, 10, 11, 10, 13, 13, | |
31680 | & 13, 10, 4, 11, 14, 14, 14, 11, 3, 1, | |
31681 | & 8, 1, 1, 2, 9, 2, 2, 13, 23, 8, | |
31682 | & 1, 8, 17, 7, 7, 7, 23, 23, 13, 13, | |
31683 | & 13, 13, 23, 14, 13, 13, 23, 15, 24, 24, | |
31684 | & 15, 16, 25, 25, 16, 15, 24, 24, 15, 16, | |
31685 | & 24, 25, 16, 15, 24, 36, 37, 15, 24, 15, | |
31686 | & 15, 24, 15, 37, 36, 24, 15, 24, 24, 16, | |
31687 | & 24, 38, 39, 16, 25, 16, 16, 25, 16, 39, | |
31688 | & 38, 25, 16, 25, 25, 17, 22, 21, 17, 21, | |
31689 | & 20, 17, 22, 8, 1, 21, 22, 20, 17, 48, | |
31690 | & 50, 49, 8, 1, 17, 17, 17, 21, 20, 22, | |
31691 | & 17, 22, 21, 20, 22, 19, 12, 19, 12, 1, | |
31692 | & 1, 8, 1, 8, 8, 1, 53, 54, 1, 1, | |
31693 | & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55, | |
31694 | & 56, 1, 8, 8, 55, 56, 8, 1, 53, 54 / | |
31695 | DATA (NZK(K,1),K=171,340) / | |
31696 | & 55, 1, 8, 8, 54, 55, 56, 1, 8, 1, | |
31697 | & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55, | |
31698 | & 56, 1, 8, 1, 8, 1, 8, 17, 21, 22, | |
31699 | & 1, 1, 8, 1, 8, 17, 22, 20, 8, 2, | |
31700 | & 2, 9, 2, 9, 9, 2, 67, 68, 2, 2, | |
31701 | & 9, 67, 68, 69, 2, 9, 2, 9, 68, 69, | |
31702 | & 70, 2, 9, 9, 69, 70, 9, 2, 9, 67, | |
31703 | & 68, 69, 2, 9, 2, 9, 68, 69, 70, 2, | |
31704 | & 9, 1, 8, 13, 13, 14, 1, 8, 1, 1, | |
31705 | & 8, 8, 8, 1, 8, 1, 1, 1, 1, 1, | |
31706 | & 8, 2, 2, 9, 9, 2, 2, 9, 15, 15, | |
31707 | & 24, 16, 16, 25, 25, 15, 15, 24, 24, 16, | |
31708 | & 16, 25, 1, 21, 22, 21, 48, 49, 8, 17, | |
31709 | & 20, 17, 22, 20, 20, 22, 20, 0, 0, 0, | |
31710 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
31711 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
31712 | & 31, 31, 13, 7, 15, 12, 13, 31, 17, 17 / | |
31713 | DATA (NZK(K,1),K=341,510) / | |
31714 | & 2, 9, 18, 9, 18, 18, 17, 21, 22, 17, | |
31715 | & 21, 20, 17, 20, 22, 97, 98, 97, 98, 97, | |
31716 | & 98, 17, 18, 99, 100, 18, 101, 99, 18, 101, | |
31717 | & 100, 102, 103, 102, 103, 102, 103, 18, 16, 16, | |
31718 | & 24, 24, 16, 25, 15, 24, 15, 15, 25, 25, | |
31719 | & 31, 15, 15, 31, 16, 16, 23, 13, 7, 116, | |
31720 | & 116, 116, 117, 117, 119, 118, 118, 119, 119, 120, | |
31721 | & 120, 121, 121, 130, 130, 130, 4, 10, 13, 10, | |
31722 | & 4, 32, 13, 36, 11, 3, 34, 14, 38, 133, | |
31723 | & 134, 135, 136, 21, 21, 1, 97, 104, 54, 53, | |
31724 | & 17, 22, 21, 21, 1, 54, 53, 21, 97, 21, | |
31725 | & 97, 22, 21, 97, 98, 105, 137, 137, 137, 138, | |
31726 | & 139, 97, 97, 109, 109, 140, 138, 137, 139, 138, | |
31727 | & 145, 99, 99, 2, 102, 110, 68, 67, 18, 100, | |
31728 | & 99, 99, 2, 68, 67, 99, 102, 99, 102, 100, | |
31729 | & 99, 102, 103, 111, 149, 149, 149, 150, 151, 113, | |
31730 | & 113, 115, 115, 152, 150, 149, 151, 150, 157, 140 / | |
31731 | DATA (NZK(K,1),K=511,540) / | |
31732 | & 141, 142, 143, 144, 145, 146, 147, 148, 138, 145, | |
31733 | & 140, 152, 153, 154, 155, 156, 157, 158, 159, 160, | |
31734 | & 150, 157, 152, 34, 32, 33, 33, 32, 33, 34 / | |
31735 | DATA (NZK(I,1),I=541,602) / 2, 67, 68, 69, 2, 9, 9, 68, 69, | |
31736 | & 70, 2, 9, 33, 32, 13, 14, 189, 32, 34, 23, 23, 189, 33, 34, 14, | |
31737 | & 14, 189, 23, 13, 15, 24, 36, 38, 37, 39, 194, 195, 196, 197, | |
31738 | & 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 1, 8, 1, 1, 54, | |
31739 | & 55, 8, 1, 8, 8, 54, 55, 210/ | |
31740 | DATA (NZK(K,2),K= 1,170) / | |
31741 | & 0, 0, 0, 0, 0, 0, 0, 3, 4, 6, | |
31742 | & 5, 23, 14, 11, 3, 5, 5, 5, 23, 13, | |
31743 | & 23, 23, 23, 5, 23, 13, 23, 23, 23, 14, | |
31744 | & 23, 3, 11, 13, 23, 4, 10, 14, 23, 14, | |
31745 | & 23, 13, 7, 7, 4, 7, 7, 23, 14, 14, | |
31746 | & 23, 14, 23, 23, 14, 14, 7, 23, 13, 23, | |
31747 | & 14, 23, 14, 23, 13, 23, 13, 23, 14, 23, | |
31748 | & 14, 23, 13, 23, 13, 23, 13, 33, 32, 35, | |
31749 | & 31, 23, 14, 23, 14, 33, 34, 35, 31, 23, | |
31750 | & 14, 23, 14, 33, 34, 35, 31, 23, 13, 23, | |
31751 | & 13, 33, 32, 35, 31, 13, 13, 23, 23, 14, | |
31752 | & 13, 14, 14, 25, 16, 14, 23, 13, 31, 14, | |
31753 | & 13, 23, 25, 16, 23, 35, 33, 34, 32, 33, | |
31754 | & 31, 31, 14, 13, 23, 0, 0, 0, 0, 13, | |
31755 | & 23, 13, 14, 23, 14, 13, 23, 13, 78, 23, | |
31756 | & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23, | |
31757 | & 13, 80, 79, 14, 14, 23, 80, 31, 14, 23 / | |
31758 | DATA (NZK(K,2),K=171,340) / | |
31759 | & 13, 79, 78, 31, 14, 23, 13, 80, 79, 23, | |
31760 | & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23, | |
31761 | & 13, 80, 79, 23, 13, 33, 32, 15, 24, 15, | |
31762 | & 31, 14, 23, 34, 33, 24, 24, 15, 31, 14, | |
31763 | & 23, 14, 13, 23, 13, 14, 23, 14, 80, 23, | |
31764 | & 14, 13, 23, 14, 79, 80, 13, 23, 13, 23, | |
31765 | & 14, 78, 79, 13, 13, 23, 78, 23, 14, 13, | |
31766 | & 23, 14, 79, 80, 13, 23, 13, 23, 14, 78, | |
31767 | & 79, 62, 61, 23, 14, 23, 13, 13, 13, 23, | |
31768 | & 13, 13, 23, 14, 14, 14, 1, 8, 8, 1, | |
31769 | & 8, 1, 8, 8, 1, 8, 1, 8, 1, 8, | |
31770 | & 1, 1, 8, 1, 8, 8, 1, 1, 8, 8, | |
31771 | & 1, 8, 25, 23, 13, 31, 23, 13, 16, 14, | |
31772 | & 35, 34, 34, 33, 31, 14, 23, 0, 0, 0, | |
31773 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
31774 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
31775 | & 13, 23, 14, 7, 16, 19, 14, 7, 23, 14 / | |
31776 | DATA (NZK(K,2),K=341,510) / | |
31777 | & 23, 14, 7, 13, 23, 13, 13, 23, 13, 23, | |
31778 | & 14, 13, 14, 23, 14, 23, 13, 14, 23, 14, | |
31779 | & 23, 16, 14, 23, 14, 23, 14, 13, 13, 23, | |
31780 | & 13, 23, 14, 13, 23, 13, 23, 15, 13, 13, | |
31781 | & 13, 23, 13, 13, 14, 14, 14, 14, 14, 23, | |
31782 | & 13, 16, 25, 14, 15, 24, 23, 14, 7, 23, | |
31783 | & 7, 13, 23, 7, 14, 23, 7, 23, 7, 7, | |
31784 | & 7, 7, 7, 13, 23, 31, 3, 11, 14, 135, | |
31785 | & 5, 134, 134, 134, 136, 6, 133, 133, 133, 0, | |
31786 | & 0, 0, 0, 31, 95, 25, 15, 31, 95, 16, | |
31787 | & 32, 32, 33, 35, 39, 39, 38, 25, 13, 39, | |
31788 | & 32, 39, 38, 35, 32, 39, 13, 23, 14, 7, | |
31789 | & 7, 25, 37, 32, 13, 25, 13, 25, 13, 25, | |
31790 | & 13, 31, 95, 24, 16, 31, 24, 15, 34, 34, | |
31791 | & 33, 35, 37, 37, 36, 24, 14, 37, 34, 37, | |
31792 | & 36, 35, 34, 37, 14, 23, 13, 7, 7, 24, | |
31793 | & 39, 34, 14, 24, 14, 24, 14, 24, 14, 7 / | |
31794 | DATA (NZK(K,2),K=511,540) / | |
31795 | & 7, 7, 7, 7, 7, 7, 7, 7, 25, 13, | |
31796 | & 25, 7, 7, 7, 7, 7, 7, 7, 7, 7, | |
31797 | & 24, 14, 24, 13, 14, 23, 13, 23, 14, 23 / | |
31798 | DATA (NZK(I,2),I=541,602) / 31, 13, 23, 14, 79, 80, 31, 13, 23, | |
31799 | & 14, 78, 79, 13, 23, 23, 13, 13, 14, 13, 23, 13, 23, 14, 23, 23, | |
31800 | & 14, 14, 23, 14, 16, 25, | |
31801 | & 4*23, 14*0, 23, 13, 23, 13, 23, 13, 23, 14, | |
31802 | & 23, 13, 14, 23, 0 / | |
31803 | DATA (NZK(K,3),K= 1,170) / | |
31804 | & 0, 0, 0, 0, 0, 0, 0, 5, 6, 5, | |
31805 | & 6, 23, 23, 5, 5, 0, 0, 0, 0, 14, | |
31806 | & 23, 5, 5, 0, 0, 14, 23, 5, 5, 0, | |
31807 | & 0, 5, 5, 0, 0, 5, 5, 0, 0, 0, | |
31808 | & 0, 0, 0, 0, 3, 0, 7, 23, 23, 7, | |
31809 | & 0, 0, 0, 0, 23, 0, 0, 0, 0, 0, | |
31810 | & 110*0 / | |
31811 | DATA (NZK(K,3),K=171,340) / | |
31812 | & 80*0, | |
31813 | & 0, 0, 0, 0, 0, 0, 23, 13, 14, 23, | |
31814 | & 23, 14, 23, 23, 23, 14, 23, 13, 23, 14, | |
31815 | & 13, 23, 13, 23, 14, 23, 14, 14, 23, 13, | |
31816 | & 13, 23, 13, 14, 23, 23, 14, 23, 13, 23, | |
31817 | & 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, | |
31818 | & 30*0, | |
31819 | & 14, 23, 7, 0, 0, 0, 23, 0, 0, 0 / | |
31820 | DATA (NZK(K,3),K=341,510) / | |
31821 | & 30*0, | |
31822 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 23, | |
31823 | & 14, 0, 13, 0, 14, 0, 0, 23, 13, 0, | |
31824 | & 0, 15, 0, 0, 16, 0, 0, 0, 0, 0, | |
31825 | & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
31826 | & 0, 0, 0, 14, 23, 0, 0, 0, 23, 134, | |
31827 | & 134, 0, 0, 0, 133, 133, 0, 0, 0, 0, | |
31828 | & 80*0 / | |
31829 | DATA (NZK(K,3),K=511,540) / | |
31830 | & 0, 0, 0, 0, 0, 0, 0, 0, 13, 13, | |
31831 | & 25, 0, 0, 0, 0, 0, 0, 0, 0, 0, | |
31832 | & 14, 14, 24, 0, 0, 0, 0, 0, 0, 0 / | |
31833 | DATA (NZK(I,3),I=541,602) / 12*0, 2*0, 23, 13, 0, 2*0, 23, 14, 0, | |
31834 | & 2*0, 23, 13, 0, 4*0, 18*0, 2*0, 23, 14, 2*0, 2*0, 23, 14, 2*0, 0/ | |
31835 | ||
31836 | END | |
31837 | ||
31838 | *$ CREATE DT_BDEVAP.FOR | |
31839 | *COPY DT_BDEVAP | |
31840 | * | |
31841 | *=== bdevap ===========================================================* | |
31842 | * | |
31843 | BLOCK DATA DT_BDEVAP | |
31844 | ||
31845 | C INCLUDE '(DBLPRC)' | |
31846 | * DBLPRC.ADD | |
31847 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
31848 | SAVE | |
31849 | * (original name: GLOBAL) | |
31850 | PARAMETER ( KALGNM = 2 ) | |
31851 | PARAMETER ( ANGLGB = 5.0D-16 ) | |
31852 | PARAMETER ( ANGLSQ = 2.5D-31 ) | |
31853 | PARAMETER ( AXCSSV = 0.2D+16 ) | |
31854 | PARAMETER ( ANDRFL = 1.0D-38 ) | |
31855 | PARAMETER ( AVRFLW = 1.0D+38 ) | |
31856 | PARAMETER ( AINFNT = 1.0D+30 ) | |
31857 | PARAMETER ( AZRZRZ = 1.0D-30 ) | |
31858 | PARAMETER ( EINFNT = +69.07755278982137 D+00 ) | |
31859 | PARAMETER ( EZRZRZ = -69.07755278982137 D+00 ) | |
31860 | PARAMETER ( EXCSSV = +35.23192357547063 D+00 ) | |
31861 | PARAMETER ( ENGLGB = -35.23192357547063 D+00 ) | |
31862 | PARAMETER ( ONEMNS = 0.999999999999999 D+00 ) | |
31863 | PARAMETER ( ONEPLS = 1.000000000000001 D+00 ) | |
31864 | PARAMETER ( CSNNRM = 2.0D-15 ) | |
31865 | PARAMETER ( DMXTRN = 1.0D+08 ) | |
31866 | PARAMETER ( ZERZER = 0.D+00 ) | |
31867 | PARAMETER ( ONEONE = 1.D+00 ) | |
31868 | PARAMETER ( TWOTWO = 2.D+00 ) | |
31869 | PARAMETER ( THRTHR = 3.D+00 ) | |
31870 | PARAMETER ( FOUFOU = 4.D+00 ) | |
31871 | PARAMETER ( FIVFIV = 5.D+00 ) | |
31872 | PARAMETER ( SIXSIX = 6.D+00 ) | |
31873 | PARAMETER ( SEVSEV = 7.D+00 ) | |
31874 | PARAMETER ( EIGEIG = 8.D+00 ) | |
31875 | PARAMETER ( ANINEN = 9.D+00 ) | |
31876 | PARAMETER ( TENTEN = 10.D+00 ) | |
31877 | PARAMETER ( HLFHLF = 0.5D+00 ) | |
31878 | PARAMETER ( ONETHI = ONEONE / THRTHR ) | |
31879 | PARAMETER ( TWOTHI = TWOTWO / THRTHR ) | |
31880 | PARAMETER ( ONEFOU = ONEONE / FOUFOU ) | |
31881 | PARAMETER ( THRTWO = THRTHR / TWOTWO ) | |
31882 | PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 ) | |
31883 | PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 ) | |
31884 | PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 ) | |
31885 | PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 ) | |
31886 | PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 ) | |
31887 | PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 ) | |
31888 | PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 ) | |
31889 | PARAMETER ( EULERO = 0.577215664901532860606512 D+00 ) | |
31890 | PARAMETER ( EULEXP = 1.781072417990197985236504 D+00 ) | |
31891 | PARAMETER ( EULLOG =-0.5495393129816448223376619 D+00 ) | |
31892 | PARAMETER ( E1M2EU = 0.8569023337737540831433017 D+00 ) | |
31893 | PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 ) | |
31894 | PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 ) | |
31895 | PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 ) | |
31896 | PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 ) | |
31897 | PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 ) | |
31898 | PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 ) | |
31899 | PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 ) | |
31900 | PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 ) | |
31901 | PARAMETER ( CLIGHT = 2.99792458 D+10 ) | |
31902 | PARAMETER ( AVOGAD = 6.0221367 D+23 ) | |
31903 | PARAMETER ( BOLTZM = 1.380658 D-23 ) | |
31904 | PARAMETER ( AMELGR = 9.1093897 D-28 ) | |
31905 | PARAMETER ( PLCKBR = 1.05457266 D-27 ) | |
31906 | PARAMETER ( ELCCGS = 4.8032068 D-10 ) | |
31907 | PARAMETER ( ELCMKS = 1.60217733 D-19 ) | |
31908 | PARAMETER ( AMUGRM = 1.6605402 D-24 ) | |
31909 | PARAMETER ( AMMUMU = 0.113428913 D+00 ) | |
31910 | PARAMETER ( AMPRMU = 1.007276470 D+00 ) | |
31911 | PARAMETER ( AMNEMU = 1.008664904 D+00 ) | |
31912 | PARAMETER ( ALPFSC = 7.2973530791728595 D-03 ) | |
31913 | PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 ) | |
31914 | PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 ) | |
31915 | PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 ) | |
31916 | PARAMETER ( PLABRC = 0.197327053 D+00 ) | |
31917 | PARAMETER ( AMELCT = 0.51099906 D-03 ) | |
31918 | PARAMETER ( AMUGEV = 0.93149432 D+00 ) | |
31919 | PARAMETER ( AMMUON = 0.105658389 D+00 ) | |
31920 | PARAMETER ( AMPRTN = 0.93827231 D+00 ) | |
31921 | PARAMETER ( AMNTRN = 0.93956563 D+00 ) | |
31922 | PARAMETER ( AMDEUT = 1.87561339 D+00 ) | |
31923 | PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13 | |
31924 | & * 1.D-09 ) | |
31925 | PARAMETER ( RCLSEL = 2.8179409183694872 D-13 ) | |
31926 | PARAMETER ( BLTZMN = 8.617385 D-14 ) | |
31927 | PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT ) | |
31928 | PARAMETER ( GFOHB3 = 1.16639 D-05 ) | |
31929 | PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC ) | |
31930 | PARAMETER ( SIN2TW = 0.2319 D+00 ) | |
31931 | PARAMETER ( GEVMEV = 1.0 D+03 ) | |
31932 | PARAMETER ( EMVGEV = 1.0 D-03 ) | |
31933 | PARAMETER ( ALGVMV = 6.90775527898214 D+00 ) | |
31934 | PARAMETER ( RADDEG = 180.D+00 / PIPIPI ) | |
31935 | PARAMETER ( DEGRAD = PIPIPI / 180.D+00 ) | |
31936 | LOGICAL LGBIAS, LGBANA | |
31937 | COMMON /FKGLOB/ LGBIAS, LGBANA | |
31938 | C INCLUDE '(DIMPAR)' | |
31939 | * DIMPAR.ADD | |
31940 | PARAMETER ( MXXRGN = 5000 ) | |
31941 | PARAMETER ( MXXMDF = 82 ) | |
31942 | PARAMETER ( MXXMDE = 54 ) | |
31943 | PARAMETER ( MFSTCK = 1000 ) | |
31944 | PARAMETER ( MESTCK = 100 ) | |
31945 | PARAMETER ( NELEMX = 80 ) | |
31946 | PARAMETER ( MPDPDX = 8 ) | |
31947 | PARAMETER ( ICOMAX = 180 ) | |
31948 | PARAMETER ( NSTBIS = 304 ) | |
31949 | PARAMETER ( IDMAXP = 220 ) | |
31950 | PARAMETER ( IDMXDC = 640 ) | |
31951 | PARAMETER ( MKBMX1 = 1 ) | |
31952 | PARAMETER ( MKBMX2 = 1 ) | |
31953 | C INCLUDE '(IOUNIT)' | |
31954 | * IOUNIT.ADD | |
31955 | PARAMETER ( LUNIN = 5 ) | |
31956 | PARAMETER ( LUNOUT = 6 ) | |
31957 | **sr 19.5. set error output-unit from 15 to 6 | |
31958 | PARAMETER ( LUNERR = 6 ) | |
31959 | PARAMETER ( LUNBER = 14 ) | |
31960 | PARAMETER ( LUNECH = 8 ) | |
31961 | PARAMETER ( LUNFLU = 13 ) | |
31962 | PARAMETER ( LUNGEO = 16 ) | |
31963 | PARAMETER ( LUNPMF = 12 ) | |
31964 | PARAMETER ( LUNRAN = 2 ) | |
31965 | PARAMETER ( LUNXSC = 9 ) | |
31966 | PARAMETER ( LUNDET = 17 ) | |
31967 | PARAMETER ( LUNRAY = 10 ) | |
31968 | PARAMETER ( LUNRDB = 1 ) | |
31969 | PARAMETER ( LUNPGO = 7 ) | |
31970 | PARAMETER ( LUNPGS = 4 ) | |
31971 | PARAMETER ( LUNSCR = 3 ) | |
31972 | * | |
31973 | *----------------------------------------------------------------------* | |
31974 | * * | |
31975 | * Block Data for the EVAPoration routines: * | |
31976 | * * | |
31977 | * Created on 20 may 1990 by Alfredo Ferrari & Paola Sala * | |
31978 | * Infn - Milan * | |
31979 | * * | |
31980 | * Modified from the original version of J.M.Zazula * | |
31981 | * and, for cookcm, from a LAHET block data kindly provided by * | |
31982 | * R.E.Prael-LANL * | |
31983 | * * | |
31984 | * Last change on 20-feb-95 by Alfredo Ferrari * | |
31985 | * * | |
31986 | * * | |
31987 | *----------------------------------------------------------------------* | |
31988 | * | |
31989 | * (original name: COOKCM) | |
31990 | PARAMETER ( ASMTOG = SIXSIX / PIPIPI**2 ) | |
31991 | LOGICAL LDEFOZ, LDEFON | |
31992 | PARAMETER ( INCOOK = 150, IZCOOK = 98 ) | |
31993 | COMMON /FKCOOK/ ALPIGN, BETIGN, GAMIGN, POWIGN, | |
31994 | & SZCOOK (IZCOOK), SNCOOK (INCOOK), PZCOOK (IZCOOK), | |
31995 | & PNCOOK (INCOOK), LDEFOZ (IZCOOK), LDEFON (INCOOK) | |
31996 | * (original name: EVA0) | |
31997 | COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001), | |
31998 | * FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6), | |
31999 | * CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200), | |
32000 | * T (4,7), RMASS (297), ALPH (297), BET (297), | |
32001 | * APRIME (250), IA (6), IZ (6) | |
32002 | * (original name: HETTP) | |
32003 | COMMON /FKHETP/ NHSTP,NBERTP,IOSUB,INSRS | |
32004 | * (original name: HETC7) | |
32005 | COMMON /FKHET7/ COSKS,SINKS, COSTH,SINTH, COSPHI,SINPHI | |
32006 | * (original name: INPFLG) | |
32007 | COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK | |
32008 | * | |
32009 | DATA B0 / 8.D+00 /, Y0 / 1.5D+00 / | |
32010 | DATA IANG / 1 /, IFISS / 1 /, IB0 / 2 /, IGEOM / 0 / | |
32011 | DATA ISTRAG /0/, KEYDK /0/ | |
32012 | DATA NBERTP /LUNBER/ | |
32013 | DATA COSTH /ONEONE/, SINTH /ZERZER/, COSPHI /ONEONE/, | |
32014 | & SINPHI/ZERZER/ | |
32015 | * /cookcm/ | |
32016 | DATA ( PZCOOK(I),I = 1, IZCOOK ) / | |
32017 | & 0.000D+00, 5.440D+00, 0.000D+00, 2.760D+00, 0.000D+00, 3.340D+00, | |
32018 | & 0.000D+00, 2.700D+00, 0.000D+00, 2.500D+00, 0.000D+00, 2.460D+00, | |
32019 | & 0.000D+00, 2.090D+00, 0.000D+00, 1.620D+00, 0.000D+00, 1.620D+00, | |
32020 | & 0.000D+00, 1.830D+00, 0.000D+00, 1.730D+00, 0.000D+00, 1.350D+00, | |
32021 | & 0.000D+00, 1.540D+00, 0.000D+00, 1.280D+00, 2.600D-01, 8.800D-01, | |
32022 | & 1.900D-01, 1.350D+00,-5.000D-02, 1.520D+00,-9.000D-02, 1.170D+00, | |
32023 | & 4.000D-02, 1.240D+00, 2.900D-01, 1.090D+00, 2.600D-01, 1.170D+00, | |
32024 | & 2.300D-01, 1.150D+00,-8.000D-02, 1.350D+00, 3.400D-01, 1.050D+00, | |
32025 | & 2.800D-01, 1.270D+00, 0.000D+00, 1.050D+00, 0.000D+00, 1.000D+00, | |
32026 | & 9.000D-02, 1.200D+00, 2.000D-01, 1.400D+00, 9.300D-01, 1.000D+00, | |
32027 | &-2.000D-01, 1.190D+00, 9.000D-02, 9.700D-01, 0.000D+00, 9.200D-01, | |
32028 | & 1.100D-01, 6.800D-01, 5.000D-02, 6.800D-01,-2.200D-01, 7.900D-01, | |
32029 | & 9.000D-02, 6.900D-01, 1.000D-02, 7.200D-01, 0.000D+00, 4.000D-01, | |
32030 | & 1.600D-01, 7.300D-01, 0.000D+00, 4.600D-01, 1.700D-01, 8.900D-01, | |
32031 | & 0.000D+00, 7.900D-01, 0.000D+00, 8.900D-01, 0.000D+00, 8.100D-01, | |
32032 | &-6.000D-02, 6.900D-01,-2.000D-01, 7.100D-01,-1.200D-01, 7.200D-01, | |
32033 | & 0.000D+00, 7.700D-01/ | |
32034 | DATA ( PNCOOK(I),I = 1, 90 ) / | |
32035 | & 0.000D+00, 5.980D+00, 0.000D+00, 2.770D+00, 0.000D+00, 3.160D+00, | |
32036 | & 0.000D+00, 3.010D+00, 0.000D+00, 2.500D+00, 0.000D+00, 2.670D+00, | |
32037 | & 0.000D+00, 1.800D+00, 0.000D+00, 1.670D+00, 0.000D+00, 1.860D+00, | |
32038 | & 0.000D+00, 2.040D+00, 0.000D+00, 1.640D+00, 0.000D+00, 1.440D+00, | |
32039 | & 0.000D+00, 1.540D+00, 0.000D+00, 1.300D+00, 0.000D+00, 1.270D+00, | |
32040 | & 0.000D+00, 1.290D+00, 8.000D-02, 1.410D+00,-8.000D-02, 1.500D+00, | |
32041 | &-5.000D-02, 2.240D+00,-4.700D-01, 1.430D+00,-1.500D-01, 1.440D+00, | |
32042 | & 6.000D-02, 1.560D+00, 2.500D-01, 1.570D+00,-1.600D-01, 1.460D+00, | |
32043 | & 0.000D+00, 9.300D-01, 1.000D-02, 6.200D-01,-5.000D-01, 1.420D+00, | |
32044 | & 1.300D-01, 1.520D+00,-6.500D-01, 8.000D-01,-8.000D-02, 1.290D+00, | |
32045 | &-4.700D-01, 1.250D+00,-4.400D-01, 9.700D-01, 8.000D-02, 1.650D+00, | |
32046 | &-1.100D-01, 1.260D+00,-4.600D-01, 1.060D+00, 2.200D-01, 1.550D+00, | |
32047 | &-7.000D-02, 1.370D+00, 1.000D-01, 1.200D+00,-2.700D-01, 9.200D-01, | |
32048 | &-3.500D-01, 1.190D+00, 0.000D+00, 1.050D+00,-2.500D-01, 1.610D+00, | |
32049 | &-2.100D-01, 9.000D-01,-2.100D-01, 7.400D-01,-3.800D-01, 7.200D-01/ | |
32050 | DATA ( PNCOOK(I),I = 91, INCOOK ) / | |
32051 | &-3.400D-01, 9.200D-01,-2.600D-01, 9.400D-01, 1.000D-02, 6.500D-01, | |
32052 | &-3.600D-01, 8.300D-01, 1.100D-01, 6.700D-01, 5.000D-02, 1.000D+00, | |
32053 | & 5.100D-01, 1.040D+00, 3.300D-01, 6.800D-01,-2.700D-01, 8.100D-01, | |
32054 | & 9.000D-02, 7.500D-01, 1.700D-01, 8.600D-01, 1.400D-01, 1.100D+00, | |
32055 | &-2.200D-01, 8.400D-01,-4.700D-01, 4.800D-01, 2.000D-02, 8.800D-01, | |
32056 | & 2.400D-01, 5.200D-01, 2.700D-01, 4.100D-01,-5.000D-02, 3.800D-01, | |
32057 | & 1.500D-01, 6.700D-01, 0.000D+00, 6.100D-01, 0.000D+00, 7.800D-01, | |
32058 | & 0.000D+00, 6.700D-01, 0.000D+00, 6.700D-01, 0.000D+00, 7.900D-01, | |
32059 | & 0.000D+00, 6.000D-01, 4.000D-02, 6.400D-01,-6.000D-02, 4.500D-01, | |
32060 | & 5.000D-02, 2.600D-01,-2.200D-01, 3.900D-01, 0.000D+00, 3.900D-01/ | |
32061 | DATA ( SZCOOK(I),I = 1, 98) / | |
32062 | & 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, | |
32063 | & 0.000D+00, 0.000D+00,-1.100D-01,-8.100D-01,-2.910D+00,-4.170D+00, | |
32064 | &-5.720D+00,-7.800D+00,-8.970D+00,-9.700D+00,-1.010D+01,-1.070D+01, | |
32065 | &-1.138D+01,-1.207D+01,-1.255D+01,-1.324D+01,-1.393D+01,-1.471D+01, | |
32066 | &-1.553D+01,-1.637D+01,-1.736D+01,-1.860D+01,-1.870D+01,-1.801D+01, | |
32067 | &-1.787D+01,-1.708D+01,-1.660D+01,-1.675D+01,-1.650D+01,-1.635D+01, | |
32068 | &-1.622D+01,-1.641D+01,-1.689D+01,-1.643D+01,-1.668D+01,-1.673D+01, | |
32069 | &-1.745D+01,-1.729D+01,-1.744D+01,-1.782D+01,-1.862D+01,-1.827D+01, | |
32070 | &-1.939D+01,-1.991D+01,-1.914D+01,-1.826D+01,-1.740D+01,-1.642D+01, | |
32071 | &-1.577D+01,-1.437D+01,-1.391D+01,-1.310D+01,-1.311D+01,-1.143D+01, | |
32072 | &-1.089D+01,-1.075D+01,-1.062D+01,-1.041D+01,-1.021D+01,-9.850D+00, | |
32073 | &-9.470D+00,-9.030D+00,-8.610D+00,-8.130D+00,-7.460D+00,-7.480D+00, | |
32074 | &-7.200D+00,-7.130D+00,-7.060D+00,-6.780D+00,-6.640D+00,-6.640D+00, | |
32075 | &-7.680D+00,-7.890D+00,-8.410D+00,-8.490D+00,-7.880D+00,-6.300D+00, | |
32076 | &-5.470D+00,-4.780D+00,-4.370D+00,-4.170D+00,-4.130D+00,-4.320D+00, | |
32077 | &-4.550D+00,-5.040D+00,-5.280D+00,-6.060D+00,-6.280D+00,-6.870D+00, | |
32078 | &-7.200D+00,-7.740D+00/ | |
32079 | DATA ( SNCOOK(I),I = 1, 90 ) / | |
32080 | & 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, | |
32081 | & 0.000D+00, 0.000D+00, 1.030D+01, 5.660D+00, 6.800D+00, 7.530D+00, | |
32082 | & 7.550D+00, 7.210D+00, 7.440D+00, 8.070D+00, 8.940D+00, 9.810D+00, | |
32083 | & 1.060D+01, 1.139D+01, 1.254D+01, 1.368D+01, 1.434D+01, 1.419D+01, | |
32084 | & 1.383D+01, 1.350D+01, 1.300D+01, 1.213D+01, 1.260D+01, 1.326D+01, | |
32085 | & 1.413D+01, 1.492D+01, 1.552D+01, 1.638D+01, 1.716D+01, 1.755D+01, | |
32086 | & 1.803D+01, 1.759D+01, 1.903D+01, 1.871D+01, 1.880D+01, 1.899D+01, | |
32087 | & 1.846D+01, 1.825D+01, 1.776D+01, 1.738D+01, 1.672D+01, 1.562D+01, | |
32088 | & 1.438D+01, 1.288D+01, 1.323D+01, 1.381D+01, 1.490D+01, 1.486D+01, | |
32089 | & 1.576D+01, 1.620D+01, 1.762D+01, 1.773D+01, 1.816D+01, 1.867D+01, | |
32090 | & 1.969D+01, 1.951D+01, 2.017D+01, 1.948D+01, 1.998D+01, 1.983D+01, | |
32091 | & 2.020D+01, 1.972D+01, 1.987D+01, 1.924D+01, 1.844D+01, 1.761D+01, | |
32092 | & 1.710D+01, 1.616D+01, 1.590D+01, 1.533D+01, 1.476D+01, 1.354D+01, | |
32093 | & 1.263D+01, 1.065D+01, 1.010D+01, 8.890D+00, 1.025D+01, 9.790D+00, | |
32094 | & 1.139D+01, 1.172D+01, 1.243D+01, 1.296D+01, 1.343D+01, 1.337D+01/ | |
32095 | DATA ( SNCOOK(I),I = 91, INCOOK ) / | |
32096 | & 1.296D+01, 1.211D+01, 1.192D+01, 1.100D+01, 1.080D+01, 1.042D+01, | |
32097 | & 1.039D+01, 9.690D+00, 9.270D+00, 8.930D+00, 8.570D+00, 8.020D+00, | |
32098 | & 7.590D+00, 7.330D+00, 7.230D+00, 7.050D+00, 7.420D+00, 6.750D+00, | |
32099 | & 6.600D+00, 6.380D+00, 6.360D+00, 6.490D+00, 6.250D+00, 5.850D+00, | |
32100 | & 5.480D+00, 4.530D+00, 4.300D+00, 3.390D+00, 2.350D+00, 1.660D+00, | |
32101 | & 8.100D-01, 4.600D-01,-9.600D-01,-1.690D+00,-2.530D+00,-3.160D+00, | |
32102 | &-1.870D+00,-4.100D-01, 7.100D-01, 1.660D+00, 2.620D+00, 3.220D+00, | |
32103 | & 3.760D+00, 4.100D+00, 4.460D+00, 4.830D+00, 5.090D+00, 5.180D+00, | |
32104 | & 5.170D+00, 5.100D+00, 5.010D+00, 4.970D+00, 5.090D+00, 5.030D+00, | |
32105 | & 4.930D+00, 5.280D+00, 5.490D+00, 5.500D+00, 5.370D+00, 5.300D+00/ | |
32106 | DATA LDEFOZ / 53*.FALSE.,25*.TRUE.,7*.FALSE.,13*.TRUE. / | |
32107 | DATA LDEFON / 85*.FALSE.,37*.TRUE.,7*.FALSE.,21*.TRUE. / | |
32108 | *=== End of Block Data Bdevap =========================================* | |
32109 | END | |
32110 | ||
32111 | *$ CREATE DT_BDNOPT.FOR | |
32112 | *COPY DT_BDNOPT | |
32113 | * | |
32114 | *=== bdnopt ===========================================================* | |
32115 | *== * | |
32116 | BLOCK DATA DT_BDNOPT | |
32117 | ||
32118 | C INCLUDE '(DBLPRC)' | |
32119 | * DBLPRC.ADD | |
32120 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
32121 | SAVE | |
32122 | * (original name: GLOBAL) | |
32123 | PARAMETER ( KALGNM = 2 ) | |
32124 | PARAMETER ( ANGLGB = 5.0D-16 ) | |
32125 | PARAMETER ( ANGLSQ = 2.5D-31 ) | |
32126 | PARAMETER ( AXCSSV = 0.2D+16 ) | |
32127 | PARAMETER ( ANDRFL = 1.0D-38 ) | |
32128 | PARAMETER ( AVRFLW = 1.0D+38 ) | |
32129 | PARAMETER ( AINFNT = 1.0D+30 ) | |
32130 | PARAMETER ( AZRZRZ = 1.0D-30 ) | |
32131 | PARAMETER ( EINFNT = +69.07755278982137 D+00 ) | |
32132 | PARAMETER ( EZRZRZ = -69.07755278982137 D+00 ) | |
32133 | PARAMETER ( EXCSSV = +35.23192357547063 D+00 ) | |
32134 | PARAMETER ( ENGLGB = -35.23192357547063 D+00 ) | |
32135 | PARAMETER ( ONEMNS = 0.999999999999999 D+00 ) | |
32136 | PARAMETER ( ONEPLS = 1.000000000000001 D+00 ) | |
32137 | PARAMETER ( CSNNRM = 2.0D-15 ) | |
32138 | PARAMETER ( DMXTRN = 1.0D+08 ) | |
32139 | PARAMETER ( ZERZER = 0.D+00 ) | |
32140 | PARAMETER ( ONEONE = 1.D+00 ) | |
32141 | PARAMETER ( TWOTWO = 2.D+00 ) | |
32142 | PARAMETER ( THRTHR = 3.D+00 ) | |
32143 | PARAMETER ( FOUFOU = 4.D+00 ) | |
32144 | PARAMETER ( FIVFIV = 5.D+00 ) | |
32145 | PARAMETER ( SIXSIX = 6.D+00 ) | |
32146 | PARAMETER ( SEVSEV = 7.D+00 ) | |
32147 | PARAMETER ( EIGEIG = 8.D+00 ) | |
32148 | PARAMETER ( ANINEN = 9.D+00 ) | |
32149 | PARAMETER ( TENTEN = 10.D+00 ) | |
32150 | PARAMETER ( HLFHLF = 0.5D+00 ) | |
32151 | PARAMETER ( ONETHI = ONEONE / THRTHR ) | |
32152 | PARAMETER ( TWOTHI = TWOTWO / THRTHR ) | |
32153 | PARAMETER ( ONEFOU = ONEONE / FOUFOU ) | |
32154 | PARAMETER ( THRTWO = THRTHR / TWOTWO ) | |
32155 | PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 ) | |
32156 | PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 ) | |
32157 | PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 ) | |
32158 | PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 ) | |
32159 | PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 ) | |
32160 | PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 ) | |
32161 | PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 ) | |
32162 | PARAMETER ( EULERO = 0.577215664901532860606512 D+00 ) | |
32163 | PARAMETER ( EULEXP = 1.781072417990197985236504 D+00 ) | |
32164 | PARAMETER ( EULLOG =-0.5495393129816448223376619 D+00 ) | |
32165 | PARAMETER ( E1M2EU = 0.8569023337737540831433017 D+00 ) | |
32166 | PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 ) | |
32167 | PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 ) | |
32168 | PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 ) | |
32169 | PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 ) | |
32170 | PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 ) | |
32171 | PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 ) | |
32172 | PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 ) | |
32173 | PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 ) | |
32174 | PARAMETER ( CLIGHT = 2.99792458 D+10 ) | |
32175 | PARAMETER ( AVOGAD = 6.0221367 D+23 ) | |
32176 | PARAMETER ( BOLTZM = 1.380658 D-23 ) | |
32177 | PARAMETER ( AMELGR = 9.1093897 D-28 ) | |
32178 | PARAMETER ( PLCKBR = 1.05457266 D-27 ) | |
32179 | PARAMETER ( ELCCGS = 4.8032068 D-10 ) | |
32180 | PARAMETER ( ELCMKS = 1.60217733 D-19 ) | |
32181 | PARAMETER ( AMUGRM = 1.6605402 D-24 ) | |
32182 | PARAMETER ( AMMUMU = 0.113428913 D+00 ) | |
32183 | PARAMETER ( AMPRMU = 1.007276470 D+00 ) | |
32184 | PARAMETER ( AMNEMU = 1.008664904 D+00 ) | |
32185 | PARAMETER ( ALPFSC = 7.2973530791728595 D-03 ) | |
32186 | PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 ) | |
32187 | PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 ) | |
32188 | PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 ) | |
32189 | PARAMETER ( PLABRC = 0.197327053 D+00 ) | |
32190 | PARAMETER ( AMELCT = 0.51099906 D-03 ) | |
32191 | PARAMETER ( AMUGEV = 0.93149432 D+00 ) | |
32192 | PARAMETER ( AMMUON = 0.105658389 D+00 ) | |
32193 | PARAMETER ( AMPRTN = 0.93827231 D+00 ) | |
32194 | PARAMETER ( AMNTRN = 0.93956563 D+00 ) | |
32195 | PARAMETER ( AMDEUT = 1.87561339 D+00 ) | |
32196 | PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13 | |
32197 | & * 1.D-09 ) | |
32198 | PARAMETER ( RCLSEL = 2.8179409183694872 D-13 ) | |
32199 | PARAMETER ( BLTZMN = 8.617385 D-14 ) | |
32200 | PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT ) | |
32201 | PARAMETER ( GFOHB3 = 1.16639 D-05 ) | |
32202 | PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC ) | |
32203 | PARAMETER ( SIN2TW = 0.2319 D+00 ) | |
32204 | PARAMETER ( GEVMEV = 1.0 D+03 ) | |
32205 | PARAMETER ( EMVGEV = 1.0 D-03 ) | |
32206 | PARAMETER ( ALGVMV = 6.90775527898214 D+00 ) | |
32207 | PARAMETER ( RADDEG = 180.D+00 / PIPIPI ) | |
32208 | PARAMETER ( DEGRAD = PIPIPI / 180.D+00 ) | |
32209 | LOGICAL LGBIAS, LGBANA | |
32210 | COMMON /FKGLOB/ LGBIAS, LGBANA | |
32211 | C INCLUDE '(DIMPAR)' | |
32212 | * DIMPAR.ADD | |
32213 | PARAMETER ( MXXRGN = 5000 ) | |
32214 | PARAMETER ( MXXMDF = 82 ) | |
32215 | PARAMETER ( MXXMDE = 54 ) | |
32216 | PARAMETER ( MFSTCK = 1000 ) | |
32217 | PARAMETER ( MESTCK = 100 ) | |
32218 | PARAMETER ( NELEMX = 80 ) | |
32219 | PARAMETER ( MPDPDX = 8 ) | |
32220 | PARAMETER ( ICOMAX = 180 ) | |
32221 | PARAMETER ( NSTBIS = 304 ) | |
32222 | PARAMETER ( IDMAXP = 220 ) | |
32223 | PARAMETER ( IDMXDC = 640 ) | |
32224 | PARAMETER ( MKBMX1 = 1 ) | |
32225 | PARAMETER ( MKBMX2 = 1 ) | |
32226 | C INCLUDE '(IOUNIT)' | |
32227 | * IOUNIT.ADD | |
32228 | PARAMETER ( LUNIN = 5 ) | |
32229 | PARAMETER ( LUNOUT = 6 ) | |
32230 | **sr 19.5. set error output-unit from 15 to 6 | |
32231 | PARAMETER ( LUNERR = 6 ) | |
32232 | PARAMETER ( LUNBER = 14 ) | |
32233 | PARAMETER ( LUNECH = 8 ) | |
32234 | PARAMETER ( LUNFLU = 13 ) | |
32235 | PARAMETER ( LUNGEO = 16 ) | |
32236 | PARAMETER ( LUNPMF = 12 ) | |
32237 | PARAMETER ( LUNRAN = 2 ) | |
32238 | PARAMETER ( LUNXSC = 9 ) | |
32239 | PARAMETER ( LUNDET = 17 ) | |
32240 | PARAMETER ( LUNRAY = 10 ) | |
32241 | PARAMETER ( LUNRDB = 1 ) | |
32242 | PARAMETER ( LUNPGO = 7 ) | |
32243 | PARAMETER ( LUNPGS = 4 ) | |
32244 | PARAMETER ( LUNSCR = 3 ) | |
32245 | * | |
32246 | *----------------------------------------------------------------------* | |
32247 | * * | |
32248 | * Created on 20 september 1989 by Alfredo Ferrari - Infn Milan * | |
32249 | * * | |
32250 | * Last change on 20-apr-95 by Alfredo Ferrari * | |
32251 | * * | |
32252 | *----------------------------------------------------------------------* | |
32253 | * | |
32254 | C INCLUDE '(BLNKCM)' | |
32255 | * BLNKCM.ADD | |
32256 | **sr 17.5. commented since not used here | |
32257 | C PARAMETER ( NBLNMX = 1100000 ) | |
32258 | C DIMENSION GMSTOR ( NBLNMX ), BRMBRR ( NBLNMX ), BRMEXP ( NBLNMX ), | |
32259 | C & BRMSIG ( NBLNMX ), SIGGTT ( KALGNM*NBLNMX ), | |
32260 | C & COMSCO ( NBLNMX ), LBSTOR ( KALGNM*NBLNMX ) | |
32261 | C REAL SIGGTT | |
32262 | C LOGICAL LBSTOR | |
32263 | C COMMON NSTOR ( KALGNM*NBLNMX ) | |
32264 | ** | |
32265 | **sr 18.5. commented since not used for evap. | |
32266 | C COMMON / ADDRCM / MBLNMX, KBLNKL, KGMBGN, KGMLST, KCMBGN, KCMLST, | |
32267 | C & KISBGN, KISLST, KDTBGN, KDTLST, KUBBGN, KUBLST, | |
32268 | C & KUXBGN, KUXLST, KTCBGN, KTCLST, KRNBGN, KRNLST, | |
32269 | C & KYLBGN, KYLLST, KXSBGN, KXSLST, KIHBGN, KIHLST, | |
32270 | C & KINBGN, KINLST, KIEBGN, KIELST, KETBGN, KETLST, | |
32271 | C & KRRBGN, KRRLST, KGLBGN, KGLLST, KNABGN, KNALST, | |
32272 | C & KGDBGN, KGDLST, KDWBGN, KDWLST, KGCBGN, KGCLST, | |
32273 | C & KWLBGN, KWLLST, KWHBGN, KWHLST, KWMBGN, KWMLST, | |
32274 | C & KWSBGN, KWSLST, KNDBGN, KNDLST, KDPBGN, KDPLST, | |
32275 | C & KRGBGN, KRGLST, KSGBGN, KSGLST, KBRBGN, KBRLST, | |
32276 | C & KTMBGN | |
32277 | ** | |
32278 | ||
32279 | C EQUIVALENCE ( NSTOR (1), GMSTOR (1) ) | |
32280 | C EQUIVALENCE ( NSTOR (1), BRMBRR (1) ) | |
32281 | C EQUIVALENCE ( NSTOR (1), BRMEXP (1) ) | |
32282 | C EQUIVALENCE ( NSTOR (1), BRMSIG (1) ) | |
32283 | C EQUIVALENCE ( NSTOR (1), COMSCO (1) ) | |
32284 | C EQUIVALENCE ( NSTOR (1), SIGGTT (1) ) | |
32285 | C EQUIVALENCE ( NSTOR (1), LBSTOR (1) ) | |
32286 | C INCLUDE '(BLNTMP)' | |
32287 | * BLNTMP.ADD | |
32288 | **sr 18.5. commented since not used for evap. | |
32289 | C COMMON / BLNTMP / KIHBTM, KINBTM, KIEBTM, KRRBTM, KGLBTM, KNABTM, | |
32290 | C & KGCBTM, KGDWTM, KBDWTM, KWLOTM, KWHITM, KWMUTM, | |
32291 | C & KWSHTM, KEXTTM, KSTXTM, KSTNTM, KECTTM, KPCTTM, | |
32292 | C & KLPBTM, NXXRGN | |
32293 | ** | |
32294 | C INCLUDE '(CMMDNR)' | |
32295 | * CMMDNR.ADD | |
32296 | **sr 18.5. commented since not used for evap. | |
32297 | C LOGICAL LFLDNR | |
32298 | C COMMON / CMMDNR / DDNEAR, LFLDNR | |
32299 | ** | |
32300 | C INCLUDE '(CTITLE)' | |
32301 | * CTITLE.ADD | |
32302 | **sr 18.5. commented since not used for evap. | |
32303 | C CHARACTER RUNTIT*80, RUNTIM*32, RUNKEY*10 | |
32304 | C COMMON / CTITLE / RUNTIT, RUNTIM, RUNKEY | |
32305 | C COMMON / CEXPCK / ITEXPI, ITEXMX | |
32306 | ** | |
32307 | C INCLUDE '(DETECT)' | |
32308 | * DETECT.ADD | |
32309 | **sr 18.5. commented since not used for evap. | |
32310 | C PARAMETER (NRGNMX = 10) | |
32311 | C PARAMETER (NDTCMX = 10) | |
32312 | C PARAMETER (NSCRMX = 10) | |
32313 | C PARAMETER (NDTBIN = 1024) | |
32314 | C CHARACTER*10 TITDET,TITSCO | |
32315 | C LOGICAL LDTCTR | |
32316 | C COMMON /DETCT/ EDTMIN(NDTCMX), EDTBIN(NDTCMX), EDTCUT(NDTCMX), | |
32317 | C & KDTREG(NRGNMX,NDTCMX), KDTDET(NDTCMX,NSCRMX), | |
32318 | C & NDTSCO, NDTDET, LDTCTR, IDTREG(MXXRGN), | |
32319 | C & KDTSCD(NSCRMX) | |
32320 | C COMMON /DETCH/ TITDET(NDTCMX), TITSCO(NSCRMX) | |
32321 | ** | |
32322 | C INCLUDE '(DETLOC)' | |
32323 | * DETLOC.ADD | |
32324 | **sr 18.5. commented since not used for evap. | |
32325 | C PARAMETER (NDTCM2 = 10) | |
32326 | C COMMON /DETLOC/ ACCUMP (NDTCM2), ACCUMN (NDTCM2), | |
32327 | C & ICOINC(NDTCM2), NCLAS | |
32328 | ** | |
32329 | C INCLUDE '(EMGTRN)' | |
32330 | * EMGTRN.ADD | |
32331 | **sr 18.5. commented since not used for evap. | |
32332 | C LOGICAL LMCSMG | |
32333 | C COMMON / EMGTRN / UMCSMG, VMCSMG, WMCSMG, LMCSMG | |
32334 | ** | |
32335 | C INCLUDE '(EMSHO)' | |
32336 | * EMSHO.ADD | |
32337 | **sr 18.5. commented since not used for evap. | |
32338 | C LOGICAL EMFLO, EMFHLO, EMFELO, LIMPRE, LEXPTE | |
32339 | C COMMON /EMSHO/ EMFETH, EMFPTH, EMFHET, EMFHPT, EMFBIA, EMFLO, | |
32340 | C & EMFHLO, EMFELO, LIMPRE, LEXPTE | |
32341 | ** | |
32342 | C INCLUDE '(EPISOR)' | |
32343 | * EPISOR.ADD | |
32344 | **sr 18.5. commented since not used for evap. | |
32345 | C LOGICAL LUSSRC | |
32346 | C COMMON/EPISOR/TKESUM,LUSSRC | |
32347 | ** | |
32348 | * (original name: FHEAVY,FHEAVC) | |
32349 | PARAMETER ( MXHEAV = 100 ) | |
32350 | CHARACTER*8 ANHEAV | |
32351 | COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV), | |
32352 | & CZHEAV (MXHEAV), TKHEAV (MXHEAV), | |
32353 | & PHEAVY (MXHEAV), WHEAVY (MXHEAV), | |
32354 | & AMHEAV ( 12 ) , AMNHEA ( 12 ) , | |
32355 | & KHEAVY (MXHEAV), ICHEAV ( 12 ) , | |
32356 | & IBHEAV ( 12 ) , NPHEAV | |
32357 | COMMON /FKFHVC/ ANHEAV ( 12 ) | |
32358 | * (original name: FINUC) | |
32359 | PARAMETER (MXP=999) | |
32360 | COMMON /FKFINU/ CXR (MXP), CYR (MXP), CZR (MXP), | |
32361 | & CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP), | |
32362 | & TKI (MXP), PLR (MXP), WEI (MXP), | |
32363 | & TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP, | |
32364 | & KPART (MXP) | |
32365 | C INCLUDE '(GENTHR)' | |
32366 | * GENTHR.ADD | |
32367 | **sr 18.5. commented since not used for evap. | |
32368 | C COMMON / GENTHR / PEANCT, PEAPIT, PLDNCT, PTHRSH (NALLWP), | |
32369 | C & PTHDFF (NALLWP), IJNUCR (NALLWP) | |
32370 | ** | |
32371 | C INCLUDE '(LOWNEU)' | |
32372 | * LOWNEU.ADD | |
32373 | **sr 18.5. commented since not used for evap. | |
32374 | C PARAMETER ( MXGTHN = 15 ) | |
32375 | C PARAMETER ( MXGLWN = 200 ) | |
32376 | C PARAMETER ( MXSHPP = 5 ) | |
32377 | C LOGICAL LCOMPN, LIMPRN, LBIASN, LDOWNN, LRECPR, LLOWWW, LLOWET | |
32378 | C CHARACTER*10 TITLOW | |
32379 | C COMMON / LOWNEU / ATOLOW (MXXMDF), WSHPLN (MXGLWN,MXSHPP), EXTWWL, | |
32380 | C & SHPIMP (MXGLWN), EXTETL (MXGLWN), WWAMFL, | |
32381 | C & VLLNTH (MXGTHN,MXXMDF), ABLNTH (MXGTHN,MXXMDF), | |
32382 | C & STLNTH (MXGTHN,MXXMDF), TMRTLN (MXXMDF), | |
32383 | C & TMNMLN (MXXMDF), ICHCPT (MXXMDF), | |
32384 | C & IGTMRT (MXXMDF), NEUMED (MXXMDF), | |
32385 | C & ID1MED (MXXMDF), ID2MED (MXXMDF), | |
32386 | C & ID3MED (MXXMDF), MGTMED (MXXMDF), | |
32387 | C & LCOMPN (MXXMDF), LRECPR (MXXMDF), KPRLOW, NMGP, | |
32388 | C & NMTG , IGRTHN, LIMPRN, LBIASN, LDOWNN, LLOWWW, | |
32389 | C & LLOWET, ICLMED, IKRBGN, INABGN, IDWBGN, IETBGN, | |
32390 | C & I0XSEC, IDXSEC, ISENAV, ISVELN, ISPNAV, IWWLWB, | |
32391 | C & IWWLWT, IPXBGN, NPXSEC | |
32392 | C COMMON / CHLWNT / TITLOW (MXXMDF) | |
32393 | ** | |
32394 | C INCLUDE '(LTCLCM)' | |
32395 | * LTCLCM.ADD | |
32396 | **sr 18.5. commented since not used for evap. | |
32397 | C COMMON / LTCLCM / MLATTC, NEWLAT, MLATLD, MLATM1, MLTSEN, MLTSM1 | |
32398 | ** | |
32399 | C INCLUDE '(MULBOU)' | |
32400 | * MULBOU.ADD | |
32401 | **sr 18.5. commented since not used for evap. | |
32402 | C LOGICAL LLDA , LAGAIN, LSTNEW, LARTEF, LNORML, LSENSE, LMGNOR | |
32403 | C COMMON / MULBOU / UOLD , VOLD , WOLD , UMAG , VMAG , WMAG , | |
32404 | C & UNORML, VNORML, WNORML, USENSE, VSENSE, WSENSE, | |
32405 | C & TSENSE, DDSENS, DSMALL, NSSENS, LLDA , LAGAIN, | |
32406 | C & LSTNEW, LARTEF, LNORML, LSENSE, LMGNOR | |
32407 | ** | |
32408 | C INCLUDE '(MULHD)' | |
32409 | * MULHD.ADD | |
32410 | **sr 18.5. commented since not used for evap. | |
32411 | C PARAMETER ( MXXPT1 = 1 ) | |
32412 | C PARAMETER ( TIMESS = 2.00D+00 ) | |
32413 | C PARAMETER ( TMSRLX = 1.50D+00 ) | |
32414 | C PARAMETER ( EPSINS = 0.15D+00 ) | |
32415 | C PARAMETER ( EPSRLX = 0.50D+00 ) | |
32416 | C PARAMETER ( SQEPSN = 0.3872983346207417 D+00 ) | |
32417 | C PARAMETER ( SQEPSR = 0.7071067811865475 D+00 ) | |
32418 | C PARAMETER ( PARNSI = 1.732050807568877 D+00 * SQEPSN ) | |
32419 | C PARAMETER ( PRNSR0 = 1.732050807568877 D+00 * SQEPSR ) | |
32420 | C PARAMETER ( R0NCMS = 1.20 D+00 ) | |
32421 | C LOGICAL LTOPT, LSRCRH, LNSCRH | |
32422 | C COMMON / MULHD / BLCC ( MXXMDF ), BLCCRA ( MXXMDF ), | |
32423 | C & XCC ( MXXMDF ), ZTILDE ( MXXMDF, 0:MXXPT1 ), | |
32424 | C & ALPZTL ( MXXMDF, 0:MXXPT1 ), RLDU ( MXXMDF ), | |
32425 | C & ALPZT2 ( MXXMDF, 0:MXXPT1 ), TEFF0 ( MXXMDF ), | |
32426 | C & XR0 ( MXXMDF ), ECUTM ( MXXMDF, 39, 2 ), | |
32427 | C & ESTEPF ( MXXMDF ), HTHNSZ ( MXXMDF, 39 ), | |
32428 | C & AE1O3 ( MXXMDF ), PARNSR ( MXXMDF ), | |
32429 | C & HEESLI ( MXXMDF ), THMSPR, THMSSC, HMSAMP, | |
32430 | C & HMREJE, LSRCRH ( MXXMDF ), LNSCRH ( MXXMDF ), | |
32431 | C & LTOPT ( MXXMDF ), NFSCAT | |
32432 | ** | |
32433 | * (original name: PAREVT) | |
32434 | LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX, | |
32435 | & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF | |
32436 | PARAMETER ( NALLWP = 39 ) | |
32437 | COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, | |
32438 | & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY, | |
32439 | & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV, | |
32440 | & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF | |
32441 | * (original name: RESNUC) | |
32442 | LOGICAL LRNFSS, LFRAGM | |
32443 | COMMON /FKRESN/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1, | |
32444 | & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT, | |
32445 | & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES, | |
32446 | & PYRES, PZRES, PTRES2, KTARP, KTARN, IGREYP, | |
32447 | & IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE, | |
32448 | & ICRES, IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU, | |
32449 | & IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG, | |
32450 | & IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS, | |
32451 | & LFRAGM | |
32452 | C INCLUDE '(SCOHLP)' | |
32453 | * SCOHLP.ADD | |
32454 | **sr 18.5. commented since not used for evap. | |
32455 | C LOGICAL LSCZER | |
32456 | C COMMON / SCOHLP / ISCRNG, JSCRNG, LSCZER | |
32457 | ** | |
32458 | C INCLUDE '(TRACKR)' | |
32459 | * TRACKR.ADD | |
32460 | **sr 18.5. commented since not used for evap. | |
32461 | C PARAMETER ( MXTRCK = 2500 ) | |
32462 | C LOGICAL LFSSSC | |
32463 | C COMMON / TRACKR / XTRACK ( 0:MXTRCK ), YTRACK ( 0:MXTRCK ), | |
32464 | C & ZTRACK ( 0:MXTRCK ), TTRACK ( MXTRCK ), | |
32465 | C & DTRACK ( MXTRCK ), ETRACK, PTRACK, WTRACK, | |
32466 | C & ATRACK, CTRACK, AKSHRT, AKLONG, WSCRNG, | |
32467 | C & NTRACK, MTRACK, JTRACK, KTRACK, MMTRCK, | |
32468 | C & LT1TRK, LT2TRK, LTRACK, LLOUSE, LFSSSC | |
32469 | ** | |
32470 | C INCLUDE '(USRBDX)' | |
32471 | * USRBDX.ADD | |
32472 | **sr 18.5. commented since not used for evap. | |
32473 | C PARAMETER ( MXUSBX = 600 ) | |
32474 | C LOGICAL LUSBDX, LFUSBX, LWUSBX, LLNUSX | |
32475 | C CHARACTER*10 TITUSX | |
32476 | C COMMON /USRBX/ EBXLOW(MXUSBX), EBXHGH(MXUSBX), ABXLOW(MXUSBX), | |
32477 | C & ABXHGH(MXUSBX), DEBXBN(MXUSBX), DABXBN(MXUSBX), | |
32478 | C & AUSBDX(MXUSBX), | |
32479 | C & NEBXBN(MXUSBX), NABXBN(MXUSBX), NR1USX(MXUSBX), | |
32480 | C & NR2USX(MXUSBX), ITUSBX(MXUSBX), IDUSBX(MXUSBX), | |
32481 | C & KBUSBX(MXUSBX), IPUSBX(MXUSBX), IGMUSX(MXUSBX), | |
32482 | C & LFUSBX(MXUSBX), LWUSBX(MXUSBX), LLNUSX(MXUSBX), | |
32483 | C & NUSRBX, LUSBDX | |
32484 | C COMMON /USXCH/ TITUSX(MXUSBX) | |
32485 | ** | |
32486 | C INCLUDE '(USRBIN)' | |
32487 | * USRBIN.ADD | |
32488 | **sr 18.5. commented since not used for evap. | |
32489 | C PARAMETER ( MXUSBN = 100 ) | |
32490 | C LOGICAL LUSBIN, LEVTBN, LNTZER, LUSEVT, LUSTKB, LTRKBN | |
32491 | C CHARACTER*10 TITUSB | |
32492 | C COMMON /USRBN/ XLOW (MXUSBN), XHIGH (MXUSBN), YLOW (MXUSBN), | |
32493 | C & YHIGH (MXUSBN), ZLOW (MXUSBN), ZHIGH (MXUSBN), | |
32494 | C & DXUSBN(MXUSBN), DYUSBN(MXUSBN), DZUSBN(MXUSBN), | |
32495 | C & TCUSBN(MXUSBN), BKUSBN(MXUSBN), B2USBN(MXUSBN), | |
32496 | C & NXBIN (MXUSBN), NYBIN (MXUSBN), NZBIN (MXUSBN), | |
32497 | C & ITUSBN(MXUSBN), IDUSBN(MXUSBN), KBUSBN(MXUSBN), | |
32498 | C & IPUSBN(MXUSBN), LEVTBN(MXUSBN), LNTZER(MXUSBN), | |
32499 | C & LTRKBN(MXUSBN), NUSRBN, LUSBIN, LUSEVT, LUSTKB | |
32500 | C COMMON /USRCH/ TITUSB(MXUSBN) | |
32501 | ** | |
32502 | C INCLUDE '(USRSNC)' | |
32503 | * USRSNC.ADD | |
32504 | **sr 18.5. commented since not used for evap. | |
32505 | C PARAMETER ( MXRSNC = 400 ) | |
32506 | C PARAMETER ( NMZMIN = -5 ) | |
32507 | C LOGICAL LURSNC | |
32508 | C CHARACTER*10 TIURSN | |
32509 | C COMMON /USRSNC/ VURSNC(MXRSNC), IZRHGH(MXRSNC), IMRHGH(MXRSNC), | |
32510 | C & NRURSN(MXRSNC), ITURSN(MXRSNC), KBURSN(MXRSNC), | |
32511 | C & IPURSN(MXRSNC), NURSNC, LURSNC | |
32512 | C COMMON /USRSCH/ TIURSN(MXRSNC) | |
32513 | C INCLUDE '(USRTRC)' | |
32514 | * USRTRC.ADD | |
32515 | **sr 18.5. commented since not used for evap. | |
32516 | C PARAMETER ( MXUSTC = 400 ) | |
32517 | C LOGICAL LUSRTC, LUSTRK, LUSCLL, LLNUTC | |
32518 | C CHARACTER*10 TITUTC | |
32519 | C COMMON /USRTC/ ETCLOW(MXUSTC), ETCHGH(MXUSTC), DETCBN(MXUSTC), | |
32520 | C & VUSRTC(MXUSTC), | |
32521 | C & IUSTRK(MXUSTC), IUSCLL(MXUSTC), NETCBN(MXUSTC), | |
32522 | C & NRUSTC(MXUSTC), ITUSTC(MXUSTC), IDUSTC(MXUSTC), | |
32523 | C & KBUSTC(MXUSTC), IPUSTC(MXUSTC), IGMUTC(MXUSTC), | |
32524 | C & LLNUTC(MXUSTC), NUSRTC, NUSTRK, NUSCLL, LUSRTC, | |
32525 | C & LUSTRK, LUSCLL | |
32526 | C COMMON /USTCH/ TITUTC(MXUSTC) | |
32527 | ** | |
32528 | C INCLUDE '(USRYLD)' | |
32529 | * USRYLD.ADD | |
32530 | **sr 18.5. commented since not used for evap. | |
32531 | C PARAMETER ( MXUSYL = 500 ) | |
32532 | C LOGICAL LUSRYL, LLNUYL, LSCUYL | |
32533 | C CHARACTER*10 TITUYL | |
32534 | C COMMON /USRYL/ EYLLOW(MXUSYL), EYLHGH(MXUSYL), DEYLBN(MXUSYL), | |
32535 | C & USNRYL(MXUSYL), SGUSYL(MXUSYL), AYLLOW(MXUSYL), | |
32536 | C & AYLHGH(MXUSYL), PUSRYL, UUSRYL, VUSRYL, WUSRYL, | |
32537 | C & ETXUYL, ETYUYL, ETZUYL, GAMUYL, SQSUYL, UCMUYL, | |
32538 | C & VCMUYL, WCMUYL, IJUSYL, JTUSYL, | |
32539 | C & NEYLBN(MXUSYL), NR1UYL(MXUSYL), NR2UYL(MXUSYL), | |
32540 | C & IXUSYL(MXUSYL), ITUSYL(MXUSYL), IDUSYL(MXUSYL), | |
32541 | C & KBUSYL(MXUSYL), IPUSYL(MXUSYL), IGMUYL(MXUSYL), | |
32542 | C & IEUSYL(MXUSYL), IAUSYL(MXUSYL), LLNUYL(MXUSYL), | |
32543 | C & NUSRYL, LUSRYL, LSCUYL | |
32544 | C COMMON /USYCH/ TITUYL(MXUSYL) | |
32545 | ** | |
32546 | C INCLUDE '(WWINDW)' | |
32547 | * WWINDW.ADD | |
32548 | **sr 18.5. commented since not used for evap. | |
32549 | C PARAMETER ( MXWWSP = 3 ) | |
32550 | C PARAMETER ( WWSPMX = 50.D+00 ) | |
32551 | C LOGICAL LWWNDW, LWWPRM | |
32552 | C COMMON / WWINDW / ETHWW1 (NALLWP), ETHWW2 (NALLWP), | |
32553 | C & WWEXWD (NALLWP), EXTWWN (NALLWP), | |
32554 | C & IWLBGN, IWHBGN, IWMBGN, LWWNDW, LWWPRM | |
32555 | ** | |
32556 | ||
32557 | * /blnkcm/ | |
32558 | * *** If blank common dimension has to be superseded substitute in the | |
32559 | * *** following two lines the new dimension in real*8 units to Nblnmx | |
32560 | **sr 18.5. commented since not used for evap. | |
32561 | C PARAMETER (MXDUMM = KALGNM * NBLNMX) | |
32562 | C DATA KTMBGN / NBLNMX / | |
32563 | C DATA MBLNMX / MXDUMM / | |
32564 | C DATA KBLNKL, KGMBGN, KGMLST, KCMBGN, KCMLST, KISBGN, KISLST, | |
32565 | C & KDTBGN, KDTLST, KUBBGN, KUBLST, KUXBGN, KUXLST, KTCBGN, | |
32566 | C & KTCLST, KRNBGN, KRNLST, KYLBGN, KYLLST, KXSBGN, KXSLST, | |
32567 | C & KIHBGN, KIHLST, KINBGN, KINLST, KIEBGN, KIELST, KETBGN, | |
32568 | C & KETLST, KRRBGN, KRRLST, KGLBGN, KGLLST, KNABGN, KNALST, | |
32569 | C & KGDBGN, KGDLST, KDWBGN, KDWLST, KGCBGN, KGCLST, KWLBGN, | |
32570 | C & KWLLST, KWHBGN, KWHLST, KWMBGN, KWMLST, KWSBGN, KWSLST, | |
32571 | C & KDPBGN, KDPLST, KRGBGN, KRGLST, KSGBGN, KSGLST, KBRBGN, | |
32572 | C & KBRLST / 57*0 / | |
32573 | ||
32574 | * /blntmp/ | |
32575 | **sr 18.5. commented since not used for evap. | |
32576 | C DATA KIHBTM, KINBTM, KIEBTM, KRRBTM, KGLBTM, KNABTM, KGDWTM, | |
32577 | C & KBDWTM, KGCBTM, KWLOTM, KWHITM, KWMUTM, KWSHTM, KEXTTM, | |
32578 | C & KSTXTM, KSTNTM, KECTTM, KPCTTM, KLPBTM / 19*0 / | |
32579 | ||
32580 | * /cmmdnr/ | |
32581 | **sr 18.5. commented since not used for evap. | |
32582 | C DATA DDNEAR / 0.D+00 /, LFLDNR / .FALSE. / | |
32583 | ||
32584 | * /ctitle/ | |
32585 | **sr 18.5. commented since not used for evap. | |
32586 | C DATA RUNTIT (1:40) / '****************************************' / | |
32587 | C DATA RUNTIT(41:80) / '****************************************' / | |
32588 | C DATA ITEXPI, ITEXMX / 100000000, 150 / | |
32589 | * /detect/ | |
32590 | **sr 18.5. commented since not used for evap. | |
32591 | C PARAMETER (NNN1 = NRGNMX*NDTCMX) | |
32592 | C PARAMETER (NNN2 = NSCRMX*NDTCMX) | |
32593 | C DATA LDTCTR /.FALSE./, NDTSCO /0/, NDTDET /0/ | |
32594 | C DATA EDTMIN/NDTCMX*0.D0/, EDTBIN/NDTCMX*0.D0/, EDTCUT/NDTCMX*0.D0/ | |
32595 | C DATA KDTREG/NNN1*0/, KDTDET/NNN2*0/, KDTSCD/NSCRMX*0/ | |
32596 | C DATA TITDET/NDTCMX*' '/, TITSCO/NSCRMX*' '/ | |
32597 | ||
32598 | * /detloc/ | |
32599 | **sr 18.5. commented since not used for evap. | |
32600 | C DATA ACCUMP /NDTCM2*0.D0/, ACCUMN /NDTCM2*0.D0/, ICOINC /NDTCM2*0/ | |
32601 | C DATA NCLAS /0/ | |
32602 | ||
32603 | * /emgtrn/ | |
32604 | **sr 18.5. commented since not used for evap. | |
32605 | C DATA LMCSMG / .FALSE. / | |
32606 | ||
32607 | * /emsho/ | |
32608 | **sr 18.5. commented since not used for evap. | |
32609 | C DATA LIMPRE, LEXPTE / 2 * .FALSE. / | |
32610 | ||
32611 | * /episor/ | |
32612 | **sr 18.5. commented since not used for evap. | |
32613 | C DATA TKESUM / 0.D+00 /, LUSSRC / .FALSE. / | |
32614 | ||
32615 | * /fheavy/ | |
32616 | DATA AMHEAV / 12 * 0.D+00 / | |
32617 | DATA ANHEAV / 'NEUTRON ', 'PROTON ', 'DEUTERON', '3-H ', | |
32618 | & '3-He ', '4-He ', 'H-FRAG-1', 'H-FRAG-2', | |
32619 | & 'H-FRAG-3', 'H-FRAG-4', 'H-FRAG-5', 'H-FRAG-6'/ | |
32620 | DATA ICHEAV / 0, 1, 1, 1, 2, 2, 6*0 /, | |
32621 | & IBHEAV / 1, 1, 2, 3, 3, 4, 6*0 / | |
32622 | DATA NPHEAV / 0 / | |
32623 | ||
32624 | * /finuc/ | |
32625 | DATA NP / 0 /, TV / 0.D+00 /, TVCMS / 0.D+00 /, TVRECL / 0.D+00/, | |
32626 | & TVHEAV / 0.D+00 /, TVBIND / 0.D+00 / | |
32627 | ||
32628 | * /genthr/ | |
32629 | * Up to 20-apr-'95 | |
32630 | * DATA PEANCT, PEAPIT / 2*1.D+00 / | |
32631 | * DATA PTHRSH / 16*5.D+00,2*2.5D+00,5.D+00,3*2.5D+00,8*5.D+00, | |
32632 | * & 9*2.5D+00 / | |
32633 | * DATA PTHDFF / 39*5.D+00 / | |
32634 | * & 9*2.5D+00 / | |
32635 | * New values: | |
32636 | **sr 18.5. commented since not used for evap. | |
32637 | C DATA PEANCT, PEAPIT / 1.3D+00, 1.1D+00 / | |
32638 | C DATA PTHRSH / 12*5.D+00, 2*3.5D+00, 2*5.D+00, 2*2.5D+00, 5.D+00, | |
32639 | C & 3*2.5D+00, 3.5D+00, 2*5.D+00, 3.5D+00, 4*5.D+00, | |
32640 | C & 9*2.5D+00 / | |
32641 | C DATA PTHDFF / 12*5.D+00, 2*3.5D+00, 8*5.D+00, 3.5D+00, 2*5.D+00, | |
32642 | C & 3.5D+00, 13*5.D+00 / | |
32643 | C DATA PLDNCT / 0.26D+00 / | |
32644 | C DATA IJNUCR / 16*1, 2*0, 1, 3*0, 8*1, 9*0 / | |
32645 | ||
32646 | * /lowneu/ | |
32647 | **sr 18.5. commented since not used for evap. | |
32648 | C DATA WWAMFL / 10.D+00 /, EXTWWL / 1.D+00 / | |
32649 | C DATA IWWLWB, IWWLWT / 2 * 100000000 / | |
32650 | C DATA ICLMED, INABGN, IDWBGN, IETBGN / 4*0 / | |
32651 | C DATA IGRTHN / 1 / | |
32652 | C DATA LIMPRN / .FALSE. /, LBIASN / .FALSE. /, LDOWNN / .FALSE. /, | |
32653 | C & LLOWWW / .FALSE. /, LLOWET / .FALSE. / | |
32654 | ||
32655 | * /ltclcm/ | |
32656 | **sr 18.5. commented since not used for evap. | |
32657 | C DATA MLATTC, NEWLAT, MLATLD, MLATM1, MLTSEN, MLTSM1 / 6*0 / | |
32658 | ||
32659 | * /mulbou/ | |
32660 | **sr 18.5. commented since not used for evap. | |
32661 | C DATA LLDA, LAGAIN, LSTNEW, LARTEF, LSENSE, LNORML, LMGNOR | |
32662 | C & / 7 * .FALSE. / | |
32663 | C DATA TSENSE / AINFNT /, NSSENS / -1 / | |
32664 | C DATA DSMALL / ANGLGB / | |
32665 | ||
32666 | * /mulhd/ | |
32667 | **sr 18.5. commented since not used for evap. | |
32668 | C DATA LTOPT / MXXMDF * .FALSE. /, NFSCAT / 0 / | |
32669 | C DATA ESTEPF / MXXMDF * 0.1D+00 / | |
32670 | C DATA LSRCRH / MXXMDF * .FALSE. /, LNSCRH / MXXMDF * .FALSE. / | |
32671 | C DATA THMSPR / 0.02D+00 /, THMSSC / 1.D+00 / | |
32672 | ||
32673 | * /parevt/ | |
32674 | DATA DPOWER /-13.D+00 /, FSPRD0 / 0.6D+00 /, FSHPFN / 0.0D+00 /, | |
32675 | & RN1GSC /-1.0D+00 /, RN2GSC /-1.0D+00 / | |
32676 | DATA LDIFFR / .TRUE., .TRUE., 6 * .TRUE., .TRUE., 8 * .TRUE., | |
32677 | & .TRUE., 4 * .TRUE., .TRUE., 3 * .TRUE., | |
32678 | & 4 * .FALSE., 9 * .TRUE./ | |
32679 | **sr 17.5.95 | |
32680 | * default value for LEVPRT changed (reset sr 25.7.97) | |
32681 | * default value for LHEAVY changed 25.7.97 | |
32682 | C DATA LPOWER / .TRUE. /, LINCTV / .TRUE. /, LEVPRT / .TRUE. /, | |
32683 | C & LHEAVY / .FALSE. /, LDEEXG / .TRUE. /, LGDHPR / .TRUE. /, | |
32684 | C & LPREEX / .TRUE. /, LHLFIX / .FALSE. /, LPRFIX / .FALSE. /, | |
32685 | C & LPARWV / .TRUE. /, LSNGCH / .TRUE. /, LSCHDF / .TRUE. / | |
32686 | DATA LPOWER / .TRUE. /, LINCTV / .TRUE. /, LEVPRT / .TRUE. /, | |
32687 | & LHEAVY / .TRUE. /, LDEEXG / .TRUE. /, LGDHPR / .TRUE. /, | |
32688 | & LPREEX / .TRUE. /, LHLFIX / .FALSE. /, LPRFIX / .FALSE. /, | |
32689 | & LPARWV / .TRUE. /, LSNGCH / .TRUE. /, LSCHDF / .TRUE. / | |
32690 | ** | |
32691 | **sr 27.5.97 | |
32692 | * default value for ILVMOD changed | |
32693 | C DATA ILVMOD / 0 /, JLVMOD / 1 /, LLVMOD / .TRUE. / | |
32694 | DATA ILVMOD / 1 /, JLVMOD / 1 /, LLVMOD / .TRUE. / | |
32695 | ** | |
32696 | ||
32697 | * /resnuc/ | |
32698 | DATA IPREEH / 0 /, IPRTRI / 0 /, IPRDEU / 0 /, IPR3HE / 0 /, | |
32699 | & IPR4HE / 0 / | |
32700 | DATA IEVAPL / 0 /, IEVAPH / 0 /, IEVNEU / 0 /, IEVPRO / 0 /, | |
32701 | & IEVTRI / 0 /, IEVDEU / 0 /, IEV3HE / 0 /, IEV4HE / 0 /, | |
32702 | & IDEEXG / 0 / | |
32703 | DATA LRNFSS / .FALSE. / | |
32704 | ||
32705 | * /scohlp/ | |
32706 | **sr 18.5. commented since not used for evap. | |
32707 | C DATA ISCRNG, JSCRNG / 2*0 /, LSCZER / .FALSE. / | |
32708 | ||
32709 | * /trackr/ | |
32710 | **sr 18.5. commented since not used for evap. | |
32711 | C DATA ETRACK /0.D+00/, WTRACK /0.D+00/, ATRACK /0.D+00/, | |
32712 | C & CTRACK /0.D+00/, NTRACK /0/, MTRACK /0/, JTRACK /0/ | |
32713 | ||
32714 | * /usrbin/ | |
32715 | **sr 18.5. commented since not used for evap. | |
32716 | C DATA LUSBIN, LUSEVT, LUSTKB /3*.FALSE./, NUSRBN /0/ | |
32717 | ||
32718 | * /usrbdx/ | |
32719 | **sr 18.5. commented since not used for evap. | |
32720 | C DATA LUSBDX /.FALSE./, NUSRBX /0/ | |
32721 | ||
32722 | * /usrsnc/ | |
32723 | **sr 18.5. commented since not used for evap. | |
32724 | C DATA LURSNC /.FALSE./, NURSNC /0/ | |
32725 | ||
32726 | * /usrtrc/ | |
32727 | **sr 18.5. commented since not used for evap. | |
32728 | C DATA LUSRTC, LUSTRK, LUSCLL / 3*.FALSE. / | |
32729 | C DATA NUSRTC, NUSTRK, NUSCLL / 3*0 / | |
32730 | ||
32731 | * /usryld/ | |
32732 | **sr 18.5. commented since not used for evap. | |
32733 | C DATA LUSRYL / .FALSE./, LSCUYL / .FALSE. /, NUSRYL /0/, | |
32734 | C & IJUSYL /0/, JTUSYL /0/ | |
32735 | C DATA PUSRYL, UUSRYL, VUSRYL, WUSRYL / 4*ZERZER / | |
32736 | ||
32737 | * /wwindw/ | |
32738 | **sr 18.5. commented since not used for evap. | |
32739 | C DATA IWLBGN, IWHBGN, IWMBGN / 3*0 / | |
32740 | C DATA LWWPRM / .TRUE. / | |
32741 | ||
32742 | *= end*block.bdnopt * | |
32743 | END | |
32744 | ||
32745 | *$ CREATE DT_BDPREE.FOR | |
32746 | *COPY DT_BDPREE | |
32747 | * | |
32748 | *=== bdpree ===========================================================* | |
32749 | * | |
32750 | BLOCK DATA DT_BDPREE | |
32751 | ||
32752 | C INCLUDE '(DBLPRC)' | |
32753 | * DBLPRC.ADD | |
32754 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
32755 | SAVE | |
32756 | * (original name: GLOBAL) | |
32757 | PARAMETER ( KALGNM = 2 ) | |
32758 | PARAMETER ( ANGLGB = 5.0D-16 ) | |
32759 | PARAMETER ( ANGLSQ = 2.5D-31 ) | |
32760 | PARAMETER ( AXCSSV = 0.2D+16 ) | |
32761 | PARAMETER ( ANDRFL = 1.0D-38 ) | |
32762 | PARAMETER ( AVRFLW = 1.0D+38 ) | |
32763 | PARAMETER ( AINFNT = 1.0D+30 ) | |
32764 | PARAMETER ( AZRZRZ = 1.0D-30 ) | |
32765 | PARAMETER ( EINFNT = +69.07755278982137 D+00 ) | |
32766 | PARAMETER ( EZRZRZ = -69.07755278982137 D+00 ) | |
32767 | PARAMETER ( EXCSSV = +35.23192357547063 D+00 ) | |
32768 | PARAMETER ( ENGLGB = -35.23192357547063 D+00 ) | |
32769 | PARAMETER ( ONEMNS = 0.999999999999999 D+00 ) | |
32770 | PARAMETER ( ONEPLS = 1.000000000000001 D+00 ) | |
32771 | PARAMETER ( CSNNRM = 2.0D-15 ) | |
32772 | PARAMETER ( DMXTRN = 1.0D+08 ) | |
32773 | PARAMETER ( ZERZER = 0.D+00 ) | |
32774 | PARAMETER ( ONEONE = 1.D+00 ) | |
32775 | PARAMETER ( TWOTWO = 2.D+00 ) | |
32776 | PARAMETER ( THRTHR = 3.D+00 ) | |
32777 | PARAMETER ( FOUFOU = 4.D+00 ) | |
32778 | PARAMETER ( FIVFIV = 5.D+00 ) | |
32779 | PARAMETER ( SIXSIX = 6.D+00 ) | |
32780 | PARAMETER ( SEVSEV = 7.D+00 ) | |
32781 | PARAMETER ( EIGEIG = 8.D+00 ) | |
32782 | PARAMETER ( ANINEN = 9.D+00 ) | |
32783 | PARAMETER ( TENTEN = 10.D+00 ) | |
32784 | PARAMETER ( HLFHLF = 0.5D+00 ) | |
32785 | PARAMETER ( ONETHI = ONEONE / THRTHR ) | |
32786 | PARAMETER ( TWOTHI = TWOTWO / THRTHR ) | |
32787 | PARAMETER ( ONEFOU = ONEONE / FOUFOU ) | |
32788 | PARAMETER ( THRTWO = THRTHR / TWOTWO ) | |
32789 | PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 ) | |
32790 | PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 ) | |
32791 | PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 ) | |
32792 | PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 ) | |
32793 | PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 ) | |
32794 | PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 ) | |
32795 | PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 ) | |
32796 | PARAMETER ( EULERO = 0.577215664901532860606512 D+00 ) | |
32797 | PARAMETER ( EULEXP = 1.781072417990197985236504 D+00 ) | |
32798 | PARAMETER ( EULLOG =-0.5495393129816448223376619 D+00 ) | |
32799 | PARAMETER ( E1M2EU = 0.8569023337737540831433017 D+00 ) | |
32800 | PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 ) | |
32801 | PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 ) | |
32802 | PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 ) | |
32803 | PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 ) | |
32804 | PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 ) | |
32805 | PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 ) | |
32806 | PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 ) | |
32807 | PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 ) | |
32808 | PARAMETER ( CLIGHT = 2.99792458 D+10 ) | |
32809 | PARAMETER ( AVOGAD = 6.0221367 D+23 ) | |
32810 | PARAMETER ( BOLTZM = 1.380658 D-23 ) | |
32811 | PARAMETER ( AMELGR = 9.1093897 D-28 ) | |
32812 | PARAMETER ( PLCKBR = 1.05457266 D-27 ) | |
32813 | PARAMETER ( ELCCGS = 4.8032068 D-10 ) | |
32814 | PARAMETER ( ELCMKS = 1.60217733 D-19 ) | |
32815 | PARAMETER ( AMUGRM = 1.6605402 D-24 ) | |
32816 | PARAMETER ( AMMUMU = 0.113428913 D+00 ) | |
32817 | PARAMETER ( AMPRMU = 1.007276470 D+00 ) | |
32818 | PARAMETER ( AMNEMU = 1.008664904 D+00 ) | |
32819 | PARAMETER ( ALPFSC = 7.2973530791728595 D-03 ) | |
32820 | PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 ) | |
32821 | PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 ) | |
32822 | PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 ) | |
32823 | PARAMETER ( PLABRC = 0.197327053 D+00 ) | |
32824 | PARAMETER ( AMELCT = 0.51099906 D-03 ) | |
32825 | PARAMETER ( AMUGEV = 0.93149432 D+00 ) | |
32826 | PARAMETER ( AMMUON = 0.105658389 D+00 ) | |
32827 | PARAMETER ( AMPRTN = 0.93827231 D+00 ) | |
32828 | PARAMETER ( AMNTRN = 0.93956563 D+00 ) | |
32829 | PARAMETER ( AMDEUT = 1.87561339 D+00 ) | |
32830 | PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13 | |
32831 | & * 1.D-09 ) | |
32832 | PARAMETER ( RCLSEL = 2.8179409183694872 D-13 ) | |
32833 | PARAMETER ( BLTZMN = 8.617385 D-14 ) | |
32834 | PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT ) | |
32835 | PARAMETER ( GFOHB3 = 1.16639 D-05 ) | |
32836 | PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC ) | |
32837 | PARAMETER ( SIN2TW = 0.2319 D+00 ) | |
32838 | PARAMETER ( GEVMEV = 1.0 D+03 ) | |
32839 | PARAMETER ( EMVGEV = 1.0 D-03 ) | |
32840 | PARAMETER ( ALGVMV = 6.90775527898214 D+00 ) | |
32841 | PARAMETER ( RADDEG = 180.D+00 / PIPIPI ) | |
32842 | PARAMETER ( DEGRAD = PIPIPI / 180.D+00 ) | |
32843 | LOGICAL LGBIAS, LGBANA | |
32844 | COMMON /FKGLOB/ LGBIAS, LGBANA | |
32845 | C INCLUDE '(DIMPAR)' | |
32846 | * DIMPAR.ADD | |
32847 | PARAMETER ( MXXRGN = 5000 ) | |
32848 | PARAMETER ( MXXMDF = 82 ) | |
32849 | PARAMETER ( MXXMDE = 54 ) | |
32850 | PARAMETER ( MFSTCK = 1000 ) | |
32851 | PARAMETER ( MESTCK = 100 ) | |
32852 | PARAMETER ( NALLWP = 39 ) | |
32853 | PARAMETER ( NELEMX = 80 ) | |
32854 | PARAMETER ( MPDPDX = 8 ) | |
32855 | PARAMETER ( ICOMAX = 180 ) | |
32856 | PARAMETER ( NSTBIS = 304 ) | |
32857 | PARAMETER ( IDMAXP = 220 ) | |
32858 | PARAMETER ( IDMXDC = 640 ) | |
32859 | PARAMETER ( MKBMX1 = 1 ) | |
32860 | PARAMETER ( MKBMX2 = 1 ) | |
32861 | C INCLUDE '(IOUNIT)' | |
32862 | * IOUNIT.ADD | |
32863 | PARAMETER ( LUNIN = 5 ) | |
32864 | PARAMETER ( LUNOUT = 6 ) | |
32865 | **sr 19.5. set error output-unit from 15 to 6 | |
32866 | PARAMETER ( LUNERR = 6 ) | |
32867 | PARAMETER ( LUNBER = 14 ) | |
32868 | PARAMETER ( LUNECH = 8 ) | |
32869 | PARAMETER ( LUNFLU = 13 ) | |
32870 | PARAMETER ( LUNGEO = 16 ) | |
32871 | PARAMETER ( LUNPMF = 12 ) | |
32872 | PARAMETER ( LUNRAN = 2 ) | |
32873 | PARAMETER ( LUNXSC = 9 ) | |
32874 | PARAMETER ( LUNDET = 17 ) | |
32875 | PARAMETER ( LUNRAY = 10 ) | |
32876 | PARAMETER ( LUNRDB = 1 ) | |
32877 | PARAMETER ( LUNPGO = 7 ) | |
32878 | PARAMETER ( LUNPGS = 4 ) | |
32879 | PARAMETER ( LUNSCR = 3 ) | |
32880 | * | |
32881 | *----------------------------------------------------------------------* | |
32882 | * * | |
32883 | * Created on 16 september 1991 by Alfredo Ferrari & Paola Sala * | |
32884 | * Infn - Milan * | |
32885 | * * | |
32886 | * Last change on 03-feb-94 by Alfredo Ferrari * | |
32887 | * * | |
32888 | * * | |
32889 | *----------------------------------------------------------------------* | |
32890 | * | |
32891 | * (original name: CMPISG,CHPISG) | |
32892 | PARAMETER ( TPPPI0 = 0.279656044337515D+00 ) | |
32893 | PARAMETER ( TNNPI0 = 0.279642680857450D+00 ) | |
32894 | PARAMETER ( TPPPIP = 0.292295207182790D+00 ) | |
32895 | PARAMETER ( TPPDEP = 0.287514778898469D+00 ) | |
32896 | PARAMETER ( TNNPIM = 0.286723140900975D+00 ) | |
32897 | PARAMETER ( TNNDEM = 0.281949292916434D+00 ) | |
32898 | PARAMETER ( TPNPI0 = 0.279456888147740D+00 ) | |
32899 | PARAMETER ( TPNDE0 = 0.274693916135245D+00 ) | |
32900 | PARAMETER ( TPNPIP = 0.292086756473890D+00 ) | |
32901 | PARAMETER ( TNPPI0 = 0.279842093144975D+00 ) | |
32902 | PARAMETER ( TNPDE0 = 0.275072555824202D+00 ) | |
32903 | PARAMETER ( TNPPIP = 0.292489370554958D+00 ) | |
32904 | PARAMETER ( PIRSMX = 1.2D+00 ) | |
32905 | PARAMETER ( NPIREA = 10 ) | |
32906 | PARAMETER ( NPIRTA = 68 ) | |
32907 | PARAMETER ( NPIRLN = 21 ) | |
32908 | PARAMETER ( NPIRLG = NPIRTA - NPIRLN ) | |
32909 | PARAMETER ( NPISIS = NPIRLN + 20 ) | |
32910 | PARAMETER ( NPISEX = NPIRLN + 21 ) | |
32911 | PARAMETER ( NPIIMN = 14 ) | |
32912 | PARAMETER ( NPIIRC = 6 ) | |
32913 | PARAMETER ( DELWLL = 0.035D+00 ) | |
32914 | CHARACTER CHPIRE*8 | |
32915 | LOGICAL LDLRES | |
32916 | COMMON /FKCMPI/ PMNPIS, PMMPIS, PISPIS, PEXPIS, PMXPIS, DPPISG, | |
32917 | & RTPISG, AMNPIS, AMMPIS, AISPIS, AEXPIS, AMXPIS, | |
32918 | & ARPISG, BPISLO (NPIRLN:NPIRTA,NPIREA), | |
32919 | & CPISLO (NPIRLN:NPIRTA,NPIREA), PPITHR (NPIREA), | |
32920 | & SPISLO (NPIRLN:NPIRTA,NPIREA), APITHR (NPIREA), | |
32921 | & SGPIIN (NPIIMN:NPIRTA,NPIIRC), RHPICR (1:5) , | |
32922 | & SGPICU (0:20,NPIRTA,NPIREA) , SGRTRS (NPIREA), | |
32923 | & SGPIDF (0:20,NPIRTA,NPIREA) , BRREIN (NPIREA), | |
32924 | & SGPIIS (NPIRTA,NPIREA) , BRREOU (NPIREA), | |
32925 | & BRD3OU (2,2,-1:2), BRDEOU (2,-1:2), | |
32926 | & SGABSR (2,2,4) , PRRSDL, | |
32927 | & IPIREA (2,2,3:5) , IPIINE (2,3:5) , NPIRVR , | |
32928 | & KPIIRE (2,NPIREA), KPIORE (2,NPIREA) , | |
32929 | & JSTOKP (5), KPTOJS (23), ITTRRS (3:5), LDLRES | |
32930 | COMMON /FKCHPI/ CHPIRE (NPIREA) | |
32931 | DIMENSION SG2BRS (2,2), SGABSW (2,2), SG3BRS (2,2,2) | |
32932 | EQUIVALENCE ( SG2BRS (1,1), SGABSR (1,1,1) ) | |
32933 | EQUIVALENCE ( SGABSW (1,1), SGABSR (1,1,2) ) | |
32934 | EQUIVALENCE ( SG3BRS (1,1,1), SGABSR (1,1,3) ) | |
32935 | * (original name: FRBKCM) | |
32936 | PARAMETER ( MXFFBK = 6 ) | |
32937 | PARAMETER ( MXZFBK = 9 ) | |
32938 | PARAMETER ( MXNFBK = 10 ) | |
32939 | PARAMETER ( MXAFBK = 16 ) | |
32940 | PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 ) | |
32941 | PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 ) | |
32942 | PARAMETER ( NXAFBK = MXAFBK + 1 ) | |
32943 | PARAMETER ( MXPSST = 300 ) | |
32944 | PARAMETER ( MXPSFB = 41000 ) | |
32945 | LOGICAL LFRMBK, LNCMSS | |
32946 | COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST), | |
32947 | & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB), | |
32948 | & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK, | |
32949 | & IFRBKN (MXPSST), IFRBKZ (MXPSST), | |
32950 | & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST), | |
32951 | & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK), | |
32952 | & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK), | |
32953 | & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF, | |
32954 | & IFBFRB, NBUFBK, LFRMBK, LNCMSS | |
32955 | * (original name: NUCGID,NUCGEO,NUCGE2,NUCPWI,NUCGII) | |
32956 | PARAMETER ( PI = PIPIPI ) | |
32957 | PARAMETER ( PISQ = PIPISQ ) | |
32958 | PARAMETER ( SKTOHL = 0.5456645846610345D+00 ) | |
32959 | PARAMETER ( RZNUCL = 1.12 D+00 ) | |
32960 | PARAMETER ( RMSPRO = 0.8 D+00 ) | |
32961 | PARAMETER ( R0PROT = RMSPRO / SQRT12 ) | |
32962 | PARAMETER ( ARHPRO = 1.D+00 / 8.D+00 / PI / R0PROT / R0PROT | |
32963 | & / R0PROT ) | |
32964 | PARAMETER ( RLLE04 = RZNUCL ) | |
32965 | PARAMETER ( RLLE16 = RZNUCL ) | |
32966 | PARAMETER ( RLGT16 = RZNUCL ) | |
32967 | PARAMETER ( RCLE04 = 0.75D+00 / PI / RLLE04 / RLLE04 / RLLE04 ) | |
32968 | PARAMETER ( RCLE16 = 0.75D+00 / PI / RLLE16 / RLLE16 / RLLE16 ) | |
32969 | PARAMETER ( RCGT16 = 0.75D+00 / PI / RLGT16 / RLGT16 / RLGT16 ) | |
32970 | PARAMETER ( SKLE04 = 1.4D+00 ) | |
32971 | PARAMETER ( SKLE16 = 1.9D+00 ) | |
32972 | PARAMETER ( SKGT16 = 2.4D+00 ) | |
32973 | PARAMETER ( HLLE04 = SKTOHL * SKLE04 ) | |
32974 | PARAMETER ( HLLE16 = SKTOHL * SKLE16 ) | |
32975 | PARAMETER ( HLGT16 = SKTOHL * SKGT16 ) | |
32976 | PARAMETER ( ALPHA0 = 0.1D+00 ) | |
32977 | PARAMETER ( OMALH0 = 1.D+00 - ALPHA0 ) | |
32978 | PARAMETER ( GAMSK0 = 0.9D+00 ) | |
32979 | PARAMETER ( OMGAS0 = 1.D+00 - GAMSK0 ) | |
32980 | PARAMETER ( POTME0 = 0.6666666666666667D+00 ) | |
32981 | PARAMETER ( POTBA0 = 1.D+00 ) | |
32982 | PARAMETER ( PNFRAT = 1.533D+00 ) | |
32983 | PARAMETER ( RADPIM = 0.035D+00 ) | |
32984 | PARAMETER ( RDPMHL = 14.D+00 ) | |
32985 | PARAMETER ( APMRST = 4.D+00 / 44.D+00 ) | |
32986 | PARAMETER ( APMPRO = 1.D+00 / 6.D+00 ) | |
32987 | PARAMETER ( APPPRO = 5.D+00 / 6.D+00 ) | |
32988 | PARAMETER ( AP0PFS = 0.5D+00 ) | |
32989 | PARAMETER ( AP0PFP = 1.D+00 / 3.D+00 ) | |
32990 | PARAMETER ( AP0NFP = 2.D+00 / 3.D+00 ) | |
32991 | PARAMETER ( XPAUCO = 1.88495407241652 D+00 ) | |
32992 | PARAMETER ( MXSCIN = 50 ) | |
32993 | LOGICAL LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH, LNCDCY, | |
32994 | & LNUSCT, LPREEQ, LNPHTC, LNWRAD, LPNRHO, LFTCMP, LFTCAC | |
32995 | COMMON /FKNGID/ RHOTAB (2:260), RHATAB (2:260), ALPTAB (2:260), | |
32996 | & RADTAB (2:260), SKITAB (2:260), HALTAB (2:260), | |
32997 | & SK3TAB (2:260), SK4TAB (2:260), HABTAB (2:260), | |
32998 | & CWSTAB (2:260), EKATAB (2:260), PFATAB (2:260), | |
32999 | & PFRTAB (2:260) | |
33000 | COMMON /FKNGEO/ RADTOT, RADIU1, RADIU0, RAD1O2, SKINDP, HALODP, | |
33001 | & ALPHAL, OMALHL, RADSKN, SKNEFF, CPARWS, RADPRO, | |
33002 | & RADCOR, RADCO2, RADMAX, BIMPTR, RIMPTR, XIMPTR, | |
33003 | & YIMPTR, ZIMPTR, RHOIMT, EKFPRO, PFRPRO, RHOCEN, | |
33004 | & RHOCOR, RHOSKN, EKFCEN (2), PFRCEN (2), EKFBIM, | |
33005 | & PFRBIM, RHOIMP, EKFIMP, PFRIMP, RHOIM2, EKFIM2, | |
33006 | & PFRIM2, RHOIM3, EKFIM3, PFRIM3, VPRWLL, RIMPCT, | |
33007 | & BIMPCT, XIMPCT, YIMPCT, ZIMPCT, RIMPC2, XIMPC2, | |
33008 | & YIMPC2, ZIMPC2, RIMPC3, XIMPC3, YIMPC3, ZIMPC3, | |
33009 | & XBIMPC, YBIMPC, ZBIMPC, CXIMPC, CYIMPC, CZIMPC, | |
33010 | & SQRIMP, SIGMAP, SIGMAN, SIGMAA, RHORED, R0TRAJ, | |
33011 | & R1TRAJ, SBUSED, SBTOT , SBRES , RHOAVE, EKFAVE, | |
33012 | & PFRAVE, AVEBIN, ACOLL , ZCOLL , RADSIG, OPACTY, | |
33013 | & EKECON, PNUCCO, EKEWLL, PPRWLL, PXPROJ, PYPROJ, | |
33014 | & PZPROJ, EKFERM, PNFRMI, PXFERM, PYFERM, PZFERM, | |
33015 | & EKFER2, PNFRM2, PXFER2, PYFER2, PZFER2, EKFER3, | |
33016 | & PNFRM3, PXFER3, PYFER3, PZFER3, RHOMEM, EKFMEM, | |
33017 | & BIMMEM, WLLRED, VPRBIM, POTINC, POTOUT, EEXMIN | |
33018 | COMMON /FKNGE2/ RDTTNC (2), RHONCP (2), RHONC2 (2), RHONC3 (2), | |
33019 | & RHONCT (2), AMOTHR, EKOTHR, AMCREA, EKNCLN, | |
33020 | & EEXDEL, EEXANY, CLMBBR, RDCLMB, BFCLMB, BFCEFF, | |
33021 | & BNPROJ, BNDNUC, DEBRLM, SK4PAR, UBIMPC, VBIMPC, | |
33022 | & WBIMPC, BNDPOT, SIGMAT, SIGABP, SIGABN, WLLRES, | |
33023 | & POTBAR, POTMES, AGEPRI, OPNOPA, ETHRND, | |
33024 | & BNENRG (3), DEFNUC (2), SIGMPR (4), SIGMNU (4), | |
33025 | & SIGPAB (3), SIGNAB (3), HHLP (2), FORTOT (2), | |
33026 | & FPNBLC, DPNBLC, FFTFLG, IFTFLG, | |
33027 | & IPWELL, ITNCMX, KPRIN , NTARGT, KNUCIM, KNUCI2, | |
33028 | & KNUCI3, IEVPRE, ISFCOL, ISFTAR, ISFTA2, ISFTA3, | |
33029 | & NPOTHR, ICOTHR, IBOTHR, NPUMFN, ISTNCL, ITAUCM, | |
33030 | & IABCOU, IADFLG, IGSFLG, IALFLG, ICBFLG, LPREEQ, | |
33031 | & LNPHTC, LPNRHO, LNWRAD, LFTCMP, LFTCAC | |
33032 | COMMON /FKNPWI/ ALMBAR, BIMMAX, SIGGEO, LLLMAX, LLLACT | |
33033 | COMMON /FKNGII/ HOLEXP (2*MXSCIN), XEXPIN (3,0:MXSCIN), | |
33034 | & YEXPIN (3,0:MXSCIN), ZEXPIN (3,0:MXSCIN), | |
33035 | & AGEXIN (0:MXSCIN), RHOEXP (2), EKFEXP, EHLFIX, | |
33036 | & NHLEXP, NHLFIX, IPRTYP, NNCEXI (0:MXSCIN), | |
33037 | & NCEXPI (3,0:MXSCIN), ISEXIN (3,0:MXSCIN), | |
33038 | & ISCTYP (0:MXSCIN), NUSCIN, NEXPEM, | |
33039 | & LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH, | |
33040 | & LNCDCY, LNUSCT | |
33041 | DIMENSION AWSTAB (2:260), SIGMAB (3) | |
33042 | EQUIVALENCE ( DEFPRO, DEFNUC (1) ) | |
33043 | EQUIVALENCE ( DEFNEU, DEFNUC (2) ) | |
33044 | EQUIVALENCE ( RHOIPP, RHONCP (1) ) | |
33045 | EQUIVALENCE ( RHOINP, RHONCP (2) ) | |
33046 | EQUIVALENCE ( RHOIP2, RHONC2 (1) ) | |
33047 | EQUIVALENCE ( RHOIN2, RHONC2 (2) ) | |
33048 | EQUIVALENCE ( RHOIP3, RHONC3 (1) ) | |
33049 | EQUIVALENCE ( RHOIN3, RHONC3 (2) ) | |
33050 | EQUIVALENCE ( RHOIPT, RHONCT (1) ) | |
33051 | EQUIVALENCE ( RHOINT, RHONCT (2) ) | |
33052 | EQUIVALENCE ( OMALHL, SK3PAR ) | |
33053 | EQUIVALENCE ( ALPHAL, HABPAR ) | |
33054 | EQUIVALENCE ( ALPTAB (2), AWSTAB (2) ) | |
33055 | EQUIVALENCE ( SIGMPE, SIGMPR (1) ) | |
33056 | EQUIVALENCE ( SIGMPC, SIGMPR (2) ) | |
33057 | EQUIVALENCE ( SIGMPI, SIGMPR (3) ) | |
33058 | EQUIVALENCE ( SIGMPA, SIGMPR (4) ) | |
33059 | EQUIVALENCE ( SIGMNE, SIGMNU (1) ) | |
33060 | EQUIVALENCE ( SIGMNC, SIGMNU (2) ) | |
33061 | EQUIVALENCE ( SIGMNI, SIGMNU (3) ) | |
33062 | EQUIVALENCE ( SIGMNA, SIGMNU (4) ) | |
33063 | EQUIVALENCE ( SIGMA2, SIGPAB (1) ) | |
33064 | EQUIVALENCE ( SIGMA3, SIGPAB (2) ) | |
33065 | EQUIVALENCE ( SIGMAS, SIGPAB (3) ) | |
33066 | EQUIVALENCE ( SIGPAB (1), SIGMAB (1) ) | |
33067 | * (original name: NUCLEV) | |
33068 | LOGICAL LCLVSL, LFLVSL, LRLVSL, LEQSBL | |
33069 | COMMON /FKNLEV/ PAENUC (200,2), SHENUC (200,2), DEFRMI (2), | |
33070 | & DEFMAG (2), ENNCLV (160,2), RANCLV (160,2), | |
33071 | & CUMRAD (0:160,2), RUSNUC (2), | |
33072 | & ENPLVL (114), ENNLVL(164), JUSNUC (160,2), | |
33073 | & NTANUC (2), NAVNUC (2), NLSNUC (2), NCONUC (2), | |
33074 | & NSKNUC (2), NHANUC (2), NUSNUC (2), NACNUC (2), | |
33075 | & JMXNUC (2), IPRNUC (3), JPRNUC (3), MAGNUM (8), | |
33076 | & MAGNUC (2), MGSNUC (8,2), MGSSNC (25,2), | |
33077 | & NSBSHL (2), NMNSBS (2), NPRNUC, INUCLV, LCLVSL, | |
33078 | & LFLVSL, LRLVSL, LEQSBL | |
33079 | DIMENSION JUSPRO (160), JUSNEU (160), MGSPRO (8), MGSNEU (8), | |
33080 | & MGSSPR (19) , MGSSNE (25) | |
33081 | EQUIVALENCE ( RUSNUC (1), RUSPRO ) | |
33082 | EQUIVALENCE ( RUSNUC (2), RUSNEU ) | |
33083 | EQUIVALENCE ( JUSNUC (1,1), JUSPRO (1) ) | |
33084 | EQUIVALENCE ( JUSNUC (1,2), JUSNEU (1) ) | |
33085 | EQUIVALENCE ( MGSNUC (1,1), MGSPRO (1) ) | |
33086 | EQUIVALENCE ( MGSNUC (1,2), MGSNEU (1) ) | |
33087 | EQUIVALENCE ( MGSSNC (1,1), MGSSPR (1) ) | |
33088 | EQUIVALENCE ( MGSSNC (1,2), MGSSNE (1) ) | |
33089 | EQUIVALENCE ( NTANUC (1), NTAPRO ) | |
33090 | EQUIVALENCE ( NTANUC (2), NTANEU ) | |
33091 | EQUIVALENCE ( NAVNUC (1), NAVPRO ) | |
33092 | EQUIVALENCE ( NAVNUC (2), NAVNEU ) | |
33093 | EQUIVALENCE ( NLSNUC (1), NLSPRO ) | |
33094 | EQUIVALENCE ( NLSNUC (2), NLSNEU ) | |
33095 | EQUIVALENCE ( NCONUC (1), NCOPRO ) | |
33096 | EQUIVALENCE ( NCONUC (2), NCONEU ) | |
33097 | EQUIVALENCE ( NSKNUC (1), NSKPRO ) | |
33098 | EQUIVALENCE ( NSKNUC (2), NSKNEU ) | |
33099 | EQUIVALENCE ( NHANUC (1), NHAPRO ) | |
33100 | EQUIVALENCE ( NHANUC (2), NHANEU ) | |
33101 | EQUIVALENCE ( NUSNUC (1), NUSPRO ) | |
33102 | EQUIVALENCE ( NUSNUC (2), NUSNEU ) | |
33103 | EQUIVALENCE ( NACNUC (1), NACPRO ) | |
33104 | EQUIVALENCE ( NACNUC (2), NACNEU ) | |
33105 | EQUIVALENCE ( JMXNUC (1), JMXPRO ) | |
33106 | EQUIVALENCE ( JMXNUC (2), JMXNEU ) | |
33107 | EQUIVALENCE ( MAGNUC (1), MAGPRO ) | |
33108 | EQUIVALENCE ( MAGNUC (2), MAGNEU ) | |
33109 | * (original name: PARNUC) | |
33110 | PARAMETER ( PIGRK = PIPIPI ) | |
33111 | PARAMETER ( ALEVEL = 8.D-03 ) | |
33112 | PARAMETER ( RCNUCL = 1.12D+00 ) | |
33113 | PARAMETER ( R0SIG = 1.3D+00 ) | |
33114 | PARAMETER ( R0SIGK = 1.5D+00 ) | |
33115 | PARAMETER ( RCOULB = 1.5D+00 ) | |
33116 | PARAMETER ( COULBH = 0.88235D-03 ) | |
33117 | PARAMETER ( RHONU0 = 0.75D+00 / PIGRK / RCNUCL / RCNUCL / RCNUCL ) | |
33118 | PARAMETER ( TAUFO0 = 10.0D+00 ) | |
33119 | PARAMETER ( EKEEXP = 0.03D+00 ) | |
33120 | PARAMETER ( EKREXP = 0.05D+00 ) | |
33121 | PARAMETER ( EKEMNM = 0.01D+00 ) | |
33122 | PARAMETER ( NCPMX = 120 ) | |
33123 | COMMON /FKPARN/ EKORI , PXORI , PYORI , PZORI , PTORI , TAUFOR, | |
33124 | & ENNUC (NCPMX), PNUCL (NCPMX), EKFNUC (NCPMX), | |
33125 | & XSTNUC (NCPMX), YSTNUC (NCPMX), ZSTNUC (NCPMX), | |
33126 | & PXNUCL (NCPMX), PYNUCL (NCPMX), PZNUCL (NCPMX), | |
33127 | & RSTNUC (NCPMX), FREEPA (NCPMX), CRRPAN (NCPMX), | |
33128 | & CRRPAP (NCPMX), BSTNUC (NCPMX), AGENUC (NCPMX), | |
33129 | & TAUFPA (NCPMX), RHNUCL(NCPMX,2), BNDGAV, DEFMIN, | |
33130 | & KPNUCL (NCPMX), KRFNUC (NCPMX), ILINUC (NCPMX), | |
33131 | & INUCTS (NCPMX), ISFNUC (NCPMX), KPORI , IBORI , | |
33132 | & IBNUCL, NPNUC , NNUCTS | |
33133 | * | |
33134 | DATA LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH / 6*.FALSE. / | |
33135 | DATA POTBAR / POTBA0 /, POTMES / POTME0 /, WLLRES / 0.D+00 / | |
33136 | DATA JUSNUC / 320 * 0 /, INUCLV / 1 /, IEVPRE / 0 / | |
33137 | DATA MAGNUM / 2, 8, 20, 28, 50, 82, 126, 160 / | |
33138 | DATA LPREEQ / .FALSE. / | |
33139 | * /cmpisg/ | |
33140 | DATA JSTOKP / 1, 8, 13, 14, 23 / | |
33141 | DATA KPTOJS / 1, 6*0, 2, 4*0, 3, 4, 8*0, 5 / | |
33142 | DATA CHPIRE / 'PI+PPI+P','PI-PPI-P','PI-PPI0N','PI0PPI0P', | |
33143 | & 'PI0PPI+N','PI-NPI-N','PI+NPI+N','PI+NPI0P', | |
33144 | & 'PI0NPI0N','PI0NPI-P' / | |
33145 | DATA KPIIRE / 13, 1, 14, 1, 14, 1, 23, 1, 23, 1, 14, 8, | |
33146 | & 13, 8, 13, 8, 23, 8, 23, 8 / | |
33147 | DATA KPIORE / 13, 1, 14, 1, 23, 8, 23, 1, 13, 8, 14, 8, | |
33148 | & 13, 8, 23, 1, 23, 8, 14, 1 / | |
33149 | DATA IPIREA / 1, 0, 7, 8, 2, 3, 6, 0, 4, 5, 9, 10 / | |
33150 | DATA IPIINE / 1, 2, 3, 4, 5, 6 / | |
33151 | * /frbkcm/ | |
33152 | DATA LFRMBK / .FALSE. / | |
33153 | DATA NBUFBK / 500 / | |
33154 | DATA EXMXFB / 80.0 D+00 / | |
33155 | DATA R0FRBK / 1.18 D+00 / | |
33156 | DATA R0CFBK / 2.173D+00 / | |
33157 | DATA C1CFBK / 6.103D-03 / | |
33158 | DATA C2CFBK / 9.443D-03 / | |
33159 | * /parnuc/ | |
33160 | DATA TAUFOR / TAUFO0 / | |
33161 | *=== End of Block Data Bdpree =========================================* | |
33162 | END | |
33163 | ||
33164 | *$ CREATE DT_XHOINI.FOR | |
33165 | *COPY DT_XHOINI | |
33166 | * | |
33167 | *====phoini============================================================* | |
33168 | * | |
33169 | SUBROUTINE DT_XHOINI | |
33170 | C SUBROUTINE DT_PHOINI | |
33171 | ||
33172 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
33173 | SAVE | |
33174 | PARAMETER ( LINP = 10 , | |
33175 | & LOUT = 6 , | |
33176 | & LDAT = 9 ) | |
33177 | ||
33178 | RETURN | |
33179 | END | |
33180 | ||
33181 | *$ CREATE DT_XVENTB.FOR | |
33182 | *COPY DT_XVENTB | |
33183 | * | |
33184 | *====eventb============================================================* | |
33185 | * | |
33186 | SUBROUTINE DT_XVENTB(NCSY,IREJ) | |
33187 | C SUBROUTINE DT_EVENTB(NCSY,IREJ) | |
33188 | ||
33189 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
33190 | SAVE | |
33191 | PARAMETER ( LINP = 10 , | |
33192 | & LOUT = 6 , | |
33193 | & LDAT = 9 ) | |
33194 | ||
33195 | WRITE(LOUT,1000) | |
33196 | 1000 FORMAT(1X,'EVENTB: PHOJET-package requested but not linked!') | |
33197 | STOP | |
33198 | ||
33199 | END | |
33200 | ||
33201 | *$ CREATE DT_XVENT.FOR | |
33202 | *COPY DT_XVENT | |
33203 | * | |
33204 | *===event==============================================================* | |
33205 | * | |
33206 | SUBROUTINE DT_XVENT(IDUM,PP,PT,DUM,IREJ) | |
33207 | C SUBROUTINE EVENT(IDUM,PP,PT,DUM,IREJ) | |
33208 | ||
33209 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
33210 | SAVE | |
33211 | ||
33212 | DIMENSION PP(4),PT(4) | |
33213 | ||
33214 | RETURN | |
33215 | END | |
33216 | ||
33217 | *$ CREATE DT_XOHISX.FOR | |
33218 | *COPY DT_XOHISX | |
33219 | * | |
33220 | *===pohisx=============================================================* | |
33221 | * | |
33222 | SUBROUTINE DT_XOHISX(I,X) | |
33223 | C SUBROUTINE POHISX(I,X) | |
33224 | ||
33225 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
33226 | SAVE | |
33227 | ||
33228 | RETURN | |
33229 | END | |
33230 | ||
33231 | *$ CREATE PHO_LHIST.FOR | |
33232 | *COPY PHO_LHIST | |
33233 | * | |
33234 | *===poluhi=============================================================* | |
33235 | * | |
33236 | SUBROUTINE PHO_LHIST(I,X) | |
33237 | ** | |
33238 | ||
33239 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
33240 | SAVE | |
33241 | ||
33242 | RETURN | |
33243 | END | |
33244 | ||
33245 | *$ CREATE PDFSET.FOR | |
33246 | *COPY PDFSET | |
33247 | * | |
33248 | C********************************************************************** | |
33249 | C | |
33250 | C dummy subroutines, remove to link PDFLIB | |
33251 | C | |
33252 | C********************************************************************** | |
33253 | SUBROUTINE PDFSET(PARAM,VALUE) | |
33254 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
33255 | DIMENSION PARAM(20),VALUE(20) | |
33256 | CHARACTER*20 PARAM | |
33257 | END | |
33258 | ||
33259 | *$ CREATE STRUCTM.FOR | |
33260 | *COPY STRUCTM | |
33261 | * | |
33262 | SUBROUTINE STRUCTM(XI,SCALE2,UV,DV,US,DS,SS,CS,BS,TS,GL) | |
33263 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
33264 | END | |
33265 | ||
33266 | *$ CREATE STRUCTP.FOR | |
33267 | *COPY STRUCTP | |
33268 | * | |
33269 | SUBROUTINE STRUCTP(XI,SCALE2,P2,IP2,UV,DV,US,DS,SS,CS,BS,TS,GL) | |
33270 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
33271 | END | |
33272 | ||
33273 | *$ CREATE DT_DIQBRK.FOR | |
33274 | *COPY DT_DIQBRK | |
33275 | * | |
33276 | *===diqbrk=============================================================* | |
33277 | * | |
33278 | SUBROUTINE DT_XIQBRK | |
33279 | C SUBROUTINE DT_DIQBRK | |
33280 | ||
33281 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
33282 | SAVE | |
33283 | ||
33284 | STOP 'diquark-breaking not implemeted !' | |
33285 | ||
33286 | RETURN | |
33287 | END | |
33288 | ||
33289 | *$ CREATE DT_ELHAIN.FOR | |
33290 | *COPY DT_ELHAIN | |
33291 | * | |
33292 | *===elhain=============================================================* | |
33293 | * | |
33294 | SUBROUTINE DT_ELHAIN(IP,PLA,ELAB,CX,CY,CZ,IT,IREJ) | |
33295 | ||
33296 | ************************************************************************ | |
33297 | * Elastic hadron-hadron scattering. * | |
33298 | * This is a revised version of the original. * | |
33299 | * This version dated 03.04.98 is written by S. Roesler * | |
33300 | ************************************************************************ | |
33301 | ||
33302 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
33303 | SAVE | |
33304 | PARAMETER ( LINP = 10 , | |
33305 | & LOUT = 6 , | |
33306 | & LDAT = 9 ) | |
33307 | PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0, | |
33308 | & TINY10=1.0D-10) | |
33309 | ||
33310 | PARAMETER (ENNTHR = 3.5D0) | |
33311 | PARAMETER (PLOWH=0.01D0,PHIH=9.0D0, | |
33312 | & BLOWB=0.05D0,BHIB=0.2D0, | |
33313 | & BLOWM=0.1D0, BHIM=2.0D0) | |
33314 | ||
33315 | * particle properties (BAMJET index convention) | |
33316 | CHARACTER*8 ANAME | |
33317 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
33318 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
33319 | * final state from HADRIN interaction | |
33320 | PARAMETER (MAXFIN=10) | |
33321 | COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN), | |
33322 | & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH | |
33323 | ||
33324 | C DATA TSLOPE /10.0D0/ | |
33325 | ||
33326 | IREJ = 0 | |
33327 | ||
33328 | 1 CONTINUE | |
33329 | ||
33330 | PLAB = SQRT( (ELAB-AAM(IP))*(ELAB+AAM(IP)) ) | |
33331 | EKIN = ELAB-AAM(IP) | |
33332 | * kinematical quantities in cms of the hadrons | |
33333 | AMP2 = AAM(IP)**2 | |
33334 | AMT2 = AAM(IT)**2 | |
33335 | S = AMP2+AMT2+TWO*ELAB*AAM(IT) | |
33336 | ECM = SQRT(S) | |
33337 | ECMP = OHALF*ECM+(AMP2-AMT2)/(TWO*ECM) | |
33338 | PCM = SQRT( (ECMP-AAM(IP))*(ECMP+AAM(IP)) ) | |
33339 | ||
33340 | * nucleon-nucleon scattering at E_kin<3.5: use DT_TSAMCS(HETC-KFA) | |
33341 | IF ( ((IP.EQ.1).OR.(IP.EQ.8)).AND. | |
33342 | & ((IT.EQ.1).OR.(IT.EQ.8)).AND.(EKIN.LT.ENNTHR) ) THEN | |
33343 | * TSAMCS treats pp and np only, therefore change pn into np and | |
33344 | * nn into pp | |
33345 | IF (IT.EQ.1) THEN | |
33346 | KPROJ = IP | |
33347 | ELSE | |
33348 | KPROJ = 8 | |
33349 | IF (IP.EQ.8) KPROJ = 1 | |
33350 | ENDIF | |
33351 | CALL DT_TSAMCS(KPROJ,EKIN,CTCMS) | |
33352 | T = TWO*PCM**2*(CTCMS-ONE) | |
33353 | ||
33354 | * very crude treatment otherwise: sample t from exponential dist. | |
33355 | ELSE | |
33356 | * momentum transfer t | |
33357 | TMAX = TWO*TWO*PCM**2 | |
33358 | RR = (PLAB-PLOWH)/(PHIH-PLOWH) | |
33359 | IF (IIBAR(IP).NE.0) THEN | |
33360 | TSLOPE = BLOWB+RR*(BHIB-BLOWB) | |
33361 | ELSE | |
33362 | TSLOPE = BLOWM+RR*(BHIM-BLOWM) | |
33363 | ENDIF | |
33364 | FMAX = EXP(-TSLOPE*TMAX)-ONE | |
33365 | R = DT_RNDM(RR) | |
33366 | T = LOG(ONE+R*FMAX+TINY10)/TSLOPE | |
33367 | IF (T.GT.ZERO) T = LOG(ONE+R*FMAX)/TSLOPE | |
33368 | ENDIF | |
33369 | ||
33370 | * target hadron in Lab after scattering | |
33371 | ELRH(2) = (TWO*AMT2-T)/(TWO*AAM(IT)) | |
33372 | PLRH(2) = SQRT( ABS(ELRH(2)-AAM(IT))*(ELRH(2)+AAM(IT)) ) | |
33373 | IF (PLRH(2).LE.TINY10) THEN | |
33374 | C WRITE(*,*)'ELHAIN: T,PLRH(2) ',T,PLRH(2) | |
33375 | GOTO 1 | |
33376 | ENDIF | |
33377 | * projectile hadron in Lab after scattering | |
33378 | ELRH(1) = ELAB+AAM(IT)-ELRH(2) | |
33379 | PLRH(1) = SQRT( ABS(ELRH(1)-AAM(IP))*(ELRH(1)+AAM(IP)) ) | |
33380 | * scattering angle of projectile in Lab | |
33381 | CTLABP = (T-TWO*AMP2+TWO*ELAB*ELRH(1))/(TWO*PLAB*PLRH(1)) | |
33382 | STLABP = SQRT( (ONE-CTLABP)*(ONE+CTLABP) ) | |
33383 | CALL DT_DSFECF(SPLABP,CPLABP) | |
33384 | * direction cosines of projectile in Lab | |
33385 | CALL DT_STTRAN(CX,CY,CZ,CTLABP,STLABP,SPLABP,CPLABP, | |
33386 | & CXRH(1),CYRH(1),CZRH(1)) | |
33387 | * scattering angle of target in Lab | |
33388 | PLLABT = PLAB-CTLABP*PLRH(1) | |
33389 | CTLABT = PLLABT/PLRH(2) | |
33390 | STLABT = SQRT( (ONE-CTLABT)*(ONE+CTLABT) ) | |
33391 | * direction cosines of target in Lab | |
33392 | CALL DT_STTRAN(CX,CY,CZ,CTLABT,STLABT,-SPLABP,-CPLABP, | |
33393 | & CXRH(2),CYRH(2),CZRH(2)) | |
33394 | * fill /HNFSPA/ | |
33395 | IRH = 2 | |
33396 | ITRH(1) = IP | |
33397 | ITRH(2) = IT | |
33398 | ||
33399 | RETURN | |
33400 | END | |
33401 | ||
33402 | *$ CREATE DT_TSAMCS.FOR | |
33403 | *COPY DT_TSAMCS | |
33404 | * | |
33405 | *===tsamcs=============================================================* | |
33406 | * | |
33407 | SUBROUTINE DT_TSAMCS(KPROJ,EKIN,CST) | |
33408 | ||
33409 | ************************************************************************ | |
33410 | * Sampling of cos(theta) for nucleon-proton scattering according to * | |
33411 | * hetkfa2/bertini parametrization. * | |
33412 | * This is a revised version of the original (HJM 24/10/88) * | |
33413 | * This version dated 28.10.95 is written by S. Roesler * | |
33414 | ************************************************************************ | |
33415 | ||
33416 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
33417 | SAVE | |
33418 | PARAMETER ( LINP = 10 , | |
33419 | & LOUT = 6 , | |
33420 | & LDAT = 9 ) | |
33421 | PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0, | |
33422 | & TINY10=1.0D-10) | |
33423 | ||
33424 | DIMENSION DCLIN(195),DCHN(143),DCHNA(36),DCHNB(60) | |
33425 | DIMENSION PDCI(60),PDCH(55) | |
33426 | ||
33427 | DATA (DCLIN(I),I=1,80) / | |
33428 | & 5.000D-01, 1.000D+00, 0.000D+00, 1.000D+00, 0.000D+00, | |
33429 | & 4.993D-01, 9.881D-01, 5.963D-02, 9.851D-01, 5.945D-02, | |
33430 | & 4.936D-01, 8.955D-01, 5.224D-01, 8.727D-01, 5.091D-01, | |
33431 | & 4.889D-01, 8.228D-01, 8.859D-01, 7.871D-01, 8.518D-01, | |
33432 | & 4.874D-01, 7.580D-01, 1.210D+00, 7.207D-01, 1.117D+00, | |
33433 | & 4.912D-01, 6.969D-01, 1.516D+00, 6.728D-01, 1.309D+00, | |
33434 | & 5.075D-01, 6.471D-01, 1.765D+00, 6.667D-01, 1.333D+00, | |
33435 | & 5.383D-01, 6.054D-01, 1.973D+00, 7.059D-01, 1.176D+00, | |
33436 | & 5.397D-01, 5.990D-01, 2.005D+00, 7.023D-01, 1.191D+00, | |
33437 | & 5.336D-01, 6.083D-01, 1.958D+00, 6.959D-01, 1.216D+00, | |
33438 | & 5.317D-01, 6.075D-01, 1.962D+00, 6.897D-01, 1.241D+00, | |
33439 | & 5.300D-01, 6.016D-01, 1.992D+00, 6.786D-01, 1.286D+00, | |
33440 | & 5.281D-01, 6.063D-01, 1.969D+00, 6.786D-01, 1.286D+00, | |
33441 | & 5.280D-01, 5.960D-01, 2.020D+00, 6.667D-01, 1.333D+00, | |
33442 | & 5.273D-01, 5.920D-01, 2.040D+00, 6.604D-01, 1.358D+00, | |
33443 | & 5.273D-01, 5.862D-01, 2.069D+00, 6.538D-01, 1.385D+00/ | |
33444 | DATA (DCLIN(I),I=81,160) / | |
33445 | & 5.223D-01, 5.980D-01, 2.814D+00, 6.538D-01, 1.385D+00, | |
33446 | & 5.202D-01, 5.969D-01, 2.822D+00, 6.471D-01, 1.412D+00, | |
33447 | & 5.183D-01, 5.881D-01, 2.883D+00, 6.327D-01, 1.469D+00, | |
33448 | & 5.159D-01, 5.866D-01, 2.894D+00, 6.250D-01, 1.500D+00, | |
33449 | & 5.133D-01, 5.850D-01, 2.905D+00, 6.170D-01, 1.532D+00, | |
33450 | & 5.106D-01, 5.833D-01, 2.917D+00, 6.087D-01, 1.565D+00, | |
33451 | & 5.084D-01, 5.801D-01, 2.939D+00, 6.000D-01, 1.600D+00, | |
33452 | & 5.063D-01, 5.763D-01, 2.966D+00, 5.909D-01, 1.636D+00, | |
33453 | & 5.036D-01, 5.730D-01, 2.989D+00, 5.814D-01, 1.674D+00, | |
33454 | & 5.014D-01, 5.683D-01, 3.022D+00, 5.714D-01, 1.714D+00, | |
33455 | & 4.986D-01, 5.641D-01, 3.051D+00, 5.610D-01, 1.756D+00, | |
33456 | & 4.964D-01, 5.580D-01, 3.094D+00, 5.500D-01, 1.800D+00, | |
33457 | & 4.936D-01, 5.573D-01, 3.099D+00, 5.431D-01, 1.827D+00, | |
33458 | & 4.909D-01, 5.509D-01, 3.144D+00, 5.313D-01, 1.875D+00, | |
33459 | & 4.885D-01, 5.512D-01, 3.142D+00, 5.263D-01, 1.895D+00, | |
33460 | & 4.857D-01, 5.437D-01, 3.194D+00, 5.135D-01, 1.946D+00/ | |
33461 | DATA (DCLIN(I),I=161,195) / | |
33462 | & 4.830D-01, 5.353D-01, 3.253D+00, 5.000D-01, 2.000D+00, | |
33463 | & 4.801D-01, 5.323D-01, 3.274D+00, 4.915D-01, 2.034D+00, | |
33464 | & 4.770D-01, 5.228D-01, 3.341D+00, 4.767D-01, 2.093D+00, | |
33465 | & 4.738D-01, 5.156D-01, 3.391D+00, 4.643D-01, 2.143D+00, | |
33466 | & 4.701D-01, 5.010D-01, 3.493D+00, 4.444D-01, 2.222D+00, | |
33467 | & 4.672D-01, 4.990D-01, 3.507D+00, 4.375D-01, 2.250D+00, | |
33468 | & 4.634D-01, 4.856D-01, 3.601D+00, 4.194D-01, 2.323D+00/ | |
33469 | ||
33470 | DATA PDCI / | |
33471 | & 4.400D+02, 1.896D-01, 1.931D-01, 1.982D-01, 1.015D-01, | |
33472 | & 1.029D-01, 4.180D-02, 4.228D-02, 4.282D-02, 4.350D-02, | |
33473 | & 2.204D-02, 2.236D-02, 5.900D+02, 1.433D-01, 1.555D-01, | |
33474 | & 1.774D-01, 1.000D-01, 1.128D-01, 5.132D-02, 5.600D-02, | |
33475 | & 6.158D-02, 6.796D-02, 3.660D-02, 3.820D-02, 6.500D+02, | |
33476 | & 1.192D-01, 1.334D-01, 1.620D-01, 9.527D-02, 1.141D-01, | |
33477 | & 5.283D-02, 5.952D-02, 6.765D-02, 7.878D-02, 4.796D-02, | |
33478 | & 6.957D-02, 8.000D+02, 4.872D-02, 6.694D-02, 1.152D-01, | |
33479 | & 9.348D-02, 1.368D-01, 6.912D-02, 7.953D-02, 9.577D-02, | |
33480 | & 1.222D-01, 7.755D-02, 9.525D-02, 1.000D+03, 3.997D-02, | |
33481 | & 5.456D-02, 9.804D-02, 8.084D-02, 1.208D-01, 6.520D-02, | |
33482 | & 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02, 1.093D-01/ | |
33483 | ||
33484 | DATA PDCH / | |
33485 | & 1.000D+03, 9.453D-02, 9.804D-02, 8.084D-02, 1.208D-01, | |
33486 | & 6.520D-02, 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02, | |
33487 | & 1.093D-01, 1.400D+03, 1.072D-01, 7.450D-02, 6.645D-02, | |
33488 | & 1.136D-01, 6.750D-02, 8.580D-02, 1.110D-01, 1.530D-01, | |
33489 | & 1.010D-01, 1.350D-01, 2.170D+03, 4.004D-02, 3.013D-02, | |
33490 | & 2.664D-02, 5.511D-02, 4.240D-02, 7.660D-02, 1.364D-01, | |
33491 | & 2.300D-01, 1.670D-01, 2.010D-01, 2.900D+03, 1.870D-02, | |
33492 | & 1.804D-02, 1.320D-02, 2.970D-02, 2.860D-02, 5.160D-02, | |
33493 | & 1.020D-01, 2.400D-01, 2.250D-01, 3.370D-01, 4.400D+03, | |
33494 | & 1.196D-03, 8.784D-03, 1.517D-02, 2.874D-02, 2.488D-02, | |
33495 | & 4.464D-02, 8.330D-02, 2.008D-01, 2.360D-01, 3.567D-01/ | |
33496 | ||
33497 | DATA (DCHN(I),I=1,90) / | |
33498 | & 4.770D-01, 4.750D-01, 4.715D-01, 4.685D-01, 4.650D-01, | |
33499 | & 4.610D-01, 4.570D-01, 4.550D-01, 4.500D-01, 4.450D-01, | |
33500 | & 4.405D-01, 4.350D-01, 4.300D-01, 4.250D-01, 4.200D-01, | |
33501 | & 4.130D-01, 4.060D-01, 4.000D-01, 3.915D-01, 3.840D-01, | |
33502 | & 3.760D-01, 3.675D-01, 3.580D-01, 3.500D-01, 3.400D-01, | |
33503 | & 3.300D-01, 3.200D-01, 3.100D-01, 3.000D-01, 2.900D-01, | |
33504 | & 2.800D-01, 2.700D-01, 2.600D-01, 2.500D-01, 2.400D-01, | |
33505 | & 2.315D-01, 2.240D-01, 2.150D-01, 2.060D-01, 2.000D-01, | |
33506 | & 1.915D-01, 1.850D-01, 1.780D-01, 1.720D-01, 1.660D-01, | |
33507 | & 1.600D-01, 1.550D-01, 1.500D-01, 1.450D-01, 1.400D-01, | |
33508 | & 1.360D-01, 1.320D-01, 1.280D-01, 1.250D-01, 1.210D-01, | |
33509 | & 1.180D-01, 1.150D-01, 1.120D-01, 1.100D-01, 1.070D-01, | |
33510 | & 1.050D-01, 1.030D-01, 1.010D-01, 9.900D-02, 9.700D-02, | |
33511 | & 9.550D-02, 9.480D-02, 9.400D-02, 9.200D-02, 9.150D-02, | |
33512 | & 9.100D-02, 9.000D-02, 8.990D-02, 8.900D-02, 8.850D-02, | |
33513 | & 8.750D-02, 8.700D-02, 8.650D-02, 8.550D-02, 8.500D-02, | |
33514 | & 8.499D-02, 8.450D-02, 8.350D-02, 8.300D-02, 8.250D-02, | |
33515 | & 8.150D-02, 8.100D-02, 8.030D-02, 8.000D-02, 7.990D-02/ | |
33516 | DATA (DCHN(I),I=91,143) / | |
33517 | & 7.980D-02, 7.950D-02, 7.900D-02, 7.860D-02, 7.800D-02, | |
33518 | & 7.750D-02, 7.650D-02, 7.620D-02, 7.600D-02, 7.550D-02, | |
33519 | & 7.530D-02, 7.500D-02, 7.499D-02, 7.498D-02, 7.480D-02, | |
33520 | & 7.450D-02, 7.400D-02, 7.350D-02, 7.300D-02, 7.250D-02, | |
33521 | & 7.230D-02, 7.200D-02, 7.100D-02, 7.050D-02, 7.020D-02, | |
33522 | & 7.000D-02, 6.999D-02, 6.995D-02, 6.993D-02, 6.991D-02, | |
33523 | & 6.990D-02, 6.870D-02, 6.850D-02, 6.800D-02, 6.780D-02, | |
33524 | & 6.750D-02, 6.700D-02, 6.650D-02, 6.630D-02, 6.600D-02, | |
33525 | & 6.550D-02, 6.525D-02, 6.510D-02, 6.500D-02, 6.499D-02, | |
33526 | & 6.498D-02, 6.496D-02, 6.494D-02, 6.493D-02, 6.490D-02, | |
33527 | & 6.488D-02, 6.485D-02, 6.480D-02/ | |
33528 | ||
33529 | DATA DCHNA / | |
33530 | & 6.300D+02, 7.810D-02, 1.421D-01, 1.979D-01, 2.479D-01, | |
33531 | & 3.360D-01, 5.400D-01, 7.236D-01, 1.000D+00, 1.540D+03, | |
33532 | & 2.225D-01, 3.950D-01, 5.279D-01, 6.298D-01, 7.718D-01, | |
33533 | & 9.405D-01, 9.835D-01, 1.000D+00, 2.560D+03, 2.625D-01, | |
33534 | & 4.550D-01, 5.963D-01, 7.020D-01, 8.380D-01, 9.603D-01, | |
33535 | & 9.903D-01, 1.000D+00, 3.520D+03, 4.250D-01, 6.875D-01, | |
33536 | & 8.363D-01, 9.163D-01, 9.828D-01, 1.000D+00, 1.000D+00, | |
33537 | & 1.000D+00/ | |
33538 | ||
33539 | DATA DCHNB / | |
33540 | & 6.300D+02, 3.800D-02, 7.164D-02, 1.275D-01, 2.171D-01, | |
33541 | & 3.227D-01, 4.091D-01, 5.051D-01, 6.061D-01, 7.074D-01, | |
33542 | & 8.434D-01, 1.000D+00, 2.040D+03, 1.200D-01, 2.115D-01, | |
33543 | & 3.395D-01, 5.295D-01, 7.251D-01, 8.511D-01, 9.487D-01, | |
33544 | & 9.987D-01, 1.000D+00, 1.000D+00, 1.000D+00, 2.200D+03, | |
33545 | & 1.344D-01, 2.324D-01, 3.754D-01, 5.674D-01, 7.624D-01, | |
33546 | & 8.896D-01, 9.808D-01, 1.000D+00, 1.000D+00, 1.000D+00, | |
33547 | & 1.000D+00, 2.850D+03, 2.330D-01, 4.130D-01, 6.610D-01, | |
33548 | & 9.010D-01, 9.970D-01, 1.000D+00, 1.000D+00, 1.000D+00, | |
33549 | & 1.000D+00, 1.000D+00, 1.000D+00, 3.500D+03, 3.300D-01, | |
33550 | & 5.450D-01, 7.950D-01, 1.000D+00, 1.000D+00, 1.000D+00, | |
33551 | & 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00/ | |
33552 | ||
33553 | CST = ONE | |
33554 | IF (EKIN.GT.3.5D0) RETURN | |
33555 | C | |
33556 | IF(KPROJ.EQ.8) GOTO 101 | |
33557 | IF(KPROJ.EQ.1) GOTO 102 | |
33558 | C* INVALID REACTION | |
33559 | WRITE(LOUT,'(A,I5/A)') | |
33560 | & ' INVALID PARTICLE TYPE IN DNUPRE - KPROJ=',KPROJ, | |
33561 | & ' COS(THETA) = 1D0 RETURNED' | |
33562 | RETURN | |
33563 | C-------------------------------- NP ELASTIC SCATTERING---------- | |
33564 | 101 CONTINUE | |
33565 | IF (EKIN.GT.0.740D0)GOTO 1000 | |
33566 | IF (EKIN.LT.0.300D0)THEN | |
33567 | C EKIN .LT. 300 MEV | |
33568 | IDAT=1 | |
33569 | ELSE | |
33570 | C 300 MEV < EKIN < 740 MEV | |
33571 | IDAT=6 | |
33572 | END IF | |
33573 | C | |
33574 | ENER=EKIN | |
33575 | IE=INT(ABS(ENER/0.020D0)) | |
33576 | UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0 | |
33577 | C FORWARD/BACKWARD DECISION | |
33578 | K=IDAT+5*IE | |
33579 | BWFW=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K) | |
33580 | IF (DT_RNDM(CST).LT.BWFW)THEN | |
33581 | VALUE2=-1D0 | |
33582 | K=K+1 | |
33583 | ELSE | |
33584 | VALUE2=1D0 | |
33585 | K=K+3 | |
33586 | END IF | |
33587 | C | |
33588 | COEF=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K) | |
33589 | RND=DT_RNDM(COEF) | |
33590 | C | |
33591 | IF(RND.LT.COEF)THEN | |
33592 | CST=DT_RNDM(RND) | |
33593 | CST=CST*VALUE2 | |
33594 | ELSE | |
33595 | R1=DT_RNDM(CST) | |
33596 | R2=DT_RNDM(R1) | |
33597 | R3=DT_RNDM(R2) | |
33598 | R4=DT_RNDM(R3) | |
33599 | C | |
33600 | IF(VALUE2.GT.0.0)THEN | |
33601 | CST=MAX(R1,R2,R3,R4) | |
33602 | GOTO 1500 | |
33603 | ELSE | |
33604 | R5=DT_RNDM(R4) | |
33605 | C | |
33606 | IF (IDAT.EQ.1)THEN | |
33607 | CST=-MAX(R1,R2,R3,R4,R5) | |
33608 | ELSE | |
33609 | R6=DT_RNDM(R5) | |
33610 | R7=DT_RNDM(R6) | |
33611 | CST=-MAX(R1,R2,R3,R4,R5,R6,R7) | |
33612 | END IF | |
33613 | C | |
33614 | END IF | |
33615 | C | |
33616 | END IF | |
33617 | C | |
33618 | GOTO 1500 | |
33619 | C | |
33620 | C******** EKIN .GT. 0.74 GEV | |
33621 | C | |
33622 | 1000 ENER=EKIN - 0.66D0 | |
33623 | C IE=ABS(ENER/0.02) | |
33624 | IE=INT(ENER/0.02D0) | |
33625 | EMEV=EKIN*1D3 | |
33626 | C | |
33627 | UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0 | |
33628 | K=IE | |
33629 | BWFW=(DCHN(K+1)-DCHN(K))*UNIV + DCHN(K) | |
33630 | RND=DT_RNDM(BWFW) | |
33631 | C FORWARD NEUTRON | |
33632 | IF (RND.GE.BWFW)THEN | |
33633 | DO 1200 K=10,36,9 | |
33634 | IF (DCHNA(K).GT.EMEV) THEN | |
33635 | UNIVE=(EMEV-DCHNA(K-9))/(DCHNA(K)-DCHNA(K-9)) | |
33636 | UNIV=DT_RNDM(UNIVE) | |
33637 | DO 1100 I=1,8 | |
33638 | II=K+I | |
33639 | P=(DCHNA(II)-DCHNA(II-9))*UNIVE + DCHNA(II-9) | |
33640 | C | |
33641 | IF (P.GT.UNIV)THEN | |
33642 | UNIV=DT_RNDM(UNIVE) | |
33643 | FLTI=DBLE(I)-UNIV | |
33644 | GOTO(290,290,290,290,330,340,350,360) I | |
33645 | END IF | |
33646 | 1100 CONTINUE | |
33647 | END IF | |
33648 | 1200 CONTINUE | |
33649 | C | |
33650 | ELSE | |
33651 | C BACKWARD NEUTRON | |
33652 | DO 1400 K=13,60,12 | |
33653 | IF (DCHNB(K).GT.EMEV) THEN | |
33654 | UNIVE=(EMEV-DCHNB(K-12))/(DCHNB(K)-DCHNB(K-12)) | |
33655 | UNIV=DT_RNDM(UNIVE) | |
33656 | DO 1300 I=1,11 | |
33657 | II=K+I | |
33658 | P=(DCHNB(II)-DCHNB(II-12))*UNIVE + DCHNB(II-12) | |
33659 | C | |
33660 | IF (P.GT.UNIV)THEN | |
33661 | UNIV=DT_RNDM(P) | |
33662 | FLTI=DBLE(I)-UNIV | |
33663 | GOTO(120,120,140,150,160,160,180,190,200,210,220) I | |
33664 | END IF | |
33665 | 1300 CONTINUE | |
33666 | END IF | |
33667 | 1400 CONTINUE | |
33668 | END IF | |
33669 | C | |
33670 | 120 CST=1.0D-2*FLTI-1.0D0 | |
33671 | GOTO 1500 | |
33672 | 140 CST=2.0D-2*UNIV-0.98D0 | |
33673 | GOTO 1500 | |
33674 | 150 CST=4.0D-2*UNIV-0.96D0 | |
33675 | GOTO 1500 | |
33676 | 160 CST=6.0D-2*FLTI-1.16D0 | |
33677 | GOTO 1500 | |
33678 | 180 CST=8.0D-2*UNIV-0.80D0 | |
33679 | GOTO 1500 | |
33680 | 190 CST=1.0D-1*UNIV-0.72D0 | |
33681 | GOTO 1500 | |
33682 | 200 CST=1.2D-1*UNIV-0.62D0 | |
33683 | GOTO 1500 | |
33684 | 210 CST=2.0D-1*UNIV-0.50D0 | |
33685 | GOTO 1500 | |
33686 | 220 CST=3.0D-1*(UNIV-1.0D0) | |
33687 | GOTO 1500 | |
33688 | C | |
33689 | 290 CST=1.0D0-2.5d-2*FLTI | |
33690 | GOTO 1500 | |
33691 | 330 CST=0.85D0+0.5D-1*UNIV | |
33692 | GOTO 1500 | |
33693 | 340 CST=0.70D0+1.5D-1*UNIV | |
33694 | GOTO 1500 | |
33695 | 350 CST=0.50D0+2.0D-1*UNIV | |
33696 | GOTO 1500 | |
33697 | 360 CST=0.50D0*UNIV | |
33698 | C | |
33699 | 1500 RETURN | |
33700 | C | |
33701 | C----------------------------------- PP ELASTIC SCATTERING ------- | |
33702 | C | |
33703 | 102 CONTINUE | |
33704 | EMEV=EKIN*1D3 | |
33705 | C | |
33706 | IF (EKIN.LE.0.500D0) THEN | |
33707 | RND=DT_RNDM(EMEV) | |
33708 | CST=2.0D0*RND-1.0D0 | |
33709 | RETURN | |
33710 | C | |
33711 | ELSEIF (EKIN.LT.1.0D0) THEN | |
33712 | DO 2200 K=13,60,12 | |
33713 | IF (PDCI(K).GT.EMEV) THEN | |
33714 | UNIVE=(EMEV-PDCI(K-12))/(PDCI(K)-PDCI(K-12)) | |
33715 | UNIV=DT_RNDM(UNIVE) | |
33716 | SUM=0 | |
33717 | DO 2100 I=1,11 | |
33718 | II=K+I | |
33719 | SUM=SUM + (PDCI(II)-PDCI(II-12))*UNIVE + PDCI(II-12) | |
33720 | C | |
33721 | IF (UNIV.LT.SUM)THEN | |
33722 | UNIV=DT_RNDM(SUM) | |
33723 | FLTI=DBLE(I)-UNIV | |
33724 | GOTO(55,55,55,60,60,65,65,65,65,70,70) I | |
33725 | END IF | |
33726 | 2100 CONTINUE | |
33727 | END IF | |
33728 | 2200 CONTINUE | |
33729 | ELSE | |
33730 | DO 2400 K=12,55,11 | |
33731 | IF (PDCH(K).GT.EMEV) THEN | |
33732 | UNIVE=(EMEV-PDCH(K-11))/(PDCH(K)-PDCH(K-11)) | |
33733 | UNIV=DT_RNDM(UNIVE) | |
33734 | SUM=0.0D0 | |
33735 | DO 2300 I=1,10 | |
33736 | II=K+I | |
33737 | SUM=SUM + (PDCH(II)-PDCH(II-11))*UNIVE + PDCH(II-11) | |
33738 | C | |
33739 | IF (UNIV.LT.SUM)THEN | |
33740 | UNIV=DT_RNDM(SUM) | |
33741 | FLTI=UNIV+DBLE(I) | |
33742 | GOTO(50,55,60,60,65,65,65,65,70,70) I | |
33743 | END IF | |
33744 | 2300 CONTINUE | |
33745 | END IF | |
33746 | 2400 CONTINUE | |
33747 | END IF | |
33748 | C | |
33749 | 50 CST=0.4D0*UNIV | |
33750 | GOTO 2500 | |
33751 | 55 CST=0.2D0*FLTI | |
33752 | GOTO 2500 | |
33753 | 60 CST=0.3D0+0.1D0*FLTI | |
33754 | GOTO 2500 | |
33755 | 65 CST=0.6D0+0.04D0*FLTI | |
33756 | GOTO 2500 | |
33757 | 70 CST=0.78D0+0.02D0*FLTI | |
33758 | C | |
33759 | 2500 CONTINUE | |
33760 | IF (DT_RNDM(CST).GT.0.5D0) CST=-CST | |
33761 | C | |
33762 | RETURN | |
33763 | END | |
33764 | ||
33765 | *$ CREATE DT_DHADRI.FOR | |
33766 | *COPY DT_DHADRI | |
33767 | * | |
33768 | *===dhadri=============================================================* | |
33769 | * | |
33770 | SUBROUTINE DT_DHADRI(N,PLAB,ELAB,CX,CY,CZ,ITTA) | |
33771 | ||
33772 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
33773 | SAVE | |
33774 | ||
33775 | PARAMETER ( LINP = 10 , | |
33776 | & LOUT = 6 , | |
33777 | & LDAT = 9 ) | |
33778 | C | |
33779 | C----------------------------- | |
33780 | C*** INPUT VARIABLES LIST: | |
33781 | C*** SAMPLING OF HADRON NUCLEON INTERACTION FOR (ABOUT) 0.1 LE PLAB LE 6 | |
33782 | C*** GEV/C LABORATORY MOMENTUM REGION | |
33783 | C*** N - PROJECTILE HADRON INDEX | |
33784 | C*** PLAB - LABORATORY MOMENTUM OF N (GEV/C) | |
33785 | C*** ELAB - LABORATORY ENERGY OF N (GEV) | |
33786 | C*** CX,CY,CZ - DIRECTION COSINES OF N IN THE LABORATORY SYSTEM | |
33787 | C*** ITTA - TARGET NUCLEON INDEX | |
33788 | C*** OUTPUT VARIABLES LIST OF PARTICLE CHARACTERISTICS IN /FINLSP/ | |
33789 | C IR COUNTS THE NUMBER OF PRODUCED PARTICLES | |
33790 | C*** ITR - PARTICLE INDEX, CXR,CYR,CZR - DIRECTION COSINES (LAB. SYST.) | |
33791 | C*** ELR,PLR LAB. ENERGY AND LAB. MOMENTUM OF THE SAMPLED PARTICLE | |
33792 | C*** RESPECT., UNITS (GEV/C AND GEV) | |
33793 | C---------------------------- | |
33794 | ||
33795 | COMMON /HNGAMR/ REDU,AMO,AMM(15) | |
33796 | COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17) | |
33797 | COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184), | |
33798 | & NRK(2,268),NURE(30,2) | |
33799 | * particle properties (BAMJET index convention), | |
33800 | * (dublicate of DTPART for HADRIN) | |
33801 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), | |
33802 | & K1H(110),K2H(110) | |
33803 | COMMON /HNSPLI/ WTI(460),NZKI(460,3) | |
33804 | COMMON /HNMETL/ CXS(149),CYS(149),CZS(149),ELS(149),PLS(149), | |
33805 | & ITS(149),IS | |
33806 | COMMON /HNDRUN/ RUNTES,EFTES | |
33807 | * particle properties (BAMJET index convention) | |
33808 | CHARACTER*8 ANAME | |
33809 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
33810 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
33811 | * final state from HADRIN interaction | |
33812 | PARAMETER (MAXFIN=10) | |
33813 | COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN), | |
33814 | & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH | |
33815 | ||
33816 | DIMENSION ITPRF(110) | |
33817 | DATA NNN/0/ | |
33818 | DATA UMODA/0./ | |
33819 | DATA ITPRF/-1,-1,5*1,-1,-1,1,1,1,-1,-1,-1,-1,6*1,-1,-1,-1,85*1/ | |
33820 | LOWP=0 | |
33821 | IF (N.LE.0.OR.N.GE.111)N=1 | |
33822 | IF (ITPRF( N ).GT.0 .OR. ITTA.GT.8) THEN | |
33823 | GOTO 280 | |
33824 | * WRITE (6,1000) | |
33825 | * + ' FALSE USE OF THE PARTICLE TYPE INDEX: N, ITTA', N, ITTA | |
33826 | * STOP | |
33827 | *1000 FORMAT (3(5H ****/),A,2I4,3(5H ****/)) | |
33828 | * + 45H FALSE USE OF THE PARTICLE TYPE INDEX, N,LUE ,I4,3(5H ****/)) | |
33829 | ENDIF | |
33830 | IATMPT=0 | |
33831 | IF (ABS(PLAB-5.0D0).LT.4.99999D0) GO TO 20 | |
33832 | C IF(IPRI.GE.1) WRITE (6,1010) PLAB | |
33833 | C STOP | |
33834 | 1010 FORMAT ( ' PROJECTILE HADRON MOMENTUM OUTSIDE OF THE | |
33835 | + ALLOWED REGION, PLAB=',1E15.5) | |
33836 | ||
33837 | 20 CONTINUE | |
33838 | UMODAT=N*1.11111D0+ITTA*2.19291D0 | |
33839 | IF(UMODAT.NE.UMODA) CALL DT_DCALUM(N,ITTA) | |
33840 | UMODA=UMODAT | |
33841 | 30 IATMPT=0 | |
33842 | LOWP=LOWP+1 | |
33843 | 40 CONTINUE | |
33844 | IMACH=0 | |
33845 | REDU=2.0D0 | |
33846 | IF (LOWP.GT.20) THEN | |
33847 | C WRITE(LOUT,*) ' jump 1' | |
33848 | GO TO 280 | |
33849 | ENDIF | |
33850 | NNN=N | |
33851 | IF (NNN.EQ.N) GO TO 50 | |
33852 | RUNTES=0.0D0 | |
33853 | EFTES=0.0D0 | |
33854 | 50 CONTINUE | |
33855 | IS=1 | |
33856 | IRH=0 | |
33857 | IST=1 | |
33858 | NSTAB=23 | |
33859 | IRE=NURE(N,1) | |
33860 | IF(ITTA.GT.1) IRE=NURE(N,2) | |
33861 | C | |
33862 | C----------------------------- | |
33863 | C*** IE,AMT,ECM,SI DETERMINATION | |
33864 | C---------------------------- | |
33865 | CALL DT_DSIGIN(IRE,PLAB,N,IE,AMT ,AMN,ECM,SI,ITTA) | |
33866 | IANTH=-1 | |
33867 | **sr | |
33868 | C IF (AMH(1).NE.0.93828D0) IANTH=1 | |
33869 | IF (AMH(1).NE.0.9383D0) IANTH=1 | |
33870 | ** | |
33871 | IF (IANTH.GE.0) SI=1.0D0 | |
33872 | ECMMH=ECM | |
33873 | C | |
33874 | C----------------------------- | |
33875 | C ENERGY INDEX | |
33876 | C IRE CHARACTERIZES THE REACTION | |
33877 | C IE IS THE ENERGY INDEX | |
33878 | C---------------------------- | |
33879 | IF (SI.LT.1.D-6) THEN | |
33880 | C WRITE(LOUT,*) ' jump 2' | |
33881 | GO TO 280 | |
33882 | ENDIF | |
33883 | IF (N.LE.NSTAB) GO TO 60 | |
33884 | RUNTES=RUNTES+1.0D0 | |
33885 | IF (RUNTES.LT.20.D0) WRITE(LOUT,1020)N | |
33886 | 1020 FORMAT(3H N=,I10,30H THE PROEKTILE IS A RESONANCE ) | |
33887 | IF(IBARH(N).EQ.1) N=8 | |
33888 | IF(IBARH(N).EQ.-1) N=9 | |
33889 | 60 CONTINUE | |
33890 | IMACH=IMACH+1 | |
33891 | **sr 19.2.97: loop for direct channel suppression | |
33892 | C IF (IMACH.GT.10) THEN | |
33893 | IF (IMACH.GT.1000) THEN | |
33894 | ** | |
33895 | C WRITE(LOUT,*) ' jump 3' | |
33896 | GO TO 280 | |
33897 | ENDIF | |
33898 | ECM =ECMMH | |
33899 | AMN2=AMN**2 | |
33900 | AMT2=AMT**2 | |
33901 | ECMN=(ECM**2+AMN2-AMT2)/(2.0D0*ECM ) | |
33902 | IF(ECMN.LE.AMN) ECMN=AMN | |
33903 | PCMN=SQRT(ECMN**2-AMN2) | |
33904 | GAM=(ELAB+AMT)/ECM | |
33905 | BGAM=PLAB/ECM | |
33906 | IF (IANTH.GE.0) ECM=2.1D0 | |
33907 | C | |
33908 | C----------------------------- | |
33909 | C*** RANDOM CHOICE OF REACTION CHANNEL | |
33910 | C---------------------------- | |
33911 | IST=0 | |
33912 | VV=DT_RNDM(AMN2) | |
33913 | VV=VV-1.D-17 | |
33914 | C | |
33915 | C----------------------------- | |
33916 | C*** PLACE REDUCED VERSION | |
33917 | C---------------------------- | |
33918 | IIEI=IEII(IRE) | |
33919 | IDWK=IEII(IRE+1)-IIEI | |
33920 | IIWK=IRII(IRE) | |
33921 | IIKI=IKII(IRE) | |
33922 | C | |
33923 | C----------------------------- | |
33924 | C*** SHRINKAGE TO THE CONSIDERED ENERGY REGION FOR THE USE OF WEIGHTS | |
33925 | C---------------------------- | |
33926 | HECM=ECM | |
33927 | HUMO=2.0D0*UMO(IIEI+IDWK)-UMO(IIEI+IDWK-1) | |
33928 | IF (HUMO.LT.ECM) ECM=HUMO | |
33929 | C | |
33930 | C----------------------------- | |
33931 | C*** INTERPOLATION PREPARATION | |
33932 | C---------------------------- | |
33933 | ECMO=UMO(IE) | |
33934 | ECM1=UMO(IE-1) | |
33935 | DECM=ECMO-ECM1 | |
33936 | DEC=ECMO-ECM | |
33937 | C | |
33938 | C----------------------------- | |
33939 | C*** RANDOM LOOP | |
33940 | C---------------------------- | |
33941 | IK=0 | |
33942 | WKK=0.0D0 | |
33943 | WICOR=0.0D0 | |
33944 | 70 IK=IK+1 | |
33945 | IWK=IIWK+(IK-1)*IDWK+IE-IIEI | |
33946 | WOK=WK(IWK) | |
33947 | WDK=WOK-WK(IWK-1) | |
33948 | C | |
33949 | C----------------------------- | |
33950 | C*** TESTVARIABLE WICO/WICOR: IF CHANNEL IK HAS THE SAME WEIGHTS LIKE IK | |
33951 | C GO TO NEXT CHANNEL, BECAUSE WKK((IK))-WKK((IK-1))=0, IK CAN NOT | |
33952 | C CONTRIBUTE | |
33953 | C---------------------------- | |
33954 | IF (PLAB.LT.PLABF(IIEI+2)) WDK=0.0D0 | |
33955 | WICO=WOK*1.23459876D0+WDK*1.735218469D0 | |
33956 | IF (WICO.EQ.WICOR) GO TO 70 | |
33957 | IF (UMO(IIEI+IDWK).LT.HECM) WDK=0.0D0 | |
33958 | WICOR=WICO | |
33959 | C | |
33960 | C----------------------------- | |
33961 | C*** INTERPOLATION IN CHANNEL WEIGHTS | |
33962 | C---------------------------- | |
33963 | EKLIM=-THRESH(IIKI+IK) | |
33964 | IELIM=IDT_IEFUND(EKLIM,IRE) | |
33965 | DELIM=UMO(IELIM)+EKLIM | |
33966 | *+1.D-16 | |
33967 | DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0 | |
33968 | IF (DELIM*DELIM-DETE*DETE) 90,90,80 | |
33969 | 80 DECC=DELIM | |
33970 | GO TO 100 | |
33971 | 90 DECC=DECM | |
33972 | 100 CONTINUE | |
33973 | WKK=WOK-WDK*DEC/(DECC+1.D-9) | |
33974 | C | |
33975 | C----------------------------- | |
33976 | C*** RANDOM CHOICE | |
33977 | C---------------------------- | |
33978 | C | |
33979 | IF (VV.GT.WKK) GO TO 70 | |
33980 | C | |
33981 | C***IK IS THE REACTION CHANNEL | |
33982 | C---------------------------- | |
33983 | INRK=IKII(IRE)+IK | |
33984 | ECM=HECM | |
33985 | I1001 =0 | |
33986 | C | |
33987 | 110 CONTINUE | |
33988 | IT1=NRK(1,INRK) | |
33989 | AM1=DT_DAMG(IT1) | |
33990 | IT2=NRK(2,INRK) | |
33991 | AM2=DT_DAMG(IT2) | |
33992 | AMS=AM1+AM2 | |
33993 | I1001=I1001+1 | |
33994 | IF (I1001.GT.50) GO TO 60 | |
33995 | C | |
33996 | IF (IT2*AMS.GT.IT2*ECM) GO TO 110 | |
33997 | IT11=IT1 | |
33998 | IT22=IT2 | |
33999 | IF (IANTH.GE.0) ECM=ELAB+AMT+0.00001D0 | |
34000 | AM11=AM1 | |
34001 | AM22=AM2 | |
34002 | IF (IT2.GT.0) GO TO 120 | |
34003 | **sr 19.2.97: supress direct channel for pp-collisions | |
34004 | IF ((N.EQ.1).AND.(ITTA.EQ.1).AND.(IT2.LE.0)) THEN | |
34005 | RR = DT_RNDM(AM11) | |
34006 | IF (RR.LE.0.75D0) GOTO 60 | |
34007 | ENDIF | |
34008 | ** | |
34009 | C | |
34010 | C----------------------------- | |
34011 | C INCLUSION OF DIRECT RESONANCES | |
34012 | C RANDOM CHOICE OF DECAY CHANNELS OF THE DIRECT RESONANCE IT1 | |
34013 | C------------------------ | |
34014 | KZ1=K1H(IT1) | |
34015 | IST=IST+1 | |
34016 | IECO=0 | |
34017 | ECO=ECM | |
34018 | GAM=(ELAB+AMT)/ECO | |
34019 | BGAM=PLAB/ECO | |
34020 | CXS(1)=CX | |
34021 | CYS(1)=CY | |
34022 | CZS(1)=CZ | |
34023 | GO TO 170 | |
34024 | 120 CONTINUE | |
34025 | WW=DT_RNDM(ECO) | |
34026 | IF(WW.LT. 0.5D0) GO TO 130 | |
34027 | IT1=IT22 | |
34028 | IT2=IT11 | |
34029 | AM1=AM22 | |
34030 | AM2=AM11 | |
34031 | 130 CONTINUE | |
34032 | C | |
34033 | C----------------------------- | |
34034 | C THE FIRST PARTICLE IS DEFINED TO BE THE FORWARD GOING ONE AT SMALL T | |
34035 | IBN=IBARH(N) | |
34036 | IB1=IBARH(IT1) | |
34037 | IT11=IT1 | |
34038 | IT22=IT2 | |
34039 | AM11=AM1 | |
34040 | AM22=AM2 | |
34041 | IF(IB1.EQ.IBN) GO TO 140 | |
34042 | IT1=IT22 | |
34043 | IT2=IT11 | |
34044 | AM1=AM22 | |
34045 | AM2=AM11 | |
34046 | 140 CONTINUE | |
34047 | C----------------------------- | |
34048 | C***IT1,IT2 ARE THE CREATED PARTICLES | |
34049 | C***MOMENTA AND DIRECTION COSINA IN THE CM - SYSTEM | |
34050 | C------------------------ | |
34051 | CALL DT_DTWOPA(ECM1,ECM2,PCM1,PCM2,COD1,COD2,COF1,COF2,SIF1,SIF2, | |
34052 | *IT1,IT2,ECM,ECMN,PCMN,N,AM1,AM2) | |
34053 | IST=IST+1 | |
34054 | ITS(IST)=IT1 | |
34055 | AMM(IST)=AM1 | |
34056 | C | |
34057 | C----------------------------- | |
34058 | C***TRANSFORMATION INTO LAB SYSTEM AND ROTATION | |
34059 | C---------------------------- | |
34060 | CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD1,COF1,SIF1, | |
34061 | &PCM1,ECM1,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST)) | |
34062 | IST=IST+1 | |
34063 | ITS(IST)=IT2 | |
34064 | AMM(IST)=AM2 | |
34065 | CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD2,COF2,SIF2, | |
34066 | *PCM2,ECM2,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST)) | |
34067 | 150 CONTINUE | |
34068 | C | |
34069 | C----------------------------- | |
34070 | C***TEST STABLE OR UNSTABLE | |
34071 | C---------------------------- | |
34072 | IF(ITS(IST).GT.NSTAB) GO TO 160 | |
34073 | IRH=IRH+1 | |
34074 | C | |
34075 | C----------------------------- | |
34076 | C***IRH IS THE NUMBER OF THE FINAL STABLE PARTICLE | |
34077 | C---------------------------- | |
34078 | C* IF (REDU.LT.0.D0) GO TO 1009 | |
34079 | ITRH(IRH)=ITS(IST) | |
34080 | PLRH(IRH)=PLS(IST) | |
34081 | CXRH(IRH)=CXS(IST) | |
34082 | CYRH(IRH)=CYS(IST) | |
34083 | CZRH(IRH)=CZS(IST) | |
34084 | ELRH(IRH)=ELS(IST) | |
34085 | IST=IST-1 | |
34086 | IF(IST.GE.1) GO TO 150 | |
34087 | GO TO 260 | |
34088 | 160 CONTINUE | |
34089 | C | |
34090 | C RANDOM CHOICE OF DECAY CHANNELS | |
34091 | C---------------------------- | |
34092 | C | |
34093 | IT=ITS(IST) | |
34094 | ECO=AMM(IST) | |
34095 | GAM=ELS(IST)/ECO | |
34096 | BGAM=PLS(IST)/ECO | |
34097 | IECO=0 | |
34098 | KZ1=K1H(IT) | |
34099 | 170 CONTINUE | |
34100 | IECO=IECO+1 | |
34101 | VV=DT_RNDM(GAM) | |
34102 | VV=VV-1.D-17 | |
34103 | IIK=KZ1-1 | |
34104 | 180 IIK=IIK+1 | |
34105 | IF (VV.GT.WTI(IIK)) GO TO 180 | |
34106 | C | |
34107 | C IIK IS THE DECAY CHANNEL | |
34108 | C---------------------------- | |
34109 | IT1=NZKI(IIK,1) | |
34110 | I310=0 | |
34111 | 190 CONTINUE | |
34112 | I310=I310+1 | |
34113 | AM1=DT_DAMG(IT1) | |
34114 | IT2=NZKI(IIK,2) | |
34115 | AM2=DT_DAMG(IT2) | |
34116 | IF (IT2-1.LT.0) GO TO 240 | |
34117 | IT3=NZKI(IIK,3) | |
34118 | AM3=DT_DAMG(IT3) | |
34119 | AMS=AM1+AM2+AM3 | |
34120 | C | |
34121 | C IF IIK-KIN.LIM.GT.ACTUAL TOTAL CM-ENERGY, DO AGAIN RANDOM IIK-CHOICE | |
34122 | C---------------------------- | |
34123 | IF (IECO.LE.10) GO TO 200 | |
34124 | IATMPT=IATMPT+1 | |
34125 | IF(IATMPT.GT.3) THEN | |
34126 | C WRITE(LOUT,*) ' jump 4' | |
34127 | GO TO 280 | |
34128 | ENDIF | |
34129 | GO TO 40 | |
34130 | 200 CONTINUE | |
34131 | IF (I310.GT.50) GO TO 170 | |
34132 | IF (AMS.GT.ECO) GO TO 190 | |
34133 | C | |
34134 | C FOR THE DECAY CHANNEL | |
34135 | C IT1,IT2, IT3 ARE THE PRODUCED PARTICLES FROM IT | |
34136 | C---------------------------- | |
34137 | IF (REDU.LT.0.D0) GO TO 30 | |
34138 | ITWTHC=0 | |
34139 | REDU=2.0D0 | |
34140 | IF(IT3.EQ.0) GO TO 220 | |
34141 | 210 CONTINUE | |
34142 | ITWTH=1 | |
34143 | CALL DT_DTHREP(ECO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,SIF1, | |
34144 | *COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3) | |
34145 | GO TO 230 | |
34146 | 220 CALL DT_DTWOPD(ECO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1, | |
34147 | &COD2,COF2,SIF2,AM1,AM2) | |
34148 | ITWTH=-1 | |
34149 | IT3=0 | |
34150 | 230 CONTINUE | |
34151 | ITWTHC=ITWTHC+1 | |
34152 | IF (REDU.GT.0.D0) GO TO 240 | |
34153 | REDU=2.0D0 | |
34154 | IF (ITWTHC.GT.100) GO TO 30 | |
34155 | IF (ITWTH) 220,220,210 | |
34156 | 240 CONTINUE | |
34157 | ITS(IST )=IT1 | |
34158 | IF (IT2-1.LT.0) GO TO 250 | |
34159 | ITS(IST+1) =IT2 | |
34160 | ITS(IST+2)=IT3 | |
34161 | RX=CXS(IST) | |
34162 | RY=CYS(IST) | |
34163 | RZ=CZS(IST) | |
34164 | AMM(IST)=AM1 | |
34165 | CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD1,COF1,SIF1,PCM1,ECM1, | |
34166 | *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST)) | |
34167 | IST=IST+1 | |
34168 | AMM(IST)=AM2 | |
34169 | CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD2,COF2,SIF2,PCM2,ECM2, | |
34170 | *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST)) | |
34171 | IF (IT3.LE.0) GO TO 250 | |
34172 | IST=IST+1 | |
34173 | AMM(IST)=AM3 | |
34174 | CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD3,COF3,SIF3,PCM3,ECM3, | |
34175 | *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST)) | |
34176 | 250 CONTINUE | |
34177 | GO TO 150 | |
34178 | 260 CONTINUE | |
34179 | 270 CONTINUE | |
34180 | RETURN | |
34181 | 280 CONTINUE | |
34182 | C | |
34183 | C---------------------------- | |
34184 | C | |
34185 | C ZERO CROSS SECTION CASE | |
34186 | C---------------------------- | |
34187 | C | |
34188 | IRH=1 | |
34189 | ITRH(1)=N | |
34190 | CXRH(1)=CX | |
34191 | CYRH(1)=CY | |
34192 | CZRH(1)=CZ | |
34193 | ELRH(1)=ELAB | |
34194 | PLRH(1)=PLAB | |
34195 | RETURN | |
34196 | END | |
34197 | ||
34198 | *$ CREATE DT_RUNTT.FOR | |
34199 | *COPY DT_RUNTT | |
34200 | * | |
34201 | *===runtt==============================================================* | |
34202 | * | |
34203 | BLOCK DATA DT_RUNTT | |
34204 | ||
34205 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
34206 | SAVE | |
34207 | ||
34208 | COMMON /HNDRUN/ RUNTES,EFTES | |
34209 | ||
34210 | DATA RUNTES,EFTES /100.D0,100.D0/ | |
34211 | ||
34212 | END | |
34213 | ||
34214 | *$ CREATE DT_NONAME.FOR | |
34215 | *COPY DT_NONAME | |
34216 | * | |
34217 | *===noname=============================================================* | |
34218 | * | |
34219 | BLOCK DATA DT_NONAME | |
34220 | ||
34221 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
34222 | SAVE | |
34223 | ||
34224 | * slope parameters for HADRIN interactions | |
34225 | COMMON /HNSLOP/ SM(25),BBM(25),BBB(25) | |
34226 | COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17) | |
34227 | ||
34228 | C DATAS DATAS DATAS DATAS DATAS | |
34229 | C****** ********* | |
34230 | DATA IKII/ 0, 15, 41, 67, 82, 93, 110, 133, 148, 159, 172, 183, | |
34231 | & 207, 224, 241, 252, 268 / | |
34232 | DATA IEII/ 0, 21, 46, 71, 92, 109, 126, 143, 160, 173, 186, 199, | |
34233 | & 220, 241, 262, 279, 296 / | |
34234 | DATA IRII/ 0, 315, 965, 1615, 1930, 2117, 2406, 2797, 3052, 3195, | |
34235 | & 3364, 3507, 4011, 4368, 4725, 4912, 5184/ | |
34236 | ||
34237 | C | |
34238 | C MASSES FOR THE SLOPE B(M) IN GEV | |
34239 | C SLOPE B(M) FOR AN MESONIC SYSTEM | |
34240 | C SLOPE B(M) FOR A BARYONIC SYSTEM | |
34241 | ||
34242 | * | |
34243 | DATA SM,BBM,BBB/ 0.8D0, 0.85D0, 0.9D0, 0.95D0, 1.D0, | |
34244 | & 1.05D0, 1.1D0, 1.15D0, 1.2D0, 1.25D0, | |
34245 | & 1.3D0, 1.35D0, 1.4D0, 1.45D0, 1.5D0, | |
34246 | & 1.55D0, 1.6D0, 1.65D0, 1.7D0, 1.75D0, | |
34247 | & 1.8D0, 1.85D0, 1.9D0, 1.95D0, 2.D0, | |
34248 | & 15.6D0, 14.95D0, 14.3D0, 13.65D0, 13.D0, | |
34249 | & 12.35D0, 11.7D0, 10.85D0, 10.D0, 9.15D0, | |
34250 | & 8.3D0, 7.8D0, 7.3D0, 7.25D0, 7.2D0, | |
34251 | & 6.95D0, 6.7D0, 6.6D0, 6.5D0, 6.3D0, | |
34252 | & 6.1D0, 5.85D0, 5.6D0, 5.35D0, 5.1D0, | |
34253 | & 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, | |
34254 | & 14.2D0, 13.4D0, 12.6D0, | |
34255 | & 11.8D0, 11.2D0, 10.6D0, 9.8D0, 9.D0, | |
34256 | & 8.25D0, 7.5D0, 6.25D0, 5.D0, 4.5D0, 5*4.D0 / | |
34257 | * | |
34258 | END | |
34259 | ||
34260 | *$ CREATE DT_DAMG.FOR | |
34261 | *COPY DT_DAMG | |
34262 | * | |
34263 | *===damg===============================================================* | |
34264 | * | |
34265 | DOUBLE PRECISION FUNCTION DT_DAMG(IT) | |
34266 | ||
34267 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
34268 | SAVE | |
34269 | ||
34270 | * particle properties (BAMJET index convention), | |
34271 | * (dublicate of DTPART for HADRIN) | |
34272 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), | |
34273 | & K1H(110),K2H(110) | |
34274 | ||
34275 | DIMENSION GASUNI(14) | |
34276 | DATA GASUNI/ | |
34277 | *-1.D0,-.98D0,-.95D0,-.87D0,-.72D0,-.48D0, | |
34278 | *-.17D0,.17D0,.48D0,.72D0,.87D0,.95D0,.98D0,1.D0/ | |
34279 | DATA GAUNO/2.352D0/ | |
34280 | DATA GAUNON/2.4D0/ | |
34281 | DATA IO/14/ | |
34282 | DATA NSTAB/23/ | |
34283 | ||
34284 | I=1 | |
34285 | IF (IT.LE.0) GO TO 30 | |
34286 | IF (IT.LE.NSTAB) GO TO 20 | |
34287 | DGAUNI=GAUNO*GAUNON/DBLE(IO-1) | |
34288 | VV=DT_RNDM(DGAUNI) | |
34289 | VV=VV*2.0D0-1.0D0+1.D-16 | |
34290 | 10 CONTINUE | |
34291 | VO=GASUNI(I) | |
34292 | I=I+1 | |
34293 | V1=GASUNI(I) | |
34294 | IF (VV.GT.V1) GO TO 10 | |
34295 | UNIGA=DGAUNI*(DBLE(I)-2.0D0+(VV-VO+1.D-16)/ | |
34296 | & (V1-VO)-(DBLE(IO)-1.0D0)*0.5D0) | |
34297 | DAM=GAH(IT)*UNIGA/GAUNO | |
34298 | AAM=AMH(IT)+DAM | |
34299 | DT_DAMG=AAM | |
34300 | RETURN | |
34301 | 20 CONTINUE | |
34302 | DT_DAMG=AMH(IT) | |
34303 | RETURN | |
34304 | 30 CONTINUE | |
34305 | DT_DAMG=0.0D0 | |
34306 | RETURN | |
34307 | END | |
34308 | ||
34309 | *$ CREATE DT_DCALUM.FOR | |
34310 | *COPY DT_DCALUM | |
34311 | * | |
34312 | *===dcalum=============================================================* | |
34313 | * | |
34314 | SUBROUTINE DT_DCALUM(N,ITTA) | |
34315 | ||
34316 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
34317 | SAVE | |
34318 | ||
34319 | C*** C.M.S.-ENERGY AND REACTION CHANNEL THRESHOLD CALCULATION | |
34320 | ||
34321 | * particle properties (BAMJET index convention), | |
34322 | * (dublicate of DTPART for HADRIN) | |
34323 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), | |
34324 | & K1H(110),K2H(110) | |
34325 | COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17) | |
34326 | COMMON /HNSPLI/ WTI(460),NZKI(460,3) | |
34327 | COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184), | |
34328 | & NRK(2,268),NURE(30,2) | |
34329 | ||
34330 | IRE=NURE(N,ITTA/8+1) | |
34331 | IEO=IEII(IRE)+1 | |
34332 | IEE=IEII(IRE +1) | |
34333 | AM1=AMH(N ) | |
34334 | AM12=AM1**2 | |
34335 | AM2=AMH(ITTA) | |
34336 | AM22=AM2**2 | |
34337 | DO 10 IE=IEO,IEE | |
34338 | PLAB2=PLABF(IE)**2 | |
34339 | ELAB=SQRT(AM12+AM22+2.0D0*SQRT(PLAB2+AM12)*AM2) | |
34340 | UMO(IE)=ELAB | |
34341 | 10 CONTINUE | |
34342 | IKO=IKII(IRE)+1 | |
34343 | IKE=IKII(IRE +1) | |
34344 | UMOO=UMO(IEO) | |
34345 | DO 30 IK=IKO,IKE | |
34346 | IF(NRK(2,IK).GT.0) GO TO 30 | |
34347 | IKI=NRK(1,IK) | |
34348 | AMSS=5.0D0 | |
34349 | K11=K1H(IKI) | |
34350 | K22=K2H(IKI) | |
34351 | DO 20 IK1=K11,K22 | |
34352 | IN=NZKI(IK1,1) | |
34353 | AMS=AMH(IN) | |
34354 | IN=NZKI(IK1,2) | |
34355 | IF(IN.GT.0)AMS=AMS+AMH(IN) | |
34356 | IN=NZKI(IK1,3) | |
34357 | IF(IN.GT.0) AMS=AMS+AMH(IN) | |
34358 | IF (AMS.LT.AMSS) AMSS=AMS | |
34359 | 20 CONTINUE | |
34360 | IF(UMOO.LT.AMSS) UMOO=AMSS | |
34361 | THRESH(IK)=UMOO | |
34362 | 30 CONTINUE | |
34363 | RETURN | |
34364 | END | |
34365 | ||
34366 | *$ CREATE DT_DCHANH.FOR | |
34367 | *COPY DT_DCHANH | |
34368 | * | |
34369 | *===dchanh=============================================================* | |
34370 | * | |
34371 | SUBROUTINE DT_DCHANH | |
34372 | ||
34373 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
34374 | SAVE | |
34375 | ||
34376 | PARAMETER ( LINP = 10 , | |
34377 | & LOUT = 6 , | |
34378 | & LDAT = 9 ) | |
34379 | * particle properties (BAMJET index convention), | |
34380 | * (dublicate of DTPART for HADRIN) | |
34381 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), | |
34382 | & K1H(110),K2H(110) | |
34383 | COMMON /HNSPLI/ WTI(460),NZKI(460,3) | |
34384 | COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17) | |
34385 | COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184), | |
34386 | & NRK(2,268),NURE(30,2) | |
34387 | ||
34388 | DIMENSION HWT(460),HWK(40),SI(5184) | |
34389 | EQUIVALENCE (WK(1),SI(1)) | |
34390 | C-------------------- | |
34391 | C*** USE ONLY FOR DATAPREPARATION OF PURE HADRIN | |
34392 | C*** CALCULATION OF REACTION- AND DECAY-CHANNEL-WEIGHTS, | |
34393 | C*** THRESHOLD ENERGIES+MOMENTA OF REACTION CHNLS. | |
34394 | C*** CHANGE OF WT- AND WK-INPUTDATA INTO WEIGHTS FOR THE M.-C.-PROCEDURE | |
34395 | C*** (ADDED ONE TO EACH OTHER FOR CORRESPONDING CHANNELS) | |
34396 | C-------------------------- | |
34397 | IREG=16 | |
34398 | DO 90 IRE=1,IREG | |
34399 | IWKO=IRII(IRE) | |
34400 | IEE=IEII(IRE+1)-IEII(IRE) | |
34401 | IKE=IKII(IRE+1)-IKII(IRE) | |
34402 | IEO=IEII(IRE)+1 | |
34403 | IIKA=IKII(IRE) | |
34404 | * modifications to suppress elestic scattering 24/07/91 | |
34405 | DO 80 IE=1,IEE | |
34406 | SIS=1.D-14 | |
34407 | SINORC=0.0D0 | |
34408 | DO 10 IK=1,IKE | |
34409 | IWK=IWKO+IEE*(IK-1)+IE | |
34410 | IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0 | |
34411 | SIS=SIS+SI(IWK)*SINORC | |
34412 | 10 CONTINUE | |
34413 | SIIN(IEO+IE-1)=SIS | |
34414 | SIO=0.D0 | |
34415 | IF (SIS.GE.1.D-12) GO TO 20 | |
34416 | SIS=1.D0 | |
34417 | SIO=1.D0 | |
34418 | 20 CONTINUE | |
34419 | SINORC=0.0D0 | |
34420 | DO 30 IK=1,IKE | |
34421 | IWK=IWKO+IEE*(IK-1)+IE | |
34422 | IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0 | |
34423 | SIO=SIO+SI(IWK)*SINORC/SIS | |
34424 | HWK(IK)=SIO | |
34425 | 30 CONTINUE | |
34426 | DO 40 IK=1,IKE | |
34427 | IWK=IWKO+IEE*(IK-1)+IE | |
34428 | 40 WK(IWK)=HWK(IK) | |
34429 | IIKI=IKII(IRE) | |
34430 | DO 70 IK=1,IKE | |
34431 | AM111=0.D0 | |
34432 | INRK1=NRK(1,IIKI+IK) | |
34433 | IF (INRK1.GT.0) AM111=AMH(INRK1) | |
34434 | AM222=0.D0 | |
34435 | INRK2=NRK(2,IIKI+IK) | |
34436 | IF (INRK2.GT.0) AM222=AMH(INRK2) | |
34437 | THRESH(IIKI+IK)=AM111 +AM222 | |
34438 | IF (INRK2-1.GE.0) GO TO 60 | |
34439 | INRKK=K1H(INRK1) | |
34440 | AMSS=5.D0 | |
34441 | INRKO=K2H(INRK1) | |
34442 | DO 50 INRK1=INRKK,INRKO | |
34443 | INZK1=NZKI(INRK1,1) | |
34444 | INZK2=NZKI(INRK1,2) | |
34445 | INZK3=NZKI(INRK1,3) | |
34446 | IF (INZK1.LE.0.OR.INZK1.GT.110) GO TO 50 | |
34447 | IF (INZK2.LE.0.OR.INZK2.GT.110) GO TO 50 | |
34448 | IF (INZK3.LE.0.OR.INZK3.GT.110) GO TO 50 | |
34449 | C WRITE (6,310)INRK1,INZK1,INZK2,INZK3 | |
34450 | 1000 FORMAT (4I10) | |
34451 | AMS=AMH(INZK1)+AMH(INZK2) | |
34452 | IF (INZK3-1.GE.0) AMS=AMS+AMH(INZK3) | |
34453 | IF (AMSS.GT.AMS) AMSS=AMS | |
34454 | 50 CONTINUE | |
34455 | AMS=AMSS | |
34456 | IF (AMS.LT.UMO(IEO)) AMS=UMO(IEO) | |
34457 | THRESH(IIKI+IK)=AMS | |
34458 | 60 CONTINUE | |
34459 | 70 CONTINUE | |
34460 | 80 CONTINUE | |
34461 | 90 CONTINUE | |
34462 | DO 100 J=1,460 | |
34463 | 100 HWT(J)=0.D0 | |
34464 | DO 120 I=1,110 | |
34465 | IK1=K1H(I) | |
34466 | IK2=K2H(I) | |
34467 | HV=0.D0 | |
34468 | IF (IK2.GT.460)IK2=460 | |
34469 | IF (IK1.LE.0)IK1=1 | |
34470 | DO 110 J=IK1,IK2 | |
34471 | HV=HV+WTI(J) | |
34472 | HWT(J)=HV | |
34473 | JI=J | |
34474 | 110 CONTINUE | |
34475 | IF (ABS(HV-1.0D0).GT.1.D-4) WRITE(LOUT,1010)I,JI,HV | |
34476 | 1010 FORMAT (35H ERROR IN HWT, FALSE USE OF CHANWH ,2I6,F10.2) | |
34477 | 120 CONTINUE | |
34478 | DO 130 J=1,460 | |
34479 | 130 WTI(J)=HWT(J) | |
34480 | RETURN | |
34481 | END | |
34482 | ||
34483 | *$ CREATE DT_DHADDE.FOR | |
34484 | *COPY DT_DHADDE | |
34485 | * | |
34486 | *===dhadde=============================================================* | |
34487 | * | |
34488 | SUBROUTINE DT_DHADDE | |
34489 | ||
34490 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
34491 | SAVE | |
34492 | ||
34493 | * particle properties (BAMJET index convention) | |
34494 | CHARACTER*8 ANAME | |
34495 | COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), | |
34496 | & IICH(210),IIBAR(210),K1(210),K2(210) | |
34497 | * HADRIN: decay channel information | |
34498 | PARAMETER (IDMAX9=602) | |
34499 | CHARACTER*8 ZKNAME | |
34500 | COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3) | |
34501 | * particle properties (BAMJET index convention), | |
34502 | * (dublicate of DTPART for HADRIN) | |
34503 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), | |
34504 | & K1H(110),K2H(110) | |
34505 | COMMON /HNSPLI/ WTI(460),NZKI(460,3) | |
34506 | * decay channel information for HADRIN | |
34507 | COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16), | |
34508 | & K1Z(16),K2Z(16),WTZ(153),II22, | |
34509 | & NZK1(153),NZK2(153),NZK3(153) | |
34510 | ||
34511 | DATA IRETUR/0/ | |
34512 | ||
34513 | IRETUR=IRETUR+1 | |
34514 | AMH(31)=0.48D0 | |
34515 | IF (IRETUR.GT.1) RETURN | |
34516 | DO 10 I=1,94 | |
34517 | AMH(I) = AAM(I) | |
34518 | GAH(I) = GA(I) | |
34519 | TAUH(I) = TAU(I) | |
34520 | ICHH(I) = IICH(I) | |
34521 | IBARH(I) = IIBAR(I) | |
34522 | K1H(I) = K1(I) | |
34523 | K2H(I) = K2(I) | |
34524 | 10 CONTINUE | |
34525 | **sr | |
34526 | C AMH(1)=0.93828D0 | |
34527 | AMH(1)=0.9383D0 | |
34528 | ** | |
34529 | AMH(2)=AMH(1) | |
34530 | DO 20 I=26,30 | |
34531 | K1H(I)=452 | |
34532 | K2H(I)=452 | |
34533 | 20 CONTINUE | |
34534 | DO 30 I=1,307 | |
34535 | WTI(I) = WT(I) | |
34536 | NZKI(I,1) = NZK(I,1) | |
34537 | NZKI(I,2) = NZK(I,2) | |
34538 | NZKI(I,3) = NZK(I,3) | |
34539 | 30 CONTINUE | |
34540 | DO 40 I=1,16 | |
34541 | L=I+94 | |
34542 | AMH(L)=AMZ(I) | |
34543 | GAH( L)=GAZ(I) | |
34544 | TAUH( L)=TAUZ(I) | |
34545 | ICHH( L)=ICHZ(I) | |
34546 | IBARH( L)=IBARZ(I) | |
34547 | K1H( L)=K1Z(I) | |
34548 | K2H( L)=K2Z(I) | |
34549 | 40 CONTINUE | |
34550 | DO 50 I=1,153 | |
34551 | L=I+307 | |
34552 | WTI(L) = WTZ(I) | |
34553 | NZKI(L,3) = NZK3(I) | |
34554 | NZKI(L,2) = NZK2(I) | |
34555 | NZKI(L,1) = NZK1(I) | |
34556 | 50 CONTINUE | |
34557 | RETURN | |
34558 | END | |
34559 | ||
34560 | *$ CREATE IDT_IEFUND.FOR | |
34561 | *COPY IDT_IEFUND | |
34562 | * | |
34563 | *===iefund=============================================================* | |
34564 | * | |
34565 | INTEGER FUNCTION IDT_IEFUND(PL,IRE) | |
34566 | ||
34567 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
34568 | SAVE | |
34569 | ||
34570 | C*****IEFUN CALCULATES A MOMENTUM INDEX | |
34571 | ||
34572 | PARAMETER ( LINP = 10 , | |
34573 | & LOUT = 6 , | |
34574 | & LDAT = 9 ) | |
34575 | COMMON /HNDRUN/ RUNTES,EFTES | |
34576 | COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17) | |
34577 | COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184), | |
34578 | & NRK(2,268),NURE(30,2) | |
34579 | ||
34580 | IPLA=IEII(IRE)+1 | |
34581 | *+1 | |
34582 | IPLE=IEII(IRE+1) | |
34583 | IF (PL.LT.0.) GO TO 30 | |
34584 | DO 10 I=IPLA,IPLE | |
34585 | J=I-IPLA+1 | |
34586 | IF (PL.LE.PLABF(I)) GO TO 60 | |
34587 | 10 CONTINUE | |
34588 | I=IPLE | |
34589 | IF ( EFTES.GT.40.D0) GO TO 20 | |
34590 | EFTES=EFTES+1.0D0 | |
34591 | WRITE(LOUT,1000)PL,J | |
34592 | 20 CONTINUE | |
34593 | GO TO 70 | |
34594 | 30 CONTINUE | |
34595 | DO 40 I=IPLA,IPLE | |
34596 | J=I-IPLA+1 | |
34597 | IF (-PL.LE.UMO(I)) GO TO 60 | |
34598 | 40 CONTINUE | |
34599 | I=IPLE | |
34600 | IF ( EFTES.GT.40.D0) GO TO 50 | |
34601 | EFTES=EFTES+1.0D0 | |
34602 | WRITE(LOUT,1000)PL,I | |
34603 | 50 CONTINUE | |
34604 | 60 CONTINUE | |
34605 | 70 CONTINUE | |
34606 | IDT_IEFUND=I | |
34607 | RETURN | |
34608 | 1000 FORMAT(14H PLAB OR -ECM=,E12.4,27H IS OUT OF CONSIDERED RANGE , | |
34609 | +7H IEFUN=,I5) | |
34610 | END | |
34611 | ||
34612 | *$ CREATE DT_DSIGIN.FOR | |
34613 | *COPY DT_DSIGIN | |
34614 | * | |
34615 | *===dsigin=============================================================* | |
34616 | * | |
34617 | SUBROUTINE DT_DSIGIN(IRE ,PLAB,N,IE ,AMT ,AMN,ECM ,SI ,ITAR) | |
34618 | ||
34619 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
34620 | SAVE | |
34621 | ||
34622 | * particle properties (BAMJET index convention), | |
34623 | * (dublicate of DTPART for HADRIN) | |
34624 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), | |
34625 | & K1H(110),K2H(110) | |
34626 | COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17) | |
34627 | COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184), | |
34628 | & NRK(2,268),NURE(30,2) | |
34629 | ||
34630 | IE=IDT_IEFUND(PLAB,IRE) | |
34631 | IF (IE.LE.IEII(IRE)) IE=IE+1 | |
34632 | AMT=AMH(ITAR) | |
34633 | AMN=AMH(N) | |
34634 | AMN2=AMN*AMN | |
34635 | AMT2=AMT*AMT | |
34636 | ECM=SQRT(AMN2+AMT2+2.0D0*AMT*SQRT(AMN2+PLAB**2)) | |
34637 | C*** INTERPOLATION PREPARATION | |
34638 | ECMO=UMO(IE) | |
34639 | ECM1=UMO(IE-1) | |
34640 | DECM=ECMO-ECM1 | |
34641 | DEC=ECMO-ECM | |
34642 | IIKI=IKII(IRE)+1 | |
34643 | EKLIM=-THRESH(IIKI) | |
34644 | WOK=SIIN(IE) | |
34645 | WDK=WOK-SIIN(IE-1) | |
34646 | IF (ECM.GT.ECMO) WDK=0.0D0 | |
34647 | C*** INTERPOLATION IN CHANNEL WEIGHTS | |
34648 | IELIM=IDT_IEFUND(EKLIM,IRE) | |
34649 | DELIM=UMO(IELIM)+EKLIM | |
34650 | *+1.D-16 | |
34651 | DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0 | |
34652 | IF (DELIM*DELIM-DETE*DETE) 20,20,10 | |
34653 | 10 DECC=DELIM | |
34654 | GO TO 30 | |
34655 | 20 DECC=DECM | |
34656 | 30 CONTINUE | |
34657 | WKK=WOK-WDK*DEC/(DECC+1.D-9) | |
34658 | IF (WKK.LT.0.0D0) WKK=0.0D0 | |
34659 | SI=WKK+1.D-12 | |
34660 | IF (-EKLIM.GT.ECM) SI=1.D-14 | |
34661 | RETURN | |
34662 | END | |
34663 | ||
34664 | *$ CREATE DT_DTCHOI.FOR | |
34665 | *COPY DT_DTCHOI | |
34666 | * | |
34667 | *===dtchoi=============================================================* | |
34668 | * | |
34669 | SUBROUTINE DT_DTCHOI(T,P,PP,E,EE,I,II,N,AM1,AM2) | |
34670 | ||
34671 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
34672 | SAVE | |
34673 | ||
34674 | C **************************** | |
34675 | C TCHOIC CALCULATES A RANDOM VALUE | |
34676 | C FOR THE FOUR-MOMENTUM-TRANSFER T | |
34677 | C **************************** | |
34678 | ||
34679 | * particle properties (BAMJET index convention), | |
34680 | * (dublicate of DTPART for HADRIN) | |
34681 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), | |
34682 | & K1H(110),K2H(110) | |
34683 | * slope parameters for HADRIN interactions | |
34684 | COMMON /HNSLOP/ SM(25),BBM(25),BBB(25) | |
34685 | ||
34686 | AMA=AM1 | |
34687 | AMB=AM2 | |
34688 | IF (I.GT.30.AND.II.GT.30) GO TO 20 | |
34689 | III=II | |
34690 | AM3=AM2 | |
34691 | IF (I.LE.30) GO TO 10 | |
34692 | III=I | |
34693 | AM3=AM1 | |
34694 | 10 CONTINUE | |
34695 | GO TO 30 | |
34696 | 20 CONTINUE | |
34697 | III=II | |
34698 | AM3=AM2 | |
34699 | IF (AMA.LE.AMB) GO TO 30 | |
34700 | III=I | |
34701 | AM3=AM1 | |
34702 | 30 CONTINUE | |
34703 | IB=IBARH(III) | |
34704 | AMA=AM3 | |
34705 | K=INT((AMA-0.75D0)/0.05D0) | |
34706 | IF (K-2.LT.0) K=1 | |
34707 | IF (K-26.GE.0) K=25 | |
34708 | IF (IB)50,40,50 | |
34709 | 40 BM=BBM(K) | |
34710 | GO TO 60 | |
34711 | 50 BM=BBB(K) | |
34712 | 60 CONTINUE | |
34713 | C NORMALIZATION | |
34714 | TMIN=-2.0D0*(E*EE-P*PP)+AMH(N)**2+AM1 **2 | |
34715 | TMAX=-2.0D0*(E*EE+P*PP)+AMH(N)**2+AM1 **2 | |
34716 | VB=DT_RNDM(TMIN) | |
34717 | **sr test | |
34718 | C IF (VB.LT.0.2D0) BM=BM*0.1 | |
34719 | C **0.5 | |
34720 | BM = BM*5.05D0 | |
34721 | ** | |
34722 | TMI=BM*TMIN | |
34723 | TMA=BM*TMAX | |
34724 | ETMA=0.D0 | |
34725 | IF (ABS(TMA).GT.120.D0) GO TO 70 | |
34726 | ETMA=EXP(TMA) | |
34727 | 70 CONTINUE | |
34728 | AN=(1.0D0/BM)*(EXP(TMI)-ETMA) | |
34729 | C*** RANDOM CHOICE OF THE T - VALUE | |
34730 | R=DT_RNDM(TMI) | |
34731 | T=(1.0D0/BM)*LOG(ETMA+R*AN*BM) | |
34732 | RETURN | |
34733 | END | |
34734 | ||
34735 | *$ CREATE DT_DTWOPA.FOR | |
34736 | *COPY DT_DTWOPA | |
34737 | * | |
34738 | *===dtwopa=============================================================* | |
34739 | * | |
34740 | SUBROUTINE DT_DTWOPA(E1,E2,P1,P2,COD1,COD2,COF1,COF2,SIF1,SIF2, | |
34741 | &IT1,IT2,UMOO,ECM,P,N,AM1,AM2) | |
34742 | ||
34743 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
34744 | SAVE | |
34745 | ||
34746 | C ****************************************************** | |
34747 | C QUASI TWO PARTICLE PRODUCTION | |
34748 | C TWOPAR CALCULATES THE ENERGYS AND THE MOMENTA | |
34749 | C FOR THE CREATED PARTICLES OR RESONANCES IT1 AND IT2 | |
34750 | C IN THE CM - SYSTEM | |
34751 | C COD1,COD2,COF1,COF2,SIF1,SIF2 ARE THE ANGLES FOR | |
34752 | C SPHERICAL COORDINATES | |
34753 | C ****************************************************** | |
34754 | ||
34755 | * particle properties (BAMJET index convention), | |
34756 | * (dublicate of DTPART for HADRIN) | |
34757 | COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110), | |
34758 | & K1H(110),K2H(110) | |
34759 | ||
34760 | AMA=AM1 | |
34761 | AMB=AM2 | |
34762 | AMA2=AMA*AMA | |
34763 | E1=((UMOO-AMB)*(UMOO+AMB) + AMA2)/(2.0D0*UMOO) | |
34764 | E2=UMOO - E1 | |
34765 | IF (E1.LT.AMA*1.00001D0) E1=AMA*1.00001D0 | |
34766 | AMTE=(E1-AMA)*(E1+AMA) | |
34767 | AMTE=AMTE+1.D-18 | |
34768 | P1=SQRT(AMTE) | |
34769 | P2=P1 | |
34770 | C / P2 / = / P1 / BUT OPPOSITE DIRECTIONS | |
34771 | C DETERMINATION OF THE ANGLES | |
34772 | C COS(THETA1)=COD1 COS(THETA2)=COD2 | |
34773 | C SIN(PHI1)=SIF1 SIN(PHI2)=SIF2 | |
34774 | C COS(PHI1)=COF1 COS(PHI2)=COF2 | |
34775 | C PHI IS UNIFORMLY DISTRIBUTED IN ( 0,2*PI ) | |
34776 | CALL DT_DSFECF(COF1,SIF1) | |
34777 | COF2=-COF1 | |
34778 | SIF2=-SIF1 | |
34779 | C CALCULATION OF THETA1 | |
34780 | CALL DT_DTCHOI(TR,P,P1,ECM,E1,IT1,IT2,N,AM1,AM2) | |
34781 | COD1=(TR-AMA2-AMH(N)*AMH(N)+2.0D0*ECM*E1)/(2.0D0*P*P1+1.D-18) | |
34782 | IF (COD1.GT.0.9999999D0) COD1=0.9999999D0 | |
34783 | COD2=-COD1 | |
34784 | RETURN | |
34785 | END | |
34786 | ||
34787 | *$ CREATE DT_ZK.FOR | |
34788 | *COPY DT_ZK | |
34789 | * | |
34790 | *===zk=================================================================* | |
34791 | * | |
34792 | BLOCK DATA DT_ZK | |
34793 | ||
34794 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
34795 | SAVE | |
34796 | ||
34797 | * decay channel information for HADRIN | |
34798 | COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16), | |
34799 | & K1Z(16),K2Z(16),WTZ(153),II22, | |
34800 | & NZK1(153),NZK2(153),NZK3(153) | |
34801 | * decay channel information for HADRIN | |
34802 | CHARACTER*8 ANAMZ,ZKNAM4,ZKNAM5,ZKNAM6 | |
34803 | COMMON /HNADDN/ ANAMZ(16),ZKNAM4(9),ZKNAM5(90),ZKNAM6(54) | |
34804 | ||
34805 | * Particle masses in GeV * | |
34806 | DATA AMZ/ 3*2.2D0, 0.9576D0, 3*1.887D0, 2.4D0, 2.03D0, 2*1.44D0, | |
34807 | & 2*1.7D0, 3*0.D0/ | |
34808 | * Resonance width Gamma in GeV * | |
34809 | DATA GAZ/ 3*.2D0, .1D0, 4*.2D0, .18D0, 2*.2D0, 2*.15D0, 3*0.D0 / | |
34810 | * Mean life time in seconds * | |
34811 | DATA TAUZ / 16*0.D0 / | |
34812 | * Charge of particles and resonances * | |
34813 | DATA ICHZ/ 0, 1, 3*0, 1, -1, 0, 1, -1, 0, 0, 1 , 3*0 / | |
34814 | * Baryonic charge * | |
34815 | DATA IBARZ/ 2, 7*0, 1, -1, -1, 1, 1, 3*0 / | |
34816 | * First number of decay channels used for resonances * | |
34817 | * and decaying particles * | |
34818 | DATA K1Z/ 308,310,313,317,322,365,393,421,425,434,440,446,449, | |
34819 | & 3*460/ | |
34820 | * Last number of decay channels used for resonances * | |
34821 | * and decaying particles * | |
34822 | DATA K2Z/ 309,312,316,321,364,392,420,424,433,439,445,448,451, | |
34823 | & 3*460/ | |
34824 | * Weight of decay channel * | |
34825 | DATA WTZ/ .17D0, .83D0, 2*.33D0, .34D0, .17D0, 2*.33D0, .17D0, | |
34826 | & .01D0, .13D0, .36D0, .27D0, .23D0, .0014D0, .0029D0, .0014D0, | |
34827 | & .0029D0, 4*.0007D0, .0517D0, .0718D0, .0144D0, .0431D0, .0359D0, | |
34828 | & .0718D0, .0014D0, .0273D0, .0014D0, .0431D0, 2*.0129D0, .0259D0, | |
34829 | & .0517D0, .0359D0, .0014D0, 2*.0144D0, .0129D0, .0014D0, .0259D0, | |
34830 | & .0359D0, .0072D0, .0474D0, .0948D0, .0259D0, .0072D0, .0144D0, | |
34831 | & .0287D0, .0431D0, .0144D0, .0287D0, .0474D0, .0144D0, .0075D0, | |
34832 | & .0057D0, .0019D0, .0038D0, .0095D0, 2*.0014D0, .0191D0, .0572D0, | |
34833 | & .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0, .0686D0,.0172D0, | |
34834 | & .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0, .0190D0, | |
34835 | & .0057D0, .0019D0, .0038D0, .0095D0, .0014D0, .0014D0, .0191D0, | |
34836 | & .0572D0, .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0,.0686D0, | |
34837 | & .0172D0, .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0, | |
34838 | & .0190D0, 4*.25D0, 2*.2D0, .12D0, .1D0, .07D0, .07D0, .14D0, | |
34839 | & 2*.05D0, .0D0, .3334D0, .2083D0, 2*.125D0, .2083D0, .0D0, .125D0, | |
34840 | & .2083D0, .3334D0, .2083D0, .125D0, .3D0, .05D0, .65D0, .3D0, | |
34841 | & .05D0, .65D0, 9*1.D0 / | |
34842 | * Particle numbers in decay channel * | |
34843 | DATA NZK1/ 8, 1, 2, 9, 1, 2, 9, 2, 9, 7, 13, 31, 15, 24, 23, 13, | |
34844 | & 23, 13, 2*23, 14, 13, 23, 31, 98, 2*33, 32, 23, 14, 13, 35, 2*23, | |
34845 | & 14, 13, 33, 23, 98, 31, 23, 14, 13, 35, 2*33, 32, 23, 35, 33, 32, | |
34846 | & 98, 5*35, 4*13, 23, 13, 98, 32, 33, 23, 13, 23, 13, 14, 13, 32, | |
34847 | & 13, 98, 23, 13, 2*32, 13, 33, 32, 98, 2*35, 4*14, 23, 14, 98, | |
34848 | & 2*34, 23, 14, 23, 2*14, 13, 34, 14, 98, 23, 14, 2*34, 14, 33, 32, | |
34849 | & 98, 2*35, 104, 61, 105, 62, 1, 17, 21, 17, 22, 2*21, 22, 21, 2, | |
34850 | & 67, 68, 69, 2, 2*9, 68, 69, 70, 2, 9, 2*24, 15, 2*25, 16, 9*0/ | |
34851 | DATA NZK2/ 2*8, 1, 8, 9, 2*8, 2*1, 7, 14, 13, 16, 25, 23, 14, 23, | |
34852 | & 14, 31, 33, 32, 34, 35, 31, 23, 31, 33, 34, 31, 32, 34, 31, 33, | |
34853 | & 32, 2*33, 35, 31, 33, 31, 33, 32, 34, 35, 31, 33, 34, 35, 31, | |
34854 | & 4*33, 32, 3*35, 2*23, 13, 31, 32, 33, 13, 31, 32, 2*31, 32, 33, | |
34855 | & 32, 32, 35, 31, 2*32, 33, 31, 33, 35, 33, 3*32, 35, 2*23, 14, | |
34856 | & 31, 34, 33, 14, 31, 33, 2*31, 34, 32, 33, 34, 35, 31, 2*34, 33, | |
34857 | & 31, 33, 35, 33, 2*34, 33, 35, 1, 2, 8, 9, 25, 13, 35, 2*32, 33, | |
34858 | & 31, 13, 23, 31, 13, 23, 14, 79, 80, 31, 13, 23, 14, 78, 79, 8, | |
34859 | & 1, 8, 1, 8, 1, 9*0 / | |
34860 | DATA NZK3/ 23, 14, 2*13, 23, 13, 2*23, 14, 0, 7, 14, 4*0, 2*23, | |
34861 | & 10*0, 33, 2*31, 0, 33, 34, 32, 34, 0, 35, 0, 31, 3*35, 0, 3*31, | |
34862 | & 35, 31, 33, 34, 31, 33, 34, 31, 33, 35, 0, 23, 14, 6*0, 32, 3*33, | |
34863 | & 32, 34, 0, 35, 0, 2*35, 2*31, 35, 32, 34, 31, 33, 32, 0, 23, 13, | |
34864 | & 6*0, 34, 2*33, 34, 33, 34, 0, 35, 0,2*35, 2*31, 35, 2*34, 31, | |
34865 | & 2*34, 25*0, 23, 2*14, 23, 2*13, 9*0 / | |
34866 | * Particle names * | |
34867 | DATA ANAMZ / 'NNPI', 'ANPPI', 'ANNPI', ' ETS ',' PAP ',' PAN ', | |
34868 | & 'APN', 'DEO ', 'S+2030', 'AN*-14', 'AN*014','KONPI ','AKOPPI', | |
34869 | & 3*'BLANK' / | |
34870 | * Name of decay channel * | |
34871 | DATA ZKNAM4/'NNPI0','PNPI-','APPPI+','ANNPI+','ANPPI0','APNPI+', | |
34872 | & 'ANNPI0','APPPI0','ANPPI-'/ | |
34873 | DATA ZKNAM5/' GAGA ','P+P-GA','ETP+P-','K+K- ','K0AK0 ', | |
34874 | & ' POPO ',' P+P- ','POPOPO','P+P0P-','P0ET ','&0R0 ','P-R+ ', | |
34875 | & 'P+R- ','POOM ',' ETET ','ETSP0 ','R0ET ',' R0R0 ','R+R- ', | |
34876 | & 'P0ETR0','P-ETR+','P+ETR-',' OMET ','P0R0R0','P0R+R-','P-R+R0', | |
34877 | & 'P+R-R0','R0OM ','P0ETOM','ETSR0 ','ETETET','P0R0OM','P-R+OM', | |
34878 | & 'P+R-OM','OMOM ','R0ETET','R0R0ET','R+R-ET','P0OMOM','OMETET', | |
34879 | & 'R0R0R0','R+R0R-','ETSRET','OMR0R0','OMR+R-','OMOMET','OMOMR0', | |
34880 | & 'OMOMOM', | |
34881 | & ' P+PO ','P+POPO','P+P+P-','P+ET ','P0R+ ','P+R0 ','ETSP+ ', | |
34882 | & 'R+ET ',' R0R+ ','POETR+','P+ETR0','POR+R-','P+R0R0','P-R+R+', | |
34883 | & 'P+R-R+','R+OM ','P+ETOM','ETSR+ ','POR+OM','P+R0OM','R+ETET', | |
34884 | & 'R+R0ET','P+OMOM','R0R0R+','R+R+R-','ETSR+E','OMR+R0','OMOMR+', | |
34885 | & 'P-PO ','P-POPO','P-P-P+','P-ET ','POR- ','P-R0 ','ETSP- ', | |
34886 | & 'R-ET ','R-R0 ','POETR-','P-ETR0','POR-R0','P-R+R-','P-R0R0'/ | |
34887 | DATA ZKNAM6/'P+R-R-','R-OM ','P-ETOM','ETSR- ','POR-OM','P-R0OM', | |
34888 | & 'R-ETET','R-R0ET','P-OMOM','R0R0R-','R+R-R-','ETSR-E','OMR0R-', | |
34889 | & 'OMOMR-', 'PAN-14','APN+14','NAN014','ANN014','PAKO ','LPI+ ', | |
34890 | & 'SI+OM','LAMRO+','SI0RO+','SI+RO0','SI+ETA','SI0PI+','SI+PI0', | |
34891 | & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHOO','ANRHO-','ANETA ', | |
34892 | & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0', | |
34893 | & 'KONPIO','KOPPI-','K+NPI-','AKOPPO','AKONP+','K-PPI+', | |
34894 | & 9*'BLANK'/ | |
34895 | *= end*block.zk * | |
34896 | END | |
34897 | ||
34898 | *$ CREATE DT_BLKD43.FOR | |
34899 | *COPY DT_BLKD43 | |
34900 | * | |
34901 | *===blkd43=============================================================* | |
34902 | * | |
34903 | BLOCK DATA DT_BLKD43 | |
34904 | ||
34905 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
34906 | SAVE | |
34907 | ||
34908 | * | |
34909 | *=== reac =============================================================* | |
34910 | * | |
34911 | *----------------------------------------------------------------------* | |
34912 | * * | |
34913 | * Created on 10 december 1991 by Alfredo Ferrari & Paola Sala * | |
34914 | * Infn - Milan * | |
34915 | * * | |
34916 | * Last change on 10-dec-91 by Alfredo Ferrari * | |
34917 | * * | |
34918 | * This is the original common reac of Hadrin * | |
34919 | * * | |
34920 | *----------------------------------------------------------------------* | |
34921 | * | |
34922 | COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184), | |
34923 | & NRK(2,268),NURE(30,2) | |
34924 | ||
34925 | DIMENSION | |
34926 | & UMOPI(92), UMOKC(68), UMOP(39), UMON(63), UMOK0(34), | |
34927 | & PLAPI(92), PLAKC(68), PLAP(39), PLAN(63), PLAK0(34), | |
34928 | & SPIKP1(315), SPIKPU(278), SPIKPV(372), | |
34929 | & SPIKPW(278), SPIKPX(372), SPIKP4(315), | |
34930 | & SPIKP5(187), SPIKP6(289), | |
34931 | & SKMPEL(102), SPIKP7(289), SKMNEL(68), SPIKP8(187), | |
34932 | & SPIKP9(143), SPIKP0(169), SPKPV(143), | |
34933 | & SAPPEL(105), SPIKPE(399), SAPNEL(84), SPIKPZ(273), | |
34934 | & SANPEL(84) , SPIKPF(273), | |
34935 | & SPKP15(187), SPKP16(272), | |
34936 | & NRKPI(164), NRKKC(132), NRKP(70), NRKN(116), NRKK0(54), | |
34937 | & NURELN(60) | |
34938 | * | |
34939 | DIMENSION NRKLIN(532) | |
34940 | EQUIVALENCE (NRK(1,1), NRKLIN(1)) | |
34941 | EQUIVALENCE ( UMO( 1), UMOPI(1)), ( UMO( 93), UMOKC(1)) | |
34942 | EQUIVALENCE ( UMO(161), UMOP(1)), ( UMO(200), UMON(1)) | |
34943 | EQUIVALENCE ( UMO(263), UMOK0(1)) | |
34944 | EQUIVALENCE ( PLABF( 1), PLAPI(1)), ( PLABF( 93), PLAKC(1)) | |
34945 | EQUIVALENCE ( PLABF(161), PLAP(1)), ( PLABF(200), PLAN(1)) | |
34946 | EQUIVALENCE ( PLABF(263), PLAK0(1)) | |
34947 | EQUIVALENCE ( WK( 1), SPIKP1(1)), ( WK( 316), SPIKPU(1)) | |
34948 | EQUIVALENCE ( WK( 594), SPIKPV(1)), ( WK( 966), SPIKPW(1)) | |
34949 | EQUIVALENCE ( WK(1244), SPIKPX(1)), ( WK(1616), SPIKP4(1)) | |
34950 | EQUIVALENCE ( WK(1931), SPIKP5(1)), ( WK(2118), SPIKP6(1)) | |
34951 | EQUIVALENCE ( WK(2407), SKMPEL(1)), ( WK(2509), SPIKP7(1)) | |
34952 | EQUIVALENCE ( WK(2798), SKMNEL(1)), ( WK(2866), SPIKP8(1)) | |
34953 | EQUIVALENCE ( WK(3053), SPIKP9(1)), ( WK(3196), SPIKP0(1)) | |
34954 | EQUIVALENCE ( WK(3365), SPKPV(1)), ( WK(3508), SAPPEL(1)) | |
34955 | EQUIVALENCE ( WK(3613), SPIKPE(1)), ( WK(4012), SAPNEL(1)) | |
34956 | EQUIVALENCE ( WK(4096), SPIKPZ(1)), ( WK(4369), SANPEL(1)) | |
34957 | EQUIVALENCE ( WK(4453), SPIKPF(1)), ( WK(4726), SPKP15(1)) | |
34958 | EQUIVALENCE ( WK(4913), SPKP16(1)) | |
34959 | EQUIVALENCE (NRK(1,1), NRKLIN(1)) | |
34960 | EQUIVALENCE (NRKLIN( 1), NRKPI(1)), (NRKLIN( 165), NRKKC(1)) | |
34961 | EQUIVALENCE (NRKLIN( 297), NRKP(1)), (NRKLIN( 367), NRKN(1)) | |
34962 | EQUIVALENCE (NRKLIN( 483), NRKK0(1)) | |
34963 | EQUIVALENCE (NURE(1,1), NURELN(1)) | |
34964 | * | |
34965 | **** pi- p data * | |
34966 | **** pi+ n data * | |
34967 | DATA PLAPI / 0.D0, .3D0, .5D0, .6D0, .7D0, .8D0, .9D0, .95D0,1.D0, | |
34968 | & 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0, | |
34969 | & 3.D0, 3.5D0, 4.D0, 0.D0, .285D0, .4D0, .45D0, .5D0, .6D0, .7D0, | |
34970 | & .75D0, .8D0, .85D0, .9D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, | |
34971 | & 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0, | |
34972 | & .285D0, .4D0, .45D0, .5D0, .6D0, .7D0, .75D0, .8D0, .85D0, .9D0, | |
34973 | & 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0, | |
34974 | & 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0, .3D0, .5D0, .6D0, .7D0, | |
34975 | & .8D0, .9D0, .95D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, | |
34976 | & 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0 / | |
34977 | DATA PLAKC / | |
34978 | & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0, | |
34979 | & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0, | |
34980 | & 3.51D0, 3.84D0, 4.16D0, 4.49D0, | |
34981 | & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0, | |
34982 | & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0, | |
34983 | & 3.51D0, 3.84D0, 4.16D0, 4.49D0, | |
34984 | & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0, | |
34985 | & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0, | |
34986 | & 3.51D0, 3.84D0, 4.16D0, 4.49D0, | |
34987 | & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0, | |
34988 | & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0, | |
34989 | & 3.51D0, 3.84D0, 4.16D0, 4.49D0/ | |
34990 | DATA PLAK0 / | |
34991 | & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0, | |
34992 | & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0, | |
34993 | & 3.51D0, 3.84D0, 4.16D0, 4.49D0, | |
34994 | & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0, | |
34995 | & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0, | |
34996 | & 3.51D0, 3.84D0, 4.16D0, 4.49D0/ | |
34997 | * pp pn np nn * | |
34998 | DATA PLAP / | |
34999 | & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0, | |
35000 | & 3.43D0, 3.75D0, 4.07D0, 4.43D0, | |
35001 | & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0, | |
35002 | & 3.43D0, 3.75D0, 4.07D0, 4.43D0, | |
35003 | & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0, | |
35004 | & 3.43D0, 3.75D0, 4.07D0, 4.43D0 / | |
35005 | * app apn anp ann * | |
35006 | DATA PLAN / | |
35007 | & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0, | |
35008 | & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0, | |
35009 | & 3.43D0, 3.75D0, 4.07D0, 4.43D0, | |
35010 | & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0, | |
35011 | & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0, | |
35012 | & 3.43D0, 3.75D0, 4.07D0, 4.43D0, | |
35013 | & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0, | |
35014 | & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0, | |
35015 | & 3.43D0, 3.75D0, 4.07D0, 4.43D0 / | |
35016 | DATA SIIN / 296*0.D0 / | |
35017 | DATA UMOPI/ 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0, | |
35018 | & 1.557D0,1.615D0,1.6435D0, | |
35019 | & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0, | |
35020 | & 2.286D0,2.366D0,2.482D0,2.56D0, | |
35021 | & 2.735D0,2.90D0, | |
35022 | & 1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0, | |
35023 | & 1.496D0,1.527D0,1.557D0, | |
35024 | & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0, | |
35025 | & 2.071D0,2.159D0,2.286D0,2.366D0, | |
35026 | & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0, | |
35027 | & 1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0, | |
35028 | & 1.496D0,1.527D0,1.557D0, | |
35029 | & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0, | |
35030 | & 2.071D0,2.159D0,2.286D0,2.366D0, | |
35031 | & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0, | |
35032 | & 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0, | |
35033 | & 1.557D0,1.615D0,1.6435D0, | |
35034 | & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0, | |
35035 | & 2.286D0,2.366D0,2.482D0,2.56D0, | |
35036 | & 2.735D0, 2.90D0/ | |
35037 | DATA UMOKC/ 1.44D0, | |
35038 | & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0, | |
35039 | & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0, | |
35040 | & 3.1D0,1.44D0, | |
35041 | & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0, | |
35042 | & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0, | |
35043 | & 3.1D0,1.44D0, | |
35044 | & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0, | |
35045 | & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0, | |
35046 | & 3.1D0,1.44D0, | |
35047 | & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0, | |
35048 | & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0, | |
35049 | & 3.1D0/ | |
35050 | DATA UMOK0/ 1.44D0, | |
35051 | & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0, | |
35052 | & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0, | |
35053 | & 3.1D0,1.44D0, | |
35054 | & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0, | |
35055 | & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0, | |
35056 | & 3.1D0/ | |
35057 | * pp pn np nn * | |
35058 | DATA UMOP/ | |
35059 | & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0, | |
35060 | & 3.D0,3.1D0,3.2D0, | |
35061 | & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0, | |
35062 | & 3.D0,3.1D0,3.2D0, | |
35063 | & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0, | |
35064 | & 3.D0,3.1D0,3.2D0/ | |
35065 | * app apn anp ann * | |
35066 | DATA UMON / | |
35067 | & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0, | |
35068 | & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0, | |
35069 | & 3.D0,3.1D0,3.2D0, | |
35070 | & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0, | |
35071 | & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0, | |
35072 | & 3.D0,3.1D0,3.2D0, | |
35073 | & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0, | |
35074 | & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0, | |
35075 | & 3.D0,3.1D0,3.2D0/ | |
35076 | **** reaction channel state particles * | |
35077 | DATA NRKPI / 13, 1, 15, 21, 81, 0, 13, 54, 23, 53, 13, 63, 13, 58, | |
35078 | & 23, 57, 13, 65, 1, 32, 53, 31, 54, 32, 53, 33, 53, 35, 63, 32, | |
35079 | & 13, 8, 23, 1, 17, 15, 21, 24, 22, 15, 82, 0, 61, 0, 13, 55, 23, | |
35080 | & 54, 14, 53, 13, 64, 23, 63, 13, 59, 23, 58, 14, 57, 13, 66, 23, | |
35081 | & 65, 1, 31, 8, 32, 1, 33, 1, 35, 54, 31, 55, 32, 54, 33, 53, 34, | |
35082 | & 54, 35, 14, 1, 23, 8, 17, 24, 20, 15, 22, 24, 83, 0, 62, 0, 14, | |
35083 | & 54, 23, 55, 13, 56, 14, 63, 23, 64, 14, 58, 23, 59, 13, 60, 14, | |
35084 | & 65, 23, 66, 8, 31, 1, 34, 8, 33, 8, 35, 55, 31, 54, 34, 55, 33, | |
35085 | & 56, 32, 55, 35, 14, 8, 24, 20, 84, 0, 14, 55, 23, 56, 14, 64, 14, | |
35086 | & 59, 23, 60, 14, 66, 8, 34, 56, 31, 55, 34, 56, 33, 56, 35, 64,34/ | |
35087 | DATA NRKKC/ 15, 1, 89, 0, 24, 53, 15, 54, 1, 36, 1, 40, 1, 44, 36, | |
35088 | & 63, 15, 63, 45, 53, 44, 54, 15, 8, 24, 1, 91, 0, 24, 54, 15, 55, | |
35089 | & 8, 36, 1, 37, 8, 40, 1, 41, 8, 44, 1, 45, 36, 64, 37, 63, 15, 64, | |
35090 | & 24, 63, 45, 54, 44, 55, 16, 1, 25, 8, 17, 23, 21, 14, 20, | |
35091 | & 13, 22, 23, 90, 0, 38, 1, 39, 8, 16, 54, 25, 55, 1, 42, 8, 43, | |
35092 | & 16, 63, 25, 64, 39, 64, 38, 63, 46, 54, 47, 55, 8, 47, 1, 46, 52, | |
35093 | & 0, 51, 0, 16, 8, 17, 14, 20, 23, 22, 14, 92, 0, 8, 38, 16, 55, | |
35094 | & 25, 56, 8, 42, 16, 64, 38, 64, 46, 55, 47, 56, 8, 46, 94, 0 / | |
35095 | * * | |
35096 | * k0 p k0 n ak0 p ak/ n * | |
35097 | * * | |
35098 | DATA NRKK0 / 24, 8, 106, 0, 15, 56, 24, 55, 37, 8, 41, 8, 45, 8, | |
35099 | & 37, 64, 24, 64, 44, 56, 45, 55, 25, 1, 17, 13, 22, 13, 21, 23, | |
35100 | & 107, 0, 39, 1, 25, 54, 16, 53, 43, 1, 25, 63, 39, 63, 47, 54, 46, | |
35101 | & 53, 47, 1, 103, 0, 93, 0/ | |
35102 | * pp pn np nn * | |
35103 | DATA NRKP / 1, 1, 85, 0, 8, 53, 1, 54, 1, 63, 8, 57, 1, 58, 2*54, | |
35104 | & 53, 55, 63, 54, 64, 53, 1, 8, 86, 0, 8, 54, 1, 55, 8, 63, 1, 64, | |
35105 | & 8, 58, 1, 59, 64, 54, 63, 55, 54, 55, 53, 56, 77, 0, 2*8, 95, 0, | |
35106 | & 8, 55, 1, 56, 8, 64, 8, 59, 1, 60, 2*55, 54, 56, 64, 55, 63, 56 / | |
35107 | * app apn anp ann * | |
35108 | DATA NRKN/ 1, 2, 17, 18, 15, 16, 8, 9, 13, 14, 99, 0, 87, 0, 1, | |
35109 | & 68, 8, 69, 2, 54, 9, 55, 102, 0, 2, 63, 9, 64, 1, 75, 8, 76, 53, | |
35110 | & 67, 54, 68, 55, 69, 56, 70, 63, 68, 64, 69, 75, 54, 76, 55, 2, 8, | |
35111 | & 18, 20, 16, 24, 14, 23, 101, 0, 88, 0, 2, 55, 9, 56, 1, 67, 8, | |
35112 | & 68, 2, 64, 8, 75, 2, 59, 8, 72, 68, 55, 67, 54, 69, 56, 1, 9, 18, | |
35113 | & 21, 15, 25, 13, 23, 100, 0, 96, 0, 2, 53, 9, 54, 1, 69, 8, 70, 1, | |
35114 | & 76, 9, 63, 1, 73, 9, 58, 55, 70, 53, 68, 54, 69 / | |
35115 | **** channel cross section * | |
35116 | DATA SPIKP1/ 0.D0, 300.D0, 40.D0, 20.D0, 13.D0,8.5D0,8.D0, 9.5D0, | |
35117 | & 12.D0,14.D0,15.5D0,20.D0,17.D0,13.D0,10.D0,9.D0,8.5D0,8.D0,7.8D0, | |
35118 | & 7.3D0, 6.7D0, 9*0.D0,.23D0,.35D0,.7D0,.52D0,.4D0,.3D0,.2D0,.15D0, | |
35119 | & .13D0, .11D0, .09D0, .07D0, 0.D0, .033D0,.8D0,1.35D0,1.35D0,.5D0, | |
35120 | & 15*0.D0, 3*0.D0,.00D0,0.80D0,2.2D0,3.6D0,4.6D0,4.7D0,3.5D0,2.4D0, | |
35121 | &1.8D0,1.4D0,.75D0,.47D0,.25D0,.13D0,.08D0,6*0.D0,0.D0,1.2D0,3.3D0, | |
35122 | & 5.4D0,6.9D0,7.3D0,5.3D0,3.6D0,2.7D0,2.2D0,1.1D0,.73D0,.4D0,.22D0, | |
35123 | & .12D0,9*0.D0,.0D0,0.D0,2.0D0,4.4D0,6.8D0,9.9D0,7.9D0,6.0D0,3.8D0, | |
35124 | &2.5D0,2.D0,1.4D0,1.D0,.6D0,.35D0,10*0.D0,.25D0,.55D0,.75D0,1.25D0, | |
35125 | & 1.9D0,2.D0,1.8D0,1.5D0,1.25D0,1.D0,.8D0,6*0.D0,4*0.D0,.4D0,.85D0, | |
35126 | & 1.1D0, 1.85D0, 2.8D0, 3.D0,2.7D0,2.2D0,1.85D0,1.5D0,1.2D0,6*0.D0, | |
35127 | & 6*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0, 5.6D0, | |
35128 | & 5.2D0, 6*0.D0, 2*0.D0, .0D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0, | |
35129 | & 2.75D0, 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 6*0.D0, 3*0.D0, | |
35130 | & .0D0, .45D0, 1.4D0, 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0, | |
35131 | & 8*0.D0, 5*0.D0, .0D0, .0D0, .6D0, .8D0, .95D0, .8D0, .7D0, .6D0, | |
35132 | & .5D0, .4D0, 6*0.D0, 5*0.D0, .0D0, .00D0, .85D0, 1.2D0, 1.4D0, | |
35133 | & 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 6*0.D0, 5*0.D0, .0D0, .00D0, | |
35134 | & 1.D0, 1.5D0, 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 6*0.D0, | |
35135 | & 10*0.D0, .5D0, 2.0D0, 3.3D0, 5.4D0, 7.D0 / | |
35136 | **** pi+ n data * | |
35137 | DATA SPIKPU/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 20.D0, | |
35138 | & 20.D0, 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0, | |
35139 | & 10.D0, 10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0, | |
35140 | & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0, | |
35141 | & 4.2D0, 7.5D0, 3.4D0, 2.5D0, 2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0, | |
35142 | & .6D0, .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0, | |
35143 | & .48D0, .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0, | |
35144 | & .065D0, .05D0, .04D0, 12*0.D0, .2D0, .25D0, .25D0, .2D0, .1D0, | |
35145 | & .08D0, .06D0, .045D0, .03D0, .02D0, .01D0, .005D0, .003D0, | |
35146 | & 12*0.D0, .3D0, .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0, | |
35147 | & .09D0, .08D0, .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0, | |
35148 | & 3.1D0, 4.5D0, 2.D0, 18*0.D0, 3*.0D0, 0.D0, 0.D0, 4.0D0, 11.D0, | |
35149 | & 11.4D0, 10.3D0, 7.5D0, 6.8D0, 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0, | |
35150 | & .35D0, 13*0.D0, .1D0, .34D0, .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0, | |
35151 | & 2.3D0, 1.6D0, .95D0, .45D0, .28D0, .15D0, 10*0.D0, 2*0.D0, .17D0, | |
35152 | & .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0, 6.2D0, 4.4D0, 3.D0, 1.8D0, | |
35153 | & .9D0, .53D0, .28D0, 10*0.D0, 2*0.D0, .25D0, .82D0, | |
35154 | & 1.3D0, 1.9D0, 2.8D0, 5.5D0 , 8.D0, 5.7D0, 3.9D0, 2.35D0, 1.15D0, | |
35155 | & .69D0, .37D0, 10*0.D0, 7*0.D0, .0D0, .34D0, 1.5D0, 3.47D0, | |
35156 | & 5.87D0, 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/ | |
35157 | * | |
35158 | DATA SPIKPV/ 7*0.D0, .00D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0, | |
35159 | & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 6*0.D0, 10*0.D0, .2D0, | |
35160 | & .6D0, .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0, | |
35161 | & 1.D0, .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0, | |
35162 | & 3.5D0, 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0, | |
35163 | & .31D0, .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0, | |
35164 | & .23D0, 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0, | |
35165 | & 5.D0, 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0, | |
35166 | & 2.5D0, 3*0.D0, 3*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0, | |
35167 | & 1.5D0, 1.1D0, .8D0, .7D0, .55D0, .3D0, 10*0.D0, 9*0.D0, .1D0, | |
35168 | & .4D0, 1.D0, 1.4D0, 2.2D0, 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0, | |
35169 | & .8D0, .6D0, .4D0, 12*0.D0, .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0, | |
35170 | & 3.8D0, 3.3D0, 2.45D0, 2.05D0, 1.65D0, 1.2D0, .9D0, .6D0, 3*0.D0, | |
35171 | & 9*0.D0, .10D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0, | |
35172 | & 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, 13*0.D0, .2D0, .5D0, .7D0, | |
35173 | & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, | |
35174 | & 17*0.D0, .2D0, .5D0, .85D0, 2.D0, 2.15D0, 2.05D0, 1.75D0, 1.D0, | |
35175 | & 17*0.D0, .13D0, .33D0, .57D0, 1.33D0, 1.43D0, 1.36D0, 1.17D0, | |
35176 | & .67D0, 17*0.D0, .07D0, .17D0, .28D0, .67D0, .72D0, .69D0, .58D0, | |
35177 | & .33D0,17*0.D0,.4D0, .7D0, 1.D0, 1.6D0, 1.8D0, 2.3D0,1.9D0,1.7D0 / | |
35178 | **** pi- p data * | |
35179 | DATA SPIKPW/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 2*20.D0, | |
35180 | & 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0, | |
35181 | & 2*10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0, | |
35182 | & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0, | |
35183 | & 4.2D0, 7.5D0, 3.4D0, 2*2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0, .6D0, | |
35184 | & .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0, .48D0, | |
35185 | & .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0, .065D0, | |
35186 | & .05D0, .04D0, 12*0.D0, .2D0, 2*.25D0, .2D0, .1D0, .08D0, .06D0, | |
35187 | & .045D0, .03D0, .02D0, .01D0, .005D0, .003D0, 12*0.D0, .3D0, | |
35188 | & .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0, .09D0, .08D0, | |
35189 | & .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0, 3.1D0, 4.5D0, | |
35190 | & 2.D0, 23*0.D0, 4.0D0, 11.D0, 11.4D0, 10.3D0, 7.5D0, 6.8D0, | |
35191 | & 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0, .35D0, 13*0.D0, .1D0, .34D0, | |
35192 | & .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0, 2.3D0, 1.6D0, .95D0, .45D0, | |
35193 | & .28D0, .15D0, 12*0.D0, .17D0, .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0, | |
35194 | & 6.2D0, 4.4D0, 3.D0, 1.8D0, .9D0, .53D0, .28D0, 12*0.D0, .25D0, | |
35195 | & .82D0, 1.3D0, 1.9D0, 2.8D0, 5.5D0, 8.D0, 5.7D0, 3.9D0, 2.35D0, | |
35196 | & 1.15D0, .69D0, .37D0, 18*0.D0, .34D0, 1.5D0, 3.47D0, 5.87D0, | |
35197 | & 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/ | |
35198 | * | |
35199 | DATA SPIKPX/ 8*0.D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0, | |
35200 | & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 16*0.D0, .2D0, .6D0, | |
35201 | & .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0, 1.D0, | |
35202 | & .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0, 3.5D0, | |
35203 | & 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0, .31D0, | |
35204 | & .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0, .23D0, | |
35205 | & 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0, 5.D0, | |
35206 | & 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0, 2.5D0, | |
35207 | & 6*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0, 1.5D0, 1.1D0, | |
35208 | & .8D0, .7D0, .55D0, .3D0, 19*0.D0, .1D0, .4D0, 1.D0, 1.4D0, 2.2D0, | |
35209 | & 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0, .8D0, .6D0, .4D0, 12*0.D0, | |
35210 | & .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0, 3.8D0, 3.3D0, 2.45D0, 2.05D0, | |
35211 | & 1.65D0, 1.2D0, .9D0, .6D0, 12*0.D0, .10D0, .2D0, .5D0, .7D0, | |
35212 | & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, | |
35213 | & 13*0.D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, | |
35214 | & 1.35D0, 1.15D0, .95D0, .7D0, 17*0.D0, .2D0, .5D0, .85D0, 2.D0, | |
35215 | & 2.15D0, 2.05D0, 1.75D0, 1.D0, 17*0.D0, .13D0, .33D0, .57D0, | |
35216 | & 1.33D0, 1.43D0, 1.36D0, 1.17D0, .67D0, 17*0.D0, .07D0, .17D0, | |
35217 | & .28D0, .67D0, .72D0, .69D0, .58D0, .33D0, 17*0.D0, .4D0, .7D0, | |
35218 | & 1.D0, 1.6D0, 1.8D0, 2.3D0, 1.9D0, 1.7D0 / | |
35219 | **** pi- n data * | |
35220 | DATA SPIKP4 / 0.D0, 300.D0, 40.D0, 20.D0, 13.D0, 8.5D0, 8.D0, | |
35221 | & 9.5D0, 12.D0, 14.D0, 15.5D0, 20.D0, 17.D0, 13.D0, 10.D0, 9.D0, | |
35222 | & 8.5D0, 8.D0, 7.8D0, 7.3D0, 6.7D0, 9*0.D0, .23D0, .35D0, .7D0, | |
35223 | & .52D0, .4D0, .3D0, .2D0, .15D0, .13D0, .11D0, .09D0, .07D0, 0.D0, | |
35224 | & .033D0, .8D0, 2*1.35D0, .5D0, 19*0.D0, 0.8D0, 2.2D0, 3.6D0, | |
35225 | & 4.6D0, 4.7D0, 3.5D0, 2.4D0, 1.8D0, 1.4D0, .75D0, .47D0, .25D0, | |
35226 | & .13D0, .08D0, 7*0.D0, 1.2D0, 3.3D0, 5.4D0, 6.9D0, 7.3D0, 5.3D0, | |
35227 | & 3.6D0, 2.7D0, 2.2D0, 1.1D0, .73D0, .4D0, .22D0, .12D0, 11*0.D0, | |
35228 | & 2.0D0, 4.4D0, 6.8D0, 9.9D0, 7.9D0, 6.0D0, 3.8D0, 2.5D0, 2.D0, | |
35229 | & 1.4D0, 1.D0, .6D0, .35D0, 10*0.D0, .25D0, .55D0, .75D0, 1.25D0, | |
35230 | & 1.9D0, 2.D0, 1.8D0, 1.5D0, 1.25D0, 1.D0, .8D0, 10*0.D0, .4D0, | |
35231 | & .85D0, 1.1D0, 1.85D0, 2.8D0, 3.D0, 2.7D0, 2.2D0, 1.85D0, 1.5D0, | |
35232 | & 1.2D0, 12*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0, | |
35233 | & 5.6D0, 5.2D0, 9*0.D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0, 2.75D0, | |
35234 | & 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 10*0.D0, .45D0, 1.4D0, | |
35235 | & 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0, 15*0.D0, .6D0, | |
35236 | & .8D0, .95D0, .8D0, .7D0, .6D0, .5D0, .4D0, 13*0.D0, .85D0, 1.2D0, | |
35237 | & 1.4D0, 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 13*0.D0, 1.D0, 1.5D0, | |
35238 | & 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 16*0.D0, .5D0, 2.0D0, | |
35239 | & 3.3D0, 5.4D0, 7.D0 / | |
35240 | **** k+ p data * | |
35241 | DATA SPIKP5/ 0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0, | |
35242 | & 7.D0, 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0, | |
35243 | & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 13*0.D0, 0.9D0, | |
35244 | & 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0, | |
35245 | & .45D0, .21D0, .2D0, 3*0.D0, .9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, | |
35246 | & 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0, | |
35247 | & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0, 1.4D0, | |
35248 | & 1.2D0, 1.05D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0, 2*1.D0, .9D0, | |
35249 | & .7D0, .4D0, .3D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.2D0, | |
35250 | & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, | |
35251 | & 1.71D0, 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0, | |
35252 | & 3.5D0, 2.85D0, 2.35D0, 2.01D0, 1.8D0, 12*0.D0, .1D0, .8D0,2.05D0, | |
35253 | & 3.31D0, 3.5D0, 12*0.D0, .034D0, .2D0, .75D0, 1.04D0, 1.24D0 / | |
35254 | **** k+ n data * | |
35255 | DATA SPIKP6/ 0.D0, 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0, | |
35256 | & 1.5D0, 1.2D0, 1.D0, .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0, | |
35257 | & 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0, 1.5D0, 1.2D0, 1.D0, | |
35258 | & .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0, .5D0, 1.3D0, 2.8D0, | |
35259 | & 2.3D0, 1.6D0, .9D0, 13*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, | |
35260 | & 2.D0, 1.7D0, 1.5D0,1.2D0,.9D0,.6D0,.45D0,.21D0,.2D0,3*0.D0,0.9D0, | |
35261 | & 2.5D0, 3.D0, 2.5D0, 2.3D0,2.D0,1.7D0,1.5D0,1.2D0,.9D0,.6D0,.45D0, | |
35262 | & .21D0, .2D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.D0,1.8D0,1.7D0,1.4D0, | |
35263 | & 1.2D0,1.15D0,.9D0,.66D0,.5D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.1D0, | |
35264 | & 1.8D0,1.7D0,1.4D0,1.2D0, 1.15D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0, | |
35265 | & 2*1.D0, .9D0, .7D0, .4D0, .35D0, .2D0, 9*0.D0, .3D0, 2*1.D0,.9D0, | |
35266 | & .7D0, .4D0, .35D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.4D0,3.5D0,4.25D0, | |
35267 | & 4.55D0, 4.85D0, 4.9D0, 9*0.D0, .1D0, 1.D0, 2.4D0, 3.5D0, 4.25D0, | |
35268 | & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, | |
35269 | & 1.71D0, 1.6D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0, | |
35270 | & 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0,4.4D0,4.D0,3.5D0,2.85D0, | |
35271 | & 2.35D0, 2.01D0, 1.8D0, 6*0.D0, 1.4D0,3.8D0,5.D0,4.7D0,4.4D0,4.D0, | |
35272 | & 3.5D0,2.85D0,2.35D0,2.01D0,1.8D0,12*0.D0,.1D0,.8D0,2.05D0,3.31D0, | |
35273 | & 3.5D0, 12*0.D0, .034D0,.2D0,.75D0,1.04D0,1.24D0 / | |
35274 | **** k- p data * | |
35275 | DATA SKMPEL/ 0.D0, 35.D0, 22.D0, 25.D0, 17.D0, 9.D0, 9.5D0, 8.D0, | |
35276 | & 7.D0, 6.5D0, 6.1D0, 5.D0, 4.8D0, 4.6D0, 4.45D0, 4.3D0, 4.2D0, | |
35277 | & 0.D0, 8.D0, 3.5D0, 8.D0, 3.D0, 1.9D0, 1.7D0, 1.D0, .9D0, .8D0, | |
35278 | & .75D0, .5D0, .42D0, .38D0, .34D0, .25D0, .2D0, | |
35279 | & 0.D0, 3.D0, 3.2D0, 3.5D0, 1.5D0, 1.4D0, 1.1D0, .6D0, .5D0, | |
35280 | & .35D0, .28D0, .25D0, .18D0, .12D0, .1D0, .08D0, .04D0, | |
35281 | & 0.D0, 8.5D0, 2.4D0, 1.7D0, 1.3D0, 1.3D0, 1.1D0, .5D0, | |
35282 | & .4D0, .4D0, .35D0, .3D0, .28D0, .2D0, .16D0, .13D0, .11D0, | |
35283 | & 0.D0, 7.D0, 4.8D0, 1.4D0, 1.9D0, .9D0, .4D0, .2D0, .13D0, | |
35284 | & .1D0, .08D0, .06D0, .04D0, .02D0, .015D0, .01D0, .01D0, | |
35285 | & 0.D0, 5.5D0, 1.D0, .8D0, .75D0, .32D0, .2D0, .1D0, .09D0, | |
35286 | & .08D0, .065D0, .05D0, .04D0, .022D0, .017D0, 2*.01D0/ | |
35287 | DATA SPIKP7 / 0.D0, .56D0, 1.46D0, 3.16D0, 2.01D0, 1.28D0, .74D0, | |
35288 | & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, | |
35289 | & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 4*0.D0, | |
35290 | & 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0, 1.57D0, | |
35291 | & 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0, 3.03D0, | |
35292 | & 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, | |
35293 | & .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0, 2.8D0, | |
35294 | & 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, | |
35295 | & .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, | |
35296 | & .45D0, .39D0, .22D0, .07D0, 0.D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, | |
35297 | & 1.01D0, .78D0, .45D0, .39D0, .22D0, .07D0, 0.D0, 6*0.D0, 1.71D0, | |
35298 | & 4.26D0, 5.6D0, 5.57D0, 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0, | |
35299 | & 2.25D0, 2.D0, 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0, | |
35300 | & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0, .22D0, | |
35301 | & .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 10*0.D0, .22D0, .8D0, | |
35302 | & .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0, .3D0, .7D0,1.D0, | |
35303 | & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0, 1.72D0, 2.69D0, | |
35304 | & 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 9*0.D0, .11D0, 1.72D0, | |
35305 | & 2.69D0, 3.92D0, 4.76D0, 5.1D0, 5.44D0, 5.3D0, 5*0.D0,9.2D0,4.7D0, | |
35306 | & 1.9D0, 10*0.D0, 2.5D0, 15.D0, 21.5D0, 15.3D0, 3.D0, 1.5D0, | |
35307 | & 10*0.D0/ | |
35308 | ***** k- n data * | |
35309 | DATA SKMNEL/0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0, | |
35310 | & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0, | |
35311 | & 0.D0, 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0, | |
35312 | & 1.9D0, .9D0, .5D0, .3D0, .24D0, .2D0, .18D0, .1D0, .09D0, | |
35313 | & 0.D0, 1.8D0, 2.D0, 1.1D0, .9D0, .5D0, .5D0, .4D0, .4D0, | |
35314 | & .2D0, .1D0, .06D0, .05D0, .04D0, .03D0, .02D0, .02D0, | |
35315 | & 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0, .7D0, .65D0, | |
35316 | & .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0, .03D0/ | |
35317 | DATA SPIKP8/0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0, | |
35318 | & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, | |
35319 | & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, | |
35320 | & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, | |
35321 | & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0, | |
35322 | & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, | |
35323 | & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0, | |
35324 | & 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, .45D0, | |
35325 | & .39D0, .22D0, .07D0, 0.D0, | |
35326 | & 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0, | |
35327 | & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, | |
35328 | & 10*0.D0, .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, | |
35329 | & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, | |
35330 | & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, | |
35331 | & 9*0.D0, .11D0, 1.72D0, 2.69D0, 3.92D0, 4.76D0, | |
35332 | & 5.10D0, 5.44D0, 5.3D0, | |
35333 | & 4*0.D0, 0.00D0, 9.2D0, 4.7D0, 1.9D0, 9*0.D0/ | |
35334 | ***** p p data * | |
35335 | DATA SPIKP9/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0, | |
35336 | & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0, | |
35337 | & 0.D0, 3.6D0, 1.7D0, 10*0.D0, | |
35338 | & .0D0, 0.D0, 8.7D0, 17.7D0, 18.8D0, 15.9D0, | |
35339 | & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0, | |
35340 | & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0, | |
35341 | & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0, | |
35342 | & 5*0.D0, 4.6D0, 10.2D0, 15.1D0, | |
35343 | & 16.9D0, 16.5D0, 11.D0, 5.5D0, 3.5D0, | |
35344 | & 10*0.D0, 4.3D0, 7.6D0, 9.D0, | |
35345 | & 10*0.D0, 1.7D0, 2.6D0, 3.D0, | |
35346 | & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0, | |
35347 | & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0, | |
35348 | & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0, | |
35349 | & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/ | |
35350 | ***** p n data * | |
35351 | DATA SPIKP0/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0, | |
35352 | & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0, | |
35353 | & 0.D0, 1.8D0, .2D0, 12*0.D0, | |
35354 | & 3.2D0, 6.05D0, 9.9D0, 5.1D0, | |
35355 | & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0, | |
35356 | & 2*.0D0, 3.2D0, 6.05D0, 9.9D0, 5.1D0, | |
35357 | & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0, | |
35358 | & 5*0.D0, 4.6D0, 10.2D0, 15.1D0, | |
35359 | & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0, | |
35360 | & 5*0.D0, 4.6D0, 10.2D0, 15.1D0, | |
35361 | & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0, | |
35362 | & 10*0.D0, .7D0, 5.1D0, 8.D0, | |
35363 | & 10*0.D0, .7D0, 5.1D0, 8.D0, | |
35364 | & 10*.0D0, .3D0, 2.8D0, 4.7D0, | |
35365 | & 10*.0D0, .3D0, 2.8D0, 4.7D0, | |
35366 | & 7*0.D0, 1.2D0, 2.5D0, 3.5D0, 6.D0, 5.3D0, 2.9D0, | |
35367 | & 7*0.D0, 1.7D0, 3.6D0, 5.4D0, 9.D0, 7.6D0, 4.2D0, | |
35368 | & 5*0.D0, 7.7D0, 6.1D0, 2.9D0, 5*0.D0/ | |
35369 | * nn - data * | |
35370 | * * | |
35371 | DATA SPKPV/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0, | |
35372 | & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0, | |
35373 | & 0.D0, 3.6D0, 1.7D0, 12*0.D0, | |
35374 | & 8.7D0, 17.7D0, 18.8D0, 15.9D0, | |
35375 | & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0, | |
35376 | & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0, | |
35377 | & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0, | |
35378 | & 5*0.D0, 4.6D0, 10.2D0, 15.1D0, 16.9D0, 16.5D0, | |
35379 | & 11.D0, 5.5D0, 3.5D0, | |
35380 | & 10*0.D0, 4.3D0, 7.6D0, 9.D0, | |
35381 | & 10*0.D0, 1.7D0, 2.6D0, 3.D0, | |
35382 | & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0, | |
35383 | & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0, | |
35384 | & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0, | |
35385 | & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/ | |
35386 | **************** ap - p - data * | |
35387 | DATA SAPPEL/ 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, | |
35388 | & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0, | |
35389 | & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0, | |
35390 | & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0, | |
35391 | & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0, | |
35392 | & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0, | |
35393 | & 0.D0, 55.D0, 50.D0, 25.D0, 15.D0, 15.D0, 14.D0, 12.D0, | |
35394 | & 10.D0, 7.D0, 6.D0, 4.D0, 3.3D0, 2.8D0, 2.4D0, 2.D0, 1.8D0, | |
35395 | & 1.55D0, 1.3D0, .95D0, .75D0, | |
35396 | & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, | |
35397 | & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0, | |
35398 | & .01D0, .008D0, .006D0, .005D0/ | |
35399 | DATA SPIKPE/0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0, | |
35400 | & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0, | |
35401 | & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, | |
35402 | & 9*0.D0, 2.D0, 2.5D0, .2D0, 19*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0, | |
35403 | & 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0, .3D0, 1.4D0, | |
35404 | & 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0, | |
35405 | & .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, | |
35406 | & .3D0, 10*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, | |
35407 | & .6D0, .5D0, .4D0, .3D0, 9*0.D0, .6D0, 2.5D0, 5.D0, 5.2D0, 5.1D0, | |
35408 | & 5.4D0, 5.8D0, 2.8D0, 2.1D0, 1.8D0, 1.6D0, 1.2D0, 13*0.D0, 1.3D0, | |
35409 | & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0, | |
35410 | & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0, | |
35411 | & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0, | |
35412 | & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 14*0.D0, .2D0, | |
35413 | & .5D0, 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, | |
35414 | & 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0, | |
35415 | & 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0, 1.6D0, | |
35416 | & 1.4D0, 1.1D0, .9D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0, | |
35417 | & .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, | |
35418 | & 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0 / | |
35419 | **************** ap - n - data * | |
35420 | DATA SAPNEL/ | |
35421 | & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, | |
35422 | & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0, | |
35423 | & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0, | |
35424 | & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, | |
35425 | & .85D0, 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, | |
35426 | & .14D0, .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0, | |
35427 | & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, | |
35428 | & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0, | |
35429 | & .01D0, .008D0, .006D0, .005D0 / | |
35430 | DATA SPIKPZ/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0, | |
35431 | & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0, | |
35432 | & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0, | |
35433 | & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, | |
35434 | & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, | |
35435 | & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, | |
35436 | & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, | |
35437 | & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, | |
35438 | & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0, | |
35439 | & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0, | |
35440 | & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0, | |
35441 | & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, | |
35442 | & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0, | |
35443 | & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 / | |
35444 | * * | |
35445 | * * | |
35446 | **************** an - p - data * | |
35447 | * * | |
35448 | DATA SANPEL/ | |
35449 | & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, 50.D0, | |
35450 | & 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0, | |
35451 | & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0, .05D0, | |
35452 | & .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0, | |
35453 | & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0, | |
35454 | & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0, | |
35455 | & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, .25D0, | |
35456 | & .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0, | |
35457 | & .01D0, .008D0, .006D0, .005D0 / | |
35458 | DATA SPIKPF/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0, | |
35459 | & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0, | |
35460 | & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0, | |
35461 | & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, | |
35462 | & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, | |
35463 | & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, | |
35464 | & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, | |
35465 | & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, | |
35466 | & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0, | |
35467 | & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0, | |
35468 | & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0, | |
35469 | & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, | |
35470 | & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0, | |
35471 | & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 / | |
35472 | **** ko - n - data * | |
35473 | DATA SPKP15/0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0, 7.D0, | |
35474 | & 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0, | |
35475 | & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 10*0.D0, | |
35476 | & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, | |
35477 | & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0, | |
35478 | & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, | |
35479 | & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0, | |
35480 | & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0, | |
35481 | & 1.4D0, 1.2D0, 1.05D0, .9D0, .66D0, .5D0, | |
35482 | & 7*0.D0, .3D0, 1.D0, 1.D0, .9D0, .7D0, .4D0, .30D0, .2D0, | |
35483 | & 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.20D0, 4.55D0, | |
35484 | & 4.85D0, 4.9D0, | |
35485 | & 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0, 1.6D0, | |
35486 | & 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0, 3.5D0, | |
35487 | & 2.85D0, 2.35D0, 2.01D0, 1.8D0, | |
35488 | & 12*0.D0, .1D0, .8D0, 2.05D0, 3.31D0, 3.5D0, | |
35489 | & 12*0.D0, .034D0, .20D0, .75D0, 1.04D0, 1.24D0 / | |
35490 | **** ako - p - data * | |
35491 | DATA SPKP16/ 0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0, | |
35492 | & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0, 0.D0, | |
35493 | & 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0, 1.9D0, .9D0, .5D0, | |
35494 | & .3D0, .24D0, .2D0, .18D0, .1D0, .09D0, 0.D0, 1.8D0, 2.D0, 1.1D0, | |
35495 | & .9D0, .5D0, .5D0, .4D0, .4D0, .2D0, .1D0, .06D0, .05D0, .04D0, | |
35496 | & .03D0, .02D0, .02D0, 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0, | |
35497 | & .7D0, .65D0, .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0, | |
35498 | & .03D0, 0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0, | |
35499 | & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0, | |
35500 | & 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0, | |
35501 | & 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, | |
35502 | & 1.01D0, .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0, | |
35503 | & 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, | |
35504 | & .5D0, .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, | |
35505 | & .45D0, .39D0, .22D0, .07D0, 7*0.D0, 1.71D0, 4.26D0, 5.6D0,5.57D0, | |
35506 | & 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0, | |
35507 | & .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0, | |
35508 | & .3D0, .7D0, 1.D0, 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0, | |
35509 | & 1.72D0, 2.69D0, 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 5*0.D0, | |
35510 | & 9.2D0, 4.7D0, 1.9D0, 9*0.D0, .0D0,2.5D0,15.D0, | |
35511 | & 21.5D0, 15.3D0, 3.D0, 1.5D0, 10*0.D0 / | |
35512 | DATA NURELN/9, 12, 5*0, 10, 14, 3*0, 1, 3, 5, 7, 6*0, 2, 6, 16, | |
35513 | & 5*0, 10, 13, 5*0, 11, 12, 3*0, 2, 4, 6, 8, 6*0, 3, 15, 7, 5*0 / | |
35514 | *= end*block.blkdt3 * | |
35515 | END | |
35516 | ||
35517 | *$ CREATE DT_QEL_POL.FOR | |
35518 | *COPY DT_QEL_POL | |
35519 | * | |
35520 | *===qel_pol============================================================* | |
35521 | * | |
35522 | SUBROUTINE DT_QEL_POL(ENU,LTYP,P21,P22,P23,P24,P25) | |
35523 | ||
35524 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
35525 | SAVE | |
35526 | ||
35527 | CALL DT_MASS_INI | |
35528 | CALL DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25) | |
35529 | ||
35530 | RETURN | |
35531 | END | |
35532 | ||
35533 | *$ CREATE DT_GEN_QEL.FOR | |
35534 | *COPY DT_GEN_QEL | |
35535 | C================================================================== | |
35536 | C Generation of a Quasi-Elastic neutrino scattering | |
35537 | C================================================================== | |
35538 | * | |
35539 | *===gen_qel============================================================* | |
35540 | * | |
35541 | SUBROUTINE DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25) | |
35542 | ||
35543 | C...Generate a quasi-elastic neutrino/antineutrino | |
35544 | C. Interaction on a nuclear target | |
35545 | C. INPUT : LTYP = neutrino type (1,...,6) | |
35546 | C. ENU (GeV) = neutrino energy | |
35547 | C---------------------------------------------------- | |
35548 | ||
35549 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
35550 | SAVE | |
35551 | ||
35552 | PARAMETER ( LINP = 10 , | |
35553 | & LOUT = 6 , | |
35554 | & LDAT = 9 ) | |
35555 | PARAMETER (MAXLND=4000) | |
35556 | COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5) | |
35557 | * nuclear potential | |
35558 | LOGICAL LFERMI | |
35559 | COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD, | |
35560 | & EBINDP(2),EBINDN(2),EPOT(2,210), | |
35561 | & ETACOU(2),ICOUL,LFERMI | |
35562 | * steering flags for qel neutrino scattering modules | |
35563 | COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC | |
35564 | **sr - removed (not needed) | |
35565 | C COMMON /CBAD/ LBAD, NBAD | |
35566 | C COMMON /CNUC/ XMN,XMN2,PFERMI,EFERMI,EBIND,EB2,C0 | |
35567 | ** | |
35568 | ||
35569 | DIMENSION PI(3),PO(3) | |
35570 | CJR+ | |
35571 | DATA ININU/0/ | |
35572 | CJR- | |
35573 | C REAL*8 DBETA(3) | |
35574 | C REAL*8 MN(2), ML0(6), ML, ML2, MI, MI2, MF, MF2 | |
35575 | DIMENSION DBETA(3),DBETB(3),AMN(2),AML0(6) | |
35576 | DATA AMN /0.93827231D0, 0.93956563D0/ | |
35577 | DATA AML0 /2*0.51100D-03,2*0.105659D0, 2*1.777D0/ | |
35578 | DATA INIPRI/0/ | |
35579 | ||
35580 | C DATA PFERMI/0.22D0/ | |
35581 | CGB+...Binding Energy | |
35582 | DATA EBIND/0.008D0/ | |
35583 | CGB-... | |
35584 | ||
35585 | ININU=ININU+1 | |
35586 | IF(ININU.EQ.1)NDSIG=0 | |
35587 | LBAD = 0 | |
35588 | enu0=enu | |
35589 | c write(*,*) enu0 | |
35590 | C...Lepton mass | |
35591 | AML = AML0(LTYP) ! massa leptoni | |
35592 | AML2 = AML**2 ! massa leptoni **2 | |
35593 | C...Particle labels (LUND) | |
35594 | N = 5 | |
35595 | K(1,1) = 21 | |
35596 | K(2,1) = 21 | |
35597 | K(3,1) = 21 | |
35598 | K(3,3) = 1 | |
35599 | K(4,1) = 1 | |
35600 | K(4,3) = 1 | |
35601 | K(5,1) = 1 | |
35602 | K(5,3) = 2 | |
35603 | K0 = (LTYP-1)/2 ! 2 | |
35604 | K1 = LTYP/2 ! 2 | |
35605 | KA = 12 + 2*K0 ! 16 | |
35606 | IS = -1 + 2*LTYP - 4*K1 ! -1 +10 -8 = 1 | |
35607 | K(1,2) = IS*KA | |
35608 | K(4,2) = IS*(KA-1) | |
35609 | K(3,2) = IS*24 | |
35610 | LNU = 2 - LTYP + 2*K1 ! 2 - 5 + 2 = - 1 | |
35611 | IF (LNU .EQ. 2) THEN | |
35612 | K(2,2) = 2212 | |
35613 | K(5,2) = 2112 | |
35614 | AMI = AMN(1) | |
35615 | AMF = AMN(2) | |
35616 | CJR+ | |
35617 | PFERMI=PFERMN(2) | |
35618 | CJR- | |
35619 | ELSE | |
35620 | K(2,2) = 2112 | |
35621 | K(5,2) = 2212 | |
35622 | AMI = AMN(2) | |
35623 | AMF = AMN(1) | |
35624 | CJR+ | |
35625 | PFERMI=PFERMP(2) | |
35626 | CJR- | |
35627 | ENDIF | |
35628 | AMI2 = AMI**2 | |
35629 | AMF2 = AMF**2 | |
35630 | ||
35631 | DO IGB=1,5 | |
35632 | P(3,IGB) = 0. | |
35633 | P(4,IGB) = 0. | |
35634 | P(5,IGB) = 0. | |
35635 | END DO | |
35636 | ||
35637 | NTRY = 0 | |
35638 | CGB+... | |
35639 | EFMAX = SQRT(PFERMI**2 + AMI2) -AMI ! max. Fermi Energy | |
35640 | ENWELL = EFMAX + EBIND ! depth of nuclear potential well | |
35641 | CGB-... | |
35642 | ||
35643 | 100 CONTINUE | |
35644 | ||
35645 | C...4-momentum initial lepton | |
35646 | P(1,5) = 0. ! massa | |
35647 | P(1,4) = ENU0 ! energia | |
35648 | P(1,1) = 0. ! px | |
35649 | P(1,2) = 0. ! py | |
35650 | P(1,3) = ENU0 ! pz | |
35651 | ||
35652 | C PF = PFERMI*PYR(0)**(1./3.) | |
35653 | c write(23,*) PYR(0) | |
35654 | c write(*,*) 'Pfermi=',PF | |
35655 | c PF = 0. | |
35656 | NTRY=NTRY+1 | |
35657 | C IF(ntry.GT.2) WRITE(*,*) ntry,enu0,k2 | |
35658 | IF (NTRY .GT. 500) THEN | |
35659 | LBAD = 1 | |
35660 | WRITE (LOUT,1001) NBAD, ENU | |
35661 | RETURN | |
35662 | ENDIF | |
35663 | C CT = -1. + 2.*PYR(0) | |
35664 | c CT = -1. | |
35665 | C ST = SQRT(1.-CT*CT) | |
35666 | C F = 2.*3.1415926*PYR(0) | |
35667 | c F = 0. | |
35668 | ||
35669 | C P(2,4) = SQRT(PF*PF + MI2) - EBIND ! energia | |
35670 | C P(2,1) = PF*ST*COS(F) ! px | |
35671 | C P(2,2) = PF*ST*SIN(F) ! py | |
35672 | C P(2,3) = PF*CT ! pz | |
35673 | C P(2,5) = SQRT(P(2,4)**2-PF*PF) ! massa | |
35674 | P(2,1) = P21 | |
35675 | P(2,2) = P22 | |
35676 | P(2,3) = P23 | |
35677 | P(2,4) = P24 | |
35678 | P(2,5) = P25 | |
35679 | beta1=-p(2,1)/p(2,4) | |
35680 | beta2=-p(2,2)/p(2,4) | |
35681 | beta3=-p(2,3)/p(2,4) | |
35682 | N=2 | |
35683 | C WRITE(6,*)' before transforming into target rest frame' | |
35684 | CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3) | |
35685 | C print*,' nucl. rest fram ( fermi incl.) prima della rotazione' | |
35686 | N=5 | |
35687 | ||
35688 | phi11=atan(p(1,2)/p(1,3)) | |
35689 | pi(1)=p(1,1) | |
35690 | pi(2)=p(1,2) | |
35691 | pi(3)=p(1,3) | |
35692 | ||
35693 | CALL DT_TESTROT(PI,Po,PHI11,1) | |
35694 | DO ll=1,3 | |
35695 | IF(abs(po(ll)).LT.1.D-07) po(ll)=0. | |
35696 | END DO | |
35697 | c WRITE(*,*) po | |
35698 | p(1,1)=po(1) | |
35699 | p(1,2)=po(2) | |
35700 | p(1,3)=po(3) | |
35701 | phi12=atan(p(1,1)/p(1,3)) | |
35702 | ||
35703 | pi(1)=p(1,1) | |
35704 | pi(2)=p(1,2) | |
35705 | pi(3)=p(1,3) | |
35706 | CALL DT_TESTROT(Pi,Po,PHI12,2) | |
35707 | DO ll=1,3 | |
35708 | IF(abs(po(ll)).LT.1.D-07) po(ll)=0. | |
35709 | END DO | |
35710 | c WRITE(*,*) po | |
35711 | p(1,1)=po(1) | |
35712 | p(1,2)=po(2) | |
35713 | p(1,3)=po(3) | |
35714 | ||
35715 | enu=p(1,4) | |
35716 | ||
35717 | C...Kinematical limits in Q**2 | |
35718 | c S = P(2,5)**2 + 2.*ENU*(P(2,4)-P(2,3)) ! ???? | |
35719 | S = P(2,5)**2 + 2.*ENU*P(2,5) | |
35720 | SQS = SQRT(S) ! E centro massa | |
35721 | IF (SQS .LT. (AML + AMF + 3.E-03)) GOTO 100 | |
35722 | ELF = (S-AMF2+AML2)/(2.*SQS) ! energia leptone finale p | |
35723 | PSTAR = (S-P(2,5)**2)/(2.*SQS) ! p* neutrino nel c.m. | |
35724 | PLF = SQRT(ELF**2-AML2) ! 3-momento leptone finale | |
35725 | Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF) ! + o - | |
35726 | Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF) ! according con cos(theta) | |
35727 | IF (Q2MIN .LT. 0.) Q2MIN = 0. ! ??? non fisico | |
35728 | ||
35729 | C...Generate Q**2 | |
35730 | DSIGMAX = DT_DSQEL_Q2 (LTYP,ENU, Q2MIN) | |
35731 | 200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0) | |
35732 | DSIG = DT_DSQEL_Q2 (LTYP,ENU, Q2) | |
35733 | IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200 | |
35734 | CALL DT_QGAUS(Q2MIN,Q2MAX,DSIGEV,ENU,LTYP) | |
35735 | NDSIG=NDSIG+1 | |
35736 | C WRITE(6,*)' Q2,Q2min,Q2MAX,DSIGEV', | |
35737 | C &Q2,Q2min,Q2MAX,DSIGEV | |
35738 | ||
35739 | C...c.m. frame. Neutrino along z axis | |
35740 | DETOT = (P(1,4)) + (P(2,4)) ! e totale | |
35741 | DBETA(1) = ((P(1,1)) + (P(2,1)))/DETOT ! px1+px2/etot = beta_x | |
35742 | DBETA(2) = ((P(1,2)) + (P(2,2)))/DETOT ! | |
35743 | DBETA(3) = ((P(1,3)) + (P(2,3)))/DETOT ! | |
35744 | c WRITE(*,*) | |
35745 | c WRITE(*,*) | |
35746 | C WRITE(*,*) 'Input values laboratory frame' | |
35747 | N=2 | |
35748 | ||
35749 | CALL PYROBO(0,0,0.0D0,0.0D0,-DBETA(1),-DBETA(2),-DBETA(3)) | |
35750 | ||
35751 | N=5 | |
35752 | c STHETA = ULANGL(P(1,3),P(1,1)) | |
35753 | c write(*,*) 'stheta' ,stheta | |
35754 | c stheta=0. | |
35755 | c CALL PYROBO (0,0,-STHETA,0.,0.D0,0.D0,0.D0) | |
35756 | c WRITE(*,*) | |
35757 | c WRITE(*,*) | |
35758 | C WRITE(*,*) 'Output values cm frame' | |
35759 | C...Kinematic in c.m. frame | |
35760 | CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF) ! cos(theta) cm | |
35761 | STSTAR = SQRT(1.-CTSTAR**2) | |
35762 | PHI = 6.28319*PYR(0) ! random phi tra 0 e 2*pi | |
35763 | P(4,5) = AML ! massa leptone | |
35764 | P(4,4) = ELF ! e leptone | |
35765 | P(4,3) = PLF*CTSTAR ! px | |
35766 | P(4,1) = PLF*STSTAR*COS(PHI) ! py | |
35767 | P(4,2) = PLF*STSTAR*SIN(PHI) ! pz | |
35768 | ||
35769 | P(5,5) = AMF ! barione | |
35770 | P(5,4) = (S+AMF2-AML2)/(2.*SQS)! e barione | |
35771 | P(5,3) = -P(4,3) ! px | |
35772 | P(5,1) = -P(4,1) ! py | |
35773 | P(5,2) = -P(4,2) ! pz | |
35774 | ||
35775 | P(3,5) = -Q2 | |
35776 | P(3,1) = P(1,1)-P(4,1) | |
35777 | P(3,2) = P(1,2)-P(4,2) | |
35778 | P(3,3) = P(1,3)-P(4,3) | |
35779 | P(3,4) = P(1,4)-P(4,4) | |
35780 | ||
35781 | C...Transform back to laboratory frame | |
35782 | C WRITE(*,*) 'before going back to nucl rest frame' | |
35783 | c CALL PYROBO (0,0,STHETA,0.,0.D0,0.D0,0.D0) | |
35784 | N=5 | |
35785 | ||
35786 | CALL PYROBO(0,0,0.0D0,0.0D0,DBETA(1),DBETA(2),DBETA(3)) | |
35787 | ||
35788 | C WRITE(*,*) 'Now back in nucl rest frame' | |
35789 | IF(LTYP.GE.3) CALL DT_PREPOLA(Q2,LTYP,ENU) | |
35790 | ||
35791 | c******************************************** | |
35792 | ||
35793 | DO kw=1,5 | |
35794 | pi(1)=p(kw,1) | |
35795 | pi(2)=p(kw,2) | |
35796 | pi(3)=p(kw,3) | |
35797 | CALL DT_TESTROT(Pi,Po,PHI12,3) | |
35798 | DO ll=1,3 | |
35799 | IF(abs(po(ll)).LT.1.D-07) po(ll)=0. | |
35800 | END DO | |
35801 | p(kw,1)=po(1) | |
35802 | p(kw,2)=po(2) | |
35803 | p(kw,3)=po(3) | |
35804 | END DO | |
35805 | c******************************************** | |
35806 | ||
35807 | DO kw=1,5 | |
35808 | pi(1)=p(kw,1) | |
35809 | pi(2)=p(kw,2) | |
35810 | pi(3)=p(kw,3) | |
35811 | CALL DT_TESTROT(Pi,Po,PHI11,4) | |
35812 | DO ll=1,3 | |
35813 | IF(abs(po(ll)).LT.1.D-07) po(ll)=0. | |
35814 | END DO | |
35815 | p(kw,1)=po(1) | |
35816 | p(kw,2)=po(2) | |
35817 | p(kw,3)=po(3) | |
35818 | END DO | |
35819 | ||
35820 | c******************************************** | |
35821 | ||
35822 | C WRITE(*,*) 'Now back in lab frame' | |
35823 | ||
35824 | CALL PYROBO(1,5,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3) | |
35825 | ||
35826 | CGB+... | |
35827 | C...test (on final momentum of nucleon) if Fermi-blocking | |
35828 | C...is operating | |
35829 | ENUCL = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2 + P(5,5)**2) | |
35830 | & - P(5,5) | |
35831 | IF (ENUCL.LT. EFMAX) THEN | |
35832 | IF(INIPRI.LT.10)THEN | |
35833 | INIPRI=INIPRI+1 | |
35834 | C WRITE(6,*)' qel: Pauli ENUCL.LT.EFMAX ', ENUCL,EFMAX | |
35835 | C...the interaction is not possible due to Pauli-Blocking and | |
35836 | C...it must be resampled | |
35837 | ENDIF | |
35838 | GOTO 100 | |
35839 | ELSE IF (ENUCL.LT.ENWELL.and.ENUCL.GE.EFMAX) THEN | |
35840 | IF(INIPRI.LT.10)THEN | |
35841 | INIPRI=INIPRI+1 | |
35842 | C WRITE(6,*)' qel: inside ENUCL.LT.ENWELL ', ENUCL,ENWELL | |
35843 | ENDIF | |
35844 | C Reject (J:R) here all these events | |
35845 | C are otherwise rejected in dpmjet | |
35846 | GOTO 100 | |
35847 | C...the interaction is possible, but the nucleon remains inside | |
35848 | C...the nucleus. The nucleus is therefore left excited. | |
35849 | C...We treat this case as a nucleon with 0 kinetic energy. | |
35850 | C P(5,5) = AMF | |
35851 | C P(5,4) = AMF | |
35852 | C P(5,1) = 0. | |
35853 | C P(5,2) = 0. | |
35854 | C P(5,3) = 0. | |
35855 | ELSE IF (ENUCL.GE.ENWELL) THEN | |
35856 | C WRITE(6,*)' qel ENUCL.GE.ENWELL ',ENUCL,ENWELL | |
35857 | C...the interaction is possible, the nucleon can exit the nucleus | |
35858 | C...but the nuclear well depth must be subtracted. The nucleus could be | |
35859 | C...left in an excited state. | |
35860 | Pstart = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2) | |
35861 | C P(5,4) = ENUCL-ENWELL + AMF | |
35862 | Pnucl = SQRT(P(5,4)**2-AMF**2) | |
35863 | C...The 3-momentum is scaled assuming that the direction remains | |
35864 | C...unaffected | |
35865 | P(5,1) = P(5,1) * Pnucl/Pstart | |
35866 | P(5,2) = P(5,2) * Pnucl/Pstart | |
35867 | P(5,3) = P(5,3) * Pnucl/Pstart | |
35868 | C WRITE(6,*)' qel new P(5,4) ',P(5,4) | |
35869 | ENDIF | |
35870 | CGB-... | |
35871 | DSIGSU=DSIGSU+DSIGEV | |
35872 | ||
35873 | GA=P(4,4)/P(4,5) | |
35874 | BGX=P(4,1)/P(4,5) | |
35875 | BGY=P(4,2)/P(4,5) | |
35876 | BGZ=P(4,3)/P(4,5) | |
35877 | * | |
35878 | DBETB(1)=BGX/GA | |
35879 | DBETB(2)=BGY/GA | |
35880 | DBETB(3)=BGZ/GA | |
35881 | IF(NEUDEC.EQ.1.OR.NEUDEC.EQ.2) THEN | |
35882 | ||
35883 | CALL PYROBO(6,8,0.0D0,0.0D0,DBETB(1),DBETB(2),DBETB(3)) | |
35884 | ||
35885 | ENDIF | |
35886 | c | |
35887 | C PRINT*,' FINE EVENTO ' | |
35888 | enu=enu0 | |
35889 | RETURN | |
35890 | ||
35891 | 1001 FORMAT(2X, 'DT_GEN_QEL : event rejected ', I5, G10.3) | |
35892 | END | |
35893 | ||
35894 | *$ CREATE DT_MASS_INI.FOR | |
35895 | *COPY DT_MASS_INI | |
35896 | C==================================================================== | |
35897 | C. Masses | |
35898 | C==================================================================== | |
35899 | * | |
35900 | *===mass_ini===========================================================* | |
35901 | * | |
35902 | SUBROUTINE DT_MASS_INI | |
35903 | C...Initialize the kinematics for the quasi-elastic cross section | |
35904 | ||
35905 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
35906 | SAVE | |
35907 | ||
35908 | * particle masses used in qel neutrino scattering modules | |
35909 | COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6), | |
35910 | & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN, | |
35911 | & EMPROTSQ,EMNEUTSQ,EMNSQ | |
35912 | ||
35913 | EML(1) = 0.51100D-03 ! e- | |
35914 | EML(2) = EML(1) ! e+ | |
35915 | EML(3) = 0.105659D0 ! mu- | |
35916 | EML(4) = EML(3) ! mu+ | |
35917 | EML(5) = 1.7777D0 ! tau- | |
35918 | EML(6) = EML(5) ! tau+ | |
35919 | EMPROT = 0.93827231D0 ! p | |
35920 | EMNEUT = 0.93956563D0 ! n | |
35921 | EMPROTSQ = EMPROT**2 | |
35922 | EMNEUTSQ = EMNEUT**2 | |
35923 | EMN = (EMPROT + EMNEUT)/2. | |
35924 | EMNSQ = EMN**2 | |
35925 | DO J=1,3 | |
35926 | J0 = 2*(J-1) | |
35927 | EMN1(J0+1) = EMNEUT | |
35928 | EMN1(J0+2) = EMPROT | |
35929 | EMN2(J0+1) = EMPROT | |
35930 | EMN2(J0+2) = EMNEUT | |
35931 | ENDDO | |
35932 | DO J=1,6 | |
35933 | EMLSQ(J) = EML(J)**2 | |
35934 | ETQE(J) = ((EMN2(J)+ EML(J))**2-EMN1(J)**2)/(2.*EMN1(J)) | |
35935 | ENDDO | |
35936 | RETURN | |
35937 | END | |
35938 | ||
35939 | *$ CREATE DT_DSQEL_Q2.FOR | |
35940 | *COPY DT_DSQEL_Q2 | |
35941 | * | |
35942 | *===dsqel_q2===========================================================* | |
35943 | * | |
35944 | DOUBLE PRECISION FUNCTION DT_DSQEL_Q2 (JTYP,ENU, Q2) | |
35945 | ||
35946 | C...differential cross section for Quasi-Elastic scattering | |
35947 | C. nu + N -> l + N' | |
35948 | C. From Llewellin Smith Phys.Rep. 3C, 261, (1971). | |
35949 | C. | |
35950 | C. INPUT : JTYP = 1,...,6 nu_e, ...., nubar_tau | |
35951 | C. ENU (GeV) = Neutrino energy | |
35952 | C. Q2 (GeV**2) = (Transfer momentum)**2 | |
35953 | C. | |
35954 | C. OUTPUT : DSQEL_Q2 = differential cross section : | |
35955 | C. dsigma/dq**2 (10**-38 cm+2/GeV**2) | |
35956 | C------------------------------------------------------------------ | |
35957 | ||
35958 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
35959 | SAVE | |
35960 | ||
35961 | * particle masses used in qel neutrino scattering modules | |
35962 | COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6), | |
35963 | & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN, | |
35964 | & EMPROTSQ,EMNEUTSQ,EMNSQ | |
35965 | **sr - removed (not needed) | |
35966 | C COMMON /CAXIAL/ FA0, AXIAL2 | |
35967 | ** | |
35968 | ||
35969 | DIMENSION SS(6) | |
35970 | DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2 | |
35971 | DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/ | |
35972 | DATA AXIAL2 /1.03D0/ ! to be checked | |
35973 | ||
35974 | FA0=-1.253D0 | |
35975 | CSI = 3.71D0 ! ??? | |
35976 | GVE = 1.D0/ (1.D0 + Q2/0.84D0**2)**2 ! G_e(q**2) | |
35977 | GVM = (1.D0+CSI)*GVE ! G_m (q**2) | |
35978 | X = Q2/(EMN*EMN) ! emn=massa barione | |
35979 | XA = X/4.D0 | |
35980 | FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM) | |
35981 | FV2 = 1.D0/(1.D0+XA)*(GVM-GVE) | |
35982 | FA = FA0/(1.D0 + Q2/AXIAL2)**2 | |
35983 | FFA = FA*FA | |
35984 | FFV1 = FV1*FV1 | |
35985 | FFV2 = FV2*FV2 | |
35986 | RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp) | |
35987 | A1 = (4.D0+X)*FFA - (4.D0-X)*FFV1 + X*FFV2*(1.D0-XA)+4*X*FV1*FV2 | |
35988 | A2 = -RM * ((FV1 + FV2)**2 + FFA) | |
35989 | AA = (XA+0.25D0*RM)*(A1 + A2) | |
35990 | BB = -X*FA*(FV1 + FV2) | |
35991 | CC = 0.25D0*(FFA + FFV1 + XA*FFV2) | |
35992 | SU = (4.D0*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN) | |
35993 | DT_DSQEL_Q2 = C0*(AA + SS(JTYP)*BB*SU + CC*SU*SU) / (ENU*ENU) ! | |
35994 | IF(DT_DSQEL_Q2 .LT. 0.D0) DT_DSQEL_Q2 = 0.D0 | |
35995 | ||
35996 | RETURN | |
35997 | END | |
35998 | ||
35999 | *$ CREATE DT_PREPOLA.FOR | |
36000 | *COPY DT_PREPOLA | |
36001 | * | |
36002 | *===prepola============================================================* | |
36003 | * | |
36004 | SUBROUTINE DT_PREPOLA(Q2,JTYP,ENU) | |
36005 | ||
36006 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
36007 | SAVE | |
36008 | c | |
36009 | c By G. Battistoni and E. Scapparone (sept. 1997) | |
36010 | c According to: | |
36011 | c Albright & Jarlskog, Nucl Phys B84 (1975) 467 | |
36012 | c | |
36013 | c | |
36014 | PARAMETER (MAXLND=4000) | |
36015 | COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5) | |
36016 | COMMON /QNPOL/ POLARX(4),PMODUL | |
36017 | * particle masses used in qel neutrino scattering modules | |
36018 | COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6), | |
36019 | & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN, | |
36020 | & EMPROTSQ,EMNEUTSQ,EMNSQ | |
36021 | * steering flags for qel neutrino scattering modules | |
36022 | COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC | |
36023 | **sr - removed (not needed) | |
36024 | C COMMON /CAXIAL/ FA0, AXIAL2 | |
36025 | C COMMON /TAUTAU/Q(4,5),ETL,PXL,PYL,PZL, | |
36026 | C & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN | |
36027 | ** | |
36028 | REAL*8 POL(4,4),BB2(3) | |
36029 | DIMENSION SS(6) | |
36030 | C DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2 | |
36031 | DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/ | |
36032 | **sr uncommented since common block CAXIAL is now commented | |
36033 | DATA AXIAL2 /1.03D0/ ! to be checked | |
36034 | ** | |
36035 | ||
36036 | RML=P(4,5) | |
36037 | RMM=0.93960D+00 | |
36038 | FM2 = RMM**2 | |
36039 | MPI = 0.135D+00 | |
36040 | OLDQ2=Q2 | |
36041 | FA0=-1.253D+00 | |
36042 | CSI = 3.71D+00 ! | |
36043 | GVE = 1.D0/ (1.D0 + Q2/(0.84D+00)**2)**2 ! G_e(q**2) | |
36044 | GVM = (1.D0+CSI)*GVE ! G_m (q**2) | |
36045 | X = Q2/(EMN*EMN) ! emn=massa barione | |
36046 | XA = X/4.D0 | |
36047 | FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM) | |
36048 | FV2 = 1.D0/(1.D0+XA)*(GVM-GVE) | |
36049 | FA = FA0/(1.D0 + Q2/AXIAL2**2)**2 | |
36050 | FFA = FA*FA | |
36051 | FFV1 = FV1*FV1 | |
36052 | FFV2 = FV2*FV2 | |
36053 | FP=2.D0*FA*RMM/(MPI**2 + Q2) | |
36054 | RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp) | |
36055 | A1 = (4.D0+X)*FFA-(4.D0-X)*FFV1+X*FFV2*(1.D0-XA)+4.D0*X*FV1*FV2 | |
36056 | A2 = -RM * ((FV1 + FV2)**2 + FFA) | |
36057 | AA = (XA+0.25D+00*RM)*(A1 + A2) | |
36058 | BB = -X*FA*(FV1 + FV2) | |
36059 | CC = 0.25D+00*(FFA + FFV1 + XA*FFV2) | |
36060 | SU = (4.D+00*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN) | |
36061 | ||
36062 | OMEGA1=FFA+XA*(FFA+(FV1+FV2)**2 ) ! articolo di ll...-smith | |
36063 | OMEGA2=4.D+00*CC | |
36064 | OMEGA3=2.D+00*FA*(FV1+FV2) | |
36065 | OMEGA4P=(-(FV1+FV2)**2-(FA+2*FP)**2+(4.0D+00+ | |
36066 | 1 (Q2/FM2))*FP**2) | |
36067 | OMEGA5=OMEGA2 | |
36068 | OMEGA4=(OMEGA4P-OMEGA2+2*OMEGA5)/4.D+00 | |
36069 | WW1=2.D+00*OMEGA1*EMN**2 | |
36070 | WW2=2.D+00*OMEGA2*EMN**2 | |
36071 | WW3=2.D+00*OMEGA3*EMN**2 | |
36072 | WW4=2.D+00*OMEGA4*EMN**2 | |
36073 | WW5=2.D+00*OMEGA5*EMN**2 | |
36074 | ||
36075 | DO I=1,3 | |
36076 | BB2(I)=-P(4,I)/P(4,4) | |
36077 | END DO | |
36078 | c WRITE(*,*) | |
36079 | c WRITE(*,*) | |
36080 | c WRITE(*,*) 'Prepola: ready to transform to lepton rest frame' | |
36081 | N=5 | |
36082 | CALL PYROBO(0,0,0.0D0,0.0D0,BB2(1),BB2(2),BB2(3)) | |
36083 | * NOW PARTICLES ARE IN THE SCATTERED LEPTON REST FRAME | |
36084 | c WRITE(*,*) | |
36085 | c WRITE(*,*) | |
36086 | c WRITE(*,*) 'Prepola: now in lepton rest frame' | |
36087 | EE=ENU | |
36088 | QM2=Q2+RML**2 | |
36089 | U=Q2/(2.*RMM) | |
36090 | FRAC=QM2*WW1 + (2.D+00*EE*(EE-U) - 0.5D+00*QM2)*WW2 - SS(JTYP)* | |
36091 | + (0.5D+00/(RMM**2))*(2.D+00*RMM*EE*Q2 - U*QM2)*WW3 + | |
36092 | + ((RML**2)/(2.D+00*FM2))*(QM2*WW4-2.D+00*RMM*EE*WW5) !<=FM2 inv di RMM!! | |
36093 | ||
36094 | FACTK=2.D+00*WW1 -WW2 -SS(JTYP)*(EE/RMM)*WW3 +((EE-U)/RMM)*WW5 | |
36095 | + - ((RML**2)/FM2)*WW4 !<=FM2 inv di RMM!! | |
36096 | ||
36097 | FACTP=2.D+00*EE/RMM*WW2 - (QM2/(2.D+00*RMM**2))*(SS(JTYP)*WW3+WW5) | |
36098 | ||
36099 | DO I=1,3 | |
36100 | POL(4,I)=RML*SS(JTYP)*(FACTK*P(1,I)+FACTP*P(2,I))/FRAC | |
36101 | POLARX(I)=POL(4,I) | |
36102 | END DO | |
36103 | ||
36104 | PMODUL=0.D0 | |
36105 | DO I=1,3 | |
36106 | PMODUL=PMODUL+POL(4,I)**2 | |
36107 | END DO | |
36108 | ||
36109 | IF(JTYP.GT.4.AND.NEUDEC.GT.0) THEN | |
36110 | IF(NEUDEC.EQ.1) THEN | |
36111 | CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-2),POLARX(3), | |
36112 | + ETL,PXL,PYL,PZL, | |
36113 | + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN) | |
36114 | c | |
36115 | c Tau has decayed in muon | |
36116 | c | |
36117 | ENDIF | |
36118 | IF(NEUDEC.EQ.2) THEN | |
36119 | CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-4),POLARX(3), | |
36120 | + ETL,PXL,PYL,PZL, | |
36121 | + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN) | |
36122 | c | |
36123 | c Tau has decayed in electron | |
36124 | c | |
36125 | ENDIF | |
36126 | K(4,1)=15 | |
36127 | K(4,4) = 6 | |
36128 | K(4,5) = 8 | |
36129 | N=N+3 | |
36130 | c | |
36131 | c fill common for muon(electron) | |
36132 | c | |
36133 | P(6,1)=PXL | |
36134 | P(6,2)=PYL | |
36135 | P(6,3)=PZL | |
36136 | P(6,4)=ETL | |
36137 | K(6,1)=1 | |
36138 | IF(JTYP.EQ.5) THEN | |
36139 | IF(NEUDEC.EQ.1) THEN | |
36140 | P(6,5)=EML(JTYP-2) | |
36141 | K(6,2)=13 | |
36142 | ELSEIF(NEUDEC.EQ.2) THEN | |
36143 | P(6,5)=EML(JTYP-4) | |
36144 | K(6,2)=11 | |
36145 | ENDIF | |
36146 | ELSEIF(JTYP.EQ.6) THEN | |
36147 | IF(NEUDEC.EQ.1) THEN | |
36148 | K(6,2)=-13 | |
36149 | ELSEIF(NEUDEC.EQ.2) THEN | |
36150 | K(6,2)=-11 | |
36151 | ENDIF | |
36152 | END IF | |
36153 | K(6,3)=4 | |
36154 | K(6,4)=0 | |
36155 | K(6,5)=0 | |
36156 | c | |
36157 | c fill common for tau_(anti)neutrino | |
36158 | c | |
36159 | P(7,1)=PXB | |
36160 | P(7,2)=PYB | |
36161 | P(7,3)=PZB | |
36162 | P(7,4)=ETB | |
36163 | P(7,5)=0. | |
36164 | K(7,1)=1 | |
36165 | IF(JTYP.EQ.5) THEN | |
36166 | K(7,2)=16 | |
36167 | ELSEIF(JTYP.EQ.6) THEN | |
36168 | K(7,2)=-16 | |
36169 | END IF | |
36170 | K(7,3)=4 | |
36171 | K(7,4)=0 | |
36172 | K(7,5)=0 | |
36173 | c | |
36174 | c Fill common for muon(electron)_(anti)neutrino | |
36175 | c | |
36176 | P(8,1)=PXN | |
36177 | P(8,2)=PYN | |
36178 | P(8,3)=PZN | |
36179 | P(8,4)=ETN | |
36180 | P(8,5)=0. | |
36181 | K(8,1)=1 | |
36182 | IF(JTYP.EQ.5) THEN | |
36183 | IF(NEUDEC.EQ.1) THEN | |
36184 | K(8,2)=-14 | |
36185 | ELSEIF(NEUDEC.EQ.2) THEN | |
36186 | K(8,2)=-12 | |
36187 | ENDIF | |
36188 | ELSEIF(JTYP.EQ.6) THEN | |
36189 | IF(NEUDEC.EQ.1) THEN | |
36190 | K(8,2)=14 | |
36191 | ELSEIF(NEUDEC.EQ.2) THEN | |
36192 | K(8,2)=12 | |
36193 | ENDIF | |
36194 | END IF | |
36195 | K(8,3)=4 | |
36196 | K(8,4)=0 | |
36197 | K(8,5)=0 | |
36198 | ENDIF | |
36199 | c WRITE(*,*) | |
36200 | c WRITE(*,*) | |
36201 | ||
36202 | c IF(PMODUL.GE.1.D+00) THEN | |
36203 | c WRITE(*,*) 'Pol',(POLARX(I),I=1,3) | |
36204 | c write(*,*) pmodul | |
36205 | c DO I=1,3 | |
36206 | c POL(4,I)=POL(4,I)/PMODUL | |
36207 | c POLARX(I)=POL(4,I) | |
36208 | c END DO | |
36209 | c PMODUL=0. | |
36210 | c DO I=1,3 | |
36211 | c PMODUL=PMODUL+POL(4,I)**2 | |
36212 | c END DO | |
36213 | c WRITE(*,*) 'Pol',(POLARX(I),I=1,3) | |
36214 | c | |
36215 | c ENDIF | |
36216 | ||
36217 | c WRITE(*,*) 'PMODUL = ',PMODUL | |
36218 | ||
36219 | c WRITE(*,*) | |
36220 | c WRITE(*,*) | |
36221 | c WRITE(*,*) 'prepola: Now back to nucl rest frame' | |
36222 | CALL PYROBO(1,5,0.0D0,0.0D0,-BB2(1),-BB2(2),-BB2(3)) | |
36223 | ||
36224 | XDC = V(4,1)+V(4,5)*P(4,1)/P(4,5) | |
36225 | YDC = V(4,2)+V(4,5)*P(4,2)/P(4,5) | |
36226 | ZDC = V(4,3)+V(4,5)*P(4,3)/P(4,5) | |
36227 | DO NDC =6,8 | |
36228 | V(NDC,1) = XDC | |
36229 | V(NDC,2) = YDC | |
36230 | V(NDC,3) = ZDC | |
36231 | END DO | |
36232 | ||
36233 | RETURN | |
36234 | END | |
36235 | ||
36236 | *$ CREATE DT_TESTROT.FOR | |
36237 | *COPY DT_TESTROT | |
36238 | * | |
36239 | *===testrot============================================================* | |
36240 | * | |
36241 | SUBROUTINE DT_TESTROT(PI,PO,PHI,MODE) | |
36242 | ||
36243 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
36244 | SAVE | |
36245 | ||
36246 | DIMENSION ROT(3,3),PI(3),PO(3) | |
36247 | ||
36248 | IF (MODE.EQ.1) THEN | |
36249 | ROT(1,1) = 1.D0 | |
36250 | ROT(1,2) = 0.D0 | |
36251 | ROT(1,3) = 0.D0 | |
36252 | ROT(2,1) = 0.D0 | |
36253 | ROT(2,2) = COS(PHI) | |
36254 | ROT(2,3) = -SIN(PHI) | |
36255 | ROT(3,1) = 0.D0 | |
36256 | ROT(3,2) = SIN(PHI) | |
36257 | ROT(3,3) = COS(PHI) | |
36258 | ELSEIF (MODE.EQ.2) THEN | |
36259 | ROT(1,1) = 0.D0 | |
36260 | ROT(1,2) = 1.D0 | |
36261 | ROT(1,3) = 0.D0 | |
36262 | ROT(2,1) = COS(PHI) | |
36263 | ROT(2,2) = 0.D0 | |
36264 | ROT(2,3) = -SIN(PHI) | |
36265 | ROT(3,1) = SIN(PHI) | |
36266 | ROT(3,2) = 0.D0 | |
36267 | ROT(3,3) = COS(PHI) | |
36268 | ELSEIF (MODE.EQ.3) THEN | |
36269 | ROT(1,1) = 0.D0 | |
36270 | ROT(2,1) = 1.D0 | |
36271 | ROT(3,1) = 0.D0 | |
36272 | ROT(1,2) = COS(PHI) | |
36273 | ROT(2,2) = 0.D0 | |
36274 | ROT(3,2) = -SIN(PHI) | |
36275 | ROT(1,3) = SIN(PHI) | |
36276 | ROT(2,3) = 0.D0 | |
36277 | ROT(3,3) = COS(PHI) | |
36278 | ELSEIF (MODE.EQ.4) THEN | |
36279 | ROT(1,1) = 1.D0 | |
36280 | ROT(2,1) = 0.D0 | |
36281 | ROT(3,1) = 0.D0 | |
36282 | ROT(1,2) = 0.D0 | |
36283 | ROT(2,2) = COS(PHI) | |
36284 | ROT(3,2) = -SIN(PHI) | |
36285 | ROT(1,3) = 0.D0 | |
36286 | ROT(2,3) = SIN(PHI) | |
36287 | ROT(3,3) = COS(PHI) | |
36288 | ELSE | |
36289 | STOP ' TESTROT: mode not supported!' | |
36290 | ENDIF | |
36291 | DO 1 J=1,3 | |
36292 | PO(J) = ROT(J,1)*PI(1)+ROT(J,2)*PI(2)+ROT(J,3)*PI(3) | |
36293 | 1 CONTINUE | |
36294 | ||
36295 | RETURN | |
36296 | END | |
36297 | ||
36298 | *$ CREATE DT_LEPDCYP.FOR | |
36299 | *COPY DT_LEPDCYP | |
36300 | * | |
36301 | *===lepdcyp============================================================* | |
36302 | * | |
36303 | SUBROUTINE DT_LEPDCYP(AMA,AML,POL,ETL,PXL,PYL,PZL, | |
36304 | & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN) | |
36305 | C | |
36306 | C----------------------------------------------------------------- | |
36307 | C | |
36308 | C Author :- G. Battistoni 10-NOV-1995 | |
36309 | C | |
36310 | C================================================================= | |
36311 | C | |
36312 | C Purpose : performs decay of polarized lepton in | |
36313 | C its rest frame: a => b + l + anti-nu | |
36314 | C (Example: mu- => nu-mu + e- + anti-nu-e) | |
36315 | C Polarization is assumed along Z-axis | |
36316 | C WARNING: | |
36317 | C 1) b AND anti-nu ARE ASSUMED TO BE NEUTRINOS | |
36318 | C OF NEGLIGIBLE MASS | |
36319 | C 2) RADIATIVE CORRECTIONS ARE NOT CONSIDERED | |
36320 | C IN THIS VERSION | |
36321 | C | |
36322 | C Method : modifies phase space distribution obtained | |
36323 | C by routine EXPLOD using a rejection against the | |
36324 | C matrix element for unpolarized lepton decay | |
36325 | C | |
36326 | C Inputs : Mass of a : AMA | |
36327 | C Mass of l : AML | |
36328 | C Polar. of a: POL | |
36329 | C (Example: fully polar. mu- decay: AMA=AMMUON, AML=AMELCT, | |
36330 | C POL = -1) | |
36331 | C | |
36332 | C Outputs : kinematic variables in the rest frame of decaying lepton | |
36333 | C ETL,PXL,PYL,PZL 4-moment of l | |
36334 | C ETB,PXB,PYB,PZB 4-moment of b | |
36335 | C ETN,PXN,PYN,PZN 4-moment of anti-nu | |
36336 | C | |
36337 | C============================================================ | |
36338 | C + | |
36339 | C Declarations. | |
36340 | C - | |
36341 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
36342 | SAVE | |
36343 | ||
36344 | PARAMETER ( LINP = 10 , | |
36345 | & LOUT = 6 , | |
36346 | & LDAT = 9 ) | |
36347 | PARAMETER ( KALGNM = 2 ) | |
36348 | PARAMETER ( ANGLGB = 5.0D-16 ) | |
36349 | PARAMETER ( ANGLSQ = 2.5D-31 ) | |
36350 | PARAMETER ( AXCSSV = 0.2D+16 ) | |
36351 | PARAMETER ( ANDRFL = 1.0D-38 ) | |
36352 | PARAMETER ( AVRFLW = 1.0D+38 ) | |
36353 | PARAMETER ( AINFNT = 1.0D+30 ) | |
36354 | PARAMETER ( AZRZRZ = 1.0D-30 ) | |
36355 | PARAMETER ( EINFNT = +69.07755278982137 D+00 ) | |
36356 | PARAMETER ( EZRZRZ = -69.07755278982137 D+00 ) | |
36357 | PARAMETER ( ONEMNS = 0.999999999999999 D+00 ) | |
36358 | PARAMETER ( ONEPLS = 1.000000000000001 D+00 ) | |
36359 | PARAMETER ( CSNNRM = 2.0D-15 ) | |
36360 | PARAMETER ( DMXTRN = 1.0D+08 ) | |
36361 | PARAMETER ( ZERZER = 0.D+00 ) | |
36362 | PARAMETER ( ONEONE = 1.D+00 ) | |
36363 | PARAMETER ( TWOTWO = 2.D+00 ) | |
36364 | PARAMETER ( THRTHR = 3.D+00 ) | |
36365 | PARAMETER ( FOUFOU = 4.D+00 ) | |
36366 | PARAMETER ( FIVFIV = 5.D+00 ) | |
36367 | PARAMETER ( SIXSIX = 6.D+00 ) | |
36368 | PARAMETER ( SEVSEV = 7.D+00 ) | |
36369 | PARAMETER ( EIGEIG = 8.D+00 ) | |
36370 | PARAMETER ( ANINEN = 9.D+00 ) | |
36371 | PARAMETER ( TENTEN = 10.D+00 ) | |
36372 | PARAMETER ( HLFHLF = 0.5D+00 ) | |
36373 | PARAMETER ( ONETHI = ONEONE / THRTHR ) | |
36374 | PARAMETER ( TWOTHI = TWOTWO / THRTHR ) | |
36375 | PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 ) | |
36376 | PARAMETER ( ENEPER = 2.7182818284590452354 D+00 ) | |
36377 | PARAMETER ( SQRENT = 1.6487212707001281468 D+00 ) | |
36378 | PARAMETER ( CLIGHT = 2.99792458 D+10 ) | |
36379 | PARAMETER ( AVOGAD = 6.0221367 D+23 ) | |
36380 | PARAMETER ( AMELGR = 9.1093897 D-28 ) | |
36381 | PARAMETER ( PLCKBR = 1.05457266 D-27 ) | |
36382 | PARAMETER ( ELCCGS = 4.8032068 D-10 ) | |
36383 | PARAMETER ( ELCMKS = 1.60217733 D-19 ) | |
36384 | PARAMETER ( AMUGRM = 1.6605402 D-24 ) | |
36385 | PARAMETER ( AMMUMU = 0.113428913 D+00 ) | |
36386 | PARAMETER ( ALPFSC = 7.2973530791728595 D-03 ) | |
36387 | PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 ) | |
36388 | PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 ) | |
36389 | PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 ) | |
36390 | PARAMETER ( PLABRC = 0.197327053 D+00 ) | |
36391 | PARAMETER ( AMELCT = 0.51099906 D-03 ) | |
36392 | PARAMETER ( AMUGEV = 0.93149432 D+00 ) | |
36393 | PARAMETER ( AMMUON = 0.105658389 D+00 ) | |
36394 | PARAMETER ( RCLSEL = 2.8179409183694872 D-13 ) | |
36395 | PARAMETER ( GEVMEV = 1.0 D+03 ) | |
36396 | PARAMETER ( EMVGEV = 1.0 D-03 ) | |
36397 | PARAMETER ( ALGVMV = 6.90775527898214 D+00 ) | |
36398 | PARAMETER ( RADDEG = 180.D+00 / PIPIPI ) | |
36399 | PARAMETER ( DEGRAD = PIPIPI / 180.D+00 ) | |
36400 | C + | |
36401 | C variables for EXPLOD | |
36402 | C - | |
36403 | PARAMETER ( KPMX = 10 ) | |
36404 | DIMENSION AMEXPL (KPMX), PXEXPL (KPMX), PYEXPL (KPMX), | |
36405 | & PZEXPL (KPMX), ETEXPL (KPMX) | |
36406 | C + | |
36407 | C test variables | |
36408 | C - | |
36409 | **sr - removed (not needed) | |
36410 | C COMMON /GBATNU/ ELERAT,NTRY | |
36411 | ** | |
36412 | C + | |
36413 | C Initializes test variables | |
36414 | C - | |
36415 | NTRY = 0 | |
36416 | ELERAT = 0.D+00 | |
36417 | C + | |
36418 | C Maximum value for matrix element | |
36419 | C - | |
36420 | ELEMAX = ( AMA**2 + AML**2 )**2 / AMA**2 * ( AMA**2 - AML**2 + | |
36421 | & SQRT( AMA**4 + AML**4 - 3.D+00 * AMA**2 * AML**2 ) ) | |
36422 | C + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + | |
36423 | C Inputs for EXPLOD | |
36424 | C part. no. 1 is l (e- in mu- decay) | |
36425 | C part. no. 2 is b (nu-mu in mu- decay) | |
36426 | C part. no. 3 is anti-nu (anti-nu-e in mu- decay) | |
36427 | C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - | |
36428 | NPEXPL = 3 | |
36429 | ETOTEX = AMA | |
36430 | AMEXPL(1) = AML | |
36431 | AMEXPL(2) = 0.D+00 | |
36432 | AMEXPL(3) = 0.D+00 | |
36433 | C + | |
36434 | C phase space distribution | |
36435 | C - | |
36436 | 100 CONTINUE | |
36437 | NTRY = NTRY + 1 | |
36438 | ||
36439 | CALL DT_EXPLOD ( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL, | |
36440 | & PYEXPL, PZEXPL ) | |
36441 | ||
36442 | C + | |
36443 | C Calculates matrix element: | |
36444 | C 64*GF**2{[P(a)-ama*S(a)]*P(anti-nu)}{P(l)*P(b)} | |
36445 | C Here CTH is the cosine of the angle between anti-nu and Z axis | |
36446 | C - | |
36447 | CTH = PZEXPL(3) / SQRT ( PXEXPL(3)**2 + PYEXPL(3)**2 + | |
36448 | & PZEXPL(3)**2 ) | |
36449 | PROD1 = ETEXPL(3) * AMA * (1.D+00 - POL * CTH) | |
36450 | PROD2 = ETEXPL(1) * ETEXPL(2) - PXEXPL(1)*PXEXPL(2) - | |
36451 | & PYEXPL(1)*PYEXPL(2) - PZEXPL(1)*PZEXPL(2) | |
36452 | ELEMAT = 16.D+00 * PROD1 * PROD2 | |
36453 | IF(ELEMAT.GT.ELEMAX) THEN | |
36454 | WRITE(LOUT,*) 'Problems in LEPDCY',ELEMAX,ELEMAT | |
36455 | STOP | |
36456 | ENDIF | |
36457 | C + | |
36458 | C Here performs the rejection | |
36459 | C - | |
36460 | TEST = DT_RNDM(ETOTEX) * ELEMAX | |
36461 | IF ( TEST .GT. ELEMAT ) GO TO 100 | |
36462 | C + | |
36463 | C final assignment of variables | |
36464 | C - | |
36465 | ELERAT = ELEMAT/ELEMAX | |
36466 | ETL = ETEXPL(1) | |
36467 | PXL = PXEXPL(1) | |
36468 | PYL = PYEXPL(1) | |
36469 | PZL = PZEXPL(1) | |
36470 | ETB = ETEXPL(2) | |
36471 | PXB = PXEXPL(2) | |
36472 | PYB = PYEXPL(2) | |
36473 | PZB = PZEXPL(2) | |
36474 | ETN = ETEXPL(3) | |
36475 | PXN = PXEXPL(3) | |
36476 | PYN = PYEXPL(3) | |
36477 | PZN = PZEXPL(3) | |
36478 | 999 RETURN | |
36479 | END | |
36480 | ||
36481 | *$ CREATE DT_GEN_DELTA.FOR | |
36482 | *COPY DT_GEN_DELTA | |
36483 | C================================================================== | |
36484 | C. Generation of Delta resonance events | |
36485 | C================================================================== | |
36486 | * | |
36487 | *===gen_delta==========================================================* | |
36488 | * | |
36489 | SUBROUTINE DT_GEN_DELTA(ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25) | |
36490 | ||
36491 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
36492 | SAVE | |
36493 | ||
36494 | PARAMETER ( LINP = 10 , | |
36495 | & LOUT = 6 , | |
36496 | & LDAT = 9 ) | |
36497 | C...Generate a Delta-production neutrino/antineutrino | |
36498 | C. CC-interaction on a nucleon | |
36499 | C | |
36500 | C. INPUT ENU (GeV) = Neutrino Energy | |
36501 | C. LLEP = neutrino type | |
36502 | C. LTARG = nucleon target type 1=p, 2=n. | |
36503 | C. JINT = 1:CC, 2::NC | |
36504 | C. | |
36505 | C. OUTPUT PPL(4) 4-monentum of final lepton | |
36506 | C---------------------------------------------------- | |
36507 | PARAMETER (MAXLND=4000) | |
36508 | COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5) | |
36509 | **sr - removed (not needed) | |
36510 | C COMMON /CBAD/ LBAD, NBAD | |
36511 | ** | |
36512 | ||
36513 | DIMENSION PI(3),PO(3) | |
36514 | C REAL*4 AMD0, AMD, AMN(2), AML0(6), AML, AML2, AMDMIN | |
36515 | DIMENSION AML0(6),AMN(2) | |
36516 | DATA AMD0 /1.231/, GAMD /0.12/, DELD/0.169/, AMDMIN/1.084/ | |
36517 | DATA AMN /0.93827231, 0.93956563/ | |
36518 | DATA AML0 /2*0.51100E-03,2*0.105659, 2*1.777/ | |
36519 | ||
36520 | c WRITE(6,*)' GEN_DEL',ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25 | |
36521 | LBAD = 0 | |
36522 | C...Final lepton mass | |
36523 | IF (JINT.EQ.1) THEN | |
36524 | AML = AML0(LLEP) | |
36525 | ELSE | |
36526 | AML = 0. | |
36527 | ENDIF | |
36528 | AML2 = AML**2 | |
36529 | ||
36530 | C...Particle labels (LUND) | |
36531 | N = 5 | |
36532 | K(1,1) = 21 | |
36533 | K(2,1) = 21 | |
36534 | K(3,1) = 21 | |
36535 | K(4,1) = 1 | |
36536 | K(3,3) = 1 | |
36537 | K(4,3) = 1 | |
36538 | IF (LTARG .EQ. 1) THEN | |
36539 | K(2,2) = 2212 | |
36540 | ELSE | |
36541 | K(2,2) = 2112 | |
36542 | ENDIF | |
36543 | K0 = (LLEP-1)/2 | |
36544 | K1 = LLEP/2 | |
36545 | KA = 12 + 2*K0 | |
36546 | IS = -1 + 2*LLEP - 4*K1 | |
36547 | LNU = 2 - LLEP + 2*K1 | |
36548 | K(1,2) = IS*KA | |
36549 | K(5,1) = 1 | |
36550 | K(5,3) = 2 | |
36551 | IF (JINT .EQ. 1) THEN ! CC interactions | |
36552 | K(3,2) = IS*24 | |
36553 | K(4,2) = IS*(KA-1) | |
36554 | IF(LNU.EQ.1) THEN | |
36555 | IF (LTARG .EQ. 1) THEN | |
36556 | K(5,2) = 2224 | |
36557 | ELSE | |
36558 | K(5,2) = 2214 | |
36559 | ENDIF | |
36560 | ELSE | |
36561 | IF (LTARG .EQ. 1) THEN | |
36562 | K(5,2) = 2114 | |
36563 | ELSE | |
36564 | K(5,2) = 1114 | |
36565 | ENDIF | |
36566 | ENDIF | |
36567 | ELSE | |
36568 | K(3,2) = 23 ! NC (Z0) interactions | |
36569 | K(4,2) = K(1,2) | |
36570 | **sr 7.5.00: swop Delta's (bug), Delta+ for proton (LTARG=1), | |
36571 | * Delta0 for neutron (LTARG=2) | |
36572 | C IF (LTARG .EQ. 1) THEN | |
36573 | C K(5,2) = 2114 | |
36574 | C ELSE | |
36575 | C K(5,2) = 2214 | |
36576 | C ENDIF | |
36577 | IF (LTARG .EQ. 1) THEN | |
36578 | K(5,2) = 2214 | |
36579 | ELSE | |
36580 | K(5,2) = 2114 | |
36581 | ENDIF | |
36582 | ** | |
36583 | ENDIF | |
36584 | ||
36585 | C...4-momentum initial lepton | |
36586 | P(1,5) = 0. | |
36587 | P(1,4) = ENU | |
36588 | P(1,1) = 0. | |
36589 | P(1,2) = 0. | |
36590 | P(1,3) = ENU | |
36591 | C...4-momentum initial nucleon | |
36592 | P(2,5) = AMN(LTARG) | |
36593 | C P(2,4) = P(2,5) | |
36594 | C P(2,1) = 0. | |
36595 | C P(2,2) = 0. | |
36596 | C P(2,3) = 0. | |
36597 | P(2,1) = P21 | |
36598 | P(2,2) = P22 | |
36599 | P(2,3) = P23 | |
36600 | P(2,4) = P24 | |
36601 | P(2,5) = P25 | |
36602 | N=2 | |
36603 | beta1=-p(2,1)/p(2,4) | |
36604 | beta2=-p(2,2)/p(2,4) | |
36605 | beta3=-p(2,3)/p(2,4) | |
36606 | N=2 | |
36607 | ||
36608 | CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3) | |
36609 | ||
36610 | C print*,' nucl. rest fram ( fermi incl.) prima della rotazione' | |
36611 | ||
36612 | phi11=atan(p(1,2)/p(1,3)) | |
36613 | pi(1)=p(1,1) | |
36614 | pi(2)=p(1,2) | |
36615 | pi(3)=p(1,3) | |
36616 | ||
36617 | CALL DT_TESTROT(PI,Po,PHI11,1) | |
36618 | DO ll=1,3 | |
36619 | IF(abs(po(ll)).LT.1.D-07) po(ll)=0. | |
36620 | END DO | |
36621 | p(1,1)=po(1) | |
36622 | p(1,2)=po(2) | |
36623 | p(1,3)=po(3) | |
36624 | phi12=atan(p(1,1)/p(1,3)) | |
36625 | ||
36626 | pi(1)=p(1,1) | |
36627 | pi(2)=p(1,2) | |
36628 | pi(3)=p(1,3) | |
36629 | CALL DT_TESTROT(Pi,Po,PHI12,2) | |
36630 | DO ll=1,3 | |
36631 | IF(abs(po(ll)).LT.1.D-07) po(ll)=0. | |
36632 | END DO | |
36633 | p(1,1)=po(1) | |
36634 | p(1,2)=po(2) | |
36635 | p(1,3)=po(3) | |
36636 | ||
36637 | ENUU=P(1,4) | |
36638 | ||
36639 | C...Generate the Mass of the Delta | |
36640 | NTRY = 0 | |
36641 | 100 R = PYR(0) | |
36642 | AMD=AMD0+0.5*GAMD*TAN((2.*R-1.)*ATAN(2.*DELD/GAMD)) | |
36643 | NTRY = NTRY + 1 | |
36644 | IF (NTRY .GT. 1000) THEN | |
36645 | LBAD = 1 | |
36646 | WRITE (LOUT,1001) NBAD, ENUU,AMD,AMDMIN,AMD0,GAMD,ET | |
36647 | RETURN | |
36648 | ENDIF | |
36649 | IF (AMD .LT. AMDMIN) GOTO 100 | |
36650 | ET = ((AMD+AML)**2 - AMN(LTARG)**2)/(2.*AMN(LTARG)) | |
36651 | IF (ENUU .LT. ET) GOTO 100 | |
36652 | ||
36653 | C...Kinematical limits in Q**2 | |
36654 | S = AMN(LTARG)**2 + 2.*AMN(LTARG)*ENUU | |
36655 | SQS = SQRT(S) | |
36656 | PSTAR = (S - AMN(LTARG)**2)/(2.*SQS) | |
36657 | ELF = (S - AMD**2 + AML2)/(2.*SQS) | |
36658 | PLF = SQRT(ELF**2 - AML2) | |
36659 | Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF) | |
36660 | Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF) | |
36661 | IF (Q2MIN .LT. 0.) Q2MIN = 0. | |
36662 | ||
36663 | DSIGMAX = DT_DSIGMA_DELTA(LNU,-Q2MIN, S, AML, AMD) | |
36664 | 200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0) | |
36665 | DSIG = DT_DSIGMA_DELTA(LNU,-Q2, S, AML, AMD) | |
36666 | IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200 | |
36667 | ||
36668 | C...Generate the kinematics of the final particles | |
36669 | EISTAR = (S + AMN(LTARG)**2)/(2.*SQS) | |
36670 | GAM = EISTAR/AMN(LTARG) | |
36671 | BET = PSTAR/EISTAR | |
36672 | CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF) | |
36673 | EL = GAM*(ELF + BET*PLF*CTSTAR) | |
36674 | PLZ = GAM*(PLF*CTSTAR + BET*ELF) | |
36675 | PL = SQRT(EL**2 - AML2) | |
36676 | PLT = SQRT(MAX(1.D-06,(PL*PL - PLZ*PLZ))) | |
36677 | PHI = 6.28319*PYR(0) | |
36678 | P(4,1) = PLT*COS(PHI) | |
36679 | P(4,2) = PLT*SIN(PHI) | |
36680 | P(4,3) = PLZ | |
36681 | P(4,4) = EL | |
36682 | P(4,5) = AML | |
36683 | ||
36684 | C...4-momentum of Delta | |
36685 | P(5,1) = -P(4,1) | |
36686 | P(5,2) = -P(4,2) | |
36687 | P(5,3) = ENUU-P(4,3) | |
36688 | P(5,4) = ENUU+AMN(LTARG)-P(4,4) | |
36689 | P(5,5) = AMD | |
36690 | ||
36691 | C...4-momentum of intermediate boson | |
36692 | P(3,5) = -Q2 | |
36693 | P(3,4) = P(1,4)-P(4,4) | |
36694 | P(3,1) = P(1,1)-P(4,1) | |
36695 | P(3,2) = P(1,2)-P(4,2) | |
36696 | P(3,3) = P(1,3)-P(4,3) | |
36697 | N=5 | |
36698 | ||
36699 | DO kw=1,5 | |
36700 | pi(1)=p(kw,1) | |
36701 | pi(2)=p(kw,2) | |
36702 | pi(3)=p(kw,3) | |
36703 | CALL DT_TESTROT(Pi,Po,PHI12,3) | |
36704 | DO ll=1,3 | |
36705 | IF(abs(po(ll)).LT.1.D-07) po(ll)=0. | |
36706 | END DO | |
36707 | p(kw,1)=po(1) | |
36708 | p(kw,2)=po(2) | |
36709 | p(kw,3)=po(3) | |
36710 | END DO | |
36711 | ||
36712 | c******************************************** | |
36713 | ||
36714 | DO kw=1,5 | |
36715 | pi(1)=p(kw,1) | |
36716 | pi(2)=p(kw,2) | |
36717 | pi(3)=p(kw,3) | |
36718 | CALL DT_TESTROT(Pi,Po,PHI11,4) | |
36719 | DO ll=1,3 | |
36720 | IF(abs(po(ll)).LT.1.D-07) po(ll)=0. | |
36721 | END DO | |
36722 | p(kw,1)=po(1) | |
36723 | p(kw,2)=po(2) | |
36724 | p(kw,3)=po(3) | |
36725 | END DO | |
36726 | c******************************************** | |
36727 | C transform back into Lab. | |
36728 | ||
36729 | CALL PYROBO(0,0,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3) | |
36730 | ||
36731 | C WRITE(6,*)' Lab fram ( fermi incl.) ' | |
36732 | N=5 | |
36733 | CALL PYEXEC | |
36734 | ||
36735 | RETURN | |
36736 | 1001 FORMAT(2X, 'DT_GEN_DELTA : event rejected ', I5, 6G10.3) | |
36737 | END | |
36738 | ||
36739 | *$ CREATE DT_DSIGMA_DELTA.FOR | |
36740 | *COPY DT_DSIGMA_DELTA | |
36741 | * | |
36742 | *===dsigma_delta=======================================================* | |
36743 | * | |
36744 | DOUBLE PRECISION FUNCTION DT_DSIGMA_DELTA (LNU, QQ, S, AML, MD) | |
36745 | ||
36746 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
36747 | SAVE | |
36748 | ||
36749 | C...Reaction nu + N -> lepton + Delta | |
36750 | C. returns the cross section | |
36751 | C. dsigma/dt | |
36752 | C. INPUT LNU = 1, 2 (neutrino-antineutrino) | |
36753 | C. QQ = t (always negative) GeV**2 | |
36754 | C. S = (c.m energy)**2 GeV**2 | |
36755 | C. OUTPUT = 10**-38 cm+2/GeV**2 | |
36756 | C----------------------------------------------------- | |
36757 | REAL*8 MN, MN2, MN4, MD,MD2, MD4 | |
36758 | DATA MN /0.938/ | |
36759 | DATA PI /3.1415926/ | |
36760 | ||
36761 | GF = (1.1664 * 1.97) | |
36762 | GF2 = GF*GF | |
36763 | MN2 = MN*MN | |
36764 | MN4 = MN2*MN2 | |
36765 | MD2 = MD*MD | |
36766 | MD4 = MD2*MD2 | |
36767 | AML2 = AML*AML | |
36768 | AML4 = AML2*AML2 | |
36769 | VQ = (MN2 - MD2 - QQ)/2. | |
36770 | VPI = (MN2 + MD2 - QQ)/2. | |
36771 | VK = (S + QQ - MN2 - AML2)/2. | |
36772 | PIK = (S - MN2)/2. | |
36773 | QK = (AML2 - QQ)/2. | |
36774 | PIQ = (QQ + MN2 - MD2)/2. | |
36775 | Q = SQRT(-QQ) | |
36776 | C3V = 2.07*SQRT(EXP(-6.3*Q)*(1.+9*Q)) | |
36777 | C3 = SQRT(3.)*C3V/MN | |
36778 | C4 = -C3/MD ! attenzione al segno | |
36779 | C5A = 1.18/(1.-QQ/0.4225)**2 | |
36780 | C32 = C3**2 | |
36781 | C42 = C4**2 | |
36782 | C5A2 = C5A**2 | |
36783 | ||
36784 | IF (LNU .EQ. 1) THEN | |
36785 | ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ* | |
36786 | . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42- | |
36787 | . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ* | |
36788 | . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32 | |
36789 | ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK | |
36790 | . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2* | |
36791 | . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD* | |
36792 | . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ* | |
36793 | . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ | |
36794 | . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ- | |
36795 | . 4.*MN*C3*C5A*MD2*VK*QQ+4.*MN*C3*C5A*MD2*VQ*QK-2.*MD* | |
36796 | . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD | |
36797 | . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.* | |
36798 | . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.* | |
36799 | . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK-MD* | |
36800 | . C3*C5A*MD2*PIK*QQ+MD*C3*C5A*MD2*QK*PIQ-3.*MD*C3*C5A | |
36801 | . *VK*VPI*QQ+MD*C3*C5A*VK*VQ*PIQ+3.*MD*C3*C5A*VPI*VQ* | |
36802 | . QK-MD*C3*C5A*VQ**2*PIK+C4*C5A*MD2*VK*VPI*QQ+C4*C5A* | |
36803 | . MD2*VK*VQ*PIQ-C4*C5A*MD2*VPI*VQ*QK-C4*C5A*MD2*VQ**2 | |
36804 | . *PIK-C4*C5A*MD4*PIK*QQ+C4*C5A*MD4*QK*PIQ-2.*MD2*VK | |
36805 | . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK* | |
36806 | . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK | |
36807 | . *C42-2.*MD2*VPI*QK**2*C32+ANS3 | |
36808 | ELSE | |
36809 | ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ* | |
36810 | . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42- | |
36811 | . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ* | |
36812 | . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32 | |
36813 | ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK | |
36814 | . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2* | |
36815 | . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD* | |
36816 | . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ* | |
36817 | . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ | |
36818 | . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ+ | |
36819 | . 4.*MN*C3*C5A*MD2*VK*QQ-4.*MN*C3*C5A*MD2*VQ*QK-2.*MD* | |
36820 | . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD | |
36821 | . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.* | |
36822 | . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.* | |
36823 | . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK+MD* | |
36824 | . C3*C5A*MD2*PIK*QQ-MD*C3*C5A*MD2*QK*PIQ+3.*MD*C3*C5A | |
36825 | . *VK*VPI*QQ-MD*C3*C5A*VK*VQ*PIQ-3.*MD*C3*C5A*VPI*VQ* | |
36826 | . QK+MD*C3*C5A*VQ**2*PIK-C4*C5A*MD2*VK*VPI*QQ-C4*C5A* | |
36827 | . MD2*VK*VQ*PIQ+C4*C5A*MD2*VPI*VQ*QK+C4*C5A*MD2*VQ**2 | |
36828 | . *PIK+C4*C5A*MD4*PIK*QQ-C4*C5A*MD4*QK*PIQ-2.*MD2*VK | |
36829 | . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK* | |
36830 | . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK | |
36831 | . *C42-2.*MD2*VPI*QK**2*C32+ANS3 | |
36832 | ENDIF | |
36833 | ANS1=32.*ANS2 | |
36834 | ANS=ANS1/(3.*MD2) | |
36835 | P1CM = (S-MN2)/(2.*SQRT(S)) | |
36836 | DT_DSIGMA_DELTA = GF2/2. * ANS/(64.*PI*S*P1CM**2) | |
36837 | ||
36838 | RETURN | |
36839 | END | |
36840 | ||
36841 | *$ CREATE DT_QGAUS.FOR | |
36842 | *COPY DT_QGAUS | |
36843 | * | |
36844 | *===qgaus==============================================================* | |
36845 | * | |
36846 | SUBROUTINE DT_QGAUS(A,B,SS,ENU,LTYP) | |
36847 | ||
36848 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
36849 | SAVE | |
36850 | ||
36851 | DIMENSION X(5),W(5) | |
36852 | DATA X/.1488743389D0,.4333953941D0, | |
36853 | & .6794095682D0,.8650633666D0,.9739065285D0 | |
36854 | */ | |
36855 | DATA W/.2955242247D0,.2692667193D0, | |
36856 | & .2190863625D0,.1494513491D0,.0666713443D0 | |
36857 | */ | |
36858 | XM=0.5D0*(B+A) | |
36859 | XR=0.5D0*(B-A) | |
36860 | SS=0 | |
36861 | DO 11 J=1,5 | |
36862 | DX=XR*X(J) | |
36863 | SS=SS+W(J)*(DT_DSQEL_Q2(LTYP,ENU,XM+DX)+ | |
36864 | * DT_DSQEL_Q2(LTYP,ENU,XM-DX)) | |
36865 | 11 CONTINUE | |
36866 | SS=XR*SS | |
36867 | ||
36868 | RETURN | |
36869 | END | |
36870 | ||
36871 | *$ CREATE DT_DIQBRK.FOR | |
36872 | *COPY DT_DIQBRK | |
36873 | * | |
36874 | *===diqbrk=============================================================* | |
36875 | * | |
36876 | SUBROUTINE DT_DIQBRK | |
36877 | ||
36878 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
36879 | SAVE | |
36880 | ||
36881 | * event history | |
36882 | PARAMETER (NMXHKK=200000) | |
36883 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
36884 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
36885 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
36886 | * extended event history | |
36887 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
36888 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
36889 | & IHIST(2,NMXHKK) | |
36890 | * event flag | |
36891 | COMMON /DTEVNO/ NEVENT,ICASCA | |
36892 | ||
36893 | C IF(DT_RNDM(VV).LE.0.5D0)THEN | |
36894 | C CALL GSQBS1(NHKK) | |
36895 | C CALL GSQBS2(NHKK) | |
36896 | C CALL USQBS1(NHKK) | |
36897 | C CALL USQBS2(NHKK) | |
36898 | C CALL GSABS1(NHKK) | |
36899 | C CALL GSABS2(NHKK) | |
36900 | C CALL USABS1(NHKK) | |
36901 | C CALL USABS2(NHKK) | |
36902 | C ELSE | |
36903 | C CALL GSQBS2(NHKK) | |
36904 | C CALL GSQBS1(NHKK) | |
36905 | C CALL USQBS2(NHKK) | |
36906 | C CALL USQBS1(NHKK) | |
36907 | C CALL GSABS2(NHKK) | |
36908 | C CALL GSABS1(NHKK) | |
36909 | C CALL USABS2(NHKK) | |
36910 | C CALL USABS1(NHKK) | |
36911 | C ENDIF | |
36912 | ||
36913 | IF(DT_RNDM(VV).LE.0.5D0) THEN | |
36914 | CALL DT_DBREAK(1) | |
36915 | CALL DT_DBREAK(2) | |
36916 | CALL DT_DBREAK(3) | |
36917 | CALL DT_DBREAK(4) | |
36918 | CALL DT_DBREAK(5) | |
36919 | CALL DT_DBREAK(6) | |
36920 | CALL DT_DBREAK(7) | |
36921 | CALL DT_DBREAK(8) | |
36922 | ELSE | |
36923 | CALL DT_DBREAK(2) | |
36924 | CALL DT_DBREAK(1) | |
36925 | CALL DT_DBREAK(4) | |
36926 | CALL DT_DBREAK(3) | |
36927 | CALL DT_DBREAK(6) | |
36928 | CALL DT_DBREAK(5) | |
36929 | CALL DT_DBREAK(8) | |
36930 | CALL DT_DBREAK(7) | |
36931 | ENDIF | |
36932 | ||
36933 | RETURN | |
36934 | END | |
36935 | ||
36936 | *$ CREATE MUSQBS2.FOR | |
36937 | *COPY MUSQBS2 | |
36938 | C | |
36939 | C | |
36940 | C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ | |
36941 | SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, | |
36942 | * IP1,IP21,IP22,IPP1,IPP2,IPIP,ISQ,IGCOUN) | |
36943 | C | |
36944 | C USQBS-2 diagram (split target diquark) | |
36945 | C | |
36946 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
36947 | SAVE | |
36948 | ||
36949 | PARAMETER ( LINP = 10 , | |
36950 | & LOUT = 6 , | |
36951 | & LDAT = 9 ) | |
36952 | * event history | |
36953 | PARAMETER (NMXHKK=200000) | |
36954 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
36955 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
36956 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
36957 | * extended event history | |
36958 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
36959 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
36960 | & IHIST(2,NMXHKK) | |
36961 | * Lorentz-parameters of the current interaction | |
36962 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
36963 | & UMO,PPCM,EPROJ,PPROJ | |
36964 | * diquark-breaking mechanism | |
36965 | COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3 | |
36966 | ||
36967 | C | |
36968 | PARAMETER (NTMHKK= 300) | |
36969 | COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT | |
36970 | +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT | |
36971 | +(4,NTMHKK) | |
36972 | *KEEP,XSEADI. | |
36973 | COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA, | |
36974 | +SSMIMQ,VVMTHR | |
36975 | *KEEP,DPRIN. | |
36976 | COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR | |
36977 | COMMON /EVFLAG/ NUMEV | |
36978 | C | |
36979 | C USQBS-2 diagram (split target diquark) | |
36980 | C | |
36981 | C | |
36982 | C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T) | |
36983 | C Input chain 2(NC2) sea-antiquark(NC2P)-sea-quark(NC2T) | |
36984 | C | |
36985 | C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T | |
36986 | C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T | |
36987 | C | |
36988 | C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2) | |
36989 | C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5) | |
36990 | C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8) | |
36991 | C | |
36992 | C | |
36993 | C Put new chains into COMMON /HKKTMP/ | |
36994 | C | |
36995 | IIGLU1=NC1T-NC1P-1 | |
36996 | IIGLU2=NC2T-NC2P-1 | |
36997 | IGCOUN=0 | |
36998 | C WRITE(LOUT,*)'MUSQBS2: IIGLU1,IIGLU2 ',IIGLU1,IIGLU2 | |
36999 | CVQ=1.D0 | |
37000 | IREJ=0 | |
37001 | IF(IPIP.EQ.2)THEN | |
37002 | C IF(NUMEV.EQ.-324)THEN | |
37003 | C WRITE(LOUT,*)' MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,', | |
37004 | C * 'IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN)', | |
37005 | C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, | |
37006 | C * IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN | |
37007 | ENDIF | |
37008 | C | |
37009 | C | |
37010 | C | |
37011 | C determine x-values of NC1T diquark | |
37012 | XDIQT=PHKK(4,NC1T)*2.D0/UMO | |
37013 | XVQP=PHKK(4,NC1P)*2.D0/UMO | |
37014 | C | |
37015 | C determine x-values of sea quark pair | |
37016 | C | |
37017 | IPCO=1 | |
37018 | ICOU=0 | |
37019 | 2234 CONTINUE | |
37020 | ICOU=ICOU+1 | |
37021 | IF(ICOU.GE.500)THEN | |
37022 | IREJ=1 | |
37023 | IF(ISQ.EQ.3)IREJ=3 | |
37024 | IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 2234 ICOU. GT.500' | |
37025 | IPCO=0 | |
37026 | RETURN | |
37027 | ENDIF | |
37028 | IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS2 call XSEAPA: UMO,XDIQT,XVQP ', | |
37029 | * UMO, XDIQT,XVQP | |
37030 | XSQ=0.D0 | |
37031 | XSAQ=0.D0 | |
37032 | **NEW | |
37033 | C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ) | |
37034 | IF (IPIP.EQ.1) THEN | |
37035 | XQMAX = XDIQT/2.0D0 | |
37036 | XAQMAX = 2.D0*XVQP/3.0D0 | |
37037 | ELSE | |
37038 | XQMAX = 2.D0*XVQP/3.0D0 | |
37039 | XAQMAX = XDIQT/2.0D0 | |
37040 | ENDIF | |
37041 | CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ) | |
37042 | ISAQ = 6+ISQ | |
37043 | C write(*,*) 'MUSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP | |
37044 | ** | |
37045 | IF(IPCO.GE.3) | |
37046 | & WRITE(LOUT,*)'MUSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ | |
37047 | IF(IREJ.GE.1)THEN | |
37048 | IF(IPCO.GE.3) | |
37049 | & WRITE(LOUT,*)'MUSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ | |
37050 | IPCO=0 | |
37051 | RETURN | |
37052 | ENDIF | |
37053 | IF(IPIP.EQ.1)THEN | |
37054 | IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234 | |
37055 | ELSEIF(IPIP.EQ.2)THEN | |
37056 | IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234 | |
37057 | ENDIF | |
37058 | IF(IPCO.GE.3)THEN | |
37059 | WRITE(LOUT,'(A,4E12.4)')' MUSQBS2 XDIQT,XVQP,XSQ,XSAQ ', | |
37060 | * XDIQT,XVQP,XSQ,XSAQ | |
37061 | ENDIF | |
37062 | C | |
37063 | C subtract xsq,xsaq from NC1T diquark and NC1P quark | |
37064 | C | |
37065 | C XSQ=0.D0 | |
37066 | IF(IPIP.EQ.1)THEN | |
37067 | XDIQT=XDIQT-XSQ | |
37068 | XVQP =XVQP -XSAQ | |
37069 | ELSEIF(IPIP.EQ.2)THEN | |
37070 | XDIQT=XDIQT-XSAQ | |
37071 | XVQP =XVQP -XSQ | |
37072 | ENDIF | |
37073 | IF(IPCO.GE.3) | |
37074 | & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP | |
37075 | C | |
37076 | C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T | |
37077 | C | |
37078 | XVTHRO=CVQ/UMO | |
37079 | IVTHR=0 | |
37080 | 3466 CONTINUE | |
37081 | IF(IVTHR.EQ.10)THEN | |
37082 | IREJ=1 | |
37083 | IF(ISQ.EQ.3)IREJ=3 | |
37084 | IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 3466 reject IVTHR 10' | |
37085 | IPCO=0 | |
37086 | RETURN | |
37087 | ENDIF | |
37088 | IVTHR=IVTHR+1 | |
37089 | XVTHR=XVTHRO/(201-IVTHR) | |
37090 | UNOPRV=UNON | |
37091 | 380 CONTINUE | |
37092 | IF(XVTHR.GT.0.66D0*XDIQT)THEN | |
37093 | IREJ=1 | |
37094 | IF(ISQ.EQ.3)IREJ=3 | |
37095 | IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 380 XVTHR large ', | |
37096 | * XVTHR | |
37097 | IPCO=0 | |
37098 | RETURN | |
37099 | ENDIF | |
37100 | IF(DT_RNDM(V).LT.0.5D0)THEN | |
37101 | XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT) | |
37102 | XVTQII=XDIQT-XVTQI | |
37103 | ELSE | |
37104 | XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT) | |
37105 | XVTQI=XDIQT-XVTQII | |
37106 | ENDIF | |
37107 | IF(IPCO.GE.3)THEN | |
37108 | WRITE(LOUT,'(A,2E12.4)')' MUSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII | |
37109 | ENDIF | |
37110 | C | |
37111 | C Prepare 4 momenta of new chains and chain ends | |
37112 | C | |
37113 | C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT | |
37114 | C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT | |
37115 | C +(4,NTMHKK) | |
37116 | C | |
37117 | C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2) | |
37118 | C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5) | |
37119 | C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8) | |
37120 | C | |
37121 | C SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, | |
37122 | C * IP1,IP21,IP22,IPP1,IPP2) | |
37123 | C | |
37124 | IF(IPIP.EQ.1)THEN | |
37125 | XSQ1=XSQ | |
37126 | XSAQ1=XSAQ | |
37127 | ISQ1=ISQ | |
37128 | ISAQ1=ISAQ | |
37129 | ELSEIF(IPIP.EQ.2)THEN | |
37130 | XSQ1=XSAQ | |
37131 | XSAQ1=XSQ | |
37132 | ISQ1=ISAQ | |
37133 | ISAQ1=ISQ | |
37134 | ENDIF | |
37135 | IDHKT(1) =IPP1 | |
37136 | ISTHKT(1) =951 | |
37137 | JMOHKT(1,1)=NC2P | |
37138 | JMOHKT(2,1)=0 | |
37139 | JDAHKT(1,1)=3+IIGLU1 | |
37140 | JDAHKT(2,1)=0 | |
37141 | C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2) | |
37142 | PHKT(1,1) =PHKK(1,NC2P) | |
37143 | PHKT(2,1) =PHKK(2,NC2P) | |
37144 | PHKT(3,1) =PHKK(3,NC2P) | |
37145 | PHKT(4,1) =PHKK(4,NC2P) | |
37146 | C PHKT(5,1) =PHKK(5,NC2P) | |
37147 | XMIST =(PHKT(4,1)**2- | |
37148 | * PHKT(3,1)**2-PHKT(2,1)**2- | |
37149 | *PHKT(1,1)**2) | |
37150 | IF(XMIST.GT.0.D0)THEN | |
37151 | PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2- | |
37152 | *PHKT(1,1)**2) | |
37153 | ELSE | |
37154 | C WRITE(LOUT,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST | |
37155 | PHKT(5,1)=0.D0 | |
37156 | ENDIF | |
37157 | VHKT(1,1) =VHKK(1,NC2P) | |
37158 | VHKT(2,1) =VHKK(2,NC2P) | |
37159 | VHKT(3,1) =VHKK(3,NC2P) | |
37160 | VHKT(4,1) =VHKK(4,NC2P) | |
37161 | WHKT(1,1) =WHKK(1,NC2P) | |
37162 | WHKT(2,1) =WHKK(2,NC2P) | |
37163 | WHKT(3,1) =WHKK(3,NC2P) | |
37164 | WHKT(4,1) =WHKK(4,NC2P) | |
37165 | C Add here IIGLU1 gluons to this chaina | |
37166 | PG1=0.D0 | |
37167 | PG2=0.D0 | |
37168 | PG3=0.D0 | |
37169 | PG4=0.D0 | |
37170 | IF(IIGLU1.GE.1)THEN | |
37171 | JJG=NC1P | |
37172 | DO 61 IIG=2,2+IIGLU1-1 | |
37173 | KKG=JJG+IIG-1 | |
37174 | IDHKT(IIG) =IDHKK(KKG) | |
37175 | ISTHKT(IIG) =921 | |
37176 | JMOHKT(1,IIG)=KKG | |
37177 | JMOHKT(2,IIG)=0 | |
37178 | JDAHKT(1,IIG)=3+IIGLU1 | |
37179 | JDAHKT(2,IIG)=0 | |
37180 | PHKT(1,IIG)=PHKK(1,KKG) | |
37181 | PG1=PG1+ PHKT(1,IIG) | |
37182 | PHKT(2,IIG)=PHKK(2,KKG) | |
37183 | PG2=PG2+ PHKT(2,IIG) | |
37184 | PHKT(3,IIG)=PHKK(3,KKG) | |
37185 | PG3=PG3+ PHKT(3,IIG) | |
37186 | PHKT(4,IIG)=PHKK(4,KKG) | |
37187 | PG4=PG4+ PHKT(4,IIG) | |
37188 | PHKT(5,IIG)=PHKK(5,KKG) | |
37189 | VHKT(1,IIG) =VHKK(1,KKG) | |
37190 | VHKT(2,IIG) =VHKK(2,KKG) | |
37191 | VHKT(3,IIG) =VHKK(3,KKG) | |
37192 | VHKT(4,IIG) =VHKK(4,KKG) | |
37193 | WHKT(1,IIG) =WHKK(1,KKG) | |
37194 | WHKT(2,IIG) =WHKK(2,KKG) | |
37195 | WHKT(3,IIG) =WHKK(3,KKG) | |
37196 | WHKT(4,IIG) =WHKK(4,KKG) | |
37197 | 61 CONTINUE | |
37198 | ENDIF | |
37199 | IDHKT(2+IIGLU1) =IP21 | |
37200 | ISTHKT(2+IIGLU1) =952 | |
37201 | JMOHKT(1,2+IIGLU1)=NC1T | |
37202 | JMOHKT(2,2+IIGLU1)=0 | |
37203 | JDAHKT(1,2+IIGLU1)=3+IIGLU1 | |
37204 | JDAHKT(2,2+IIGLU1)=0 | |
37205 | PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1) | |
37206 | PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1) | |
37207 | PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1) | |
37208 | PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1) | |
37209 | C PHKT(5,2) =PHKK(5,NC1T) | |
37210 | XMIST =(PHKT(4,2+IIGLU1)**2- | |
37211 | * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2- | |
37212 | *PHKT(1,2+IIGLU1)**2) | |
37213 | IF(XMIST.GT.0.D0)THEN | |
37214 | PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2- | |
37215 | * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2- | |
37216 | *PHKT(1,2+IIGLU1)**2) | |
37217 | ELSE | |
37218 | C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST | |
37219 | PHKT(5,5+IIGLU1)=0.D0 | |
37220 | ENDIF | |
37221 | VHKT(1,2+IIGLU1) =VHKK(1,NC1T) | |
37222 | VHKT(2,2+IIGLU1) =VHKK(2,NC1T) | |
37223 | VHKT(3,2+IIGLU1) =VHKK(3,NC1T) | |
37224 | VHKT(4,2+IIGLU1) =VHKK(4,NC1T) | |
37225 | WHKT(1,2+IIGLU1) =WHKK(1,NC1T) | |
37226 | WHKT(2,2+IIGLU1) =WHKK(2,NC1T) | |
37227 | WHKT(3,2+IIGLU1) =WHKK(3,NC1T) | |
37228 | WHKT(4,2+IIGLU1) =WHKK(4,NC1T) | |
37229 | IDHKT(3+IIGLU1) =88888 | |
37230 | ISTHKT(3+IIGLU1) =95 | |
37231 | JMOHKT(1,3+IIGLU1)=1 | |
37232 | JMOHKT(2,3+IIGLU1)=2+IIGLU1 | |
37233 | JDAHKT(1,3+IIGLU1)=0 | |
37234 | JDAHKT(2,3+IIGLU1)=0 | |
37235 | PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1 | |
37236 | PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2 | |
37237 | PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3 | |
37238 | PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4 | |
37239 | XMIST | |
37240 | * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2 | |
37241 | * -PHKT(3,3+IIGLU1)**2) | |
37242 | IF(XMIST.GT.0.D0)THEN | |
37243 | PHKT(5,3+IIGLU1) | |
37244 | * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2 | |
37245 | * -PHKT(3,3+IIGLU1)**2) | |
37246 | ELSE | |
37247 | C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST | |
37248 | PHKT(5,5+IIGLU1)=0.D0 | |
37249 | ENDIF | |
37250 | IF(IPIP.GE.2)THEN | |
37251 | C IF(NUMEV.EQ.-324)THEN | |
37252 | C WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1), | |
37253 | C * JDAHKT(1,1), | |
37254 | C *JDAHKT(2,1),(PHKT(III,1),III=1,5) | |
37255 | DO 71 IIG=2,2+IIGLU1-1 | |
37256 | C WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG), | |
37257 | C & JMOHKT(1,IIG),JMOHKT(2,IIG), | |
37258 | C * JDAHKT(1,IIG), | |
37259 | C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) | |
37260 | 71 CONTINUE | |
37261 | C WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1), | |
37262 | C * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1), | |
37263 | C *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5) | |
37264 | C WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1), | |
37265 | C * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1), | |
37266 | C *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5) | |
37267 | ENDIF | |
37268 | CHAMAL=CHAM1 | |
37269 | IF(IPIP.EQ.1)THEN | |
37270 | IF(IPP1.LE.-3.OR.IP21.GE.3)CHAMAL=CHAM3 | |
37271 | ELSEIF(IPIP.EQ.2)THEN | |
37272 | IF(IPP1.GE.3.OR.IP21.LE.-3)CHAMAL=CHAM3 | |
37273 | ENDIF | |
37274 | IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN | |
37275 | C IREJ=1 | |
37276 | IPCO=0 | |
37277 | C RETURN | |
37278 | C WRITE(LOUT,*)' MUSQBS1 jump back from chain 3' | |
37279 | GO TO 3466 | |
37280 | ENDIF | |
37281 | VHKT(1,3+IIGLU1) =VHKK(1,NC1) | |
37282 | VHKT(2,3+IIGLU1) =VHKK(2,NC1) | |
37283 | VHKT(3,3+IIGLU1) =VHKK(3,NC1) | |
37284 | VHKT(4,3+IIGLU1) =VHKK(4,NC1) | |
37285 | WHKT(1,3+IIGLU1) =WHKK(1,NC1) | |
37286 | WHKT(2,3+IIGLU1) =WHKK(2,NC1) | |
37287 | WHKT(3,3+IIGLU1) =WHKK(3,NC1) | |
37288 | WHKT(4,3+IIGLU1) =WHKK(4,NC1) | |
37289 | IF(IPIP.EQ.1)THEN | |
37290 | IDHKT(4+IIGLU1) =-(ISAQ1-6) | |
37291 | ELSEIF(IPIP.EQ.2)THEN | |
37292 | IDHKT(4+IIGLU1) =ISAQ1 | |
37293 | ENDIF | |
37294 | ISTHKT(4+IIGLU1) =951 | |
37295 | JMOHKT(1,4+IIGLU1)=NC1P | |
37296 | JMOHKT(2,4+IIGLU1)=0 | |
37297 | JDAHKT(1,4+IIGLU1)=6+IIGLU1 | |
37298 | JDAHKT(2,4+IIGLU1)=0 | |
37299 | C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5) | |
37300 | PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1) | |
37301 | PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1) | |
37302 | PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1) | |
37303 | PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1) | |
37304 | C PHKT(5,4+IIGLU1) =PHKK(5,NC1P) | |
37305 | XMIST =(PHKT(4,4+IIGLU1)**2- | |
37306 | * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2- | |
37307 | *PHKT(1,4+IIGLU1)**2) | |
37308 | IF(XMIST.GT.0.D0)THEN | |
37309 | PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2- | |
37310 | * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2- | |
37311 | *PHKT(1,4+IIGLU1)**2) | |
37312 | ELSE | |
37313 | C WRITE(LOUT,*)'MUSQBS2 parton 4 mass square LT.0 ',XMIST | |
37314 | PHKT(5,4+IIGLU1)=0.D0 | |
37315 | ENDIF | |
37316 | VHKT(1,4+IIGLU1) =VHKK(1,NC1P) | |
37317 | VHKT(2,4+IIGLU1) =VHKK(2,NC1P) | |
37318 | VHKT(3,4+IIGLU1) =VHKK(3,NC1P) | |
37319 | VHKT(4,4+IIGLU1) =VHKK(4,NC1P) | |
37320 | WHKT(1,4+IIGLU1) =WHKK(1,NC1P) | |
37321 | WHKT(2,4+IIGLU1) =WHKK(2,NC1P) | |
37322 | WHKT(3,4+IIGLU1) =WHKK(3,NC1P) | |
37323 | WHKT(4,4+IIGLU1) =WHKK(4,NC1P) | |
37324 | IDHKT(5+IIGLU1) =IP22 | |
37325 | ISTHKT(5+IIGLU1) =952 | |
37326 | JMOHKT(1,5+IIGLU1)=NC1T | |
37327 | JMOHKT(2,5+IIGLU1)=0 | |
37328 | JDAHKT(1,5+IIGLU1)=6+IIGLU1 | |
37329 | JDAHKT(2,5+IIGLU1)=0 | |
37330 | PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1) | |
37331 | PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1) | |
37332 | PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1) | |
37333 | PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1) | |
37334 | C PHKT(5,5+IIGLU1) =PHKK(5,NC1T) | |
37335 | XMIST =(PHKT(4,5+IIGLU1)**2- | |
37336 | * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2- | |
37337 | *PHKT(1,5+IIGLU1)**2) | |
37338 | IF(XMIST.GT.0.D0)THEN | |
37339 | PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2- | |
37340 | * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2- | |
37341 | *PHKT(1,5+IIGLU1)**2) | |
37342 | ELSE | |
37343 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST | |
37344 | PHKT(5,5+IIGLU1)=0.D0 | |
37345 | ENDIF | |
37346 | VHKT(1,5+IIGLU1) =VHKK(1,NC1T) | |
37347 | VHKT(2,5+IIGLU1) =VHKK(2,NC1T) | |
37348 | VHKT(3,5+IIGLU1) =VHKK(3,NC1T) | |
37349 | VHKT(4,5+IIGLU1) =VHKK(4,NC1T) | |
37350 | WHKT(1,5+IIGLU1) =WHKK(1,NC1T) | |
37351 | WHKT(2,5+IIGLU1) =WHKK(2,NC1T) | |
37352 | WHKT(3,5+IIGLU1) =WHKK(3,NC1T) | |
37353 | WHKT(4,5+IIGLU1) =WHKK(4,NC1T) | |
37354 | IDHKT(6+IIGLU1) =88888 | |
37355 | ISTHKT(6+IIGLU1) =95 | |
37356 | JMOHKT(1,6+IIGLU1)=4+IIGLU1 | |
37357 | JMOHKT(2,6+IIGLU1)=5+IIGLU1 | |
37358 | JDAHKT(1,6+IIGLU1)=0 | |
37359 | JDAHKT(2,6+IIGLU1)=0 | |
37360 | PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1) | |
37361 | PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1) | |
37362 | PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1) | |
37363 | PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1) | |
37364 | XMIST | |
37365 | * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2 | |
37366 | * -PHKT(3,6+IIGLU1)**2) | |
37367 | IF(XMIST.GT.0.D0)THEN | |
37368 | PHKT(5,6+IIGLU1) | |
37369 | * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2 | |
37370 | * -PHKT(3,6+IIGLU1)**2) | |
37371 | ELSE | |
37372 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST | |
37373 | PHKT(5,5+IIGLU1)=0.D0 | |
37374 | ENDIF | |
37375 | C IF(IPIP.GE.2)THEN | |
37376 | C IF(NUMEV.EQ.-324)THEN | |
37377 | C WRITE(6,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1), | |
37378 | C * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1), | |
37379 | C *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5) | |
37380 | C WRITE(6,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1), | |
37381 | C * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1), | |
37382 | C *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5) | |
37383 | C WRITE(6,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1), | |
37384 | C * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1), | |
37385 | C *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5) | |
37386 | C ENDIF | |
37387 | CHAMAL=CHAM1 | |
37388 | IF(IPIP.EQ.1)THEN | |
37389 | IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3 | |
37390 | ELSEIF(IPIP.EQ.2)THEN | |
37391 | IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3 | |
37392 | ENDIF | |
37393 | IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN | |
37394 | C IREJ=1 | |
37395 | IPCO=0 | |
37396 | C RETURN | |
37397 | C WRITE(6,*)' MUSQBS1 jump back from chain 6', | |
37398 | C * CHAMAL,PHKT(5,6+IIGLU1) | |
37399 | GO TO 3466 | |
37400 | ENDIF | |
37401 | VHKT(1,6+IIGLU1) =VHKK(1,NC1) | |
37402 | VHKT(2,6+IIGLU1) =VHKK(2,NC1) | |
37403 | VHKT(3,6+IIGLU1) =VHKK(3,NC1) | |
37404 | VHKT(4,6+IIGLU1) =VHKK(4,NC1) | |
37405 | WHKT(1,6+IIGLU1) =WHKK(1,NC1) | |
37406 | WHKT(2,6+IIGLU1) =WHKK(2,NC1) | |
37407 | WHKT(3,6+IIGLU1) =WHKK(3,NC1) | |
37408 | WHKT(4,6+IIGLU1) =WHKK(4,NC1) | |
37409 | C IDHKT(7) =1000*IPP1+100*ISQ+1 | |
37410 | IDHKT(7+IIGLU1) =IP1 | |
37411 | ISTHKT(7+IIGLU1) =951 | |
37412 | JMOHKT(1,7+IIGLU1)=NC1P | |
37413 | JMOHKT(2,7+IIGLU1)=0 | |
37414 | **NEW | |
37415 | C JDAHKT(1,7+IIGLU1)=9+IIGLU1 | |
37416 | JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2 | |
37417 | ** | |
37418 | JDAHKT(2,7+IIGLU1)=0 | |
37419 | PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1) | |
37420 | PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1) | |
37421 | PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1) | |
37422 | PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1) | |
37423 | C PHKT(5,7+IIGLU1) =PHKK(5,NC1P) | |
37424 | XMIST =(PHKT(4,7+IIGLU1)**2- | |
37425 | * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2- | |
37426 | *PHKT(1,7+IIGLU1)**2) | |
37427 | IF(XMIST.GT.0.D0)THEN | |
37428 | PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2- | |
37429 | * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2- | |
37430 | *PHKT(1,7+IIGLU1)**2) | |
37431 | ELSE | |
37432 | C WRITE(6,*)'MUSQBS2 parton 7 mass square LT.0 ',XMIST | |
37433 | PHKT(5,7+IIGLU1)=0.D0 | |
37434 | ENDIF | |
37435 | VHKT(1,7+IIGLU1) =VHKK(1,NC1P) | |
37436 | VHKT(2,7+IIGLU1) =VHKK(2,NC1P) | |
37437 | VHKT(3,7+IIGLU1) =VHKK(3,NC1P) | |
37438 | VHKT(4,7+IIGLU1) =VHKK(4,NC1P) | |
37439 | WHKT(1,7+IIGLU1) =WHKK(1,NC1P) | |
37440 | WHKT(2,7+IIGLU1) =WHKK(2,NC1P) | |
37441 | WHKT(3,7+IIGLU1) =WHKK(3,NC1P) | |
37442 | WHKT(4,7+IIGLU1) =WHKK(4,NC2P) | |
37443 | C Insert here the IIGLU2 gluons | |
37444 | PG1=0.D0 | |
37445 | PG2=0.D0 | |
37446 | PG3=0.D0 | |
37447 | PG4=0.D0 | |
37448 | IF(IIGLU2.GE.1)THEN | |
37449 | JJG=NC2P | |
37450 | DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 | |
37451 | KKG=JJG+IIG-7-IIGLU1 | |
37452 | IDHKT(IIG) =IDHKK(KKG) | |
37453 | ISTHKT(IIG) =921 | |
37454 | JMOHKT(1,IIG)=KKG | |
37455 | JMOHKT(2,IIG)=0 | |
37456 | JDAHKT(1,IIG)=9+IIGLU1+IIGLU2 | |
37457 | JDAHKT(2,IIG)=0 | |
37458 | PHKT(1,IIG)=PHKK(1,KKG) | |
37459 | PG1=PG1+ PHKT(1,IIG) | |
37460 | PHKT(2,IIG)=PHKK(2,KKG) | |
37461 | PG2=PG2+ PHKT(2,IIG) | |
37462 | PHKT(3,IIG)=PHKK(3,KKG) | |
37463 | PG3=PG3+ PHKT(3,IIG) | |
37464 | PHKT(4,IIG)=PHKK(4,KKG) | |
37465 | PG4=PG4+ PHKT(4,IIG) | |
37466 | PHKT(5,IIG)=PHKK(5,KKG) | |
37467 | VHKT(1,IIG) =VHKK(1,KKG) | |
37468 | VHKT(2,IIG) =VHKK(2,KKG) | |
37469 | VHKT(3,IIG) =VHKK(3,KKG) | |
37470 | VHKT(4,IIG) =VHKK(4,KKG) | |
37471 | WHKT(1,IIG) =WHKK(1,KKG) | |
37472 | WHKT(2,IIG) =WHKK(2,KKG) | |
37473 | WHKT(3,IIG) =WHKK(3,KKG) | |
37474 | WHKT(4,IIG) =WHKK(4,KKG) | |
37475 | 81 CONTINUE | |
37476 | ENDIF | |
37477 | IF(IPIP.EQ.1)THEN | |
37478 | IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3 | |
37479 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103 | |
37480 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103 | |
37481 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203 | |
37482 | ELSEIF(IPIP.EQ.2)THEN | |
37483 | IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3 | |
37484 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103 | |
37485 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103 | |
37486 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203 | |
37487 | ENDIF | |
37488 | ISTHKT(8+IIGLU1+IIGLU2) =952 | |
37489 | JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T | |
37490 | JMOHKT(2,8+IIGLU1+IIGLU2)=0 | |
37491 | JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2 | |
37492 | JDAHKT(2,8+IIGLU1+IIGLU2)=0 | |
37493 | PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC2T)+ | |
37494 | * PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1) | |
37495 | PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC2T)+ | |
37496 | * PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1) | |
37497 | PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC2T)+ | |
37498 | * PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1) | |
37499 | PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC2T)+ | |
37500 | * PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1) | |
37501 | C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)', | |
37502 | C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7) | |
37503 | IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN | |
37504 | C IREJ=1 | |
37505 | C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)' | |
37506 | C * ,PHKT(4,8+IIGLU1+IIGLU2), PHKK(4,NC2T),NC2T | |
37507 | IPCO=0 | |
37508 | C RETURN | |
37509 | GO TO 3466 | |
37510 | ENDIF | |
37511 | C PHKT(5,8) =PHKK(5,NC2T) | |
37512 | XMIST =(PHKT(4,8+IIGLU1+IIGLU2)**2- | |
37513 | * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2- | |
37514 | *PHKT(1,8+IIGLU1+IIGLU2)**2) | |
37515 | IF(XMIST.GT.0.D0)THEN | |
37516 | PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2- | |
37517 | * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2- | |
37518 | *PHKT(1,8+IIGLU1+IIGLU2)**2) | |
37519 | ELSE | |
37520 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST | |
37521 | PHKT(5,5+IIGLU1)=0.D0 | |
37522 | ENDIF | |
37523 | VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T) | |
37524 | VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T) | |
37525 | VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T) | |
37526 | VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T) | |
37527 | WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T) | |
37528 | WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T) | |
37529 | WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T) | |
37530 | WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T) | |
37531 | IDHKT(9+IIGLU1+IIGLU2) =88888 | |
37532 | ISTHKT(9+IIGLU1+IIGLU2) =95 | |
37533 | JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1 | |
37534 | JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2 | |
37535 | JDAHKT(1,9+IIGLU1+IIGLU2)=0 | |
37536 | JDAHKT(2,9+IIGLU1+IIGLU2)=0 | |
37537 | **NEW | |
37538 | C PHKT(1,9+IIGLU1+IIGLU2) | |
37539 | C * =PHKT(1,7+IIGLU1+IIGLU2)+PHKT(1,8+IIGLU1+IIGLU2)+PG1 | |
37540 | C PHKT(2,9+IIGLU1+IIGLU2) | |
37541 | C * =PHKT(2,7+IIGLU1+IIGLU2)+PHKT(2,8+IIGLU1+IIGLU2)+PG2 | |
37542 | C PHKT(3,9+IIGLU1+IIGLU2) | |
37543 | C * =PHKT(3,7+IIGLU1+IIGLU2)+PHKT(3,8+IIGLU1+IIGLU2)+PG3 | |
37544 | C PHKT(4,9+IIGLU1+IIGLU2) | |
37545 | C * =PHKT(4,7+IIGLU1+IIGLU2)+PHKT(4,8+IIGLU1+IIGLU2)+PG4 | |
37546 | PHKT(1,9+IIGLU1+IIGLU2) | |
37547 | * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1 | |
37548 | PHKT(2,9+IIGLU1+IIGLU2) | |
37549 | * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2 | |
37550 | PHKT(3,9+IIGLU1+IIGLU2) | |
37551 | * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3 | |
37552 | PHKT(4,9+IIGLU1+IIGLU2) | |
37553 | * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4 | |
37554 | ** | |
37555 | XMIST | |
37556 | * =(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2 | |
37557 | * -PHKT(2,9+IIGLU1+IIGLU2)**2 | |
37558 | * -PHKT(3,9+IIGLU1+IIGLU2)**2) | |
37559 | IF(XMIST.GT.0.D0)THEN | |
37560 | PHKT(5,9+IIGLU1+IIGLU2) | |
37561 | * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2 | |
37562 | * -PHKT(2,9+IIGLU1+IIGLU2)**2 | |
37563 | * -PHKT(3,9+IIGLU1+IIGLU2)**2) | |
37564 | ELSE | |
37565 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST | |
37566 | PHKT(5,5+IIGLU1)=0.D0 | |
37567 | ENDIF | |
37568 | IF(IPIP.GE.2)THEN | |
37569 | C IF(NUMEV.EQ.-324)THEN | |
37570 | C WRITE(6,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1), | |
37571 | C * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1), | |
37572 | C *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5) | |
37573 | C DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 | |
37574 | C WRITE(6,*)IIG,ISTHKT(IIG),IDHKT(IIG),JMOHKT(1,IIG),JMOHKT(2,IIG), | |
37575 | C * JDAHKT(1,IIG), | |
37576 | C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) | |
37577 | C 91 CONTINUE | |
37578 | C WRITE(6,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2), | |
37579 | C * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2), | |
37580 | C *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2), | |
37581 | C *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5) | |
37582 | C WRITE(6,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2), | |
37583 | C * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2), | |
37584 | C *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2), | |
37585 | C *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5) | |
37586 | ENDIF | |
37587 | CHAMAL=CHAB1 | |
37588 | IF(IPIP.EQ.1)THEN | |
37589 | IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3 | |
37590 | ELSEIF(IPIP.EQ.2)THEN | |
37591 | IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3 | |
37592 | ENDIF | |
37593 | IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN | |
37594 | C IREJ=1 | |
37595 | IPCO=0 | |
37596 | C RETURN | |
37597 | C WRITE(6,*)' MUSQBS1 jump back from chain 9', | |
37598 | C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2) | |
37599 | GO TO 3466 | |
37600 | ENDIF | |
37601 | VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1) | |
37602 | VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1) | |
37603 | VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1) | |
37604 | VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1) | |
37605 | WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1) | |
37606 | WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1) | |
37607 | WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1) | |
37608 | WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1) | |
37609 | C | |
37610 | IPCO=0 | |
37611 | IGCOUN=9+IIGLU1+IIGLU2 | |
37612 | RETURN | |
37613 | END | |
37614 | ||
37615 | *$ CREATE MGSQBS2.FOR | |
37616 | *COPY MGSQBS2 | |
37617 | C | |
37618 | C | |
37619 | C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ | |
37620 | SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, | |
37621 | * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,ISQ,IGCOUN) | |
37622 | C | |
37623 | C GSQBS-2 diagram (split target diquark) | |
37624 | C | |
37625 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
37626 | SAVE | |
37627 | ||
37628 | PARAMETER ( LINP = 10 , | |
37629 | & LOUT = 6 , | |
37630 | & LDAT = 9 ) | |
37631 | * event history | |
37632 | PARAMETER (NMXHKK=200000) | |
37633 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
37634 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
37635 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
37636 | * extended event history | |
37637 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
37638 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
37639 | & IHIST(2,NMXHKK) | |
37640 | * Lorentz-parameters of the current interaction | |
37641 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
37642 | & UMO,PPCM,EPROJ,PPROJ | |
37643 | * diquark-breaking mechanism | |
37644 | COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3 | |
37645 | ||
37646 | C | |
37647 | PARAMETER (NTMHKK= 300) | |
37648 | COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT | |
37649 | +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT | |
37650 | +(4,NTMHKK) | |
37651 | ||
37652 | *KEEP,XSEADI. | |
37653 | COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA, | |
37654 | +SSMIMQ,VVMTHR | |
37655 | *KEEP,DPRIN. | |
37656 | COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR | |
37657 | C | |
37658 | C GSQBS-2 diagram (split target diquark) | |
37659 | C | |
37660 | C | |
37661 | C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T) | |
37662 | C Input chain 2(NC2) valence-diquark(NC2P)-sea-quark(NC2T) | |
37663 | C | |
37664 | C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T | |
37665 | C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T | |
37666 | C | |
37667 | C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2) | |
37668 | C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5) | |
37669 | C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8) | |
37670 | C | |
37671 | C | |
37672 | C | |
37673 | C Put new chains into COMMON /HKKTMP/ | |
37674 | C | |
37675 | IIGLU1=NC1T-NC1P-1 | |
37676 | IIGLU2=NC2T-NC2P-1 | |
37677 | IGCOUN=0 | |
37678 | C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2 | |
37679 | CVQ=1.D0 | |
37680 | IREJ=0 | |
37681 | C IF(IPIP.EQ.2)THEN | |
37682 | C WRITE(6,*)' MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,', | |
37683 | C * 'IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN)', | |
37684 | C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, | |
37685 | C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN | |
37686 | C ENDIF | |
37687 | C | |
37688 | C | |
37689 | C | |
37690 | C determine x-values of NC1T diquark | |
37691 | XDIQT=PHKK(4,NC1T)*2.D0/UMO | |
37692 | XVQP=PHKK(4,NC1P)*2.D0/UMO | |
37693 | C | |
37694 | C determine x-values of sea quark pair | |
37695 | C | |
37696 | IPCO=1 | |
37697 | ICOU=0 | |
37698 | 2234 CONTINUE | |
37699 | ICOU=ICOU+1 | |
37700 | IF(ICOU.GE.500)THEN | |
37701 | IREJ=1 | |
37702 | IF(ISQ.EQ.3)IREJ=3 | |
37703 | IF(IPCO.GE.3) | |
37704 | & WRITE(LOUT,*)' MGSQBS2 Rejection 2234 ICOU. GT.500' | |
37705 | IPCO=0 | |
37706 | RETURN | |
37707 | ENDIF | |
37708 | IF(IPCO.GE.3) | |
37709 | & WRITE(LOUT,*)'MGSQBS2 call XSEAPA: UMO,XDIQT,XVQP ', | |
37710 | * UMO, XDIQT,XVQP | |
37711 | XSQ=0.D0 | |
37712 | XSAQ=0.D0 | |
37713 | **NEW | |
37714 | C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ) | |
37715 | IF (IPIP.EQ.1) THEN | |
37716 | XQMAX = XDIQT/2.0D0 | |
37717 | XAQMAX = 2.D0*XVQP/3.0D0 | |
37718 | ELSE | |
37719 | XQMAX = 2.D0*XVQP/3.0D0 | |
37720 | XAQMAX = XDIQT/2.0D0 | |
37721 | ENDIF | |
37722 | CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ) | |
37723 | ISAQ = 6+ISQ | |
37724 | C write(*,*) 'MGSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP | |
37725 | ** | |
37726 | IF(IPCO.GE.3) | |
37727 | & WRITE(LOUT,*)'MGSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ | |
37728 | IF(IREJ.GE.1)THEN | |
37729 | IF(IPCO.GE.3) | |
37730 | & WRITE(LOUT,*)'MGSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ | |
37731 | IPCO=0 | |
37732 | RETURN | |
37733 | ENDIF | |
37734 | IF(IPIP.EQ.1)THEN | |
37735 | IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234 | |
37736 | ELSEIF(IPIP.EQ.2)THEN | |
37737 | IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234 | |
37738 | ENDIF | |
37739 | IF(IPCO.GE.3)THEN | |
37740 | WRITE(LOUT,'(A,4E12.4)')' MGSQBS2 XDIQT,XVQP,XSQ,XSAQ ', | |
37741 | * XDIQT,XVQP,XSQ,XSAQ | |
37742 | ENDIF | |
37743 | C | |
37744 | C subtract xsq,xsaq from NC1T diquark and NC1P quark | |
37745 | C | |
37746 | C XSQ=0.D0 | |
37747 | IF(IPIP.EQ.1)THEN | |
37748 | XDIQT=XDIQT-XSQ | |
37749 | XVQP =XVQP -XSAQ | |
37750 | ELSEIF(IPIP.EQ.2)THEN | |
37751 | XDIQT=XDIQT-XSAQ | |
37752 | XVQP =XVQP -XSQ | |
37753 | ENDIF | |
37754 | IF(IPCO.GE.3) | |
37755 | & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP | |
37756 | C | |
37757 | C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T | |
37758 | C | |
37759 | XVTHRO=CVQ/UMO | |
37760 | IVTHR=0 | |
37761 | 3466 CONTINUE | |
37762 | IF(IVTHR.EQ.10)THEN | |
37763 | IREJ=1 | |
37764 | IF(ISQ.EQ.3)IREJ=3 | |
37765 | IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 3466 reject IVTHR 10' | |
37766 | IPCO=0 | |
37767 | RETURN | |
37768 | ENDIF | |
37769 | IVTHR=IVTHR+1 | |
37770 | XVTHR=XVTHRO/(201-IVTHR) | |
37771 | UNOPRV=UNON | |
37772 | 380 CONTINUE | |
37773 | IF(XVTHR.GT.0.66D0*XDIQT)THEN | |
37774 | IREJ=1 | |
37775 | IF(ISQ.EQ.3)IREJ=3 | |
37776 | IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 Rejection 380 XVTHR large ', | |
37777 | * XVTHR | |
37778 | IPCO=0 | |
37779 | RETURN | |
37780 | ENDIF | |
37781 | IF(DT_RNDM(V).LT.0.5D0)THEN | |
37782 | XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT) | |
37783 | XVTQII=XDIQT-XVTQI | |
37784 | ELSE | |
37785 | XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT) | |
37786 | XVTQI=XDIQT-XVTQII | |
37787 | ENDIF | |
37788 | IF(IPCO.GE.3)THEN | |
37789 | WRITE(LOUT,'(A,2E12.4)')' MGSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII | |
37790 | ENDIF | |
37791 | C | |
37792 | C Prepare 4 momenta of new chains and chain ends | |
37793 | C | |
37794 | C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT | |
37795 | C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT | |
37796 | C +(4,NTMHKK) | |
37797 | C | |
37798 | C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2) | |
37799 | C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5) | |
37800 | C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8) | |
37801 | C | |
37802 | C SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, | |
37803 | C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IGCOUN) | |
37804 | C | |
37805 | IF(IPIP.EQ.1)THEN | |
37806 | XSQ1=XSQ | |
37807 | XSAQ1=XSAQ | |
37808 | ISQ1=ISQ | |
37809 | ISAQ1=ISAQ | |
37810 | ELSEIF(IPIP.EQ.2)THEN | |
37811 | XSQ1=XSAQ | |
37812 | XSAQ1=XSQ | |
37813 | ISQ1=ISAQ | |
37814 | ISAQ1=ISQ | |
37815 | ENDIF | |
37816 | KK11=IP21 | |
37817 | C IDHKT(1) =1000*IPP11+100*IPP12+1 | |
37818 | KK21=IPP11 | |
37819 | KK22=IPP12 | |
37820 | XGIVE=0.D0 | |
37821 | IF(IPIP.EQ.1)THEN | |
37822 | IDHKT(4+IIGLU1) =-(ISAQ1-6) | |
37823 | ELSEIF(IPIP.EQ.2)THEN | |
37824 | IDHKT(4+IIGLU1) =ISAQ1 | |
37825 | ENDIF | |
37826 | ISTHKT(4+IIGLU1) =961 | |
37827 | JMOHKT(1,4+IIGLU1)=NC1P | |
37828 | JMOHKT(2,4+IIGLU1)=0 | |
37829 | JDAHKT(1,4+IIGLU1)=6+IIGLU1 | |
37830 | JDAHKT(2,4+IIGLU1)=0 | |
37831 | C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5) | |
37832 | PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1) | |
37833 | PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1) | |
37834 | PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1) | |
37835 | PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1) | |
37836 | C PHKT(5,4+IIGLU1) =PHKK(5,NC1P) | |
37837 | XXMIST=(PHKT(4,4+IIGLU1)**2- | |
37838 | * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2- | |
37839 | *PHKT(1,4+IIGLU1)**2) | |
37840 | IF(XXMIST.GT.0.D0)THEN | |
37841 | PHKT(5,4+IIGLU1) =SQRT(XXMIST) | |
37842 | ELSE | |
37843 | WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST | |
37844 | XXMIST=ABS(XXMIST) | |
37845 | PHKT(5,4+IIGLU1) =SQRT(XXMIST) | |
37846 | ENDIF | |
37847 | VHKT(1,4+IIGLU1) =VHKK(1,NC1P) | |
37848 | VHKT(2,4+IIGLU1) =VHKK(2,NC1P) | |
37849 | VHKT(3,4+IIGLU1) =VHKK(3,NC1P) | |
37850 | VHKT(4,4+IIGLU1) =VHKK(4,NC1P) | |
37851 | WHKT(1,4+IIGLU1) =WHKK(1,NC1P) | |
37852 | WHKT(2,4+IIGLU1) =WHKK(2,NC1P) | |
37853 | WHKT(3,4+IIGLU1) =WHKK(3,NC1P) | |
37854 | WHKT(4,4+IIGLU1) =WHKK(4,NC1P) | |
37855 | IDHKT(5+IIGLU1) =IP22 | |
37856 | ISTHKT(5+IIGLU1) =962 | |
37857 | JMOHKT(1,5+IIGLU1)=NC1T | |
37858 | JMOHKT(2,5+IIGLU1)=0 | |
37859 | JDAHKT(1,5+IIGLU1)=6+IIGLU1 | |
37860 | JDAHKT(2,5+IIGLU1)=0 | |
37861 | PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1) | |
37862 | PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1) | |
37863 | PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1) | |
37864 | PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1) | |
37865 | C PHKT(5,5+IIGLU1) =PHKK(5,NC1T) | |
37866 | XXMIST=(PHKT(4,5+IIGLU1)**2- | |
37867 | * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2- | |
37868 | *PHKT(1,5+IIGLU1)**2) | |
37869 | IF(XXMIST.GT.0.D0)THEN | |
37870 | PHKT(5,5+IIGLU1) =SQRT(XXMIST) | |
37871 | ELSE | |
37872 | WRITE(LOUT,*)' MGSQBS2 XXMIST', XXMIST | |
37873 | XXMIST=ABS(XXMIST) | |
37874 | PHKT(5,5+IIGLU1) =SQRT(XXMIST) | |
37875 | ENDIF | |
37876 | VHKT(1,5+IIGLU1) =VHKK(1,NC1T) | |
37877 | VHKT(2,5+IIGLU1) =VHKK(2,NC1T) | |
37878 | VHKT(3,5+IIGLU1) =VHKK(3,NC1T) | |
37879 | VHKT(4,5+IIGLU1) =VHKK(4,NC1T) | |
37880 | WHKT(1,5+IIGLU1) =WHKK(1,NC1T) | |
37881 | WHKT(2,5+IIGLU1) =WHKK(2,NC1T) | |
37882 | WHKT(3,5+IIGLU1) =WHKK(3,NC1T) | |
37883 | WHKT(4,5+IIGLU1) =WHKK(4,NC1T) | |
37884 | IDHKT(6+IIGLU1) =88888 | |
37885 | ISTHKT(6+IIGLU1) =96 | |
37886 | JMOHKT(1,6+IIGLU1)=4+IIGLU1 | |
37887 | JMOHKT(2,6+IIGLU1)=5+IIGLU1 | |
37888 | JDAHKT(1,6+IIGLU1)=0 | |
37889 | JDAHKT(2,6+IIGLU1)=0 | |
37890 | PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1) | |
37891 | PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1) | |
37892 | PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1) | |
37893 | PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1) | |
37894 | PHKT(5,6+IIGLU1) | |
37895 | * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2 | |
37896 | * -PHKT(3,6+IIGLU1)**2) | |
37897 | CHAMAL=CHAM1 | |
37898 | IF(IPIP.EQ.1)THEN | |
37899 | IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3 | |
37900 | ELSEIF(IPIP.EQ.2)THEN | |
37901 | IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3 | |
37902 | ENDIF | |
37903 | C--------------------------------------------------- | |
37904 | IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN | |
37905 | IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN | |
37906 | C we drop chain 6 and give the energy to chain 3 | |
37907 | IDHKT(6+IIGLU1)=22888 | |
37908 | XGIVE=1.D0 | |
37909 | C WRITE(6,*)' drop chain 6 xgive=1' | |
37910 | GO TO 7788 | |
37911 | ELSEIF(IDHKT(4+IIGLU1).EQ.-IP21)THEN | |
37912 | C we drop chain 6 and give the energy to chain 3 | |
37913 | C and change KK11 to IDHKT(5) | |
37914 | IDHKT(6+IIGLU1)=22888 | |
37915 | XGIVE=1.D0 | |
37916 | C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(5)' | |
37917 | KK11=IDHKT(5+IIGLU1) | |
37918 | GO TO 7788 | |
37919 | ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP11)THEN | |
37920 | C we drop chain 6 and give the energy to chain 3 | |
37921 | C and change KK21 to IDHKT(5+IIGLU1) | |
37922 | C IDHKT(1) =1000*IPP11+100*IPP12+1 | |
37923 | IDHKT(6+IIGLU1)=22888 | |
37924 | XGIVE=1.D0 | |
37925 | C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(5+IIGLU1)' | |
37926 | KK21=IDHKT(5+IIGLU1) | |
37927 | GO TO 7788 | |
37928 | ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP12)THEN | |
37929 | C we drop chain 6 and give the energy to chain 3 | |
37930 | C and change KK22 to IDHKT(5) | |
37931 | C IDHKT(1) =1000*IPP11+100*IPP12+1 | |
37932 | IDHKT(6+IIGLU1)=22888 | |
37933 | XGIVE=1.D0 | |
37934 | C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(5+IIGLU1)' | |
37935 | KK22=IDHKT(5+IIGLU1) | |
37936 | GO TO 7788 | |
37937 | ENDIF | |
37938 | C IREJ=1 | |
37939 | IPCO=0 | |
37940 | C RETURN | |
37941 | GO TO 3466 | |
37942 | ENDIF | |
37943 | 7788 CONTINUE | |
37944 | C--------------------------------------------------- | |
37945 | IF(IPIP.GE.3)THEN | |
37946 | WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1), | |
37947 | * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1), | |
37948 | *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5) | |
37949 | WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1), | |
37950 | * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1), | |
37951 | *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5) | |
37952 | WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1), | |
37953 | * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1), | |
37954 | *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5) | |
37955 | ENDIF | |
37956 | VHKT(1,6+IIGLU1) =VHKK(1,NC1) | |
37957 | VHKT(2,6+IIGLU1) =VHKK(2,NC1) | |
37958 | VHKT(3,6+IIGLU1) =VHKK(3,NC1) | |
37959 | VHKT(4,6+IIGLU1) =VHKK(4,NC1) | |
37960 | WHKT(1,6+IIGLU1) =WHKK(1,NC1) | |
37961 | WHKT(2,6+IIGLU1) =WHKK(2,NC1) | |
37962 | WHKT(3,6+IIGLU1) =WHKK(3,NC1) | |
37963 | WHKT(4,6+IIGLU1) =WHKK(4,NC1) | |
37964 | C IDHKT(1) =1000*IPP11+100*IPP12+1 | |
37965 | IF(IPIP.EQ.1)THEN | |
37966 | IDHKT(1) =1000*KK21+100*KK22+3 | |
37967 | IF(IDHKT(1).EQ.1203)IDHKT(1)=2103 | |
37968 | IF(IDHKT(1).EQ.1303)IDHKT(1)=3103 | |
37969 | IF(IDHKT(1).EQ.2303)IDHKT(1)=3203 | |
37970 | ELSEIF(IPIP.EQ.2)THEN | |
37971 | IDHKT(1) =1000*KK21+100*KK22-3 | |
37972 | IF(IDHKT(1).EQ.-1203)IDHKT(1)=-2103 | |
37973 | IF(IDHKT(1).EQ.-1303)IDHKT(1)=-3103 | |
37974 | IF(IDHKT(1).EQ.-2303)IDHKT(1)=-3203 | |
37975 | ENDIF | |
37976 | ISTHKT(1) =961 | |
37977 | JMOHKT(1,1)=NC2P | |
37978 | JMOHKT(2,1)=0 | |
37979 | JDAHKT(1,1)=3+IIGLU1 | |
37980 | JDAHKT(2,1)=0 | |
37981 | C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2) | |
37982 | PHKT(1,1) =PHKK(1,NC2P) | |
37983 | *+XGIVE*PHKT(1,4+IIGLU1) | |
37984 | PHKT(2,1) =PHKK(2,NC2P) | |
37985 | *+XGIVE*PHKT(2,4+IIGLU1) | |
37986 | PHKT(3,1) =PHKK(3,NC2P) | |
37987 | *+XGIVE*PHKT(3,4+IIGLU1) | |
37988 | PHKT(4,1) =PHKK(4,NC2P) | |
37989 | *+XGIVE*PHKT(4,4+IIGLU1) | |
37990 | C PHKT(5,1) =PHKK(5,NC2P) | |
37991 | XXMIST=PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2- | |
37992 | *PHKT(1,1)**2 | |
37993 | IF(XXMIST.GT.0.D0)THEN | |
37994 | PHKT(5,1) =SQRT(XXMIST) | |
37995 | ELSE | |
37996 | WRITE(LOUT,*)'MGSQBS2',XXMIST | |
37997 | XXMIST=ABS(XXMIST) | |
37998 | PHKT(5,1) =SQRT(XXMIST) | |
37999 | ENDIF | |
38000 | VHKT(1,1) =VHKK(1,NC2P) | |
38001 | VHKT(2,1) =VHKK(2,NC2P) | |
38002 | VHKT(3,1) =VHKK(3,NC2P) | |
38003 | VHKT(4,1) =VHKK(4,NC2P) | |
38004 | WHKT(1,1) =WHKK(1,NC2P) | |
38005 | WHKT(2,1) =WHKK(2,NC2P) | |
38006 | WHKT(3,1) =WHKK(3,NC2P) | |
38007 | WHKT(4,1) =WHKK(4,NC2P) | |
38008 | C Add here IIGLU1 gluons to this chaina | |
38009 | PG1=0.D0 | |
38010 | PG2=0.D0 | |
38011 | PG3=0.D0 | |
38012 | PG4=0.D0 | |
38013 | IF(IIGLU1.GE.1)THEN | |
38014 | JJG=NC1P | |
38015 | DO 61 IIG=2,2+IIGLU1-1 | |
38016 | KKG=JJG+IIG-1 | |
38017 | IDHKT(IIG) =IDHKK(KKG) | |
38018 | ISTHKT(IIG) =921 | |
38019 | JMOHKT(1,IIG)=KKG | |
38020 | JMOHKT(2,IIG)=0 | |
38021 | JDAHKT(1,IIG)=3+IIGLU1 | |
38022 | JDAHKT(2,IIG)=0 | |
38023 | PHKT(1,IIG)=PHKK(1,KKG) | |
38024 | PG1=PG1+ PHKT(1,IIG) | |
38025 | PHKT(2,IIG)=PHKK(2,KKG) | |
38026 | PG2=PG2+ PHKT(2,IIG) | |
38027 | PHKT(3,IIG)=PHKK(3,KKG) | |
38028 | PG3=PG3+ PHKT(3,IIG) | |
38029 | PHKT(4,IIG)=PHKK(4,KKG) | |
38030 | PG4=PG4+ PHKT(4,IIG) | |
38031 | PHKT(5,IIG)=PHKK(5,KKG) | |
38032 | VHKT(1,IIG) =VHKK(1,KKG) | |
38033 | VHKT(2,IIG) =VHKK(2,KKG) | |
38034 | VHKT(3,IIG) =VHKK(3,KKG) | |
38035 | VHKT(4,IIG) =VHKK(4,KKG) | |
38036 | WHKT(1,IIG) =WHKK(1,KKG) | |
38037 | WHKT(2,IIG) =WHKK(2,KKG) | |
38038 | WHKT(3,IIG) =WHKK(3,KKG) | |
38039 | WHKT(4,IIG) =WHKK(4,KKG) | |
38040 | 61 CONTINUE | |
38041 | ENDIF | |
38042 | C IDHKT(2) =IP21 | |
38043 | IDHKT(2+IIGLU1) =KK11 | |
38044 | ISTHKT(2+IIGLU1) =962 | |
38045 | JMOHKT(1,2+IIGLU1)=NC1T | |
38046 | JMOHKT(2,2+IIGLU1)=0 | |
38047 | JDAHKT(1,2+IIGLU1)=3+IIGLU1 | |
38048 | JDAHKT(2,2+IIGLU1)=0 | |
38049 | PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1) | |
38050 | C * +0.5D0*PHKK(1,NC2T) | |
38051 | *+XGIVE*PHKT(1,5+IIGLU1) | |
38052 | PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1) | |
38053 | C *+0.5D0*PHKK(2,NC2T) | |
38054 | *+XGIVE*PHKT(2,5+IIGLU1) | |
38055 | PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1) | |
38056 | C *+0.5D0*PHKK(3,NC2T) | |
38057 | *+XGIVE*PHKT(3,5+IIGLU1) | |
38058 | PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1) | |
38059 | C *+0.5D0*PHKK(4,NC2T) | |
38060 | *+XGIVE*PHKT(4,5+IIGLU1) | |
38061 | C PHKT(5,2) =PHKK(5,NC1T) | |
38062 | XXMIST=(PHKT(4,2+IIGLU1)**2- | |
38063 | * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2- | |
38064 | *PHKT(1,2+IIGLU1)**2) | |
38065 | IF(XXMIST.GT.0.D0)THEN | |
38066 | PHKT(5,2+IIGLU1) =SQRT(XXMIST) | |
38067 | ELSE | |
38068 | WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST | |
38069 | XXMIST=ABS(XXMIST) | |
38070 | PHKT(5,2+IIGLU1) =SQRT(XXMIST) | |
38071 | ENDIF | |
38072 | VHKT(1,2+IIGLU1) =VHKK(1,NC1T) | |
38073 | VHKT(2,2+IIGLU1) =VHKK(2,NC1T) | |
38074 | VHKT(3,2+IIGLU1) =VHKK(3,NC1T) | |
38075 | VHKT(4,2+IIGLU1) =VHKK(4,NC1T) | |
38076 | WHKT(1,2+IIGLU1) =WHKK(1,NC1T) | |
38077 | WHKT(2,2+IIGLU1) =WHKK(2,NC1T) | |
38078 | WHKT(3,2+IIGLU1) =WHKK(3,NC1T) | |
38079 | WHKT(4,2+IIGLU1) =WHKK(4,NC1T) | |
38080 | IDHKT(3+IIGLU1) =88888 | |
38081 | ISTHKT(3+IIGLU1) =96 | |
38082 | JMOHKT(1,3+IIGLU1)=1 | |
38083 | JMOHKT(2,3+IIGLU1)=2+IIGLU1 | |
38084 | JDAHKT(1,3+IIGLU1)=0 | |
38085 | JDAHKT(2,3+IIGLU1)=0 | |
38086 | PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1 | |
38087 | PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2 | |
38088 | PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3 | |
38089 | PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4 | |
38090 | PHKT(5,3+IIGLU1) | |
38091 | * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2 | |
38092 | * -PHKT(3,3+IIGLU1)**2) | |
38093 | IF(IPIP.EQ.3)THEN | |
38094 | WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1), | |
38095 | * JDAHKT(1,1), | |
38096 | *JDAHKT(2,1),(PHKT(III,1),III=1,5) | |
38097 | DO 71 IIG=2,2+IIGLU1-1 | |
38098 | WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG), | |
38099 | & JMOHKT(1,IIG),JMOHKT(2,IIG), | |
38100 | * JDAHKT(1,IIG), | |
38101 | *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) | |
38102 | 71 CONTINUE | |
38103 | WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1), | |
38104 | * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1), | |
38105 | *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5) | |
38106 | WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1), | |
38107 | * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1), | |
38108 | *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5) | |
38109 | ENDIF | |
38110 | CHAMAL=CHAB1 | |
38111 | IF(IPIP.EQ.1)THEN | |
38112 | IF(IPP11.GE.3.OR.IPP12.GE.3.OR.IP21.GE.3)CHAMAL=CHAB3 | |
38113 | ELSEIF(IPIP.EQ.2)THEN | |
38114 | IF(IPP11.LE.-3.OR.IPP12.LE.-3.OR.IP21.LE.-3)CHAMAL=CHAB3 | |
38115 | ENDIF | |
38116 | IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN | |
38117 | C IREJ=1 | |
38118 | IPCO=0 | |
38119 | C RETURN | |
38120 | GO TO 3466 | |
38121 | ENDIF | |
38122 | VHKT(1,3+IIGLU1) =VHKK(1,NC1) | |
38123 | VHKT(2,3+IIGLU1) =VHKK(2,NC1) | |
38124 | VHKT(3,3+IIGLU1) =VHKK(3,NC1) | |
38125 | VHKT(4,3+IIGLU1) =VHKK(4,NC1) | |
38126 | WHKT(1,3+IIGLU1) =WHKK(1,NC1) | |
38127 | WHKT(2,3+IIGLU1) =WHKK(2,NC1) | |
38128 | WHKT(3,3+IIGLU1) =WHKK(3,NC1) | |
38129 | WHKT(4,3+IIGLU1) =WHKK(4,NC1) | |
38130 | C IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+1 | |
38131 | IDHKT(7+IIGLU1) =IP1 | |
38132 | ISTHKT(7+IIGLU1) =961 | |
38133 | JMOHKT(1,7+IIGLU1)=NC1P | |
38134 | JMOHKT(2,7+IIGLU1)=0 | |
38135 | JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2 | |
38136 | JDAHKT(2,7+IIGLU1)=0 | |
38137 | PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1) | |
38138 | PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1) | |
38139 | PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1) | |
38140 | PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1) | |
38141 | C PHKT(5,7+IIGLU1) =PHKK(5,NC1P) | |
38142 | XXMIST=(PHKT(4,7+IIGLU1)**2- | |
38143 | * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2- | |
38144 | *PHKT(1,7+IIGLU1)**2) | |
38145 | IF(XXMIST.GT.0.D0)THEN | |
38146 | PHKT(5,7+IIGLU1) =SQRT(XXMIST) | |
38147 | ELSE | |
38148 | WRITE(LOUT,*)' MGSQBS2, XXMIST',XXMIST | |
38149 | XXMIST=ABS(XXMIST) | |
38150 | PHKT(5,7+IIGLU1) =SQRT(XXMIST) | |
38151 | ENDIF | |
38152 | VHKT(1,7+IIGLU1) =VHKK(1,NC1P) | |
38153 | VHKT(2,7+IIGLU1) =VHKK(2,NC1P) | |
38154 | VHKT(3,7+IIGLU1) =VHKK(3,NC1P) | |
38155 | VHKT(4,7+IIGLU1) =VHKK(4,NC1P) | |
38156 | WHKT(1,7+IIGLU1) =WHKK(1,NC1P) | |
38157 | WHKT(2,7+IIGLU1) =WHKK(2,NC1P) | |
38158 | WHKT(3,7+IIGLU1) =WHKK(3,NC1P) | |
38159 | WHKT(4,7+IIGLU1) =WHKK(4,NC2P) | |
38160 | C IDHKT(7) =1000*IPP1+100*ISQ+1 | |
38161 | C Insert here the IIGLU2 gluons | |
38162 | PG1=0.D0 | |
38163 | PG2=0.D0 | |
38164 | PG3=0.D0 | |
38165 | PG4=0.D0 | |
38166 | IF(IIGLU2.GE.1)THEN | |
38167 | JJG=NC2P | |
38168 | DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 | |
38169 | KKG=JJG+IIG-7-IIGLU1 | |
38170 | IDHKT(IIG) =IDHKK(KKG) | |
38171 | ISTHKT(IIG) =921 | |
38172 | JMOHKT(1,IIG)=KKG | |
38173 | JMOHKT(2,IIG)=0 | |
38174 | JDAHKT(1,IIG)=9+IIGLU1+IIGLU2 | |
38175 | JDAHKT(2,IIG)=0 | |
38176 | PHKT(1,IIG)=PHKK(1,KKG) | |
38177 | PG1=PG1+ PHKT(1,IIG) | |
38178 | PHKT(2,IIG)=PHKK(2,KKG) | |
38179 | PG2=PG2+ PHKT(2,IIG) | |
38180 | PHKT(3,IIG)=PHKK(3,KKG) | |
38181 | PG3=PG3+ PHKT(3,IIG) | |
38182 | PHKT(4,IIG)=PHKK(4,KKG) | |
38183 | PG4=PG4+ PHKT(4,IIG) | |
38184 | PHKT(5,IIG)=PHKK(5,KKG) | |
38185 | VHKT(1,IIG) =VHKK(1,KKG) | |
38186 | VHKT(2,IIG) =VHKK(2,KKG) | |
38187 | VHKT(3,IIG) =VHKK(3,KKG) | |
38188 | VHKT(4,IIG) =VHKK(4,KKG) | |
38189 | WHKT(1,IIG) =WHKK(1,KKG) | |
38190 | WHKT(2,IIG) =WHKK(2,KKG) | |
38191 | WHKT(3,IIG) =WHKK(3,KKG) | |
38192 | WHKT(4,IIG) =WHKK(4,KKG) | |
38193 | 81 CONTINUE | |
38194 | ENDIF | |
38195 | IF(IPIP.EQ.1)THEN | |
38196 | IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3 | |
38197 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103 | |
38198 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103 | |
38199 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203 | |
38200 | ELSEIF(IPIP.EQ.2)THEN | |
38201 | **NEW | |
38202 | C IDHKT(8) =1000*IPP2+100*(-ISQ1+6)-3 | |
38203 | IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3 | |
38204 | ** | |
38205 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103 | |
38206 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103 | |
38207 | IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203 | |
38208 | ENDIF | |
38209 | ISTHKT(8+IIGLU1+IIGLU2) =962 | |
38210 | JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T | |
38211 | JMOHKT(2,8+IIGLU1+IIGLU2)=0 | |
38212 | JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2 | |
38213 | JDAHKT(2,8+IIGLU1+IIGLU2)=0 | |
38214 | C PHKT(1,8) =0.5D0*PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ/(XDIQT+XSQ) | |
38215 | C PHKT(2,8) =0.5D0*PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ/(XDIQT+XSQ) | |
38216 | C PHKT(3,8) =0.5D0*PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ/(XDIQT+XSQ) | |
38217 | C PHKT(4,8) =0.5D0*PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ/(XDIQT+XSQ) | |
38218 | PHKT(1,8+IIGLU1+IIGLU2) = | |
38219 | * PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1) | |
38220 | PHKT(2,8+IIGLU1+IIGLU2) = | |
38221 | * PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1) | |
38222 | PHKT(3,8+IIGLU1+IIGLU2) = | |
38223 | * PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1) | |
38224 | PHKT(4,8+IIGLU1+IIGLU2) = | |
38225 | * PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1) | |
38226 | C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)', | |
38227 | C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7) | |
38228 | IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN | |
38229 | C IREJ=1 | |
38230 | C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)' | |
38231 | IPCO=0 | |
38232 | C RETURN | |
38233 | GO TO 3466 | |
38234 | ENDIF | |
38235 | C PHKT(5,8) =PHKK(5,NC2T) | |
38236 | PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2- | |
38237 | * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2- | |
38238 | *PHKT(1,8+IIGLU1+IIGLU2)**2) | |
38239 | VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T) | |
38240 | VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T) | |
38241 | VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T) | |
38242 | VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T) | |
38243 | WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T) | |
38244 | WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T) | |
38245 | WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T) | |
38246 | WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T) | |
38247 | IDHKT(9+IIGLU1+IIGLU2) =88888 | |
38248 | ISTHKT(9+IIGLU1+IIGLU2) =96 | |
38249 | JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1 | |
38250 | JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2 | |
38251 | JDAHKT(1,9+IIGLU1+IIGLU2)=0 | |
38252 | JDAHKT(2,9+IIGLU1+IIGLU2)=0 | |
38253 | PHKT(1,9+IIGLU1+IIGLU2) | |
38254 | * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1 | |
38255 | PHKT(2,9+IIGLU1+IIGLU2) | |
38256 | * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2 | |
38257 | PHKT(3,9+IIGLU1+IIGLU2) | |
38258 | * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3 | |
38259 | PHKT(4,9+IIGLU1+IIGLU2) | |
38260 | * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4 | |
38261 | PHKT(5,9+IIGLU1+IIGLU2) | |
38262 | * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2- | |
38263 | * PHKT(2,9+IIGLU1+IIGLU2)**2 | |
38264 | * -PHKT(3,9+IIGLU1+IIGLU2)**2) | |
38265 | IF(IPIP.GE.3)THEN | |
38266 | WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1), | |
38267 | * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1), | |
38268 | *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5) | |
38269 | DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 | |
38270 | WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG), | |
38271 | & JMOHKT(1,IIG),JMOHKT(2,IIG), | |
38272 | * JDAHKT(1,IIG), | |
38273 | *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) | |
38274 | 91 CONTINUE | |
38275 | WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2), | |
38276 | * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2), | |
38277 | *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2), | |
38278 | *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5) | |
38279 | WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2), | |
38280 | * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2), | |
38281 | *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2), | |
38282 | *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5) | |
38283 | ENDIF | |
38284 | CHAMAL=CHAB1 | |
38285 | IF(IPIP.EQ.1)THEN | |
38286 | IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3 | |
38287 | ELSEIF(IPIP.EQ.2)THEN | |
38288 | IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3 | |
38289 | ENDIF | |
38290 | IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN | |
38291 | C IREJ=1 | |
38292 | IPCO=0 | |
38293 | C RETURN | |
38294 | GO TO 3466 | |
38295 | ENDIF | |
38296 | VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1) | |
38297 | VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1) | |
38298 | VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1) | |
38299 | VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1) | |
38300 | WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1) | |
38301 | WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1) | |
38302 | WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1) | |
38303 | WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1) | |
38304 | C | |
38305 | IPCO=0 | |
38306 | IGCOUN=9+IIGLU1+IIGLU2 | |
38307 | RETURN | |
38308 | END | |
38309 | ||
38310 | *$ CREATE MUSQBS1.FOR | |
38311 | *COPY MUSQBS1 | |
38312 | C | |
38313 | C | |
38314 | C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ | |
38315 | SUBROUTINE MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, | |
38316 | * IP11,IP12,IP2,IPP1,IPP2,IPIP,ISQ,IGCOUN) | |
38317 | C | |
38318 | C USQBS-1 diagram (split projectile diquark) | |
38319 | C | |
38320 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
38321 | SAVE | |
38322 | ||
38323 | PARAMETER ( LINP = 10 , | |
38324 | & LOUT = 6 , | |
38325 | & LDAT = 9 ) | |
38326 | * event history | |
38327 | PARAMETER (NMXHKK=200000) | |
38328 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
38329 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
38330 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
38331 | * extended event history | |
38332 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
38333 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
38334 | & IHIST(2,NMXHKK) | |
38335 | * Lorentz-parameters of the current interaction | |
38336 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
38337 | & UMO,PPCM,EPROJ,PPROJ | |
38338 | * diquark-breaking mechanism | |
38339 | COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3 | |
38340 | ||
38341 | C | |
38342 | PARAMETER (NTMHKK= 300) | |
38343 | COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT | |
38344 | +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT | |
38345 | +(4,NTMHKK) | |
38346 | *KEEP,XSEADI. | |
38347 | COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA, | |
38348 | +SSMIMQ,VVMTHR | |
38349 | *KEEP,DPRIN. | |
38350 | COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR | |
38351 | COMMON /EVFLAG/ NUMEV | |
38352 | C | |
38353 | C USQBS-1 diagram (split projectile diquark) | |
38354 | C | |
38355 | C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T) | |
38356 | C Input chain 2(NC2) sea-quark(NC2P)-sea-antiquark(NC2T) | |
38357 | C | |
38358 | C Create quark(qsP)-antiquark(aqsT) pair, energy from NC1P and NC1T | |
38359 | C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P | |
38360 | C | |
38361 | C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2) | |
38362 | C 6 valence quark(vq2P 4)-sea-quark(aqsT 5) | |
38363 | C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8) | |
38364 | C | |
38365 | C Put new chains into COMMON /HKKTMP/ | |
38366 | C | |
38367 | IIGLU1=NC1T-NC1P-1 | |
38368 | IIGLU2=NC2T-NC2P-1 | |
38369 | IGCOUN=0 | |
38370 | C WRITE(6,*)'MUSQBS1: IIGLU1,IIGLU2,IPIP ',IIGLU1,IIGLU2,IPIP | |
38371 | CVQ=1.D0 | |
38372 | IREJ=0 | |
38373 | IF(IPIP.EQ.3)THEN | |
38374 | C IF(NUMEV.EQ.-324)THEN | |
38375 | WRITE(LOUT,*)' MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,', | |
38376 | * ' IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN)', | |
38377 | *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, | |
38378 | * IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN | |
38379 | ENDIF | |
38380 | C | |
38381 | C | |
38382 | C | |
38383 | C determine x-values of NC1P diquark | |
38384 | XDIQP=PHKK(4,NC1P)*2.D0/UMO | |
38385 | XVQT=PHKK(4,NC1T)*2.D0/UMO | |
38386 | C | |
38387 | C determine x-values of sea quark pair | |
38388 | C | |
38389 | IPCO=1 | |
38390 | ICOU=0 | |
38391 | 2234 CONTINUE | |
38392 | ICOU=ICOU+1 | |
38393 | IF(ICOU.GE.500)THEN | |
38394 | IREJ=1 | |
38395 | IF(ISQ.EQ.3)IREJ=3 | |
38396 | IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 2234 ICOU. GT.100' | |
38397 | IPCO=0 | |
38398 | RETURN | |
38399 | ENDIF | |
38400 | IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 call XSEAPA: UMO,XDIQP,XVQT ', | |
38401 | * UMO, XDIQP,XVQT | |
38402 | XSQ=0.D0 | |
38403 | XSAQ=0.D0 | |
38404 | **NEW | |
38405 | C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ) | |
38406 | IF (IPIP.EQ.1) THEN | |
38407 | XQMAX = XDIQP/2.0D0 | |
38408 | XAQMAX = 2.D0*XVQT/3.0D0 | |
38409 | ELSE | |
38410 | XQMAX = 2.D0*XVQT/3.0D0 | |
38411 | XAQMAX = XDIQP/2.0D0 | |
38412 | ENDIF | |
38413 | CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ) | |
38414 | ISAQ = 6+ISQ | |
38415 | C write(*,*) 'MUSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT | |
38416 | ** | |
38417 | IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ | |
38418 | IF(IREJ.GE.1)THEN | |
38419 | IF(IPCO.GE.3) | |
38420 | & WRITE(LOUT,*)'MUSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ | |
38421 | IPCO=0 | |
38422 | RETURN | |
38423 | ENDIF | |
38424 | IF(IPIP.EQ.1)THEN | |
38425 | IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234 | |
38426 | ELSEIF(IPIP.EQ.2)THEN | |
38427 | IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234 | |
38428 | ENDIF | |
38429 | IF(IPCO.GE.3)THEN | |
38430 | WRITE(LOUT,'(A,4E12.4)')' MUSQBS1 XDIQP,XVQT,XSQ,XSAQ ', | |
38431 | * XDIQP,XVQT,XSQ,XSAQ | |
38432 | ENDIF | |
38433 | C | |
38434 | C subtract xsq,xsaq from NC1P diquark and NC1T quark | |
38435 | C | |
38436 | C XSQ=0.D0 | |
38437 | IF(IPIP.EQ.1)THEN | |
38438 | XDIQP=XDIQP-XSQ | |
38439 | XVQT =XVQT -XSAQ | |
38440 | ELSEIF(IPIP.EQ.2)THEN | |
38441 | XDIQP=XDIQP-XSAQ | |
38442 | XVQT =XVQT -XSQ | |
38443 | ENDIF | |
38444 | IF(IPCO.GE.3) | |
38445 | & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT | |
38446 | C | |
38447 | C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P | |
38448 | C | |
38449 | XVTHRO=CVQ/UMO | |
38450 | IVTHR=0 | |
38451 | 3466 CONTINUE | |
38452 | IF(IVTHR.EQ.10)THEN | |
38453 | IREJ=1 | |
38454 | IF(ISQ.EQ.3)IREJ=3 | |
38455 | IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 3466 reject IVTHR 10' | |
38456 | IPCO=0 | |
38457 | RETURN | |
38458 | ENDIF | |
38459 | IVTHR=IVTHR+1 | |
38460 | XVTHR=XVTHRO/(201-IVTHR) | |
38461 | UNOPRV=UNON | |
38462 | 380 CONTINUE | |
38463 | IF(XVTHR.GT.0.66D0*XDIQP)THEN | |
38464 | IREJ=1 | |
38465 | IF(ISQ.EQ.3)IREJ=3 | |
38466 | IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 380 XVTHR large ', | |
38467 | * XVTHR | |
38468 | IPCO=0 | |
38469 | RETURN | |
38470 | ENDIF | |
38471 | IF(DT_RNDM(V).LT.0.5D0)THEN | |
38472 | XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP) | |
38473 | XVPQII=XDIQP-XVPQI | |
38474 | ELSE | |
38475 | XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP) | |
38476 | XVPQI=XDIQP-XVPQII | |
38477 | ENDIF | |
38478 | IF(IPCO.GE.3)THEN | |
38479 | WRITE(LOUT,'(A,2E12.4)')' MUSQBS1:XVPQI,XVPQII ',XVPQI,XVPQII | |
38480 | ENDIF | |
38481 | C | |
38482 | C Prepare 4 momenta of new chains and chain ends | |
38483 | C | |
38484 | C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT | |
38485 | C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT | |
38486 | C +(4,NTMHKK) | |
38487 | C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2) | |
38488 | C 6 valence quark(vq2P 4)-sea-quark(aqsT 5) | |
38489 | C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8) | |
38490 | IF(IPIP.EQ.1)THEN | |
38491 | XSQ1=XSQ | |
38492 | XSAQ1=XSAQ | |
38493 | ISQ1=ISQ | |
38494 | ISAQ1=ISAQ | |
38495 | ELSEIF(IPIP.EQ.2)THEN | |
38496 | XSQ1=XSAQ | |
38497 | XSAQ1=XSQ | |
38498 | ISQ1=ISAQ | |
38499 | ISAQ1=ISQ | |
38500 | ENDIF | |
38501 | IDHKT(1) =IP11 | |
38502 | ISTHKT(1) =931 | |
38503 | JMOHKT(1,1)=NC1P | |
38504 | JMOHKT(2,1)=0 | |
38505 | JDAHKT(1,1)=3+IIGLU1 | |
38506 | JDAHKT(2,1)=0 | |
38507 | C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2) | |
38508 | PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1) | |
38509 | PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1) | |
38510 | PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1) | |
38511 | PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1) | |
38512 | C PHKT(5,1) =PHKK(5,NC1P) | |
38513 | XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2- | |
38514 | *PHKT(1,1)**2) | |
38515 | IF(XMIST.GE.0.D0)THEN | |
38516 | PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2- | |
38517 | *PHKT(1,1)**2) | |
38518 | ELSE | |
38519 | C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST | |
38520 | PHKT(5,1)=0.D0 | |
38521 | ENDIF | |
38522 | VHKT(1,1) =VHKK(1,NC1P) | |
38523 | VHKT(2,1) =VHKK(2,NC1P) | |
38524 | VHKT(3,1) =VHKK(3,NC1P) | |
38525 | VHKT(4,1) =VHKK(4,NC1P) | |
38526 | WHKT(1,1) =WHKK(1,NC1P) | |
38527 | WHKT(2,1) =WHKK(2,NC1P) | |
38528 | WHKT(3,1) =WHKK(3,NC1P) | |
38529 | WHKT(4,1) =WHKK(4,NC1P) | |
38530 | C Add here IIGLU1 gluons to this chaina | |
38531 | PG1=0.D0 | |
38532 | PG2=0.D0 | |
38533 | PG3=0.D0 | |
38534 | PG4=0.D0 | |
38535 | IF(IIGLU1.GE.1)THEN | |
38536 | JJG=NC1P | |
38537 | DO 61 IIG=2,2+IIGLU1-1 | |
38538 | KKG=JJG+IIG-1 | |
38539 | IDHKT(IIG) =IDHKK(KKG) | |
38540 | ISTHKT(IIG) =921 | |
38541 | JMOHKT(1,IIG)=KKG | |
38542 | JMOHKT(2,IIG)=0 | |
38543 | JDAHKT(1,IIG)=3+IIGLU1 | |
38544 | JDAHKT(2,IIG)=0 | |
38545 | PHKT(1,IIG)=PHKK(1,KKG) | |
38546 | PG1=PG1+ PHKT(1,IIG) | |
38547 | PHKT(2,IIG)=PHKK(2,KKG) | |
38548 | PG2=PG2+ PHKT(2,IIG) | |
38549 | PHKT(3,IIG)=PHKK(3,KKG) | |
38550 | PG3=PG3+ PHKT(3,IIG) | |
38551 | PHKT(4,IIG)=PHKK(4,KKG) | |
38552 | PG4=PG4+ PHKT(4,IIG) | |
38553 | PHKT(5,IIG)=PHKK(5,KKG) | |
38554 | VHKT(1,IIG) =VHKK(1,KKG) | |
38555 | VHKT(2,IIG) =VHKK(2,KKG) | |
38556 | VHKT(3,IIG) =VHKK(3,KKG) | |
38557 | VHKT(4,IIG) =VHKK(4,KKG) | |
38558 | WHKT(1,IIG) =WHKK(1,KKG) | |
38559 | WHKT(2,IIG) =WHKK(2,KKG) | |
38560 | WHKT(3,IIG) =WHKK(3,KKG) | |
38561 | WHKT(4,IIG) =WHKK(4,KKG) | |
38562 | 61 CONTINUE | |
38563 | ENDIF | |
38564 | IDHKT(2+IIGLU1) =IPP2 | |
38565 | ISTHKT(2+IIGLU1) =932 | |
38566 | JMOHKT(1,2+IIGLU1)=NC2T | |
38567 | JMOHKT(2,2+IIGLU1)=0 | |
38568 | JDAHKT(1,2+IIGLU1)=3+IIGLU1 | |
38569 | JDAHKT(2,2+IIGLU1)=0 | |
38570 | PHKT(1,2+IIGLU1) =PHKK(1,NC2T) | |
38571 | PHKT(2,2+IIGLU1) =PHKK(2,NC2T) | |
38572 | PHKT(3,2+IIGLU1) =PHKK(3,NC2T) | |
38573 | PHKT(4,2+IIGLU1) =PHKK(4,NC2T) | |
38574 | C PHKT(5,2+IIGLU1) =PHKK(5,NC2T) | |
38575 | XMIST=(PHKT(4,2+IIGLU1)**2- | |
38576 | * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2- | |
38577 | *PHKT(1,2+IIGLU1)**2) | |
38578 | IF(XMIST.GT.0.D0)THEN | |
38579 | PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2- | |
38580 | * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2- | |
38581 | *PHKT(1,2+IIGLU1)**2) | |
38582 | ELSE | |
38583 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST | |
38584 | PHKT(5,2+IIGLU1)=0.D0 | |
38585 | ENDIF | |
38586 | VHKT(1,2+IIGLU1) =VHKK(1,NC2T) | |
38587 | VHKT(2,2+IIGLU1) =VHKK(2,NC2T) | |
38588 | VHKT(3,2+IIGLU1) =VHKK(3,NC2T) | |
38589 | VHKT(4,2+IIGLU1) =VHKK(4,NC2T) | |
38590 | WHKT(1,2+IIGLU1) =WHKK(1,NC2T) | |
38591 | WHKT(2,2+IIGLU1) =WHKK(2,NC2T) | |
38592 | WHKT(3,2+IIGLU1) =WHKK(3,NC2T) | |
38593 | WHKT(4,2+IIGLU1) =WHKK(4,NC2T) | |
38594 | IDHKT(3+IIGLU1) =88888 | |
38595 | ISTHKT(3+IIGLU1) =94 | |
38596 | JMOHKT(1,3+IIGLU1)=1 | |
38597 | JMOHKT(2,3+IIGLU1)=2+IIGLU1 | |
38598 | JDAHKT(1,3+IIGLU1)=0 | |
38599 | JDAHKT(2,3+IIGLU1)=0 | |
38600 | PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1 | |
38601 | PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2 | |
38602 | PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3 | |
38603 | PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4 | |
38604 | XMIST | |
38605 | * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2 | |
38606 | * -PHKT(3,3+IIGLU1)**2) | |
38607 | IF(XMIST.GE.0.D0)THEN | |
38608 | PHKT(5,3+IIGLU1) | |
38609 | * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2 | |
38610 | * -PHKT(3,3+IIGLU1)**2) | |
38611 | ELSE | |
38612 | C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST | |
38613 | PHKT(5,1)=0.D0 | |
38614 | ENDIF | |
38615 | IF(IPIP.GE.3)THEN | |
38616 | C IF(NUMEV.EQ.-324)THEN | |
38617 | WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1), | |
38618 | * JMOHKT(2,1),JDAHKT(1,1), | |
38619 | *JDAHKT(2,1),(PHKT(III,1),III=1,5) | |
38620 | DO 71 IIG=2,2+IIGLU1-1 | |
38621 | WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG), | |
38622 | & JMOHKT(1,IIG),JMOHKT(2,IIG), | |
38623 | * JDAHKT(1,IIG), | |
38624 | *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) | |
38625 | 71 CONTINUE | |
38626 | WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1), | |
38627 | * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1), | |
38628 | *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5) | |
38629 | WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1), | |
38630 | * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1), | |
38631 | *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5) | |
38632 | ENDIF | |
38633 | CHAMAL=CHAM1 | |
38634 | IF(IPIP.EQ.1)THEN | |
38635 | IF(IP11.GE.3.OR.IPP2.GE.3)CHAMAL=CHAM3 | |
38636 | ELSEIF(IPIP.EQ.2)THEN | |
38637 | IF(IP11.LE.-3.OR.IPP2.LE.-3)CHAMAL=CHAM3 | |
38638 | ENDIF | |
38639 | IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN | |
38640 | C IREJ=1 | |
38641 | IPCO=0 | |
38642 | C RETURN | |
38643 | C WRITE(6,*)' MUSQBS1 jump back from chain 3' | |
38644 | GO TO 3466 | |
38645 | ENDIF | |
38646 | VHKT(1,3+IIGLU1) =VHKK(1,NC1) | |
38647 | VHKT(2,3+IIGLU1) =VHKK(2,NC1) | |
38648 | VHKT(3,3+IIGLU1) =VHKK(3,NC1) | |
38649 | VHKT(4,3+IIGLU1) =VHKK(4,NC1) | |
38650 | WHKT(1,3+IIGLU1) =WHKK(1,NC1) | |
38651 | WHKT(2,3+IIGLU1) =WHKK(2,NC1) | |
38652 | WHKT(3,3+IIGLU1) =WHKK(3,NC1) | |
38653 | WHKT(4,3+IIGLU1) =WHKK(4,NC1) | |
38654 | IDHKT(4+IIGLU1) =IP12 | |
38655 | ISTHKT(4+IIGLU1) =931 | |
38656 | JMOHKT(1,4+IIGLU1)=NC1P | |
38657 | JMOHKT(2,4+IIGLU1)=0 | |
38658 | JDAHKT(1,4+IIGLU1)=6+IIGLU1 | |
38659 | JDAHKT(2,4+IIGLU1)=0 | |
38660 | C create chain 6 valence quark(vq2P 4)-sea-quark(aqsT 5) | |
38661 | PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1) | |
38662 | PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1) | |
38663 | PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1) | |
38664 | PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1) | |
38665 | C PHKT(5,4+IIGLU1) =PHKK(5,NC1P) | |
38666 | XMIST =(PHKT(4,4+IIGLU1)**2- | |
38667 | * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2- | |
38668 | *PHKT(1,4+IIGLU1)**2) | |
38669 | IF(XMIST.GT.0.D0)THEN | |
38670 | PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2- | |
38671 | * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2- | |
38672 | *PHKT(1,4+IIGLU1)**2) | |
38673 | ELSE | |
38674 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST | |
38675 | PHKT(5,4+IIGLU1)=0.D0 | |
38676 | ENDIF | |
38677 | VHKT(1,4+IIGLU1) =VHKK(1,NC1P) | |
38678 | VHKT(2,4+IIGLU1) =VHKK(2,NC1P) | |
38679 | VHKT(3,4+IIGLU1) =VHKK(3,NC1P) | |
38680 | VHKT(4,4+IIGLU1) =VHKK(4,NC1P) | |
38681 | WHKT(1,4+IIGLU1) =WHKK(1,NC1P) | |
38682 | WHKT(2,4+IIGLU1) =WHKK(2,NC1P) | |
38683 | WHKT(3,4+IIGLU1) =WHKK(3,NC1P) | |
38684 | WHKT(4,4+IIGLU1) =WHKK(4,NC1P) | |
38685 | IF(IPIP.EQ.1)THEN | |
38686 | IDHKT(5+IIGLU1) =-(ISAQ1-6) | |
38687 | ELSEIF(IPIP.EQ.2)THEN | |
38688 | IDHKT(5+IIGLU1) =ISAQ1 | |
38689 | ENDIF | |
38690 | ISTHKT(5+IIGLU1) =932 | |
38691 | JMOHKT(1,5+IIGLU1)=NC1T | |
38692 | JMOHKT(2,5+IIGLU1)=0 | |
38693 | JDAHKT(1,5+IIGLU1)=6+IIGLU1 | |
38694 | JDAHKT(2,5+IIGLU1)=0 | |
38695 | PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1) | |
38696 | PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1) | |
38697 | PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1) | |
38698 | PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1) | |
38699 | C IF( PHKT(4,5).EQ.0.D0)THEN | |
38700 | C IREJ=1 | |
38701 | CIPCO=0 | |
38702 | CRETURN | |
38703 | C ENDIF | |
38704 | C PHKT(5,5) =PHKK(5,NC1T) | |
38705 | XMIST=(PHKT(4,5+IIGLU1)**2- | |
38706 | * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2- | |
38707 | *PHKT(1,5+IIGLU1)**2) | |
38708 | IF(XMIST.GT.0.D0)THEN | |
38709 | PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2- | |
38710 | * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2- | |
38711 | *PHKT(1,5+IIGLU1)**2) | |
38712 | ELSE | |
38713 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST | |
38714 | PHKT(5,5+IIGLU1)=0.D0 | |
38715 | ENDIF | |
38716 | VHKT(1,5+IIGLU1) =VHKK(1,NC1T) | |
38717 | VHKT(2,5+IIGLU1) =VHKK(2,NC1T) | |
38718 | VHKT(3,5+IIGLU1) =VHKK(3,NC1T) | |
38719 | VHKT(4,5+IIGLU1) =VHKK(4,NC1T) | |
38720 | WHKT(1,5+IIGLU1) =WHKK(1,NC1T) | |
38721 | WHKT(2,5+IIGLU1) =WHKK(2,NC1T) | |
38722 | WHKT(3,5+IIGLU1) =WHKK(3,NC1T) | |
38723 | WHKT(4,5+IIGLU1) =WHKK(4,NC1T) | |
38724 | IDHKT(6+IIGLU1) =88888 | |
38725 | ISTHKT(6+IIGLU1) =94 | |
38726 | JMOHKT(1,6+IIGLU1)=4+IIGLU1 | |
38727 | JMOHKT(2,6+IIGLU1)=5+IIGLU1 | |
38728 | JDAHKT(1,6+IIGLU1)=0 | |
38729 | JDAHKT(2,6+IIGLU1)=0 | |
38730 | PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1) | |
38731 | PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1) | |
38732 | PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1) | |
38733 | PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1) | |
38734 | XMIST | |
38735 | * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2 | |
38736 | * -PHKT(3,6+IIGLU1)**2) | |
38737 | IF(XMIST.GE.0.D0)THEN | |
38738 | PHKT(5,6+IIGLU1) | |
38739 | * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2 | |
38740 | * -PHKT(3,6+IIGLU1)**2) | |
38741 | ELSE | |
38742 | C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST | |
38743 | PHKT(5,1)=0.D0 | |
38744 | ENDIF | |
38745 | C IF(IPIP.EQ.3)THEN | |
38746 | CHAMAL=CHAM1 | |
38747 | IF(IPIP.EQ.1)THEN | |
38748 | IF(IP12.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3 | |
38749 | ELSEIF(IPIP.EQ.2)THEN | |
38750 | IF(IP12.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3 | |
38751 | ENDIF | |
38752 | IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN | |
38753 | C IREJ=1 | |
38754 | IPCO=0 | |
38755 | C RETURN | |
38756 | C WRITE(6,*)' MGSQBS1 jump back from chain 6', | |
38757 | C * CHAMAL,PHKT(5,6+IIGLU1) | |
38758 | GO TO 3466 | |
38759 | ENDIF | |
38760 | IF(IPIP.GE.3)THEN | |
38761 | C IF(NUMEV.EQ.-324)THEN | |
38762 | WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1), | |
38763 | * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1), | |
38764 | *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5) | |
38765 | WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1), | |
38766 | * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1), | |
38767 | *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5) | |
38768 | WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1), | |
38769 | * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1), | |
38770 | *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5) | |
38771 | ENDIF | |
38772 | VHKT(1,6+IIGLU1) =VHKK(1,NC1) | |
38773 | VHKT(2,6+IIGLU1) =VHKK(2,NC1) | |
38774 | VHKT(3,6+IIGLU1) =VHKK(3,NC1) | |
38775 | VHKT(4,6+IIGLU1) =VHKK(4,NC1) | |
38776 | WHKT(1,6+IIGLU1) =WHKK(1,NC1) | |
38777 | WHKT(2,6+IIGLU1) =WHKK(2,NC1) | |
38778 | WHKT(3,6+IIGLU1) =WHKK(3,NC1) | |
38779 | WHKT(4,6+IIGLU1) =WHKK(4,NC1) | |
38780 | IF(IPIP.EQ.1)THEN | |
38781 | IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+3 | |
38782 | IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103 | |
38783 | IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103 | |
38784 | IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203 | |
38785 | ELSEIF(IPIP.EQ.2)THEN | |
38786 | IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3 | |
38787 | IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103 | |
38788 | IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103 | |
38789 | IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203 | |
38790 | C WRITE(6,*)'IDHKT(7+IIGLU1),IPP1,ISQ1',IDHKT(7+IIGLU1),IPP1,ISQ1 | |
38791 | ENDIF | |
38792 | ISTHKT(7+IIGLU1) =931 | |
38793 | JMOHKT(1,7+IIGLU1)=NC2P | |
38794 | JMOHKT(2,7+IIGLU1)=0 | |
38795 | JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2 | |
38796 | JDAHKT(2,7+IIGLU1)=0 | |
38797 | C create chain 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8) | |
38798 | PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1) | |
38799 | PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1) | |
38800 | PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1) | |
38801 | PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1) | |
38802 | C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)', | |
38803 | C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7) | |
38804 | IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN | |
38805 | C IREJ=1 | |
38806 | C WRITE(6,*)'reject PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P)' | |
38807 | IPCO=0 | |
38808 | C RETURN | |
38809 | GO TO 3466 | |
38810 | ENDIF | |
38811 | C PHKT(5,7) =PHKK(5,NC2P) | |
38812 | PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2- | |
38813 | * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2- | |
38814 | *PHKT(1,7+IIGLU1)**2) | |
38815 | VHKT(1,7+IIGLU1) =VHKK(1,NC2P) | |
38816 | VHKT(2,7+IIGLU1) =VHKK(2,NC2P) | |
38817 | VHKT(3,7+IIGLU1) =VHKK(3,NC2P) | |
38818 | VHKT(4,7+IIGLU1) =VHKK(4,NC2P) | |
38819 | WHKT(1,7+IIGLU1) =WHKK(1,NC2P) | |
38820 | WHKT(2,7+IIGLU1) =WHKK(2,NC2P) | |
38821 | WHKT(3,7+IIGLU1) =WHKK(3,NC2P) | |
38822 | WHKT(4,7+IIGLU1) =WHKK(4,NC2P) | |
38823 | C Insert here the IIGLU2 gluons | |
38824 | PG1=0.D0 | |
38825 | PG2=0.D0 | |
38826 | PG3=0.D0 | |
38827 | PG4=0.D0 | |
38828 | IF(IIGLU2.GE.1)THEN | |
38829 | JJG=NC2P | |
38830 | DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 | |
38831 | KKG=JJG+IIG-7-IIGLU1 | |
38832 | IDHKT(IIG) =IDHKK(KKG) | |
38833 | ISTHKT(IIG) =921 | |
38834 | JMOHKT(1,IIG)=KKG | |
38835 | JMOHKT(2,IIG)=0 | |
38836 | JDAHKT(1,IIG)=9+IIGLU1+IIGLU2 | |
38837 | JDAHKT(2,IIG)=0 | |
38838 | PHKT(1,IIG)=PHKK(1,KKG) | |
38839 | PG1=PG1+ PHKT(1,IIG) | |
38840 | PHKT(2,IIG)=PHKK(2,KKG) | |
38841 | PG2=PG2+ PHKT(2,IIG) | |
38842 | PHKT(3,IIG)=PHKK(3,KKG) | |
38843 | PG3=PG3+ PHKT(3,IIG) | |
38844 | PHKT(4,IIG)=PHKK(4,KKG) | |
38845 | PG4=PG4+ PHKT(4,IIG) | |
38846 | PHKT(5,IIG)=PHKK(5,KKG) | |
38847 | VHKT(1,IIG) =VHKK(1,KKG) | |
38848 | VHKT(2,IIG) =VHKK(2,KKG) | |
38849 | VHKT(3,IIG) =VHKK(3,KKG) | |
38850 | VHKT(4,IIG) =VHKK(4,KKG) | |
38851 | WHKT(1,IIG) =WHKK(1,KKG) | |
38852 | WHKT(2,IIG) =WHKK(2,KKG) | |
38853 | WHKT(3,IIG) =WHKK(3,KKG) | |
38854 | WHKT(4,IIG) =WHKK(4,KKG) | |
38855 | 81 CONTINUE | |
38856 | ENDIF | |
38857 | IDHKT(8+IIGLU1+IIGLU2) =IP2 | |
38858 | ISTHKT(8+IIGLU1+IIGLU2) =932 | |
38859 | JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T | |
38860 | JMOHKT(2,8+IIGLU1+IIGLU2)=0 | |
38861 | JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2 | |
38862 | JDAHKT(2,8+IIGLU1+IIGLU2)=0 | |
38863 | PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT) | |
38864 | PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT) | |
38865 | PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT) | |
38866 | PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT) | |
38867 | C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T) | |
38868 | XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2- | |
38869 | * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2- | |
38870 | *PHKT(1,8+IIGLU1+IIGLU2)**2) | |
38871 | IF(XMIST.GT.0.D0)THEN | |
38872 | PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2- | |
38873 | * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2- | |
38874 | *PHKT(1,8+IIGLU1+IIGLU2)**2) | |
38875 | ELSE | |
38876 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST | |
38877 | PHKT(5,8+IIGLU1+IIGLU2)=0.D0 | |
38878 | ENDIF | |
38879 | VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T) | |
38880 | VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T) | |
38881 | VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T) | |
38882 | VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T) | |
38883 | WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T) | |
38884 | WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T) | |
38885 | WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T) | |
38886 | WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T) | |
38887 | IDHKT(9+IIGLU1+IIGLU2) =88888 | |
38888 | ISTHKT(9+IIGLU1+IIGLU2) =94 | |
38889 | JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1 | |
38890 | JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2 | |
38891 | JDAHKT(1,9+IIGLU1+IIGLU2)=0 | |
38892 | JDAHKT(2,9+IIGLU1+IIGLU2)=0 | |
38893 | PHKT(1,9+IIGLU1+IIGLU2) | |
38894 | * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1 | |
38895 | PHKT(2,9+IIGLU1+IIGLU2) | |
38896 | * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2 | |
38897 | PHKT(3,9+IIGLU1+IIGLU2) | |
38898 | * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3 | |
38899 | PHKT(4,9+IIGLU1+IIGLU2) | |
38900 | * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4 | |
38901 | XMIST | |
38902 | *=(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2 | |
38903 | * -PHKT(2,9+IIGLU1+IIGLU2)**2 | |
38904 | * -PHKT(3,9+IIGLU1+IIGLU2)**2) | |
38905 | IF(XMIST.GE.0.D0)THEN | |
38906 | PHKT(5,9+IIGLU1+IIGLU2) | |
38907 | *=SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2 | |
38908 | * -PHKT(2,9+IIGLU1+IIGLU2)**2 | |
38909 | * -PHKT(3,9+IIGLU1+IIGLU2)**2) | |
38910 | ELSE | |
38911 | C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST | |
38912 | PHKT(5,1)=0.D0 | |
38913 | ENDIF | |
38914 | IF(IPIP.GE.3)THEN | |
38915 | C IF(NUMEV.EQ.-324)THEN | |
38916 | WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1), | |
38917 | * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1), | |
38918 | *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5) | |
38919 | DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 | |
38920 | WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG), | |
38921 | & JMOHKT(1,IIG),JMOHKT(2,IIG), | |
38922 | * JDAHKT(1,IIG), | |
38923 | *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) | |
38924 | 91 CONTINUE | |
38925 | WRITE(LOUT,*)8+IIGLU1+IIGLU2, | |
38926 | * ISTHKT(8+IIGLU1+IIGLU2),IDHKT(8+IIGLU1+IIGLU2), | |
38927 | * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2), | |
38928 | *JDAHKT(1,8+IIGLU1+IIGLU2), | |
38929 | *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5) | |
38930 | WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2), | |
38931 | * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2), | |
38932 | *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2), | |
38933 | *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5) | |
38934 | ENDIF | |
38935 | CHAMAL=CHAB1 | |
38936 | IF(IPIP.EQ.1)THEN | |
38937 | IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3 | |
38938 | ELSEIF(IPIP.EQ.2)THEN | |
38939 | IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3 | |
38940 | ENDIF | |
38941 | IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN | |
38942 | C IREJ=1 | |
38943 | IPCO=0 | |
38944 | C RETURN | |
38945 | C WRITE(6,*)' MGSQBS1 jump back from chain 9', | |
38946 | C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2) | |
38947 | GO TO 3466 | |
38948 | ENDIF | |
38949 | VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1) | |
38950 | VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1) | |
38951 | VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1) | |
38952 | VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1) | |
38953 | WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1) | |
38954 | WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1) | |
38955 | WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1) | |
38956 | WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1) | |
38957 | C | |
38958 | IPCO=0 | |
38959 | IGCOUN=9+IIGLU1+IIGLU2 | |
38960 | RETURN | |
38961 | END | |
38962 | ||
38963 | *$ CREATE MGSQBS1.FOR | |
38964 | *COPY MGSQBS1 | |
38965 | C | |
38966 | C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ | |
38967 | SUBROUTINE MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, | |
38968 | * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,ISQ,IGCOUN) | |
38969 | C | |
38970 | C GSQBS-1 diagram (split projectile diquark) | |
38971 | C | |
38972 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
38973 | SAVE | |
38974 | ||
38975 | PARAMETER ( LINP = 10 , | |
38976 | & LOUT = 6 , | |
38977 | & LDAT = 9 ) | |
38978 | * event history | |
38979 | PARAMETER (NMXHKK=200000) | |
38980 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
38981 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
38982 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
38983 | * extended event history | |
38984 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
38985 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
38986 | & IHIST(2,NMXHKK) | |
38987 | * Lorentz-parameters of the current interaction | |
38988 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
38989 | & UMO,PPCM,EPROJ,PPROJ | |
38990 | * diquark-breaking mechanism | |
38991 | COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3 | |
38992 | ||
38993 | C | |
38994 | PARAMETER (NTMHKK= 300) | |
38995 | COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT | |
38996 | +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT | |
38997 | +(4,NTMHKK) | |
38998 | *KEEP,XSEADI. | |
38999 | COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA, | |
39000 | +SSMIMQ,VVMTHR | |
39001 | *KEEP,DPRIN. | |
39002 | COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR | |
39003 | C | |
39004 | C GSQBS-1 diagram (split projectile diquark) | |
39005 | C | |
39006 | C | |
39007 | C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T) | |
39008 | C Input chain 2(NC2) sea-quark(NC2P)-valence-diquark(NC2T) | |
39009 | C | |
39010 | C Create quark(qs)-antiquark(aqs) pair energy from NC1P and NC1T | |
39011 | C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P | |
39012 | C | |
39013 | C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2) | |
39014 | C 6 valence quark(vq2P 4)-sea-quark(aqsP 5) | |
39015 | C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8) | |
39016 | C | |
39017 | C Put new chains into COMMON /HKKTMP/ | |
39018 | C | |
39019 | IIGLU1=NC1T-NC1P-1 | |
39020 | IIGLU2=NC2T-NC2P-1 | |
39021 | IGCOUN=0 | |
39022 | C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2 | |
39023 | CVQ=1.D0 | |
39024 | NNNC1=IDHKK(NC1)/1000 | |
39025 | MMMC1=IDHKK(NC1)-NNNC1*1000 | |
39026 | KKKC1=ISTHKK(NC1) | |
39027 | NNNC2=IDHKK(NC2)/1000 | |
39028 | MMMC2=IDHKK(NC2)-NNNC2*1000 | |
39029 | KKKC2=ISTHKK(NC2) | |
39030 | IREJ=0 | |
39031 | IF(IPIP.EQ.3)THEN | |
39032 | WRITE(LOUT,*)' MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,', | |
39033 | * ' IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN)', | |
39034 | *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ, | |
39035 | * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN | |
39036 | ENDIF | |
39037 | C | |
39038 | C | |
39039 | C | |
39040 | C determine x-values of NC1P diquark | |
39041 | XDIQP=PHKK(4,NC1P)*2.D0/UMO | |
39042 | XVQT=PHKK(4,NC1T)*2.D0/UMO | |
39043 | C | |
39044 | C determine x-values of sea quark pair | |
39045 | C | |
39046 | IPCO=1 | |
39047 | ICOU=0 | |
39048 | 2234 CONTINUE | |
39049 | ICOU=ICOU+1 | |
39050 | IF(ICOU.GE.500)THEN | |
39051 | IREJ=1 | |
39052 | IF(ISQ.EQ.3)IREJ=3 | |
39053 | IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 Rejection 2234 ICOU. GT.100' | |
39054 | IPCO=0 | |
39055 | RETURN | |
39056 | ENDIF | |
39057 | IF(IPCO.GE.3)WRITE(LOUT,*)'MGSQBS1 call XSEAPA: UMO,XDIQP,XVQT ', | |
39058 | * UMO, XDIQP,XVQT | |
39059 | XSQ=0.D0 | |
39060 | XSAQ=0.D0 | |
39061 | **NEW | |
39062 | C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ) | |
39063 | IF (IPIP.EQ.1) THEN | |
39064 | XQMAX = XDIQP/2.0D0 | |
39065 | XAQMAX = 2.D0*XVQT/3.0D0 | |
39066 | ELSE | |
39067 | XQMAX = 2.D0*XVQT/3.0D0 | |
39068 | XAQMAX = XDIQP/2.0D0 | |
39069 | ENDIF | |
39070 | CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ) | |
39071 | ISAQ = 6+ISQ | |
39072 | C write(*,*) 'MGSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT | |
39073 | ** | |
39074 | IF(IPCO.GE.3) | |
39075 | & WRITE(LOUT,*)'MGSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ | |
39076 | IF(IREJ.GE.1)THEN | |
39077 | IF(IPCO.GE.3) | |
39078 | & WRITE(LOUT,*)'MGSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ | |
39079 | IPCO=0 | |
39080 | RETURN | |
39081 | ENDIF | |
39082 | IF(IPIP.EQ.1)THEN | |
39083 | IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234 | |
39084 | ELSEIF(IPIP.EQ.2)THEN | |
39085 | IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234 | |
39086 | ENDIF | |
39087 | IF(IPCO.GE.3)THEN | |
39088 | WRITE(LOUT,'(A,4E12.4)')' MGSQBS1 XDIQP,XVQT,XSQ,XSAQ ', | |
39089 | * XDIQP,XVQT,XSQ,XSAQ | |
39090 | ENDIF | |
39091 | C | |
39092 | C subtract xsq,xsaq from NC1P diquark and NC1T quark | |
39093 | C | |
39094 | C XSQ=0.D0 | |
39095 | IF(IPIP.EQ.1)THEN | |
39096 | XDIQP=XDIQP-XSQ | |
39097 | **NEW | |
39098 | C IF (XDIQP.LT.0.0D0) WRITE(*,*) ' mgsqbs1: XDIQP<0!!',XDIQP | |
39099 | ** | |
39100 | XVQT =XVQT -XSAQ | |
39101 | ELSEIF(IPIP.EQ.2)THEN | |
39102 | XDIQP=XDIQP-XSAQ | |
39103 | XVQT =XVQT -XSQ | |
39104 | ENDIF | |
39105 | IF(IPCO.GE.3) | |
39106 | & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT | |
39107 | C | |
39108 | C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P | |
39109 | C | |
39110 | XVTHRO=CVQ/UMO | |
39111 | IVTHR=0 | |
39112 | 3466 CONTINUE | |
39113 | IF(IVTHR.EQ.10)THEN | |
39114 | IREJ=1 | |
39115 | IF(ISQ.EQ.3)IREJ=3 | |
39116 | IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 3466 reject IVTHR 10' | |
39117 | IPCO=0 | |
39118 | RETURN | |
39119 | ENDIF | |
39120 | IVTHR=IVTHR+1 | |
39121 | XVTHR=XVTHRO/(201-IVTHR) | |
39122 | UNOPRV=UNON | |
39123 | 380 CONTINUE | |
39124 | IF(XVTHR.GT.0.66D0*XDIQP)THEN | |
39125 | IREJ=1 | |
39126 | IF(ISQ.EQ.3)IREJ=3 | |
39127 | IF(IPCO.GE.3) | |
39128 | & WRITE(LOUT,*)' MGSQBS1 Rejection 380 XVTHR large ', | |
39129 | * XVTHR | |
39130 | IPCO=0 | |
39131 | RETURN | |
39132 | ENDIF | |
39133 | IF(DT_RNDM(V).LT.0.5D0)THEN | |
39134 | XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP) | |
39135 | XVPQII=XDIQP-XVPQI | |
39136 | ELSE | |
39137 | XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP) | |
39138 | XVPQI=XDIQP-XVPQII | |
39139 | ENDIF | |
39140 | IF(IPCO.GE.3)THEN | |
39141 | WRITE(LOUT,'(A,4E12.4)')' MGSQBS1:XVTHR,XDIQP,XVPQI,XVPQII ', | |
39142 | * XVTHR,XDIQP,XVPQI,XVPQII | |
39143 | ENDIF | |
39144 | C | |
39145 | C Prepare 4 momenta of new chains and chain ends | |
39146 | C | |
39147 | C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT | |
39148 | C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT | |
39149 | C +(4,NTMHKK) | |
39150 | C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2) | |
39151 | C 6 valence quark(vq2P 4)-sea-quark(aqsP 5) | |
39152 | C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8) | |
39153 | IF(IPIP.EQ.1)THEN | |
39154 | XSQ1=XSQ | |
39155 | XSAQ1=XSAQ | |
39156 | ISQ1=ISQ | |
39157 | ISAQ1=ISAQ | |
39158 | ELSEIF(IPIP.EQ.2)THEN | |
39159 | XSQ1=XSAQ | |
39160 | XSAQ1=XSQ | |
39161 | ISQ1=ISAQ | |
39162 | ISAQ1=ISQ | |
39163 | ENDIF | |
39164 | KK11=IP11 | |
39165 | C IDHKT(2) =1000*IPP21+100*IPP22+1 | |
39166 | KK21= IPP21 | |
39167 | KK22= IPP22 | |
39168 | XGIVE=0.D0 | |
39169 | IDHKT(4+IIGLU1) =IP12 | |
39170 | ISTHKT(4+IIGLU1) =921 | |
39171 | JMOHKT(1,4+IIGLU1)=NC1P | |
39172 | JMOHKT(2,4+IIGLU1)=0 | |
39173 | JDAHKT(1,4+IIGLU1)=6+IIGLU1 | |
39174 | JDAHKT(2,4+IIGLU1)=0 | |
39175 | **NEW | |
39176 | IF ((XDIQP.LT.0.0D0).OR.(XVPQII.LT.0.0D0).OR. | |
39177 | & (XSQ1.LT.0.0D0)) WRITE(LOUT,*) ' mgsqbs1: ',XDIQP,XVPQII,XSQ1 | |
39178 | ** | |
39179 | PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1) | |
39180 | PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1) | |
39181 | PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1) | |
39182 | PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1) | |
39183 | C PHKT(5,4+IIGLU1) =PHKK(5,NC1P) | |
39184 | XXMIST=(PHKT(4,4+IIGLU1)**2- | |
39185 | * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2- | |
39186 | * PHKT(1,4+IIGLU1)**2) | |
39187 | IF(XXMIST.GT.0.D0)THEN | |
39188 | PHKT(5,4+IIGLU1) =SQRT(XXMIST) | |
39189 | ELSE | |
39190 | WRITE(LOUT,*)'MGSQBS1 XXMIST',XXMIST | |
39191 | XXMIST=ABS(XXMIST) | |
39192 | PHKT(5,4+IIGLU1) =SQRT(XXMIST) | |
39193 | ENDIF | |
39194 | VHKT(1,4+IIGLU1) =VHKK(1,NC1P) | |
39195 | VHKT(2,4+IIGLU1) =VHKK(2,NC1P) | |
39196 | VHKT(3,4+IIGLU1) =VHKK(3,NC1P) | |
39197 | VHKT(4,4+IIGLU1) =VHKK(4,NC1P) | |
39198 | WHKT(1,4+IIGLU1) =WHKK(1,NC1P) | |
39199 | WHKT(2,4+IIGLU1) =WHKK(2,NC1P) | |
39200 | WHKT(3,4+IIGLU1) =WHKK(3,NC1P) | |
39201 | WHKT(4,4+IIGLU1) =WHKK(4,NC1P) | |
39202 | IF(IPIP.EQ.1)THEN | |
39203 | IDHKT(5+IIGLU1) =-(ISAQ1-6) | |
39204 | ELSEIF(IPIP.EQ.2)THEN | |
39205 | IDHKT(5+IIGLU1) =ISAQ1 | |
39206 | ENDIF | |
39207 | ISTHKT(5+IIGLU1) =922 | |
39208 | JMOHKT(1,5+IIGLU1)=NC1T | |
39209 | JMOHKT(2,5+IIGLU1)=0 | |
39210 | JDAHKT(1,5+IIGLU1)=6+IIGLU1 | |
39211 | JDAHKT(2,5+IIGLU1)=0 | |
39212 | **NEW | |
39213 | IF ((XSAQ1.LT.0.0D0).OR.(XVQT .LT.0.0D0)) | |
39214 | & WRITE(LOUT,*) ' mgsqbs2: ',XSAQ1,XVQT | |
39215 | ** | |
39216 | PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1) | |
39217 | PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1) | |
39218 | PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1) | |
39219 | PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1) | |
39220 | C PHKT(5,5+IIGLU1) =PHKK(5,NC1T) | |
39221 | XMIST=(PHKT(4,5+IIGLU1)**2- | |
39222 | * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2- | |
39223 | *PHKT(1,5+IIGLU1)**2) | |
39224 | IF(XMIST.GT.0.D0)THEN | |
39225 | PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2- | |
39226 | * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2- | |
39227 | *PHKT(1,5+IIGLU1)**2) | |
39228 | ELSE | |
39229 | C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST | |
39230 | PHKT(5,5+IIGLU1)=0.D0 | |
39231 | ENDIF | |
39232 | VHKT(1,5+IIGLU1) =VHKK(1,NC1T) | |
39233 | VHKT(2,5+IIGLU1) =VHKK(2,NC1T) | |
39234 | VHKT(3,5+IIGLU1) =VHKK(3,NC1T) | |
39235 | VHKT(4,5+IIGLU1) =VHKK(4,NC1T) | |
39236 | WHKT(1,5+IIGLU1) =WHKK(1,NC1T) | |
39237 | WHKT(2,5+IIGLU1) =WHKK(2,NC1T) | |
39238 | WHKT(3,5+IIGLU1) =WHKK(3,NC1T) | |
39239 | WHKT(4,5+IIGLU1) =WHKK(4,NC1T) | |
39240 | IDHKT(6+IIGLU1) =88888 | |
39241 | C IDHKT(6) =1000*NNNC1+MMMC1 | |
39242 | ISTHKT(6+IIGLU1) =93 | |
39243 | C ISTHKT(6) =KKKC1 | |
39244 | JMOHKT(1,6+IIGLU1)=4+IIGLU1 | |
39245 | JMOHKT(2,6+IIGLU1)=5+IIGLU1 | |
39246 | JDAHKT(1,6+IIGLU1)=0 | |
39247 | JDAHKT(2,6+IIGLU1)=0 | |
39248 | PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1) | |
39249 | PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1) | |
39250 | PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1) | |
39251 | PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1) | |
39252 | PHKT(5,6+IIGLU1) | |
39253 | * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2 | |
39254 | * -PHKT(3,6+IIGLU1)**2) | |
39255 | CHAMAL=CHAM1 | |
39256 | IF(IPIP.EQ.1)THEN | |
39257 | IF(IP12.GE.3.OR.ISAQ.GE.9)CHAMAL=CHAM3 | |
39258 | ELSEIF(IPIP.EQ.2)THEN | |
39259 | IF(IP12.LE.-3.OR.ISAQ.GE.3)CHAMAL=CHAM3 | |
39260 | ENDIF | |
39261 | IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN | |
39262 | IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN | |
39263 | C we drop chain 6 and give the energy to chain 3 | |
39264 | IDHKT(6+IIGLU1)=33888 | |
39265 | XGIVE=1.D0 | |
39266 | C WRITE(6,*)' drop chain 6 xgive=1' | |
39267 | GO TO 7788 | |
39268 | ELSEIF(IDHKT(5+IIGLU1).EQ.-IP11)THEN | |
39269 | C we drop chain 6 and give the energy to chain 3 | |
39270 | C and change KK11 to IDHKT(4) | |
39271 | IDHKT(6+IIGLU1)=33888 | |
39272 | XGIVE=1.D0 | |
39273 | C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(4+IIGLU1)' | |
39274 | KK11=IDHKT(4+IIGLU1) | |
39275 | GO TO 7788 | |
39276 | ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP21)THEN | |
39277 | C we drop chain 6 and give the energy to chain 3 | |
39278 | C and change KK21 to IDHKT(4) | |
39279 | C IDHKT(2) =1000*IPP21+100*IPP22+1 | |
39280 | IDHKT(6+IIGLU1)=33888 | |
39281 | XGIVE=1.D0 | |
39282 | C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(4+IIGLU1)' | |
39283 | KK21=IDHKT(4+IIGLU1) | |
39284 | GO TO 7788 | |
39285 | ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP22)THEN | |
39286 | C we drop chain 6 and give the energy to chain 3 | |
39287 | C and change KK22 to IDHKT(4) | |
39288 | C IDHKT(2) =1000*IPP21+100*IPP22+1 | |
39289 | IDHKT(6+IIGLU1)=33888 | |
39290 | XGIVE=1.D0 | |
39291 | C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(4+IIGLU1)' | |
39292 | KK22=IDHKT(4+IIGLU1) | |
39293 | GO TO 7788 | |
39294 | ENDIF | |
39295 | C IREJ=1 | |
39296 | IPCO=0 | |
39297 | C RETURN | |
39298 | C WRITE(6,*)' MGSQBS1 jump back from chain 6' | |
39299 | GO TO 3466 | |
39300 | ENDIF | |
39301 | 7788 CONTINUE | |
39302 | IF(IPIP.GE.3)THEN | |
39303 | WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1), | |
39304 | * JMOHKT(1,4+IIGLU1), | |
39305 | * JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1), | |
39306 | *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5) | |
39307 | WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1), | |
39308 | * JMOHKT(1,5+IIGLU1), | |
39309 | * JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1), | |
39310 | *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5) | |
39311 | WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1), | |
39312 | * JMOHKT(1,6+IIGLU1), | |
39313 | * JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1), | |
39314 | *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5) | |
39315 | ENDIF | |
39316 | VHKT(1,6+IIGLU1) =VHKK(1,NC1) | |
39317 | VHKT(2,6+IIGLU1) =VHKK(2,NC1) | |
39318 | VHKT(3,6+IIGLU1) =VHKK(3,NC1) | |
39319 | VHKT(4,6+IIGLU1) =VHKK(4,NC1) | |
39320 | WHKT(1,6+IIGLU1) =WHKK(1,NC1) | |
39321 | WHKT(2,6+IIGLU1) =WHKK(2,NC1) | |
39322 | WHKT(3,6+IIGLU1) =WHKK(3,NC1) | |
39323 | WHKT(4,6+IIGLU1) =WHKK(4,NC1) | |
39324 | C IDHKT(1) =IP11 | |
39325 | IDHKT(1) =KK11 | |
39326 | ISTHKT(1) =921 | |
39327 | JMOHKT(1,1)=NC1P | |
39328 | JMOHKT(2,1)=0 | |
39329 | JDAHKT(1,1)=3+IIGLU1 | |
39330 | JDAHKT(2,1)=0 | |
39331 | PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1) | |
39332 | C * +0.5D0*PHKK(1,NC2P) | |
39333 | *+XGIVE*PHKT(1,4+IIGLU1) | |
39334 | PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1) | |
39335 | C * +0.5D0*PHKK(2,NC2P) | |
39336 | *+XGIVE*PHKT(2,4+IIGLU1) | |
39337 | PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1) | |
39338 | C * +0.5D0*PHKK(3,NC2P) | |
39339 | *+XGIVE*PHKT(3,4+IIGLU1) | |
39340 | PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1) | |
39341 | C * +0.5D0*PHKK(4,NC2P) | |
39342 | *+XGIVE*PHKT(4,4+IIGLU1) | |
39343 | C PHKT(5,1) =PHKK(5,NC1P) | |
39344 | XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2- | |
39345 | *PHKT(1,1)**2) | |
39346 | IF(XMIST.GE.0.D0)THEN | |
39347 | PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2- | |
39348 | *PHKT(1,1)**2) | |
39349 | ELSE | |
39350 | C WRITE(6,*)'MGSQBS1 parton 1 mass square LT.0 ',XMIST | |
39351 | PHKT(5,1)=0.D0 | |
39352 | ENDIF | |
39353 | VHKT(1,1) =VHKK(1,NC1P) | |
39354 | VHKT(2,1) =VHKK(2,NC1P) | |
39355 | VHKT(3,1) =VHKK(3,NC1P) | |
39356 | VHKT(4,1) =VHKK(4,NC1P) | |
39357 | WHKT(1,1) =WHKK(1,NC1P) | |
39358 | WHKT(2,1) =WHKK(2,NC1P) | |
39359 | WHKT(3,1) =WHKK(3,NC1P) | |
39360 | WHKT(4,1) =WHKK(4,NC1P) | |
39361 | C Add here IIGLU1 gluons to this chaina | |
39362 | PG1=0.D0 | |
39363 | PG2=0.D0 | |
39364 | PG3=0.D0 | |
39365 | PG4=0.D0 | |
39366 | IF(IIGLU1.GE.1)THEN | |
39367 | JJG=NC1P | |
39368 | DO 61 IIG=2,2+IIGLU1-1 | |
39369 | KKG=JJG+IIG-1 | |
39370 | IDHKT(IIG) =IDHKK(KKG) | |
39371 | ISTHKT(IIG) =921 | |
39372 | JMOHKT(1,IIG)=KKG | |
39373 | JMOHKT(2,IIG)=0 | |
39374 | JDAHKT(1,IIG)=3+IIGLU1 | |
39375 | JDAHKT(2,IIG)=0 | |
39376 | PHKT(1,IIG)=PHKK(1,KKG) | |
39377 | PG1=PG1+ PHKT(1,IIG) | |
39378 | PHKT(2,IIG)=PHKK(2,KKG) | |
39379 | PG2=PG2+ PHKT(2,IIG) | |
39380 | PHKT(3,IIG)=PHKK(3,KKG) | |
39381 | PG3=PG3+ PHKT(3,IIG) | |
39382 | PHKT(4,IIG)=PHKK(4,KKG) | |
39383 | PG4=PG4+ PHKT(4,IIG) | |
39384 | PHKT(5,IIG)=PHKK(5,KKG) | |
39385 | VHKT(1,IIG) =VHKK(1,KKG) | |
39386 | VHKT(2,IIG) =VHKK(2,KKG) | |
39387 | VHKT(3,IIG) =VHKK(3,KKG) | |
39388 | VHKT(4,IIG) =VHKK(4,KKG) | |
39389 | WHKT(1,IIG) =WHKK(1,KKG) | |
39390 | WHKT(2,IIG) =WHKK(2,KKG) | |
39391 | WHKT(3,IIG) =WHKK(3,KKG) | |
39392 | WHKT(4,IIG) =WHKK(4,KKG) | |
39393 | 61 CONTINUE | |
39394 | ENDIF | |
39395 | C IDHKT(2) =1000*IPP21+100*IPP22+1 | |
39396 | IF(IPIP.EQ.1)THEN | |
39397 | IDHKT(2+IIGLU1) =1000*KK21+100*KK22+3 | |
39398 | IF(IDHKT(2+IIGLU1).EQ.1203)IDHKT(2+IIGLU1)=2103 | |
39399 | IF(IDHKT(2+IIGLU1).EQ.1303)IDHKT(2+IIGLU1)=3103 | |
39400 | IF(IDHKT(2+IIGLU1).EQ.2303)IDHKT(2+IIGLU1)=3203 | |
39401 | ELSEIF(IPIP.EQ.2)THEN | |
39402 | IDHKT(2+IIGLU1) =1000*KK21+100*KK22-3 | |
39403 | IF(IDHKT(2+IIGLU1).EQ.-1203)IDHKT(2+IIGLU1)=-2103 | |
39404 | IF(IDHKT(2+IIGLU1).EQ.-1303)IDHKT(2+IIGLU1)=-3103 | |
39405 | IF(IDHKT(2+IIGLU1).EQ.-2303)IDHKT(2+IIGLU1)=-3203 | |
39406 | ENDIF | |
39407 | ISTHKT(2+IIGLU1) =922 | |
39408 | JMOHKT(1,2+IIGLU1)=NC2T | |
39409 | JMOHKT(2,2+IIGLU1)=0 | |
39410 | JDAHKT(1,2+IIGLU1)=3+IIGLU1 | |
39411 | JDAHKT(2,2+IIGLU1)=0 | |
39412 | PHKT(1,2+IIGLU1) =PHKK(1,NC2T) | |
39413 | *+XGIVE*PHKT(1,5+IIGLU1) | |
39414 | PHKT(2,2+IIGLU1) =PHKK(2,NC2T) | |
39415 | *+XGIVE*PHKT(2,5+IIGLU1) | |
39416 | PHKT(3,2+IIGLU1) =PHKK(3,NC2T) | |
39417 | *+XGIVE*PHKT(3,5+IIGLU1) | |
39418 | PHKT(4,2+IIGLU1) =PHKK(4,NC2T) | |
39419 | *+XGIVE*PHKT(4,5+IIGLU1) | |
39420 | C PHKT(5,2) =PHKK(5,NC2T) | |
39421 | XMIST=(PHKT(4,2+IIGLU1)**2- | |
39422 | * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2- | |
39423 | *PHKT(1,2+IIGLU1)**2) | |
39424 | IF(XMIST.GT.0.D0)THEN | |
39425 | PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2- | |
39426 | * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2- | |
39427 | *PHKT(1,2+IIGLU1)**2) | |
39428 | ELSE | |
39429 | C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST | |
39430 | PHKT(5,2+IIGLU1)=0.D0 | |
39431 | ENDIF | |
39432 | VHKT(1,2+IIGLU1) =VHKK(1,NC2T) | |
39433 | VHKT(2,2+IIGLU1) =VHKK(2,NC2T) | |
39434 | VHKT(3,2+IIGLU1) =VHKK(3,NC2T) | |
39435 | VHKT(4,2+IIGLU1) =VHKK(4,NC2T) | |
39436 | WHKT(1,2+IIGLU1) =WHKK(1,NC2T) | |
39437 | WHKT(2,2+IIGLU1) =WHKK(2,NC2T) | |
39438 | WHKT(3,2+IIGLU1) =WHKK(3,NC2T) | |
39439 | WHKT(4,2+IIGLU1) =WHKK(4,NC2T) | |
39440 | IDHKT(3+IIGLU1) =88888 | |
39441 | C IDHKT(3) =1000*NNNC1+MMMC1+10 | |
39442 | ISTHKT(3+IIGLU1) =93 | |
39443 | C ISTHKT(3) =KKKC1 | |
39444 | JMOHKT(1,3+IIGLU1)=1 | |
39445 | JMOHKT(2,3+IIGLU1)=2+IIGLU1 | |
39446 | JDAHKT(1,3+IIGLU1)=0 | |
39447 | JDAHKT(2,3+IIGLU1)=0 | |
39448 | PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1 | |
39449 | PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2 | |
39450 | PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3 | |
39451 | PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4 | |
39452 | PHKT(5,3+IIGLU1) | |
39453 | * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2 | |
39454 | * -PHKT(3,3+IIGLU1)**2) | |
39455 | IF(IPIP.GE.3)THEN | |
39456 | WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1), | |
39457 | * JDAHKT(1,1), | |
39458 | *JDAHKT(2,1),(PHKT(III,1),III=1,5) | |
39459 | DO 71 IIG=2,2+IIGLU1-1 | |
39460 | WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG), | |
39461 | & JMOHKT(1,IIG),JMOHKT(2,IIG), | |
39462 | * JDAHKT(1,IIG), | |
39463 | *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) | |
39464 | 71 CONTINUE | |
39465 | WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1), | |
39466 | & IDHKT(2),JMOHKT(1,2+IIGLU1), | |
39467 | * JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1), | |
39468 | *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5) | |
39469 | WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1), | |
39470 | * JMOHKT(1,3+IIGLU1), | |
39471 | * JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1), | |
39472 | *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5) | |
39473 | ENDIF | |
39474 | CHAMAL=CHAB1 | |
39475 | **NEW | |
39476 | C IF(IPIP.EQ.1)THEN | |
39477 | C IF(IPP21.GE.3.OR.IPP22.GE.3.OR.IP11.GE.3)CHAMAL=CHAB3 | |
39478 | C ELSEIF(IPIP.EQ.2)THEN | |
39479 | C IF(IPP21.LE.-3.OR.IPP22.LE.-3.OR.IP11.LE.-3)CHAMAL=CHAB3 | |
39480 | C ENDIF | |
39481 | IF(IPIP.EQ.1)THEN | |
39482 | IF(KK21.GE.3.OR.KK22.GE.3.OR.KK11.GE.3)CHAMAL=CHAB3 | |
39483 | ELSEIF(IPIP.EQ.2)THEN | |
39484 | IF(KK21.LE.-3.OR.KK22.LE.-3.OR.KK11.LE.-3)CHAMAL=CHAB3 | |
39485 | ENDIF | |
39486 | ** | |
39487 | IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN | |
39488 | C IREJ=1 | |
39489 | IPCO=0 | |
39490 | C RETURN | |
39491 | C WRITE(6,*)' MGSQBS1 jump back from chain 3' | |
39492 | GO TO 3466 | |
39493 | ENDIF | |
39494 | VHKT(1,3+IIGLU1) =VHKK(1,NC1) | |
39495 | VHKT(2,3+IIGLU1) =VHKK(2,NC1) | |
39496 | VHKT(3,3+IIGLU1) =VHKK(3,NC1) | |
39497 | VHKT(4,3+IIGLU1) =VHKK(4,NC1) | |
39498 | WHKT(1,3+IIGLU1) =WHKK(1,NC1) | |
39499 | WHKT(2,3+IIGLU1) =WHKK(2,NC1) | |
39500 | WHKT(3,3+IIGLU1) =WHKK(3,NC1) | |
39501 | WHKT(4,3+IIGLU1) =WHKK(4,NC1) | |
39502 | IF(IPIP.EQ.1)THEN | |
39503 | IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ1+3 | |
39504 | IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103 | |
39505 | IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103 | |
39506 | IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203 | |
39507 | ELSEIF(IPIP.EQ.2)THEN | |
39508 | IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3 | |
39509 | IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103 | |
39510 | IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103 | |
39511 | IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203 | |
39512 | C WRITE(6,*)'IDHKT(7),IPP1,ISQ1',IDHKT(7),IPP1,ISQ1 | |
39513 | ENDIF | |
39514 | ISTHKT(7+IIGLU1) =921 | |
39515 | JMOHKT(1,7+IIGLU1)=NC2P | |
39516 | JMOHKT(2,7+IIGLU1)=0 | |
39517 | JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2 | |
39518 | JDAHKT(2,7+IIGLU1)=0 | |
39519 | C PHKT(1,7) =0.5D0*PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ/(XDIQP+XSQ) | |
39520 | C PHKT(2,7) =0.5D0*PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ/(XDIQP+XSQ) | |
39521 | C PHKT(3,7) =0.5D0*PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ/(XDIQP+XSQ) | |
39522 | C PHKT(4,7+IIGLU1) =0.5D0*PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ/(XDIQP+XSQ) | |
39523 | **NEW | |
39524 | IF ((XSQ1 .LT.0.0D0).OR.(XDIQP .LT.0.0D0)) | |
39525 | & WRITE(LOUT,*) ' mgsqbs3: ',XSQ1,XDIQP | |
39526 | ** | |
39527 | PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1) | |
39528 | PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1) | |
39529 | PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1) | |
39530 | PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1) | |
39531 | C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)', | |
39532 | C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7) | |
39533 | IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN | |
39534 | C IREJ=1 | |
39535 | C WRITE(6,*)'reject PHKT(4,7).GE. PHKK(4,NC1P)' | |
39536 | IPCO=0 | |
39537 | C RETURN | |
39538 | GO TO 3466 | |
39539 | ENDIF | |
39540 | C PHKT(5,7) =PHKK(5,NC2P) | |
39541 | PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2- | |
39542 | * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2- | |
39543 | *PHKT(1,7+IIGLU1)**2) | |
39544 | VHKT(1,7+IIGLU1) =VHKK(1,NC2P) | |
39545 | VHKT(2,7+IIGLU1) =VHKK(2,NC2P) | |
39546 | VHKT(3,7+IIGLU1) =VHKK(3,NC2P) | |
39547 | VHKT(4,7+IIGLU1) =VHKK(4,NC2P) | |
39548 | WHKT(1,7+IIGLU1) =WHKK(1,NC2P) | |
39549 | WHKT(2,7+IIGLU1) =WHKK(2,NC2P) | |
39550 | WHKT(3,7+IIGLU1) =WHKK(3,NC2P) | |
39551 | WHKT(4,7+IIGLU1) =WHKK(4,NC2P) | |
39552 | C Insert here the IIGLU2 gluons | |
39553 | PG1=0.D0 | |
39554 | PG2=0.D0 | |
39555 | PG3=0.D0 | |
39556 | PG4=0.D0 | |
39557 | IF(IIGLU2.GE.1)THEN | |
39558 | JJG=NC2P | |
39559 | DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 | |
39560 | KKG=JJG+IIG-7-IIGLU1 | |
39561 | IDHKT(IIG) =IDHKK(KKG) | |
39562 | ISTHKT(IIG) =921 | |
39563 | JMOHKT(1,IIG)=KKG | |
39564 | JMOHKT(2,IIG)=0 | |
39565 | JDAHKT(1,IIG)=9+IIGLU1+IIGLU2 | |
39566 | JDAHKT(2,IIG)=0 | |
39567 | PHKT(1,IIG)=PHKK(1,KKG) | |
39568 | PG1=PG1+ PHKT(1,IIG) | |
39569 | PHKT(2,IIG)=PHKK(2,KKG) | |
39570 | PG2=PG2+ PHKT(2,IIG) | |
39571 | PHKT(3,IIG)=PHKK(3,KKG) | |
39572 | PG3=PG3+ PHKT(3,IIG) | |
39573 | PHKT(4,IIG)=PHKK(4,KKG) | |
39574 | PG4=PG4+ PHKT(4,IIG) | |
39575 | PHKT(5,IIG)=PHKK(5,KKG) | |
39576 | VHKT(1,IIG) =VHKK(1,KKG) | |
39577 | VHKT(2,IIG) =VHKK(2,KKG) | |
39578 | VHKT(3,IIG) =VHKK(3,KKG) | |
39579 | VHKT(4,IIG) =VHKK(4,KKG) | |
39580 | WHKT(1,IIG) =WHKK(1,KKG) | |
39581 | WHKT(2,IIG) =WHKK(2,KKG) | |
39582 | WHKT(3,IIG) =WHKK(3,KKG) | |
39583 | WHKT(4,IIG) =WHKK(4,KKG) | |
39584 | 81 CONTINUE | |
39585 | ENDIF | |
39586 | IDHKT(8+IIGLU1+IIGLU2) =IP2 | |
39587 | ISTHKT(8+IIGLU1+IIGLU2) =922 | |
39588 | JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T | |
39589 | JMOHKT(2,8+IIGLU1+IIGLU2)=0 | |
39590 | JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2 | |
39591 | JDAHKT(2,8+IIGLU1+IIGLU2)=0 | |
39592 | **NEW | |
39593 | IF ((XVQT.LT.0.0D0).OR.(XSAQ1 .LT.0.0D0)) | |
39594 | & WRITE(LOUT,*) ' mgsqbs4: ',XVQT,XSAQ1 | |
39595 | ** | |
39596 | PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT) | |
39597 | PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT) | |
39598 | PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT) | |
39599 | PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT) | |
39600 | C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T) | |
39601 | XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2- | |
39602 | * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2- | |
39603 | *PHKT(1,8+IIGLU1+IIGLU2)**2) | |
39604 | IF(XMIST.GT.0.D0)THEN | |
39605 | PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2- | |
39606 | * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2- | |
39607 | *PHKT(1,8+IIGLU1+IIGLU2)**2) | |
39608 | ELSE | |
39609 | C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST | |
39610 | PHKT(5,8+IIGLU1+IIGLU2)=0.D0 | |
39611 | ENDIF | |
39612 | VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T) | |
39613 | VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T) | |
39614 | VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T) | |
39615 | VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T) | |
39616 | WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T) | |
39617 | WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T) | |
39618 | WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T) | |
39619 | WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T) | |
39620 | IDHKT(9+IIGLU1+IIGLU2) =88888 | |
39621 | C IDHKT(9) =1000*NNNC2+MMMC2+10 | |
39622 | ISTHKT(9+IIGLU1+IIGLU2) =93 | |
39623 | C ISTHKT(9) =KKKC2 | |
39624 | JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1 | |
39625 | JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2 | |
39626 | JDAHKT(1,9+IIGLU1+IIGLU2)=0 | |
39627 | JDAHKT(2,9+IIGLU1+IIGLU2)=0 | |
39628 | PHKT(1,9+IIGLU1+IIGLU2) =PHKT(1,7+IIGLU1) | |
39629 | * +PHKT(1,8+IIGLU1+IIGLU2)+PG1 | |
39630 | PHKT(2,9+IIGLU1+IIGLU2) =PHKT(2,7+IIGLU1) | |
39631 | * +PHKT(2,8+IIGLU1+IIGLU2)+PG2 | |
39632 | PHKT(3,9+IIGLU1+IIGLU2) =PHKT(3,7+IIGLU1) | |
39633 | * +PHKT(3,8+IIGLU1+IIGLU2)+PG3 | |
39634 | PHKT(4,9+IIGLU1+IIGLU2) =PHKT(4,7+IIGLU1) | |
39635 | * +PHKT(4,8+IIGLU1+IIGLU2)+PG4 | |
39636 | PHKT(5,9+IIGLU1+IIGLU2) | |
39637 | * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2- | |
39638 | * PHKT(2,9+IIGLU1+IIGLU2)**2 | |
39639 | * -PHKT(3,9+IIGLU1+IIGLU2)**2) | |
39640 | IF(IPIP.GE.3)THEN | |
39641 | WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1), | |
39642 | * JMOHKT(1,7+IIGLU1), | |
39643 | * JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1), | |
39644 | *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5) | |
39645 | DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2 | |
39646 | WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG), | |
39647 | & JMOHKT(1,IIG),JMOHKT(2,IIG), | |
39648 | * JDAHKT(1,IIG), | |
39649 | *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5) | |
39650 | 91 CONTINUE | |
39651 | WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2), | |
39652 | * IDHKT(8+IIGLU1+IIGLU2), | |
39653 | * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2), | |
39654 | * JDAHKT(1,8+IIGLU1+IIGLU2), | |
39655 | *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5) | |
39656 | WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2), | |
39657 | * IDHKT(9+IIGLU1+IIGLU2), | |
39658 | * JMOHKT(1,9+IIGLU1+IIGLU2),JMOHKT(2,9+IIGLU1+IIGLU2), | |
39659 | * JDAHKT(1,9+IIGLU1+IIGLU2), | |
39660 | *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5) | |
39661 | ENDIF | |
39662 | CHAMAL=CHAB1 | |
39663 | IF(IPIP.EQ.1)THEN | |
39664 | IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3 | |
39665 | ELSEIF(IPIP.EQ.2)THEN | |
39666 | IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3 | |
39667 | ENDIF | |
39668 | IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN | |
39669 | C IREJ=1 | |
39670 | IPCO=0 | |
39671 | C RETURN | |
39672 | C WRITE(6,*)' MGSQBS1 jump back from chain 9', | |
39673 | C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2) | |
39674 | GO TO 3466 | |
39675 | ENDIF | |
39676 | VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1) | |
39677 | VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1) | |
39678 | VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1) | |
39679 | VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1) | |
39680 | WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1) | |
39681 | WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1) | |
39682 | WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1) | |
39683 | WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1) | |
39684 | C | |
39685 | IGCOUN=9+IIGLU1+IIGLU2 | |
39686 | IPCO=0 | |
39687 | RETURN | |
39688 | END | |
39689 | ||
39690 | *$ CREATE HKKHKT.FOR | |
39691 | *COPY HKKHKT | |
39692 | C | |
39693 | C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ | |
39694 | C | |
39695 | SUBROUTINE HKKHKT(I,J) | |
39696 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
39697 | SAVE | |
39698 | ||
39699 | * event history | |
39700 | PARAMETER (NMXHKK=200000) | |
39701 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
39702 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
39703 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
39704 | * extended event history | |
39705 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
39706 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
39707 | & IHIST(2,NMXHKK) | |
39708 | ||
39709 | PARAMETER (NTMHKK= 300) | |
39710 | COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT | |
39711 | +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT | |
39712 | +(4,NTMHKK) | |
39713 | C | |
39714 | ISTHKK(I) =ISTHKT(J) | |
39715 | IDHKK(I) =IDHKT(J) | |
39716 | C IF(J.EQ.3.OR.J.EQ.6.OR.J.EQ.9)THEN | |
39717 | IF(IDHKK(I).EQ.88888)THEN | |
39718 | C JMOHKK(1,I)=I-2 | |
39719 | C JMOHKK(2,I)=I-1 | |
39720 | JMOHKK(1,I)=I-(J-JMOHKT(1,J)) | |
39721 | JMOHKK(2,I)=I-(J-JMOHKT(2,J)) | |
39722 | ELSE | |
39723 | JMOHKK(1,I)=JMOHKT(1,J) | |
39724 | JMOHKK(2,I)=JMOHKT(2,J) | |
39725 | ENDIF | |
39726 | JDAHKK(1,I)=JDAHKT(1,J) | |
39727 | JDAHKK(2,I)=JDAHKT(2,J) | |
39728 | C IF(J.EQ.1.OR.J.EQ.4.OR.J.EQ.7)THEN | |
39729 | C JDAHKK(1,I)=I+2 | |
39730 | C ELSEIF(J.EQ.2.OR.J.EQ.5.OR.J.EQ.8)THEN | |
39731 | C JDAHKK(1,I)=I+1 | |
39732 | C ENDIF | |
39733 | IF(JDAHKT(1,J).GT.0)THEN | |
39734 | JDAHKK(1,I)=I+(JDAHKT(1,J)-J) | |
39735 | ENDIF | |
39736 | PHKK(1,I) =PHKT(1,J) | |
39737 | PHKK(2,I) =PHKT(2,J) | |
39738 | PHKK(3,I) =PHKT(3,J) | |
39739 | PHKK(4,I) =PHKT(4,J) | |
39740 | PHKK(5,I) =PHKT(5,J) | |
39741 | VHKK(1,I) =VHKT(1,J) | |
39742 | VHKK(2,I) =VHKT(2,J) | |
39743 | VHKK(3,I) =VHKT(3,J) | |
39744 | VHKK(4,I) =VHKT(4,J) | |
39745 | WHKK(1,I) =WHKT(1,J) | |
39746 | WHKK(2,I) =WHKT(2,J) | |
39747 | WHKK(3,I) =WHKT(3,J) | |
39748 | WHKK(4,I) =WHKT(4,J) | |
39749 | RETURN | |
39750 | END | |
39751 | ||
39752 | *$ CREATE DT_DBREAK.FOR | |
39753 | *COPY DT_DBREAK | |
39754 | * | |
39755 | *===dbreak=============================================================* | |
39756 | * | |
39757 | SUBROUTINE DT_DBREAK(MODE) | |
39758 | ||
39759 | ************************************************************************ | |
39760 | * This is the steering subroutine for the different diquark breaking * | |
39761 | * mechanisms. * | |
39762 | * * | |
39763 | * MODE = 1 breaking of projectile diquark in qq-q chain using * | |
39764 | * a sea quark (q-qq chain) of the same projectile * | |
39765 | * = 2 breaking of target diquark in q-qq chain using * | |
39766 | * a sea quark (qq-q chain) of the same target * | |
39767 | * = 3 breaking of projectile diquark in qq-q chain using * | |
39768 | * a sea quark (q-aq chain) of the same projectile * | |
39769 | * = 4 breaking of target diquark in q-qq chain using * | |
39770 | * a sea quark (aq-q chain) of the same target * | |
39771 | * = 5 breaking of projectile anti-diquark in aqaq-aq chain using * | |
39772 | * a sea anti-quark (aq-aqaq chain) of the same projectile * | |
39773 | * = 6 breaking of target anti-diquark in aq-aqaq chain using * | |
39774 | * a sea anti-quark (aqaq-aq chain) of the same target * | |
39775 | * = 7 breaking of projectile anti-diquark in aqaq-aq chain using * | |
39776 | * a sea anti-quark (aq-q chain) of the same projectile * | |
39777 | * = 8 breaking of target anti-diquark in aq-aqaq chain using * | |
39778 | * a sea anti-quark (q-aq chain) of the same target * | |
39779 | * * | |
39780 | * Original version by J. Ranft. * | |
39781 | * This version dated 17.5.00 is written by S. Roesler. * | |
39782 | ************************************************************************ | |
39783 | ||
39784 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
39785 | SAVE | |
39786 | PARAMETER ( LINP = 10 , | |
39787 | & LOUT = 6 , | |
39788 | & LDAT = 9 ) | |
39789 | ||
39790 | * event history | |
39791 | PARAMETER (NMXHKK=200000) | |
39792 | COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), | |
39793 | & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), | |
39794 | & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) | |
39795 | * extended event history | |
39796 | COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), | |
39797 | & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), | |
39798 | & IHIST(2,NMXHKK) | |
39799 | * flags for input different options | |
39800 | LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO | |
39801 | COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), | |
39802 | & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT | |
39803 | * pointer to chains in hkkevt common (used by qq-breaking mechanisms) | |
39804 | PARAMETER (MAXCHN=10000) | |
39805 | COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN | |
39806 | * diquark-breaking mechanism | |
39807 | COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3 | |
39808 | * flags for particle decays | |
39809 | COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20), | |
39810 | & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20), | |
39811 | & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0 | |
39812 | ||
39813 | * | |
39814 | * chain identifiers | |
39815 | * ( 1 = q-aq, 2 = aq-q, 3 = q-qq, 4 = qq-q, | |
39816 | * 5 = aq-adq, 6 = adq-aq, 7 = dq-adq, 8 = adq-dq ) | |
39817 | DIMENSION IDCHN1(8),IDCHN2(8) | |
39818 | DATA IDCHN1 / 4, 3, 4, 3, 6, 5, 6, 5/ | |
39819 | DATA IDCHN2 / 3, 4, 1, 2, 5, 6, 2, 1/ | |
39820 | * | |
39821 | * parton identifiers | |
39822 | * ( +-21/22 = valence, +-31/32 = Glauber-sea, +-41/42 = Pomeron (diff), | |
39823 | * +-51/52 = unitarity-sea, +-61/62 = gluons ) | |
39824 | DIMENSION ISP1P(8,3),ISP1T(8,3),ISP2P(8,3),ISP2T(8,3) | |
39825 | DATA ISP1P / 21, 21, 21, 21, 21, 21, 21, 21, | |
39826 | & 31, 31, 31, 31, 31, 31, 31, 31, | |
39827 | & 41, 41, 41, 41, 51, 51, 51, 51/ | |
39828 | DATA ISP1T / 22, 22, 22, 22, 22, 22, 22, 22, | |
39829 | & 32, 32, 32, 32, 32, 32, 32, 32, | |
39830 | & 42, 42, 42, 42, 52, 52, 52, 52/ | |
39831 | DATA ISP2P / 31, 21, 31, 31, 21, 21, 21, 21, | |
39832 | & 51, 31, 41, 41, 31, 31, 31, 31, | |
39833 | & 0, 41, 51, 51, 51, 51, 51, 51/ | |
39834 | DATA ISP2T / 22, 32, 32, 32, 22, 22, 22, 22, | |
39835 | & 32, 52, 42, 42, 32, 32, 32, 32, | |
39836 | & 42, 0, 52, 52, 52, 52, 52, 52/ | |
39837 | ||
39838 | IF (NCHAIN.LE.0) RETURN | |
39839 | DO 1 I=1,NCHAIN | |
39840 | IDX1 = IDXCHN(1,I) | |
39841 | IS1P = ABS(ISTHKK(JMOHKK(1,IDX1))) | |
39842 | IS1T = ABS(ISTHKK(JMOHKK(2,IDX1))) | |
39843 | IF ( (IDXCHN(2,I).EQ.IDCHN1(MODE)) | |
39844 | & .AND. | |
39845 | & ((IS1P.EQ.ISP1P(MODE,1)).OR.(IS1P.EQ.ISP1P(MODE,2)).OR. | |
39846 | & (IS1P.EQ.ISP1P(MODE,3))) | |
39847 | & .AND. | |
39848 | & ((IS1T.EQ.ISP1T(MODE,1)).OR.(IS1T.EQ.ISP1T(MODE,2)).OR. | |
39849 | & (IS1T.EQ.ISP1T(MODE,3))) | |
39850 | & ) THEN | |
39851 | DO 2 J=1,NCHAIN | |
39852 | IDX2 = IDXCHN(1,J) | |
39853 | IS2P = ABS(ISTHKK(JMOHKK(1,IDX2))) | |
39854 | IS2T = ABS(ISTHKK(JMOHKK(2,IDX2))) | |
39855 | IF ( (IDXCHN(2,J).EQ.IDCHN2(MODE)) | |
39856 | & .AND. | |
39857 | & ((IS2P.EQ.ISP2P(MODE,1)).OR.(IS2P.EQ.ISP2P(MODE,2)) | |
39858 | & .OR.(IS2P.EQ.ISP2P(MODE,3))) | |
39859 | & .AND. | |
39860 | & ((IS2T.EQ.ISP2T(MODE,1)).OR.(IS2T.EQ.ISP2T(MODE,2)) | |
39861 | & .OR.(IS2T.EQ.ISP2T(MODE,3))) | |
39862 | & ) THEN | |
39863 | * find mother nucleons of the diquark to be splitted and of the | |
39864 | * sea-quark and reject this combination if it is not the same | |
39865 | IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR. | |
39866 | & (MODE.EQ.5).OR.(MODE.EQ.7)) THEN | |
39867 | IANCES = 1 | |
39868 | ELSE | |
39869 | IANCES = 2 | |
39870 | ENDIF | |
39871 | IDXMO1 = JMOHKK(IANCES,IDX1) | |
39872 | 4 CONTINUE | |
39873 | IF ((JMOHKK(1,IDXMO1).NE.0).AND. | |
39874 | & (JMOHKK(2,IDXMO1).NE.0)) THEN | |
39875 | IANC = IANCES | |
39876 | ELSE | |
39877 | IANC = 1 | |
39878 | ENDIF | |
39879 | IF (JMOHKK(IANC,IDXMO1).NE.0) THEN | |
39880 | IDXMO1 = JMOHKK(IANC,IDXMO1) | |
39881 | GOTO 4 | |
39882 | ENDIF | |
39883 | IDXMO2 = JMOHKK(IANCES,IDX2) | |
39884 | 5 CONTINUE | |
39885 | IF ((JMOHKK(1,IDXMO2).NE.0).AND. | |
39886 | & (JMOHKK(2,IDXMO2).NE.0)) THEN | |
39887 | IANC = IANCES | |
39888 | ELSE | |
39889 | IANC = 1 | |
39890 | ENDIF | |
39891 | IF (JMOHKK(IANC,IDXMO2).NE.0) THEN | |
39892 | IDXMO2 = JMOHKK(IANC,IDXMO2) | |
39893 | GOTO 5 | |
39894 | ENDIF | |
39895 | IF (IDXMO1.NE.IDXMO2) GOTO 2 | |
39896 | * quark content of projectile parton | |
39897 | IP1 = IDHKK(JMOHKK(1,IDX1)) | |
39898 | IP11 = IP1/1000 | |
39899 | IP12 = (IP1-1000*IP11)/100 | |
39900 | IP2 = IDHKK(JMOHKK(2,IDX1)) | |
39901 | IP21 = IP2/1000 | |
39902 | IP22 = (IP2-1000*IP21)/100 | |
39903 | * quark content of target parton | |
39904 | IT1 = IDHKK(JMOHKK(1,IDX2)) | |
39905 | IT11 = IT1/1000 | |
39906 | IT12 = (IT1-1000*IT11)/100 | |
39907 | IT2 = IDHKK(JMOHKK(2,IDX2)) | |
39908 | IT21 = IT2/1000 | |
39909 | IT22 = (IT2-1000*IT21)/100 | |
39910 | * split diquark and form new chains | |
39911 | IF (MODE.EQ.1) THEN | |
39912 | IF (IT1.EQ.4) GOTO 2 | |
39913 | CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), | |
39914 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, | |
39915 | & IP11,IP12,IP2,IT1,IT21,IT22,1,IPQ,IGCOUN) | |
39916 | ELSEIF (MODE.EQ.2) THEN | |
39917 | IF (IT2.EQ.4) GOTO 2 | |
39918 | CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), | |
39919 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, | |
39920 | & IP1,IP21,IP22,IT11,IT12,IT2,1,IPQ,IGCOUN) | |
39921 | ELSEIF (MODE.EQ.3) THEN | |
39922 | IF (IT1.EQ.4) GOTO 2 | |
39923 | CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), | |
39924 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, | |
39925 | & IP11,IP12,IP2,IT1,IT2,1,IPQ,IGCOUN) | |
39926 | ELSEIF (MODE.EQ.4) THEN | |
39927 | IF (IT2.EQ.4) GOTO 2 | |
39928 | CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), | |
39929 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, | |
39930 | & IP1,IP21,IP22,IT1,IT2,1,IPQ,IGCOUN) | |
39931 | ELSEIF (MODE.EQ.5) THEN | |
39932 | CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), | |
39933 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, | |
39934 | & IP11,IP12,IP2,IT1,IT21,IT22,2,IPQ,IGCOUN) | |
39935 | ELSEIF (MODE.EQ.6) THEN | |
39936 | CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), | |
39937 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, | |
39938 | & IP1,IP21,IP22,IT11,IT12,IT2,2,IPQ,IGCOUN) | |
39939 | ELSEIF (MODE.EQ.7) THEN | |
39940 | CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), | |
39941 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, | |
39942 | & IP11,IP12,IP2,IT1,IT2,2,IPQ,IGCOUN) | |
39943 | ELSEIF (MODE.EQ.8) THEN | |
39944 | CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1), | |
39945 | & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ, | |
39946 | & IP1,IP21,IP22,IT1,IT2,2,IPQ,IGCOUN) | |
39947 | ENDIF | |
39948 | IF (IREJ.GE.1) THEN | |
39949 | if ((ipq.lt.0).or.(ipq.ge.4)) | |
39950 | & write(LOUT,*) 'ipq !!!',ipq,mode | |
39951 | DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0 | |
39952 | * accept or reject new chains corresponding to PDBSEA | |
39953 | ELSE | |
39954 | IF ((IPQ.EQ.1).OR.(IPQ.EQ.2)) THEN | |
39955 | ACC = DBRKA(1,MODE)+DBRKA(2,MODE) | |
39956 | REJ = DBRKR(1,MODE)+DBRKR(2,MODE) | |
39957 | ELSEIF (IPQ.EQ.3) THEN | |
39958 | ACC = DBRKA(3,MODE) | |
39959 | REJ = DBRKR(3,MODE) | |
39960 | ELSE | |
39961 | WRITE(LOUT,*) ' inconsistent IPQ ! ',IPQ | |
39962 | STOP | |
39963 | ENDIF | |
39964 | IF (ACC/(ACC+REJ).LE.PDBSEA(IPQ)) THEN | |
39965 | DBRKA(IPQ,MODE) = DBRKA(IPQ,MODE)+1.0D0 | |
39966 | IACC = 1 | |
39967 | ELSE | |
39968 | DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0 | |
39969 | IACC = 0 | |
39970 | ENDIF | |
39971 | * new chains have been accepted and are now copied into HKKEVT | |
39972 | IF (IACC.EQ.1) THEN | |
39973 | IF (LEMCCK) THEN | |
39974 | CALL DT_EVTEMC(PHKK(1,IDX1),PHKK(2,IDX1), | |
39975 | & PHKK(3,IDX1),PHKK(4,IDX1), | |
39976 | & 1,IDUM1,IDUM2) | |
39977 | CALL DT_EVTEMC(PHKK(1,IDX2),PHKK(2,IDX2), | |
39978 | & PHKK(3,IDX2),PHKK(4,IDX2), | |
39979 | & 2,IDUM1,IDUM2) | |
39980 | ENDIF | |
39981 | IDHKK(IDX1) = 99888 | |
39982 | IDHKK(IDX2) = 99888 | |
39983 | IDXCHN(2,I) = -1 | |
39984 | IDXCHN(2,J) = -1 | |
39985 | DO 3 K=1,IGCOUN | |
39986 | NHKK = NHKK+1 | |
39987 | CALL HKKHKT(NHKK,K) | |
39988 | IF ((LEMCCK).AND.(IDHKK(NHKK).EQ.88888))THEN | |
39989 | PX = -PHKK(1,NHKK) | |
39990 | PY = -PHKK(2,NHKK) | |
39991 | PZ = -PHKK(3,NHKK) | |
39992 | PE = -PHKK(4,NHKK) | |
39993 | CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2) | |
39994 | ENDIF | |
39995 | 3 CONTINUE | |
39996 | IF (LEMCCK) THEN | |
39997 | CHKLEV = 0.1D0 | |
39998 | CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,9000, | |
39999 | & IREJ) | |
40000 | IF (IREJ.NE.0) CALL DT_EVTOUT(4) | |
40001 | ENDIF | |
40002 | GOTO 1 | |
40003 | ENDIF | |
40004 | ENDIF | |
40005 | ENDIF | |
40006 | 2 CONTINUE | |
40007 | ENDIF | |
40008 | 1 CONTINUE | |
40009 | RETURN | |
40010 | END | |
40011 | ||
40012 | *$ CREATE DT_CQPAIR.FOR | |
40013 | *COPY DT_CQPAIR | |
40014 | * | |
40015 | *===cqpair=============================================================* | |
40016 | * | |
40017 | SUBROUTINE DT_CQPAIR(XQMAX,XAQMAX,XQ,XAQ,IFLV,IREJ) | |
40018 | ||
40019 | ************************************************************************ | |
40020 | * This subroutine Creates a Quark-antiquark PAIR from the sea. * | |
40021 | * * | |
40022 | * XQMAX maxium energy fraction of quark (input) * | |
40023 | * XAQMAX maxium energy fraction of antiquark (input) * | |
40024 | * XQ energy fraction of quark (output) * | |
40025 | * XAQ energy fraction of antiquark (output) * | |
40026 | * IFLV quark flavour (- antiquark flavor) (output) * | |
40027 | * * | |
40028 | * This version dated 14.5.00 is written by S. Roesler. * | |
40029 | ************************************************************************ | |
40030 | ||
40031 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) | |
40032 | SAVE | |
40033 | PARAMETER ( LINP = 10 , | |
40034 | & LOUT = 6 , | |
40035 | & LDAT = 9 ) | |
40036 | ||
40037 | * Lorentz-parameters of the current interaction | |
40038 | COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, | |
40039 | & UMO,PPCM,EPROJ,PPROJ | |
40040 | ||
40041 | * | |
40042 | IREJ = 0 | |
40043 | XQ = 0.0D0 | |
40044 | XAQ = 0.0D0 | |
40045 | * | |
40046 | * sample quark flavour | |
40047 | * | |
40048 | * set seasq here (the one from DTCHAI should be used in the future) | |
40049 | SEASQ = 0.5D0 | |
40050 | IFLV = INT(1.0D0+DT_RNDM(XQMAX)*(2.0D0+SEASQ)) | |
40051 | * | |
40052 | * sample energy fractions of sea pair | |
40053 | * we first sample the energy fraction of a gluon and then split the gluon | |
40054 | * | |
40055 | * maximum energy fraction of the gluon forced via input | |
40056 | XGMAXI = XQMAX+XAQMAX | |
40057 | * minimum energy fraction of the gluon | |
40058 | XTHR1 = 4.0D0 /UMO**2 | |
40059 | XTHR2 = 0.54D0/UMO**1.5D0 | |
40060 | XGMIN = MAX(XTHR1,XTHR2) | |
40061 | * maximum energy fraction of the gluon | |
40062 | XGMAX = 0.3D0 | |
40063 | XGMAX = MIN(XGMAXI,XGMAX) | |
40064 | IF (XGMIN.GE.XGMAX) THEN | |
40065 | IREJ = 1 | |
40066 | RETURN | |
40067 | ENDIF | |
40068 | * | |
40069 | * sample energy fraction of the gluon | |
40070 | NLOOP = 0 | |
40071 | 1 CONTINUE | |
40072 | NLOOP = NLOOP+1 | |
40073 | IF (NLOOP.GE.50) THEN | |
40074 | IREJ = 1 | |
40075 | RETURN | |
40076 | ENDIF | |
40077 | XGLUON = DT_SAMSQX(XGMIN,XGMAX) | |
40078 | EGLUON = XGLUON*UMO/2.0D0 | |
40079 | * | |
40080 | * split gluon into q-aq pair (we follow PHOJET's subroutine PHO_GLU2QU) | |
40081 | ZMIN = MIN(0.1D0,0.5D0/EGLUON) | |
40082 | ZMAX = 1.0D0-ZMIN | |
40083 | RZ = DT_RNDM(ZMAX) | |
40084 | XHLP = ((1.0D0-RZ)*ZMIN**3+RZ*ZMAX**3)**0.33333 | |
40085 | RQ = DT_RNDM(ZMAX) | |
40086 | IF (RQ.LT.0.5D0) THEN | |
40087 | XQ = XGLUON*XHLP | |
40088 | XAQ = XGLUON-XQ | |
40089 | ELSE | |
40090 | XAQ = XGLUON*XHLP | |
40091 | XQ = XGLUON-XAQ | |
40092 | ENDIF | |
40093 | IF ((XQ.GT.XQMAX).OR.(XAQ.GT.XAQMAX)) GOTO 1 | |
40094 | ||
40095 | RETURN | |
40096 | END |